diff --git a/code/pprint.lisp b/code/pprint.lisp index 7e020e887d6dce1a6d205b4b958d076616b83cab..ebe96a37d2ae472f5734f81fa0d5139766098751 100644 --- a/code/pprint.lisp +++ b/code/pprint.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.42 2004/09/10 14:42:09 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.43 2004/09/27 21:54:53 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1132,6 +1132,15 @@ nil) +(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))))) + + ;;;; Standard pretty-printing routines. (defun pprint-array (stream array) @@ -1139,7 +1148,8 @@ (stringp array) (bit-vector-p array)) (output-ugly-object array stream)) - ((and *print-readably* (not (eq (array-element-type array) t))) + ((and *print-readably* + (not (lisp::array-readably-printable-p array))) (pprint-raw-array stream array)) ((vectorp array) (pprint-vector stream array)) diff --git a/code/print.lisp b/code/print.lisp index 55919be50b8079d87383134c31731ac878b48118..f3d8673ce3abfa57035a45b657e3ceecb1437369 100644 --- a/code/print.lisp +++ b/code/print.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.97 2004/09/03 03:05:58 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.98 2004/09/27 21:54:53 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1002,6 +1002,16 @@ |# + +(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))))) + + ;;;; Recursive objects. (defun output-list (list stream) @@ -1041,7 +1051,7 @@ (0 (write-char #\0 stream)) (1 (write-char #\1 stream))))) ((and *print-readably* - (not (eq (array-element-type vector) 't))) + (not (array-readably-printable-p vector))) (output-array vector stream)) (t (descend-into (stream)