From mboxrd@z Thu Jan 1 00:00:00 1970 Path: main.gmane.org!not-for-mail From: Kevin Ryde Newsgroups: gmane.lisp.guile.devel Subject: floor, ceiling, etc on exacts [1.6] Date: Sat, 24 Apr 2004 07:11:13 +1000 Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Message-ID: <87r7ue8kni.fsf@zip.com.au> NNTP-Posting-Host: deer.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: sea.gmane.org 1082755099 19821 80.91.224.253 (23 Apr 2004 21:18:19 GMT) X-Complaints-To: usenet@sea.gmane.org NNTP-Posting-Date: Fri, 23 Apr 2004 21:18:19 +0000 (UTC) Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Fri Apr 23 23:18:06 2004 Return-path: Original-Received: from monty-python.gnu.org ([199.232.76.173]) by deer.gmane.org with esmtp (Exim 3.35 #1 (Debian)) id 1BH83i-0007qc-00 for ; Fri, 23 Apr 2004 23:18:06 +0200 Original-Received: from localhost ([127.0.0.1] helo=monty-python.gnu.org) by monty-python.gnu.org with esmtp (Exim 4.30) id 1BH83U-0001DW-Rm for guile-devel@m.gmane.org; Fri, 23 Apr 2004 17:17:52 -0400 Original-Received: from list by monty-python.gnu.org with tmda-scanned (Exim 4.30) id 1BH82w-000186-F6 for guile-devel@gnu.org; Fri, 23 Apr 2004 17:17:18 -0400 Original-Received: from mail by monty-python.gnu.org with spam-scanned (Exim 4.30) id 1BH817-0000Cu-FU for guile-devel@gnu.org; Fri, 23 Apr 2004 17:15:58 -0400 Original-Received: from [61.8.0.85] (helo=mailout2.pacific.net.au) by monty-python.gnu.org with esmtp (Exim 4.30) id 1BH7zw-00075x-12 for guile-devel@gnu.org; Fri, 23 Apr 2004 17:14:12 -0400 Original-Received: from mailproxy1.pacific.net.au (mailproxy1.pacific.net.au [61.8.0.86]) by mailout2.pacific.net.au (8.12.3/8.12.3/Debian-6.6) with ESMTP id i3NLD35v029367 for ; Sat, 24 Apr 2004 07:13:03 +1000 Original-Received: from localhost (ppp256E.dyn.pacific.net.au [61.8.37.110]) by mailproxy1.pacific.net.au (8.12.3/8.12.3/Debian-6.6) with ESMTP id i3NLD1I1001482 for ; Sat, 24 Apr 2004 07:13:01 +1000 Original-Received: from gg by localhost with local (Exim 3.36 #1 (Debian)) id 1BH7x9-0002eN-00; Sat, 24 Apr 2004 07:11:19 +1000 Original-To: guile-devel@gnu.org Mail-Copies-To: never User-Agent: Gnus/5.110002 (No Gnus v0.2) Emacs/21.3 (gnu/linux) X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.4 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: main.gmane.org gmane.lisp.guile.devel:3634 X-Report-Spam: http://spam.gmane.org/gmane.lisp.guile.devel:3634 --=-=-= * numbers.c (scm_floor, scm_ceiling, scm_truncate_number, scm_round_number): New functions, replacing scm_tc7_cxr definitions, and ensuring exact arguments give exact results, as required by R5RS. Derived in part from the same by Marius in the cvs head. Reported by Ray Lehtiniemi. * tests/numbers.test (truncate, round, floor, ceiling): Add tests, in particular exercising exactness fixes and scm_round 2^53-1 fix. These bits and pieces of tests will be for the cvs head too, though the 2^53-1 part is still broken there at the moment (scm_round_number is afflicted by the same problem as scm_round was). --=-=-= Content-Disposition: attachment; filename=numbers.c.floor-exact.diff --- numbers.c.~1.135.2.15.~ 2004-04-22 10:27:57.000000000 +1000 +++ numbers.c 2004-04-23 18:20:43.000000000 +1000 @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004 Free Software Foundation, Inc. * * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories * and Bellcore. See scm_divide. @@ -3892,9 +3892,20 @@ -SCM_GPROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate, g_truncate); -/* "Round the inexact number @var{x} towards zero." - */ +SCM_PRIMITIVE_GENERIC (scm_truncate_number, "truncate", 1, 0, 0, + (SCM x), + "Round the inexact number @var{x} towards zero.") +#define FUNC_NAME s_scm_truncate_number +{ + if (SCM_INUMP (x) || SCM_BIGP (x)) + return x; + else if (SCM_REALP (x)) + return scm_make_real (scm_truncate (SCM_REAL_VALUE (x))); + else + SCM_WTA_DISPATCH_1 (g_scm_truncate_number, x, 1, s_scm_truncate_number); +} +#undef FUNC_NAME + double scm_truncate (double x) { @@ -3930,10 +3941,6 @@ already. And if it's not then the exponent must be small enough to allow an 0.5 to be represented, and hence added without a bad rounding. */ -SCM_GPROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round, g_round); -/* "Round the inexact number @var{x}. If @var{x} is halfway between two\n" - * "numbers, round towards even." - */ double scm_round (double x) { @@ -3949,6 +3956,23 @@ ? result - 1 : result; } +SCM_PRIMITIVE_GENERIC (scm_round_number, "round", 1, 0, 0, + (SCM x), + "Round the number @var{x} towards the nearest integer. " + "When it is exactly halfway between two integers, " + "round towards the even one.") +#define FUNC_NAME s_scm_round_number +{ + if (SCM_INUMP (x) || SCM_BIGP (x)) + return x; + else if (SCM_REALP (x)) + return scm_make_real (scm_round (SCM_REAL_VALUE (x))); + else + SCM_WTA_DISPATCH_1 (g_scm_round_number, x, 1, s_scm_round_number); +} +#undef FUNC_NAME + + SCM_GPROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact, g_exact_to_inexact); @@ -3961,12 +3985,35 @@ } -SCM_GPROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor, g_i_floor); -/* "Round the number @var{x} towards minus infinity." - */ -SCM_GPROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil, g_i_ceil); -/* "Round the number @var{x} towards infinity." - */ +SCM_PRIMITIVE_GENERIC (scm_floor, "floor", 1, 0, 0, + (SCM x), + "Round the number @var{x} towards minus infinity.") +#define FUNC_NAME s_scm_floor +{ + if (SCM_INUMP (x) || SCM_BIGP (x)) + return x; + else if (SCM_REALP (x)) + return scm_make_real (floor (SCM_REAL_VALUE (x))); + else + SCM_WTA_DISPATCH_1 (g_scm_floor, x, 1, s_scm_floor); +} +#undef FUNC_NAME + +SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0, + (SCM x), + "Round the number @var{x} towards infinity.") +#define FUNC_NAME s_scm_ceiling +{ + if (SCM_INUMP (x) || SCM_BIGP (x)) + return x; + else if (SCM_REALP (x)) + return scm_make_real (ceil (SCM_REAL_VALUE (x))); + else + SCM_WTA_DISPATCH_1 (g_scm_ceiling, x, 1, s_scm_ceiling); +} +#undef FUNC_NAME + + SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)()) sqrt, g_i_sqrt); /* "Return the square root of the real number @var{x}." */ --=-=-= Content-Disposition: attachment; filename=numbers.test.floor-exact.diff --- numbers.test.~1.5.4.3.~ 2002-05-17 02:48:02.000000000 +1000 +++ numbers.test 2004-04-23 18:22:58.000000000 +1000 @@ -1,5 +1,5 @@ ;;;; numbers.test --- tests guile's numbers -*- scheme -*- -;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2004 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -1274,10 +1274,147 @@ ;;; truncate ;;; +(with-test-prefix "truncate" + (with-test-prefix "inum" + (pass-if "0" + (and (= 0 (truncate 0)) + (exact? (truncate 0)))) + + (pass-if "1" + (and (= 1 (truncate 1)) + (exact? (truncate 1)))) + + (pass-if "-1" + (and (= -1 (truncate -1)) + (exact? (truncate -1))))) + + (with-test-prefix "bignum" + (let ((x (1+ most-positive-fixnum))) + (pass-if "(1+ most-positive-fixnum)" + (and (= x (truncate x)) + (exact? (truncate x))))) + + (let ((x (1- most-negative-fixnum))) + (pass-if "(1- most-negative-fixnum)" + (and (= x (truncate x)) + (exact? (truncate x)))))) + + (with-test-prefix "real" + (pass-if "0.0" + (and (= 0.0 (truncate 0.0)) + (inexact? (truncate 0.0)))) + + (pass-if "1.0" + (and (= 1.0 (truncate 1.0)) + (inexact? (truncate 1.0)))) + + (pass-if "-1.0" + (and (= -1.0 (truncate -1.0)) + (inexact? (truncate -1.0)))) + + (pass-if "3.9" + (and (= 3.0 (truncate 3.9)) + (inexact? (truncate 3.9)))) + + (pass-if "-3.9" + (and (= -3.0 (truncate -3.9)) + (inexact? (truncate -3.9)))))) + ;;; ;;; round ;;; +(with-test-prefix "round" + (with-test-prefix "inum" + (pass-if "0" + (and (= 0 (round 0)) + (exact? (round 0)))) + + (pass-if "1" + (and (= 1 (round 1)) + (exact? (round 1)))) + + (pass-if "-1" + (and (= -1 (round -1)) + (exact? (round -1))))) + + (with-test-prefix "bignum" + (let ((x (1+ most-positive-fixnum))) + (pass-if "(1+ most-positive-fixnum)" + (and (= x (round x)) + (exact? (round x))))) + + (let ((x (1- most-negative-fixnum))) + (pass-if "(1- most-negative-fixnum)" + (and (= x (round x)) + (exact? (round x)))))) + + (with-test-prefix "real" + (pass-if "0.0" + (and (= 0.0 (round 0.0)) + (inexact? (round 0.0)))) + + (pass-if "1.0" + (and (= 1.0 (round 1.0)) + (inexact? (round 1.0)))) + + (pass-if "-1.0" + (and (= -1.0 (round -1.0)) + (inexact? (round -1.0)))) + + (pass-if "-3.1" + (and (= -3.0 (round -3.1)) + (inexact? (round -3.1)))) + + (pass-if "3.1" + (and (= 3.0 (round 3.1)) + (inexact? (round 3.1)))) + + (pass-if "3.9" + (and (= 4.0 (round 3.9)) + (inexact? (round 3.9)))) + + (pass-if "-3.9" + (and (= -4.0 (round -3.9)) + (inexact? (round -3.9)))) + + (pass-if "1.5" + (and (= 2.0 (round 1.5)) + (inexact? (round 1.5)))) + + (pass-if "2.5" + (and (= 2.0 (round 2.5)) + (inexact? (round 2.5)))) + + (pass-if "3.5" + (and (= 4.0 (round 3.5)) + (inexact? (round 3.5)))) + + (pass-if "-1.5" + (and (= -2.0 (round -1.5)) + (inexact? (round -1.5)))) + + (pass-if "-2.5" + (and (= -2.0 (round -2.5)) + (inexact? (round -2.5)))) + + (pass-if "-3.5" + (and (= -4.0 (round -3.5)) + (inexact? (round -3.5)))) + + ;; prior to guile 1.6.5, on an IEEE system an inexact 2^53-1 (ie. a + ;; float with mantissa all ones) came out as 2^53 from `round' (except + ;; on i386 and m68k systems using the coprocessor and optimizing, where + ;; extra precision hid the problem) + (pass-if "2^53-1" + (let ((x (exact->inexact (1- (ash 1 53))))) + (and (= x (round x)) + (inexact? (round x))))) + (pass-if "-(2^53-1)" + (let ((x (exact->inexact (- (1- (ash 1 53)))))) + (and (= x (round x)) + (inexact? (round x))))))) + ;;; ;;; exact->inexact ;;; @@ -1286,10 +1423,102 @@ ;;; floor ;;; +(with-test-prefix "floor" + (with-test-prefix "inum" + (pass-if "0" + (and (= 0 (floor 0)) + (exact? (floor 0)))) + + (pass-if "1" + (and (= 1 (floor 1)) + (exact? (floor 1)))) + + (pass-if "-1" + (and (= -1 (floor -1)) + (exact? (floor -1))))) + + (with-test-prefix "bignum" + (let ((x (1+ most-positive-fixnum))) + (pass-if "(1+ most-positive-fixnum)" + (and (= x (floor x)) + (exact? (floor x))))) + + (let ((x (1- most-negative-fixnum))) + (pass-if "(1- most-negative-fixnum)" + (and (= x (floor x)) + (exact? (floor x)))))) + + (with-test-prefix "real" + (pass-if "0.0" + (and (= 0.0 (floor 0.0)) + (inexact? (floor 0.0)))) + + (pass-if "1.0" + (and (= 1.0 (floor 1.0)) + (inexact? (floor 1.0)))) + + (pass-if "-1.0" + (and (= -1.0 (floor -1.0)) + (inexact? (floor -1.0)))) + + (pass-if "3.9" + (and (= 3.0 (floor 3.9)) + (inexact? (floor 3.9)))) + + (pass-if "-3.9" + (and (= -4.0 (floor -3.9)) + (inexact? (floor -3.9)))))) + ;;; ;;; ceiling ;;; +(with-test-prefix "ceiling" + (with-test-prefix "inum" + (pass-if "0" + (and (= 0 (ceiling 0)) + (exact? (ceiling 0)))) + + (pass-if "1" + (and (= 1 (ceiling 1)) + (exact? (ceiling 1)))) + + (pass-if "-1" + (and (= -1 (ceiling -1)) + (exact? (ceiling -1))))) + + (with-test-prefix "bignum" + (let ((x (1+ most-positive-fixnum))) + (pass-if "(1+ most-positive-fixnum)" + (and (= x (ceiling x)) + (exact? (ceiling x))))) + + (let ((x (1- most-negative-fixnum))) + (pass-if "(1- most-negative-fixnum)" + (and (= x (ceiling x)) + (exact? (ceiling x)))))) + + (with-test-prefix "real" + (pass-if "0.0" + (and (= 0.0 (ceiling 0.0)) + (inexact? (ceiling 0.0)))) + + (pass-if "1.0" + (and (= 1.0 (ceiling 1.0)) + (inexact? (ceiling 1.0)))) + + (pass-if "-1.0" + (and (= -1.0 (ceiling -1.0)) + (inexact? (ceiling -1.0)))) + + (pass-if "3.9" + (and (= 4.0 (ceiling 3.9)) + (inexact? (ceiling 3.9)))) + + (pass-if "-3.9" + (and (= -3.0 (ceiling -3.9)) + (inexact? (ceiling -3.9)))))) + ;;; ;;; sqrt ;;; --=-=-= Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Disposition: inline _______________________________________________ Guile-devel mailing list Guile-devel@gnu.org http://mail.gnu.org/mailman/listinfo/guile-devel --=-=-=--