X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Farray.lisp;h=d300256604807ea764b00b2abd17180b97a900dc;hb=791e9d15abba835457b308121668a0ce75386a03;hp=14843406b609820f5b9db0b607da140ee6b55b21;hpb=a41b3abd325afaabf14e444ad516c3e9833c3883;p=sbcl.git diff --git a/src/code/array.lisp b/src/code/array.lisp index 1484340..d300256 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -65,15 +65,6 @@ (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) @@ -136,7 +127,8 @@ (defun make-array (dimensions &key (element-type t) (initial-element nil initial-element-p) - initial-contents adjustable fill-pointer + (initial-contents nil initial-contents-p) + adjustable fill-pointer displaced-to displaced-index-offset) (let* ((dimensions (if (listp dimensions) dimensions (list dimensions))) (array-rank (length (the list dimensions))) @@ -164,8 +156,8 @@ (declare (type index length)) (when initial-element-p (fill array initial-element)) - (when initial-contents - (when initial-element + (when initial-contents-p + (when initial-element-p (error "can't specify both :INITIAL-ELEMENT and ~ :INITIAL-CONTENTS")) (unless (= length (length initial-contents)) @@ -180,7 +172,8 @@ (data (or displaced-to (data-vector-from-inits dimensions total-size element-type - initial-contents initial-element initial-element-p))) + initial-contents initial-contents-p + initial-element initial-element-p))) (array (make-array-header (cond ((= array-rank 1) (%complex-vector-widetag element-type)) @@ -210,7 +203,7 @@ (setf (%array-available-elements array) total-size) (setf (%array-data-vector array) data) (cond (displaced-to - (when (or initial-element-p initial-contents) + (when (or initial-element-p initial-contents-p) (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~ can be specified along with :DISPLACED-TO")) (let ((offset (or displaced-index-offset 0))) @@ -232,9 +225,9 @@ ;;; to FILL-DATA-VECTOR for error checking on the structure of ;;; initial-contents. (defun data-vector-from-inits (dimensions total-size element-type - initial-contents initial-element - initial-element-p) - (when (and initial-contents initial-element-p) + 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 either MAKE-ARRAY or ADJUST-ARRAY.")) (let ((data (if initial-element-p @@ -249,7 +242,7 @@ (error "~S cannot be used to initialize an array of type ~S." initial-element element-type)) (fill (the vector data) initial-element))) - (initial-contents + (initial-contents-p (fill-data-vector data dimensions initial-contents))) data)) @@ -343,7 +336,7 @@ (let ((index (car subs)) (dim (%array-dimension array axis))) (declare (fixnum dim)) - (unless (< -1 index dim) + (unless (and (fixnump index) (< -1 index dim)) (if invalid-index-error-p (error 'simple-type-error :format-control "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S" @@ -355,7 +348,7 @@ (setf chunk-size (* chunk-size dim)))) (let ((index (first subscripts)) (length (length (the (simple-array * (*)) array)))) - (unless (< -1 index length) + (unless (and (fixnump index) (< -1 index length)) (if invalid-index-error-p ;; FIXME: perhaps this should share a format-string ;; with INVALID-ARRAY-INDEX-ERROR or @@ -370,7 +363,7 @@ (defun array-in-bounds-p (array &rest subscripts) #!+sb-doc - "Return T if the Subscipts are in bounds for the Array, Nil otherwise." + "Return T if the SUBSCIPTS are in bounds for the ARRAY, NIL otherwise." (if (%array-row-major-index array subscripts nil) t)) @@ -379,7 +372,7 @@ (defun aref (array &rest subscripts) #!+sb-doc - "Return the element of the Array specified by the Subscripts." + "Return the element of the ARRAY specified by the SUBSCRIPTS." (row-major-aref array (%array-row-major-index array subscripts))) (defun %aset (array &rest stuff) @@ -545,7 +538,25 @@ (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)))) + ;; ANSI sayeth (ADJUST-ARRAY dictionary entry): + ;; + ;; "If A is displaced to B, the consequences are + ;; unspecified if B is adjusted in such a way that it no + ;; longer has enough elements to satisfy A. + ;; + ;; In situations where this matters we should be doing a + ;; bounds-check, which in turn uses ARRAY-DIMENSION -- so + ;; this seems like a good place to signal an error. + (multiple-value-bind (target offset) (array-displacement array) + (when (and target + (> (array-total-size array) + (- (array-total-size target) offset))) + (error 'displaced-to-array-too-small-error + :format-control "~@" + :format-arguments (list (array-total-size array) + (- (array-total-size target) offset)))) + (%array-dimension array axis-number))))) (defun array-dimensions (array) #!+sb-doc @@ -580,6 +591,10 @@ "Return T if (ADJUST-ARRAY ARRAY...) would return an array identical to the argument, this happens for complex arrays." (declare (array array)) + ;; Note that this appears not to be a fundamental limitation. + ;; non-vector SIMPLE-ARRAYs are in fact capable of being adjusted, + ;; but in practice we test using ADJUSTABLE-ARRAY-P in ADJUST-ARRAY. + ;; -- CSR, 2004-03-01. (not (typep array 'simple-array))) ;;;; fill pointer frobbing stuff @@ -646,7 +661,9 @@ (declare (fixnum fill-pointer)) (when (= fill-pointer (%array-available-elements vector)) (adjust-array vector (+ fill-pointer extension))) - (setf (aref vector fill-pointer) new-element) + ;; disable bounds checking + (locally (declare (optimize (safety 0))) + (setf (aref vector fill-pointer) new-element)) (setf (%array-fill-pointer vector) (1+ fill-pointer)) fill-pointer)) @@ -659,16 +676,20 @@ (declare (fixnum fill-pointer)) (if (zerop fill-pointer) (error "There is nothing left to pop.") - (aref array - (setf (%array-fill-pointer array) - (1- fill-pointer)))))) + ;; disable bounds checking (and any fixnum test) + (locally (declare (optimize (safety 0))) + (aref array + (setf (%array-fill-pointer array) + (1- fill-pointer))))))) + ;;;; ADJUST-ARRAY (defun adjust-array (array dimensions &key (element-type (array-element-type array)) (initial-element nil initial-element-p) - initial-contents fill-pointer + (initial-contents nil initial-contents-p) + fill-pointer displaced-to displaced-index-offset) #!+sb-doc "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff." @@ -681,9 +702,10 @@ element-type))) (let ((array-rank (length (the list dimensions)))) (declare (fixnum array-rank)) - (when (and fill-pointer (> array-rank 1)) - (error "Multidimensional arrays can't have fill pointers.")) - (cond (initial-contents + (unless (= array-rank 1) + (when fill-pointer + (error "Only vectors can have fill pointers."))) + (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 ~ @@ -691,8 +713,8 @@ (let* ((array-size (apply #'* dimensions)) (array-data (data-vector-from-inits dimensions array-size element-type - initial-contents initial-element - initial-element-p))) + initial-contents initial-contents-p + initial-element initial-element-p))) (if (adjustable-array-p array) (set-array-header array array-data array-size (get-new-fill-pointer array array-size @@ -743,8 +765,8 @@ (setf new-data (data-vector-from-inits dimensions new-length element-type - initial-contents initial-element - initial-element-p)) + initial-contents initial-contents-p + initial-element initial-element-p)) (replace new-data old-data :start2 old-start :end2 old-end)) (t (setf new-data @@ -766,8 +788,8 @@ (> new-length old-length)) (data-vector-from-inits dimensions new-length - element-type () initial-element - initial-element-p) + element-type () nil + initial-element initial-element-p) old-data))) (if (or (zerop old-length) (zerop new-length)) (when initial-element-p (fill new-data initial-element)) @@ -776,8 +798,15 @@ new-data dimensions new-length element-type initial-element initial-element-p)) - (set-array-header array new-data new-length - new-length 0 dimensions nil))))))))) + (if (adjustable-array-p array) + (set-array-header array new-data new-length + new-length 0 dimensions nil) + (let ((new-array + (make-array-header + sb!vm:simple-array-widetag array-rank))) + (set-array-header new-array new-data new-length + new-length 0 dimensions nil))))))))))) + (defun get-new-fill-pointer (old-array new-array-size fill-pointer) (cond ((not fill-pointer) @@ -906,7 +935,7 @@ (macrolet ((bump-index-list (index limits) `(do ((subscripts ,index (cdr subscripts)) (limits ,limits (cdr limits))) - ((null subscripts) nil) + ((null subscripts) :eof) (cond ((< (the fixnum (car subscripts)) (the fixnum (car limits))) (rplaca subscripts @@ -915,7 +944,7 @@ (t (rplaca subscripts 0)))))) (do ((index (make-list (length old-dims) :initial-element 0) (bump-index-list index limits))) - ((null index)) + ((eq index :eof)) (setf (aref new-data (row-major-index-from-dims index new-dims)) (aref old-data (+ (the fixnum (row-major-index-from-dims index old-dims)) @@ -963,6 +992,7 @@ (defmacro def-bit-array-op (name function) `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array) + #!+sb-doc ,(format nil "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~ BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~