,n-vec))))
;;; Just convert it into a MAKE-ARRAY.
-(define-source-transform 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))
+(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-)
(destructuring-bind (type-spec &rest rest) args
(let ((ctype (specifier-type type-spec)))
(apply #'!make-saetp ctype rest))))
- `((base-char ,(code-char 0) 8 ,sb!vm:simple-string-widetag
+ `(;; 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)
(saetp (find-if (lambda (saetp)
(csubtypep eltype-type (saetp-ctype saetp)))
*specialized-array-element-type-properties*))
- (creation-form `(make-array dims :element-type ',eltype
- ,@(when fill-pointer
- '(:fill-pointer fill-pointer))
- ,@(when adjustable
- '(:adjustable adjustable)))))
+ (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 ((or (null initial-element)
- (and (constant-continuation-p initial-element)
- (eql (continuation-value initial-element)
- (saetp-initial-element-default saetp))))
- (unless (csubtypep (ctype-of (saetp-initial-element-default saetp))
- eltype-type)
- ;; This situation arises e.g. in (MAKE-ARRAY 4
- ;; :ELEMENT-TYPE '(INTEGER 1 5)) ANSI's definition of
- ;; MAKE-ARRAY says "If INITIAL-ELEMENT is not supplied,
- ;; the consequences of later reading an uninitialized
- ;; element of new-array are undefined," so this could be
- ;; legal code as long as the user plans to write before
- ;; he reads, and if he doesn't we're free to do anything
- ;; we like. But in case the user doesn't know to write
- ;; elements before he reads elements (or to read manuals
- ;; before he writes code:-), we'll signal a STYLE-WARNING
- ;; in case he didn't realize this.
- (compiler-style-warn "The default initial element ~S is not a ~S."
- (saetp-initial-element-default saetp)
- 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)
(unless saetp
(give-up-ir1-transform
"cannot open-code creation of ~S" result-type-spec))
-
+ #-sb-xc-host
+ (unless (csubtypep (ctype-of (saetp-initial-element-default saetp))
+ eltype-type)
+ ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
+ ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
+ ;; INITIAL-ELEMENT is not supplied, the consequences of later
+ ;; reading an uninitialized element of new-array are undefined,"
+ ;; so this could be legal code as long as the user plans to
+ ;; write before he reads, and if he doesn't we're free to do
+ ;; anything we like. But in case the user doesn't know to write
+ ;; elements before he reads elements (or to read manuals before
+ ;; he writes code:-), we'll signal a STYLE-WARNING in case he
+ ;; didn't realize this.
+ (compiler-style-warn "The default initial element ~S is not a ~S."
+ (saetp-initial-element-default saetp)
+ eltype))
(let* ((n-bits-per-element (saetp-n-bits saetp))
(typecode (saetp-typecode saetp))
(n-pad-elements (saetp-n-pad-elements saetp))
'length
`(+ length ,n-pad-elements)))
(n-words-form
- (if (>= n-bits-per-element sb!vm:n-word-bits)
- `(* ,padded-length-form
- (the fixnum ; i.e., not RATIO
- ,(/ n-bits-per-element sb!vm:n-word-bits)))
- (let ((n-elements-per-word (/ sb!vm:n-word-bits
- n-bits-per-element)))
- (declare (type index n-elements-per-word)) ; i.e., not RATIO
- `(ceiling ,padded-length-form ,n-elements-per-word)))))
+ (cond
+ ((= n-bits-per-element 0) 0)
+ ((>= n-bits-per-element sb!vm:n-word-bits)
+ `(* ,padded-length-form
+ (the fixnum ; i.e., not RATIO
+ ,(/ n-bits-per-element sb!vm:n-word-bits))))
+ (t
+ (let ((n-elements-per-word (/ sb!vm:n-word-bits
+ n-bits-per-element)))
+ (declare (type index n-elements-per-word)) ; i.e., not RATIO
+ `(ceiling ,padded-length-form ,n-elements-per-word))))))
(values
`(truly-the ,result-type-spec
(allocate-vector ,typecode length ,n-words-form))
(cond (,end
(unless (or ,unsafe? (<= ,end ,size))
,(if fail-inline?
- `(error "End ~W is greater than total size ~W."
- ,end ,size)
+ `(error 'bounding-indices-bad-error
+ :datum (cons ,start ,end)
+ :expected-type `(cons (integer 0 ,',size)
+ (integer ,',start ,',size))
+ :object ,array)
`(failed-%with-array-data ,array ,start ,end)))
,end)
(t ,size))))
(unless (or ,unsafe? (<= ,start ,defaulted-end))
,(if fail-inline?
- `(error "Start ~W is greater than end ~W." ,start ,defaulted-end)
+ `(error 'bounding-indices-bad-error
+ :datum (cons ,start ,end)
+ :expected-type `(cons (integer 0 ,',size)
+ (integer ,',start ,',size))
+ :object ,array)
`(failed-%with-array-data ,array ,start ,end)))
(do ((,data ,array (%array-data-vector ,data))
(,cumulative-offset 0
projects / sbcl.git / blobdiff