X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Farray.lisp;h=2d4ab67a7029f3529c7a927af855a22488b4fbca;hb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;hp=4268f550b93bc1af3abedd75a28fe4d58c91d5b7;hpb=4603ca100a7d181fe4316429365fc725501336dd;p=sbcl.git diff --git a/src/code/array.lisp b/src/code/array.lisp index 4268f55..2d4ab67 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -476,6 +476,15 @@ of specialized arrays is supported." (defun data-vector-ref-with-offset (array index offset) (hairy-data-vector-ref array (+ index offset))) +(declaim (ftype (function (array integer integer &optional t) nil) + invalid-array-index-error)) +(defun invalid-array-index-error (array index bound &optional axis) + (error 'invalid-array-index-error + :array array + :axis axis + :datum index + :expected-type `(integer 0 (,bound)))) + ;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed (defun %array-row-major-index (array subscripts &optional (invalid-index-error-p t)) @@ -497,11 +506,7 @@ of specialized arrays is supported." (declare (fixnum 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" - :format-arguments (list index axis array) - :datum index - :expected-type `(integer 0 (,dim))) + (invalid-array-index-error array index dim axis) (return-from %array-row-major-index nil))) (incf result (* chunk-size (the fixnum index))) (setf chunk-size (* chunk-size dim)))) @@ -509,14 +514,7 @@ of specialized arrays is supported." (length (length (the (simple-array * (*)) array)))) (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 - ;; 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))) + (invalid-array-index-error array index length) (return-from %array-row-major-index nil))) index)))) @@ -527,17 +525,17 @@ of specialized arrays is supported." t)) (defun array-row-major-index (array &rest subscripts) - (declare (dynamic-extent subscripts)) + (declare (truly-dynamic-extent subscripts)) (%array-row-major-index array subscripts)) (defun aref (array &rest subscripts) #!+sb-doc "Return the element of the ARRAY specified by the SUBSCRIPTS." - (declare (dynamic-extent subscripts)) + (declare (truly-dynamic-extent subscripts)) (row-major-aref array (%array-row-major-index array subscripts))) (defun %aset (array &rest stuff) - (declare (dynamic-extent 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)) @@ -570,7 +568,7 @@ of specialized arrays is supported." #!-sb-fluid (declaim (inline (setf aref))) (defun (setf aref) (new-value array &rest subscripts) - (declare (dynamic-extent subscripts)) + (declare (truly-dynamic-extent subscripts)) (declare (type array array)) (setf (row-major-aref array (%array-row-major-index array subscripts)) new-value)) @@ -768,31 +766,37 @@ of specialized arrays is supported." (declare (array array)) (and (array-header-p array) (%array-fill-pointer-p array))) +(defun fill-pointer-error (vector arg) + (cond (arg + (aver (array-has-fill-pointer-p vector)) + (let ((max (%array-available-elements vector))) + (error 'simple-type-error + :datum arg + :expected-type (list 'integer 0 max) + :format-control "The new fill pointer, ~S, is larger than the length of the vector (~S.)" + :format-arguments (list arg max)))) + (t + (error 'simple-type-error + :datum vector + :expected-type '(and vector (satisfies array-has-fill-pointer-p)) + :format-control "~S is not an array with a fill pointer." + :format-arguments (list vector))))) + (defun fill-pointer (vector) #!+sb-doc "Return the FILL-POINTER of the given VECTOR." - (declare (vector vector)) - (if (and (array-header-p vector) (%array-fill-pointer-p vector)) + (if (array-has-fill-pointer-p vector) (%array-fill-pointer vector) - (error 'simple-type-error - :datum vector - :expected-type '(and vector (satisfies array-has-fill-pointer-p)) - :format-control "~S is not an array with a fill pointer." - :format-arguments (list vector)))) + (fill-pointer-error vector nil))) (defun %set-fill-pointer (vector new) - (declare (vector vector) (fixnum new)) - (if (and (array-header-p vector) (%array-fill-pointer-p vector)) - (if (> new (%array-available-elements vector)) - (error - "The new fill pointer, ~S, is larger than the length of the vector." - new) - (setf (%array-fill-pointer vector) new)) - (error 'simple-type-error - :datum vector - :expected-type '(and vector (satisfies array-has-fill-pointer-p)) - :format-control "~S is not an array with a fill pointer." - :format-arguments (list vector)))) + (flet ((oops (x) + (fill-pointer-error vector x))) + (if (array-has-fill-pointer-p vector) + (if (> new (%array-available-elements vector)) + (oops new) + (setf (%array-fill-pointer vector) new)) + (oops nil)))) ;;; FIXME: It'd probably make sense to use a MACROLET to share the ;;; guts of VECTOR-PUSH between VECTOR-PUSH-EXTEND. Such a macro @@ -811,19 +815,23 @@ of specialized arrays is supported." (cond ((= fill-pointer (%array-available-elements array)) nil) (t - (setf (aref array fill-pointer) new-el) + (locally (declare (optimize (safety 0))) + (setf (aref array fill-pointer) new-el)) (setf (%array-fill-pointer array) (1+ fill-pointer)) fill-pointer)))) (defun vector-push-extend (new-element vector &optional - (extension (1+ (length vector)))) - (declare (vector vector) (fixnum extension)) + (min-extension + (let ((length (length vector))) + (min (1+ length) + (- array-dimension-limit length))))) + (declare (vector vector) (fixnum min-extension)) (let ((fill-pointer (fill-pointer vector))) (declare (fixnum fill-pointer)) (when (= fill-pointer (%array-available-elements vector)) - (adjust-array vector (+ fill-pointer extension))) + (adjust-array vector (+ fill-pointer (max 1 min-extension)))) ;; disable bounds checking (locally (declare (optimize (safety 0))) (setf (aref vector fill-pointer) new-element)) @@ -969,12 +977,12 @@ of specialized arrays is supported." initial-element-p)) (if (adjustable-array-p array) (set-array-header array new-data new-length - new-length 0 dimensions nil) + nil 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))))))))))) + nil 0 dimensions nil))))))))))) (defun get-new-fill-pointer (old-array new-array-size fill-pointer) @@ -1073,7 +1081,37 @@ of specialized arrays is supported." (setf (%array-dimension array 0) dimensions)) (setf (%array-displaced-p array) displacedp) array) + +;;; User visible extension +(declaim (ftype (function (array) (values (simple-array * (*)) &optional)) + array-storage-vector)) +(defun array-storage-vector (array) + "Returns the underlying storage vector of ARRAY, which must be a non-displaced array. + +In SBCL, if ARRAY is a of type \(SIMPLE-ARRAY * \(*)), it is its own storage +vector. Multidimensional arrays, arrays with fill pointers, and adjustable +arrays have an underlying storage vector with the same ARRAY-ELEMENT-TYPE as +ARRAY, which this function returns. + +Important note: the underlying vector is an implementation detail. Even though +this function exposes it, changes in the implementation may cause this +function to be removed without further warning." + ;; KLUDGE: Without TRULY-THE the system is not smart enough to figure out that + ;; the return value is always of the known type. + (truly-the (simple-array * (*)) + (if (array-header-p array) + (if (%array-displaced-p array) + (error "~S cannot be used with displaced arrays. Use ~S instead." + 'array-storage-vector 'array-displacement) + (%array-data-vector array)) + array))) +;;;; used by SORT + +;;; temporary vector for stable sorting vectors, allocated for each new thread +(defvar *merge-sort-temp-vector* (vector)) +(declaim (simple-vector *merge-sort-temp-vector*)) + ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY ;;; a temporary to be used when OLD-DATA and NEW-DATA are EQ. @@ -1122,18 +1160,14 @@ of specialized arrays is supported." (unless (typep initial-element element-type) (error "~S can't be used to initialize an array of type ~S." initial-element element-type))) - (without-interrupts - ;; Need to disable interrupts while using the temp-vector. - ;; An interrupt handler that also happened to call - ;; ADJUST-ARRAY could otherwise stomp on our data here. - (let ((temp (zap-array-data-temp new-length - initial-element initial-element-p))) - (declare (simple-vector temp)) - (zap-array-data-aux old-data old-dims offset temp new-dims) - (dotimes (i new-length) - (setf (aref new-data i) (aref temp i) - ;; zero out any garbage right away - (aref temp i) 0))))) + (let ((temp (zap-array-data-temp new-length + initial-element initial-element-p))) + (declare (simple-vector temp)) + (zap-array-data-aux old-data old-dims offset temp new-dims) + (dotimes (i new-length) + (setf (aref new-data i) (aref temp i) + ;; zero out any garbage right away + (aref temp i) 0)))) (t ;; When OLD-DATA and NEW-DATA are not EQ, NEW-DATA has ;; already been filled with any