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.
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
"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"
`((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))))
(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))))
(>= ,index *print-length*))
(write-string "..." ,stream)
(return)))
+
+\f
+;;;; 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))))))
+
(write-char #\> stream))))
nil)
\f
-;;;; 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))))))
-\f
;;;; OUTPUT-OBJECT -- the main entry point
;;; Objects whose print representation identifies them EQLly don't
(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)))
(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*)
(pprint '(frob a b) s))))
(assert (position #\3 s)))
\f
+;; 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= "<A 1 2 3>"
+ (with-output-to-string (s)
+ (write '(a 1 2 3) :stream s))))
+ (assert (string= "#1=<A 1 #1# #2=#(2) #2#>"
+ (with-output-to-string (s)
+ (write '#2=(a 1 #2# #5=#(2) #5#) :stream s))))
+ (assert (string= "#1=(B #2=<A 1 #1# 2 3> #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)))))
+\f
;;; success
(quit :unix-status 104)
;;; 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"
projects / sbcl.git / commitdiff