X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=02a3ca0189e6b0273a4a9cf4d74ae1b8fe91bce7;hb=dc9d03a1c43398d3a860520c6ea03e8d5838d142;hp=d27924ae6358228662533fb53386ab5673081ad1;hpb=e5e1b41799b814bca18e5f6e5c10b12d06c35c46;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index d27924a..02a3ca0 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -75,26 +75,26 @@ #!+sb-doc "Bind the reader and printer control variables to values that enable READ to reliably read the results of PRINT. These values are: - *PACKAGE* the COMMON-LISP-USER package - *PRINT-ARRAY* T - *PRINT-BASE* 10 - *PRINT-CASE* :UPCASE - *PRINT-CIRCLE* NIL - *PRINT-ESCAPE* T - *PRINT-GENSYM* T - *PRINT-LENGTH* NIL - *PRINT-LEVEL* NIL - *PRINT-LINES* NIL - *PRINT-MISER-WIDTH* NIL - *PRINT-PRETTY* NIL - *PRINT-RADIX* NIL - *PRINT-READABLY* T - *PRINT-RIGHT-MARGIN* NIL - *READ-BASE* 10 - *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT - *READ-EVAL* T - *READ-SUPPRESS* NIL - *READTABLE* the standard readtable" + *PACKAGE* the COMMON-LISP-USER package + *PRINT-ARRAY* T + *PRINT-BASE* 10 + *PRINT-CASE* :UPCASE + *PRINT-CIRCLE* NIL + *PRINT-ESCAPE* T + *PRINT-GENSYM* T + *PRINT-LENGTH* NIL + *PRINT-LEVEL* NIL + *PRINT-LINES* NIL + *PRINT-MISER-WIDTH* NIL + *PRINT-PRETTY* NIL + *PRINT-RADIX* NIL + *PRINT-READABLY* T + *PRINT-RIGHT-MARGIN* NIL + *READ-BASE* 10 + *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT + *READ-EVAL* T + *READ-SUPPRESS* NIL + *READTABLE* the standard readtable" `(%with-standard-io-syntax (lambda () ,@body))) (defun %with-standard-io-syntax (function) @@ -158,7 +158,7 @@ #!+sb-doc "Output a mostly READable printed representation of OBJECT on the specified STREAM." - (let ((*print-escape* T)) + (let ((*print-escape* t)) (output-object object (out-synonym-of stream))) object) @@ -166,8 +166,8 @@ #!+sb-doc "Output an aesthetic but not necessarily READable printed representation of OBJECT on the specified STREAM." - (let ((*print-escape* NIL) - (*print-readably* NIL)) + (let ((*print-escape* nil) + (*print-readably* nil)) (output-object object (out-synonym-of stream))) object) @@ -217,18 +217,21 @@ #!+sb-doc "Return the printed representation of OBJECT as a string with slashification on." - (stringify-object object t)) + (let ((*print-escape* t)) + (stringify-object object))) (defun princ-to-string (object) #!+sb-doc "Return the printed representation of OBJECT as a string with slashification off." - (stringify-object object nil)) + (let ((*print-escape* nil) + (*print-readably* nil)) + (stringify-object object))) ;;; This produces the printed representation of an object as a string. ;;; The few ...-TO-STRING functions above call this. (defvar *string-output-streams* ()) -(defun stringify-object (object &optional (*print-escape* *print-escape*)) +(defun stringify-object (object) (let ((stream (if *string-output-streams* (pop *string-output-streams*) (make-string-output-stream)))) @@ -249,15 +252,12 @@ (when type (write (type-of object) :stream stream :circle nil :level nil :length nil) - (when (or body identity) - (write-char #\space stream) - (pprint-newline :fill stream))) + (write-char #\space stream)) (when body (funcall body)) (when identity - (when body - (write-char #\space stream) - (pprint-newline :fill stream)) + (when (or body (not type)) + (write-char #\space stream)) (write-char #\{ stream) (write (get-lisp-obj-address object) :stream stream :radix nil :base 16) @@ -360,7 +360,7 @@ ;; Someone forgot to initiate circularity detection. (let ((*print-circle* nil)) (error "trying to use CHECK-FOR-CIRCULARITY when ~ - circularity checking isn't initiated"))) + circularity checking isn't initiated"))) ((t) ;; It's a second (or later) reference to the object while we are ;; just looking. So don't bother groveling it again. @@ -598,10 +598,11 @@ ;;; READTABLE-CASE. (defun output-symbol-name (name stream &optional (maybe-quote t)) (declare (type simple-string name)) - (setup-printer-state) - (if (and maybe-quote (symbol-quotep name)) - (output-quoted-symbol-name name stream) - (funcall *internal-symbol-output-fun* name stream))) + (let ((*readtable* (if *print-readably* *standard-readtable* *readtable*))) + (setup-printer-state) + (if (and maybe-quote (symbol-quotep name)) + (output-quoted-symbol-name name stream) + (funcall *internal-symbol-output-fun* name stream)))) ;;;; escaping symbols @@ -614,10 +615,10 @@ ;;; character has. At characters have at least one bit set, so we can ;;; search for any character with a positive test. (defvar *character-attributes* - (make-array char-code-limit + (make-array 160 ; FIXME :element-type '(unsigned-byte 16) :initial-element 0)) -(declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit)) +(declaim (type (simple-array (unsigned-byte 16) (#.160)) ; FIXME *character-attributes*)) ;;; constants which are a bit-mask for each interesting character attribute @@ -671,17 +672,17 @@ (set-bit #\/ slash-attribute) ;; Mark anything not explicitly allowed as funny. - (dotimes (i char-code-limit) + (dotimes (i 160) ; FIXME (when (zerop (aref *character-attributes* i)) (setf (aref *character-attributes* i) funny-attribute)))) ;;; For each character, the value of the corresponding element is the ;;; lowest base in which that character is a digit. (defvar *digit-bases* - (make-array char-code-limit + (make-array 128 ; FIXME :element-type '(unsigned-byte 8) :initial-element 36)) -(declaim (type (simple-array (unsigned-byte 8) (#.char-code-limit)) +(declaim (type (simple-array (unsigned-byte 8) (#.128)) ; FIXME *digit-bases*)) (dotimes (i 36) (let ((char (digit-char i 36))) @@ -697,7 +698,11 @@ ,(if at-end '(go TEST-SIGN) '(return nil))) (setq current (schar name index) code (char-code current) - bits (aref attributes code)) + bits (cond ; FIXME + ((< code 160) (aref attributes code)) + ((upper-case-p current) uppercase-attribute) + ((lower-case-p current) lowercase-attribute) + (t other-attribute))) (incf index) (go ,tag))) (test (&rest attributes) @@ -712,7 +717,8 @@ attributes)) bits))))) (digitp () - `(< (the fixnum (aref bases code)) base))) + `(and (< code 128) ; FIXME + (< (the fixnum (aref bases code)) base)))) (prog ((len (length name)) (attributes *character-attributes*) @@ -739,7 +745,13 @@ letter-attribute))) (do ((i (1- index) (1+ i))) ((= i len) (return-from symbol-quotep nil)) - (unless (zerop (logand (aref attributes (char-code (schar name i))) + (unless (zerop (logand (let* ((char (schar name i)) + (code (char-code char))) + (cond + ((< code 160) (aref attributes code)) + ((upper-case-p char) uppercase-attribute) + ((lower-case-p char) lowercase-attribute) + (t other-attribute))) mask)) (return-from symbol-quotep t)))) @@ -960,7 +972,13 @@ (defun output-vector (vector stream) (declare (vector vector)) (cond ((stringp vector) - (cond ((or *print-escape* *print-readably*) + (cond ((and *print-readably* + (not (eq (array-element-type vector) + (load-time-value + (array-element-type + (make-array 0 :element-type 'character)))))) + (error 'print-not-readable :object vector)) + ((or *print-escape* *print-readably*) (write-char #\" stream) (quote-string vector stream) (write-char #\" stream)) @@ -1030,7 +1048,8 @@ (not (array-readably-printable-p array))) (error 'print-not-readable :object array)) (write-char #\# stream) - (let ((*print-base* 10)) + (let ((*print-base* 10) + (*print-radix* nil)) (output-integer (array-rank array) stream)) (write-char #\A stream) (with-array-data ((data array) (start) (end)) @@ -1243,8 +1262,6 @@ ;;; [CMUC]tradix.press. DO NOT EVEN THINK OF ATTEMPTING TO ;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER! -(defvar *digits* "0123456789") - (defun flonum-to-string (x &optional width fdigits scale fmin) (cond ((zerop x) ;; Zero is a special case which FLOAT-STRING cannot handle. @@ -1265,6 +1282,7 @@ (defun float-string (fraction exponent precision width fdigits scale fmin) (let ((r fraction) (s 1) (m- 1) (m+ 1) (k 0) (digits 0) (decpnt 0) (cutoff nil) (roundup nil) u low high + (digit-characters "0123456789") (digit-string (make-array 50 :element-type 'base-char :fill-pointer 0 @@ -1355,13 +1373,13 @@ ;; Stop when either precision is exhausted or we have printed as ;; many fraction digits as permitted. (when (or low high (and cutoff (<= k cutoff))) (return)) - (vector-push-extend (char *digits* u) digit-string) + (vector-push-extend (char digit-characters u) digit-string) (incf digits)) ;; If cutoff occurred before first digit, then no digits are ;; generated at all. (when (or (not cutoff) (>= k cutoff)) ;; Last digit may need rounding - (vector-push-extend (char *digits* + (vector-push-extend (char digit-characters (cond ((and low (not high)) u) ((and high (not low)) (1+ u)) (t (if (<= (ash r 1) s) u (1+ u))))) @@ -1380,6 +1398,97 @@ ;; all done (values digit-string (1+ digits) (= decpnt 0) (= decpnt digits) decpnt))) +;;; implementation of figure 1 from Burger and Dybvig, 1996. As the +;;; implementation of the Dragon from Classic CMUCL (and above, +;;; FLONUM-TO-STRING) says: "DO NOT EVEN THINK OF ATTEMPTING TO +;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER!", and in this case +;;; we have to add that even reading the paper might not bring +;;; immediate illumination as CSR has attempted to turn idiomatic +;;; Scheme into idiomatic Lisp. +;;; +;;; FIXME: figure 1 from Burger and Dybvig is the unoptimized +;;; algorithm, noticeably slow at finding the exponent. Figure 2 has +;;; an improved algorithm, but CSR ran out of energy +;;; +;;; FIXME: Burger and Dybvig also provide an algorithm for +;;; fixed-format floating point printing. If it were implemented, +;;; then we could delete the Dragon altogether (see FLONUM-TO-STRING). +;;; +;;; possible extension for the enthusiastic: printing floats in bases +;;; other than base 10. +(defconstant single-float-min-e + (nth-value 1 (decode-float least-positive-single-float))) +(defconstant double-float-min-e + (nth-value 1 (decode-float least-positive-double-float))) +#!+long-float +(defconstant long-float-min-e + (nth-value 1 (decode-float least-positive-long-float))) + +(defun flonum-to-digits (v) + (let ((print-base 10) ; B + (float-radix 2) ; b + (float-digits (float-digits v)) ; p + (digit-characters "0123456789") + (min-e + (etypecase v + (single-float single-float-min-e) + (double-float double-float-min-e) + #!+long-float + (long-float long-float-min-e)))) + (multiple-value-bind (f e) + (integer-decode-float v) + (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 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)))))) + (if (>= e 0) + (if (/= f (expt float-radix (1- float-digits))) + (let ((be (expt float-radix e))) + (scale (* f be 2) 2 be be)) + (let* ((be (expt float-radix e)) + (be1 (* be float-radix))) + (scale (* f be1 2) (* float-radix 2) be1 be))) + (if (or (= e min-e) (/= f (expt float-radix (1- float-digits)))) + (scale (* f 2) (* (expt float-radix (- e)) 2) 1 1) + (scale (* f float-radix 2) + (* (expt float-radix (- 1 e)) 2) float-radix 1)))))))) + ;;; 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 ;;; exponent E such that Z * 10^E is (approximately) equal to the @@ -1444,6 +1553,12 @@ ;;; attractive to handle exponential notation with the same accuracy ;;; as non-exponential notation, using the method described in the ;;; Steele and White paper. +;;; +;;; NOTE II: this has been bypassed slightly by implementing Burger +;;; and Dybvig, 1996. When someone has time (KLUDGE) they can +;;; probably (a) implement the optimizations suggested by Burger and +;;; Dyvbig, and (b) remove all vestiges of Dragon4, including from +;;; fixed-format printing. ;;; Print the appropriate exponent marker for X and the specified exponent. (defun print-float-exponent (x exp stream) @@ -1501,26 +1616,34 @@ (write-string "0.0" stream) (print-float-exponent x 0 stream)) (t - (output-float-aux x stream (float 1/1000 x) (float 10000000 x)))))))) + (output-float-aux x stream -3 8))))))) (defun output-float-aux (x stream e-min e-max) - (if (and (>= x e-min) (< x e-max)) - ;; free format - (multiple-value-bind (str len lpoint tpoint) (flonum-to-string x) - (declare (ignore len)) - (when lpoint (write-char #\0 stream)) - (write-string str stream) - (when tpoint (write-char #\0 stream)) - (print-float-exponent x 0 stream)) - ;; exponential format - (multiple-value-bind (f ex) (scale-exponent x) - (multiple-value-bind (str len lpoint tpoint) - (flonum-to-string f nil nil 1) - (declare (ignore len)) - (when lpoint (write-char #\0 stream)) - (write-string str stream) - (when tpoint (write-char #\0 stream)) - ;; Subtract out scale factor of 1 passed to FLONUM-TO-STRING. - (print-float-exponent x (1- ex) stream))))) + (multiple-value-bind (e string) + (flonum-to-digits x) + (cond + ((< e-min e e-max) + (if (plusp e) + (progn + (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)) + (when (<= (length string) e) + (write-char #\0 stream)) + (print-float-exponent x 0 stream)) + (progn + (write-string "0." stream) + (dotimes (i (- e)) + (write-char #\0 stream)) + (write-string string stream) + (print-float-exponent x 0 stream)))) + (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