0.8.15.3:

[sbcl.git] / src / code / array.lisp

diff --git a/src/code/array.lisp b/src/code/array.lisp
index ed95b97..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
@@ -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)))))))
+
 \f
 ;;;; ADJUST-ARRAY
 
@@ -679,8 +702,9 @@
                  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."))
+      (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)
@@ -968,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. ~