"VECTOR-TO-BIT-VECTOR*" "VECTOR-TO-SIMPLE-BIT-VECTOR*"
"VECTOR-OF-CHECKED-LENGTH-GIVEN-LENGTH"
"WITH-ARRAY-DATA"
- "WITH-CIRCULARITY-DETECTION" "WITH-TYPE-CACHES"
"WRONG-NUMBER-OF-INDICES-ERROR"
"FDEFN" "MAKE-FDEFN" "FDEFN-P"
;;; 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 you are not using this inside a WITH-CIRCULARITY-DETECTION,
-;;; then you have to be prepared to handle a return value of :INITIATE
-;;; which means it needs to initiate the circularity detection noise.
+;;; 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*)
- :initiate)
+ (values nil :initiate))
((null *circularity-counter*)
(ecase (gethash object *circularity-hash-table*)
((nil)
(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*
+ (multiple-value-bind (marker initiate)
+ (check-for-circularity object t)
+ ;; initialization of the circulation detect noise ...
+ (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))))
- ((nil)
- (print-it stream))
- (t
- (when (handle-circularity marker stream)
- (print-it stream)))))))
+ (check-it (make-broadcast-stream))
+ (let ((*circularity-counter* 0))
+ (check-it stream)))
+ ;; otherwise
+ (if marker
+ (when (handle-circularity marker stream)
+ (print-it stream))
+ (print-it stream))))))
(cond (;; Maybe we don't need to bother with circularity detection.
(or (not *print-circle*)
(uniquely-identified-by-print-p object))
(output-object (pop list) stream)
(unless list
(return))
- (when (or (atom list) (check-for-circularity list))
+ (when (or (atom list)
+ (check-for-circularity list))
(write-string " . " stream)
(output-object list stream)
(return))
;;; (But with the PURIFY option it seems to work OK.)
(defun save-lisp-and-die (core-file-name &key
(toplevel #'toplevel-init)
- (purify nil)
+ (purify t)
(root-structures ())
(environment-name "auxiliary"))
#!+sb-doc
mkdir animal/vertebrate/mammal/mythical
mkdir animal/vertebrate/mammal/rodent
mkdir animal/vertebrate/mammal/ruminant
+touch animal/vertebrate/mammal/platypus
+touch animal/vertebrate/mammal/walrus
touch animal/vertebrate/mammal/bear/grizzly
touch animal/vertebrate/mammal/mythical/mermaid
touch animal/vertebrate/mammal/mythical/unicorn
--- /dev/null
+;;;; test of the pretty-printer
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package :cl-user)
+
+;;;; tests for former BUG 99, where pretty-printing was pretty messed
+;;;; up, e.g. PPRINT-LOGICAL-BLOCK - because of CHECK-FOR-CIRCULARITY
+;;;; - didn't really work:
+;;;; "DESCRIBE interacts poorly with *PRINT-CIRCLE*, e.g. the output from
+;;;; (let ((*print-circle* t)) (describe (make-hash-table)))
+;;;; is weird, [...] #<HASH-TABLE :TEST EQL :COUNT 0 {90BBFC5}> is an . (EQL)
+;;;; ..."
+;;;; So, this was mainly a pretty printing problem.
+
+;;; Create a circular list.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *circ-list* '(1 1))
+ (prog1 nil
+ (setf (cdr *circ-list*) *circ-list*)))
+
+;;; circular lists are still being printed correctly?
+(assert (equal
+ (with-output-to-string (*standard-output*)
+ (let ((*print-circle* t))
+ (pprint-logical-block (*standard-output* *circ-list*)
+ (format *standard-output* "~S" *circ-list*))))
+ "#1=(1 . #1#)"))
+
+;;; test from CLHS
+(assert (equal
+ (with-output-to-string (*standard-output*)
+ (let ((a (list 1 2 3)))
+ (setf (cdddr a) a)
+ (let ((*print-circle* t))
+ (write a :stream *standard-output*))
+ :done))
+ "#1=(1 2 3 . #1#)"))
+
+;;; test case 1 for bug 99
+(assert (equal
+ (with-output-to-string (*standard-output*)
+ (let* ((*print-circle* t))
+ (format *standard-output* "~@<~S ~_is ~S. This was not seen!~:>"
+ 'eql 'eql)))
+ "EQL is EQL. This was not seen!"))
+
+;;; test case 2 for bug 99
+(assert (equal
+ (with-output-to-string (*standard-output*)
+ (let* ((*print-circle* t))
+ (format *standard-output*
+ "~@<~S ~_is ~S and ~S. This was not seen!~:>"
+ 'eql 'eql 'eql)))
+ "EQL is EQL and EQL. This was not seen!"))
+
+;;; the original test for BUG 99 (only interactive), no obvious
+;;; way to make an automated test:
+;;; (LET ((*PRINT-CIRCLE* T)) (DESCRIBE (MAKE-HASH-TABLE)))
+
+;;; success
+(quit :unix-status 104)
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.121"
+"0.pre7.123"
projects / sbcl.git / commitdiff