X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=9d1045d3a44260d39b9d0f80aa03351e294a9ee8;hb=2db3b6b4cb740d5b6512459c223859f747807b09;hp=dbbfbee7c4eb2eabd783022bf6891d7356ff035b;hpb=0c7ffa8fb85a94482814835c9f28abfd0400ab99;p=sbcl.git diff --git a/src/code/array.lisp b/src/code/array.lisp index dbbfbee..9d1045d 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -49,16 +49,29 @@ (defun %with-array-data (array start end) (%with-array-data-macro array start end :fail-inline? t)) +(defun %data-vector-and-index (array index) + (if (array-header-p array) + (%with-array-data array index nil) + (values array index))) + ;;; It'd waste space to expand copies of error handling in every ;;; inline %WITH-ARRAY-DATA, so we have them call this function ;;; instead. This is just a wrapper which is known never to return. (defun failed-%with-array-data (array start end) (declare (notinline %with-array-data)) (%with-array-data array start end) - (error "internal error: shouldn't be here with valid parameters")) + (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) @@ -94,6 +107,7 @@ ;; 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-string-widetag #.sb!vm:n-byte-bits)) (bit (values #.sb!vm:simple-bit-vector-widetag 1)) ((unsigned-byte 2) @@ -160,11 +174,11 @@ (when (and displaced-index-offset (null displaced-to)) (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO")) (if (and simple (= array-rank 1)) - ;; Its a (simple-array * (*)) + ;; it's a (SIMPLE-ARRAY * (*)) (multiple-value-bind (type n-bits) (%vector-widetag-and-n-bits element-type) (declare (type (unsigned-byte 8) type) - (type (integer 1 256) n-bits)) + (type (integer 0 256) n-bits)) (let* ((length (car dimensions)) (array (allocate-vector type @@ -188,7 +202,7 @@ length)) (replace array initial-contents)) array)) - ;; It's either a complex array or a multidimensional array. + ;; it's either a complex array or a multidimensional array. (let* ((total-size (reduce #'* dimensions)) (data (or displaced-to (data-vector-from-inits @@ -315,11 +329,12 @@ #!+long-float long-float (complex single-float) (complex double-float) - #!+long-float (complex long-float)))) + #!+long-float (complex long-float) + nil))) (defun hairy-data-vector-ref (array index) (with-array-data ((vector array) (index index) (end)) - (declare (ignore end) (optimize (safety 3))) + (declare (ignore end)) (etypecase vector . #.(mapcar (lambda (type) (let ((atype `(simple-array ,type (*)))) @@ -328,9 +343,15 @@ index)))) *specialized-array-element-types*)))) +;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but +;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function +;;; definition is needed for the compiler to use in constant folding.) +(defun data-vector-ref (array index) + (hairy-data-vector-ref array index)) + (defun hairy-data-vector-set (array index new-value) (with-array-data ((vector array) (index index) (end)) - (declare (ignore end) (optimize (safety 3))) + (declare (ignore end)) (etypecase vector . #.(mapcar (lambda (type) (let ((atype `(simple-array ,type (*)))) @@ -338,7 +359,13 @@ (data-vector-set (the ,atype vector) index (the ,type - new-value))))) + 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*)))) (defun %array-row-major-index (array subscripts @@ -358,18 +385,29 @@ (declare (list subs) (fixnum axis chunk-size result)) (let ((index (car subs)) (dim (%array-dimension array axis))) - (declare (fixnum index dim)) + (declare (fixnum dim)) (unless (< -1 index dim) (if invalid-index-error-p - (error "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S" - index axis array) + (error 'simple-type-error + :format-control "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S" + :format-arguments (list index axis array) + :datum index + :expected-type `(integer 0 (,dim))) (return-from %array-row-major-index nil))) - (incf result (* chunk-size index)) + (incf result (* chunk-size (the fixnum index))) (setf chunk-size (* chunk-size dim)))) - (let ((index (first subscripts))) - (unless (< -1 index (length (the (simple-array * (*)) array))) + (let ((index (first subscripts)) + (length (length (the (simple-array * (*)) array)))) + (unless (< -1 index length) (if invalid-index-error-p - (error "invalid index ~W in ~S" index array) + ;; FIXME: perhaps this should share a format-string + ;; with INVALID-ARRAY-INDEX-ERROR or + ;; INDEX-TOO-LARGE-ERROR? + (error 'simple-type-error + :format-control "invalid index ~W in ~S" + :format-arguments (list index array) + :datum index + :expected-type `(integer 0 (,length))) (return-from %array-row-major-index nil))) index)))) @@ -408,6 +446,13 @@ ;;; ZOO ;;; But that doesn't seem to be what happens in CMU CL. ;;; +;;; KLUDGE: this is probably because ANSI, in its wisdom (CLHS +;;; 5.1.2.5) requires implementations to support +;;; (SETF (APPLY #'AREF ...) ...) +;;; [and also #'BIT and #'SBIT]. Yes, this is terrifying, and it's +;;; also terrifying that this sequence of definitions causes it to +;;; work. +;;; ;;; Also, it would be nice to make DESCRIBE FOO tell whether a symbol ;;; has a setf expansion and/or a setf function defined. @@ -509,6 +554,7 @@ ;; FIXME: The data here are redundant with ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*. (pick-element-type + (sb!vm:simple-array-nil-widetag nil) ((sb!vm:simple-string-widetag sb!vm:complex-string-widetag) 'base-char) ((sb!vm:simple-bit-vector-widetag sb!vm:complex-bit-vector-widetag) 'bit) @@ -539,7 +585,7 @@ (declare (ignore start end)) (array-element-type array))) (t - (error "~S is not an array." array)))))) + (error 'type-error :datum array :expected-type 'array)))))) (defun array-rank (array) #!+sb-doc @@ -827,6 +873,8 @@ (unless (array-header-p vector) (macrolet ((frob (name &rest things) `(etypecase ,name + ((simple-array nil (*)) (error 'cell-error + :name 'nil-array-element)) ,@(mapcar (lambda (thing) (destructuring-bind (type-spec fill-value) thing