X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=4c945e8bb126e659dc74694b44419a5b4c5bfef8;hb=7c5138fcbdb302abc563a2060493f2f0304ae902;hp=ce3e83670cbad373e44895c7aa534a79cca7c6c6;hpb=ba34717602d80e5fd74d10e61f4729fb0d019a0c;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index ce3e836..4c945e8 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)))) @@ -357,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. @@ -451,8 +454,6 @@ ;; As long as no one comes up with a non-obscure way of detecting this ;; sleaziness, fixing this nonconformity will probably have a low ;; priority. -- WHN 2001-11-25 - (fixnum - (output-integer object stream)) (list (if (null object) (output-symbol object stream) @@ -612,10 +613,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 @@ -669,17 +670,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))) @@ -695,7 +696,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) @@ -710,7 +715,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*) @@ -737,7 +743,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)))) @@ -1068,115 +1080,70 @@ ;;;; integer, ratio, and complex printing (i.e. everything but floats) +(defun %output-radix (base stream) + (write-char #\# stream) + (write-char (case base + (2 #\b) + (8 #\o) + (16 #\x) + (t (%output-fixnum-in-base base 10 stream) + #\r)) + stream)) + +(defun %output-fixnum-in-base (n base stream) + (multiple-value-bind (q r) + (truncate n base) + ;; Recurse until you have all the digits pushed on + ;; the stack. + (unless (zerop q) + (%output-fixnum-in-base q base stream)) + ;; Then as each recursive call unwinds, turn the + ;; digit (in remainder) into a character and output + ;; the character. + (write-char + (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" r) + stream))) + +(defun %output-bignum-in-base (n base stream) + (labels ((bisect (n power) + (if (fixnump n) + (%output-fixnum-in-base n base stream) + (let ((k (truncate power 2))) + (multiple-value-bind (q r) (truncate n (expt base k)) + (bisect q (- power k)) + (let ((npower (if (zerop r) 0 (truncate (log r base))))) + (dotimes (z (- k npower 1)) + (write-char #\0 stream)) + (bisect r npower))))))) + (bisect n (truncate (log n base))))) + +(defun %output-integer-in-base (integer base stream) + (when (minusp integer) + (write-char #\- stream) + (setf integer (- integer))) + (if (fixnump integer) + (%output-fixnum-in-base integer base stream) + (%output-bignum-in-base integer base stream))) + (defun output-integer (integer stream) - ;; FIXME: This UNLESS form should be pulled out into something like - ;; (SANE-PRINT-BASE), along the lines of (SANE-PACKAGE) for the - ;; *PACKAGE* variable. - (unless (and (fixnump *print-base*) - (< 1 *print-base* 37)) - (let ((obase *print-base*)) - (setq *print-base* 10.) - (error "~A is not a reasonable value for *PRINT-BASE*." obase))) - (when (and (not (= *print-base* 10.)) - *print-radix*) - ;; First print leading base information, if any. - (write-char #\# stream) - (write-char (case *print-base* - (2. #\b) - (8. #\o) - (16. #\x) - (T (let ((fixbase *print-base*) - (*print-base* 10.) - (*print-radix* ())) - (sub-output-integer fixbase stream)) - #\r)) - stream)) - ;; Then output a minus sign if the number is negative, then output - ;; the absolute value of the number. - (cond ((bignump integer) (print-bignum integer stream)) - ((< integer 0) - (write-char #\- stream) - (sub-output-integer (- integer) stream)) - (t - (sub-output-integer integer stream))) - ;; Print any trailing base information, if any. - (if (and (= *print-base* 10.) *print-radix*) - (write-char #\. stream))) - -(defun sub-output-integer (integer stream) - (let ((quotient ()) - (remainder ())) - ;; Recurse until you have all the digits pushed on the stack. - (if (not (zerop (multiple-value-setq (quotient remainder) - (truncate integer *print-base*)))) - (sub-output-integer quotient stream)) - ;; Then as each recursive call unwinds, turn the digit (in remainder) - ;; into a character and output the character. - (write-char (code-char (if (and (> remainder 9.) - (> *print-base* 10.)) - (+ (char-code #\A) (- remainder 10.)) - (+ (char-code #\0) remainder))) - stream))) - -;;;; bignum printing - -;;; *BASE-POWER* holds the number that we keep dividing into the -;;; bignum for each *print-base*. We want this number as close to -;;; *most-positive-fixnum* as possible, i.e. (floor (log -;;; most-positive-fixnum *print-base*)). -(defparameter *base-power* (make-array 37 :initial-element nil)) - -;;; *FIXNUM-POWER--1* holds the number of digits for each *PRINT-BASE* -;;; that fit in the corresponding *base-power*. -(defparameter *fixnum-power--1* (make-array 37 :initial-element nil)) - -;;; Print the bignum to the stream. We first generate the correct -;;; value for *base-power* and *fixnum-power--1* if we have not -;;; already. Then we call bignum-print-aux to do the printing. -(defun print-bignum (big stream) - (unless (aref *base-power* *print-base*) - (do ((power-1 -1 (1+ power-1)) - (new-divisor *print-base* (* new-divisor *print-base*)) - (divisor 1 new-divisor)) - ((not (fixnump new-divisor)) - (setf (aref *base-power* *print-base*) divisor) - (setf (aref *fixnum-power--1* *print-base*) power-1)))) - (bignum-print-aux (cond ((minusp big) - (write-char #\- stream) - (- big)) - (t big)) - (aref *base-power* *print-base*) - (aref *fixnum-power--1* *print-base*) - stream) - big) - -(defun bignum-print-aux (big divisor power-1 stream) - (multiple-value-bind (newbig fix) (truncate big divisor) - (if (fixnump newbig) - (sub-output-integer newbig stream) - (bignum-print-aux newbig divisor power-1 stream)) - (do ((zeros power-1 (1- zeros)) - (base-power *print-base* (* base-power *print-base*))) - ((> base-power fix) - (dotimes (i zeros) (write-char #\0 stream)) - (sub-output-integer fix stream))))) + (let ((base *print-base*)) + (when (and (/= base 10) *print-radix*) + (%output-radix base stream)) + (%output-integer-in-base integer base stream) + (when (and *print-radix* (= base 10)) + (write-char #\. stream)))) (defun output-ratio (ratio stream) - (when *print-radix* - (write-char #\# stream) - (case *print-base* - (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)))) - (let ((*print-radix* nil)) - (output-integer (numerator ratio) stream) + (let ((base *print-base*)) + (when *print-radix* + (%output-radix base stream)) + (%output-integer-in-base (numerator ratio) base stream) (write-char #\/ stream) - (output-integer (denominator ratio) stream))) + (%output-integer-in-base (denominator ratio) base stream))) (defun output-complex (complex stream) (write-string "#C(" stream) + ;; FIXME: Could this just be OUTPUT-NUMBER? (output-object (realpart complex) stream) (write-char #\space stream) (output-object (imagpart complex) stream) @@ -1248,9 +1215,6 @@ ;;; [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) (cond ((zerop x) ;; Zero is a special case which FLOAT-STRING cannot handle. @@ -1271,6 +1235,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 @@ -1361,13 +1326,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))))) @@ -1416,6 +1381,7 @@ (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) @@ -1440,7 +1406,8 @@ (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)))) + (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) @@ -1454,7 +1421,7 @@ (and high-ok (= (+ r m+) s)))) (when (or tc1 tc2) (go end)) - (vector-push-extend (char *digits* d) result) + (vector-push-extend (char digit-characters d) result) (go loop) end (let ((d (cond @@ -1462,7 +1429,7 @@ ((and tc1 (not tc2)) d) (t ; (and tc1 tc2) (if (< (* r 2) s) d (1+ d)))))) - (vector-push-extend (char *digits* d) result) + (vector-push-extend (char digit-characters d) result) (return-from generate result)))))) (if (>= e 0) (if (/= f (expt float-radix (1- float-digits)))