X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=4981c77f2e0a32f9b8354b5fb5531509e9b7e04b;hb=7b384da95e6a30e1434523213aeeed3a90448c78;hp=77ad049bdacba48dc7bd73c734c7f4fff947e1bb;hpb=ef04b756fea49f03ce543873b4606bac0a31badf;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index 77ad049..4981c77 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 @@ -94,9 +95,10 @@ *READ-EVAL* T *READ-SUPPRESS* NIL *READTABLE* the standard readtable" - `(%with-standard-io-syntax #'(lambda () ,@body))) + `(%with-standard-io-syntax (lambda () ,@body))) (defun %with-standard-io-syntax (function) + (declare (type function function)) (let ((*package* (find-package "COMMON-LISP-USER")) (*print-array* t) (*print-base* 10) @@ -240,6 +242,7 @@ ;;; guts of PRINT-UNREADABLE-OBJECT (defun %print-unreadable-object (object stream type identity body) + (declare (type (or null function) body)) (when *print-readably* (error 'print-not-readable :object object)) (flet ((print-description () @@ -291,20 +294,23 @@ ;;; Check to see whether OBJECT is a circular reference, and return ;;; something non-NIL if it is. If ASSIGN is T, then the number to use ;;; in the #n= and #n# noise is assigned at this time. +;;; If ASSIGN is true, reference bookkeeping will only be done for +;;; existing entries, no new references will be recorded! ;;; ;;; Note: CHECK-FOR-CIRCULARITY must be called *exactly* once with ;;; ASSIGN true, or the circularity detection noise will get confused ;;; about when to use #n= and when to use #n#. If this returns non-NIL ;;; when ASSIGN is true, then you must call HANDLE-CIRCULARITY on it. -;;; If you are not using this inside a WITH-CIRCULARITY-DETECTION, -;;; then you have to be prepared to handle a return value of :INITIATE -;;; which means it needs to initiate the circularity detection noise. +;;; If CHECK-FOR-CIRCULARITY returns :INITIATE as the second value, +;;; you need to initiate the circularity detection noise, e.g. bind +;;; *CIRCULARITY-HASH-TABLE* and *CIRCULARITY-COUNTER* to suitable values +;;; (see #'OUTPUT-OBJECT for an example). (defun check-for-circularity (object &optional assign) (cond ((null *print-circle*) ;; Don't bother, nobody cares. nil) ((null *circularity-hash-table*) - :initiate) + (values nil :initiate)) ((null *circularity-counter*) (ecase (gethash object *circularity-hash-table*) ((nil) @@ -373,11 +379,6 @@ ;;;; OUTPUT-OBJECT -- the main entry point -;;; the current pretty printer. This should be either a function that -;;; takes two arguments (the object and the stream) or NIL to indicate -;;; that there is no pretty printer installed. -(defvar *pretty-printer* nil) - ;;; Objects whose print representation identifies them EQLly don't ;;; need to be checked for circularity. (defun uniquely-identified-by-print-p (x) @@ -388,34 +389,28 @@ ;;; Output OBJECT to STREAM observing all printer control variables. (defun output-object (object stream) - (/show0 "entering OUTPUT-OBJECT") (labels ((print-it (stream) - (/show0 "entering PRINT-IT in OUTPUT-OBJECT") (if *print-pretty* - (if *pretty-printer* - (funcall *pretty-printer* object stream) - (let ((*print-pretty* nil)) - (output-ugly-object object stream))) + (sb!pretty:output-pretty-object object stream) (output-ugly-object object stream))) (check-it (stream) - (/show0 "entering CHECK-IT") - (let ((marker (check-for-circularity object t))) - (case marker - (:initiate - (let ((*circularity-hash-table* - (make-hash-table :test 'eq))) - (check-it (make-broadcast-stream)) - (let ((*circularity-counter* 0)) - (check-it stream)))) - ((nil) - (print-it stream)) - (t - (when (handle-circularity marker stream) - (print-it stream))))))) + (multiple-value-bind (marker initiate) + (check-for-circularity object t) + ;; initialization of the circulation detect noise ... + (if (eq initiate :initiate) + (let ((*circularity-hash-table* + (make-hash-table :test 'eq))) + (check-it (make-broadcast-stream)) + (let ((*circularity-counter* 0)) + (check-it stream))) + ;; otherwise + (if marker + (when (handle-circularity marker stream) + (print-it stream)) + (print-it stream)))))) (cond (;; Maybe we don't need to bother with circularity detection. (or (not *print-circle*) (uniquely-identified-by-print-p object)) - (/show0 "in obviously-don't-bother case") (print-it stream)) (;; If we have already started circularity detection, this ;; object might be a shared reference. If we have not, then @@ -423,14 +418,14 @@ ;; reference to itself or multiple shared references. (or *circularity-hash-table* (compound-object-p object)) - (/show0 "in CHECK-IT case") (check-it stream)) (t - (/show0 "in don't-bother-after-all case") (print-it stream))))) -;;; a hack for debugging -#!+sb-show +;;; a hack to work around recurring gotchas with printing while +;;; DEFGENERIC PRINT-OBJECT is being built +;;; +;;; (hopefully will go away naturally when CLOS moves into cold init) (defvar *print-object-is-disabled-p*) ;;; Output OBJECT to STREAM observing all printer control variables @@ -438,7 +433,6 @@ ;;; then the pretty printer will be used for any components of OBJECT, ;;; just not for OBJECT itself. (defun output-ugly-object (object stream) - (/show0 "entering OUTPUT-UGLY-OBJECT") (typecase object ;; KLUDGE: The TYPECASE approach here is non-ANSI; the ANSI definition of ;; PRINT-OBJECT says it provides printing and we're supposed to provide @@ -451,15 +445,15 @@ ;; a method on an external symbol in the CL package which is ;; applicable to arg lists containing only direct instances of ;; standardized classes. - ;; Thus, in order for the user to detect our sleaziness, he has to do - ;; something relatively obscure like + ;; Thus, in order for the user to detect our sleaziness in conforming + ;; code, he has to do something relatively obscure like ;; (1) actually use tools like FIND-METHOD to look for PRINT-OBJECT ;; methods, or ;; (2) define a PRINT-OBJECT method which is specialized on the stream ;; value (e.g. a Gray stream object). ;; 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 20000121 + ;; priority. -- WHN 2001-11-25 (fixnum (output-integer object stream)) (list @@ -467,28 +461,17 @@ (output-symbol object stream) (output-list object stream))) (instance - (/show0 "in PRINT-OBJECT case") - #!-sb-show - (print-object object stream) - - ;; After being bitten several times by the difficulty of - ;; debugging problems around DEFGENERIC PRINT-OBJECT when the old - ;; placeholder printer is disabled by FMAKUNBOUND 'PRINT-OBJECT - ;; and/or DEFGENERIC has already executed but DEFMETHODs haven't, - ;; I added this workaround to allow output during that - ;; interval... -- WHN 2001-11-25 - #!+sb-show (cond ((not (and (boundp '*print-object-is-disabled-p*) *print-object-is-disabled-p*)) (print-object object stream)) ((typep object 'structure-object) - (default-structure-print object stream *current-level*)) + (default-structure-print object stream *current-level-in-print*)) (t - (write-string "#")))) + (write-string "#" stream)))) (function (unless (and (funcallable-instance-p object) (printed-as-funcallable-standard-class object stream)) - (output-function object stream))) + (output-fun object stream))) (symbol (output-symbol object stream)) (number @@ -520,24 +503,23 @@ (fdefn (output-fdefn object stream)) (t - (/show0 "in OUTPUT-RANDOM case") (output-random object stream)))) ;;;; symbols -;;; Values of *PRINT-CASE* and (READTABLE-CASE *READTABLE*) the last -;;; time the printer was called. +;;; values of *PRINT-CASE* and (READTABLE-CASE *READTABLE*) the last +;;; time the printer was called (defvar *previous-case* nil) (defvar *previous-readtable-case* nil) ;;; This variable contains the current definition of one of three ;;; symbol printers. SETUP-PRINTER-STATE sets this variable. -(defvar *internal-symbol-output-function* nil) +(defvar *internal-symbol-output-fun* nil) ;;; This function sets the internal global symbol -;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* to the right function depending -;;; on the value of *PRINT-CASE*. See the manual for details. The -;;; print buffer stream is also reset. +;;; *INTERNAL-SYMBOL-OUTPUT-FUN* to the right function depending on +;;; the value of *PRINT-CASE*. See the manual for details. The print +;;; buffer stream is also reset. (defun setup-printer-state () (unless (and (eq *print-case* *previous-case*) (eq (readtable-case *readtable*) *previous-readtable-case*)) @@ -551,7 +533,7 @@ (setf (readtable-case *readtable*) :upcase) (error "invalid READTABLE-CASE value: ~S" *previous-readtable-case*)) - (setq *internal-symbol-output-function* + (setq *internal-symbol-output-fun* (case *previous-readtable-case* (:upcase (case *print-case* @@ -615,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-function* 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 @@ -701,7 +684,6 @@ :initial-element 36)) (declaim (type (simple-array (unsigned-byte 8) (#.char-code-limit)) *digit-bases*)) - (dotimes (i 36) (let ((char (digit-char i 36))) (setf (aref *digit-bases* (char-code char)) i))) @@ -849,13 +831,16 @@ (return t) MARKER ; number marker in a numeric number... + ;; ("What," you may ask, "is a 'number marker'?" It's something + ;; that a conforming implementation might use in number syntax. + ;; See ANSI 2.3.1.1 "Potential Numbers as Tokens".) (when (test letter) (advance OTHER nil)) (go DIGIT)))) -;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* +;;;; *INTERNAL-SYMBOL-OUTPUT-FUN* ;;;; -;;;; Case hackery. These functions are stored in -;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* according to the values of +;;;; case hackery: These functions are stored in +;;;; *INTERNAL-SYMBOL-OUTPUT-FUN* according to the values of ;;;; *PRINT-CASE* and READTABLE-CASE. ;;; called when: @@ -891,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* @@ -964,7 +949,8 @@ (output-object (pop list) stream) (unless list (return)) - (when (or (atom list) (check-for-circularity list)) + (when (or (atom list) + (check-for-circularity list)) (write-string " . " stream) (output-object list stream) (return)) @@ -991,7 +977,7 @@ (write-char (if (zerop bit) #\0 #\1) stream))) (t (when (and *print-readably* - (not (eq (array-element-type vector) t))) + (not (array-readably-printable-p vector))) (error 'print-not-readable :object vector)) (descend-into (stream) (write-string "#(" stream) @@ -1018,6 +1004,14 @@ (when (needs-slash-p char) (write-char #\\ stream)) (write-char char stream)))))) +(defun array-readably-printable-p (array) + (and (eq (array-element-type array) t) + (let ((zero (position 0 (array-dimensions array))) + (number (position 0 (array-dimensions array) + :test (complement #'eql) + :from-end t))) + (or (null zero) (null number) (> zero number))))) + ;;; Output the printed representation of any array in either the #< or #A ;;; form. (defun output-array (array stream) @@ -1034,7 +1028,7 @@ ;;; Output the readable #A form of an array. (defun output-array-guts (array stream) (when (and *print-readably* - (not (eq (array-element-type array) t))) + (not (array-readably-printable-p array))) (error 'print-not-readable :object array)) (write-char #\# stream) (let ((*print-base* 10)) @@ -1066,8 +1060,7 @@ ;;; use until CLOS is set up (at which time it will be replaced with ;;; the real generic function implementation) (defun print-object (instance stream) - (/show0 "in pre-CLOS PRINT-OBJECT placeholder") - (default-structure-print instance stream *current-level*)) + (default-structure-print instance stream *current-level-in-print*)) ;;;; integer, ratio, and complex printing (i.e. everything but floats) @@ -1171,8 +1164,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) @@ -1400,30 +1393,40 @@ ;;; part of the computation to avoid over/under flow. When ;;; denormalized, we must pull out a large factor, since there is more ;;; negative exponent range than positive range. + +(eval-when (:compile-toplevel :execute) + (setf *read-default-float-format* + #!+long-float 'long-float #!-long-float 'double-float)) (defun scale-exponent (original-x) (let* ((x (coerce original-x 'long-float))) (multiple-value-bind (sig exponent) (decode-float x) (declare (ignore sig)) - (if (= x 0.0l0) - (values (float 0.0l0 original-x) 1) - (let* ((ex (round (* exponent (log 2l0 10)))) + (if (= x 0.0e0) + (values (float 0.0e0 original-x) 1) + (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 - (* x 1.0l16 (expt 10.0l0 (- (- ex) 16))) + (* x 1.0e16 (expt 10.0e0 (- (- ex) 16))) #!+long-float - (* x 1.0l18 (expt 10.0l0 (- (- ex) 18))) - (* x 10.0l0 (expt 10.0l0 (- (- ex) 1)))) - (/ x 10.0l0 (expt 10.0l0 (1- ex)))))) - (do ((d 10.0l0 (* d 10.0l0)) + (* x 1.0e18 (expt 10.0e0 (- (- ex) 18))) + (* x 10.0e0 (expt 10.0e0 (- (- ex) 1)))) + (/ x 10.0e0 (expt 10.0e0 (1- ex)))))) + (do ((d 10.0e0 (* d 10.0e0)) (y x (/ x d)) (ex ex (1+ ex))) - ((< y 1.0l0) - (do ((m 10.0l0 (* m 10.0l0)) + ((< y 1.0e0) + (do ((m 10.0e0 (* m 10.0e0)) (z y (* y m)) (ex ex (1- ex))) - ((>= z 0.1l0) - (values (float z original-x) ex)))))))))) + ((>= z 0.1e0) + (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)) ;;;; entry point for the float printer @@ -1526,9 +1529,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))) @@ -1583,12 +1587,12 @@ (declare (ignore object stream)) nil) -(defun output-function (object stream) +(defun output-fun (object stream) (let* ((*print-length* 3) ; in case we have to.. (*print-level* 3) ; ..print an interpreted function definition ;; FIXME: This find-the-function-name idiom ought to be ;; encapsulated in a function somewhere. - (name (case (function-subtype object) + (name (case (fun-subtype object) (#.sb!vm:closure-header-widetag "CLOSURE") (#.sb!vm:simple-fun-header-widetag (%simple-fun-name object)) (t 'no-name-available)))