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