X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=68aa0c6df08c29abaf0b4472fd66e360dd09e21d;hb=2010727926b091b23a246f6f659be61e27e19667;hp=f2b646ab0c15592b942e50b30e8e9fe824722b85;hpb=5384ab22e633886f56e981054bf83580765008ad;p=sbcl.git diff --git a/src/code/array.lisp b/src/code/array.lisp index f2b646a..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. @@ -492,20 +535,20 @@ "Return the type of the elements of the array" (let ((widetag (widetag-of array))) (macrolet ((pick-element-type (&rest stuff) - `(cond ,@(mapcar #'(lambda (stuff) - (cons - (let ((item (car stuff))) - (cond ((eq item t) - t) - ((listp item) - (cons 'or - (mapcar (lambda (x) - `(= widetag ,x)) - item))) - (t - `(= widetag ,item)))) - (cdr stuff))) - stuff)))) + `(cond ,@(mapcar (lambda (stuff) + (cons + (let ((item (car stuff))) + (cond ((eq item t) + t) + ((listp item) + (cons 'or + (mapcar (lambda (x) + `(= widetag ,x)) + item))) + (t + `(= widetag ,item)))) + (cdr stuff))) + stuff)))) ;; FIXME: The data here are redundant with ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*. (pick-element-type @@ -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 @@ -930,9 +973,9 @@ (defun zap-array-data-aux (old-data old-dims offset new-data new-dims) (declare (fixnum offset)) - (let ((limits (mapcar #'(lambda (x y) - (declare (fixnum x y)) - (1- (the fixnum (min x y)))) + (let ((limits (mapcar (lambda (x y) + (declare (fixnum x y)) + (1- (the fixnum (min x y)))) old-dims new-dims))) (macrolet ((bump-index-list (index limits) `(do ((subscripts ,index (cdr subscripts))