[cffi-devel] [PATCH] adding copy-in/out WITH-POINTER-TO-VECTOR-DATA to the clisp backend

[Stelian Ionescu]

until a better solution can be found, the attached patch adds a
copy-in/out WITH-POINTER-TO-VECTOR-DATA to the clisp backend

-- 
(sign :name "Stelian Ionescu" :aka "fe[nl]ix"
      :quote "Quidquid latine dictum sit, altum sonatur.")
-------------- next part --------------
--- old-cffi/src/cffi-clisp.lisp	2006-12-20 18:43:10.000000000 +0100
+++ new-cffi/src/cffi-clisp.lisp	2006-12-20 18:43:10.000000000 +0100
@@ -51,6 +51,8 @@
    #:native-namestring
    #:%mem-ref
    #:%mem-set
+   #:make-shareable-byte-vector
+   #:with-pointer-to-vector-data
    #:foreign-symbol-pointer
    #:%defcallback
    #:%callback
@@ -208,6 +210,38 @@
       `(ffi::write-memory-as ,value ,ptr ',(convert-foreign-type (eval type)) ,offset)
       form))
 
+;;;# Shareable Vectors
+;;;
+;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
+;;; should be defined to perform a copy-in/copy-out if the Lisp
+;;; implementation can't do this.
+
+(declaim (inline make-shareable-byte-vector))
+(defun make-shareable-byte-vector (size)
+  "Create a Lisp vector of SIZE bytes can passed to
+WITH-POINTER-TO-VECTOR-DATA."
+  (make-array size :element-type '(unsigned-byte 8)))
+
+(deftype shareable-byte-vector ()
+  `(vector (unsigned-byte 8)))
+
+(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
+  "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
+  (with-unique-names (vector-var size-var)
+    `(let ((,vector-var ,vector))
+       (check-type ,vector-var shareable-byte-vector)
+       (with-foreign-pointer (,ptr-var (length ,vector-var) ,size-var)
+         ;; COPY-IN
+         (loop :for i :below ,size-var :do
+            (%mem-set (aref ,vector-var i) ,ptr-var :unsigned-char i))
+
+         , at body
+
+         ;; COPY-OUT
+         (loop :for i :below ,size-var :do
+            (setf (aref ,vector-var i)
+                  (%mem-ref ,ptr-var :unsigned-char i)))))))
+
 ;;;# Foreign Function Calling
 
 (defun parse-foreign-funcall-args (args)

-------------- next part --------------
A non-text attachment was scrubbed...
Name: not available
Type: application/pgp-signature
Size: 189 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/cffi-devel/attachments/20061220/b85aa0f7/attachment.sig>