X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Farray.lisp;h=6d6ae8c6452f15d44da98e71bbd84ebd75fff73e;hb=25fe91bf63fd473d9316675b0e0ca9be0079e9eb;hp=9b8088a9e09c9b9767ca9c301c60b95f47e251b3;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 9b8088a..6d6ae8c 100644
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -149,6 +149,11 @@
     (declare (fixnum array-rank))
     (when (and displaced-index-offset (null displaced-to))
       (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))
+    (when (and displaced-to
+               (arrayp displaced-to)
+               (not (equal (array-element-type displaced-to)
+                           (upgraded-array-element-type element-type))))
+      (error "Array element type of :DISPLACED-TO array does not match specified element type"))
     (if (and simple (= array-rank 1))
         ;; it's a (SIMPLE-ARRAY * (*))
         (multiple-value-bind (type n-bits)
@@ -764,7 +769,11 @@ of specialized arrays is supported."
            (error "The number of dimensions not equal to rank of array."))
           ((not (subtypep element-type (array-element-type array)))
            (error "The new element type, ~S, is incompatible with old type."
-                  element-type)))
+                  element-type))
+          ((and fill-pointer (not (array-has-fill-pointer-p array)))
+           (error 'type-error
+                  :datum array
+                  :expected-type '(satisfies array-has-fill-pointer-p))))
     (let ((array-rank (length (the list dimensions))))
       (declare (fixnum array-rank))
       (unless (= array-rank 1)
@@ -825,7 +834,8 @@ of specialized arrays is supported."
                (declare (fixnum old-length new-length))
                (with-array-data ((old-data array) (old-start)
                                  (old-end old-length))
-                 (cond ((or (%array-displaced-p array)
+                 (cond ((or (and (array-header-p array)
+                                 (%array-displaced-p array))
                             (< old-length new-length))
                         (setf new-data
                               (data-vector-from-inits
@@ -849,7 +859,8 @@ of specialized arrays is supported."
                (with-array-data ((old-data array) (old-start)
                                  (old-end old-length))
                  (declare (ignore old-end))
-                 (let ((new-data (if (or (%array-displaced-p array)
+                 (let ((new-data (if (or (and (array-header-p array)
+                                              (%array-displaced-p array))
                                          (> new-length old-length))
                                      (data-vector-from-inits
                                       dimensions new-length
@@ -900,8 +911,12 @@ of specialized arrays is supported."
                 fill-pointer))))
 
 ;;; Destructively alter VECTOR, changing its length to NEW-LENGTH,
-;;; which must be less than or equal to its current length.
-(defun shrink-vector (vector new-length)
+;;; which must be less than or equal to its current length. This can
+;;; be called on vectors without a fill pointer but it is extremely
+;;; dangerous to do so: shrinking the size of an object (as viewed by
+;;; the gc) makes bounds checking unreliable in the face of interrupts
+;;; or multi-threading. Call it only on provably local vectors.
+(defun %shrink-vector (vector new-length)
   (declare (vector vector))
   (unless (array-header-p vector)
     (macrolet ((frob (name &rest things)
@@ -915,6 +930,10 @@ of specialized arrays is supported."
                                           ,fill-value
                                           :start new-length))))
                               things))))
+      ;; Set the 'tail' of the vector to the appropriate type of zero,
+      ;; "because in some cases we'll scavenge larger areas in one go,
+      ;; like groups of pages that had triggered the write barrier, or
+      ;; the whole static space" according to jsnell.
       #.`(frob vector
           ,@(map 'list
                  (lambda (saetp)
@@ -932,6 +951,16 @@ of specialized arrays is supported."
   (setf (%array-fill-pointer vector) new-length)
   vector)
 
+(defun shrink-vector (vector new-length)
+  (declare (vector vector))
+  (cond
+    ((eq (length vector) new-length)
+     vector)
+    ((array-has-fill-pointer-p vector)
+     (setf (%array-fill-pointer vector) new-length)
+     vector)
+    (t (subseq vector 0 new-length))))
+
 ;;; Fill in array header with the provided information, and return the array.
 (defun set-array-header (array data length fill-pointer displacement dimensions
                          &optional displacedp)
@@ -955,7 +984,13 @@ of specialized arrays is supported."
 ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY
 
 ;;; a temporary to be used when OLD-DATA and NEW-DATA are EQ.
-;;; KLUDGE: Boy, DYNAMIC-EXTENT would be nice.
+;;; KLUDGE: Boy, DYNAMIC-EXTENT would be nice. This is rebound
+;;; to length zero array in each new thread.
+;;;
+;;; DX is probably a bad idea, because a with a big array it would
+;;; be fairly easy to blow the stack.
+;;;
+;;; Rebound per thread.
 (defvar *zap-array-data-temp* (make-array 1000 :initial-element t))
 
 (defun zap-array-data-temp (length element-type initial-element