Skip to content
Snippets Groups Projects
Commit a668d7bd authored by wlott's avatar wlott
Browse files

Significant rewrite to support *print-readably* at all and to better

support and *print-circle*, *print-level*, and *print-length*.
parent bfcd7984
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -19,152 +19,136 @@
(in-package "LISP") (in-package "LISP")
(export '(*print-escape* *print-pretty* *print-circle* *print-base* (export '(*print-readably* *print-escape* *print-pretty* *print-circle*
*print-radix* *print-case* *print-level* *print-length* *print-base* *print-radix* *print-case* *print-gensym* *print-level*
*print-array* *print-gensym* write prin1 print princ *print-length* *print-array* *print-lines* *print-right-margin*
write-to-string prin1-to-string princ-to-string)) *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 (defvar *print-escape* T
"Flag which indicates that slashification is on. See the manual") "Flag which indicates that slashification is on. See the manual")
(defvar *print-pretty* nil (defvar *print-pretty* nil
"Flag which indicates that pretty printing is to be used") "Flag which indicates that pretty printing is to be used")
(defvar *print-base* 10. (defvar *print-base* 10.
"The output base for integers and rationals.") "The output base for integers and rationals.")
(defvar *print-radix* () (defvar *print-radix* nil
"This flag requests to verify base when printing rationals.") "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.") "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.") "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.") "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") "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") "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 true, symbols with no home package are printed with a #: prefix.
If false, no prefix is printed.") If false, no prefix is printed.")
;;; These next two vars are *not* really fully implemented, but I added them (defvar *print-lines* nil)
;;; here so that I wouldn't be forced to write new code incorrectly. (defvar *print-right-margin* nil)
;;; -- Ram, 9/28/90 (defvar *print-miser-width* nil)
;;; (defvar *print-pprint-dispatch* nil)
(defvar *print-readably* nil
"If true, all objects will printed readably. If readably printing is (defmacro with-standard-io-syntax (&body body)
impossible, an error will be signalled. This overrides the value of "Bind the reader and printer control variables to values that enable READ
*PRINT-ESCAPE*. But this isn't really implemented yet.") to reliably read the results of PRINT. These values are:
*PACKAGE* The COMMON-LISP-USER package
(defvar *read-eval* t *PRINT-ARRAY* T
"If false, then the #. read macro is disabled. But this isn't really *PRINT-BASE* 10
implemented yet.") *PRINT-CASE* :UPCASE
*PRINT-CIRCLE* NIL
*PRINT-ESCAPE* T
;;; Imported from reader. *PRINT-GENSYM* T
;;; *PRINT-LENGTH* NIL
(proclaim '(special *read-default-float-format*)) *PRINT-LEVEL* NIL
*PRINT-LINES* NIL
;;; From the package system. *PRINT-MISER-WIDTH* NIL
;;; *PRINT-PRETTY* NIL
(proclaim '(special *package* *keyword-package*)) *PRINT-RADIX* NIL
*PRINT-READABLY* T
*PRINT-RIGHT-MARGIN* NIL
;;; DOSTRING -- Internal. *READ-BASE* 10
;;; *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT
;;; This macro returns code which maps over a string, binding VARIABLE to each *READ-EVAL* T
;;; successive character in the string INIT-FORM, and executing BODY with *READ-SUPPRESS* NIL
;;; the variable so bound. This function used to be part of Common Lisp, but *READTABLE* the standard readtable."
;;; is no more. It lives on in the printer, though. `(%with-standard-io-syntax #'(lambda () ,@body)))
;;;
(defmacro dostring ((variable init-form &optional terminate-form) &rest body) (defun %with-standard-io-syntax (function)
(let ((str (gensym)) (let ((*package* (find-package "USER"))
(end (gensym)) (*print-array* t)
(index (gensym))) (*print-base* 10)
`(let* ((,str ,init-form) (*print-case* :upcase)
(,end (length (the string ,str))) (*print-circle* nil)
(,index 0)) (*print-escape* t)
(declare (fixnum ,index ,end)) (*print-gensym* t)
(loop (*print-length* nil)
(when (= ,index ,end) (return ,terminate-form)) (*print-level* nil)
(let ((,variable (char ,str ,index))) (*print-lines* nil)
,@body) (*print-miser-width* nil)
(incf ,index))))) (*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 ;;;; Routines to print objects.
(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)))))))
(defun write (object &key (defun write (object &key
((:stream stream) *standard-output*) ((:stream stream) *standard-output*)
((:escape *print-escape*) *print-escape*) ((:escape *print-escape*) *print-escape*)
((:radix *print-radix*) *print-radix*) ((:radix *print-radix*) *print-radix*)
((:base *print-base*) *print-base*) ((:base *print-base*) *print-base*)
((:circle *print-circle*) *print-circle*) ((:circle *print-circle*) *print-circle*)
((:pretty *print-pretty*) *print-pretty*) ((:pretty *print-pretty*) *print-pretty*)
((:level *print-level*) *print-level*) ((:level *print-level*) *print-level*)
((:length *print-length*) *print-length*) ((:length *print-length*) *print-length*)
((:case *print-case*) *print-case*) ((:case *print-case*) *print-case*)
((:array *print-array*) *print-array*) ((:array *print-array*) *print-array*)
((:gensym *print-gensym*) *print-gensym*)) ((: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*" "Outputs OBJECT to the specified stream, defaulting to *standard-output*"
(setup-printer-state) (output-object object (out-synonym-of stream))
(let ((stream (out-synonym-of stream)))
(if *print-pretty*
(output-pretty-object object stream)
(output-object object stream)))
object) object)
(defun prin1 (object &optional stream) (defun prin1 (object &optional stream)
"Outputs a mostly READable printed representation of OBJECT on the specified "Outputs a mostly READable printed representation of OBJECT on the specified
stream." stream."
(let ((stream (out-synonym-of stream))) (let ((*print-escape* T))
(setup-printer-state) (output-object object (out-synonym-of stream)))
(let ((*print-escape* T)) object)
(if *print-pretty*
(output-pretty-object object stream)
(output-object object stream)))
object))
(defun princ (object &optional stream) (defun princ (object &optional stream)
"Outputs an asthetic but not READable printed representation of OBJECT on the "Outputs an asthetic but not READable printed representation of OBJECT on the
specified stream." specified stream."
(let ((stream (out-synonym-of stream))) (let ((*print-escape* NIL))
(setup-printer-state) (output-object object (out-synonym-of stream)))
(let ((*print-escape* NIL)) object)
(if *print-pretty*
(output-pretty-object object stream)
(output-object object stream)))
object))
(defun print (object &optional stream) (defun print (object &optional stream)
"Outputs a terpri, the mostly READable printed represenation of OBJECT, and "Outputs a terpri, the mostly READable printed represenation of OBJECT, and
...@@ -175,19 +159,35 @@ ...@@ -175,19 +159,35 @@
(write-char #\space stream) (write-char #\space stream)
object)) object))
(defun write-to-string (object &key (defun pprint (object &optional stream)
((:escape *print-escape*) *print-escape*) "Prettily outputs the Object preceded by a newline."
((:radix *print-radix*) *print-radix*) (let ((*print-pretty* t)
((:base *print-base*) *print-base*) (*print-escape* t))
((:circle *print-circle*) *print-circle*) (terpri stream)
((:pretty *print-pretty*) *print-pretty*) (output-object object stream))
((:level *print-level*) *print-level*) (values))
((:length *print-length*) *print-length*)
((:case *print-case*) *print-case*)
((:array *print-array*) *print-array*) (defun write-to-string
((:gensym *print-gensym*) *print-gensym*)) (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." "Returns the printed representation of OBJECT as a string."
(stringify-object object *print-escape*)) (stringify-object object))
(defun prin1-to-string (object) (defun prin1-to-string (object)
"Returns the printed representation of OBJECT as a string with "Returns the printed representation of OBJECT as a string with
...@@ -199,129 +199,319 @@ ...@@ -199,129 +199,319 @@
slashification off." slashification off."
(stringify-object object nil)) (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. ;;; STRINGIFY-OBJECT -- Internal.
;;; ;;;
;;; This produces the printed representation of an object as a string. The ;;; This produces the printed representation of an object as a string. The
;;; few ...-TO-STRING functions above call this. ;;; few ...-TO-STRING functions above call this.
;;; ;;;
(defun stringify-object (object &optional (*print-escape* nil)) (defvar *string-output-streams* ())
(let ((stream (if *in-stringify-object* ;;;
(make-string-output-stream) (defun stringify-object (object &optional (*print-escape* *print-escape*))
*print-string-stream*)) (let ((stream (if *string-output-streams*
(*in-stringify-object* t)) (pop *string-output-streams*)
(make-string-output-stream))))
(setup-printer-state) (setup-printer-state)
(if *print-pretty* (output-object object stream)
(output-pretty-object object stream) (prog1
(output-object object stream 0)) (get-output-stream-string stream)
(get-output-stream-string stream))) (push stream *string-output-streams*))))
;;;; Central Print Functions. ;;;; PRINT-UNREADABLE-OBJECT macro
;;; OUTPUT-OBJECT -- Internal. (defmacro print-unreadable-object ((object stream &key type identity)
;;; &body body)
;;; This takes an object and outputs its printed representation to stream, `(%print-unreadable-object ,object ,stream ,type ,identity
;;; which typically is the internal print stream. This function is called ,(if body
;;; recursively by the sub-functions which know how to print structures which `#'(lambda () ,@body)
;;; can contain other lisp objects. 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)) ;;; Check to see if OBJECT is a circular reference, and return T if it is and
"Outputs a string which is the printed representation of the given object." ;;; NIL if not. Note: this function must be called *exactly* once with
;; First check and make sure we aren't too deep ;;; assign T for every potentially circular object.
(declare (fixnum currlevel)) ;;;
(if (and (not (null *print-level*)) (defun check-for-circularity (object &optional assign)
(not (= *print-level* 0)) (cond ((null *print-circle*)
(>= currlevel (the fixnum *print-level*))) ;; Don't bother, nobody cares.
(write-char #\# stream) nil)
(typecase object ((null *circularity-hash-table*)
(symbol :initiate)
(if *print-escape* ((null *circularity-counter*)
(output-symbol object stream) (ecase (gethash object *circularity-hash-table*)
(case *print-case* ((nil)
(:upcase (write-string (symbol-name object) stream)) ;; First encounter.
(:downcase (setf (gethash object *circularity-hash-table*) t)
(let ((name (symbol-name object))) ;; We need to keep looking.
(declare (simple-string name)) nil)
(dotimes (i (length name)) ((t)
(write-char (char-downcase (char name i)) stream)))) ;; Second encounter.
(:capitalize (setf (gethash object *circularity-hash-table*) 0)
(write-string (string-capitalize (symbol-name object)) ;; It's a circular reference.
stream))))) t)
;; If a list, go through element by element, being careful (0
;; about not running over the printlength ;; It's a circular reference.
(list t)))
(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))
(t (t
(if (and (fboundp 'funcallable-instance-p) (let ((value (gethash object *circularity-hash-table*)))
(funcallable-instance-p object)) (case value
(pcl:print-object object stream) ((nil)
(output-random object stream)))))) ;; 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)) ;;;; OUTPUT-OBJECT -- the main entry point.
(name (symbol-name object)))
(cond (defvar *pretty-printer* nil)
;; If the symbol's home package is the current one, then a
;; prefix is never necessary. (defun output-object (object stream)
((eq package *package*)) (if (and *print-pretty* *pretty-printer*)
;; If the symbol is in the keyword package, output a colon. (funcall *pretty-printer* object stream)
((eq package *keyword-package*) (output-ugly-object object stream)))
(write-char #\: stream))
;; Uninterned symbols print with a leading #:. (defun output-ugly-object (object stream)
((null package) (typecase object
(when *print-gensym* (write-string "#:" stream))) (fixnum
(t (output-integer object stream))
(multiple-value-bind (symbol accessible) (list
(find-symbol name *package*) (if (null object)
;; If we can find the symbol by looking it up, it need not be (output-symbol object stream)
;; qualified. This can happen if the symbol has been inherited (output-list object stream)))
;; from a package other than its home package. (structure
(unless (and accessible (eq symbol object)) (output-structure object stream))
(funcall *internal-symbol-output-function* (function
(package-name package) (if (and (fboundp 'funcallable-instance-p)
stream) (funcallable-instance-p object))
(multiple-value-bind (symbol externalp) (pcl:print-object object stream)
(find-external-symbol name package) (output-function object stream)))
(declare (ignore symbol)) (symbol
(if externalp (output-symbol object stream))
(write-char #\: stream) (number
(write-string "::" stream))))))) (etypecase object
(funcall *internal-symbol-output-function* name stream))) (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: ;;;; Escaping symbols:
...@@ -536,8 +726,9 @@ ...@@ -536,8 +726,9 @@
MARKER ; Number marker in a numeric number... MARKER ; Number marker in a numeric number...
(when (test letter) (advance OTHER nil)) (when (test letter) (advance OTHER nil))
(go DIGIT)))) (go DIGIT))))
;;;; Pathname hackery ;;;; Printname hackery
;;; This function takes the pname of a symbol and adds slashes and/or ;;; This function takes the pname of a symbol and adds slashes and/or
;;; vertical bars to it to make it readable again. ;;; vertical bars to it to make it readable again.
...@@ -605,127 +796,52 @@ ...@@ -605,127 +796,52 @@
;;;; Recursive Datatype Printing Subfunctions ;;;; Recursive objects.
(defun output-list (list stream &optional (currlevel 0)) (defun output-list (list stream)
(write-char #\( stream) (decend-into (list stream)
(do ((list list (cdr list)) (write-char #\( stream)
(currlength 0 (1+ currlength))) (let ((length 0)
((or (null list) (list list))
(and (not (null *print-length*)) (loop
(>= currlength (the fixnum *print-length*)))) (punt-if-too-long length stream)
(if (not (null list)) (write-string " ..." stream)) (output-object (pop list) stream)
(write-char #\) stream)) (unless list
(declare (fixnum currlength)) (return))
;;If we are not printing the first object, we should space first. (when (or (atom list) (check-for-circularity list))
(if (> currlength 0) (write-char #\space stream)) (write-string " . " stream)
;;Print whatever the car of the list is, at this level. (output-object list stream)
(output-object (car list) stream currlevel) (return))
(cond ((not (or (consp (cdr list)) (write-char #\space stream)
(null (cdr list)))) (incf length)))
(write-string " . " stream) (write-char #\) stream)))
(output-object (cdr list) stream currlevel)
(write-char #\) stream)
(return ()))))) (defun output-vector (vector stream)
(declare (vector vector))
(defun output-vector (vector stream &optional (currlevel 0)) (if (or *print-array* *print-readably*)
(declare (fixnum currlevel)) (typecase vector
(cond ((not *print-array*) (bit-vector
(output-terse-array vector stream currlevel)) (write-string "#*" stream)
(T (dotimes (i (length vector))
(if (bit-vector-p vector) (output-object (aref vector i) stream)))
(write-string "#*" stream) (string
(write-string "#(" stream)) (if (or *print-escape* *print-readably*)
(do ((currlength 0 (1+ currlength)) (quote-string vector stream)
(vlength (length (the vector vector))) (write-string vector stream)))
(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)
(t (t
(write-char #\( stream) (when (and *print-readably*
(do ((index index) (not (eq (array-element-type vector) 't)))
(times 0 (1+ times)) (error "Cannot print ~S in a readable format." vector))
(limit (pop dimensions))) (decend-into (vector stream)
((or (= times limit) (write-string "#(" stream)
(and (not (null *print-length*)) (dotimes (i (length vector))
(= times *print-length*))) (unless (zerop i)
(if (not (= times limit)) (write-char #\space stream))
(write-string " ...)" stream) (punt-if-too-long i stream)
(write-char #\) stream)) (output-object (aref vector i) stream))
index) (write-string ")" stream))))
(declare (fixnum index times limit)) (output-terse-array vector stream)))
(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.
;;; QUOTE-STRING -- Internal. ;;; QUOTE-STRING -- Internal.
;;; ;;;
...@@ -744,46 +860,97 @@ ...@@ -744,46 +860,97 @@
(write-char char stream)) (write-char char stream))
(write-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) (defun output-integer (integer stream)
(cond ((not (and (fixnump *print-base*) (> (the fixnum *print-base*) 1))) (unless (and (fixnump *print-base*)
(let ((obase *print-base*)) (< 1 *print-base* 37))
(setq *print-base* 10.) (let ((obase *print-base*))
(error "~A is not a reasonable value for *Print-Base*." obase))) (setq *print-base* 10.)
;; Otherwise print the base (error "~A is not a reasonable value for *Print-Base*." obase)))
(T (cond ((and (not (= *print-base* 10.)) (when (and (not (= *print-base* 10.))
*print-radix*) *print-radix*)
;; First print leading base information, if any. ;; First print leading base information, if any.
(write-char #\# stream) (write-char #\# stream)
(write-char (case *print-base* (write-char (case *print-base*
(2. #\b) (2. #\b)
(8. #\o) (8. #\o)
(16. #\x) (16. #\x)
(T (let ((fixbase *print-base*) (T (let ((fixbase *print-base*)
(*print-base* 10.) (*print-base* 10.)
(*print-radix* ())) (*print-radix* ()))
(sub-output-integer fixbase stream)) (sub-output-integer fixbase stream))
#\r)) #\r))
stream))) stream))
;; Then output a minus sign if the number is negative, then output ;; Then output a minus sign if the number is negative, then output
;; the absolute value of the number. ;; the absolute value of the number.
(cond ((bignump integer) (print-bignum integer stream)) (cond ((bignump integer) (print-bignum integer stream))
((< integer 0) ((< integer 0)
(write-char #\- stream) (write-char #\- stream)
(sub-output-integer (- integer) stream)) (sub-output-integer (- integer) stream))
(T (sub-output-integer integer stream))) (t
;; Print any trailing base information, if any. (sub-output-integer integer stream)))
(if (and (= *print-base* 10.) *print-radix*) ;; Print any trailing base information, if any.
(write-char #\. stream))))) (if (and (= *print-base* 10.) *print-radix*)
(write-char #\. stream)))
(defun sub-output-integer (integer stream) (defun sub-output-integer (integer stream)
(let ((quotient ()) (let ((quotient ())
...@@ -800,30 +967,6 @@ ...@@ -800,30 +967,6 @@
(+ (char-code #\0) remainder))) (+ (char-code #\0) remainder)))
stream))) 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 ;;;; Bignum printing
;;; Written by Steven Handerson ;;; Written by Steven Handerson
...@@ -881,7 +1024,30 @@ ...@@ -881,7 +1024,30 @@
(sub-output-integer fix stream))))) (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 ;;; Written by Bill Maddox
;;; ;;;
...@@ -1262,17 +1428,7 @@ ...@@ -1262,17 +1428,7 @@
(print-float-exponent x (1- ex) stream))))) (print-float-exponent x (1- ex) stream)))))
;;;; Output Character ;;;; Other leaf objects.
;;; 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))))
;;; OUTPUT-CHARACTER -- Internal ;;; OUTPUT-CHARACTER -- Internal
;;; ;;;
...@@ -1280,7 +1436,7 @@ ...@@ -1280,7 +1436,7 @@
;;; character name or the character in the #\char format. ;;; character name or the character in the #\char format.
;;; ;;;
(defun output-character (char stream) (defun output-character (char stream)
(if *print-escape* (if (or *print-escape* *print-readably*)
(let ((name (char-name char))) (let ((name (char-name char)))
(write-string "#\\" stream) (write-string "#\\" stream)
(if name (if name
...@@ -1288,8 +1444,34 @@ ...@@ -1288,8 +1444,34 @@
(write-char char stream))) (write-char char stream)))
(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 ;;; OUTPUT-FUNCTION-OBJECT outputs the main part of the printed
...@@ -1314,89 +1496,62 @@ ...@@ -1314,89 +1496,62 @@
(let ((*print-level* 3)) (let ((*print-level* 3))
(format stream "Interpreted Function ~S" (or name def))))) (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 ;;;; Catch-all for unknown things.
;;; 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.
(defun output-random (object stream) (defun output-random (object stream)
(write-string "#<" stream) (print-unreadable-object (object stream :identity t)
(let ((lowtag (get-lowtag object))) (let ((lowtag (get-lowtag object)))
(case lowtag (case lowtag
((#.vm:other-pointer-type #.vm:function-pointer-type) (#.vm:other-pointer-type
(let ((type (get-type object))) (let ((type (get-type object)))
(case type (case type
(#.vm:code-header-type (#.vm:code-header-type
(let ((dinfo (code-header-ref object vm:code-debug-info-slot))) (let ((dinfo (code-header-ref object vm:code-debug-info-slot)))
(cond ((eq dinfo :bogus-lra) (cond ((eq dinfo :bogus-lra)
(write-string "Bogus Code Object" stream)) (write-string "Bogus Code Object" stream))
(t (t
(write-string "Code Object" stream) (write-string "Code Object" stream)
(when dinfo (when dinfo
(write-char #\space stream) (write-char #\space stream)
(output-object (c::compiled-debug-info-name dinfo) (output-object (c::compiled-debug-info-name dinfo)
stream)))))) stream))))))
((#.vm:function-header-type #.vm:closure-function-header-type) (#.vm:return-pc-header-type
(output-function-object object stream)) (write-string "Return PC Object" stream))
(#.vm:return-pc-header-type (#.vm:value-cell-header-type
(write-string "Return PC Object" stream)) (write-string "Value Cell " stream)
(#.vm:closure-header-type (output-object (%primitive value-cell-ref object) stream))
(cond (t
((eval:interpreted-function-p object) (write-string "Unknown Pointer Object, type=" stream)
(output-interpreted-function object stream)) (let ((*print-base* 16) (*print-radix* t))
(t (output-integer type stream))))))
(write-string "Closure Over " stream) ((#.vm:function-pointer-type
(output-function-object (%primitive c::closure-function object) #.vm:structure-pointer-type
stream)))) #.vm:list-pointer-type)
(#.vm:value-cell-header-type (write-string "Unknown Pointer Object, type=" stream))
(write-string "Value Cell " stream) (t
(output-object (%primitive value-cell-ref object) stream)) (case (get-type object)
(#.vm:unbound-marker-type (#.vm:unbound-marker-type
(write-string "Unbound Marker" stream)) (write-string "Unbound Marker"))
(t (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)) (let ((*print-base* 16) (*print-radix* t))
(output-integer type stream)))))) (output-integer (get-type object) 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)))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment