X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Farray.lisp;h=9d1045d3a44260d39b9d0f80aa03351e294a9ee8;hb=2db3b6b4cb740d5b6512459c223859f747807b09;hp=b5a380bca2b7718fc5298b202e842f5a47dd3ef0;hpb=50305b602c3953440af716137a56f50cd204375d;p=sbcl.git diff --git a/src/code/array.lisp b/src/code/array.lisp index b5a380b..9d1045d 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,23 +49,36 @@ (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) - `(,(if (eq (car spec) t) - t - `(subtypep ,type ',(car spec))) - ,@(cdr spec))) + `(cond ,@(mapcar (lambda (spec) + `(,(if (eq (car spec) t) + t + `(subtypep ,type ',(car spec))) + ,@(cdr spec))) specs)))) ;;; These functions are used in the implementation of MAKE-ARRAY for @@ -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 @@ -182,13 +196,13 @@ (error "can't specify both :INITIAL-ELEMENT and ~ :INITIAL-CONTENTS")) (unless (= length (length initial-contents)) - (error "There are ~D elements in the :INITIAL-CONTENTS, but ~ - the vector length is ~D." + (error "There are ~W elements in the :INITIAL-CONTENTS, but ~ + the vector length is ~W." (length initial-contents) 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 @@ -212,8 +226,9 @@ (unless (and (fixnump fill-pointer) (>= fill-pointer 0) (<= fill-pointer length)) - (error "invalid fill-pointer ~D" - fill-pointer)) + ;; FIXME: should be TYPE-ERROR? + (error "invalid fill-pointer ~W" + fill-pointer)) fill-pointer)))) (setf (%array-fill-pointer-p array) t)) (t @@ -274,12 +289,12 @@ (t (unless (typep contents 'sequence) (error "malformed :INITIAL-CONTENTS: ~S is not a ~ - sequence, but ~D more layer~:P needed." + sequence, but ~W more layer~:P needed." contents (- (length dimensions) axis))) (unless (= (length contents) (car dims)) (error "malformed :INITIAL-CONTENTS: Dimension of ~ - axis ~D is ~D, but ~S is ~D long." + axis ~W is ~W, but ~S is ~W long." axis (car dims) contents (length contents))) (if (listp contents) (dolist (content contents) @@ -314,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 (*)))) @@ -327,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 (*)))) @@ -337,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 @@ -346,7 +374,7 @@ (list subscripts)) (let ((rank (array-rank array))) (unless (= rank (length subscripts)) - (error "wrong number of subscripts, ~D, for array of rank ~D" + (error "wrong number of subscripts, ~W, for array of rank ~W" (length subscripts) rank)) (if (array-header-p array) (do ((subs (nreverse subscripts) (cdr subs)) @@ -357,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 ~D~[~;~:; on axis ~:*~D~] 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 ~D 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)))) @@ -407,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. @@ -489,25 +535,26 @@ (defun array-element-type (array) #!+sb-doc "Return the type of the elements of the array" - (let ((type (get-type 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) - `(= type ,x)) - item))) - (t - `(= type ,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 + (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) @@ -538,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 @@ -556,7 +603,7 @@ (error "Vector axis is not zero: ~S" axis-number)) (length (the (simple-array * (*)) array))) ((>= axis-number (%array-rank array)) - (error "~D is too big; ~S only has ~D dimension~:P." + (error "Axis number ~W is too big; ~S only has ~D dimension~:P." axis-number array (%array-rank array))) (t (%array-dimension array axis-number)))) @@ -826,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 @@ -929,9 +978,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))