X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=205afbe98025649f5755932593673d0f2f84d6b0;hb=bed279acc9bd04eb1bbf56acb0dcaa3b1acf04f0;hp=22281e5db0f103fbe7a4dd90b3fca72adbb55fa4;hpb=99bcb3a92b44ce343586f8bd7c717d665f31f4ad;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index 22281e5..205afbe 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,7 +93,7 @@ *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT *READ-EVAL* T *READ-SUPPRESS* NIL - *READTABLE* the standard readtable." + *READTABLE* the standard readtable" `(%with-standard-io-syntax #'(lambda () ,@body))) (defun %with-standard-io-syntax (function) @@ -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)) @@ -272,18 +272,6 @@ (write-char #\> stream)))) nil) -;;;; WHITESPACE-CHAR-P - -;;; This is used in other files, but is defined in this one for some reason. - -(defun whitespace-char-p (char) - #!+sb-doc - "Determines whether or not the character is considered whitespace." - (or (char= char #\space) - (char= char (code-char tab-char-code)) - (char= char (code-char return-char-code)) - (char= char #\linefeed))) - ;;;; circularity detection stuff ;;; When *PRINT-CIRCLE* is T, this gets bound to a hash table that @@ -300,18 +288,18 @@ ;;; 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. +;;; +;;; 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. (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) @@ -320,12 +308,12 @@ ((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) @@ -336,31 +324,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. @@ -385,15 +373,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* @@ -415,32 +409,25 @@ (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. + (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))))) +;;; 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 @@ -622,7 +609,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. @@ -779,15 +766,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) @@ -969,8 +956,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))) @@ -985,7 +974,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) @@ -1000,21 +989,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))) @@ -1568,19 +1556,12 @@ (defun output-function (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 (function-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)))) @@ -1595,30 +1576,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)))))))))