From 8ace184823741d140aab261ee288c8b86c266d00 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Thu, 24 Jun 1993 14:18:59 +0000
Subject: [PATCH] Added PRINT-NOT-READABLE condition and made people use it.

---
 code/print.lisp | 58 ++++++++++++++++++++++++-------------------------
 1 file changed, 29 insertions(+), 29 deletions(-)

diff --git a/code/print.lisp b/code/print.lisp
index 4749d657c..81e2dc28d 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.54 1993/05/11 13:42:51 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.55 1993/06/24 14:18:59 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -25,7 +25,8 @@
 	  *print-miser-width* *print-pprint-dispatch* with-standard-io-syntax
 	  write prin1 print princ pprint
 	  write-to-string prin1-to-string princ-to-string
-	  print-unreadable-object))
+	  print-unreadable-object print-not-readable
+	  print-not-readable-object))
 
 (in-package "KERNEL")
 (export '(*current-level* *pretty-printer* output-object output-ugly-object
@@ -244,9 +245,15 @@
 				  `#'(lambda () ,@body)
 				  nil)))
 
+(define-condition print-not-readable (error) (object)
+  (:report
+   (lambda (condition stream)
+    (format stream "~S cannot be printed readably."
+	    (print-not-readable-object condition)))))
+
 (defun %print-unreadable-object (object stream type identity body)
   (when *print-readably*
-    (error "~S cannot be printed readably." object))
+    (error 'print-not-readable :object object))
   (write-string "#<" stream)
   (when type
     (write (type-of object) :stream stream :circle nil
@@ -1016,7 +1023,7 @@
 	(t
 	 (when (and *print-readably*
 		    (not (eq (array-element-type vector) 't)))
-	   (error "Cannot print ~S in a readable format." vector))
+	   (error 'print-not-readable :object vector))
 	 (descend-into (stream)
 	   (write-string "#(" stream)
 	   (dotimes (i (length vector))
@@ -1058,8 +1065,7 @@
 (defun output-array-guts (array stream)
   (when (and *print-readably*
 	     (not (eq (array-element-type array) t)))
-    (error "Arrays of element-type ~S cannot be printed readably."
-	   (array-element-type array)))
+    (error 'print-not-readable :object (array-element-type array)))
   (write-char #\# stream)
   (let ((*print-base* 10))
     (output-integer (array-rank array) stream))
@@ -1550,7 +1556,7 @@
   (cond (*read-eval*
 	 (write-string "#." stream))
 	(*print-readably*
-	 (error "Unable to print infinities readably without #."))
+	 (error 'print-not-readable :object x))
 	(t
 	 (write-string "#<" stream)))
   (write-string "EXT:" stream)
@@ -1567,12 +1573,10 @@
 ;;;    Output a #< NaN or die trying.
 ;;;
 (defun output-float-nan (x stream)
-  (when *print-readably*
-    (error "Can't print NaN's readably."))
-  (write-string "#<" stream)
-  (write-string (float-format-name x) stream)
-  (write-string (if (float-trapping-nan-p x) " Trapping" " Quiet") stream)
-  (write-string " NaN>" stream))
+  (print-unreadable-object (x stream)
+    (write-string (float-format-name x) stream)
+    (write-string (if (float-trapping-nan-p x) " Trapping" " Quiet") stream)
+    (write-string " NaN" stream)))
 
 
 ;;; OUTPUT-FLOAT  --  Internal
@@ -1642,26 +1646,22 @@
   (cond (*read-eval*
 	 (format stream "#.(~S #x~8,'0X)"
 		 'int-sap (sap-int sap)))
-	((not *print-readably*)
-	 (format stream "#<System-Area-Pointer: #x~8,'0X>"
-		 (sap-int sap)))
 	(t
-	 (error "Cannot print system-area-pointers with *READ-EVAL* NIL and ~
-		 *PRINT-READABLY* T."))))
+	 (print-unreadable-object (sap stream)
+	   (format stream "System-Area-Pointer: #x~8,'0X"
+		   (sap-int sap))))))
 
 (defun output-weak-pointer (weak-pointer stream)
   (declare (type weak-pointer weak-pointer))
-  (when *print-readably*
-    (error "Cannot print weak poinrts with *PRINT-READABLY* T."))
-  (multiple-value-bind
-      (value validp)
-      (weak-pointer-value weak-pointer)
-    (cond (validp
-	   (write-string "#<Weak Pointer: " stream)
-	   (write value :stream stream)
-	   (write-char #\> stream))
-	  (t
-	   (write-string "#<Broken Weak Pointer>" stream)))))
+  (print-unreadable-object (weak-pointer stream)
+    (multiple-value-bind
+	(value validp)
+	(weak-pointer-value weak-pointer)
+      (cond (validp
+	     (write-string "Weak Pointer: " stream)
+	     (write value :stream stream))
+	    (t
+	     (write-string "Broken Weak Pointer" stream))))))
 
 (defun output-code-component (component stream)
   (print-unreadable-object (component stream :identity t)
-- 
GitLab