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

diff --git a/src/code/print.lisp b/src/code/print.lisp
index 9da5da1..ffc2f72 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -358,10 +358,14 @@
             (default-structure-print object stream *current-level-in-print*))
            (t
             (write-string "#<INSTANCE but not STRUCTURE-OBJECT>" stream))))
+    (funcallable-instance
+     (cond
+       ((not (and (boundp '*print-object-is-disabled-p*)
+                  *print-object-is-disabled-p*))
+        (print-object object stream))
+       (t (output-fun object stream))))
     (function
-     (unless (and (funcallable-instance-p object)
-                  (printed-as-funcallable-standard-class object stream))
-       (output-fun object stream)))
+     (output-fun object stream))
     (symbol
      (output-symbol object stream))
     (number
@@ -1140,10 +1144,19 @@
         (t
          (multiple-value-bind (e string)
              (if fdigits
-                 (flonum-to-digits x (min (- fdigits) (- (or fmin 0))))
+                 (flonum-to-digits x (min (- (+ fdigits (or scale 0)))
+                                          (- (or fmin 0))))
                  (if (and width (> width 1))
-                     (let ((w (multiple-value-list (flonum-to-digits x (1- width) t)))
-                           (f (multiple-value-list (flonum-to-digits x (- (or fmin 0))))))
+                     (let ((w (multiple-value-list
+                               (flonum-to-digits x
+                                                 (max 1
+                                                      (+ (1- width)
+                                                         (if (and scale (minusp scale))
+                                                             scale 0)))
+                                                 t)))
+                           (f (multiple-value-list
+                               (flonum-to-digits x (- (+ (or fmin 0)
+                                                         (if scale scale 0)))))))
                        (cond
                          ((>= (length (cadr w)) (length (cadr f)))
                           (values-list w))
@@ -1153,11 +1166,13 @@
                  (stream (make-string-output-stream)))
              (if (plusp e)
                  (progn
-                   (write-string string stream :end (min (length string) e))
+                   (write-string string stream :end (min (length string)
+                                                         e))
                    (dotimes (i (- e (length string)))
                      (write-char #\0 stream))
                    (write-char #\. stream)
-                   (write-string string stream :start (min (length string) e))
+                   (write-string string stream :start (min (length
+                                                            string) e))
                    (when fdigits
                      (dotimes (i (- fdigits
                                     (- (length string)
@@ -1215,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
@@ -1375,18 +1389,17 @@
 ;;; Print the appropriate exponent marker for X and the specified exponent.
 (defun print-float-exponent (x exp stream)
   (declare (type float x) (type integer exp) (type stream stream))
-  (let ((*print-radix* nil)
-        (plusp (plusp exp)))
+  (let ((*print-radix* nil))
     (if (typep x *read-default-float-format*)
         (unless (eql exp 0)
-          (format stream "e~:[~;+~]~D" plusp exp))
-        (format stream "~C~:[~;+~]~D"
+          (format stream "e~D" exp))
+        (format stream "~C~D"
                 (etypecase x
                   (single-float #\f)
                   (double-float #\d)
                   (short-float #\s)
                   (long-float #\L))
-                plusp exp))))
+                exp))))
 
 (defun output-float-infinity (x stream)
   (declare (float x) (stream stream))
@@ -1429,6 +1442,7 @@
         (print-float-exponent x 0 stream))
        (t
         (output-float-aux x stream -3 8)))))))
+
 (defun output-float-aux (x stream e-min e-max)
   (multiple-value-bind (e string)
       (flonum-to-digits x)
@@ -1453,8 +1467,6 @@
       (t (write-string string stream :end 1)
          (write-char #\. stream)
          (write-string string stream :start 1)
-         (when (= (length string) 1)
-           (write-char #\0 stream))
          (print-float-exponent x (1- e) stream)))))
 
 ;;;; other leaf objects
@@ -1463,7 +1475,8 @@
 ;;; the character name or the character in the #\char format.
 (defun output-character (char stream)
   (if (or *print-escape* *print-readably*)
-      (let ((graphicp (graphic-char-p char))
+      (let ((graphicp (and (graphic-char-p char)
+                           (standard-char-p char)))
             (name (char-name char)))
         (write-string "#\\" stream)
         (if (and name (not graphicp))
@@ -1517,7 +1530,7 @@
 ;;; The definition here is a simple temporary placeholder. It will be
 ;;; overwritten by a smarter version (capable of calling generic
 ;;; PRINT-OBJECT when appropriate) when CLOS is installed.
-(defun printed-as-clos-funcallable-standard-class (object stream)
+(defun printed-as-funcallable-standard-class (object stream)
   (declare (ignore object stream))
   nil)