diff --git a/code/print.lisp b/code/print.lisp index b4c452d1f27cfd633bb4826c8b5f9a503ce963f6..b77c2937da6f36629e54cb39ae15fdfad5da39c6 100644 --- a/code/print.lisp +++ b/code/print.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.42 1992/04/21 04:24:01 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.43 1992/06/14 07:08:27 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -29,8 +29,8 @@ (in-package "KERNEL") (export '(*current-level* *pretty-printer* output-object output-ugly-object - check-for-circularity handle-circularity with-circularity-detection - descend-into punt-if-too-long output-symbol-name)) + check-for-circularity handle-circularity descend-into + punt-if-too-long output-symbol-name)) (in-package "LISP") @@ -281,22 +281,6 @@ ;;;; Circularity detection stuff. -;;; *CURRENT-STRUCTURE* -- internal -;;; -;;; We have to bend over backwards in order to make sure depth abbrevs and -;;; circularity detection work right despite the fact that the user supplied -;;; print function may or may not do anything special. -;;; -;;; In order to correctly handle depth abbrevs, OUTPUT-STRUCTURE binds a -;;; this to the structure being output. If the descend-into stuff notices -;;; that we are trying to descend into that structure, we don't bother -;;; doing the depth check/inc because we know it's already been done. But -;;; if we try to descend into something else, then we know that the -;;; structure printer is being stupid and didn't check the depth or for -;;; circularities. -;;; -(defvar *current-structure* nil) - ;;; *CIRCULARITY-HASH-TABLE* -- internal. ;;; ;;; When *print-circle* is T, this gets bound to a hash table that (eventually) @@ -332,9 +316,6 @@ (cond ((null *print-circle*) ;; Don't bother, nobody cares. nil) - ((eq object *current-structure*) - ;; It's already been handled by output-structure. - nil) ((null *circularity-hash-table*) :initiate) ((null *circularity-counter*) @@ -355,13 +336,15 @@ (t (let ((value (gethash object *circularity-hash-table*))) (case value - ((nil) - ;; We found an object that wasn't there the first time around. - (let ((*print-circle* nil)) - (error "Found an object on the second pass that wasn't there ~ - on the first pass."))) - ((t) - ;; Exactly one occurance of this object appears. That's good. + ((nil t) + ;; If NIL, we found an object that wasn't there the first time + ;; around. If T, exactly one occurance of this object appears. + ;; 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 @@ -382,7 +365,7 @@ you should blow it off." (case marker (:initiate - ;; Someone forgor to initiate circularity detection. + ;; Someone forgot to initiate circularity detection. (let ((*print-circle* nil)) (error "Attempt to use CHECK-FOR-CIRCULARITY when circularity ~ checking has not been initiated."))) @@ -402,37 +385,6 @@ (write-char #\= stream) t)))))) -;;; WITH-CIRCULARITY-DETECTION -- interface. -;;; -(defmacro with-circularity-detection ((object stream) &body body) - "Check to see if OBJECT needs to be delt with specially, and if so, do - whatever is necessary. STREAM is the stream that the object is being - printed to (so we know where to print the #n= and #n#). Note: BODY - might be executed twice, so it cannot have any side effects. Also, - while initially looking for circularities, STREAM is rebound to a - stream that ignores all output so it must be a bindable symbol." - (let ((user-body (gensym)) - (checker (gensym))) - (once-only ((object object)) - `(labels ((,user-body (,stream) - (let ((*current-structure* nil)) - ,@body)) - (,checker (,stream) - (let ((marker (check-for-circularity ,object t))) - (case marker - (:initiate - (let ((*circularity-hash-table* - (make-hash-table :test #'eq))) - (,checker (make-broadcast-stream)) - (let ((*circularity-counter* 0)) - (,checker ,stream)))) - ((nil) - (,user-body ,stream)) - (t - (when (handle-circularity marker ,stream) - (,user-body ,stream))))))) - (,checker ,stream))))) - ;;;; Level and Length abbreviations. @@ -444,40 +396,25 @@ ;;; DESCEND-INTO -- interface. ;;; -(defmacro descend-into ((object stream) &body body) - "Automatically handle *print-level* abbreviation and circularity detection. - If we are too deep, then a # is printed to STREAM and BODY is ignored. - If OBJECT isn't NIL, then it is checked to see if it is a circular - reference (see WITH-CIRCULARITY-DETECTION), and handled accordingly. - BODY should do it's output to STREAM (which might be rebound)." - (if object - (once-only ((object object)) - `(if (and (null *print-readably*) - *print-level* - (>= *current-level* *print-level*) - (or (null *current-structure*) - (not (eq *current-structure* ,object)))) - (write-char #\# ,stream) - (with-circularity-detection (,object ,stream) - (let ((*current-level* - (if (or (null *current-structure*) - (not (eq *current-structure* ,object))) - (1+ *current-level*) - *current-level*))) - ,@body)))) - `(if (and (null *print-readably*) - *print-level* - (>= *current-level* *print-level*)) - (write-char #\# ,stream) - (let ((*current-structure* nil) - (*current-level* (1+ *current-level*))) - ,@body)))) +(defmacro descend-into ((stream) &body body) + "Automatically handle *print-level* abbreviation. If we are too deep, then + a # is printed to STREAM and BODY is ignored." + (let ((flet-name (gensym))) + `(flet ((,flet-name () + ,@body)) + (cond ((and (null *print-readably*) + *print-level* + (>= *current-level* *print-level*)) + (write-char #\# ,stream)) + (t + (let ((*current-level* (1+ *current-level*))) + (,flet-name))))))) ;;; PUNT-IF-TOO-LONG -- interface. ;;; (defmacro punt-if-too-long (index stream) "Punt if INDEX is equal or larger then *PRINT-LENGTH* (and *PRINT-READABLY* - is NIL by outputting \"...\" and throwing to the block named NIL." + is NIL) by outputting \"...\" and returning from the block named NIL." `(when (and (not *print-readably*) *print-length* (>= ,index *print-length*)) @@ -498,12 +435,46 @@ ;;; (defun output-object (object stream) "Output OBJECT to STREAM observing all printer control variables." - (if *print-pretty* - (if *pretty-printer* - (funcall *pretty-printer* object stream) - (let ((*print-pretty* nil)) - (output-ugly-object object stream))) - (output-ugly-object object stream))) + (labels ((print-it (stream) + (if *print-pretty* + (if *pretty-printer* + (funcall *pretty-printer* object stream) + (let ((*print-pretty* 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* + (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))))))) + (cond ((or (not *print-circle*) + (numberp object) + (characterp object) + (and (symbolp object) (symbol-package object) t)) + ;; If it a number, character, or interned symbol, we do not want + ;; to check for circularity/sharing. + (print-it stream)) + ((or *circularity-hash-table* + (consp object) + (structurep object) + (typep object '(array t *))) + ;; If we have already started circularity detection, this object + ;; might be a sharded reference. If we have not, then if it is + ;; a cons, a structure, or an array of element type t it might + ;; contain a circular reference to itself or multiple shared + ;; references. + (check-it stream)) + (t + (print-it stream))))) ;;; OUTPUT-UGLY-OBJECT -- interface. ;;; @@ -1020,7 +991,7 @@ ;;;; Recursive objects. (defun output-list (list stream) - (descend-into (list stream) + (descend-into (stream) (write-char #\( stream) (let ((length 0) (list list)) @@ -1054,7 +1025,7 @@ (when (and *print-readably* (not (eq (array-element-type vector) 't))) (error "Cannot print ~S in a readable format." vector)) - (descend-into (vector stream) + (descend-into (stream) (write-string "#(" stream) (dotimes (i (length vector)) (unless (zerop i) @@ -1097,21 +1068,20 @@ (not (eq (array-element-type array) t))) (error "Arrays of element-type ~S cannot be printed readably." (array-element-type array))) - (descend-into (array stream) - (write-char #\# stream) - (let ((*print-base* 10)) - (output-integer (array-rank array) stream)) - (write-char #\A stream) - (with-array-data ((data array) (start) (end)) - (declare (ignore end)) - (sub-output-array-guts data (array-dimensions array) stream start)))) + (write-char #\# stream) + (let ((*print-base* 10)) + (output-integer (array-rank array) stream)) + (write-char #\A stream) + (with-array-data ((data array) (start) (end)) + (declare (ignore end)) + (sub-output-array-guts data (array-dimensions array) stream start))) (defun sub-output-array-guts (array dimensions stream index) (declare (simple-vector array) (fixnum index)) (cond ((null dimensions) (output-object (svref array index) stream)) (t - (descend-into (nil stream) + (descend-into (stream) (write-char #\( stream) (let* ((dimension (car dimensions)) (dimensions (cdr dimensions)) @@ -1136,12 +1106,9 @@ ;;; Defstruct code. (defun output-structure (structure stream) - (let ((*current-structure* nil)) - (descend-into (structure stream) - (let ((*current-structure* structure)) - (funcall (or (info type printer (structure-ref structure 0)) - #'c::default-structure-print) - structure stream *current-level*))))) + (funcall (or (info type printer (structure-ref structure 0)) + #'c::default-structure-print) + structure stream *current-level*)) ;;;; Integer, ratio, and complex printing. (i.e. everything but floats)