X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcode%2Farray.lisp;h=68aa0c6df08c29abaf0b4472fd66e360dd09e21d;hb=acce826c593a188b231b7b7918c752bda21d0201;hp=8adb473b45fc82c642bb2aa22b6db214750fc9f7;hpb=74a48d09e08aead6f67204878bdf9be4f448e1e8;p=sbcl.git diff --git a/src/code/array.lisp b/src/code/array.lisp index 8adb473..68aa0c6 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -19,18 +19,18 @@ ;;; These functions are only needed by the interpreter, 'cause the ;;; compiler inlines them. -(macrolet ((def-frob (name) +(macrolet ((def (name) `(progn (defun ,name (array) (,name array)) (defun (setf ,name) (value array) (setf (,name array) value))))) - (def-frob %array-fill-pointer) - (def-frob %array-fill-pointer-p) - (def-frob %array-available-elements) - (def-frob %array-data-vector) - (def-frob %array-displacement) - (def-frob %array-displaced-p)) + (def %array-fill-pointer) + (def %array-fill-pointer-p) + (def %array-available-elements) + (def %array-data-vector) + (def %array-displacement) + (def %array-displaced-p)) (defun %array-rank (array) (%array-rank array)) @@ -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) @@ -319,7 +332,7 @@ (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 +341,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 +357,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 +383,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 +444,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. @@ -539,7 +582,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