X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=6e46a9d38d71c1b2d4ec0fd597c8ca05cdad8231;hb=cd13034f9415f64cdaa05893a4ac5ff1e95c97bd;hp=e951999acb4d36dd4417e87fd3dc76ebd271f814;hpb=9767de1cecfe50560fe1da69fd458b6148a66da3;p=sbcl.git diff --git a/src/code/array.lisp b/src/code/array.lisp index e951999..6e46a9d 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -65,15 +65,6 @@ (bug "called FAILED-%WITH-ARRAY-DATA with valid array parameters?")) ;;;; MAKE-ARRAY -(defun upgraded-array-element-type (spec &optional environment) - #!+sb-doc - "Return the element type that will actually be used to implement an array - with the specifier :ELEMENT-TYPE Spec." - (declare (ignore environment)) - (if (unknown-type-p (specifier-type spec)) - (error "undefined type: ~S" spec) - (type-specifier (array-type-specialized-element-type - (specifier-type `(array ,spec)))))) (eval-when (:compile-toplevel :execute) (sb!xc:defmacro pick-vector-type (type &rest specs) `(cond ,@(mapcar (lambda (spec) @@ -106,46 +97,14 @@ (values #.sb!vm:simple-bit-vector-widetag 1)) ;; OK, we have to wade into SUBTYPEPing after all. (t - ;; FIXME: The data here are redundant with - ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*. - (pick-vector-type type - (nil (values #.sb!vm:simple-array-nil-widetag 0)) - (base-char (values #.sb!vm:simple-base-string-widetag #.sb!vm:n-byte-bits)) - (bit (values #.sb!vm:simple-bit-vector-widetag 1)) - ((unsigned-byte 2) - (values #.sb!vm:simple-array-unsigned-byte-2-widetag 2)) - ((unsigned-byte 4) - (values #.sb!vm:simple-array-unsigned-byte-4-widetag 4)) - ((unsigned-byte 8) - (values #.sb!vm:simple-array-unsigned-byte-8-widetag 8)) - ((unsigned-byte 16) - (values #.sb!vm:simple-array-unsigned-byte-16-widetag 16)) - ((unsigned-byte 32) - (values #.sb!vm:simple-array-unsigned-byte-32-widetag 32)) - ((signed-byte 8) - (values #.sb!vm:simple-array-signed-byte-8-widetag 8)) - ((signed-byte 16) - (values #.sb!vm:simple-array-signed-byte-16-widetag 16)) - ((signed-byte 30) - (values #.sb!vm:simple-array-signed-byte-30-widetag 32)) - ((signed-byte 32) - (values #.sb!vm:simple-array-signed-byte-32-widetag 32)) - (single-float (values #.sb!vm:simple-array-single-float-widetag 32)) - (double-float (values #.sb!vm:simple-array-double-float-widetag 64)) - #!+long-float - (long-float - (values #.sb!vm:simple-array-long-float-widetag - #!+x86 96 #!+sparc 128)) - ((complex single-float) - (values #.sb!vm:simple-array-complex-single-float-widetag 64)) - ((complex double-float) - (values #.sb!vm:simple-array-complex-double-float-widetag 128)) - #!+long-float - ((complex long-float) - (values #.sb!vm:simple-array-complex-long-float-widetag - #!+x86 192 - #!+sparc 256)) - (t (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits)))))) + #.`(pick-vector-type type + ,@(map 'list + (lambda (saetp) + `(,(sb!vm:saetp-specifier saetp) + (values ,(sb!vm:saetp-typecode saetp) + ,(sb!vm:saetp-n-bits saetp)))) + sb!vm:*specialized-array-element-type-properties*))))) + (defun %complex-vector-widetag (type) (case type ;; Pick off some easy common cases. @@ -168,7 +127,8 @@ (defun make-array (dimensions &key (element-type t) (initial-element nil initial-element-p) - initial-contents adjustable fill-pointer + (initial-contents nil initial-contents-p) + adjustable fill-pointer displaced-to displaced-index-offset) (let* ((dimensions (if (listp dimensions) dimensions (list dimensions))) (array-rank (length (the list dimensions))) @@ -196,8 +156,8 @@ (declare (type index length)) (when initial-element-p (fill array initial-element)) - (when initial-contents - (when initial-element + (when initial-contents-p + (when initial-element-p (error "can't specify both :INITIAL-ELEMENT and ~ :INITIAL-CONTENTS")) (unless (= length (length initial-contents)) @@ -212,7 +172,8 @@ (data (or displaced-to (data-vector-from-inits dimensions total-size element-type - initial-contents initial-element initial-element-p))) + initial-contents initial-contents-p + initial-element initial-element-p))) (array (make-array-header (cond ((= array-rank 1) (%complex-vector-widetag element-type)) @@ -242,7 +203,7 @@ (setf (%array-available-elements array) total-size) (setf (%array-data-vector array) data) (cond (displaced-to - (when (or initial-element-p initial-contents) + (when (or initial-element-p initial-contents-p) (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~ can be specified along with :DISPLACED-TO")) (let ((offset (or displaced-index-offset 0))) @@ -264,9 +225,9 @@ ;;; to FILL-DATA-VECTOR for error checking on the structure of ;;; initial-contents. (defun data-vector-from-inits (dimensions total-size element-type - initial-contents initial-element - initial-element-p) - (when (and initial-contents initial-element-p) + initial-contents initial-contents-p + initial-element initial-element-p) + (when (and initial-contents-p initial-element-p) (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to either MAKE-ARRAY or ADJUST-ARRAY.")) (let ((data (if initial-element-p @@ -281,7 +242,7 @@ (error "~S cannot be used to initialize an array of type ~S." initial-element element-type)) (fill (the vector data) initial-element))) - (initial-contents + (initial-contents-p (fill-data-vector data dimensions initial-contents))) data)) @@ -314,42 +275,20 @@ (coerce (the list objects) 'simple-vector)) ;;;; accessor/setter functions -(eval-when (:compile-toplevel :execute) - (defparameter *specialized-array-element-types* - ;; FIXME: Ideally we would generate this list from - ;; SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES. However, this list - ;; is optimized for frequency of occurrence, not type lattice - ;; relationships, so it's tricky to do so cleanly. - '(t - character - bit - (unsigned-byte 8) - (unsigned-byte 16) - (unsigned-byte 32) - (signed-byte 8) - (signed-byte 16) - (signed-byte 30) - (signed-byte 32) - single-float - double-float - #!+long-float long-float - (complex single-float) - (complex double-float) - #!+long-float (complex long-float) - (unsigned-byte 4) - (unsigned-byte 2) - nil))) - (defun hairy-data-vector-ref (array index) (with-array-data ((vector array) (index index) (end)) (declare (ignore end)) (etypecase vector . - #.(mapcar (lambda (type) - (let ((atype `(simple-array ,type (*)))) - `(,atype - (data-vector-ref (the ,atype vector) - index)))) - *specialized-array-element-types*)))) + #.(map 'list + (lambda (saetp) + (let* ((type (sb!vm:saetp-specifier saetp)) + (atype `(simple-array ,type (*)))) + `(,atype + (data-vector-ref (the ,atype vector) index)))) + (sort + (copy-seq + sb!vm:*specialized-array-element-type-properties*) + #'> :key #'sb!vm:saetp-importance))))) ;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but ;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function @@ -361,20 +300,23 @@ (with-array-data ((vector array) (index index) (end)) (declare (ignore end)) (etypecase vector . - #.(mapcar (lambda (type) - (let ((atype `(simple-array ,type (*)))) - `(,atype - (data-vector-set (the ,atype vector) - index - (the ,type - new-value)) - ;; For specialized arrays, the return - ;; from data-vector-set would have to - ;; be reboxed to be a (Lisp) return - ;; value; instead, we use the - ;; already-boxed value as the return. - new-value))) - *specialized-array-element-types*)))) + #.(map 'list + (lambda (saetp) + (let* ((type (sb!vm:saetp-specifier saetp)) + (atype `(simple-array ,type (*)))) + `(,atype + (data-vector-set (the ,atype vector) index + (the ,type new-value)) + ;; For specialized arrays, the return from + ;; data-vector-set would have to be + ;; reboxed to be a (Lisp) return value; + ;; instead, we use the already-boxed value + ;; as the return. + new-value))) + (sort + (copy-seq + sb!vm:*specialized-array-element-type-properties*) + #'> :key #'sb!vm:saetp-importance))))) (defun %array-row-major-index (array subscripts &optional (invalid-index-error-p t)) @@ -394,7 +336,7 @@ (let ((index (car subs)) (dim (%array-dimension array axis))) (declare (fixnum dim)) - (unless (< -1 index dim) + (unless (and (fixnump index) (< -1 index dim)) (if invalid-index-error-p (error 'simple-type-error :format-control "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S" @@ -406,7 +348,7 @@ (setf chunk-size (* chunk-size dim)))) (let ((index (first subscripts)) (length (length (the (simple-array * (*)) array)))) - (unless (< -1 index length) + (unless (and (fixnump index) (< -1 index length)) (if invalid-index-error-p ;; FIXME: perhaps this should share a format-string ;; with INVALID-ARRAY-INDEX-ERROR or @@ -421,7 +363,7 @@ (defun array-in-bounds-p (array &rest subscripts) #!+sb-doc - "Return T if the Subscipts are in bounds for the Array, Nil otherwise." + "Return T if the SUBSCIPTS are in bounds for the ARRAY, NIL otherwise." (if (%array-row-major-index array subscripts nil) t)) @@ -430,7 +372,7 @@ (defun aref (array &rest subscripts) #!+sb-doc - "Return the element of the Array specified by the Subscripts." + "Return the element of the ARRAY specified by the SUBSCRIPTS." (row-major-aref array (%array-row-major-index array subscripts))) (defun %aset (array &rest stuff) @@ -559,41 +501,23 @@ `(= widetag ,item)))) (cdr stuff))) stuff)))) - ;; FIXME: The data here are redundant with - ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*. - (pick-element-type - ((sb!vm:simple-array-nil-widetag sb!vm:complex-vector-nil-widetag) nil) - ((sb!vm:simple-base-string-widetag sb!vm:complex-base-string-widetag) 'base-char) - ((sb!vm:simple-bit-vector-widetag - sb!vm:complex-bit-vector-widetag) 'bit) - (sb!vm:simple-vector-widetag t) - (sb!vm:simple-array-unsigned-byte-2-widetag '(unsigned-byte 2)) - (sb!vm:simple-array-unsigned-byte-4-widetag '(unsigned-byte 4)) - (sb!vm:simple-array-unsigned-byte-8-widetag '(unsigned-byte 8)) - (sb!vm:simple-array-unsigned-byte-16-widetag '(unsigned-byte 16)) - (sb!vm:simple-array-unsigned-byte-32-widetag '(unsigned-byte 32)) - (sb!vm:simple-array-signed-byte-8-widetag '(signed-byte 8)) - (sb!vm:simple-array-signed-byte-16-widetag '(signed-byte 16)) - (sb!vm:simple-array-signed-byte-30-widetag '(signed-byte 30)) - (sb!vm:simple-array-signed-byte-32-widetag '(signed-byte 32)) - (sb!vm:simple-array-single-float-widetag 'single-float) - (sb!vm:simple-array-double-float-widetag 'double-float) - #!+long-float - (sb!vm:simple-array-long-float-widetag 'long-float) - (sb!vm:simple-array-complex-single-float-widetag - '(complex single-float)) - (sb!vm:simple-array-complex-double-float-widetag - '(complex double-float)) - #!+long-float - (sb!vm:simple-array-complex-long-float-widetag '(complex long-float)) - ((sb!vm:simple-array-widetag - sb!vm:complex-vector-widetag - sb!vm:complex-array-widetag) - (with-array-data ((array array) (start) (end)) - (declare (ignore start end)) - (array-element-type array))) - (t - (error 'type-error :datum array :expected-type 'array)))))) + #.`(pick-element-type + ,@(map 'list + (lambda (saetp) + `(,(if (sb!vm:saetp-complex-typecode saetp) + (list (sb!vm:saetp-typecode saetp) + (sb!vm:saetp-complex-typecode saetp)) + (sb!vm:saetp-typecode saetp)) + ',(sb!vm:saetp-specifier saetp))) + sb!vm:*specialized-array-element-type-properties*) + ((sb!vm:simple-array-widetag + sb!vm:complex-vector-widetag + sb!vm:complex-array-widetag) + (with-array-data ((array array) (start) (end)) + (declare (ignore start end)) + (array-element-type array))) + (t + (error 'type-error :datum array :expected-type 'array)))))) (defun array-rank (array) #!+sb-doc @@ -737,7 +661,8 @@ (defun adjust-array (array dimensions &key (element-type (array-element-type array)) (initial-element nil initial-element-p) - initial-contents fill-pointer + (initial-contents nil initial-contents-p) + fill-pointer displaced-to displaced-index-offset) #!+sb-doc "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff." @@ -752,7 +677,7 @@ (declare (fixnum array-rank)) (when (and fill-pointer (> array-rank 1)) (error "Multidimensional arrays can't have fill pointers.")) - (cond (initial-contents + (cond (initial-contents-p ;; array former contents replaced by INITIAL-CONTENTS (if (or initial-element-p displaced-to) (error "INITIAL-CONTENTS may not be specified with ~ @@ -760,8 +685,8 @@ (let* ((array-size (apply #'* dimensions)) (array-data (data-vector-from-inits dimensions array-size element-type - initial-contents initial-element - initial-element-p))) + initial-contents initial-contents-p + initial-element initial-element-p))) (if (adjustable-array-p array) (set-array-header array array-data array-size (get-new-fill-pointer array array-size @@ -812,8 +737,8 @@ (setf new-data (data-vector-from-inits dimensions new-length element-type - initial-contents initial-element - initial-element-p)) + initial-contents initial-contents-p + initial-element initial-element-p)) (replace new-data old-data :start2 old-start :end2 old-end)) (t (setf new-data @@ -835,8 +760,8 @@ (> new-length old-length)) (data-vector-from-inits dimensions new-length - element-type () initial-element - initial-element-p) + element-type () nil + initial-element initial-element-p) old-data))) (if (or (zerop old-length) (zerop new-length)) (when initial-element-p (fill new-data initial-element)) @@ -890,33 +815,16 @@ ,fill-value :start new-length)))) things)))) - ;; FIXME: The associations between vector types and initial - ;; values here are redundant with - ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*. - (frob vector - (simple-vector 0) - (simple-base-string #.*default-init-char-form*) - (simple-bit-vector 0) - ((simple-array (unsigned-byte 2) (*)) 0) - ((simple-array (unsigned-byte 4) (*)) 0) - ((simple-array (unsigned-byte 8) (*)) 0) - ((simple-array (unsigned-byte 16) (*)) 0) - ((simple-array (unsigned-byte 32) (*)) 0) - ((simple-array (signed-byte 8) (*)) 0) - ((simple-array (signed-byte 16) (*)) 0) - ((simple-array (signed-byte 30) (*)) 0) - ((simple-array (signed-byte 32) (*)) 0) - ((simple-array single-float (*)) (coerce 0 'single-float)) - ((simple-array double-float (*)) (coerce 0 'double-float)) - #!+long-float - ((simple-array long-float (*)) (coerce 0 'long-float)) - ((simple-array (complex single-float) (*)) - (coerce 0 '(complex single-float))) - ((simple-array (complex double-float) (*)) - (coerce 0 '(complex double-float))) - #!+long-float - ((simple-array (complex long-float) (*)) - (coerce 0 '(complex long-float)))))) + #.`(frob vector + ,@(map 'list + (lambda (saetp) + `((simple-array ,(sb!vm:saetp-specifier saetp) (*)) + ,(if (eq (sb!vm:saetp-specifier saetp) 'base-char) + *default-init-char-form* + (sb!vm:saetp-initial-element-default saetp)))) + (remove-if-not + #'sb!vm:saetp-specifier + sb!vm:*specialized-array-element-type-properties*))))) ;; Only arrays have fill-pointers, but vectors have their length ;; parameter in the same place. (setf (%array-fill-pointer vector) new-length)