From 7ccc14dfb44255d54efb2cec1bbedb9e779509b6 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Sun, 14 Jun 1992 07:41:22 +0000
Subject: [PATCH] Changed the DEFPRINTER expansion to error if *PRINT-READABLY*
 is set and to print an atomic version of the structure (just its type and
 address) if the depth is below *PRINT-LEVEL*.  Also, use DESCEND-INTO in the
 non-pretty case to parallel the DESCEND-INTO inside the PPRINT-LOGICAL-BLOCK
 in the pretty case.

---
 compiler/macros.lisp | 22 ++++++++++++++--------
 1 file changed, 14 insertions(+), 8 deletions(-)

diff --git a/compiler/macros.lisp b/compiler/macros.lisp
index 2d96903c6..dd584ddfc 100644
--- a/compiler/macros.lisp
+++ b/compiler/macros.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/macros.lisp,v 1.30 1992/03/24 20:35:35 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/macros.lisp,v 1.31 1992/06/14 07:41:22 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -858,11 +858,16 @@
 			    (first option)))))))))
 	     
       `(defun ,(symbolicate "%PRINT-" name) (structure stream depth)
-	 (declare (ignore depth))
 	 (flet ((do-prints (stream)
 		  (declare (ignorable stream))
 		  ,@(prints)))
-	   (cond (*print-pretty*
+	   (cond (*print-readably*
+		  (error "~S cannot be printed readably." structure))
+		 ((and *print-level* (>= depth *print-level*))
+		  (format stream "#<~S ~X>"
+			  ',name
+			  (get-lisp-obj-address structure)))
+		 (*print-pretty*
 		  (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
 		    (pprint-indent :current 2 stream)
 		    (prin1 ',name stream)
@@ -872,11 +877,12 @@
 		      (prin1 (get-lisp-obj-address structure) stream))
 		    (do-prints stream)))
 		 (t
-		  (format stream "#<~S ~X"
-			  ',name
-			  (get-lisp-obj-address structure))
-		  (do-prints stream)
-		  (format stream ">"))))
+		  (descend-into (stream)
+		    (format stream "#<~S ~X"
+			    ',name
+			    (get-lisp-obj-address structure))
+		    (do-prints stream)
+		    (format stream ">")))))
 	 nil))))
 
 
-- 
GitLab