From a668d7bd835ea594fec61bf2af31912819958b11 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Mon, 2 Dec 1991 18:57:14 +0000
Subject: [PATCH] Significant rewrite to support *print-readably* at all and to
 better support and *print-circle*, *print-level*, and *print-length*.

---
 code/print.lisp | 1175 +++++++++++++++++++++++++++--------------------
 1 file changed, 665 insertions(+), 510 deletions(-)

diff --git a/code/print.lisp b/code/print.lisp
index bd45892d5..d031fafe9 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.26 1991/11/16 00:22:51 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.27 1991/12/02 18:57:14 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -19,152 +19,136 @@
 
 (in-package "LISP")
 
-(export '(*print-escape* *print-pretty* *print-circle* *print-base*
-	  *print-radix* *print-case* *print-level* *print-length*
-	  *print-array* *print-gensym* write prin1 print princ
-	  write-to-string prin1-to-string princ-to-string))
+(export '(*print-readably* *print-escape* *print-pretty* *print-circle*
+	  *print-base* *print-radix* *print-case* *print-gensym* *print-level*
+	  *print-length* *print-array* *print-lines* *print-right-margin*
+	  *print-miser-width* with-standard-io-syntax
+	  write prin1 print princ pprint
+	  write-to-string prin1-to-string princ-to-string
+	  print-unreadable-object))
 
