`(%with-standard-io-syntax (lambda () ,@body)))
(defun %with-standard-io-syntax (function)
+ (declare (type function function))
(let ((*package* (find-package "COMMON-LISP-USER"))
(*print-array* t)
(*print-base* 10)
;;; guts of PRINT-UNREADABLE-OBJECT
(defun %print-unreadable-object (object stream type identity body)
+ (declare (type (or null function) body))
(when *print-readably*
(error 'print-not-readable :object object))
(flet ((print-description ()
\f
;;;; OUTPUT-OBJECT -- the main entry point
-;;; the current pretty printer. This should be either a function that
-;;; takes two arguments (the object and the stream) or NIL to indicate
-;;; that there is no pretty printer installed.
-(defvar *pretty-printer* nil)
-
;;; Objects whose print representation identifies them EQLly don't
;;; need to be checked for circularity.
(defun uniquely-identified-by-print-p (x)
(defun output-object (object stream)
(labels ((print-it (stream)
(if *print-pretty*
- (if *pretty-printer*
- (funcall *pretty-printer* object stream)
- (let ((*print-pretty* nil))
- (output-ugly-object object stream)))
+ (sb!pretty:output-pretty-object object stream)
(output-ugly-object object stream)))
(check-it (stream)
(multiple-value-bind (marker initiate)
*print-object-is-disabled-p*))
(print-object object stream))
((typep object 'structure-object)
- (default-structure-print object stream *current-level*))
+ (default-structure-print object stream *current-level-in-print*))
(t
(write-string "#<INSTANCE but not STRUCTURE-OBJECT>" stream))))
(function
(write-char (if (zerop bit) #\0 #\1) stream)))
(t
(when (and *print-readably*
- (not (eq (array-element-type vector) t)))
+ (not (array-readably-printable-p array)))
(error 'print-not-readable :object vector))
(descend-into (stream)
(write-string "#(" stream)
(when (needs-slash-p char) (write-char #\\ stream))
(write-char char stream))))))
+(defun array-readably-printable-p (array)
+ (and (eq (array-element-type array) t)
+ (let ((zero (position 0 (array-dimensions array)))
+ (number (position 0 (array-dimensions array)
+ :test (complement #'eql)
+ :from-end t)))
+ (or (null zero) (null number) (> zero number)))))
+
;;; Output the printed representation of any array in either the #< or #A
;;; form.
(defun output-array (array stream)
;;; Output the readable #A form of an array.
(defun output-array-guts (array stream)
(when (and *print-readably*
- (not (eq (array-element-type array) t)))
+ (not (array-readably-printable-p array)))
(error 'print-not-readable :object array))
(write-char #\# stream)
(let ((*print-base* 10))
;;; use until CLOS is set up (at which time it will be replaced with
;;; the real generic function implementation)
(defun print-object (instance stream)
- (default-structure-print instance stream *current-level*))
+ (default-structure-print instance stream *current-level-in-print*))
\f
;;;; integer, ratio, and complex printing (i.e. everything but floats)
(*print-level* 3) ; ..print an interpreted function definition
;; FIXME: This find-the-function-name idiom ought to be
;; encapsulated in a function somewhere.
- (name (case (function-subtype object)
+ (name (case (fun-subtype object)
(#.sb!vm:closure-header-widetag "CLOSURE")
(#.sb!vm:simple-fun-header-widetag (%simple-fun-name object))
(t 'no-name-available)))