Add a boundp-function slot, which is required by virtual slot getter.

[clg] / gffi / vectors.lisp

diff --git a/gffi/vectors.lisp b/gffi/vectors.lisp
index d7ded24d53dee601850af436fe5df3f8180dd68d..836403388365c357026aa72a4a42fecbc3f85674 100644 (file)
--- 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 @@ (defun make-c-vector (type length &key content location temp)
   (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 @@ (defun map-c-vector (seqtype function location element-type length
                     &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 @@ (defun map-c-vector (seqtype function location element-type length
        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 @@ (define-type-method copy-function ((type vector) &key inlined)
                (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 @@ (defun check-unboxed-vector (type)
 #+(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 alien-arg-wrapper ((type unboxed-vector) var vector style
 
   (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 to-alien-form ((type unboxed-vector) vector &optional copy
 
 
   (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 from-alien-form ((type unboxed-vector) form &key (ref :fre
 
   (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 @@   (define-type-method writer-function ((type unboxed-vector) &key temp inlined)
                  (* (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 @@   (define-type-method reader-function ((type unboxed-vector) &key (ref :read) in
                   (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 '*)