Permalink
Browse files

Indirecting foreign objects for libffi

The generic function translate-into-foreign-memory has been slightly
repurposed and expanded to provide indirection of enums and pointers.
The function translate-objects and generic function
expand-to-foreign-dyn have a new argument, 'indirect, that when set,
expand to with-foreign-object and translate-into-foreign-memory
instead of translate-to-foreign, unwind-protect, and
free-translated-object.  This insures that all arguments to functions
passed to libffi are indirected one level, as is required.
  • Loading branch information...
liamh committed Nov 13, 2011
1 parent 153bbe2 commit 366949718c40b3a71d307c05f920684a70d5c183
Showing with 54 additions and 32 deletions.
  1. +25 −13 src/early-types.lisp
  2. +5 −0 src/enum.lisp
  3. +10 −7 src/functions.lisp
  4. +9 −12 src/structures.lisp
  5. +5 −0 src/types.lisp
View
@@ -359,6 +359,11 @@ Signals an error if the type cannot be resolved."
(declare (ignore type))
value))
+(defgeneric translate-into-foreign-memory (value type pointer)
+ (:documentation
+ "Translate the Lisp value into the foreign type, making the pointer point to the foreign object.")
+ (:argument-precedence-order type value pointer))
+
;;; Similar to TRANSLATE-TO-FOREIGN, used exclusively by
;;; (SETF FOREIGN-STRUCT-SLOT-VALUE).
(defgeneric translate-aggregate-to-foreign (ptr value type))
@@ -431,20 +436,24 @@ Signals an error if the type cannot be resolved."
;;; EXPAND-TO-FOREIGN-DYN
-(defgeneric expand-to-foreign-dyn (value var body type)
- (:method (value var body type)
- (declare (ignore type))
+(defgeneric expand-to-foreign-dyn (value var body type &optional indirect)
+ (:method (value var body type &optional indirect)
+ (declare (ignore type indirect))
`(let ((,var ,value)) ,@body)))
(defmethod expand-to-foreign-dyn :around
- (value var body (type translatable-foreign-type))
+ (value var body (type translatable-foreign-type) &optional indirect)
(let ((*runtime-translator-form*
- (with-unique-names (param)

This comment has been minimized.

Show comment Hide comment
@liamh

liamh Nov 13, 2011

Member

I've added an 'indirect argument to expand-to-foreign-dyn and translate-objects so that every object gets indirected one level (e.g., a foreign pointer becomes a pointer to a pointer) as libffi (in cffi-fsbv) requires. This indirection is performed by the method translate-into-foreign-memory, whose function I've expanded for this purpose. Accompanying that, I expand into with-foreign-object instead of translate-to-foreign, unwind-protect, and free-translated-object. This mimics what was expanded in the (soon to be obsolete) standalone FSBV. Does this look like a good way to go?

@liamh

liamh Nov 13, 2011

Member

I've added an 'indirect argument to expand-to-foreign-dyn and translate-objects so that every object gets indirected one level (e.g., a foreign pointer becomes a pointer to a pointer) as libffi (in cffi-fsbv) requires. This indirection is performed by the method translate-into-foreign-memory, whose function I've expanded for this purpose. Accompanying that, I expand into with-foreign-object instead of translate-to-foreign, unwind-protect, and free-translated-object. This mimics what was expanded in the (soon to be obsolete) standalone FSBV. Does this look like a good way to go?

- `(multiple-value-bind (,var ,param)
- (translate-to-foreign ,value ,type)
- (unwind-protect
- (progn ,@body)
- (free-translated-object ,var ,type ,param))))))
+ (if indirect
+ `(with-foreign-object (,var ',(unparse-type type))
+ (translate-into-foreign-memory ,value ,type ,var)
+ ,@body)
+ (with-unique-names (param)
+ `(multiple-value-bind (,var ,param)
+ (translate-to-foreign ,value ,type)
+ (unwind-protect
+ (progn ,@body)
+ (free-translated-object ,var ,type ,param)))))))
(call-next-method)))
;;; If this method is called it means the user hasn't defined a
@@ -455,7 +464,9 @@ Signals an error if the type cannot be resolved."
;;; above *RUNTIME-TRANSLATOR-FORM* which includes a call to
;;; FREE-TRANSLATED-OBJECT. (Or else there would occur no translation
;;; at all.)
-(defmethod expand-to-foreign-dyn (value var body (type translatable-foreign-type))
+
+(defmethod expand-to-foreign-dyn
+ (value var body (type translatable-foreign-type) &optional indirect)
(multiple-value-bind (expansion default-etp-p)
(expand-to-foreign value type)
(if default-etp-p
@@ -506,8 +517,9 @@ Signals an error if the type cannot be resolved."
(defmethod expand-to-foreign (value (type enhanced-typedef))
(expand-to-foreign value (actual-type type)))
-(defmethod expand-to-foreign-dyn (value var body (type enhanced-typedef))
- (expand-to-foreign-dyn value var body (actual-type type)))
+(defmethod expand-to-foreign-dyn
+ (value var body (type enhanced-typedef) &optional indirect)
+ (expand-to-foreign-dyn value var body (actual-type type) indirect))
;;;# User-defined Types and Translations.
View
@@ -121,6 +121,11 @@
(%foreign-enum-value type value :errorp t)
value))
+(defmethod translate-into-foreign-memory
+ (value (type foreign-enum) pointer)
+ (setf (mem-aref pointer (unparse-type (actual-type type)))
+ (translate-to-foreign value type)))
+
(defmethod translate-from-foreign (value (type foreign-enum))
(%foreign-enum-keyword type value :errorp t))
View
@@ -40,15 +40,16 @@
;;; TRANSLATE-OBJECTS as the CALL-FORM argument) instead of
;;; CFFI-SYS:%FOREIGN-FUNCALL to call the foreign-function.
-(defun translate-objects (syms args types rettype call-form)
+(defun translate-objects (syms args types rettype call-form &optional indirect)
"Helper function for FOREIGN-FUNCALL and DEFCFUN."
(if (null args)
(expand-from-foreign call-form (parse-type rettype))
(expand-to-foreign-dyn
(car args) (car syms)
(list (translate-objects (cdr syms) (cdr args)
- (cdr types) rettype call-form))
- (parse-type (car types)))))
+ (cdr types) rettype call-form indirect))
+ (parse-type (car types))
+ indirect)))
(defun parse-args-and-types (args)
"Returns 4 values. Types, canonicalized types, args and return type."
@@ -97,16 +98,17 @@
(defvar *foreign-structures-by-value*
(lambda (&rest args)
(declare (ignore args))
- (error "Unable to call structures by value; load CFFI-FSBV."))
+ (error "Unable to call structures by value; load CFFI-FSBV and retry."))
"A function that produces a form suitable for calling structures by value.")
(defun foreign-funcall-form (thing options args pointerp)
(multiple-value-bind (types ctypes fargs rettype)
(parse-args-and-types args)
- (let ((syms (make-gensym-list (length fargs))))
+ (let ((syms (make-gensym-list (length fargs)))
+ (fsbvp (fn-call-by-value-p ctypes rettype)))
(translate-objects
syms fargs types rettype
- (if (fn-call-by-value-p ctypes rettype)
+ (if fsbvp
;; Structures by value call through *foreign-structures-by-value*
(funcall *foreign-structures-by-value*
thing
@@ -119,7 +121,8 @@
,thing
(,@(mapcan #'list ctypes syms)
,(canonicalize-foreign-type rettype))
- ,@(parse-function-options options :pointer pointerp)))))))
+ ,@(parse-function-options options :pointer pointerp)))
+ fsbvp))))
(defmacro foreign-funcall (name-and-options &rest args)
"Wrapper around %FOREIGN-FUNCALL that translates its arguments."
View
@@ -1,5 +1,5 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
-;;; Time-stamp: <2011-10-29 17:48:06EDT structures.lisp>
+;;; Time-stamp: <2011-11-12 22:02:39EST structures.lisp>
;;;
;;; structures.lisp --- Methods for translating foreign structures.
;;;
@@ -30,17 +30,14 @@
;;; Definitions for conversion of foreign structures.
-(defgeneric translate-into-foreign-memory (value type p)
- (:documentation
- "Translate the Lisp value into the foreign type, writing the answers at the pointer p.")
- (:argument-precedence-order type value p)
- (:method ((object list) (type foreign-struct-type) p)
- ;; Iterate over plist, set slots
- (loop for (name value) on object by #'cddr
- do (setf
- (foreign-slot-value p (unparse-type type) name)
- (let ((slot (gethash name (structure-slots type))))
- (convert-to-foreign value (slot-type slot)))))))
+(defmethod translate-into-foreign-memory
+ ((object list) (type foreign-struct-type) p)
+ ;; Iterate over plist, set slots
+ (loop for (name value) on object by #'cddr
+ do (setf
+ (foreign-slot-value p (unparse-type type) name)
+ (let ((slot (gethash name (structure-slots type))))
+ (convert-to-foreign value (slot-type slot))))))
(defun convert-into-foreign-memory (value type ptr)
(let ((ptype (parse-type type)))
View
@@ -284,6 +284,11 @@ to open-code (SETF MEM-REF) forms."
(list index)
(list index-tmp)))))))
+
+(defmethod translate-into-foreign-memory
+ (value (type foreign-pointer-type) pointer)
+ (setf (mem-aref pointer :pointer) value))
+
(define-foreign-type foreign-array-type ()
((dimensions :reader dimensions :initarg :dimensions)
(element-type :reader element-type :initarg :element-type))

0 comments on commit 3669497

Please sign in to comment.