-(def-source-transform make-string (length &key
- (element-type ''base-char)
- (initial-element default-init-char))
- (if (byte-compiling)
- (values nil t)
- `(make-array (the index ,length)
- :element-type ,element-type
- :initial-element ,initial-element)))
-
-(defparameter *array-info*
- #((base-char #.default-init-char 8 sb!vm:simple-string-type)
- (single-float 0.0s0 32 sb!vm:simple-array-single-float-type)
- (double-float 0.0d0 64 sb!vm:simple-array-double-float-type)
- #!+long-float (long-float 0.0l0 #!+x86 96 #!+sparc 128
- sb!vm:simple-array-long-float-type)
- (bit 0 1 sb!vm:simple-bit-vector-type)
- ((unsigned-byte 2) 0 2 sb!vm:simple-array-unsigned-byte-2-type)
- ((unsigned-byte 4) 0 4 sb!vm:simple-array-unsigned-byte-4-type)
- ((unsigned-byte 8) 0 8 sb!vm:simple-array-unsigned-byte-8-type)
- ((unsigned-byte 16) 0 16 sb!vm:simple-array-unsigned-byte-16-type)
- ((unsigned-byte 32) 0 32 sb!vm:simple-array-unsigned-byte-32-type)
- ((signed-byte 8) 0 8 sb!vm:simple-array-signed-byte-8-type)
- ((signed-byte 16) 0 16 sb!vm:simple-array-signed-byte-16-type)
- ((signed-byte 30) 0 32 sb!vm:simple-array-signed-byte-30-type)
- ((signed-byte 32) 0 32 sb!vm:simple-array-signed-byte-32-type)
- ((complex single-float) #C(0.0s0 0.0s0) 64
- sb!vm:simple-array-complex-single-float-type)
- ((complex double-float) #C(0.0d0 0.0d0) 128
- sb!vm:simple-array-complex-double-float-type)
- #!+long-float
- ((complex long-float) #C(0.0l0 0.0l0) #!+x86 192 #!+sparc 256
- sb!vm:simple-array-complex-long-float-type)
- (t 0 32 sb!vm:simple-vector-type)))
+(deftransform make-string ((length &key
+ (element-type 'base-char)
+ (initial-element
+ #.*default-init-char-form*)))
+ '(make-array (the index length)
+ :element-type element-type
+ :initial-element initial-element))
+
+(defstruct (specialized-array-element-type-properties
+ (:conc-name saetp-)
+ (:constructor !make-saetp (ctype
+ initial-element-default
+ n-bits
+ typecode
+ &key
+ (n-pad-elements 0)))
+ (:copier nil))
+ ;; the element type, e.g. #<BUILT-IN-CLASS BASE-CHAR (sealed)> or
+ ;; #<SB-KERNEL:NUMERIC-TYPE (UNSIGNED-BYTE 4)>
+ (ctype (missing-arg) :type ctype :read-only t)
+ ;; what we get when the low-level vector-creation logic zeroes all
+ ;; the bits (which also serves as the default value of MAKE-ARRAY's
+ ;; :INITIAL-ELEMENT keyword)
+ (initial-element-default (missing-arg) :read-only t)
+ ;; how many bits per element
+ (n-bits (missing-arg) :type index :read-only t)
+ ;; the low-level type code
+ (typecode (missing-arg) :type index :read-only t)
+ ;; the number of extra elements we use at the end of the array for
+ ;; low level hackery (e.g., one element for arrays of BASE-CHAR,
+ ;; which is used for a fixed #\NULL so that when we call out to C
+ ;; we don't need to cons a new copy)
+ (n-pad-elements (missing-arg) :type index :read-only t))
+
+(defparameter *specialized-array-element-type-properties*
+ (map 'simple-vector
+ (lambda (args)
+ (destructuring-bind (type-spec &rest rest) args
+ (let ((ctype (specifier-type type-spec)))
+ (apply #'!make-saetp ctype rest))))
+ `(;; Erm. Yeah. There aren't a lot of things that make sense
+ ;; for an initial element for (ARRAY NIL). -- CSR, 2002-03-07
+ (nil '#:mu 0 ,sb!vm:simple-array-nil-widetag)
+ (base-char ,(code-char 0) 8 ,sb!vm:simple-string-widetag
+ ;; (SIMPLE-STRINGs are stored with an extra trailing
+ ;; #\NULL for convenience in calling out to C.)
+ :n-pad-elements 1)
+ (single-float 0.0f0 32 ,sb!vm:simple-array-single-float-widetag)
+ (double-float 0.0d0 64 ,sb!vm:simple-array-double-float-widetag)
+ #!+long-float (long-float 0.0L0 #!+x86 96 #!+sparc 128
+ ,sb!vm:simple-array-long-float-widetag)
+ (bit 0 1 ,sb!vm:simple-bit-vector-widetag)
+ ;; KLUDGE: The fact that these UNSIGNED-BYTE entries come
+ ;; before their SIGNED-BYTE partners is significant in the
+ ;; implementation of the compiler; some of the cross-compiler
+ ;; code (see e.g. COERCE-TO-SMALLEST-ELTYPE in
+ ;; src/compiler/debug-dump.lisp) attempts to create an array
+ ;; specialized on (UNSIGNED-BYTE FOO), where FOO could be 7;
+ ;; (UNSIGNED-BYTE 7) is SUBTYPEP (SIGNED-BYTE 8), so if we're
+ ;; not careful we could get the wrong specialized array when
+ ;; we try to FIND-IF, below. -- CSR, 2002-07-08
+ ((unsigned-byte 2) 0 2 ,sb!vm:simple-array-unsigned-byte-2-widetag)
+ ((unsigned-byte 4) 0 4 ,sb!vm:simple-array-unsigned-byte-4-widetag)
+ ((unsigned-byte 8) 0 8 ,sb!vm:simple-array-unsigned-byte-8-widetag)
+ ((unsigned-byte 16) 0 16 ,sb!vm:simple-array-unsigned-byte-16-widetag)
+ ((unsigned-byte 32) 0 32 ,sb!vm:simple-array-unsigned-byte-32-widetag)
+ ((signed-byte 8) 0 8 ,sb!vm:simple-array-signed-byte-8-widetag)
+ ((signed-byte 16) 0 16 ,sb!vm:simple-array-signed-byte-16-widetag)
+ ((signed-byte 30) 0 32 ,sb!vm:simple-array-signed-byte-30-widetag)
+ ((signed-byte 32) 0 32 ,sb!vm:simple-array-signed-byte-32-widetag)
+ ((complex single-float) #C(0.0f0 0.0f0) 64
+ ,sb!vm:simple-array-complex-single-float-widetag)
+ ((complex double-float) #C(0.0d0 0.0d0) 128
+ ,sb!vm:simple-array-complex-double-float-widetag)
+ #!+long-float ((complex long-float) #C(0.0L0 0.0L0)
+ #!+x86 192 #!+sparc 256
+ ,sb!vm:simple-array-complex-long-float-widetag)
+ (t 0 32 ,sb!vm:simple-vector-widetag))))
+
+(deftransform make-array ((dims &key initial-element element-type
+ adjustable fill-pointer)
+ (t &rest *))
+ (when (null initial-element)
+ (give-up-ir1-transform))
+ (let* ((eltype (cond ((not element-type) t)
+ ((not (constant-continuation-p element-type))
+ (give-up-ir1-transform
+ "ELEMENT-TYPE is not constant."))
+ (t
+ (continuation-value element-type))))
+ (eltype-type (ir1-transform-specifier-type eltype))
+ (saetp (find-if (lambda (saetp)
+ (csubtypep eltype-type (saetp-ctype saetp)))
+ *specialized-array-element-type-properties*))
+ (creation-form `(make-array dims
+ :element-type ',(type-specifier (saetp-ctype saetp))
+ ,@(when fill-pointer
+ '(:fill-pointer fill-pointer))
+ ,@(when adjustable
+ '(:adjustable adjustable)))))
+
+ (unless saetp
+ (give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype))
+
+ (cond ((and (constant-continuation-p initial-element)
+ (eql (continuation-value initial-element)
+ (saetp-initial-element-default saetp)))
+ creation-form)
+ (t
+ ;; error checking for target, disabled on the host because
+ ;; (CTYPE-OF #\Null) is not possible.
+ #-sb-xc-host
+ (when (constant-continuation-p initial-element)
+ (let ((value (continuation-value initial-element)))
+ (cond
+ ((not (csubtypep (ctype-of value)
+ (saetp-ctype saetp)))
+ ;; this case will cause an error at runtime, so we'd
+ ;; better WARN about it now.
+ (compiler-warn "~@<~S is not a ~S (which is the ~
+ UPGRADED-ARRAY-ELEMENT-TYPE of ~S).~@:>"
+ value
+ (type-specifier (saetp-ctype saetp))
+ eltype))
+ ((not (csubtypep (ctype-of value) eltype-type))
+ ;; this case will not cause an error at runtime, but
+ ;; it's still worth STYLE-WARNing about.
+ (compiler-style-warn "~S is not a ~S."
+ value eltype)))))
+ `(let ((array ,creation-form))
+ (multiple-value-bind (vector)
+ (%data-vector-and-index array 0)
+ (fill vector initial-element))
+ array)))))