X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=5b1ae0502d22534b79b5d70bb9f22e859e5753ba;hb=29a9ccc860532b32c566aec095f570e999a9c52c;hp=7bb66a9865a73760eeddf8a1b6dbe33284cd8d96;hpb=231721189e1e2431597dc013aaf5eee01bc41a51;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index 7bb66a9..5b1ae05 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -23,42 +23,43 @@ *PRINT-ESCAPE*.") (defvar *print-escape* T #!+sb-doc - "Flag which indicates that slashification is on. See the manual") + "Should we print in a reasonably machine-readable way? (possibly + overridden by *PRINT-READABLY*)") (defvar *print-pretty* nil ; (set later when pretty-printer is initialized) #!+sb-doc - "Flag which indicates that pretty printing is to be used") + "Should pretty printing be used?") (defvar *print-base* 10. #!+sb-doc - "The output base for integers and rationals.") + "the output base for RATIONALs (including integers)") (defvar *print-radix* nil #!+sb-doc - "This flag requests to verify base when printing rationals.") + "Should base be verified when printing RATIONALs?") (defvar *print-level* nil #!+sb-doc - "How many levels deep to print. Unlimited if null.") + "How many levels should be printed before abbreviating with \"#\"?") (defvar *print-length* nil #!+sb-doc - "How many elements to print on each level. Unlimited if null.") + "How many elements at any level should be printed before abbreviating + with \"...\"?") (defvar *print-circle* nil #!+sb-doc - "Whether to worry about circular list structures. See the manual.") + "Should we use #n= and #n# notation to preserve uniqueness in general (and + circularity in particular) when printing?") (defvar *print-case* :upcase #!+sb-doc - "What kind of case the printer should use by default") + "What case should the printer should use default?") (defvar *print-array* t #!+sb-doc - "Whether the array should print its guts out") + "Should the contents of arrays be printed?") (defvar *print-gensym* t #!+sb-doc - "If true, symbols with no home package are printed with a #: prefix. - If false, no prefix is printed.") + "Should #: prefixes be used when printing symbols with null SYMBOL-PACKAGE?") (defvar *print-lines* nil #!+sb-doc - "The maximum number of lines to print. If NIL, unlimited.") + "the maximum number of lines to print per object") (defvar *print-right-margin* nil #!+sb-doc - "The position of the right margin in ems. If NIL, try to determine this - from the stream in use.") + "the position of the right margin in ems (for pretty-printing)") (defvar *print-miser-width* nil #!+sb-doc "If the remaining space between the current column and the right margin @@ -67,8 +68,7 @@ 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. See - COPY-PPRINT-DISPATH, PPRINT-DISPATCH, and SET-PPRINT-DISPATCH.") + "the pprint-dispatch-table that controls how to pretty-print objects") (defmacro with-standard-io-syntax (&body body) #!+sb-doc @@ -93,8 +93,8 @@ *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT *READ-EVAL* T *READ-SUPPRESS* NIL - *READTABLE* the standard readtable." - `(%with-standard-io-syntax #'(lambda () ,@body))) + *READTABLE* the standard readtable" + `(%with-standard-io-syntax (lambda () ,@body))) (defun %with-standard-io-syntax (function) (let ((*package* (find-package "COMMON-LISP-USER")) @@ -148,13 +148,13 @@ ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*)) #!+sb-doc - "Outputs OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*" + "Output OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*" (output-object object (out-synonym-of stream)) object) (defun prin1 (object &optional stream) #!+sb-doc - "Outputs a mostly READable printed representation of OBJECT on the specified + "Output a mostly READable printed representation of OBJECT on the specified STREAM." (let ((*print-escape* T)) (output-object object (out-synonym-of stream))) @@ -162,7 +162,7 @@ (defun princ (object &optional stream) #!+sb-doc - "Outputs an aesthetic but not necessarily READable printed representation + "Output an aesthetic but not necessarily READable printed representation of OBJECT on the specified STREAM." (let ((*print-escape* NIL) (*print-readably* NIL)) @@ -171,7 +171,7 @@ (defun print (object &optional stream) #!+sb-doc - "Outputs a terpri, the mostly READable printed represenation of OBJECT, and + "Output a newline, the mostly READable printed representation of OBJECT, and space to the specified STREAM." (let ((stream (out-synonym-of stream))) (terpri stream) @@ -181,7 +181,7 @@ (defun pprint (object &optional stream) #!+sb-doc - "Prettily outputs OBJECT preceded by a newline." + "Prettily output OBJECT preceded by a newline." (let ((*print-pretty* t) (*print-escape* t) (stream (out-synonym-of stream))) @@ -208,18 +208,18 @@ ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*)) #!+sb-doc - "Returns the printed representation of OBJECT as a string." + "Return the printed representation of OBJECT as a string." (stringify-object object)) (defun prin1-to-string (object) #!+sb-doc - "Returns the printed representation of OBJECT as a string with + "Return the printed representation of OBJECT as a string with slashification on." (stringify-object object t)) (defun princ-to-string (object) #!+sb-doc - "Returns the printed representation of OBJECT as a string with + "Return the printed representation of OBJECT as a string with slashification off." (stringify-object object nil)) @@ -288,32 +288,35 @@ ;;; marker, it is incremented. (defvar *circularity-counter* nil) +;;; 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 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) - #!+sb-doc - "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. Note: CHECK-FOR-CIRCULARITY must - be called *EXACTLY* once with ASSIGN T, 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 T, 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. See the - source for info on how to do that." (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) - ;; First encounter. + ;; first encounter (setf (gethash object *circularity-hash-table*) t) ;; We need to keep looking. nil) ((t) - ;; Second encounter. + ;; second encounter (setf (gethash object *circularity-hash-table*) 0) ;; It's a circular reference. t) @@ -324,31 +327,31 @@ (let ((value (gethash object *circularity-hash-table*))) (case value ((nil t) - ;; If NIL, we found an object that wasn't there the first time - ;; around. If T, exactly one occurance of this object appears. - ;; Either way, just print the thing without any special - ;; processing. Note: you might argue that finding a new object - ;; means that something is broken, but this can happen. If - ;; someone uses the ~@<...~:> format directive, it conses a - ;; new list each time though format (i.e. the &REST list), so - ;; we will have different cdrs. + ;; If NIL, we found an object that wasn't there the + ;; first time around. If T, this object appears exactly + ;; once. Either way, just print the thing without any + ;; special processing. Note: you might argue that + ;; finding a new object means that something is broken, + ;; but this can happen. If someone uses the ~@<...~:> + ;; format directive, it conses a new list each time + ;; though format (i.e. the &REST list), so we will have + ;; different cdrs. nil) (0 (if assign (let ((value (incf *circularity-counter*))) - ;; First occurance of this object. Set the counter. + ;; first occurrence of this object: Set the counter. (setf (gethash object *circularity-hash-table*) value) value) t)) (t - ;; Second or later occurance. + ;; second or later occurrence (- value))))))) +;;; Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then +;;; you should go ahead and print the object. If it returns NIL, then +;;; you should blow it off. (defun handle-circularity (marker stream) - #!+sb-doc - "Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then - you should go ahead and print the object. If it returns NIL, then - you should blow it off." (case marker (:initiate ;; Someone forgot to initiate circularity detection. @@ -373,15 +376,21 @@ ;;;; OUTPUT-OBJECT -- the main entry point -(defvar *pretty-printer* nil - #!+sb-doc - "The current pretty printer. 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.") +;;; 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) + (or (numberp x) + (characterp x) + (and (symbolp x) + (symbol-package x)))) +;;; Output OBJECT to STREAM observing all printer control variables. (defun output-object (object stream) - #!+sb-doc - "Output OBJECT to STREAM observing all printer control variables." (labels ((print-it (stream) (if *print-pretty* (if *pretty-printer* @@ -390,45 +399,45 @@ (output-ugly-object object stream))) (output-ugly-object object stream))) (check-it (stream) - (let ((marker (check-for-circularity object t))) - (case marker - (:initiate - (let ((*circularity-hash-table* + (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)))) - ((nil) - (print-it stream)) - (t - (when (handle-circularity marker stream) - (print-it stream))))))) - (cond ((or (not *print-circle*) - (numberp object) - (characterp object) - (and (symbolp object) (symbol-package object) t)) - ;; If it a number, character, or interned symbol, we do not - ;; want to check for circularity/sharing. + (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)) (print-it stream)) - ((or *circularity-hash-table* - (consp object) - (typep object 'instance) - (typep object '(array t *))) - ;; If we have already started circularity detection, this - ;; object might be a sharded reference. If we have not, - ;; then if it is a cons, a instance, or an array of element - ;; type t it might contain a circular reference to itself - ;; or multiple shared references. + (;; If we have already started circularity detection, this + ;; object might be a shared reference. If we have not, then + ;; if it is a compound object it might contain a circular + ;; reference to itself or multiple shared references. + (or *circularity-hash-table* + (compound-object-p object)) (check-it stream)) (t (print-it stream))))) +;;; 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 +;;; except for *PRINT-PRETTY*. Note: if *PRINT-PRETTY* is non-NIL, +;;; then the pretty printer will be used for any components of OBJECT, +;;; just not for OBJECT itself. (defun output-ugly-object (object stream) - #!+sb-doc - "Output OBJECT to STREAM observing all printer control variables except - for *PRINT-PRETTY*. Note: if *PRINT-PRETTY* is non-NIL, then the pretty - printer will be used for any components of OBJECT, just not for OBJECT - itself." (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 @@ -441,15 +450,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 @@ -457,11 +466,17 @@ (output-symbol object stream) (output-list object stream))) (instance - (print-object object stream)) + (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*)) + (t + (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 @@ -497,19 +512,19 @@ ;;;; 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*)) @@ -523,7 +538,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* @@ -591,7 +606,7 @@ (setup-printer-state) (if (and maybe-quote (symbol-quotep name)) (output-quoted-symbol-name name stream) - (funcall *internal-symbol-output-function* name stream))) + (funcall *internal-symbol-output-fun* name stream))) ;;;; escaping symbols @@ -610,7 +625,7 @@ (declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit)) *character-attributes*)) -;;; Constants which are a bit-mask for each interesting character attribute. +;;; constants which are a bit-mask for each interesting character attribute (defconstant other-attribute (ash 1 0)) ; Anything else legal. (defconstant number-attribute (ash 1 1)) ; A numeric digit. (defconstant uppercase-attribute (ash 1 2)) ; An uppercase letter. @@ -767,15 +782,15 @@ (when (test letter) (advance OTHER nil)) (go START-STUFF) - START-DOT-STUFF ; leading stuff containing dot w/o digit... + START-DOT-STUFF ; leading stuff containing dot without digit... (when (test letter) (advance START-DOT-STUFF nil)) (when (digitp) (advance DOT-DIGIT)) (when (test sign extension dot slash) (advance START-DOT-STUFF nil)) (when (test number other) (advance OTHER nil)) (return t) - START-DOT-MARKER ; number marker in leading stuff w/ dot.. - ;; leading stuff containing dot w/o digit followed by letter... + START-DOT-MARKER ; number marker in leading stuff with dot.. + ;; leading stuff containing dot without digit followed by letter... (when (test letter) (advance OTHER nil)) (go START-DOT-STUFF) @@ -824,10 +839,10 @@ (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: @@ -936,7 +951,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)) @@ -957,8 +973,10 @@ (output-terse-array vector stream)) ((bit-vector-p vector) (write-string "#*" stream) - (dotimes (i (length vector)) - (output-object (aref vector i) stream))) + (dovector (bit vector) + ;; (Don't use OUTPUT-OBJECT here, since this code + ;; has to work for all possible *PRINT-BASE* values.) + (write-char (if (zerop bit) #\0 #\1) stream))) (t (when (and *print-readably* (not (eq (array-element-type vector) t))) @@ -973,7 +991,7 @@ (write-string ")" stream))))) ;;; This function outputs a string quoting characters sufficiently -;;; that so someone can read it in again. Basically, put a slash in +;;; so that someone can read it in again. Basically, put a slash in ;;; front of an character satisfying NEEDS-SLASH-P. (defun quote-string (string stream) (macrolet ((needs-slash-p (char) @@ -988,21 +1006,20 @@ (when (needs-slash-p char) (write-char #\\ stream)) (write-char char stream)))))) +;;; Output the printed representation of any array in either the #< or #A +;;; form. (defun output-array (array stream) - #!+sb-doc - "Outputs the printed representation of any array in either the #< or #A - form." (if (or *print-array* *print-readably*) (output-array-guts array stream) (output-terse-array array stream))) -;;; to output the abbreviated #< form of an array +;;; Output the abbreviated #< form of an array. (defun output-terse-array (array stream) (let ((*print-level* nil) (*print-length* nil)) (print-unreadable-object (array stream :type t :identity t)))) -;;; to output the readable #A form of an array +;;; 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))) @@ -1553,22 +1570,15 @@ (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 - (name (cond ((find (function-subtype object) - #(#.sb!vm:closure-header-type - #.sb!vm:byte-code-closure-type)) - "CLOSURE") - ((sb!eval::interpreted-function-p object) - (or (sb!eval::interpreted-function-%name object) - (sb!eval:interpreted-function-lambda-expression - object))) - ((find (function-subtype object) - #(#.sb!vm:function-header-type - #.sb!vm:closure-function-header-type)) - (%function-name object)) - (t 'no-name-available))) + ;; FIXME: This find-the-function-name idiom ought to be + ;; encapsulated in a function somewhere. + (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))) (identified-by-name-p (and (symbolp name) (fboundp name) (eq (fdefinition name) object)))) @@ -1583,30 +1593,32 @@ (defun output-random (object stream) (print-unreadable-object (object stream :identity t) - (let ((lowtag (get-lowtag object))) + (let ((lowtag (lowtag-of object))) (case lowtag - (#.sb!vm:other-pointer-type - (let ((type (get-type object))) - (case type - (#.sb!vm:value-cell-header-type + (#.sb!vm:other-pointer-lowtag + (let ((widetag (widetag-of object))) + (case widetag + (#.sb!vm:value-cell-header-widetag (write-string "value cell " stream) - (output-object (sb!c:value-cell-ref object) stream)) + (output-object (value-cell-ref object) stream)) (t - (write-string "unknown pointer object, type=" stream) + (write-string "unknown pointer object, widetag=" stream) (let ((*print-base* 16) (*print-radix* t)) - (output-integer type stream)))))) - ((#.sb!vm:function-pointer-type - #.sb!vm:instance-pointer-type - #.sb!vm:list-pointer-type) - (write-string "unknown pointer object, type=" stream)) + (output-integer widetag stream)))))) + ((#.sb!vm:fun-pointer-lowtag + #.sb!vm:instance-pointer-lowtag + #.sb!vm:list-pointer-lowtag) + (write-string "unknown pointer object, lowtag=" stream) + (let ((*print-base* 16) (*print-radix* t)) + (output-integer lowtag stream))) (t - (case (get-type object) - (#.sb!vm:unbound-marker-type + (case (widetag-of object) + (#.sb!vm:unbound-marker-widetag (write-string "unbound marker" stream)) (t (write-string "unknown immediate object, lowtag=" stream) (let ((*print-base* 2) (*print-radix* t)) (output-integer lowtag stream)) - (write-string ", type=" stream) + (write-string ", widetag=" stream) (let ((*print-base* 16) (*print-radix* t)) - (output-integer (get-type object) stream))))))))) + (output-integer (widetag-of object) stream)))))))))