*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
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
*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"))
((: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)))
(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))
(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)
(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)))
((: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))
(write-char #\> stream))))
nil)
\f
-;;;; 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)))
-\f
;;;; circularity detection stuff
;;; When *PRINT-CIRCLE* is T, this gets bound to a hash table that
;;; 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)
(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.
\f
;;;; 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*
(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
;; 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
(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 "#<INSTANCE but not STRUCTURE-OBJECT>" 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
\f
;;;; 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*))
(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*
(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)))
\f
;;;; escaping symbols
(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.
(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)
(when (test letter) (advance OTHER nil))
(go DIGIT))))
\f
-;;;; *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:
(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))
(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)))
(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)
(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)))
(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))))
(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)))))))))