X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/9cbf385857b0d6f4d41d374e0b1673293eee59a0..a348b7c1ba0310350e2d59bd98b6b33726cc0939:/gffi/vectors.lisp

diff --git a/gffi/vectors.lisp b/gffi/vectors.lisp
index d7ded24..8364033 100644
--- a/gffi/vectors.lisp
+++ b/gffi/vectors.lisp
@@ -20,7 +20,7 @@
 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
-;; $Id: vectors.lisp,v 1.7 2008-04-29 22:16:28 espen Exp $
+;; $Id: vectors.lisp,v 1.9 2008-12-10 02:41:40 espen Exp $
 
 
 (in-package "GFFI")
@@ -44,16 +44,23 @@
   (let* ((element-size (size-of type))
 	 (location (or location (allocate-memory (* element-size length))))
 	 (writer (writer-function type :temp temp)))
-    (etypecase content
-      (vector
+
+    (cond
+      #+(or cmu sbcl)
+      ((and 
+	(typep content 'simple-unboxed-array) 
+	(type-equal-p type (array-element-type content)))
+       (with-pinned-objects (content)
+	 (copy-memory (vector-sap content) (* length element-size) location)))
+      ((listp content)
        (loop
-	for element across content
+	for element in content
 	for i below length
 	for offset by element-size
 	do (funcall writer element location offset)))
-      (list
+      (t
        (loop
-	for element in content
+	for element across content
 	for i below length
 	for offset by element-size
 	do (funcall writer element location offset))))
@@ -64,7 +71,7 @@
 		     &optional (ref :read))
   (let ((reader (reader-function element-type :ref ref))
 	(element-size (size-of element-type)))
-    (case seqtype 
+    (case seqtype
      ((nil)
       (loop
        for i below length
@@ -75,6 +82,23 @@
        for i below length
        for offset by element-size
        collect (funcall function (funcall reader location offset))))
+     (vector
+      (let ((vector (make-array length :element-type element-type)))
+	(cond
+	  #+(or cmu sbcl)
+	  ((and 
+	    (typep vector 'simple-unboxed-array)
+	    (or (eq function 'identity) (eq function #'identity)))
+	   (with-pinned-objects (vector)
+	     (copy-memory location (* length element-size) (vector-sap vector))))
+	  (t
+	   (loop
+	    for i below length
+	    for offset by element-size
+	    do (setf 
+		(aref vector i)
+		(funcall function (funcall reader location offset))))))
+	vector))
      (t
       (loop
        with sequence = (make-sequence seqtype length)
@@ -284,6 +308,7 @@
 		(setf (ref-pointer to offset) vector)	    
 		(funcall copy-content (ref-pointer from offset) vector)))))))))
 
+
 ;;;; Unboxed vector
 
 (deftype unboxed-vector (element-type &optional (length '*)) 
@@ -307,9 +332,9 @@
 #+(or sbcl cmu)
 (progn
   (define-type-method alien-arg-wrapper ((type unboxed-vector) var vector style form &optional copy-in-p)
+    (check-unboxed-vector type)
     (destructuring-bind (element-type &optional (length '*)) 
 	(rest (type-expand-to 'unboxed-vector type))
-      (check-unboxed-vector type)
       (when (and (eq length '*) (out-arg-p style))
 	(error "Can't use vector with variable size as return type"))
       (cond
@@ -328,9 +353,9 @@
 
   (define-type-method to-alien-form ((type unboxed-vector) vector &optional copy-p)
     (declare (ignore copy-p))
+    (check-unboxed-vector type)
     (destructuring-bind (element-type &optional (length '*)) 
 	(rest (type-expand-to 'unboxed-vector type))
-      (check-unboxed-vector type)
       `(with-pinned-objects (,vector)
 	 (copy-memory 
 	  (vector-sap ,vector) 
@@ -339,9 +364,9 @@
 
 
   (define-type-method from-alien-form ((type unboxed-vector) form &key (ref :free))
+    (check-unboxed-vector type)
     (destructuring-bind (element-type &optional (length '*))
 	(rest (type-expand-to 'unboxed-vector type))
-      (check-unboxed-vector type)
       (when (eq length '*)
 	(error "Can't use vector of variable size as return type"))
       `(let ((c-vector ,form)
@@ -354,9 +379,9 @@
 
   (define-type-method writer-function ((type unboxed-vector) &key temp inlined)
     (declare (ignore temp))
+    (check-unboxed-vector type)
     (destructuring-bind (element-type &optional (length '*))
 	(rest (type-expand-to 'unboxed-vector type))
-      (check-unboxed-vector type)
       (if inlined
 	  (if (eq length '*)
 	      (error "Can't inline vector with variable size: ~A" type)
@@ -374,9 +399,9 @@
 		  (* (length vector) (size-of element-type)))))))))
 
   (define-type-method reader-function ((type unboxed-vector) &key (ref :read) inlined)
+    (check-unboxed-vector type)
     (destructuring-bind (element-type &optional (length '*))
 	(rest (type-expand-to 'unboxed-vector type))
-      (check-unboxed-vector type)
       (cond
 	((eq length '*)
 	 (error "Can't create reader function for vector with variable size"))
@@ -403,11 +428,44 @@
 		   (setf (ref-pointer location offset) (make-pointer 0)))
 		 vector))))))))
 
+
+#-(or sbcl cmu)
+(progn
+  (define-type-method alien-arg-wrapper ((type unboxed-vector) var vector style form &optional copy-in-p)
+    (check-unboxed-vector type)
+    (destructuring-bind (element-type &optional (length '*))
+	(rest (type-expand-to 'unboxed-vector type))
+      (alien-arg-wrapper `(vector ,element-type ,length) var vector style form copy-in-p)))
+
+  (define-type-method to-alien-form ((type unboxed-vector) vector &optional copy-p)
+    (check-unboxed-vector type)
+    (destructuring-bind (element-type &optional (length '*))
+	(rest (type-expand-to 'unboxed-vector type))
+      (to-alien-form `(vector ,element-type ,length) vector copy-p)))
+
+  (define-type-method from-alien-form ((type unboxed-vector) form &key (ref :free))
+    (check-unboxed-vector type)
+    (destructuring-bind (element-type &optional (length '*))
+	(rest (type-expand-to 'unboxed-vector type))
+      (from-alien-form `(vector ,element-type ,length) form :ref ref)))
+
+  (define-type-method writer-function ((type unboxed-vector) &key temp inlined)
+    (check-unboxed-vector type)
+    (destructuring-bind (element-type &optional (length '*))
+	(rest (type-expand-to 'unboxed-vector type))
+      (writer-function `(vector ,element-type ,length) :temp temp :inlined inlined)))
+
+  (define-type-method reader-function ((type unboxed-vector) &key (ref :read) inlined)
+    (check-unboxed-vector type)
+    (destructuring-bind (element-type &optional (length '*))
+	(rest (type-expand-to 'unboxed-vector type))
+      (reader-function `(vector ,element-type ,length) :ref ref :inlined inlined))))
+
 (define-type-method destroy-function ((type unboxed-vector) &key temp inlined)
   (declare (ignore temp))
+  (check-unboxed-vector type)
   (destructuring-bind (element-type &optional (length '*))
       (rest (type-expand-to 'unboxed-vector type))
-    (check-unboxed-vector type)
     (cond
      #+sbcl 
      ((eq length '*)