-;;;; 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
projects / sbcl.git / blobdiff