X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=e2e67d8f732422be2ffedf70fcc99bbca49b0c52;hb=872175cd9cb5b4966a36d4bd92421cc407a0355b;hp=22281e5db0f103fbe7a4dd90b3fca72adbb55fa4;hpb=99bcb3a92b44ce343586f8bd7c717d665f31f4ad;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index 22281e5..e2e67d8 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -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,17 @@ ;;; 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 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. (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) @@ -356,11 +343,10 @@ ;; Second or later occurance. (- 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 +371,13 @@ ;;;; 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) +;;; 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* @@ -435,12 +419,11 @@ (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 +605,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 +762,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 +952,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 +970,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 +985,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))) @@ -1572,10 +1556,6 @@ #(#.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))