printing specialized arrays readably

  When *READ-EVAL* is true, use #. based syntax to print them.

  lp#803665.

diff --git a/NEWS b/NEWS
index 5c384d4..9a82f45 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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