X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=d300256604807ea764b00b2abd17180b97a900dc;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=6e46a9d38d71c1b2d4ec0fd597c8ca05cdad8231;hpb=09cd508206ea4d5da08d3950f9cddb862e81dffd;p=sbcl.git

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 6e46a9d..d300256 100644
--- 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
@@ -573,6 +591,10 @@
   "Return T if (ADJUST-ARRAY ARRAY...) would return an array identical
    to the argument, this happens for complex arrays."
   (declare (array array))
+  ;; Note that this appears not to be a fundamental limitation.
+  ;; non-vector SIMPLE-ARRAYs are in fact capable of being adjusted,
+  ;; but in practice we test using ADJUSTABLE-ARRAY-P in ADJUST-ARRAY.
+  ;; -- CSR, 2004-03-01.
   (not (typep array 'simple-array)))
 
 ;;;; fill pointer frobbing stuff
@@ -639,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))
 
@@ -652,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
 
@@ -675,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)
@@ -770,8 +798,15 @@
 				       new-data dimensions new-length
 				       element-type initial-element
 				       initial-element-p))
-		   (set-array-header array new-data new-length
-				     new-length 0 dimensions nil)))))))))
+		   (if (adjustable-array-p array)
+		       (set-array-header array new-data new-length
+					 new-length 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)))))))))))
+  
 
 (defun get-new-fill-pointer (old-array new-array-size fill-pointer)
   (cond ((not fill-pointer)
@@ -900,7 +935,7 @@
     (macrolet ((bump-index-list (index limits)
 		 `(do ((subscripts ,index (cdr subscripts))
 		       (limits ,limits (cdr limits)))
-		      ((null subscripts) nil)
+		      ((null subscripts) :eof)
 		    (cond ((< (the fixnum (car subscripts))
 			      (the fixnum (car limits)))
 			   (rplaca subscripts
@@ -909,7 +944,7 @@
 			  (t (rplaca subscripts 0))))))
       (do ((index (make-list (length old-dims) :initial-element 0)
 		  (bump-index-list index limits)))
-	  ((null index))
+	  ((eq index :eof))
 	(setf (aref new-data (row-major-index-from-dims index new-dims))
 	      (aref old-data
 		    (+ (the fixnum (row-major-index-from-dims index old-dims))
@@ -957,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. ~