0.7.13.28:

[sbcl.git] / src / code / print.lisp

diff --git a/src/code/print.lisp b/src/code/print.lisp
index 04d85f4..91f200f 100644 (file)
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -97,6 +97,7 @@
   `(%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)
@@ -240,6 +241,7 @@
 
 ;;; 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 ()
@@ -971,7 +973,7 @@
           (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)
@@ -998,6 +1000,14 @@
          (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)
@@ -1014,7 +1024,7 @@
 ;;; 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))