From fc9615a048b78e625535ef0b27cb92ea49bc8579 Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Mon, 6 Dec 2004 21:35:49 +0000 Subject: [PATCH] As reported by Rolf Wester, cmucl-help, 2004-12-06, 1d23 was causing an error. o Fix the logic error in scale in flonum-to-digits, where the test for high-ok was wrong. o Take the opportunity to eliminate some common subexpressions to reduce computation and consing of bignums. --- code/print.lisp | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/code/print.lisp b/code/print.lisp index f8ac763ac..05cdc6e58 100644 --- a/code/print.lisp +++ b/code/print.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.99 2004/10/14 16:32:44 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.100 2004/12/06 21:35:49 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1798,16 +1798,21 @@ radix-R. If you have a power-list then pass it in as PL." (result (make-array 50 :element-type 'base-char :fill-pointer 0 :adjustable t))) (labels ((scale (r s m+ m-) + ;; Keep increasing k until it's big enough (do ((k 0 (1+ k)) (s s (* s print-base))) - ((not (or (> (+ r m+) s) - (and high-ok (= (+ r m+) s)))) + ((not (let ((test (+ r m+))) + (or (> test s) + (and high-ok (= test s))))) + ;; k is too big. Decrease until (do ((k k (1- k)) (r r (* r print-base)) (m+ m+ (* m+ print-base)) (m- m- (* m- print-base))) - ((not (or (< (* (+ r m+) print-base) s) - (and high-ok (= (* (+ r m+) print-base) s)))) + ((not (let ((test (* (+ r m+) print-base))) + (or (< test s) + (and (not high-ok) (= test s))))) + ;; k is correct. Generate the digits. (values k (generate r s m+ m-))))))) (generate (r s m+ m-) (multiple-value-bind (d r) @@ -1815,8 +1820,9 @@ radix-R. If you have a power-list then pass it in as PL." (let ((m+ (* m+ print-base)) (m- (* m- print-base))) (let ((tc1 (or (< r m-) (and low-ok (= r m-)))) - (tc2 (or (> (+ r m+) s) - (and high-ok (= (+ r m+) s))))) + (tc2 (let ((test (+ r m+))) + (or (> test s) + (and high-ok (= test s)))))) (cond ((and (not tc1) (not tc2)) (vector-push-extend (char *digits* d) result) -- GitLab