X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-print.lisp;h=46bd84904367b2227c7a1078185b26f4f2de8129;hb=HEAD;hp=f3e7a744ab445d12bd8c2a2c4a88ea6570e29f97;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git

diff --git a/src/code/early-print.lisp b/src/code/early-print.lisp
index f3e7a74..46bd849 100644
--- a/src/code/early-print.lisp
+++ b/src/code/early-print.lisp
@@ -10,38 +10,203 @@
 ;;;; files for more information.
 
 (in-package "SB!IMPL")
-
-(file-comment
-  "$Header$")
 
 ;;;; level and length abbreviations
 
-(defvar *current-level* 0
-  #!+sb-doc
-  "The current level we are printing at, to be compared against *PRINT-LEVEL*.
-   See the macro DESCEND-INTO for a handy interface to depth abbreviation.")
+;;; The current level we are printing at, to be compared against
+;;; *PRINT-LEVEL*. See the macro DESCEND-INTO for a handy interface to
+;;; depth abbreviation.
+(defvar *current-level-in-print* 0)
 
+;;; Automatically handle *PRINT-LEVEL* abbreviation. If we are too
+;;; deep, then a #\# is printed to STREAM and BODY is ignored.
 (defmacro descend-into ((stream) &body body)
-  #!+sb-doc
-  "Automatically handle *PRINT-LEVEL* abbreviation. If we are too deep, then
-   a # is printed to STREAM and BODY is ignored."
-  (let ((flet-name (gensym)))
+  (let ((flet-name (sb!xc:gensym "DESCEND")))
     `(flet ((,flet-name ()
-	      ,@body))
+              ,@body))
        (cond ((and (null *print-readably*)
-		   *print-level*
-		   (>= *current-level* *print-level*))
-	      (write-char #\# ,stream))
-	     (t
-	      (let ((*current-level* (1+ *current-level*)))
-		(,flet-name)))))))
-
-(defmacro punt-if-too-long (index stream)
-  #!+sb-doc
-  "Punt if INDEX is equal or larger then *PRINT-LENGTH* (and *PRINT-READABLY*
-   is NIL) by outputting \"...\" and returning from the block named NIL."
+                   *print-level*
+                   (>= *current-level-in-print* *print-level*))
+              (write-char #\# ,stream))
+             (t
+              (let ((*current-level-in-print* (1+ *current-level-in-print*)))
+                (,flet-name)))))))
+
+;;; Punt if INDEX is equal or larger then *PRINT-LENGTH* (and
+;;; *PRINT-READABLY* is NIL) by outputting \"...\" and returning from
+;;; the block named NIL.
+(defmacro punt-print-if-too-long (index stream)
   `(when (and (not *print-readably*)
-	      *print-length*
-	      (>= ,index *print-length*))
+              *print-length*
+              (>= ,index *print-length*))
      (write-string "..." ,stream)
      (return)))
+
+
+;;;; circularity detection stuff
+
+;;; When *PRINT-CIRCLE* is T, this gets bound to a hash table that
+;;; (eventually) ends up with entries for every object printed. When
+;;; we are initially looking for circularities, we enter a T when we
+;;; find an object for the first time, and a 0 when we encounter an
+;;; object a second time around. When we are actually printing, the 0
+;;; entries get changed to the actual marker value when they are first
+;;; printed.
+(defvar *circularity-hash-table* nil)
+
+;;; When NIL, we are just looking for circularities. After we have
+;;; found them all, this gets bound to 0. Then whenever we need a new
+;;; 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 true, reference
+;;; bookkeeping will only be done for existing entries, no new
+;;; references will be recorded. If ASSIGN is true, 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 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).
+;;;
+;;; Circularity detection is done in two places, OUTPUT-OBJECT and
+;;; WITH-CIRCULARITY-DETECTION (which is used from PPRINT-LOGICAL-BLOCK).
+;;; These checks aren't really redundant (at least I can't really see
+;;; a clean way of getting by with the checks in only one of the places).
+;;; This causes problems when mixed with pprint-dispatching; an object is
+;;; marked as visited in OUTPUT-OBJECT, dispatched to a pretty printer
+;;; that uses PPRINT-LOGICAL-BLOCK (directly or indirectly), leading to
+;;; output like #1=#1#. The MODE parameter is used for detecting and
+;;; correcting this problem.
+(defun check-for-circularity (object &optional assign (mode t))
+  (cond ((null *print-circle*)
+         ;; Don't bother, nobody cares.
+         nil)
+        ((null *circularity-hash-table*)
+          (values nil :initiate))
+        ((null *circularity-counter*)
+         (ecase (gethash object *circularity-hash-table*)
+           ((nil)
+            ;; first encounter
+            (setf (gethash object *circularity-hash-table*) mode)
+            ;; We need to keep looking.
+            nil)
+           ((:logical-block)
+            (setf (gethash object *circularity-hash-table*)
+                  :logical-block-circular)
+            t)
+           ((t)
+            (cond ((eq mode :logical-block)
+                   ;; We've seen the object before in output-object, and now
+                   ;; a second time in a PPRINT-LOGICAL-BLOCK (for example
+                   ;; via pprint-dispatch). Don't mark it as circular yet.
+                   (setf (gethash object *circularity-hash-table*)
+                         :logical-block)
+                   nil)
+                  (t
+                   ;; second encounter
+                   (setf (gethash object *circularity-hash-table*) 0)
+                   ;; It's a circular reference.
+                   t)))
+           ((0 :logical-block-circular)
+            ;; It's a circular reference.
+            t)))
+        (t
+         (let ((value (gethash object *circularity-hash-table*)))
+           (case value
+             ((nil t :logical-block)
+              ;; If NIL, we found an object that wasn't there the
+              ;; first time around. If T or :LOGICAL-BLOCK, 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)
+             ;; A circular reference to something that will be printed
+             ;; as a logical block. Wait until we're called from
+             ;; PPRINT-LOGICAL-BLOCK with ASSIGN true before assigning the
+             ;; number.
+             ;;
+             ;; If mode is :LOGICAL-BLOCK and assign is false, return true
+             ;; to indicate that this object is circular, but don't assign
+             ;; it a number yet. This is neccessary for cases like
+             ;; #1=(#2=(#2# . #3=(#1# . #3#))))).
+             (:logical-block-circular
+              (cond ((and (not assign)
+                          (eq mode :logical-block))
+                     t)
+                    ((and assign
+                          (eq mode :logical-block))
+                     (let ((value (incf *circularity-counter*)))
+                       ;; first occurrence of this object: Set the counter.
+                       (setf (gethash object *circularity-hash-table*) value)
+                       value))
+                    (t
+                     nil)))
+             (0
+              (if (eq assign t)
+                  (let ((value (incf *circularity-counter*)))
+                    ;; first occurrence of this object: Set the counter.
+                    (setf (gethash object *circularity-hash-table*) value)
+                    value)
+                  t))
+             (t
+              ;; 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)
+  (case marker
+    (:initiate
+     ;; Someone forgot to initiate circularity detection.
+     (let ((*print-circle* nil))
+       (error "trying to use CHECK-FOR-CIRCULARITY when ~
+               circularity checking isn't initiated")))
+    ((t :logical-block)
+     ;; It's a second (or later) reference to the object while we are
+     ;; just looking. So don't bother groveling it again.
+     nil)
+    (t
+     (write-char #\# stream)
+     (let ((*print-base* 10) (*print-radix* nil))
+       (cond ((minusp marker)
+              (output-integer (- marker) stream)
+              (write-char #\# stream)
+              nil)
+             (t
+              (output-integer marker stream)
+              (write-char #\= stream)
+              t))))))
+
+(defmacro with-circularity-detection ((object stream) &body body)
+  (with-unique-names (marker body-name)
+    `(labels ((,body-name ()
+               ,@body))
+      (cond ((not *print-circle*)
+            (,body-name))
+            (*circularity-hash-table*
+             (let ((,marker (check-for-circularity ,object t :logical-block)))
+               (if ,marker
+                   (when (handle-circularity ,marker ,stream)
+                    (,body-name))
+                  (,body-name))))
+            (t
+             (let ((*circularity-hash-table* (make-hash-table :test 'eq)))
+               (output-object ,object (make-broadcast-stream))
+               (let ((*circularity-counter* 0))
+                 (let ((,marker (check-for-circularity ,object t
+                                                       :logical-block)))
+                   (when ,marker
+                     (handle-circularity ,marker ,stream)))
+                (,body-name))))))))
+