From 7862b94e18f36531517fed986db8df0d6791d826 Mon Sep 17 00:00:00 2001
From: emarsden <emarsden>
Date: Tue, 6 Apr 2004 17:18:03 +0000
Subject: [PATCH] Two unrelated fixes to ADJUST-ARRAY:

  - (adjust-array (make-array nil :initial-element 'zob) nil)
    was losing the :initial-element information

  - ADJUST-ARRAY was sometimes returning the same array despite
    ADJUSTABLE-ARRAY-P returning nil for that array (fix from SBCL)

Fixes a number of AJUST-ARRAY.* tests in Paul Dietz's ANSI compliance
suite.
---
 code/array.lisp | 50 ++++++++++++++++++++++++++++---------------------
 1 file changed, 29 insertions(+), 21 deletions(-)

diff --git a/code/array.lisp b/code/array.lisp
index d1d2c20d1..8863d07ec 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.37 2003/07/23 09:39:25 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.38 2004/04/06 17:18:03 emarsden Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -778,26 +778,34 @@
 	    (t
 	     (let ((old-length (%array-available-elements array))
 		   (new-length (apply #'* dimensions)))
-	       (declare (fixnum old-length new-length))
-	       (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)
-					 (> new-length old-length))
-				     (data-vector-from-inits
-				      dimensions new-length
-				      element-type () nil
-                                      initial-element initial-element-p)
-				     old-data)))
-		   (if (or (zerop old-length) (zerop new-length))
-		       (when initial-element-p (fill new-data initial-element))
-		       (zap-array-data old-data (array-dimensions array)
-				       old-start
-				       new-data dimensions new-length
-				       element-type initial-element
-				       initial-element-p))
-		   (set-array-header array new-data new-length
-				     new-length 0 dimensions nil)))))))))
+               (declare (fixnum old-length new-length))
+               (cond ((null dimensions)
+                      array)
+                     (t
+                      (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)
+                                                (> new-length old-length))
+                                            (data-vector-from-inits
+                                             dimensions new-length
+                                             element-type () nil
+                                             initial-element initial-element-p)
+                                            old-data)))
+                          (if (or (zerop old-length) (zerop new-length))
+                              (when initial-element-p (fill new-data initial-element))
+                              (zap-array-data old-data (array-dimensions array)
+                                              old-start
+                                              new-data dimensions new-length
+                                              element-type initial-element
+                                              initial-element-p))
+                          (if (adjustable-array-p array)
+                              (set-array-header array new-data new-length
+                                                new-length 0 dimensions nil)
+                              (let ((new-array
+                                     (make-array-header vm:simple-array-type array-rank)))
+                                (set-array-header new-array new-data new-length
+                                                  new-length 0 dimensions nil)))))))))))))
 
 (defun get-new-fill-pointer (old-array new-array-size fill-pointer)
   (cond ((not fill-pointer)
-- 
GitLab