From 165bb53b405ab95ce76615ab77cee8284df0a36e Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sat, 12 Jan 2002 16:58:49 +0000 Subject: [PATCH] 0.pre7.123: NJF save.lisp buglet fix sbcl-devel 2002-01-11 MNA "patch for bug 99" sbcl-devel 2002-01-11 (includes symbol and filesys.test.sh cleanups too, not just bug 99) --- package-data-list.lisp-expr | 1 - src/code/print.lisp | 39 +++++++++++++----------- src/code/save.lisp | 2 +- tests/filesys.test.sh | 2 ++ tests/pprint.impure.lisp | 71 +++++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 97 insertions(+), 20 deletions(-) create mode 100644 tests/pprint.impure.lisp diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 2f19617..9b8fd88 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1205,7 +1205,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "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" diff --git a/src/code/print.lisp b/src/code/print.lisp index b3a74a5..03bfd1b 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -291,20 +291,23 @@ ;;; 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) @@ -396,19 +399,20 @@ (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)) @@ -947,7 +951,8 @@ (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)) diff --git a/src/code/save.lisp b/src/code/save.lisp index cb9956f..772fa8e 100644 --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -28,7 +28,7 @@ ;;; (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 diff --git a/tests/filesys.test.sh b/tests/filesys.test.sh index 7530090..28f3935 100644 --- a/tests/filesys.test.sh +++ b/tests/filesys.test.sh @@ -86,6 +86,8 @@ mkdir animal/vertebrate/mammal/bear 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 diff --git a/tests/pprint.impure.lisp b/tests/pprint.impure.lisp new file mode 100644 index 0000000..216c9e0 --- /dev/null +++ b/tests/pprint.impure.lisp @@ -0,0 +1,71 @@ +;;;; 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, [...] # 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) diff --git a/version.lisp-expr b/version.lisp-expr index caeb541..848a908 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; 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" -- 1.7.10.4