*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)
(let ((*package* (find-package "COMMON-LISP-USER"))
;;; 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)
;;; 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)
(output-ugly-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*
+ (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)))))))
+ (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
;; 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 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)
- (/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
;; 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
- (/show0 "in PRINT-OBJECT case")
- (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-in-print*))
+ (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
(fdefn
(output-fdefn object stream))
(t
- (/show0 "in OUTPUT-RANDOM case")
(output-random object stream))))
\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
(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))
;;; 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*))
\f
;;;; integer, ratio, and complex printing (i.e. everything but floats)
(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)))