[cl-utilities-cvs] CVS update: cl-utilities/copy-array.lisp

[Peter Scott]

Update of /project/cl-utilities/cvsroot/cl-utilities
In directory common-lisp.net:/tmp/cvs-serv7681

Modified Files:
	copy-array.lisp 
Log Message:
Factored out part of COPY-ARRAY into its own function.

Date: Thu May 26 22:24:24 2005
Author: pscott

Index: cl-utilities/copy-array.lisp
diff -u cl-utilities/copy-array.lisp:1.1.1.1 cl-utilities/copy-array.lisp:1.2
--- cl-utilities/copy-array.lisp:1.1.1.1	Mon May  9 23:26:29 2005
+++ cl-utilities/copy-array.lisp	Thu May 26 22:24:24 2005
@@ -7,19 +7,23 @@
 unless UNDISPLACE is non-NIL, in which case the contents of the array
 will be copied into a completely new, not displaced, array."
   (declare (type array array))
-  (let ((copy
-         (apply #'make-array
-                (list* (array-dimensions array)
-                       :element-type (array-element-type array)
-                       :adjustable (adjustable-array-p array)
-                       :fill-pointer (when (array-has-fill-pointer-p array)
-                                       (fill-pointer array))
-                       (multiple-value-bind (displacement offset)
-                           (array-displacement array)
-                         (when (and displacement (not undisplace))
-                           (list :displaced-to displacement
-                                 :displaced-index-offset offset)))))))
+  (let ((copy (%make-array-with-same-properties array undisplace)))
     (unless (array-displacement copy)
       (dotimes (n (array-total-size copy))
         (setf (row-major-aref copy n) (row-major-aref array n))))
-    copy))
\ No newline at end of file
+    copy))
+
+(defun %make-array-with-same-properties (array undisplace)
+  "Make an array with the same properties (size, adjustability, etc.)
+as another array, optionally undisplacing the array."
+  (apply #'make-array
+	 (list* (array-dimensions array)
+		:element-type (array-element-type array)
+		:adjustable (adjustable-array-p array)
+		:fill-pointer (when (array-has-fill-pointer-p array)
+				(fill-pointer array))
+		(multiple-value-bind (displacement offset)
+		    (array-displacement array)
+		  (when (and displacement (not undisplace))
+		    (list :displaced-to displacement
+			  :displaced-index-offset offset))))))
\ No newline at end of file