From 628c9c353690b012965ccd74d68e1b81e4a2a368 Mon Sep 17 00:00:00 2001 From: Robert Brown Date: Fri, 2 Dec 2011 17:07:20 +0200 Subject: [PATCH] printing specialized arrays readably When *READ-EVAL* is true, use #. based syntax to print them. lp#803665. --- NEWS | 2 ++ src/code/pprint.lisp | 6 ++++- src/code/print.lisp | 69 ++++++++++++++++++++++++++++++++++------------- tests/print.impure.lisp | 52 +++++++++++++++++++++++++++++++++++ 4 files changed, 110 insertions(+), 19 deletions(-) diff --git a/NEWS b/NEWS index 5c384d4..9a82f45 100644 --- a/NEWS +++ b/NEWS @@ -7,6 +7,8 @@ changes relative to sbcl-1.0.54: ** --arch option can be used to specify the architecture to build for. (Mainly useful for building 32-bit SBCL's on x86-64 hosts, not full-blows cross-compilation.) + * enhancement: when *READ-EVAL* is true, arrays with element type other than + T can be printed readably using #.-based syntax. (Thanks to Robert Brown) * enhancement: MAKE-ALIEN signals a storage-condition instead of returning a null alien when malloc() fails. (lp#891268) * enhancement: SB-EXT:PRINT-UNREADABLY restart for PRINT-NOT-READABLE diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index ef17572..f499bfb 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -1007,7 +1007,11 @@ line break." (output-ugly-object array stream)) ((and *print-readably* (not (array-readably-printable-p array))) - (print-not-readable-error array stream)) + (if *read-eval* + (if (vectorp array) + (sb!impl::output-unreadable-vector-readably array stream) + (sb!impl::output-unreadable-array-readably array stream)) + (print-not-readable-error array stream))) ((vectorp array) (pprint-vector stream array)) (t diff --git a/src/code/print.lisp b/src/code/print.lisp index ec2ad86..43f379f 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -991,6 +991,13 @@ variable: an unreadable object representing the error is printed instead.") (incf length))) (write-char #\) stream))) +(defun output-unreadable-vector-readably (vector stream) + (declare (vector vector)) + (write-string "#." stream) + (write `(coerce ,(coerce vector '(vector t)) + '(simple-array ,(array-element-type vector) (*))) + :stream stream)) + (defun output-vector (vector stream) (declare (vector vector)) (cond ((stringp vector) @@ -1014,11 +1021,8 @@ variable: an unreadable object representing the error is printed instead.") ;; (Don't use OUTPUT-OBJECT here, since this code ;; has to work for all possible *PRINT-BASE* values.) (write-char (if (zerop bit) #\0 #\1) stream))) - (t - (when (and *print-readably* - (not (array-readably-printable-p vector))) - (return-from output-vector - (print-not-readable-error vector stream))) + ((or (not *print-readably*) + (array-readably-printable-p vector)) (descend-into (stream) (write-string "#(" stream) (dotimes (i (length vector)) @@ -1026,7 +1030,11 @@ variable: an unreadable object representing the error is printed instead.") (write-char #\space stream)) (punt-print-if-too-long i stream) (output-object (aref vector i) stream)) - (write-string ")" stream))))) + (write-string ")" stream))) + (*read-eval* + (output-unreadable-vector-readably vector stream)) + (t + (print-not-readable-error vector stream)))) ;;; This function outputs a string quoting characters sufficiently ;;; so that someone can read it in again. Basically, put a slash in @@ -1066,20 +1074,45 @@ variable: an unreadable object representing the error is printed instead.") (*print-length* nil)) (print-unreadable-object (array stream :type t :identity t)))) -;;; Output the readable #A form of an array. -(defun output-array-guts (array stream) - (when (and *print-readably* - (not (array-readably-printable-p array))) - (return-from output-array-guts - (print-not-readable-error array stream))) - (write-char #\# stream) - (let ((*print-base* 10) - (*print-radix* nil)) - (output-integer (array-rank array) stream)) - (write-char #\A stream) +;;; Convert an array into a list that can be used with MAKE-ARRAY's +;;; :INITIAL-CONTENTS keyword argument. +(defun listify-array (array) (with-array-data ((data array) (start) (end)) (declare (ignore end)) - (sub-output-array-guts data (array-dimensions array) stream start))) + (labels ((listify (dimensions index) + (if (null dimensions) + (aref data index) + (let* ((dimension (car dimensions)) + (dimensions (cdr dimensions)) + (count (reduce #'* dimensions))) + (loop for i below dimension + collect (listify dimensions index) + do (incf index count)))))) + (listify (array-dimensions array) start)))) + +(defun output-unreadable-array-readably (array stream) + (write-string "#." stream) + (write `(make-array ',(array-dimensions array) + :element-type ',(array-element-type array) + :initial-contents ',(listify-array array)) + :stream stream)) + +;;; Output the readable #A form of an array. +(defun output-array-guts (array stream) + (cond ((or (not *print-readably*) + (array-readably-printable-p array)) + (write-char #\# stream) + (let ((*print-base* 10) + (*print-radix* nil)) + (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))) + (*read-eval* + (output-unreadable-array-readably array stream)) + (t + (print-not-readable-error array stream)))) (defun sub-output-array-guts (array dimensions stream index) (declare (type (simple-array * (*)) array) (fixnum index)) diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp index 33f12aa..7261f62 100644 --- a/tests/print.impure.lisp +++ b/tests/print.impure.lisp @@ -579,4 +579,56 @@ (handler-bind ((print-not-readable #'sb-ext:print-unreadably)) (write-to-string (coerce "foo" 'base-string) :readably t))))) +(with-test (:name :printing-specialized-arrays-readably) + (let ((*read-eval* t) + (dimss (loop repeat 10 + collect (loop repeat (1+ (random 3)) + collect (1+ (random 10))))) + (props sb-vm::*specialized-array-element-type-properties*)) + (labels ((random-elt (type) + (case type + (base-char + (code-char (random 128))) + (character + (code-char (random char-code-limit))) + (single-float + (+ least-positive-normalized-single-float + (random most-positive-single-float))) + (double-float + (+ least-positive-normalized-double-float + (random most-positive-double-float))) + (bit + (random 2)) + (fixnum + (random most-positive-fixnum)) + ((t) + t) + (otherwise + (destructuring-bind (type x) type + (ecase type + (unsigned-byte + (random (1- (expt 2 x)))) + (signed-byte + (- (random (expt 2 (1- x))))) + (complex + (complex (random-elt x) (random-elt x))))))))) + (dotimes (i (length props)) + (let ((et (sb-vm::saetp-specifier (aref props i)))) + (when et + (when (eq 'base-char et) + ;; base-strings not included in the #. printing. + (go :next)) + (dolist (dims dimss) + (let ((a (make-array dims :element-type et))) + (assert (equal et (array-element-type a))) + (dotimes (i (array-total-size a)) + (setf (row-major-aref a i) (random-elt et))) + (let ((copy (read-from-string (write-to-string a :readably t)))) + (assert (equal dims (array-dimensions copy))) + (assert (equal et (array-element-type copy))) + (assert (equal (array-total-size a) (array-total-size copy))) + (dotimes (i (array-total-size a)) + (assert (equal (row-major-aref a i) (row-major-aref copy i))))))))) + :next)))) + ;;; success -- 1.7.10.4