From e2b96221bb0fe35571446a1f619e70cd5c744427 Mon Sep 17 00:00:00 2001
From: phg <phg>
Date: Tue, 24 Mar 1992 11:03:16 +0000
Subject: [PATCH] Adjust-array has been updated to be ANSI compliant by
 allowing arrays which were not created with :adjustable non-nil to be
 adjusted to new dimensions.

Adjustable-array-p has been updated to ANSI standards. It returns T if adjust
ADJUST-ARRAY would return an EQ array.
---
 code/array.lisp | 71 ++++++++++++++++++++++++++++++++-----------------
 1 file changed, 46 insertions(+), 25 deletions(-)

diff --git a/code/array.lisp b/code/array.lisp
index 7bc81f102..5662fb479 100644
--- a/code/array.lisp
+++ b/code/array.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.15 1991/12/02 17:10:41 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.16 1992/03/24 11:03:16 phg Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -180,7 +180,7 @@
 		       length))
 	      (replace array initial-contents))
 	    array))
-	;; It's either a complex array or a multidemsional array.
+	;; It's either a complex array or a multidimensional array.
 	(let* ((total-size (reduce #'* dimensions))
 	       (data (or displaced-to
 			 (data-vector-from-inits
@@ -392,19 +392,17 @@
   (setf (row-major-aref array (%array-row-major-index array subscripts))
 	new-value))
 
-
 (defun row-major-aref (array index)
   "Returns the element of array corressponding to the row-major index.  This is
    SETF'able."
   (declare (optimize (safety 1)))
   (row-major-aref array index))
 
+
 (defun %set-row-major-aref (array index new-value)
   (declare (optimize (safety 1)))
   (setf (row-major-aref array index) new-value))
 
-
-
 (defun svref (simple-vector index)
   "Returns the Index'th element of the given Simple-Vector."
   (declare (optimize (safety 1)))
@@ -532,11 +530,17 @@
       (%array-available-elements array)
       (length (the vector array))))
 
+(defun array-displacement (array)
+  "Returns values of :displaced-to and :displaced-index-offset options to
+   make-array, or the defaults nil and 0 if not a displaced array."
+  (declare (array array))
+  (values (%array-data-vector array) (%array-displacement array)))
 
 (defun adjustable-array-p (array)
-  "Returns T if the given Array is adjustable, or NIL otherwise."
+  "Returns T if (adjust-array array...) would return an array identical
+   to the argument, this happens for complex arrays."
   (declare (array array))
-  (array-header-p array))
+  (not (typep array '(simple-array * (*)))))
 
 
 ;;;; Fill pointer frobbing stuff.
@@ -615,9 +619,7 @@
 			   displaced-to displaced-index-offset)
   "Adjusts the Array's dimensions to the given Dimensions and stuff."
   (let ((dimensions (if (listp dimensions) dimensions (list dimensions))))
-    (cond ((not (array-header-p array))
-	   (error "~S is not an adjustable array." array))
-	  ((/= (the fixnum (length (the list dimensions)))
+    (cond ((/= (the fixnum (length (the list dimensions)))
 	       (the fixnum (array-rank array)))
 	   (error "Number of dimensions not equal to rank of array."))
 	  ((not (subtypep element-type (array-element-type array)))
@@ -628,6 +630,7 @@
       (when (and fill-pointer (> array-rank 1))
 	(error "Multidimensional arrays can't have fill pointers."))
       (cond (initial-contents
+	     ;; Array former contents replaced by initial-contents.
 	     (if (or initial-element-p displaced-to)
 		 (error "Initial contents may not be specified with ~
 		 the :initial-element or :displaced-to option."))
@@ -636,12 +639,19 @@
 				 dimensions array-size element-type
 				 initial-contents initial-element
 				 initial-element-p)))
-	       (set-array-header array array-data array-size
+	       (if (adjustable-array-p array)
+		   (set-array-header array array-data array-size
 				 (get-new-fill-pointer array array-size
 						       fill-pointer)
-				 0 dimensions nil)))
+				 0 dimensions nil)
+		   (if (array-header-p array)
+		       ;; Simple multidimensional or single dimensional array.
+		       (make-array dimensions
+				   :element-type element-type
+				   :initial-contents initial-contents)
+		       array-data))))
 	    (displaced-to
-	     ;; no initial-contents supplied is already known
+	     ;; No initial-contents supplied is already established.
 	     (when initial-element
 	       (error "The :initial-element option may not be specified ~
 	       with :displaced-to."))
@@ -655,12 +665,20 @@
 	       (if (< (the fixnum (array-total-size displaced-to))
 		      (the fixnum (+ displacement array-size)))
 		   (error "The :displaced-to array is too small."))
-	       (set-array-header array displaced-to array-size
-				 (get-new-fill-pointer array array-size
-						       fill-pointer)
-				 displacement dimensions t)))
+	       (if (adjustable-array-p array)
+		   ;; None of the original contents appear in adjusted array.
+		   (set-array-header array displaced-to array-size
+				     (get-new-fill-pointer array array-size
+							   fill-pointer)
+				     displacement dimensions t)
+		   ;; Simple multidimensional or single dimensional array.
+		   (make-array dimensions
+			       :element-type element-type
+			       :displaced-to displaced-to
+			       :displaced-index-offset
+			       displaced-index-offset))))
 	    ((= array-rank 1)
-	     (let ((old-length (%array-available-elements array))
+	     (let ((old-length (array-total-size array))
 		   (new-length (car dimensions))
 		   new-data)
 	       (declare (fixnum old-length new-length))
@@ -677,10 +695,12 @@
 				 :start2 old-start :end2 old-end))
 		       (t (setf new-data
 				(shrink-vector old-data new-length))))
-		 (set-array-header array new-data new-length
-				   (get-new-fill-pointer array new-length
-							 fill-pointer)
-				   0 dimensions nil))))
+		 (if (adjustable-array-p array)
+		     (set-array-header array new-data new-length
+				       (get-new-fill-pointer array new-length
+							     fill-pointer)
+				       0 dimensions nil)
+		     new-data))))
 	    (t
 	     (let ((old-length (%array-available-elements array))
 		   (new-length (apply #'* dimensions)))
@@ -699,8 +719,7 @@
 				   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))))))))
-  array)
+				     new-length 0 dimensions nil)))))))))
 
 (defun get-new-fill-pointer (old-array new-array-size fill-pointer)
   (cond ((not fill-pointer)
@@ -713,7 +732,7 @@
 	((not (array-has-fill-pointer-p old-array))
 	 (error "Cannot supply a non-NIL value (~S) for :fill-pointer ~
 		        in adjust-array unless the array (~S) was originally ~
-			created with a fill pointer."
+ 			created with a fill pointer."
 		       fill-pointer
 		       old-array))
 	((numberp fill-pointer)
@@ -752,6 +771,8 @@
 	((simple-array (unsigned-byte 32) (*)) 0)
 	((simple-array single-float (*)) (coerce 0 'single-float))
 	((simple-array double-float (*)) (coerce 0 'double-float)))))
+  ;; Only arrays have fill-pointers, but vectors have their length parameter
+  ;; in the same place.
   (setf (%array-fill-pointer vector) new-size)
   vector)
 
-- 
GitLab