0.8.10.68:

        Fixed BUG 315 "no bounds check for access to displaced array"
        (reported by Bruno Haible)
        ... ARRAY-DIMENSION now signals an
               DISPLACED-TO-ARRAY-TOO-SMALL-ERROR when called on a
               displaced array, whose displaced-to array has been
               adjusted out of bounds.
        ... Test case.

diff --git a/BUGS b/BUGS
index e5b063c..19aeb2e 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1314,32 +1314,6 @@ WORKAROUND:
     Expected: (2 6 15 38)
     Got:      ERROR
 
-315: "no bounds check for access to displaced array"
-  reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP
-  test suite.
-    (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)))
-
-  SBCL fails this because (array-dimension y 0) return 10 even after the
-  adjustment, and hence the bounds-check passes. This is strictly
-  speaking legal, since the dictionary entry for ADJUST-ARRAY
-  says:
-
-    "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."
-
-  Should this be left as is, or should ARRAY-DIMENSION see if the
-  displaced-to array has shrunk too much and signal an error? An error
-  would probably be preferable, since a test of that form but with
-  (setf (char y 5) #\Space) potentially corrupts the heap and
-  certainly confuses the world if that string is used by C code.
-
 317: "FORMAT of floating point numbers"
   reported by Bruno Haible sbcl-devel "various SBCL bugs" from CLISP
   test suite.

diff --git a/NEWS b/NEWS
index 3681d6a..5bf1739 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2415,6 +2415,9 @@ changes in sbcl-0.8.11 relative to sbcl-0.8.10:
     beginnings of a semantically meaningful condition hierarchy is
     under development, for use in SB-EXT:MUFFLE-CONDITIONS and by
     IDEs.
+  * fixed bug: Displaced arrays whose displaced-to array has become
+    too small now cause ARRAY-DIMENSION to signal an error, providing
+    for safer bounds-checking. (reported by Bruno Haible)
   * fixed bug: DEFCLASS slot definitions with identical :READER and
     :WRITER names now signal a reasonable error. (reported by Thomas
     Burdick)

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index d842cc5..9315fca 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1104,6 +1104,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
              "DEFINED-FTYPE-MATCHES-DECLARED-FTYPE-P"
             "!DEFSTRUCT-WITH-ALTERNATE-METACLASS"
              "DESCEND-INTO"
+             "DISPLACED-TO-ARRAY-TOO-SMALL-ERROR"
              "DIVISION-BY-ZERO-ERROR"
              "DOUBLE-FLOAT-EXPONENT" "DOUBLE-FLOAT-HIGH-BITS"
              "DOUBLE-FLOAT-INT-EXPONENT" "DOUBLE-FLOAT-LOW-BITS"

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 0a76afa..d300256 100644 (file)
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -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 "~@<The displaced-to array is too small. ~S ~
+                                      elements after offset required, ~S available.~:@>"
+                     :format-arguments (list (array-total-size array) 
+                                             (- (array-total-size target) offset))))
+          (%array-dimension array axis-number)))))
 
 (defun array-dimensions (array)
   #!+sb-doc

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index 43e034d..0ab79c7 100644 (file)
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -979,6 +979,12 @@
       :references (list '(:ansi-cl :function make-array) 
                        '(:ansi-cl :function upgraded-array-element-type))))
 
+(define-condition displaced-to-array-too-small-error
+    (reference-condition simple-error)
+  ()
+  (:default-initargs
+      :references (list '(:ansi-cl :function adjust-array))))
+
 (define-condition type-warning (reference-condition simple-warning)
   ()
   (:default-initargs :references (list '(:sbcl :node "Handling of Types"))))

diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp
index 098cd0e..25d7bea 100644 (file)
--- a/tests/array.pure.lisp
+++ b/tests/array.pure.lisp
@@ -159,3 +159,17 @@
 (let ((x (make-array nil :initial-element 'foo)))
   (adjust-array x nil)
   (assert (eql (aref x) 'foo)))
+
+;;; 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))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 594b0ee..6989d69 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.10.67"
+"0.8.10.68"