From 26e7aeea0a08d975674a0eeaccf5a8f16dabc129 Mon Sep 17 00:00:00 2001 From: pmai <pmai> Date: Wed, 21 Nov 2001 22:45:36 +0000 Subject: [PATCH] o When created displaced arrays, MAKE-ARRAY (unlike ADJUST-ARRAY) didn't check whether the specified element-type was a subtype of the array-element-type of the displaced-to array. o One case in ADJUST-ARRAY didn't check for an array-header before calling %array-displaced-p on an array, so that sometimes an array element was accessed and checked instead. Fixed this, and prevented ADJUST-ARRAY from shrinking non-adjustable arrays in-place, since this can violate naive user expectations for little gain. --- code/array.lisp | 35 +++++++++++++++++++++++------------ 1 file changed, 23 insertions(+), 12 deletions(-) diff --git a/code/array.lisp b/code/array.lisp index 3677f56fe..986872923 100644 --- a/code/array.lisp +++ b/code/array.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.31 2000/05/13 12:28:41 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.32 2001/11/21 22:45:36 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -232,6 +232,11 @@ (when (or initial-element-p initial-contents) (error "Neither :initial-element nor :initial-contents ~ can be specified along with :displaced-to")) + (unless (subtypep element-type + (array-element-type displaced-to)) + (error "One can't displace an array of type ~S into ~ + another of type ~S." + element-type (array-element-type displaced-to))) (let ((offset (or displaced-index-offset 0))) (when (> (+ offset total-size) (array-total-size displaced-to)) @@ -746,17 +751,23 @@ (declare (fixnum old-length new-length)) (with-array-data ((old-data array) (old-start) (old-end old-length)) - (cond ((or (%array-displaced-p array) - (< old-length new-length)) - (setf new-data - (data-vector-from-inits - dimensions new-length element-type - initial-contents initial-element - initial-element-p)) - (replace new-data old-data - :start2 old-start :end2 old-end)) - (t (setf new-data - (shrink-vector old-data new-length)))) + (cond + ((and (adjustable-array-p array) + (not (%array-displaced-p array)) + (<= new-length old-length)) + ;; Shrink underlying vector in-place. We don't do this + ;; for non-adjustable arrays, since that might confuse + ;; user expectations about adjust-array consing a fresh + ;; array in that case. + (setf new-data (shrink-vector old-data new-length))) + (t + (setf new-data + (data-vector-from-inits + dimensions new-length element-type + initial-contents initial-element + initial-element-p)) + (replace new-data old-data + :start2 old-start :end2 old-end))) (if (adjustable-array-p array) (set-array-header array new-data new-length (get-new-fill-pointer array new-length -- GitLab