X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=ad0e294cd3498b755d7df713949262a0bcfe826c;hb=e0814eee6f6dea52db010b45a330100f2fe65832;hp=9cb85d17a2b3d6ffc7c42aa42b754eaee5347314;hpb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index 9cb85d1..ad0e294 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -94,7 +94,7 @@ *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")) @@ -291,20 +291,23 @@ ;;; 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) @@ -378,6 +381,14 @@ ;;; 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) (labels ((print-it (stream) @@ -388,40 +399,40 @@ (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))) - ;; If it's a number, character, or interned symbol, we - ;; don't 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 + (;; If we have already started circularity detection, this ;; object might be a shared reference. If we have not, then - ;; if it is a cons, an instance, or an array of element - ;; type T it might contain a circular reference to itself - ;; or multiple shared references. + ;; 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, @@ -439,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 @@ -455,7 +466,13 @@ (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)) @@ -495,8 +512,8 @@ ;;;; 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) @@ -934,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))