;;; -*- Mode:LISP; Package:LISP-IO; Base:10; Readtable:CL -*-
;;;
;;; PRINT.LISP
;;;
;;; Still needs work: Flonums.  (no, really?)


(defvar *print-escape* T
  "Indicates whether or not to output escape characters when printing an
expression.")

(defvar *print-pretty* NIL
  "Indicates whether or not to nicely format expressions when printing them.")

(defvar *print-circle* NIL
  "If T, the printer will detect cycles in output expressions and print them
using the #n= and #n# syntax.")

(defvar *print-base* 10.
  "Determines what radix the printer will use to print rational numbers.")

(defvar *print-radix* NIL
  "If not NIL, the printer will print a radix specifier along with each
rational number.")

(defvar *print-case* :UPCASE
  "Controls the case of output.  :UPCASE means use upper case, :DOWNCASE means
use lower case, :CAPITALIZE means capitalize the first letter of each word.")

(defvar *print-gensym* T
  "Indicates whether or not to print #: in front of uninterned symbols.")

(defvar *print-level* NIL
  "Controls how many levels deep a nested object is printed.  If NIL, an 
object is printed to arbitrary depth; if a number, parts of the object which
are nested more times than that number are printed as #.")

(defvar *print-length* NIL
  "Controls how many elements at a given level of nesting are printed.  If 
NIL, all the elements on a given level are printed; if a number, then whenever
the number of objects on a level exceeds that number, the excess are printed
with three dots, ..., in their place.")

(defvar *print-array* NIL
  "If NIL, the contents of arrays (except for strings) are not printed.")

(defvar *print-nicely* NIL)


;;;----------------------------------------------------------------------------
;;; CYCLE TABLES
;;;----------------------------------------------------------------------------
;;;
;;; Duplications within a printed object's structure are kept track of in a
;;; cycle table.  A cycle table is generated by a top level print function, if
;;; *print-circle* is true, before the object is printed.  The cycle table is a
;;; hash table.  The table contains an entry whose key is :COUNTER and whose
;;; value is used to keep track of an index.  The index is used for #n= and #n#
;;; forms.  Other entries in the table keep track of duplicated objects.
;;;
;;; Each object which is part of the thing being printed is in one of four
;;; states:
;;;
;;;   NOT-CIRCULAR.  The object only occurs once in the thing being printed.
;;;   This state is represented by the object having no entry in the cycle
;;;   table, or having an entry of NIL in the cycle table.
;;;
;;;   NOT-PRINTED.  The object occurs more than once in the thing being
;;;   printed, but it has not yet been encountered by the printer.  Represented
;;;   by the object having a value of :NOT-PRINTED in the cycle table.
;;;
;;;   HEADER-PRINTED.  The object occurs more than once in the thing being
;;;   printed.  The #n= header has been printed for the object, but the object
;;;   itself has not yet been printed.  Represented by the object having a
;;;   value of (:HEADER-PRINTED n) in the cycle table.
;;;
;;;   PRINT-STARTED.  The object occurs more than once in the thing being 
;;;   printed.  The #n= header has been printed for the object, and printing of
;;;   the object itself has commenced.  Represented by the object having a
;;;   value of (:PRINT-STARTED n) in the cycle table.
;;;
;;; The magic predicate PRINT-CIRCULAR-OBJECT returns true if an object should
;;; be printed, and NIL if it shouldn't.  This function also modifies the 
;;; object's state in a cycle table and possibly prints a #n= or #n#
;;; expression.  Here's how it works:
;;;
;;;   If *print-circle* is nil, or the object's state is NOT-CIRCULAR, then
;;;   just return T.  
;;;
;;;   If the object's state is NOT-PRINTED, generate an index n for the object,
;;;   print #n=, change the object's state to HEADER-PRINTED, and return T.
;;;
;;;   If the object's state is HEADER-PRINTED, return T.
;;;
;;;   If the object's state is PRINT-STARTED, print #n# and return NIL.
;;;
;;; It is the caller's responsibility to use the NOTE-PRINT-STARTED function,
;;; which changes an object's state to PRINT-STARTED.
;;;----------------------------------------------------------------------------

;;; This definition has been buggerred so that we can use the
;;; printer without hash tables in the cold-load.  For now we
;;; just return NIL.
(defun make-cycle-table ()
;  (make-hash-table :test 'EQ)
  NIL)

(defun find-cycles (thing)
  (let ((table (make-cycle-table)))
    (walk-object thing table)
    (puthash :COUNTER 1 table)
    table))

(defun walk-object (thing table)
  (flet ((add-entry (key)
	   (let ((foo (gethash key table :not-present)))
	     (cond
	       ((eq foo :not-present)
		(puthash key NIL table)
		T)
	       ((eq foo NIL)
		(puthash key :NOT-PRINTED table)
		NIL)
	       (T 
		NIL)))))
  (typecase thing
    (cons   (when (add-entry thing)
	      (walk-object (car thing) table)
	      (walk-object (cdr thing) table)))
    (vector (when (add-entry thing)
	      (dotimes (i (length thing))
		(walk-object (aref thing i) table))))
    (array  (when (add-entry thing)
	      (walk-object (array-to-list thing) table)))
    (symbol (unless (symbol-package thing)
	      (add-entry thing))))))

(defun print-circular-object (thing table stream)
  "Print #n= or #n# if needed.  Return T if thing must be printed, NIL if it
doesn't have to."
  (if *print-circle*
      (let ((entry (gethash thing table))
	    (count (gethash :COUNTER table)))
	(cond
	  ((eq entry :NOT-PRINTED)
	   (write-char #\# stream)
	   (print-raw-fixnum count 10. stream)
	   (write-char #\= stream)
	   (puthash thing (list :HEADER-PRINTED count) table)
	   (puthash :COUNTER (1+ count) table)
	   T)
	  ((eq (car entry) :HEADER-PRINTED)
	   T)
	  ((eq (car entry) :PRINT-STARTED)
	   (write-char #\# stream)
	   (print-raw-fixnum (second entry) 10. stream)
	   (write-char #\# stream)
	   NIL)
	  (T
	   T)))
      T))

(defun note-print-started (thing table)
  (when *print-circle*
    (let ((entry (gethash thing table)))
      (when (eq (first entry) :HEADER-PRINTED)
	(setf (first entry) :PRINT-STARTED)))))
  
;;; This definition has been buggerred so that we can use the
;;; printer without hash tables in the cold-load.  For now we
;;; just return NIL.
(defun circular-object-p (object table)
;  (gethash object table)
  NIL)


;;;----------------------------------------------------------------------------
;;; SPECIAL TOKENS
;;;----------------------------------------------------------------------------
;;;
;;; These aren't Common Lisp objects.  They are special tokens which print as
;;; the dot in a dotted list, ..., and #.
;;;----------------------------------------------------------------------------

(deftype sptoken ()
  '(satisfies special-token-p))

(defconstant *dot-token* 'THE-DOT-TOKEN)

(defconstant *three-dot-token* 'THE-THREE-DOT-TOKEN)

(defconstant *sharp-token* 'THE-SHARP-TOKEN)

(defconstant *special-tokens-list* 
	     (list *dot-token* *three-dot-token* *sharp-token*))

(defun special-token-p (thing)
  (member thing *special-tokens-list*))

(defun print-special (special-token stream)
  (write-string
    (cond ((eq special-token *dot-token*)       ".")
	  ((eq special-token *three-dot-token*) "...")
	  ((eq special-token *sharp-token*)     "#")
	  (t (error "Unrecognized special token.")))
    stream))


;;;----------------------------------------------------------------------------
;;; CHARACTERS
;;;----------------------------------------------------------------------------

(defun print-character (char stream)
  (if *print-escape*
      (let ((basic-char (make-char char 0)))
	(write-char #\# stream)
	(write-char #\\ stream)
	(when (char-bit char :control) (write-string "Control-" stream))
	(when (char-bit char :meta)    (write-string "Meta-"    stream))
	(when (char-bit char :super)   (write-string "Super-"   stream))
	(when (char-bit char :hyper)   (write-string "Hyper-"   stream))
	(if (char-name basic-char)
	    (write-string (string-capitalize (char-name basic-char)) stream)
	    (progn
	      (when (and (> (char-bits char) 0)
			 (must-escape-character-p basic-char))
		(write-char #\\ stream))
	      (write-char basic-char stream))))
      (write-char char stream)))


;;;----------------------------------------------------------------------------
;;; SYMBOLS
;;;----------------------------------------------------------------------------

(defun print-symbol (symbol stream cycles)
  (let ((symbol-name (symbol-name symbol)))
    (when (or (symbol-package symbol)
	      (print-circular-object symbol cycles stream))
      (if *print-escape*
	  (progn
	    (print-package-prefix symbol stream)
	    (cond
	      ((or (could-be-number symbol-name)
		   (must-escape-print-name-p symbol-name))
	       (print-in-bars symbol-name stream))
	      (t
	       (print-symbol-print-name symbol-name stream))))
	  (print-symbol-print-name symbol-name stream)))))
  
(defun print-package-prefix (symbol stream)
  (let ((current-package *package*)
	(symbol-package  (symbol-package symbol))
	(symbol-name     (symbol-name symbol)))
    (cond ((keywordp symbol)
	   (write-string ":" stream))
	  ((eq (intern symbol-name current-package) symbol)
	   ())
	  (symbol-package
	   (write-string (package-name symbol-package) stream)
	   (multiple-value-bind (ignore how-interned)
	       (intern symbol-name symbol-package)
	     (case how-interned
	       (:INTERNAL (write-string "::" stream))
	       (:EXTERNAL (write-string ":"  stream))
	       (OTHERWISE (ferror "~S is not present in its home package." 
				  symbol)))))
	  ((and *print-gensym* *print-escape*)
	   (write-string "#:" stream)))))

(defun print-symbol-print-name (string stream)
  "Print STRING to STREAM, without escape characters, paying heed to nothing
but *print-case*."
  (case *print-case*
    (:UPCASE (write-string string stream))
    (:DOWNCASE (write-string (string-downcase string) stream))
    (:CAPITALIZE 
     (do ((length (length string)) char prev-letter
	  (i 0 (1+ i)))
	 ((= i length))
       (setq char (char string i))
       (cond ((upper-case-p char)
	      (write-char (if prev-letter (char-downcase char) char) stream)
	      (setq prev-letter t))
	     ((lower-case-p char)
	      (write-char (if prev-letter char (char-upcase char)) stream)
	      (setq prev-letter t))
	     ((char<= #\0 char #\9)
	      (write-char char stream)
	      (setq prev-letter t))
	     (t
	      (write-char char stream)
	      (setq prev-letter nil)))))))

(defun print-in-bars (string stream)
  "Print STRING to STREAM, engulfed in |'s, with \\'s and |'s within STRING
preceded by a \\."
  (write-char #\| stream)
  (do ((length (length string)) char
       (i 0 (1+ i)))
      ((= i length))
    (setq char (char string i))
    (when (or (char= char #\|)
	      (char= char #\\))
      (write-char #\\ stream))
    (write-char char stream))
  (write-char #\| stream))

(defun could-be-number (string)
  (every #'(lambda (char)
	     (digit-char-p char *print-base*))
	 string))


;;;----------------------------------------------------------------------------
;;; FIXNA
;;;----------------------------------------------------------------------------

(defun print-raw-fixnum (number radix stream)
  (when (minusp number)
    (write-char #\- stream)
    (setq number (- number)))
  (multiple-value-bind (quotient remainder)
      (truncate number radix)
    (unless (zerop quotient)
      (print-raw-fixnum quotient radix stream))
    (write-char (char "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" remainder) 
		stream)))

(defun print-print-radix-prefix (radix stream &optional print-10-p)
  (unless (<= 2. radix 36.)
    (error "~S is not a legal print radix." radix))
  (case radix
    (2.  (write-string "#b" stream))
    (8.  (write-string "#o" stream))
    (10. (when print-10-p (write-string "#10r" stream)))
    (16. (write-string "#x" stream))
    (t   (write-char #\# stream)
	 (print-raw-fixnum radix 10. stream)
	 (write-char #\r stream))))

(defun print-print-radix-suffix (radix stream)
  (when (= radix 10.)
    (write-char #\. stream)))

(defun print-fixnum (number stream)
  (let ((radix         *print-base*)
	(print-radix-p *print-radix*))
    (when print-radix-p
      (print-print-radix-prefix radix stream))
    (print-raw-fixnum number radix stream)
    (when print-radix-p
      (print-print-radix-suffix radix stream))))


;;;----------------------------------------------------------------------------
;;; RATIOS
;;;----------------------------------------------------------------------------

(defun print-ratio (ratio stream)
  (let ((radix         *print-base*)
	(print-radix-p *print-radix*))
    (when print-radix-p
      (print-print-radix-prefix radix stream t))
    (print-raw-fixnum (numerator ratio) radix stream)
    (write-char #\/ stream)
    (print-raw-fixnum (denominator ratio) radix stream)))
  

;;;----------------------------------------------------------------------------
;;; FLONUMS
;;;----------------------------------------------------------------------------

(defconstant *short-float-mantissa-bits* 17.)

(defconstant *single-float-mantissa-bits* 23.)

(defconstant *double-float-mantissa-bits* 52.)

(defconstant *long-float-mantissa-bits* 52.)

(defconstant *short-float-significant-digits* 
	     (floor (* (log 2 10) *short-float-mantissa-bits*)))

(defconstant *single-float-significant-digits*
	     (floor (* (log 2 10) *single-float-mantissa-bits*)))

(defconstant *double-float-significant-digits*
	     (floor (* (log 2 10) *double-float-mantissa-bits*)))

(defconstant *long-float-significant-digits*
	     (floor (* (log 2 10) *long-float-mantissa-bits*)))

(defun significant-digits (flonum)
  (typecase flonum
    (short-float  *short-float-significant-digits*)
    (single-float *single-float-significant-digits*)
    (double-float *double-float-significant-digits*)
    (long-float   *long-float-significant-digits*)))

(defun exponent-character (flonum)
  (if (typep flonum *read-default-float-format*)
      #\e
      (typecase flonum
	(short-float  #\s)
	(single-float #\f)
	(double-float #\d)
	(long-float   #\L)
	(t
	 (error "~S is not a flonum type." (type-of flonum))))))

(defun print-flonum (number stream &optional force-e-format)
  (when (minusp number)
    (write-char #\- stream)
    (setq number (- number)))
  (cond
    ((zerop number)
     (write-string "0.0" stream)
     (unless (typep number *read-default-float-format*)
       (write-char (exponent-character number) stream)
       (write-char #\0 stream)))
    ((or (< number 1.0s-3) (>= number 1.0s7) force-e-format)
     (multiple-value-bind (mantissa exponent)
	 (scale-flonum number)
       (let ((digits-to-print (significant-digits number)))
	 (setq mantissa
	       (+ mantissa (* 5 (expt 0.1 digits-to-print))))
	 (when (>= mantissa 10)
	   (setq mantissa (/ mantissa 10))
	   (setq exponent (1+ exponent)))
	 (print-flonum-mantissa mantissa digits-to-print stream))
       (write-char (exponent-character number) stream)
       (print-raw-fixnum exponent 10. stream)))
    (t
     (let* ((digits-to-print       (significant-digits number))
	    (digits-before-decimal (ceiling (log number 10)))
	    (fraction-digits 
	      (max 0 (- digits-to-print digits-before-decimal))))
       (print-positive-flonum number stream fraction-digits))
     ;; ^^ This will lose in one case.  If there are more digits before the
     ;; decimal point than there are significant digits, some of the digits
     ;; printed will be meaningless.  Ex: A flonum that looks like 123456.8
     ;; but only having five significant digits.  (How should something like
     ;; this be printed, anyway?  Scheme says: 12346#.#)
     (unless (typep number *read-default-float-format*)
       (write-char (exponent-character number) stream)
       (write-char #\0 stream)))))
	     
(defun scale-flonum (number)
  "Return the mantissa and exponent of a base-10 representation of NUMBER."
  (let* ((exponent (floor (log number 10)))
	 (mantissa (/ number (expt 10 exponent))))
    (values mantissa exponent)))

(defun print-flonum-mantissa (mantissa digits-to-print stream)
  (let ((digit (floor mantissa)))
    (write-char (char "0123456789" digit) stream)
    (write-char #\. stream)
    (print-flonum-decimals (- mantissa digit) stream (1- digits-to-print))))

(defun print-positive-flonum (number stream fraction-digits)
  (setq number (+ number (* 0.5 (expt 0.1 fraction-digits))))
  (multiple-value-bind (integer-part fraction-part)
      (floor number)
    (print-raw-fixnum integer-part 10. stream)
    (write-char #\. stream)
    (print-flonum-decimals fraction-part stream fraction-digits)))

(defun print-flonum-decimals (number stream digits-to-print 
			      &key print-trailing-zeros
			           no-digits-for-zero)
  "NUMBER must satisfy 0 <= NUMBER < 1.  Print DIGITS-TO-PRINT decimal digits
of NUMBER onto STREAM.  If PRINT-TRAILING-ZEROS is true, then print trailing
zeros; otherwise suppress them.  If NO-DIGITS-FOR-ZERO is false, then always
print at least one digit, even if it's zero."
  (let ((string (make-string digits-to-print))
	(index  0))
    (labels ((do-digits (number)
	       (unless (>= index digits-to-print)
		 (let* ((number*10 (* number 10))
			(digit     (floor number*10)))
		   (setf (char string index) (char "0123456789" digit))
		   (incf index)
		   (do-digits (- number*10 digit)))))
	     (remove-trailing-zeros ()
	       (when (and (> index 0)
			  (char= (char string (1- index)) #\0))
		 (decf index)
		 (remove-trailing-zeros))))
      (do-digits number)
      (unless print-trailing-zeros (remove-trailing-zeros))
      (write-string string stream :end index)
      (when (and (= index 0) (not no-digits-for-zero))
	(write-char #\0 stream)))))
      

;;; Bigna code narfed from Lambda sources.  

;;; Printing bigna
;(defun print-bignum-piece (piece radix stream ndigits)
;  (when (or (> ndigits 1) (>= piece radix))
;    (print-bignum-piece (truncate piece radix) radix stream (1- ndigits)))
;  (write-char (char "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" (rem piece radix)) stream))

;;; Print the digits of a bignum
;(defun print-raw-bignum (num radix stream &aux length max-radix digits-per-q)
;  (setq digits-per-q (floor %%q-pointer (haulong radix))
;	max-radix (^ radix digits-per-q)
;	num (bignum-to-array num max-radix)
;	length (array-length num))
;  (do ((index (1- length) (1- index))
;       (ndigits -1 digits-per-q))
;      ((minusp index))
;    (print-bignum-piece (aref num index) radix stream ndigits)))

;(defprinter print-bignum bignum (bignum stream &aux (base (current-print-base)))
;  (declare (unspecial base))
;  (when *print-radix*
;    (print-print-radix-prefix base stream))
;  (when (minusp bignum)
;    (write-char (pttbl-minus-sign (rdtbl-print-table *readtable*)) stream))
;  (if (fixnump base)
;      (print-raw-bignum bignum base stream)
;    (funcall (get base 'princ-function) (- bignum) stream))
;  (when (and (or *print-radix* (not *nopoint))
;	     (eq base 10.))
;    (write-char #\. stream))
;  bignum)


;;;----------------------------------------------------------------------------
;;; COMPLEX
;;;----------------------------------------------------------------------------

(defun print-complex (number stream cycles)
  (write-string "#C(" stream)
  (print-object (realpart number) stream cycles)
  (write-string " " stream)
  (print-object (imagpart number) stream cycles)
  (write-string ")" stream))


;;;----------------------------------------------------------------------------
;;; CONSES
;;;----------------------------------------------------------------------------

(defun list-length-equals-p (list length)
  (let ((len (list-length list)))
    (and len (= len length) (null (nthcdr len list)))))


(defun print-cons (cons stream cycle-table)
  (when (print-circular-object cons cycle-table stream)
    (cond
      ((and *print-level* (zerop *print-level*))
       (write-string "#" stream))
      ((and (or *print-pretty* *print-nicely*)
	    (list-length-equals-p cons 2)
	    (member (first cons) 
		    '(QUOTE FUNCTION BACKQUOTE UNQUOTE UNQUOTE-SPLICING
		      DESTRUCTIVE-UNQUOTE-SPLICING SI::DISPLACED)))
       (note-print-started cons cycle-table)
       (case (first cons)
	 (QUOTE                        (write-char #\' stream))
	 (FUNCTION                     (write-string "#'" stream))
	 (BACKQUOTE                    (write-char #\` stream))
	 (UNQUOTE                      (write-char #\, stream))
	 (UNQUOTE-SPLICING             (write-string ",@" stream))
	 (DESTRUCTIVE-UNQUOTE-SPLICING (write-string ",." stream))
	 (SI::DISPLACED                NIL))
       (print-object (second cons) stream cycle-table))
      (*print-pretty*
       (grind-list cons (get-indentation (first cons)) stream cycle-table))
      (t
       (note-print-started cons cycle-table)
       (write-char #\( stream)
       (print-list-elements cons stream cycle-table)
       (write-char #\) stream)))))

(defun print-list-elements (list stream cycle-table)
  (do ((current-cons-cell list (cdr current-cons-cell))
       (number-printed    0    (1+ number-printed)))
      (nil)
    (let ((current-car (car current-cons-cell))
	  (current-cdr (cdr current-cons-cell)))
      (cond
	((null current-cons-cell)
	 (return))
	((and *print-length* (>= number-printed *print-length*))
	 (write-string "..." stream)
	 (return))
	(t
	 (let ((*print-level* (decrement *print-level*)))
	   (print-object current-car stream cycle-table))
	 (cond
	   ((and (consp current-cdr)
		 (not (circular-object-p current-cdr cycle-table)))
	    (write-string " " stream))
	   ((not (null current-cdr))
	    (write-string " . " stream)
	    (let ((*print-level* (decrement *print-level*)))
	      (print-object current-cdr stream cycle-table))
	    (return))
	   (t
	    (return))))))))
  
(defun decrement (frob)
  "If FROB is not NIL, return FROB - 1.  Otherwise, return NIL."
  (if frob (1- frob) NIL))


;;;----------------------------------------------------------------------------
;;; STRINGS
;;;----------------------------------------------------------------------------

(defun print-string (string stream)
  (if *print-escape*
      (progn 
	(write-char #\" stream)
	(dotimes (i (length string))
	  (print-string-char (char string i) stream))
	(write-char #\" stream))
      (dotimes (i (length string))
	(write-char (char string i) stream))))

(defun print-string-char (char stream)
  (when (or (char= char #\\)
	    (char= char #\"))
    (write-char #\\ stream))
  (write-char char stream))


;;;----------------------------------------------------------------------------
;;; BIT VECTORS
;;;----------------------------------------------------------------------------

(defun print-bit-vector (bit-vector stream)
  (cond
    ((not *print-array*)
     (write-string "#<Bit Vector>" stream))
    (t
     (write-string "#*" stream)
     (dotimes (i (length bit-vector))
       (print-bit-char (bit bit-vector i) stream)))))

(defun print-bit-char (bit stream)
  (if (zerop bit)
      (write-char #\0 stream)
      (write-char #\1 stream)))


;;;----------------------------------------------------------------------------
;;; VECTORS
;;;----------------------------------------------------------------------------

(defun print-vector (vector stream cycles)
  (cond
    ((not *print-array*)
     (write-string "#<Vector>" stream))
    ((and *print-level* (zerop *print-level*))
     (write-string "#" stream))
    (*print-pretty*
     (grind-vector vector stream cycles))
    ((print-circular-object vector cycles stream)
     (write-char #\# stream)
     (print-array-contents vector NIL stream cycles))))


;;;----------------------------------------------------------------------------
;;; ARRAYS 
;;;----------------------------------------------------------------------------

(defun print-array (array stream cycles)
  (cond
    ((not *print-array*)
     (write-string
       (format nil "#<Array ~{~S~^x~}>" (array-dimensions array))
       stream))
    ((and *print-level* (zerop *print-level*))
     (write-string "#" stream))
    (*print-pretty*
     (grind-array array stream cycles))
    ((print-circular-object array cycles stream)
     (write-char #\# stream)
     (print-raw-fixnum (array-rank array) 10. stream)
     (write-char #\A stream)
     (print-array-contents array NIL stream cycles))))

(defun print-array-contents (array indices stream cycles)
  (print-object (array-to-list array :indices indices) stream cycles))
	
(defun array-to-list (array &key indices stringify)
  "Return a list representation of the subarray of ARRAY specified by INDICES.
If INDICES is NIL, return a list representation of the entire array.  If
STRINGIFY is not nil, then arrays of characters will be considered strings and
arrays of bits will be considered bit-vectors."
  (let* ((next-dimension     (length indices))
	 (rank-of-subarray   (- (array-rank array) (length indices))))
    (if (zerop rank-of-subarray)
	(apply #'aref array indices)
	(let ((length-of-subarray (array-dimension array next-dimension))
	      (result NIL))
	  (dotimes (i length-of-subarray)
	    (push (array-to-list array :indices (append indices (list i))
				 :stringify stringify)
		  result))
	  (setq result (nreverse result))
	  (cond
	    ((every #'characterp result)
	     (coerce result 'string))
	    ((every #'bit-vector-p result)
	     (coerce result 'bit-vector))
	    (t
	     result))))))

;(defun print-array-contents (array indices stream cycles)
;  (let* ((rank-of-subarray       (- (array-rank array) (length indices)))
;	 (next-dimension         (length indices))
;	 (length-of-subarray     (array-dimension array next-dimension))
;	 (subarray-is-string     NIL)
;	 (subarray-is-bit-vector NIL))
;    (when (and (= rank-of-subarray 1)
;	       (or (not *print-length*) (>= length-of-subarray *print-length*)))
;      (cond ((typep array `(array bit ,(array-rank array)))
;	     (setq subarray-is-bit-vector T))
;	    ((typep array `(array character ,(array-rank array)))
;	     (setq subarray-is-string T))))
;    (cond (subarray-is-string     (write-char #\" stream))
;	  (subarray-is-bit-vector (write-string "#*" stream))
;	  (t                      (write-char #\( stream)))
;    (dotimes (i length-of-subarray)
;      (cond ((and *print-length* (>= i *print-length*))
;	     (write-string "..." stream)
;	     (return))
;	    ((> rank-of-subarray 1)
;	     (print-array-contents array (append indices (list i))
;				   stream cycles))
;	    (subarray-is-string
;	     (print-string-char (apply #'aref array (append indices (list i)))
;				stream))
;	    (subarray-is-bit-vector
;	     (print-bit-char (apply #'aref array (append indices (list i)))
;			     stream))
;	    (t
;	     (let ((*print-level* (decrement *print-level*)))
;	       (print-object (apply #'aref array (append indices (list i)))
;			     stream cycles))))
;      (unless (or (= (1+ i) length-of-subarray)
;		  subarray-is-string
;		  subarray-is-bit-vector)
;	(write-string " " stream)))
;    (write-char #\) stream)))


;;;----------------------------------------------------------------------------
;;; DISPATCH
;;;----------------------------------------------------------------------------

(defun print-object (thing stream cycle-table)
  (typecase thing
    (sptoken    (print-special    thing stream))
    (character  (print-character  thing stream))
    (symbol     (print-symbol     thing stream cycle-table))
    (string     (print-string     thing stream))
    (integer    (print-fixnum     thing stream))
    (ratio      (print-ratio      thing stream))
    (float      (print-flonum     thing stream))
    (complex    (print-complex    thing stream cycle-table))
    (bit-vector (print-bit-vector thing stream))
    (cons       (print-cons       thing stream cycle-table))
    (vector     (print-vector     thing stream cycle-table))
    (array      (print-array      thing stream cycle-table))
    (t 
     (error "I don't know how to print objects of type ~S."
	    (type-of thing)))
    )
  thing)


;;;----------------------------------------------------------------------------
;;; PUBLIC FUNCTIONS
;;;----------------------------------------------------------------------------

(defun write (object &key (stream *standard-output*)
	                  (escape *print-escape*)
			  (radix  *print-radix*)
			  (base   *print-base*)
			  (circle *print-circle*)
			  (pretty *print-pretty*)
			  (level  *print-level*)
			  (length *print-length*)
			  (case   *print-case*)
			  (gensym *print-gensym*)
			  (array  *print-array*))
  "Print OBJECT on STREAM, which defaults to *STANDARD-OUTPUT*.  The keyword
arguments control multiferous printing formats.  Return OBJECT."
  (when (eq stream t) 
    (setq stream *terminal-io*))
  (let ((*standard-output* stream)
	(*print-escape* escape)
	(*print-radix*  radix)
	(*print-base*   base)
	(*print-circle* circle)
	(*print-pretty* pretty)
	(*print-level*  level)
	(*print-length* length)
	(*print-case*   case)
	(*print-gensym* gensym)
	(*print-array*  array))
    (print-object
      object
      (if *print-pretty*
	  (make-grinder 50. stream)
	  stream)
      (if *print-circle*
	  (find-cycles object)
	  (make-cycle-table))))
  object)

(defun prin1 (object &optional (stream *standard-output*))
  "Write OBJECT onto STREAM, using escape characters.  Return OBJECT."
  (when (eq stream t) 
    (setq stream *terminal-io*))
  (write object :stream stream :escape t))

(defun print (object &optional (stream *standard-output*))
  "Write OBJECT onto STREAM, using escape characters, with a newline before and
a space after.  Return OBJECT."
  (when (eq stream t) 
    (setq stream *terminal-io*))
  (terpri)
  (write object :stream stream :escape t)
  (write-char #\Space stream)
  object)

(defun pprint (object &optional (stream *standard-output*))
  "Write OBJECT onto STREAM, formatted nicely, preceded by a newline.  Return
zero values."
  (when (eq stream t) 
    (setq stream *terminal-io*))
  (terpri)
  (write object :stream stream :pretty t)
  (values))

(defun princ (object &optional (stream *standard-output*))
  "Write OBJECT onto STREAM, without any escape characters.  Return OBJECT."
  (when (eq stream t) 
    (setq stream *terminal-io*))
  (write object :stream stream :escape nil))

(defun write-to-string (object &key (escape *print-escape*)
			            (radix  *print-radix*)
				    (base   *print-base*)
				    (circle *print-circle*)
				    (pretty *print-pretty*)
				    (level  *print-level*)
				    (length *print-length*)
				    (case   *print-case*)
				    (gensym *print-gensym*)
				    (array  *print-array*))
  "Write OBJECT to a string.  The keyword arguments control multiferous format
parameters."
  (let ((*print-escape* escape)
	(*print-radix*  radix)
	(*print-base*   base)
	(*print-circle* circle)
	(*print-pretty* pretty)
	(*print-level*  level)
	(*print-length* length)
	(*print-case*   case)
	(*print-gensym* gensym)
	(*print-array*  array))
    (let ((stream      (if *print-pretty*
			   (make-grinder 50. (make-string-output-stream))
			   (make-string-output-stream)))
	  (cycle-table (if *print-circle*
			   (find-cycles object)
			   (make-cycle-table))))
      (print-object object stream cycle-table)
      (get-output-stream-string stream))))

(defun prin1-to-string (object)
  "Return a string, the printed representation of OBJECT, with escape           
characters if necessary."
  (write-to-string object :escape t))

(defun princ-to-string (object)
  "Return a string, the printed representation of OBJECT, without escape
characters."
  (write-to-string object :escape nil))