X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=1b3d50688da233e3acbe84ae39aea496016e0389;hb=902e93736a0888aa6b04dc328b1eb328423bf426;hp=8adb473b45fc82c642bb2aa22b6db214750fc9f7;hpb=74a48d09e08aead6f67204878bdf9be4f448e1e8;p=sbcl.git diff --git a/src/code/array.lisp b/src/code/array.lisp index 8adb473..1b3d506 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,31 @@ (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) + (multiple-value-bind (vector index) + (%with-array-data array index nil) + (values vector index)) + (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) @@ -85,8 +100,8 @@ ;; and for all in any reasonable user programs.) ((t) (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits)) - ((character base-char standard-char) - (values #.sb!vm:simple-string-widetag #.sb!vm:n-byte-bits)) + ((base-char standard-char) + (values #.sb!vm:simple-base-string-widetag #.sb!vm:n-byte-bits)) ((bit) (values #.sb!vm:simple-bit-vector-widetag 1)) ;; OK, we have to wade into SUBTYPEPing after all. @@ -94,7 +109,8 @@ ;; FIXME: The data here are redundant with ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*. (pick-vector-type type - (base-char (values #.sb!vm:simple-string-widetag #.sb!vm:n-byte-bits)) + (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)) @@ -135,14 +151,17 @@ ;; Pick off some easy common cases. ((t) #.sb!vm:complex-vector-widetag) - ((character base-char) - #.sb!vm:complex-string-widetag) + ((base-char) + #.sb!vm:complex-base-string-widetag) + ((nil) + #.sb!vm:complex-vector-nil-widetag) ((bit) #.sb!vm:complex-bit-vector-widetag) ;; OK, we have to wade into SUBTYPEPing after all. (t (pick-vector-type type - (base-char #.sb!vm:complex-string-widetag) + (nil #.sb!vm:complex-vector-nil-widetag) + (base-char #.sb!vm:complex-base-string-widetag) (bit #.sb!vm:complex-bit-vector-widetag) (t #.sb!vm:complex-vector-widetag))))) @@ -160,16 +179,16 @@ (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 length - (ceiling (* (if (= type sb!vm:simple-string-widetag) + (ceiling (* (if (= type sb!vm:simple-base-string-widetag) (1+ length) length) n-bits) @@ -188,7 +207,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 @@ -239,7 +258,7 @@ (setf (%array-dimension array axis) dim) (incf axis))) array)))) - + ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the ;;; specified array characteristics. Dimensions is only used to pass ;;; to FILL-DATA-VECTOR for error checking on the structure of @@ -295,7 +314,6 @@ (coerce (the list objects) 'simple-vector)) ;;;; accessor/setter functions - (eval-when (:compile-toplevel :execute) (defparameter *specialized-array-element-types* '(t @@ -315,11 +333,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 +347,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 +363,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 +389,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 +450,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,7 +558,8 @@ ;; FIXME: The data here are redundant with ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*. (pick-element-type - ((sb!vm:simple-string-widetag sb!vm:complex-string-widetag) 'base-char) + ((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) @@ -539,7 +589,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 +877,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