X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=a384a6c0e64234ca22189dc70ec086f4df9d0710;hb=d61775ee52828f379eb6acedca421d5a55bfa2bd;hp=579064e88e77db57fc7dfe63dc4e1a8982afff2a;hpb=09d7974601df2aaaa820ca576026b9b4f03e6ab1;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 579064e..a384a6c 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -187,13 +187,13 @@ ,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-) @@ -227,7 +227,10 @@ (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) @@ -278,37 +281,41 @@ (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) @@ -339,7 +346,22 @@ (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)) @@ -347,14 +369,17 @@ '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)) @@ -610,14 +635,21 @@ (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