From 74c3f536a4f39bd7b677c8020c662f711c8fb1a5 Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Mon, 27 Sep 2004 21:54:53 +0000 Subject: [PATCH] Borrow SBCL's ARRAY-READABLY-PRINTABLE-P function and use it to determine if an array can be printed readably. --- code/pprint.lisp | 14 ++++++++++++-- code/print.lisp | 14 ++++++++++++-- 2 files changed, 24 insertions(+), 4 deletions(-) diff --git a/code/pprint.lisp b/code/pprint.lisp index 7e020e887..ebe96a37d 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 55919be50..f3d8673ce 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) -- GitLab