X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=ffc2f721623da4a030832ab0a4dcd63765296f09;hb=b6ed0e20d468099b62d27095db7d18f76d8886d2;hp=d3096e852c4b3bb1931337f73745f4bf367a542e;hpb=970dd272dc84f7420252eadb4829cc193f795716;p=sbcl.git

diff --git a/src/code/print.lisp b/src/code/print.lisp
index d3096e8..ffc2f72 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -1230,91 +1230,90 @@
       (let (;; FIXME: these even tests assume normal IEEE rounding
             ;; mode.  I wonder if we should cater for non-normal?
             (high-ok (evenp f))
-            (low-ok (evenp f))
-            (result (make-array 50 :element-type 'base-char
-                                :fill-pointer 0 :adjustable t)))
-        (labels ((scale (r s m+ m-)
-                   (do ((k 0 (1+ k))
-                        (s s (* s print-base)))
-                       ((not (or (> (+ r m+) s)
-                                 (and high-ok (= (+ r m+) s))))
-                        (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 (not high-ok)
-                                           (= (* (+ r m+) print-base) s))))
-                             (values k (generate r s m+ m-)))))))
-                 (generate (r s m+ m-)
-                   (let (d tc1 tc2)
-                     (tagbody
-                      loop
-                        (setf (values d r) (truncate (* r print-base) s))
-                        (setf m+ (* m+ print-base))
-                        (setf m- (* m- print-base))
-                        (setf tc1 (or (< r m-) (and low-ok (= r m-))))
-                        (setf tc2 (or (> (+ r m+) s)
-                                      (and high-ok (= (+ r m+) s))))
-                        (when (or tc1 tc2)
-                          (go end))
-                        (vector-push-extend (char digit-characters d) result)
-                        (go loop)
-                      end
-                        (let ((d (cond
-                                   ((and (not tc1) tc2) (1+ d))
-                                   ((and tc1 (not tc2)) d)
-                                   (t ; (and tc1 tc2)
-                                    (if (< (* r 2) s) d (1+ d))))))
-                          (vector-push-extend (char digit-characters d) result)
-                          (return-from generate result)))))
-                 (initialize ()
-                   (let (r s m+ m-)
-                     (if (>= e 0)
-                         (let* ((be (expt float-radix e))
-                                (be1 (* be float-radix)))
-                           (if (/= f (expt float-radix (1- float-digits)))
-                               (setf r (* f be 2)
-                                     s 2
-                                     m+ be
-                                     m- be)
-                               (setf r (* f be1 2)
-                                     s (* float-radix 2)
-                                     m+ be1
-                                     m- be)))
-                         (if (or (= e min-e)
-                                 (/= f (expt float-radix (1- float-digits))))
-                             (setf r (* f 2)
-                                   s (* (expt float-radix (- e)) 2)
-                                   m+ 1
-                                   m- 1)
-                             (setf r (* f float-radix 2)
-                                   s (* (expt float-radix (- 1 e)) 2)
-                                   m+ float-radix
-                                   m- 1)))
-                     (when position
-                       (when relativep
-                         (aver (> position 0))
-                         (do ((k 0 (1+ k))
-                              ;; running out of letters here
-                              (l 1 (* l print-base)))
-                             ((>= (* s l) (+ r m+))
-                              ;; k is now \hat{k}
-                              (if (< (+ r (* s (/ (expt print-base (- k position)) 2)))
-                                     (* s (expt print-base k)))
-                                  (setf position (- k position))
-                                  (setf position (- k position 1))))))
-                       (let ((low (max m- (/ (* s (expt print-base position)) 2)))
-                             (high (max m+ (/ (* s (expt print-base position)) 2))))
-                         (when (<= m- low)
-                           (setf m- low)
-                           (setf low-ok t))
-                         (when (<= m+ high)
-                           (setf m+ high)
-                           (setf high-ok t))))
-                     (values r s m+ m-))))
-          (multiple-value-bind (r s m+ m-) (initialize)
-            (scale r s m+ m-)))))))
+            (low-ok (evenp f)))
+        (with-push-char (:element-type base-char)
+          (labels ((scale (r s m+ m-)
+                     (do ((k 0 (1+ k))
+                          (s s (* s print-base)))
+                         ((not (or (> (+ r m+) s)
+                                   (and high-ok (= (+ r m+) s))))
+                          (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 (not high-ok)
+                                             (= (* (+ r m+) print-base) s))))
+                               (values k (generate r s m+ m-)))))))
+                   (generate (r s m+ m-)
+                     (let (d tc1 tc2)
+                       (tagbody
+                        loop
+                          (setf (values d r) (truncate (* r print-base) s))
+                          (setf m+ (* m+ print-base))
+                          (setf m- (* m- print-base))
+                          (setf tc1 (or (< r m-) (and low-ok (= r m-))))
+                          (setf tc2 (or (> (+ r m+) s)
+                                        (and high-ok (= (+ r m+) s))))
+                          (when (or tc1 tc2)
+                            (go end))
+                          (push-char (char digit-characters d))
+                          (go loop)
+                        end
+                          (let ((d (cond
+                                     ((and (not tc1) tc2) (1+ d))
+                                     ((and tc1 (not tc2)) d)
+                                     (t ; (and tc1 tc2)
+                                      (if (< (* r 2) s) d (1+ d))))))
+                            (push-char (char digit-characters d))
+                            (return-from generate (get-pushed-string))))))
+                   (initialize ()
+                     (let (r s m+ m-)
+                       (if (>= e 0)
+                           (let* ((be (expt float-radix e))
+                                  (be1 (* be float-radix)))
+                             (if (/= f (expt float-radix (1- float-digits)))
+                                 (setf r (* f be 2)
+                                       s 2
+                                       m+ be
+                                       m- be)
+                                 (setf r (* f be1 2)
+                                       s (* float-radix 2)
+                                       m+ be1
+                                       m- be)))
+                           (if (or (= e min-e)
+                                   (/= f (expt float-radix (1- float-digits))))
+                               (setf r (* f 2)
+                                     s (* (expt float-radix (- e)) 2)
+                                     m+ 1
+                                     m- 1)
+                               (setf r (* f float-radix 2)
+                                     s (* (expt float-radix (- 1 e)) 2)
+                                     m+ float-radix
+                                     m- 1)))
+                       (when position
+                         (when relativep
+                           (aver (> position 0))
+                           (do ((k 0 (1+ k))
+                                ;; running out of letters here
+                                (l 1 (* l print-base)))
+                               ((>= (* s l) (+ r m+))
+                                ;; k is now \hat{k}
+                                (if (< (+ r (* s (/ (expt print-base (- k position)) 2)))
+                                       (* s (expt print-base k)))
+                                    (setf position (- k position))
+                                    (setf position (- k position 1))))))
+                         (let ((low (max m- (/ (* s (expt print-base position)) 2)))
+                               (high (max m+ (/ (* s (expt print-base position)) 2))))
+                           (when (<= m- low)
+                             (setf m- low)
+                             (setf low-ok t))
+                           (when (<= m+ high)
+                             (setf m+ high)
+                             (setf high-ok t))))
+                       (values r s m+ m-))))
+            (multiple-value-bind (r s m+ m-) (initialize)
+              (scale r s m+ m-))))))))
 
 ;;; Given a non-negative floating point number, SCALE-EXPONENT returns
 ;;; a new floating point number Z in the range (0.1, 1.0] and an