From 0cc03f23cfc7e58cd22e2eb0d80565a336da06b7 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Fri, 17 Feb 2006 15:45:40 +0000
Subject: [PATCH] Handle circularity detection in logical blocks better. 
 (Ported from sbcl.)

---
 code/pprint.lisp |   9 ++--
 code/print.lisp  | 119 ++++++++++++++++++++++++++++++++++-------------
 2 files changed, 93 insertions(+), 35 deletions(-)

diff --git a/code/pprint.lisp b/code/pprint.lisp
index 88a846173..cfe9261b6 100644
--- a/code/pprint.lisp
+++ b/code/pprint.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.63 2006/02/15 19:39:53 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.64 2006/02/17 15:45:40 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -880,7 +880,9 @@ When annotations are present, invoke them at the right positions."
 				`((when (and ,object-var
 					     (plusp ,count-name)
 					     (check-for-circularity
-					      ,object-var))
+					      ,object-var
+					      nil
+					      :logical-block))
 				    (write-string ". " ,stream-var)
 				    (output-object ,object-var ,stream-var)
 				    (return-from ,block-name nil))))
@@ -904,7 +906,8 @@ When annotations are present, invoke them at the right positions."
 	(setf body
 	      `(let ((,object-var ,object))
 		 (if (listp ,object-var)
-		     ,body
+		     (with-circularity-detection (,object-var ,stream-var)
+		       ,body)
 		     (output-object ,object-var ,stream-var)))))
       `(with-pretty-stream (,stream-var ,stream-expression)
 	 ,body))))
diff --git a/code/print.lisp b/code/print.lisp
index 90f05c922..53023eb6e 100644
--- a/code/print.lisp
+++ b/code/print.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.107 2005/08/02 17:14:41 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.108 2006/02/17 15:45:40 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -327,7 +327,7 @@
 
 ;;; CHECK-FOR-CIRCULARITY -- interface.
 ;;;
-(defun check-for-circularity (object &optional assign)
+(defun check-for-circularity (object &optional assign (mode t))
   "Check to see if 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
@@ -338,35 +338,69 @@
 	 ;; 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.
-	    (setf (gethash object *circularity-hash-table*) t)
+	    (setf (gethash object *circularity-hash-table*) mode)
 	    ;; We need to keep looking.
 	    nil)
-	   ((t)
-	    ;; Second encounter.
-	    (setf (gethash object *circularity-hash-table*) 0)
-	    ;; It's a circular reference.
+	   ((:logical-block)
+            (setf (gethash object *circularity-hash-table*)
+                  :logical-block-circular)
 	    t)
-	   (0
+	   ((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)
-	      ;; 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.
+	     ((nil t :logical-block)
+	      ;; If NIL, we found an object that wasn't there the
+	      ;; first time around.  If T or :LOGICAL-BLOCK, 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.
 	      nil)
+             (:logical-block-circular
+	      ;; 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#))))).
+              (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 assign
 		  (let ((value (incf *circularity-counter*)))
@@ -390,7 +424,7 @@
      (let ((*print-circle* nil))
        (error "Attempt to use CHECK-FOR-CIRCULARITY when circularity ~
 	       checking has not been initiated.")))
-    ((t)
+    ((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)
@@ -406,6 +440,28 @@
 	      (write-char #\= stream)
 	      t))))))
 
+(defmacro with-circularity-detection ((object stream) &body body)
+  (let ((marker (gensym "WITH-CIRCULARITY-DETECTION-"))
+        (body-name (gensym "WITH-CIRCULARITY-DETECTION-BODY-")))
+    `(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))))))))
 
 ;;;; Level and Length abbreviations.
 
@@ -464,19 +520,18 @@
 		       (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*
-			 (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)))))))
+	     (multiple-value-bind (marker initiate)
+		 (check-for-circularity object t)
+	       (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)))
+		   (if marker
+                       (when (handle-circularity marker stream)
+                         (print-it stream))
+                       (print-it stream))))))
     (cond ((or (not *print-circle*)
 	       (numberp object)
 	       (characterp object)
-- 
GitLab