[alexandria.git] updated branch master: 75f9136 improved COPY-ARRAY

[Nikodemus Siivola]

The branch master has been updated:
       via  75f9136a7c62d2da139e2f45b9dad5b8aa021fa2 (commit)
      from  cd158549ef56f10ef660f22cf4f9ddd96f0693c3 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 75f9136a7c62d2da139e2f45b9dad5b8aa021fa2
Author: Svante Carl v. Erichsen <svante.v.erichsen at web.de>
Date:   Sun Oct 30 00:42:02 2011 +0300

    improved COPY-ARRAY
    
      No need to depend on the vagaries of ADJUST-ARRAY.

-----------------------------------------------------------------------

Summary of changes:
 arrays.lisp |   30 ++++++++++++++----------------
 tests.lisp  |   18 ++++++++++++++++++
 2 files changed, 32 insertions(+), 16 deletions(-)

diff --git a/arrays.lisp b/arrays.lisp
index 670880f..76c1879 100644
--- a/arrays.lisp
+++ b/arrays.lisp
@@ -1,20 +1,18 @@
 (in-package :alexandria)
 
-(defun copy-array (array &key
-                   (element-type (array-element-type array))
-                   (fill-pointer (and (array-has-fill-pointer-p array)
-                                      (fill-pointer array)))
-                   (adjustable (adjustable-array-p array)))
+(defun copy-array (array &key (element-type (array-element-type array))
+                              (fill-pointer (and (array-has-fill-pointer-p array)
+                                                 (fill-pointer array)))
+                              (adjustable (adjustable-array-p array)))
   "Returns an undisplaced copy of ARRAY, with same fill-pointer and
 adjustability (if any) as the original, unless overridden by the keyword
-arguments. Performance depends on efficiency of general ADJUST-ARRAY in the
-host lisp -- for most cases a special purpose copying function is likely to
-perform better."
-  (let ((dims (array-dimensions array)))
-    ;; Dictionary entry for ADJUST-ARRAY requires adjusting a
-    ;; displaced array to a non-displaced one to make a copy.
-    (adjust-array
-     (make-array dims
-                 :element-type element-type :fill-pointer fill-pointer
-                 :adjustable adjustable :displaced-to array)
-     dims)))
+arguments."
+ (let* ((dimensions (array-dimensions array))
+        (new-array (make-array dimensions
+                               :element-type element-type
+                               :adjustable adjustable
+                               :fill-pointer fill-pointer)))
+   (dotimes (i (array-total-size array))
+     (setf (row-major-aref new-array i)
+           (row-major-aref array i)))
+   new-array))
diff --git a/tests.lisp b/tests.lisp
index ef7d19d..cb1978c 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -29,6 +29,24 @@
                 (eql (fill-pointer orig) (fill-pointer copy)))))
   nil t t t)
 
+(deftest copy-array.3
+    (let* ((orig (vector 1 2 3))
+           (copy (copy-array orig)))
+      (typep copy 'simple-array))
+  t)
+
+(deftest copy-array.4
+   (let ((orig (make-array 21
+                           :adjustable t
+                           :fill-pointer 0)))
+     (dotimes (n 42)
+       (vector-push-extend n orig))
+     (let ((copy (copy-array orig
+                             :adjustable nil
+                             :fill-pointer nil)))
+       (typep copy 'simple-array)))
+ t)
+
 (deftest array-index.1
     (typep 0 'array-index)
   t)
-- 
Alexandria hooks/post-receive