Extend copy-array to non-simple array

privet-kitty · Nov 10, 2023 · 442be27 · 442be27
1 parent 455950c
commit 442be27
Show file tree

Hide file tree

Showing 2 changed files with 40 additions and 17 deletions.
diff --git a/module/copy-array.lisp b/module/copy-array.lisp
@@ -4,7 +4,7 @@
                 #:defoptimizer #:derive-type #:unsupplied-or-nil #:lvar-type
                 #:compiler-warn #:combination-kind #:*compiler-error-context*)
   (:import-from #:sb-kernel #:type-specifier #:type-intersection #:make-array-type
-                #:*wild-type* #:*empty-type*)
+                #:*wild-type* #:*empty-type* #:array-type-p)
   (:import-from #:sb-int #:index)
   (:export #:copy-array))
 (in-package :cp/copy-array)
@@ -19,23 +19,25 @@
        node)
     (let* ((array-type (lvar-type array))
            (int (type-intersection array-type
-                                   (make-array-type '* 
-                                                    :complexp nil
-                                                    :element-type *wild-type*))))
-      (if (eq int *empty-type*)
-          (let ((*compiler-error-context* node))
-            (setf (combination-kind node) :error)
-            (compiler-warn "~A doesn't seem to be a SIMPLE-ARRAY"
-                           (type-specifier array-type)))
-          int))))
+                                   (make-array-type '* :element-type *wild-type*))))
+      (if (array-type-p int)
+          (make-array-type (sb-c::array-type-dimensions int)
+                           :complexp nil
+                           :element-type (sb-c::array-type-element-type int)
+                           :specialized-element-type (sb-c::array-type-specialized-element-type int))
+          (make-array-type '* :element-type *wild-type*)))))
 
 (defun copy-array (array)
-  "Returns a copy of an ARRAY.
+  "Returns a (simple) copy of an ARRAY.
 
-NOTE: Currently this function can only deal with a simple-array."
-  (declare (simple-array array))
+If the array is a vector with a fill pointer, the fill pointer is ignored and
+the whole array is copied."
+  (declare (array array))
   (let ((new (make-array (array-dimensions array) :element-type (array-element-type array))))
-    #+sbcl (replace (sb-ext:array-storage-vector new) (sb-ext:array-storage-vector array))
-    #-sbcl (dotimes (i (array-total-size array))
-             (setf (row-major-aref new i) (row-major-aref array i)))
+    #+sbcl
+    (when (typep array 'simple-array)
+      (replace (sb-ext:array-storage-vector new) (sb-ext:array-storage-vector array))
+      (return-from copy-array new))
+    (dotimes (i (array-total-size array))
+      (setf (row-major-aref new i) (row-major-aref array i)))
     new))
diff --git a/module/test/copy-array.lisp b/module/test/copy-array.lisp
@@ -8,4 +8,25 @@
   (let* ((arr #2a((1 2 3) (4 5 6.0)))
          (copied (copy-array arr)))
     (is (equalp copied #2a((1 2 3) (4 5 6.0))))
-    (is (not (eq arr copied)))))
+    (is (not (eq arr copied))))
+  (let* ((arr (make-array '(2 3)
+                          :element-type 'fixnum
+                          :initial-contents '((1 2 3) (4 5 6))
+                          :adjustable t))
+         (copied (copy-array arr)))
+    (is (equalp copied #2a((1 2 3) (4 5 6))))
+    (is (not (eq arr copied)))
+    (is (typep arr '(array fixnum (2 3))))
+    (is (typep copied '(simple-array fixnum (2 3)))))
+  (let* ((arr (make-array 2 :element-type 'base-char :fill-pointer 1 :initial-element #\a))
+         (copied (copy-array arr)))
+    (is (equalp copied "aa"))
+    (is (not (eq arr copied)))
+    (is (typep arr '(base-string 2)))
+    (is (typep copied '(simple-base-string 2)))))
+
+;; (defun copy-array-func (arr1 arr2 arr3)
+;;   (declare ((simple-array fixnum (3 4)) arr1)
+;;            ((and (array fixnum *) (not simple-array)) arr2)
+;;            ((or integer (simple-array fixnum (*)) array) arr3))
+;;   (values (copy-array arr1) (copy-array arr2) (copy-array arr3)))