From: Nikodemus S. <de...@us...> - 2009-05-06 16:28:11
|
Update of /cvsroot/sbcl/sbcl/tests In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv2238/tests Modified Files: array.pure.lisp Log Message: 1.0.28.19: faster ARRAY-DIMENSION for non-vectors Previously each ARRAY-DIMENSION call for a non-vector resulted in checking (1) if the array was a displaced array (2) if the array it was displaced to was still big enough for it. This sucks pretty badly, because we use ARRAY-DIMENSION in bounds checking -- especially given how rare it is to have an array displaced to an adjustable array. Add a new slot, ARRAY-DISPLACED-FROM, to array-headers, and store a list of weak backpointers to arrays displaced to the array in question there. SET-ARRAY-HEADER (as part of ADJUST-ARRAY) now checks this list, and signals an error if any of the displaced-from arrays is larger than the new size. This also allows us to open code ARRAY-DIMENSION as long as the array rank is known. Index: array.pure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/array.pure.lisp,v retrieving revision 1.35 retrieving revision 1.36 diff -u -d -r1.35 -r1.36 --- array.pure.lisp 23 Apr 2009 12:26:58 -0000 1.35 +++ array.pure.lisp 6 May 2009 16:28:04 -0000 1.36 @@ -163,16 +163,17 @@ ;;; BUG 315: "no bounds check for access to displaced array" ;;; reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP ;;; test suite. -(multiple-value-bind (val err) - (ignore-errors - (locally (declare (optimize (safety 3) (speed 0))) - (let* ((x (make-array 10 :fill-pointer 4 :element-type 'character - :initial-element #\space :adjustable t)) - (y (make-array 10 :fill-pointer 4 :element-type 'character - :displaced-to x))) - (adjust-array x '(5)) - (char y 5)))) - (assert (and (not val) (typep err 'sb-kernel:displaced-to-array-too-small-error)))) +(locally (declare (optimize (safety 3) (speed 0))) + (let* ((x (make-array 10 :fill-pointer 4 :element-type 'character + :initial-element #\space :adjustable t)) + (y (make-array 10 :fill-pointer 4 :element-type 'character + :displaced-to x))) + (handler-case + (adjust-array x '(5)) + (error (e) + (assert (typep e 'sb-int:simple-reference-error)) + (assert (equal '((:ansi-cl function adjust-array)) + (sb-int:reference-condition-references e))))))) ;;; MISC.527: bit-vector bitwise operations used LENGTH to get a size ;;; of a vector |