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: Re: real == frac Date: Wed, 10 Dec 2003 06:34:38 +1000 Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Message-ID: <87r7zdenmp.fsf@zip.com.au> References: <87u14xphf4.fsf@zip.com.au> <87vfp2abh2.fsf@zagadka.ping.de> NNTP-Posting-Host: deer.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: sea.gmane.org 1071002225 18387 80.91.224.253 (9 Dec 2003 20:37:05 GMT) X-Complaints-To: usenet@sea.gmane.org NNTP-Posting-Date: Tue, 9 Dec 2003 20:37:05 +0000 (UTC) Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Tue Dec 09 21:37:02 2003 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 1ATobN-0005ZW-01 for ; Tue, 09 Dec 2003 21:37:02 +0100 Original-Received: from localhost ([127.0.0.1] helo=monty-python.gnu.org) by monty-python.gnu.org with esmtp (Exim 4.24) id 1ATpYZ-0001NX-QX for guile-devel@m.gmane.org; Tue, 09 Dec 2003 16:38:11 -0500 Original-Received: from list by monty-python.gnu.org with tmda-scanned (Exim 4.24) id 1ATpXP-0001Gn-Pv for guile-devel@gnu.org; Tue, 09 Dec 2003 16:36:59 -0500 Original-Received: from mail by monty-python.gnu.org with spam-scanned (Exim 4.24) id 1ATpX2-0001Bx-9A for guile-devel@gnu.org; Tue, 09 Dec 2003 16:36:57 -0500 Original-Received: from [61.8.0.36] (helo=snoopy.pacific.net.au) by monty-python.gnu.org with esmtp (Exim 4.24) id 1ATpX1-0001BG-Do for guile-devel@gnu.org; Tue, 09 Dec 2003 16:36:35 -0500 Original-Received: from mongrel.pacific.net.au (mongrel.pacific.net.au [61.8.0.107]) by snoopy.pacific.net.au (8.12.3/8.12.3/Debian-6.6) with ESMTP id hB9KZ8no005854 for ; Wed, 10 Dec 2003 07:35:08 +1100 Original-Received: from localhost (ppp159.dyn16.pacific.net.au [61.8.16.159]) by mongrel.pacific.net.au (8.12.3/8.12.3/Debian-6.6) with ESMTP id hB9KZ6xs022302 for ; Wed, 10 Dec 2003 07:35:07 +1100 Original-Received: from gg by localhost with local (Exim 3.35 #1 (Debian)) id 1AToZ6-0002Je-00; Wed, 10 Dec 2003 06:34:40 +1000 Original-To: guile-devel@gnu.org Mail-Copies-To: never User-Agent: Gnus/5.1003 (Gnus v5.10.3) Emacs/21.3 (gnu/linux) X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.2 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:3110 X-Report-Spam: http://spam.gmane.org/gmane.lisp.guile.devel:3110 --=-=-= Marius Vollmer writes: > > Yes, that would be an improvement. Could you implement it? Starting with less_p, * numbers.c (scm_less_p): Don't convert frac to float for compares, that can give wrong results through rounding. * tests/numbers.test (<): Add tests inum/bignum/flonum/frac with frac. For min and max, I'd be inclined to have them call scm_less_p for their comparison, to avoid duplicating code. --=-=-= Content-Disposition: attachment; filename=numbers.c.less-frac.diff --- numbers.c.~1.219.~ 2003-12-03 07:37:10.000000000 +1000 +++ numbers.c 2003-12-09 14:50:46.000000000 +1000 @@ -3074,6 +3074,12 @@ } +/* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications + done are good for inums, but for bignums an answer can almost always be + had by just examining a few high bits of the operands, as done in GMP by + mpq_cmp. flonum/frac compares likewise, but with the slight complication + of the float exponent to take into account. */ + SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p); /* "Return @code{#t} if the list of parameters is monotonically\n" * "increasing." @@ -3081,6 +3087,7 @@ SCM scm_less_p (SCM x, SCM y) { + again: if (SCM_INUMP (x)) { long xx = SCM_INUM (x); @@ -3098,7 +3105,13 @@ else if (SCM_REALP (y)) return SCM_BOOL ((double) xx < SCM_REAL_VALUE (y)); else if (SCM_FRACTIONP (y)) - return SCM_BOOL ((double) xx < scm_i_fraction2double (y)); + { + /* "x < a/b" becomes "x*b < a" */ + int_frac: + x = scm_product (x, SCM_FRACTION_DENOMINATOR (y)); + y = SCM_FRACTION_NUMERATOR (y); + goto again; + } else SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); } @@ -3126,12 +3139,7 @@ return SCM_BOOL (cmp < 0); } else if (SCM_FRACTIONP (y)) - { - int cmp; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), scm_i_fraction2double (y)); - scm_remember_upto_here_1 (x); - return SCM_BOOL (cmp < 0); - } + goto int_frac; else SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); } @@ -3151,25 +3159,48 @@ else if (SCM_REALP (y)) return SCM_BOOL (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y)); else if (SCM_FRACTIONP (y)) - return SCM_BOOL (SCM_REAL_VALUE (x) < scm_i_fraction2double (y)); + { + double xx = SCM_REAL_VALUE (x); + if (xisnan (xx)) + return SCM_BOOL_F; + if (xisinf (xx)) + return SCM_BOOL (xx < 0.0); + x = scm_inexact_to_exact (x); /* with x as frac or int */ + goto again; + } else SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); } else if (SCM_FRACTIONP (x)) { - if (SCM_INUMP (y)) - return SCM_BOOL (scm_i_fraction2double (x) < (double) SCM_INUM (y)); - else if (SCM_BIGP (y)) - { - int cmp; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), scm_i_fraction2double (x)); - scm_remember_upto_here_1 (y); - return SCM_BOOL (cmp > 0); - } + if (SCM_INUMP (y) || SCM_BIGP (y)) + { + /* "a/b < y" becomes "a < y*b" */ + y = scm_product (y, SCM_FRACTION_DENOMINATOR (x)); + x = SCM_FRACTION_NUMERATOR (x); + goto again; + } else if (SCM_REALP (y)) - return SCM_BOOL (scm_i_fraction2double (x) < SCM_REAL_VALUE (y)); + { + double yy = SCM_REAL_VALUE (y); + if (xisnan (yy)) + return SCM_BOOL_F; + if (xisinf (yy)) + return SCM_BOOL (0.0 < yy); + y = scm_inexact_to_exact (y); /* with y as frac or int */ + goto again; + } else if (SCM_FRACTIONP (y)) - return SCM_BOOL (scm_i_fraction2double (x) < scm_i_fraction2double (y)); + { + /* "a/b < c/d" becomes "a*d < c*b" */ + SCM new_x = scm_product (SCM_FRACTION_NUMERATOR (x), + SCM_FRACTION_DENOMINATOR (y)); + SCM new_y = scm_product (SCM_FRACTION_NUMERATOR (y), + SCM_FRACTION_DENOMINATOR (x)); + x = new_x; + y = new_y; + goto again; + } else SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); } --=-=-= Content-Disposition: attachment; filename=numbers.test.less-frac.diff --- numbers.test.~1.39.~ 2003-11-25 08:11:18.000000000 +1000 +++ numbers.test 2003-12-09 15:06:40.000000000 +1000 @@ -1684,7 +1684,95 @@ (pass-if (not (< (1- (ash 3 1023)) +nan.0))) (pass-if (not (< +nan.0 (ash 3 1023)))) (pass-if (not (< +nan.0 (1+ (ash 3 1023))))) - (pass-if (not (< +nan.0 (1- (ash 3 1023)))))) + (pass-if (not (< +nan.0 (1- (ash 3 1023))))) + + (with-test-prefix "inum/frac" + (pass-if (< 2 9/4)) + (pass-if (< -2 9/4)) + (pass-if (< -2 7/4)) + (pass-if (< -2 -7/4)) + (pass-if (eq? #f (< 2 7/4))) + (pass-if (eq? #f (< 2 -7/4))) + (pass-if (eq? #f (< 2 -9/4))) + (pass-if (eq? #f (< -2 -9/4)))) + + (with-test-prefix "bignum/frac" + (let ((x (ash 1 2048))) + (pass-if (< x (* 4/3 x))) + (pass-if (< (- x) (* 4/3 x))) + (pass-if (< (- x) (* 2/3 x))) + (pass-if (< (- x) (* -2/3 x))) + (pass-if (eq? #f (< x (* 2/3 x)))) + (pass-if (eq? #f (< x (* -2/3 x)))) + (pass-if (eq? #f (< x (* -4/3 x)))) + (pass-if (eq? #f (< (- x) (* -4/3 x)))))) + + (with-test-prefix "flonum/frac" + (pass-if (< 0.75 4/3)) + (pass-if (< -0.75 4/3)) + (pass-if (< -0.75 2/3)) + (pass-if (< -0.75 -2/3)) + (pass-if (eq? #f (< 0.75 2/3))) + (pass-if (eq? #f (< 0.75 -2/3))) + (pass-if (eq? #f (< 0.75 -4/3))) + (pass-if (eq? #f (< -0.75 -4/3))) + + (pass-if (< -inf.0 4/3)) + (pass-if (< -inf.0 -4/3)) + (pass-if (eq? #f (< +inf.0 4/3))) + (pass-if (eq? #f (< +inf.0 -4/3))) + + (pass-if (eq? #f (< +nan.0 4/3))) + (pass-if (eq? #f (< +nan.0 -4/3)))) + + (with-test-prefix "frac/inum" + (pass-if (< 7/4 2)) + (pass-if (< -7/4 2)) + (pass-if (< -9/4 2)) + (pass-if (< -9/4 -2)) + (pass-if (eq? #f (< 9/4 2))) + (pass-if (eq? #f (< 9/4 -2))) + (pass-if (eq? #f (< 7/4 -2))) + (pass-if (eq? #f (< -7/4 -2)))) + + (with-test-prefix "frac/bignum" + (let ((x (ash 1 2048))) + (pass-if (< (* 2/3 x) x)) + (pass-if (< (* -2/3 x) x)) + (pass-if (< (* -4/3 x) x)) + (pass-if (< (* -4/3 x) (- x))) + (pass-if (eq? #f (< (* 4/3 x) x))) + (pass-if (eq? #f (< (* 4/3 x) (- x)))) + (pass-if (eq? #f (< (* 2/3 x) (- x)))) + (pass-if (eq? #f (< (* -2/3 x) (- x)))))) + + (with-test-prefix "frac/flonum" + (pass-if (< 2/3 0.75)) + (pass-if (< -2/3 0.75)) + (pass-if (< -4/3 0.75)) + (pass-if (< -4/3 -0.75)) + (pass-if (eq? #f (< 4/3 0.75))) + (pass-if (eq? #f (< 4/3 -0.75))) + (pass-if (eq? #f (< 2/3 -0.75))) + (pass-if (eq? #f (< -2/3 -0.75))) + + (pass-if (< 4/3 +inf.0)) + (pass-if (< -4/3 +inf.0)) + (pass-if (eq? #f (< 4/3 -inf.0))) + (pass-if (eq? #f (< -4/3 -inf.0))) + + (pass-if (eq? #f (< 4/3 +nan.0))) + (pass-if (eq? #f (< -4/3 +nan.0)))) + + (with-test-prefix "frac/frac" + (pass-if (< 2/3 6/7)) + (pass-if (< -2/3 6/7)) + (pass-if (< -4/3 6/7)) + (pass-if (< -4/3 -6/7)) + (pass-if (eq? #f (< 4/3 6/7))) + (pass-if (eq? #f (< 4/3 -6/7))) + (pass-if (eq? #f (< 2/3 -6/7))) + (pass-if (eq? #f (< -2/3 -6/7))))) ;;; ;;; > --=-=-= 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 --=-=-=--