From 3a2c2a2217f77e0d1a44a581c83e0311ebc2594a Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Sun, 5 Jun 2005 11:37:01 +0000 Subject: [PATCH] 0.9.1.26: Fix some circularity detection issues in the pretty printer. * Move the circularity detection infrastructure into early-print.lisp. * Do circularity checks in PPRINT-LOGICAL-BLOCK. * Add a couple of new tests, disable an old test which is (IMHO) invalid. --- NEWS | 9 +-- package-data-list.lisp-expr | 2 +- src/code/early-pprint.lisp | 7 +- src/code/early-print.lisp | 167 +++++++++++++++++++++++++++++++++++++++++++ src/code/print.lisp | 107 +-------------------------- tests/pprint.impure.lisp | 37 ++++++++++ version.lisp-expr | 2 +- 7 files changed, 218 insertions(+), 113 deletions(-) diff --git a/NEWS b/NEWS index f478b76..80967a5 100644 --- a/NEWS +++ b/NEWS @@ -23,12 +23,13 @@ changes in sbcl-0.9.2 relative to sbcl-0.9.1: the wrong file descriptor; implementation of SOCKET-OPEN-P. (thanks to Tony Martinez) * fixed some bugs revealed by Paul Dietz' test suite: - ** Invalid dotted lists no longer raise a read error when + ** invalid dotted lists no longer raise a read error when *READ-SUPPRESS* is T - ** Signal an error if a symbol that names a declaration is used + ** signal an error if a symbol that names a declaration is used as the name of a type, or vice versa - ** Allow using the (declare (typespec var*)) abbreviation for - (declare (type typespec var*)) with all type specifiers. + ** allow using the (declare (typespec var*)) abbreviation for + (declare (type typespec var*)) with all type specifiers + ** circularity detection works properly with PPRINT-LOGICAL-BLOCK changes in sbcl-0.9.1 relative to sbcl-0.9.0: * fixed cross-compiler leakages that prevented building a 32-bit diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index dba38c8..c07596e 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1423,7 +1423,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "VALUES-TYPES-EQUAL-OR-INTERSECT" "VECTOR-T-P" "VECTOR-NIL-P" "VECTOR-TO-VECTOR*" "VECTOR-OF-CHECKED-LENGTH-GIVEN-LENGTH" "WITH-ARRAY-DATA" - "WRONG-NUMBER-OF-INDICES-ERROR" + "WITH-CIRCULARITY-DETECTION" "WRONG-NUMBER-OF-INDICES-ERROR" ;; bit bash fillers (FIXME: 32/64-bit issues) "UB1-BASH-FILL" "SYSTEM-AREA-UB1-FILL" diff --git a/src/code/early-pprint.lisp b/src/code/early-pprint.lisp index 25d9763..296135a 100644 --- a/src/code/early-pprint.lisp +++ b/src/code/early-pprint.lisp @@ -112,7 +112,9 @@ `((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)))) @@ -140,7 +142,8 @@ (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/src/code/early-print.lisp b/src/code/early-print.lisp index 7df6c18..bb0fcd1 100644 --- a/src/code/early-print.lisp +++ b/src/code/early-print.lisp @@ -41,3 +41,170 @@ (>= ,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) + (let ((marker (gensym "WITH-CIRCULARITY-DETECTION-"))) + `(cond ((not *print-circle*) + ,@body) + (*circularity-hash-table* + (let ((,marker (check-for-circularity ,object t :logical-block))) + (if ,marker + (when (handle-circularity ,marker ,stream) + ,@body) + ,@body))) + (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)))))) + diff --git a/src/code/print.lisp b/src/code/print.lisp index b53c9ec..4d7aa09 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -275,108 +275,6 @@ (write-char #\> stream)))) nil) -;;;; 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 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 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*) - (values nil :initiate)) - ((null *circularity-counter*) - (ecase (gethash object *circularity-hash-table*) - ((nil) - ;; first encounter - (setf (gethash object *circularity-hash-table*) t) - ;; We need to keep looking. - nil) - ((t) - ;; second encounter - (setf (gethash object *circularity-hash-table*) 0) - ;; It's a circular reference. - t) - (0 - ;; 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, 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) - (0 - (if assign - (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) - ;; 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)))))) - ;;;; OUTPUT-OBJECT -- the main entry point ;;; Objects whose print representation identifies them EQLly don't @@ -394,9 +292,8 @@ (sb!pretty:output-pretty-object object stream) (output-ugly-object object stream))) (check-it (stream) - (multiple-value-bind (marker initiate) - (check-for-circularity object t) - ;; initialization of the circulation detect noise ... + (multiple-value-bind (marker initiate) + (check-for-circularity object t) (if (eq initiate :initiate) (let ((*circularity-hash-table* (make-hash-table :test 'eq))) diff --git a/tests/pprint.impure.lisp b/tests/pprint.impure.lisp index 66efdc1..8c68a65 100644 --- a/tests/pprint.impure.lisp +++ b/tests/pprint.impure.lisp @@ -28,6 +28,12 @@ (prog1 nil (setf (cdr *circ-list*) *circ-list*))) +;;; I think this test is bogus. PPRINT-LOGICAL-BLOCK needs to print +;;; the #1= and mark *CIRC-LIST* as having been printed for the first +;;; time. After that any attempt to print *CIRC-LIST* must result in +;;; in a #1# being printed. Thus the right output is (for once) +;;; #1=#1#. -- JES, 2005-06-05 +#+nil ;;; circular lists are still being printed correctly? (assert (equal (with-output-to-string (*standard-output*) @@ -164,5 +170,36 @@ (pprint '(frob a b) s)))) (assert (position #\3 s))) +;; Test that circularity detection works with pprint-logical-block +;; (including when called through pprint-dispatch). +(let ((*print-pretty* t) + (*print-circle* t) + (*print-pprint-dispatch* (copy-pprint-dispatch))) + (labels ((pprint-a (stream form &rest rest) + (declare (ignore rest)) + (pprint-logical-block (stream form :prefix "<" :suffix ">") + (pprint-exit-if-list-exhausted) + (loop + (write (pprint-pop) :stream stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream))))) + (set-pprint-dispatch '(cons (eql a)) #'pprint-a) + (assert (string= "" + (with-output-to-string (s) + (write '(a 1 2 3) :stream s)))) + (assert (string= "#1=" + (with-output-to-string (s) + (write '#2=(a 1 #2# #5=#(2) #5#) :stream s)))) + (assert (string= "#1=(B #2= #2#)" + (with-output-to-string (s) + (write '#3=(b #4=(a 1 #3# 2 3) #4#) :stream s)))))) + +;; Test that a circular improper list inside a logical block works. +(let ((*print-circle* t) + (*print-pretty* t)) + (assert (string= "#1=(#2=(#2# . #3=(#1# . #3#)))" + (with-output-to-string (s) + (write '#1=(#2=(#2# . #3=(#1# . #3#))) :stream s))))) + ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index c4c517d..a7f3c7a 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.1.25" +"0.9.1.26" -- 1.7.10.4