(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)
(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)
(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
(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
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)
,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)
(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)
;;;; 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