From 75f9136a7c62d2da139e2f45b9dad5b8aa021fa2 Mon Sep 17 00:00:00 2001 From: "Svante Carl v. Erichsen" <svante.v.erichsen@web.de> Date: Sun, 30 Oct 2011 00:42:02 +0300 Subject: [PATCH] improved COPY-ARRAY No need to depend on the vagaries of ADJUST-ARRAY. --- 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) -- GitLab