- (when (array-header-p data)
- (let* ((old (%array-displaced-from data))
- (new (cons (make-weak-pointer array) old)))
- (loop until (eq old (%compare-and-swap-array-displaced-from data old new))
- do (setf old (%array-displaced-from data)
- new (rplacd new (remove-if-not #'weak-pointer-value old)))))))
+ (flet ((purge (pointers)
+ (remove-if (lambda (value)
+ (or (not value) (eq array value)))
+ pointers
+ :key #'weak-pointer-value)))
+ ;; Add backpointer to the new data vector if it has a header.
+ (when (array-header-p data)
+ (setf (%array-displaced-from data)
+ (cons (make-weak-pointer array)
+ (purge (%array-displaced-from data)))))
+ ;; Remove old backpointer, if any.
+ (let ((old-data (%array-data-vector array)))
+ (when (and (neq data old-data) (array-header-p old-data))
+ (setf (%array-displaced-from old-data)
+ (purge (%array-displaced-from old-data)))))))
+
+(defun %walk-displaced-array-backpointers (array new-length)
+ (dolist (p (%array-displaced-from array))
+ (let ((from (weak-pointer-value p)))
+ (when (and from (eq array (%array-data-vector from)))
+ (let ((requires (+ (%array-available-elements from)
+ (%array-displacement from))))
+ (unless (>= new-length requires)
+ ;; 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.
+ ;;
+ ;; since we're hanging on a weak pointer here, we can't signal an
+ ;; error right now: the array that we're looking at might be
+ ;; garbage. Instead, we set all dimensions to zero so that next
+ ;; safe access to the displaced array will trap. Additionally, we
+ ;; save the original dimensions, so we can signal a more
+ ;; understandable error when the time comes.
+ (%walk-displaced-array-backpointers from 0)
+ (setf (%array-fill-pointer from) 0
+ (%array-available-elements from) 0
+ (%array-displaced-p from) (array-dimensions array))
+ (dotimes (i (%array-rank from))
+ (setf (%array-dimension from i) 0))))))))