X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=8055ac05c57db571e9259193a7d99e2422ad0013;hb=cee8ef591040db9a79cdd19297867672a9529051;hp=90b7a996df80e31b5bb147059aeae7f36f6171b4;hpb=43c6634142a96e1d1bab2efe1a39cd8234903c41;p=sbcl.git diff --git a/src/code/array.lisp b/src/code/array.lisp index 90b7a99..8055ac0 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -133,6 +133,28 @@ (bit #.sb!vm:complex-bit-vector-widetag) (t #.sb!vm:complex-vector-widetag))))) +(defglobal %%simple-array-n-bits%% (make-array (1+ sb!vm:widetag-mask))) +#.(loop for info across sb!vm:*specialized-array-element-type-properties* + collect `(setf (aref %%simple-array-n-bits%% ,(sb!vm:saetp-typecode info)) + ,(sb!vm:saetp-n-bits info)) into forms + finally (return `(progn ,@forms))) + +(defun allocate-vector-with-widetag (widetag length &optional n-bits) + (declare (type (unsigned-byte 8) widetag) + (type index length)) + (let ((n-bits (or n-bits (aref %%simple-array-n-bits%% widetag)))) + (declare (type (integer 0 256) n-bits)) + (allocate-vector widetag length + (ceiling + (* (if (or (= widetag sb!vm:simple-base-string-widetag) + #!+sb-unicode + (= widetag + sb!vm:simple-character-string-widetag)) + (1+ length) + length) + n-bits) + sb!vm:n-word-bits)))) + (defun make-array (dimensions &key (element-type t) (initial-element nil initial-element-p) @@ -159,18 +181,7 @@ (declare (type (unsigned-byte 8) type) (type (integer 0 256) n-bits)) (let* ((length (car dimensions)) - (array (allocate-vector - type - length - (ceiling - (* (if (or (= type sb!vm:simple-base-string-widetag) - #!+sb-unicode - (= type - sb!vm:simple-character-string-widetag)) - (1+ length) - length) - n-bits) - sb!vm:n-word-bits)))) + (array (allocate-vector-with-widetag type length n-bits))) (declare (type index length)) (when initial-element-p (fill array initial-element)) @@ -189,7 +200,7 @@ (let* ((total-size (reduce #'* dimensions)) (data (or displaced-to (data-vector-from-inits - dimensions total-size element-type + dimensions total-size element-type nil initial-contents initial-contents-p initial-element initial-element-p))) (array (make-array-header @@ -289,24 +300,22 @@ of specialized arrays is supported." ;;; specified array characteristics. Dimensions is only used to pass ;;; to FILL-DATA-VECTOR for error checking on the structure of ;;; initial-contents. -(defun data-vector-from-inits (dimensions total-size element-type +(defun data-vector-from-inits (dimensions total-size + element-type widetag initial-contents initial-contents-p initial-element initial-element-p) - (when (and initial-contents-p initial-element-p) - (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to + (when initial-element-p + (when initial-contents-p + (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to either MAKE-ARRAY or ADJUST-ARRAY.")) - (let ((data (if initial-element-p - (make-array total-size - :element-type element-type - :initial-element initial-element) - (make-array total-size - :element-type element-type)))) + (unless (typep initial-element element-type) + (error "~S cannot be used to initialize an array of type ~S." + initial-element element-type))) + (let ((data (if widetag + (allocate-vector-with-widetag widetag total-size) + (make-array total-size :element-type element-type)))) (cond (initial-element-p - (unless (simple-vector-p data) - (unless (typep initial-element element-type) - (error "~S cannot be used to initialize an array of type ~S." - initial-element element-type)) - (fill (the vector data) initial-element))) + (fill (the vector data) initial-element)) (initial-contents-p (fill-data-vector data dimensions initial-contents))) data)) @@ -567,42 +576,14 @@ of specialized arrays is supported." (declare (truly-dynamic-extent subscripts)) (row-major-aref array (%array-row-major-index array subscripts))) -(defun %aset (array &rest stuff) - (declare (truly-dynamic-extent stuff)) - (let ((subscripts (butlast stuff)) - (new-value (car (last stuff)))) - (setf (row-major-aref array (%array-row-major-index array subscripts)) - new-value))) - -;;; FIXME: What's supposed to happen with functions -;;; like AREF when we (DEFUN (SETF FOO) ..) when -;;; DEFSETF FOO is also defined? It seems as though the logical -;;; thing to do would be to nuke the macro definition for (SETF FOO) -;;; and replace it with the (SETF FOO) function, issuing a warning, -;;; just as for ordinary functions -;;; * (LISP-IMPLEMENTATION-VERSION) -;;; "18a+ release x86-linux 2.4.7 6 November 1998 cvs" -;;; * (DEFMACRO ZOO (X) `(+ ,X ,X)) -;;; ZOO -;;; * (DEFUN ZOO (X) (* 3 X)) -;;; Warning: ZOO previously defined as a macro. -;;; 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. - -#!-sb-fluid (declaim (inline (setf aref))) +;;; (setf aref/bit/sbit) are implemented using setf-functions, +;;; because they have to work with (setf (apply #'aref array subscripts)) +;;; All other setfs can be done using setf-functions too, but I +;;; haven't found technical advantages or disatvantages for either +;;; scheme. (defun (setf aref) (new-value array &rest subscripts) - (declare (truly-dynamic-extent subscripts)) - (declare (type array array)) + (declare (truly-dynamic-extent subscripts) + (type array array)) (setf (row-major-aref array (%array-row-major-index array subscripts)) new-value)) @@ -630,20 +611,14 @@ of specialized arrays is supported." (defun bit (bit-array &rest subscripts) #!+sb-doc "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS." - (declare (type (array bit) bit-array) (optimize (safety 1))) + (declare (type (array bit) bit-array) + (optimize (safety 1))) (row-major-aref bit-array (%array-row-major-index bit-array subscripts))) -(defun %bitset (bit-array &rest stuff) - (declare (type (array bit) bit-array) (optimize (safety 1))) - (let ((subscripts (butlast stuff)) - (new-value (car (last stuff)))) - (setf (row-major-aref bit-array - (%array-row-major-index bit-array subscripts)) - new-value))) - -#!-sb-fluid (declaim (inline (setf bit))) (defun (setf bit) (new-value bit-array &rest subscripts) - (declare (type (array bit) bit-array) (optimize (safety 1))) + (declare (type (array bit) bit-array) + (type bit new-value) + (optimize (safety 1))) (setf (row-major-aref bit-array (%array-row-major-index bit-array subscripts)) new-value)) @@ -651,25 +626,15 @@ of specialized arrays is supported." (defun sbit (simple-bit-array &rest subscripts) #!+sb-doc "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS." - (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1))) + (declare (type (simple-array bit) simple-bit-array) + (optimize (safety 1))) (row-major-aref simple-bit-array (%array-row-major-index simple-bit-array subscripts))) -;;; KLUDGE: Not all these things (%SET-ROW-MAJOR-AREF, %SET-FILL-POINTER, -;;; %SET-FDEFINITION, %SCHARSET, %SBITSET..) seem to deserve separate names. -;;; Could we just DEFUN (SETF SBIT) etc. and get rid of the non-ANSI names? -;;; -- WHN 19990911 -(defun %sbitset (simple-bit-array &rest stuff) - (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1))) - (let ((subscripts (butlast stuff)) - (new-value (car (last stuff)))) - (setf (row-major-aref simple-bit-array - (%array-row-major-index simple-bit-array subscripts)) - new-value))) - -#!-sb-fluid (declaim (inline (setf sbit))) (defun (setf sbit) (new-value bit-array &rest subscripts) - (declare (type (simple-array bit) bit-array) (optimize (safety 1))) + (declare (type (simple-array bit) bit-array) + (type bit new-value) + (optimize (safety 1))) (setf (row-major-aref bit-array (%array-row-major-index bit-array subscripts)) new-value)) @@ -900,11 +865,11 @@ of specialized arrays is supported." (cond (initial-contents-p ;; array former contents replaced by INITIAL-CONTENTS (if (or initial-element-p displaced-to) - (error "INITIAL-CONTENTS may not be specified with ~ + (error ":INITIAL-CONTENTS may not be specified with ~ the :INITIAL-ELEMENT or :DISPLACED-TO option.")) (let* ((array-size (apply #'* dimensions)) (array-data (data-vector-from-inits - dimensions array-size element-type + dimensions array-size element-type nil initial-contents initial-contents-p initial-element initial-element-p))) (if (adjustable-array-p array) @@ -958,9 +923,13 @@ of specialized arrays is supported." (setf new-data (data-vector-from-inits dimensions new-length element-type + (widetag-of old-data) initial-contents initial-contents-p initial-element initial-element-p)) + ;; Provide :END1 to avoid full call to LENGTH + ;; inside REPLACE. (replace new-data old-data + :end1 new-length :start2 old-start :end2 old-end)) (t (setf new-data (shrink-vector old-data new-length)))) @@ -982,7 +951,8 @@ of specialized arrays is supported." (> new-length old-length)) (data-vector-from-inits dimensions new-length - element-type () nil + element-type + (widetag-of old-data) () nil initial-element initial-element-p) old-data))) (if (or (zerop old-length) (zerop new-length))