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