X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=1399a42e97fb92ae01e5739d6e6f93ded78f8cf1;hb=771b864c8f32af7734bc0550aeaf1539fc4df194;hp=71ce324fbd28e3acd1c2d0d4965e392ea05323e3;hpb=a6103aace1e40d0948aeb090f7b5d5ca77fc293a;p=sbcl.git diff --git a/src/code/array.lisp b/src/code/array.lisp index 71ce324..1399a42 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -158,13 +158,13 @@ (fill array 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)) - (error "There are ~W elements in the :INITIAL-CONTENTS, but ~ - the vector length is ~W." - (length initial-contents) - length)) + (error "can't specify both :INITIAL-ELEMENT and ~ + :INITIAL-CONTENTS")) + (unless (= length (length initial-contents)) + (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. @@ -205,7 +205,7 @@ (cond (displaced-to (when (or initial-element-p initial-contents-p) (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~ - can be specified along with :DISPLACED-TO")) + can be specified along with :DISPLACED-TO")) (let ((offset (or displaced-index-offset 0))) (when (> (+ offset total-size) (array-total-size displaced-to)) @@ -229,7 +229,7 @@ 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.")) + either MAKE-ARRAY or ADJUST-ARRAY.")) (let ((data (if initial-element-p (make-array total-size :element-type element-type @@ -254,13 +254,13 @@ (incf index)) (t (unless (typep contents 'sequence) - (error "malformed :INITIAL-CONTENTS: ~S is not a ~ - sequence, but ~W more layer~:P needed." + (error "malformed :INITIAL-CONTENTS: ~S is not a ~ + sequence, but ~W more layer~:P needed." contents (- (length dimensions) axis))) (unless (= (length contents) (car dims)) - (error "malformed :INITIAL-CONTENTS: Dimension of ~ - axis ~W is ~W, but ~S is ~W long." + (error "malformed :INITIAL-CONTENTS: Dimension of ~ + axis ~W is ~W, but ~S is ~W long." axis (car dims) contents (length contents))) (if (listp contents) (dolist (content contents) @@ -538,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 @@ -643,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)) @@ -656,9 +676,12 @@ (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 @@ -685,8 +708,8 @@ (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 ~ - the :INITIAL-ELEMENT or :DISPLACED-TO option.")) + (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 @@ -706,11 +729,11 @@ (displaced-to ;; We already established that no INITIAL-CONTENTS was supplied. (when initial-element - (error "The :INITIAL-ELEMENT option may not be specified ~ - with :DISPLACED-TO.")) - (unless (subtypep element-type (array-element-type displaced-to)) - (error "can't displace an array of type ~S into another of ~ - type ~S" + (error "The :INITIAL-ELEMENT option may not be specified ~ + with :DISPLACED-TO.")) + (unless (subtypep element-type (array-element-type displaced-to)) + (error "can't displace an array of type ~S into another of ~ + type ~S" element-type (array-element-type displaced-to))) (let ((displacement (or displaced-index-offset 0)) (array-size (apply #'* dimensions))) @@ -790,19 +813,19 @@ (when (array-has-fill-pointer-p old-array) (when (> (%array-fill-pointer old-array) new-array-size) (error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~ - smaller than its fill pointer (~S)" + smaller than its fill pointer (~S)" old-array new-array-size (fill-pointer old-array))) (%array-fill-pointer old-array))) ((not (array-has-fill-pointer-p old-array)) (error "cannot supply a non-NIL value (~S) for :FILL-POINTER ~ - in ADJUST-ARRAY unless the array (~S) was originally ~ - created with a fill pointer" + in ADJUST-ARRAY unless the array (~S) was originally ~ + created with a fill pointer" fill-pointer old-array)) ((numberp fill-pointer) (when (> fill-pointer new-array-size) (error "can't supply a value for :FILL-POINTER (~S) that is larger ~ - than the new length of the vector (~S)" + than the new length of the vector (~S)" fill-pointer new-array-size)) fill-pointer) ((eq fill-pointer t) @@ -969,12 +992,13 @@ (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. ~ - If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~ - RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~ - All the arrays must have the same rank and dimensions." + BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~ + If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~ + RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~ + All the arrays must have the same rank and dimensions." (symbol-name function)) (declare (type (array bit) bit-array-1 bit-array-2) (type (or (array bit) (member t nil)) result-bit-array))