X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=3aaaf74cc7a27268e9062dc93587a89ceb30d71c;hb=5f0cfcf9095f2d8dbca4ddf703c580a36d5c3709;hp=ec2ad868531ec44eefdf1b401cf7b5b94e8f0bbf;hpb=171fde84561e232b8af8c05b82dfe8a8f9e08340;p=sbcl.git

diff --git a/src/code/print.lisp b/src/code/print.lisp
index ec2ad86..3aaaf74 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -524,6 +524,9 @@ variable: an unreadable object representing the error is printed instead.")
      (output-code-component object stream))
     (fdefn
      (output-fdefn object stream))
+    #!+sb-simd-pack
+    (simd-pack
+     (output-simd-pack object stream))
     (t
      (output-random object stream))))
 
@@ -584,7 +587,8 @@ variable: an unreadable object representing the error is printed instead.")
 (defun output-symbol (object stream)
   (if (or *print-escape* *print-readably*)
       (let ((package (symbol-package object))
-            (name (symbol-name object)))
+            (name (symbol-name object))
+            (current (sane-package)))
         (cond
          ;; The ANSI spec "22.1.3.3.1 Package Prefixes for Symbols"
          ;; requires that keywords be printed with preceding colons
@@ -593,19 +597,24 @@ variable: an unreadable object representing the error is printed instead.")
           (write-char #\: stream))
          ;; Otherwise, if the symbol's home package is the current
          ;; one, then a prefix is never necessary.
-         ((eq package (sane-package)))
+         ((eq package current))
          ;; Uninterned symbols print with a leading #:.
          ((null package)
           (when (or *print-gensym* *print-readably*)
             (write-string "#:" stream)))
          (t
           (multiple-value-bind (symbol accessible)
-              (find-symbol name (sane-package))
+              (find-symbol name current)
             ;; If we can find the symbol by looking it up, it need not
             ;; be qualified. This can happen if the symbol has been
             ;; inherited from a package other than its home package.
+            ;;
+            ;; To preserve print-read consistency, use the local nickname if
+            ;; one exists.
             (unless (and accessible (eq symbol object))
-              (output-symbol-name (package-name package) stream)
+              (let ((prefix (or (car (rassoc package (package-%local-nicknames current)))
+                                (package-name package))))
+                (output-symbol-name prefix stream))
               (multiple-value-bind (symbol externalp)
                   (find-external-symbol name package)
                 (declare (ignore symbol))
@@ -991,6 +1000,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 +1030,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 +1039,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 +1083,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))
@@ -1736,6 +1778,58 @@ variable: an unreadable object representing the error is printed instead.")
   (print-unreadable-object (fdefn stream)
     (write-string "FDEFINITION object for " stream)
     (output-object (fdefn-name fdefn) stream)))
+
+#!+sb-simd-pack
+(defun output-simd-pack (pack stream)
+  (declare (type simd-pack pack))
+  (cond ((and *print-readably* *read-eval*)
+         (etypecase pack
+           ((simd-pack double-float)
+            (multiple-value-call #'format stream
+              "#.(~S ~S ~S)"
+              '%make-simd-pack-double
+              (%simd-pack-doubles pack)))
+           ((simd-pack single-float)
+            (multiple-value-call #'format stream
+              "#.(~S ~S ~S ~S ~S)"
+              '%make-simd-pack-single
+              (%simd-pack-singles pack)))
+           (t
+            (multiple-value-call #'format stream
+              "#.(~S #X~16,'0X #X~16,'0X)"
+              '%make-simd-pack-ub64
+              (%simd-pack-ub64s pack)))))
+        (t
+         (print-unreadable-object (pack stream)
+           (flet ((all-ones-p (value start end &aux (mask (- (ash 1 end) (ash 1 start))))
+                      (= (logand value mask) mask))
+                    (split-num (value start)
+                      (loop
+                         for i from 0 to 3
+                         and v = (ash value (- start)) then (ash v -8)
+                         collect (logand v #xFF))))
+             (multiple-value-bind (low high)
+                 (%simd-pack-ub64s pack)
+               (etypecase pack
+                 ((simd-pack double-float)
+                  (multiple-value-bind (v0 v1) (%simd-pack-doubles pack)
+                    (format stream "~S~@{ ~:[~,13E~;~*TRUE~]~}"
+                            'simd-pack
+                            (all-ones-p low 0 64) v0
+                            (all-ones-p high 0 64) v1)))
+                 ((simd-pack single-float)
+                  (multiple-value-bind (v0 v1 v2 v3) (%simd-pack-singles pack)
+                    (format stream "~S~@{ ~:[~,7E~;~*TRUE~]~}"
+                            'simd-pack
+                            (all-ones-p low 0 32) v0
+                            (all-ones-p low 32 64) v1
+                            (all-ones-p high 0 32) v2
+                            (all-ones-p high 32 64) v3)))
+                 (t
+                  (format stream "~S~@{ ~{ ~2,'0X~}~}"
+                          'simd-pack
+                          (split-num low 0) (split-num low 32)
+                          (split-num high 0) (split-num high 32))))))))))
 
 ;;;; functions