+
+;;;; Exported printer control variables.
+
+(defvar *print-readably* nil
+  "If true, all objects will printed readably.  If readably printing is
+  impossible, an error will be signalled.  This overrides the value of
+  *PRINT-ESCAPE*.")
 (defvar *print-escape* T
   "Flag which indicates that slashification is on.  See the manual")
 (defvar *print-pretty* nil
   "Flag which indicates that pretty printing is to be used")
 (defvar *print-base* 10.
   "The output base for integers and rationals.")
-(defvar *print-radix* ()
+(defvar *print-radix* nil
   "This flag requests to verify base when printing rationals.")
-(defvar *print-level* ()
+(defvar *print-level* nil
   "How many levels deep to print.  Unlimited if null.")
-(defvar *print-length* ()
+(defvar *print-length* nil
   "How many elements to print on each level.  Unlimited if null.")
-(defvar *print-circle* ()
+(defvar *print-circle* nil
   "Whether to worry about circular list structures. See the manual.")
-(defvar *print-case* ':upcase
+(defvar *print-case* :upcase
   "What kind of case the printer should use by default")
-(defvar *print-array* T
+(defvar *print-array* t
   "Whether the array should print it's guts out")
-(defvar *print-gensym* T
+(defvar *print-gensym* t
   "If true, symbols with no home package are printed with a #: prefix.
   If false, no prefix is printed.")
 
-;;; These next two vars are *not* really fully implemented, but I added them
-;;; here so that I wouldn't be forced to write new code incorrectly.  
-;;;        -- Ram, 9/28/90
-;;;
-(defvar *print-readably* nil
-  "If true, all objects will printed readably.  If readably printing is
-  impossible, an error will be signalled.  This overrides the value of
-  *PRINT-ESCAPE*.  But this isn't really implemented yet.")
-
-(defvar *read-eval* t
-  "If false, then the #. read macro is disabled.  But this isn't really
-  implemented yet.")
-
-
-;;; Imported from reader.
-;;;
-(proclaim '(special *read-default-float-format*))
-
-;;; From the package system.
-;;;
-(proclaim '(special *package* *keyword-package*))
-
-
-;;; DOSTRING -- Internal.
-;;;
-;;; This macro returns code which maps over a string, binding VARIABLE to each
-;;; successive character in the string INIT-FORM, and executing BODY with
-;;; the variable so bound.  This function used to be part of Common Lisp, but
-;;; is no more.  It lives on in the printer, though.
-;;;
-(defmacro dostring ((variable init-form &optional terminate-form) &rest body)
-  (let ((str (gensym))
-	(end (gensym))
-	(index (gensym)))
-    `(let* ((,str ,init-form)
-	    (,end (length (the string ,str)))
-	    (,index 0))
-       (declare (fixnum ,index ,end))
-       (loop
-	 (when (= ,index ,end) (return ,terminate-form))
-	 (let ((,variable (char ,str ,index)))
-	   ,@body)
-	 (incf ,index)))))
-
+(defvar *print-lines* nil)
+(defvar *print-right-margin* nil)
+(defvar *print-miser-width* nil)
+(defvar *print-pprint-dispatch* nil)
+
+(defmacro with-standard-io-syntax (&body body)
+  "Bind the reader and printer control variables to values that enable READ
+   to reliably read the results of PRINT.  These values are:
+       *PACKAGE*			The COMMON-LISP-USER package
+       *PRINT-ARRAY*			T
+       *PRINT-BASE*			10
+       *PRINT-CASE*			:UPCASE
+       *PRINT-CIRCLE*			NIL
+       *PRINT-ESCAPE*			T
+       *PRINT-GENSYM*			T
+       *PRINT-LENGTH*			NIL
+       *PRINT-LEVEL*			NIL
+       *PRINT-LINES*			NIL
+       *PRINT-MISER-WIDTH*		NIL
+       *PRINT-PRETTY*			NIL
+       *PRINT-RADIX*			NIL
+       *PRINT-READABLY*			T
+       *PRINT-RIGHT-MARGIN*		NIL
+       *READ-BASE*			10
+       *READ-DEFAULT-FLOAT-FORMAT* 	SINGLE-FLOAT
+       *READ-EVAL*			T
+       *READ-SUPPRESS*			NIL
+       *READTABLE*			the standard readtable."
+  `(%with-standard-io-syntax #'(lambda () ,@body)))
+
+(defun %with-standard-io-syntax (function)
+  (let ((*package* (find-package "USER"))
+	(*print-array* t)
+	(*print-base* 10)
+	(*print-case* :upcase)
+	(*print-circle* nil)
+	(*print-escape* t)
+	(*print-gensym* t)
+	(*print-length* nil)
+	(*print-level* nil)
+	(*print-lines* nil)
+	(*print-miser-width* nil)
+	(*print-pretty* nil)
+	(*print-radix* nil)
+	(*print-readably* t)
+	(*print-right-margin* nil)
+	(*read-base* 10)
+	(*read-default-float-format* 'single-float)
+	(*read-eval* t)
+	(*read-suppress* nil)
+	(*readtable* std-lisp-readtable))
+    (funcall function)))
 
 
-;;;; Printing Functions
-
-(proclaim '(inline setup-printer-state))
-
-(defvar *previous-case* ()
-  "What the previous case selection the printer was set to.")
-
-;;; This variable contains the current definition of one of three symbol
-;;; printers.  SETUP-PRINTER-STATE sets this variable.
-;;;
-(defvar *internal-symbol-output-function* nil)
-
-;;; SETUP-PRINTER-STATE -- Internal.
-;;;
-;;; This function sets the internal global symbol
-;;; *internal-symbol-output-function* to the right function depending on the
-;;; value of *print-case*.  See the manual for details.  The print buffer
-;;; stream is also reset.
-;;;
-(defun setup-printer-state ()
-  (unless (eq *print-case* *previous-case*)
-    (setq *previous-case* *print-case*)
-    (setq *internal-symbol-output-function*
-	  (case *print-case*
-	    (:upcase #'output-uppercase-symbol)
-	    (:downcase #'output-lowercase-symbol)
-	    (:capitalize #'output-capitalize-symbol)
-	    (T (let ((bad-case *print-case*))
-		 (setq *print-case* :upcase)
-		 (Error "Invalid *print-case* value: ~s" bad-case)))))))
-
+;;;; Routines to print objects.
 
 (defun write (object &key
-		     ((:stream  stream)		     *standard-output*)
-		     ((:escape  *print-escape*)      *print-escape*)
-		     ((:radix   *print-radix*)       *print-radix*)
-		     ((:base    *print-base*)        *print-base*)
-		     ((:circle  *print-circle*)      *print-circle*)
-		     ((:pretty  *print-pretty*)      *print-pretty*)
-		     ((:level   *print-level*)       *print-level*)
-		     ((:length  *print-length*)      *print-length*)
-		     ((:case    *print-case*)        *print-case*)
-		     ((:array   *print-array*)       *print-array*)
-		     ((:gensym  *print-gensym*)      *print-gensym*))
+		     ((:stream stream) *standard-output*)
+		     ((:escape *print-escape*) *print-escape*)
+		     ((:radix *print-radix*) *print-radix*)
+		     ((:base *print-base*) *print-base*)
+		     ((:circle *print-circle*) *print-circle*)
+		     ((:pretty *print-pretty*) *print-pretty*)
+		     ((:level *print-level*) *print-level*)
+		     ((:length *print-length*) *print-length*)
+		     ((:case *print-case*) *print-case*)
+		     ((:array *print-array*) *print-array*)
+		     ((:gensym *print-gensym*) *print-gensym*)
+		     ((:readably *print-readably*) *print-readably*)
+		     ((:right-margin *print-right-margin*) 
+		      *print-right-margin*)
+		     ((:miser-width *print-miser-width*) 
+		      *print-miser-width*)
+		     ((:lines *print-lines*) *print-lines*)
+		     ((:pprint-dispatch *print-pprint-dispatch*)
+		      *print-pprint-dispatch*))
   "Outputs OBJECT to the specified stream, defaulting to *standard-output*"
-  (setup-printer-state)
-  (let ((stream (out-synonym-of stream)))
-    (if *print-pretty*
-	(output-pretty-object object stream)
-	(output-object object stream)))
+  (output-object object (out-synonym-of stream))
   object)
 
 (defun prin1 (object &optional stream)
   "Outputs a mostly READable printed representation of OBJECT on the specified
   stream."
-  (let ((stream (out-synonym-of stream)))
-    (setup-printer-state)
-    (let ((*print-escape* T))
-      (if *print-pretty*
-	  (output-pretty-object object stream)
-	  (output-object object stream)))
-    object))
+  (let ((*print-escape* T))
+    (output-object object (out-synonym-of stream)))
+  object)
 
 (defun princ (object &optional stream)
   "Outputs an asthetic but not READable printed representation of OBJECT on the
   specified stream."
-  (let ((stream (out-synonym-of stream)))
-    (setup-printer-state)
-    (let ((*print-escape* NIL))
-      (if *print-pretty*
-	  (output-pretty-object object stream)
-	  (output-object object stream)))
-    object))
+  (let ((*print-escape* NIL))
+    (output-object object (out-synonym-of stream)))
+  object)
 
 (defun print (object &optional stream)
   "Outputs a terpri, the mostly READable printed represenation of OBJECT, and 
@@ -175,19 +159,35 @@
     (write-char #\space stream)
     object))
 
-(defun write-to-string (object &key
-		     ((:escape  *print-escape*)      *print-escape*)
-		     ((:radix   *print-radix*)       *print-radix*)
-		     ((:base    *print-base*)        *print-base*)
-		     ((:circle  *print-circle*)      *print-circle*)
-		     ((:pretty  *print-pretty*)      *print-pretty*)
-		     ((:level   *print-level*)       *print-level*)
-		     ((:length  *print-length*)      *print-length*)
-		     ((:case    *print-case*)        *print-case*)
-		     ((:array   *print-array*)       *print-array*)
-		     ((:gensym  *print-gensym*)      *print-gensym*))
+(defun pprint (object &optional stream)
+  "Prettily outputs the Object preceded by a newline."
+  (let ((*print-pretty* t)
+	(*print-escape* t))
+    (terpri stream)
+    (output-object object stream))
+  (values))
+
+
+(defun write-to-string
+       (object &key
+	       ((:escape *print-escape*) *print-escape*)
+	       ((:radix *print-radix*) *print-radix*)
+	       ((:base *print-base*) *print-base*)
+	       ((:circle *print-circle*) *print-circle*)
+	       ((:pretty *print-pretty*) *print-pretty*)
+	       ((:level *print-level*) *print-level*)
+	       ((:length *print-length*) *print-length*)
+	       ((:case *print-case*) *print-case*)
+	       ((:array *print-array*) *print-array*)
+	       ((:gensym *print-gensym*) *print-gensym*)
+	       ((:readably *print-readably*) *print-readably*)
+	       ((:right-margin *print-right-margin*) *print-right-margin*)
+	       ((:miser-width *print-miser-width*) *print-miser-width*)
+	       ((:lines *print-lines*) *print-lines*)
+	       ((:pprint-dispatch *print-pprint-dispatch*)
+		*print-pprint-dispatch*))
   "Returns the printed representation of OBJECT as a string."
-  (stringify-object object *print-escape*))
+  (stringify-object object))
 
 (defun prin1-to-string (object)
   "Returns the printed representation of OBJECT as a string with 
@@ -199,129 +199,319 @@
   slashification off."
   (stringify-object object nil))
 
-(defvar *print-string-stream* (make-string-output-stream)
-  "Holds the string stream for the x-TO-STRING functions.")
-
-(defvar *in-stringify-object* ()
-  "T if in the middle of stringify-object.")
-
 ;;; STRINGIFY-OBJECT -- Internal.
 ;;;
 ;;; This produces the printed representation of an object as a string.  The
 ;;; few ...-TO-STRING functions above call this.
 ;;;
-(defun stringify-object (object &optional (*print-escape* nil))
-  (let ((stream (if *in-stringify-object*
-		    (make-string-output-stream)
-		    *print-string-stream*))
-	(*in-stringify-object* t))
+(defvar *string-output-streams* ())
+;;;
+(defun stringify-object (object &optional (*print-escape* *print-escape*))
+  (let ((stream (if *string-output-streams*
+		    (pop *string-output-streams*)
+		    (make-string-output-stream))))
     (setup-printer-state)
-    (if *print-pretty*
-	(output-pretty-object object stream)
-	(output-object object stream 0))
-    (get-output-stream-string stream)))
+    (output-object object stream)
+    (prog1
+	(get-output-stream-string stream)
+      (push stream *string-output-streams*))))
 
 
 
-;;;; Central Print Functions.  
+;;;; PRINT-UNREADABLE-OBJECT macro
 
-;;; OUTPUT-OBJECT -- Internal.
-;;;
-;;; This takes an object and outputs its printed representation to stream,
-;;; which typically is the internal print stream.  This function is called
-;;; recursively by the sub-functions which know how to print structures which
-;;; can contain other lisp objects.
+(defmacro print-unreadable-object ((object stream &key type identity)
+				   &body body)
+  `(%print-unreadable-object ,object ,stream ,type ,identity
+			     ,(if body
+				  `#'(lambda () ,@body)
+				  nil)))
+
+(defun %print-unreadable-object (object stream type identity body)
+  (when *print-readably*
+    (error "~S cannot be printed readably." object))
+  (write-string "#<" stream)
+  (when type
+    (write (type-of object) :stream stream :circle nil :level nil :length nil)
+    (when (or body identity)
+      (write-char #\space stream)))
+  (when body
+    (funcall body))
+  (when identity
+    (when body
+      (write-char #\space stream))
+    (write-char #\{ stream)
+    (write (get-lisp-obj-address object) :stream stream :radix nil :base 16)
+    (write-char #\} stream))
+  (write-char #\> stream))
+
+
+;;;; WHITESPACE-CHAR-P
+
+;;; This is used in other files, but is defined in this one for some reason.
+
+(defun whitespace-char-p (char)
+  "Determines whether or not the character is considered whitespace."
+  (or (char= char #\space)
+      (char= char #\tab)
+      (char= char #\return)
+      (char= char #\linefeed)))
+
+
+;;;; Circularity detection stuff.
+
+(defvar *circularity-hash-table* nil)
+
+(defvar *circularity-counter* nil)
+
+;;; CHECK-FOR-CIRCULARITY -- interface.
 ;;;
-(defun output-object (object stream &optional (currlevel 0))
-  "Outputs a string which is the printed representation of the given object."
-  ;; First check and make sure we aren't too deep
-  (declare (fixnum currlevel))
-  (if (and (not (null *print-level*))
-	   (not (= *print-level* 0))
-	   (>= currlevel (the fixnum *print-level*)))
-      (write-char #\# stream)
-      (typecase object
-	(symbol
-	 (if *print-escape*
-	     (output-symbol object stream)
-	     (case *print-case*
-	       (:upcase (write-string (symbol-name object) stream))
-	       (:downcase
-		(let ((name (symbol-name object)))
-		  (declare (simple-string name))
-		  (dotimes (i (length name))
-		    (write-char (char-downcase (char name i)) stream))))
-	       (:capitalize
-		(write-string (string-capitalize (symbol-name object))
-			      stream)))))
-	;; If a list, go through element by element, being careful
-	;; about not running over the printlength
-	(list
-	 (output-list object stream (1+ currlevel)))
-	(string
-	 (if *print-escape*
-	     (quote-string object stream)
-	     (write-string object stream)))
-	(integer
-	 (output-integer object stream))
-	(float
-	 (output-float object stream))
-	(ratio
-	 (output-ratio object stream))
-	(complex
-	 (output-complex object stream))
-	(structure
-	 (output-structure object stream currlevel))
-	(character
-	 (output-character object stream))
-	(vector
-	 (output-vector object stream))
-	(array
-	 (output-array object stream (1+ currlevel)))
-	(system-area-pointer
-	 (output-sap object stream))
-	(weak-pointer
-	 (output-weak-pointer object stream))
+;;; Check to see if OBJECT is a circular reference, and return T if it is and
+;;; NIL if not.  Note: this function must be called *exactly* once with
+;;; assign T for every potentially circular object.  
+;;; 
+(defun check-for-circularity (object &optional assign)
+  (cond ((null *print-circle*)
+	 ;; Don't bother, nobody cares.
+	 nil)
+	((null *circularity-hash-table*)
+	 :initiate)
+	((null *circularity-counter*)
+	 (ecase (gethash object *circularity-hash-table*)
+	   ((nil)
+	    ;; First encounter.
+	    (setf (gethash object *circularity-hash-table*) t)
+	    ;; We need to keep looking.
+	    nil)
+	   ((t)
+	    ;; Second encounter.
+	    (setf (gethash object *circularity-hash-table*) 0)
+	    ;; It's a circular reference.
+	    t)
+	   (0
+	    ;; It's a circular reference.
+	    t)))
 	(t
-	 (if (and (fboundp 'funcallable-instance-p)
-		  (funcallable-instance-p object))
-	     (pcl:print-object object stream)
-	     (output-random object stream))))))
+	 (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)
+	     (0
+	      (if assign
+		  (let ((value (incf *circularity-counter*)))
+		    ;; First occurance of this object.  Set the counter.
+		    (setf (gethash object *circularity-hash-table*) value)
+		    value)
+		  t))
+	     (t
+	      ;; Second or later occurance.
+	      (- value)))))))
+
+(defun handle-circularity (marker stream)
+  (case marker
+    (:initiate
+     ;; Someone forgor to initiate circularity detection.
+     (let ((*print-circle* nil))
+       (error "Attempt to use CHECK-FOR-CIRCULARITY when circularity ~
+	       checking has not been initiated.")))
+    ((t)
+     ;; It's a second (or later) reference to the object while we are
+     ;; just looking.  So don't bother groveling it again.
+     nil)
+    (t
+     (write-char #\# stream)
+     (let ((*print-base* 10) (*print-radix* nil))
+       (cond ((minusp marker)
+	      (output-integer (- marker) stream)
+	      (write-char #\# stream)
+	      nil)
+	     (t
+	      (output-integer marker stream)
+	      (write-char #\= stream)
+	      t))))))
+
+(defmacro with-circularity-detection ((object stream) &body body)
+  (let ((user-body (gensym))
+	(checker (gensym)))
+    (once-only ((object object))
+      `(labels ((,user-body (,stream)
+		  ,@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)))))
 
 
-;;;; Symbol Printing Subfunctions
+;;;; Level and Length abbreviations.
+
+(defvar *current-level* 0)
+
+(defmacro decend-into ((object stream) &body body)
+  (let ((guts `(let ((*current-level* (1+ *current-level*)))
+		 ,@body)))
+    `(if (and (null *print-readably*)
+	      *print-level*
+	      (>= *current-level* *print-level*))
+	 (write-char #\# ,stream)
+	 ,(if object
+	      `(with-circularity-detection (,object ,stream)
+		 ,guts)
+	      guts))))
+
+(defmacro punt-if-too-long (index stream)
+  `(when (and (not *print-readably*)
+	      *print-length*
+	      (>= ,index *print-length*))
+     (write-string "..." ,stream)
+     (return)))
 
-(defun output-symbol (object stream)
-  (let ((package (symbol-package object))
-	(name (symbol-name object)))
-    (cond
-     ;; If the symbol's home package is the current one, then a
-     ;; prefix is never necessary.
-     ((eq package *package*))
-     ;; If the symbol is in the keyword package, output a colon.
-     ((eq package *keyword-package*)
-      (write-char #\: stream))
-     ;; Uninterned symbols print with a leading #:.
-     ((null package)
-      (when *print-gensym* (write-string "#:" stream)))
-     (t
-      (multiple-value-bind (symbol accessible)
-			   (find-symbol name *package*)
-	;; If we can find the symbol by looking it up, it need not be
-	;; qualified.  This can happen if the symbol has been inherited
-	;; from a package other than its home package.
-	(unless (and accessible (eq symbol object))
-	  (funcall *internal-symbol-output-function*
-		   (package-name package)
-		   stream)
-	  (multiple-value-bind (symbol externalp)
-			       (find-external-symbol name package)
-	    (declare (ignore symbol))
-	    (if externalp
-		(write-char #\: stream)
-		(write-string "::" stream)))))))
-    (funcall *internal-symbol-output-function* name stream)))
+
+;;;; OUTPUT-OBJECT -- the main entry point.
+
+(defvar *pretty-printer* nil)
+
+(defun output-object (object stream)
+  (if (and *print-pretty* *pretty-printer*)
+      (funcall *pretty-printer* object stream)
+      (output-ugly-object object stream)))
+
+(defun output-ugly-object (object stream)
+  (typecase object
+    (fixnum
+     (output-integer object stream))
+    (list
+     (if (null object)
+	 (output-symbol object stream)
+	 (output-list object stream)))
+    (structure
+     (output-structure object stream))
+    (function
+     (if (and (fboundp 'funcallable-instance-p)
+	      (funcallable-instance-p object))
+	 (pcl:print-object object stream)
+	 (output-function object stream)))
+    (symbol
+     (output-symbol object stream))
+    (number
+     (etypecase object
+       (integer
+	(output-integer object stream))
+       (float
+	(output-float object stream))
+       (ratio
+	(output-ratio object stream))
+       (ratio
+	(output-ratio object stream))
+       (complex
+	(output-complex object stream))))
+    (character
+     (output-character object stream))
+    (vector
+     (output-vector object stream))
+    (array
+     (output-array object stream))
+    (system-area-pointer
+     (output-sap object stream))
+    (weak-pointer
+     (output-weak-pointer object stream))
+    (t
+     (output-random object stream))))
+
+
+;;;; Symbols.
+
+(defvar *previous-case* ()
+  "What the previous case selection the printer was set to.")
+
+;;; This variable contains the current definition of one of three symbol
+;;; printers.  SETUP-PRINTER-STATE sets this variable.
+;;;
+(defvar *internal-symbol-output-function* nil)
+
+;;; SETUP-PRINTER-STATE -- Internal.
+;;;
+;;; This function sets the internal global symbol
+;;; *internal-symbol-output-function* to the right function depending on the
+;;; value of *print-case*.  See the manual for details.  The print buffer
+;;; stream is also reset.
+;;;
+(defun setup-printer-state ()
+  (unless (eq *print-case* *previous-case*)
+    (setq *previous-case* *print-case*)
+    (setq *internal-symbol-output-function*
+	  (case *print-case*
+	    (:upcase #'output-uppercase-symbol)
+	    (:downcase #'output-lowercase-symbol)
+	    (:capitalize #'output-capitalize-symbol)
+	    (T (let ((bad-case *print-case*))
+		 (setq *print-case* :upcase)
+		 (Error "Invalid *print-case* value: ~s" bad-case)))))))
 
+(defun output-symbol (object stream)
+  (if (or *print-escape* *print-readably*)
+      (let ((package (symbol-package object))
+	    (name (symbol-name object)))
+	(setup-printer-state)
+	(cond
+	 ;; If the symbol's home package is the current one, then a
+	 ;; prefix is never necessary.
+	 ((eq package *package*))
+	 ;; If the symbol is in the keyword package, output a colon.
+	 ((eq package *keyword-package*)
+	  (write-char #\: stream))
+	 ;; Uninterned symbols print with a leading #:.
+	 ((null package)
+	  (when (or *print-circle* *print-readably*)
+	    (let ((marker (check-for-circularity object t)))
+	      (case marker
+		((:initiate nil))
+		(t
+		 (unless (handle-circularity marker stream)
+		   (return-from output-symbol nil))))))
+	  (when (or *print-gensym* *print-readably*)
+	    (write-string "#:" stream)))
+	 (t
+	  (multiple-value-bind (symbol accessible)
+			       (find-symbol name *package*)
+	    ;; If we can find the symbol by looking it up, it need not be
+	    ;; qualified.  This can happen if the symbol has been inherited
+	    ;; from a package other than its home package.
+	    (unless (and accessible (eq symbol object))
+	      (funcall *internal-symbol-output-function*
+		       (package-name package)
+		       stream)
+	      (multiple-value-bind (symbol externalp)
+				   (find-external-symbol name package)
+		(declare (ignore symbol))
+		(if externalp
+		    (write-char #\: stream)
+		    (write-string "::" stream)))))))
+	(funcall *internal-symbol-output-function* name stream))
+      (case *print-case*
+	(:upcase
+	 (write-string (symbol-name object) stream))
+	(:downcase
+	 (write-string (string-downcase (symbol-name object)) stream))
+	(:capitalize
+	 (write-string (string-capitalize (symbol-name object))
+		       stream)))))
 
 
 ;;;; Escaping symbols:
@@ -536,8 +726,9 @@
      MARKER ; Number marker in a numeric number...
       (when (test letter) (advance OTHER nil))
       (go DIGIT))))
+
 
-;;;; Pathname hackery
+;;;; Printname hackery
 
 ;;; This function takes the pname of a symbol and adds slashes and/or 
 ;;; vertical bars to it to make it readable again.
@@ -605,127 +796,52 @@
 
 
 
-;;;; Recursive Datatype Printing Subfunctions
-
-(defun output-list (list stream &optional (currlevel 0))
-  (write-char #\( stream)
-  (do ((list list (cdr list))
-       (currlength 0 (1+ currlength)))
-      ((or (null list)
-	   (and (not (null *print-length*))
-		(>= currlength (the fixnum *print-length*))))
-       (if (not (null list)) (write-string " ..." stream))
-       (write-char #\) stream))
-    (declare (fixnum currlength))
-    ;;If we are not printing the first object, we should space first.
-    (if (> currlength 0) (write-char #\space stream))
-    ;;Print whatever the car of the list is, at this level.
-    (output-object (car list) stream currlevel)
-    (cond ((not (or (consp (cdr list))
-		    (null (cdr list))))
-	   (write-string " .  " stream)
-	   (output-object (cdr list) stream currlevel)
-	   (write-char #\) stream)
-	   (return ())))))
- 
-(defun output-vector (vector stream &optional (currlevel 0))
-  (declare (fixnum currlevel))
-  (cond ((not *print-array*)
-	 (output-terse-array vector stream currlevel))
-	(T
-	 (if (bit-vector-p vector)
-	     (write-string "#*" stream)
-	     (write-string "#(" stream))
-	 (do ((currlength 0 (1+ currlength))
-	      (vlength (length (the vector vector)))
-	      (not-bit-vector-p (not (bit-vector-p vector))))
-	     ((or (and (not (null *print-length*))
-		       (>= currlength (the fixnum *print-length*)))
-		  (= currlength vlength))
-	      (if (not (= currlength vlength)) (write-string " ..." stream))
-	      (if not-bit-vector-p
-		  (write-char #\) stream)))
-	   (declare (fixnum currlength vlength))
-	 ;;Put a space before every element except the first
-	 ;; and not in bit vectors.
-	 (if (and (> currlength 0) not-bit-vector-p)
-	     (write-char #\space stream))
-	 ;;Output an element of the vector
-	 (output-object (aref vector currlength) stream currlevel)))))
-
-(defun output-array (array stream &optional (currlevel 0))
-  "Outputs the printed representation of any array in either the #< or #A form."
-  (let ((rank (array-rank array)))
-    (cond ((not *print-array*)
-	   (output-terse-array array stream rank))
-	  (T
-	   (output-array-guts array rank stream currlevel)))))
-
-;;; Master function for outputing the #A form of an array
-;;;
-(defun output-array-guts (array rank stream currlevel)
-  (write-char #\# stream)
-  (let ((*print-base* 10))
-    (output-integer rank stream))
-  (write-char #\A stream)
-  (with-array-data ((data array) (start) (end))
-    (declare (ignore end))
-    (sub-output-array-guts data (array-dimensions array)
-			   stream currlevel start)))
-
-;;; Some Ideas stolen from Skef Wholey.
-;;; Helping function for above.
-(defun sub-output-array-guts (array dimensions stream currlevel index)
-  (declare (fixnum currlevel index))
-  (cond ((null dimensions)
-	 (output-object (aref array index) stream currlevel)
-	 (1+ index))
-	((and (not (null *print-level*))
-	      (>= currlevel (the fixnum *print-level*)))
-	 (write-char #\# stream)
-	 index)
+;;;; Recursive objects.
+
+(defun output-list (list stream)
+  (decend-into (list stream)
+    (write-char #\( stream)
+    (let ((length 0)
+	  (list list))
+      (loop
+	(punt-if-too-long length stream)
+	(output-object (pop list) stream)
+	(unless list
+	  (return))
+	(when (or (atom list) (check-for-circularity list))
+	  (write-string " . " stream)
+	  (output-object list stream)
+	  (return))
+	(write-char #\space stream)
+	(incf length)))
+    (write-char #\) stream)))
+
+
+(defun output-vector (vector stream)
+  (declare (vector vector))
+  (if (or *print-array* *print-readably*)
+      (typecase vector
+	(bit-vector
+	 (write-string "#*" stream)
+	 (dotimes (i (length vector))
+	   (output-object (aref vector i) stream)))
+	(string
+	 (if (or *print-escape* *print-readably*)
+	     (quote-string vector stream)
+	     (write-string vector stream)))
 	(t
-	 (write-char #\( stream)
-	 (do ((index index)
-	      (times 0 (1+ times))
-	      (limit (pop dimensions)))
-	     ((or (= times limit)
-		  (and (not (null *print-length*))
-		       (= times *print-length*)))
-	      (if (not (= times limit))
-		  (write-string " ...)" stream)
-		  (write-char #\) stream))
-	      index)
-	   (declare (fixnum index times limit))
-	   (if (not (zerop times)) (write-char #\space stream))
-	   (setq index
-		 (sub-output-array-guts array dimensions
-					stream (1+ currlevel) index))))))
-
-;;; Used to output the #< form of any array.
-;;;
-(defun output-terse-array (array stream rank)
-  (write-string "#<" stream)
-  (cond ((vectorp array)
-	 (if (bit-vector-p array)
-	     (write-string "Bit-vector" stream)
-	     (write-string "Vector" stream)))
-	(T
-	 (write-string "Array, rank " stream)
-	 (output-integer rank stream)))
-  (finish-random array stream))
-
-
-;;; Structure Printing.  These days we can always pass the buck to the
-;;; Defstruct code.
-
-(defun output-structure (structure stream currlevel)
-  (funcall (or (info type printer (structure-ref structure 0))
-	       #'c::default-structure-print)
-	   structure stream currlevel))
-
-
-;;;; Functions to help print strings.
+	 (when (and *print-readably*
+		    (not (eq (array-element-type vector) 't)))
+	   (error "Cannot print ~S in a readable format." vector))
+	 (decend-into (vector stream)
+	   (write-string "#(" stream)
+	   (dotimes (i (length vector))
+	     (unless (zerop i)
+	       (write-char #\space stream))
+	     (punt-if-too-long i stream)
+	     (output-object (aref vector i) stream))
+	   (write-string ")" stream))))
+      (output-terse-array vector stream)))
 
 ;;; QUOTE-STRING -- Internal.
 ;;;
@@ -744,46 +860,97 @@
       (write-char char stream))
     (write-char #\" stream)))
 
+(defun output-array (array stream)
+  "Outputs the printed representation of any array in either the #< or #A
+   form."
+  (if (or *print-array* *print-readably*)
+      (output-array-guts array stream)
+      (output-terse-array array stream)))
+
+;;; Master function for outputing the #A form of an array
+;;;
+(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)))
+  (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
+	 (decend-into (nil stream)
+	   (write-char #\( stream)
+	   (let* ((dimension (car dimensions))
+		  (dimensions (cdr dimensions))
+		  (count (reduce #'* dimensions)))
+	     (dotimes (i dimension)
+	       (unless (zerop i)
+		 (write-char #\space stream))
+	       (punt-if-too-long i stream)
+	       (sub-output-array-guts array dimensions stream index)
+	       (incf index count)))
+	   (write-char #\) stream)))))
+
+;;; Used to output the #< form of any array.
+;;;
+(defun output-terse-array (array stream)
+  (let ((*print-level* nil)
+	(*print-length* nil))
+    (print-unreadable-object (array stream :type t :identity t))))
+
+
+;;; Structure Printing.  These days we can always pass the buck to the
+;;; Defstruct code.
+
+(defun output-structure (structure stream)
+  (decend-into (structure stream)
+    (funcall (or (info type printer (structure-ref structure 0))
+		 #'c::default-structure-print)
+	     structure stream *current-level*)))
 
-(defun whitespace-char-p (char)
-  "Determines whether or not the character is considered whitespace."
-  (or (char= char #\space)
-      (char= char #\tab)
-      (char= char #\return)
-      (char= char #\linefeed)))
 
-;;;; Integer, ratio, complex printing.
+;;;; Integer, ratio, and complex printing.  (i.e. everything but floats)
 
 (defun output-integer (integer stream)
-  (cond ((not (and (fixnump *print-base*) (> (the fixnum *print-base*) 1)))
-	 (let ((obase *print-base*))
-	   (setq *print-base* 10.)
-	   (error "~A is not a reasonable value for *Print-Base*." obase)))
-	;; Otherwise print the base
-	(T (cond ((and (not (= *print-base* 10.))
-		       *print-radix*)
-		  ;; First print leading base information, if any.
-		  (write-char #\# stream)
-		  (write-char (case *print-base*
-				(2.  #\b)
-				(8.  #\o)
-				(16. #\x)
-				(T (let ((fixbase *print-base*)
-					 (*print-base* 10.)
-					 (*print-radix* ()))
-				     (sub-output-integer fixbase stream))
-				   #\r))
-			      stream)))
-	   ;; Then output a minus sign if the number is negative, then output
-	   ;; the absolute value of the number.
-	   (cond ((bignump integer) (print-bignum integer stream))
-		 ((< integer 0)
-		  (write-char #\- stream)
-		  (sub-output-integer (- integer) stream))
-		 (T (sub-output-integer integer stream)))
-	   ;; Print any trailing base information, if any.
-	   (if (and (= *print-base* 10.) *print-radix*)
-	       (write-char #\. stream)))))
+  (unless (and (fixnump *print-base*)
+	       (< 1 *print-base* 37))
+    (let ((obase *print-base*))
+      (setq *print-base* 10.)
+      (error "~A is not a reasonable value for *Print-Base*." obase)))
+  (when (and (not (= *print-base* 10.))
+	     *print-radix*)
+    ;; First print leading base information, if any.
+    (write-char #\# stream)
+    (write-char (case *print-base*
+		  (2.  #\b)
+		  (8.  #\o)
+		  (16. #\x)
+		  (T (let ((fixbase *print-base*)
+			   (*print-base* 10.)
+			   (*print-radix* ()))
+		       (sub-output-integer fixbase stream))
+		     #\r))
+		stream))
+  ;; Then output a minus sign if the number is negative, then output
+  ;; the absolute value of the number.
+  (cond ((bignump integer) (print-bignum integer stream))
+	((< integer 0)
+	 (write-char #\- stream)
+	 (sub-output-integer (- integer) stream))
+	(t
+	 (sub-output-integer integer stream)))
+  ;; Print any trailing base information, if any.
+  (if (and (= *print-base* 10.) *print-radix*)
+      (write-char #\. stream)))
 
 (defun sub-output-integer (integer stream)
   (let ((quotient ())
@@ -800,30 +967,6 @@
 			       (+ (char-code #\0) remainder)))
 		stream)))
 
-
-(defun output-ratio (ratio stream)
-  (when *print-radix*
-    (write-char #\# stream)
-    (case *print-base*
-      (2 (write-char #\b stream))
-      (8 (write-char #\o stream))
-      (16 (write-char #\x stream))
-      (t (write *print-base* :stream stream :radix nil :base 10)))
-    (write-char #\r stream))
-  (let ((*print-radix* nil))
-    (output-integer (numerator ratio) stream)
-    (write-char #\/ stream)
-    (output-integer (denominator ratio) stream)))
-
-(defun output-complex (complex stream)
-  (write-string "#C(" stream)
-  (output-object (realpart complex) stream)
-  (write-char #\space stream)
-  (output-object (imagpart complex) stream)
-  (write-char #\) stream))
-
-
-
 ;;;; Bignum printing
 
 ;;; Written by Steven Handerson
@@ -881,7 +1024,30 @@
 	 (sub-output-integer fix stream)))))
 
 
+(defun output-ratio (ratio stream)
+  (when *print-radix*
+    (write-char #\# stream)
+    (case *print-base*
+      (2 (write-char #\b stream))
+      (8 (write-char #\o stream))
+      (16 (write-char #\x stream))
+      (t (write *print-base* :stream stream :radix nil :base 10)))
+    (write-char #\r stream))
+  (let ((*print-radix* nil))
+    (output-integer (numerator ratio) stream)
+    (write-char #\/ stream)
+    (output-integer (denominator ratio) stream)))
+
+(defun output-complex (complex stream)
+  (write-string "#C(" stream)
+  (output-object (realpart complex) stream)
+  (write-char #\space stream)
+  (output-object (imagpart complex) stream)
+  (write-char #\) stream))
+
 
+;;;; Float printing.
+
 ;;;
 ;;;  Written by Bill Maddox
 ;;;
@@ -1262,17 +1428,7 @@
 	  (print-float-exponent x (1- ex) stream)))))
 
 
-;;;; Output Character
-
-;;; FUNNY-CHARACTER-CHAR-P returns a predicate which determines whether a
-;;; character must be slashified when being output.
-;;;
-(defmacro funny-character-char-p (char)
-;  (and (not (zerop (char-bits ,char)))
-;	(not (zerop (logand (aref character-attributes (char-code ,char))
-;			    funny-attribute))))
-  `(not (zerop (logand (aref character-attributes (char-code ,char))
-		       funny-attribute))))
+;;;; Other leaf objects.
 
 ;;; OUTPUT-CHARACTER  --  Internal
 ;;;
@@ -1280,7 +1436,7 @@
 ;;; character name or the character in the #\char format.
 ;;;
 (defun output-character (char stream)
-  (if *print-escape*
+  (if (or *print-escape* *print-readably*)
       (let ((name (char-name char)))
 	(write-string "#\\" stream)
 	(if name
@@ -1288,8 +1444,34 @@
 	    (write-char char stream)))
       (write-char char stream)))
 
+(defun output-sap (sap stream)
+  (declare (type system-area-pointer sap))
+  (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."))))
+
+(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)))))
+
 
-;;;; Random and Miscellaneous Print Subfunctions
+;;;; Various flavors of function pointers.
 
 
 ;;; OUTPUT-FUNCTION-OBJECT outputs the main part of the printed 
@@ -1314,89 +1496,62 @@
     (let ((*print-level* 3))
       (format stream "Interpreted Function ~S" (or name def)))))
 
+(defun output-function (function stream)
+  (print-unreadable-object (function stream :identity t)
+    (case (get-type function)
+      ((#.vm:function-header-type #.vm:closure-function-header-type)
+       (output-function-object function stream))
+      (#.vm:closure-header-type
+       (cond
+	((eval:interpreted-function-p function)
+	 (output-interpreted-function function stream))
+	(t
+	 (write-string "Closure Over " stream)
+	 (output-function-object (%primitive c::closure-function function)
+				 stream)))))))
+    
 
-;;; FINISH-RANDOM is a helping function for OUTPUT-RANDOM below.  
-;;; It outputs the numerical value of the low 28 bits of 
-;;; RANDOM-OBJECT, enclosed in braces, followed by the closing
-;;; angle-bracket (">") random objects have at the end.  This
-;;; is used to distringuish random objects of the same type.
-
-(defun finish-random (random-object stream)
-  (write-string " {" stream)
-  (let ((*print-base* 16))
-    (output-integer (%primitive make-fixnum random-object) stream))
-  (write-string "}>" stream))
-
-;;; Functions Objects and other implmentation specific objects 
-;;; are output here. 
+
+;;;; Catch-all for unknown things.
 
 (defun output-random (object stream)
-  (write-string "#<" stream)
-  (let ((lowtag (get-lowtag object)))
-    (case lowtag
-      ((#.vm:other-pointer-type #.vm:function-pointer-type)
-       (let ((type (get-type object)))
-	 (case type
-	   (#.vm:code-header-type
-	    (let ((dinfo (code-header-ref object vm:code-debug-info-slot)))
-	      (cond ((eq dinfo :bogus-lra)
-		     (write-string "Bogus Code Object" stream))
-		    (t
-		     (write-string "Code Object" stream)
-		     (when dinfo
-		       (write-char #\space stream)
-		       (output-object (c::compiled-debug-info-name dinfo)
-				      stream))))))
-	   ((#.vm:function-header-type #.vm:closure-function-header-type)
-	    (output-function-object object stream))
-	   (#.vm:return-pc-header-type
-	    (write-string "Return PC Object" stream))
-	   (#.vm:closure-header-type
-	    (cond
-	     ((eval:interpreted-function-p object)
-	      (output-interpreted-function object stream))
-	     (t
-	      (write-string "Closure Over " stream)
-	      (output-function-object (%primitive c::closure-function object)
-				      stream))))
-	   (#.vm:value-cell-header-type
-	    (write-string "Value Cell " stream)
-	    (output-object (%primitive value-cell-ref object) stream))
+  (print-unreadable-object (object stream :identity t)
+    (let ((lowtag (get-lowtag object)))
+      (case lowtag
+	(#.vm:other-pointer-type
+	  (let ((type (get-type object)))
+	    (case type
+	      (#.vm:code-header-type
+	       (let ((dinfo (code-header-ref object vm:code-debug-info-slot)))
+		 (cond ((eq dinfo :bogus-lra)
+			(write-string "Bogus Code Object" stream))
+		       (t
+			(write-string "Code Object" stream)
+			(when dinfo
+			  (write-char #\space stream)
+			  (output-object (c::compiled-debug-info-name dinfo)
+					 stream))))))
+	      (#.vm:return-pc-header-type
+	       (write-string "Return PC Object" stream))
+	      (#.vm:value-cell-header-type
+	       (write-string "Value Cell " stream)
+	       (output-object (%primitive value-cell-ref object) stream))
+	      (t
+	       (write-string "Unknown Pointer Object, type=" stream)
+	       (let ((*print-base* 16) (*print-radix* t))
+		 (output-integer type stream))))))
+	((#.vm:function-pointer-type
+	  #.vm:structure-pointer-type
+	  #.vm:list-pointer-type)
+	 (write-string "Unknown Pointer Object, type=" stream))
+	(t
+	 (case (get-type object)
 	   (#.vm:unbound-marker-type
-	    (write-string "Unbound Marker" stream))
+	    (write-string "Unbound Marker"))
 	   (t
-	    (write-string "Unknown Object, type=" stream)
+	    (write-string "Unknown Immediate Object, lowtag=" stream)
+	    (let ((*print-base* 2) (*print-radix* t))
+	      (output-integer lowtag stream))
+	    (write-string ", type=" stream)
 	    (let ((*print-base* 16) (*print-radix* t))
-	      (output-integer type stream))))))
-      (#.vm:structure-pointer-type
-       (write-string "Structure?"))
-      (#.vm:list-pointer-type
-       (write-string "List?"))
-      (t
-       (write-string "Unknown Immediate Object, lowtag=" stream)
-       (let ((*print-base* 2) (*print-radix* t))
-	 (output-integer lowtag stream))
-       (write-string ", type=" stream)
-       (let ((*print-base* 16) (*print-radix* t))
-	 (output-integer (get-type object) stream)))))
-  (finish-random object stream))
-
-
-(defun output-sap (sap stream)
-  (declare (type system-area-pointer sap))
-  (write-string "#<System-Area pointer: " stream)
-  (let ((*print-base* 16) (*print-radix* t))
-    (output-integer (sap-int sap) stream))
-  (write-char #\> stream))
-
-(defun output-weak-pointer (weak-pointer stream)
-  (declare (type weak-pointer weak-pointer))
-  (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)))))
+	      (output-integer (get-type object) stream)))))))))
-- 
GitLab