X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=3556649b5e682d893bc6b5985bb250f57592cbe4;hb=c6b052b5c190f24ac8e03d69bfc5d333f268b960;hp=a6539ee60258ddedc7a3aac4bd32ed5bff234370;hpb=22b819c0cd0ca0ea5be52ba280b9e9e0b8e86210;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index a6539ee..3556649 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -66,9 +66,10 @@ is less than this, then print using ``miser-style'' output. Miser style conditional newlines are turned on, and all indentations are turned off. If NIL, never use miser mode.") -(defvar *print-pprint-dispatch* nil - #!+sb-doc - "the pprint-dispatch-table that controls how to pretty-print objects") +(defvar *print-pprint-dispatch*) +#!+sb-doc +(setf (fdocumentation '*print-pprint-dispatch* 'variable) + "the pprint-dispatch-table that controls how to pretty-print objects") (defmacro with-standard-io-syntax (&body body) #!+sb-doc @@ -596,11 +597,12 @@ ;;; words, diddle its case according to *PRINT-CASE* and ;;; READTABLE-CASE. (defun output-symbol-name (name stream &optional (maybe-quote t)) - (declare (type simple-base-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))) + (declare (type simple-string name)) + (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 @@ -874,19 +876,19 @@ ;;; :DOWNCASE :CAPITALIZE (defun output-capitalize-symbol (pname stream) (declare (simple-string pname)) - (let ((prev-not-alpha t) + (let ((prev-not-alphanum t) (up (eq (readtable-case *readtable*) :upcase))) (dotimes (i (length pname)) (let ((char (char pname i))) (write-char (if up - (if (or prev-not-alpha (lower-case-p char)) + (if (or prev-not-alphanum (lower-case-p char)) char (char-downcase char)) - (if prev-not-alpha + (if prev-not-alphanum (char-upcase char) char)) stream) - (setq prev-not-alpha (not (alpha-char-p char))))))) + (setq prev-not-alphanum (not (alphanumericp char))))))) ;;; called when: ;;; READTABLE-CASE *PRINT-CASE* @@ -959,7 +961,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)) @@ -975,7 +983,7 @@ (write-char (if (zerop bit) #\0 #\1) stream))) (t (when (and *print-readably* - (not (array-readably-printable-p array))) + (not (array-readably-printable-p vector))) (error 'print-not-readable :object vector)) (descend-into (stream) (write-string "#(" stream) @@ -1029,7 +1037,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)) @@ -1162,8 +1171,8 @@ (2 (write-char #\b stream)) (8 (write-char #\o stream)) (16 (write-char #\x stream)) - (t (write *print-base* :stream stream :radix nil :base 10))) - (write-char #\r stream)) + (t (write *print-base* :stream stream :radix nil :base 10) + (write-char #\r stream)))) (let ((*print-radix* nil)) (output-integer (numerator ratio) stream) (write-char #\/ stream) @@ -1242,6 +1251,7 @@ ;;; [CMUC]tradix.press. DO NOT EVEN THINK OF ATTEMPTING TO ;;; UNDERSTAND THIS CODE WITHOUT READING THE PAPER! +(declaim (type (simple-array character (10)) *digits*)) (defvar *digits* "0123456789") (defun flonum-to-string (x &optional width fdigits scale fmin) @@ -1379,6 +1389,96 @@ ;; 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 + (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 *digits* 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 *digits* 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 @@ -1401,7 +1501,9 @@ (declare (ignore sig)) (if (= x 0.0e0) (values (float 0.0e0 original-x) 1) - (let* ((ex (round (* exponent (log 2e0 10)))) + (let* ((ex (locally (declare (optimize (safety 0))) + (the fixnum + (round (* exponent (log 2e0 10)))))) (x (if (minusp ex) (if (float-denormalized-p x) #!-long-float @@ -1418,7 +1520,9 @@ (z y (* y m)) (ex ex (1- ex))) ((>= z 0.1e0) - (values (float z original-x) ex)))))))))) + (values (float z original-x) ex)) + (declare (long-float m) (integer ex)))) + (declare (long-float d)))))))) (eval-when (:compile-toplevel :execute) (setf *read-default-float-format* 'single-float)) @@ -1439,6 +1543,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) @@ -1496,26 +1606,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 @@ -1523,9 +1641,10 @@ ;;; the character name or the character in the #\char format. (defun output-character (char stream) (if (or *print-escape* *print-readably*) - (let ((name (char-name char))) + (let ((graphicp (graphic-char-p char)) + (name (char-name char))) (write-string "#\\" stream) - (if name + (if (and name (not graphicp)) (quote-string name stream) (write-char char stream))) (write-char char stream)))