(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))))
\f
(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
(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))
(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)
;; (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))
(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
(*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))
(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))))))))))
\f
;;;; functions
projects / sbcl.git / blobdiff