I wrote:
> Meanwhile, I've implemented this with some changes.
So, here's what I've got:
diff -rN -u cffi-old/src/foreign-vars.lisp cffi-new/src/foreign-vars.lisp
--- cffi-old/src/foreign-vars.lisp 2006-01-07 01:54:06.000000000 +0000
+++ cffi-new/src/foreign-vars.lisp 2006-02-12 06:26:46.000000000 +0000
@@ -62,26 +62,20 @@
returning nil when foreign-name is not found."
(or (foreign-symbol-pointer foreign-name :data)
(error "Trying access undefined foreign variable ~S." foreign-name)))
-
+
(defmacro defcvar (name type &key read-only)
"Define a foreign global variable."
(let* ((lisp-name (lisp-var-name name))
(foreign-name (foreign-var-name name))
- (fn (symbolicate '#:%var-accessor- lisp-name))
- (ptype (parse-type type)))
- (when (aggregatep ptype) ; we can't really setf an aggregate type
- (setq read-only t)) ; at least not yet...
+ (fn (symbolicate '#:%var-accessor- lisp-name)))
+ (when (aggregatep (parse-type type)) ; we can't really setf an aggregate
+ (setq read-only t)) ; type, at least not yet...
`(progn
;; Save foreign-name for posterior access by get-var-ptr
(setf (get ',lisp-name 'foreign-var-name) ,foreign-name)
;; Getter
(defun ,fn ()
- ,(if (aggregatep ptype)
- ;; no dereference for aggregate types.
- `(foreign-symbol-pointer-or-lose ,foreign-name)
- `(translate-type-from-foreign
- (mem-ref (foreign-symbol-pointer-or-lose ,foreign-name) ',type)
- ,ptype)))
+ (mem-ref (foreign-symbol-pointer-or-lose ,foreign-name) ',type))
;; Setter
(defun (setf ,fn) (value)
,(if read-only '(declare (ignore value)) (values))
@@ -89,7 +83,7 @@
`(error ,(format nil "Trying to modify read-only foreign var: ~A."
lisp-name))
`(setf (mem-ref (foreign-symbol-pointer-or-lose ,foreign-name)
- ',type)
- (translate-type-to-foreign value ,ptype))))
+ ',type)
+ value)))
;; Symbol macro
(define-symbol-macro ,lisp-name (,fn)))))
diff -rN -u cffi-old/src/functions.lisp cffi-new/src/functions.lisp
--- cffi-old/src/functions.lisp 2006-02-10 18:18:03.000000000 +0000
+++ cffi-new/src/functions.lisp 2006-02-12 05:32:52.000000000 +0000
@@ -39,21 +39,15 @@
;;; (passed to TRANSLATE-OBJECTS as the CALL argument) instead
;;; of CFFI-SYS:%FOREIGN-FUNCALL to call the foreign-function.
-(defmacro translate-objects (syms args types rettype call)
- "Helper macro for FOREIGN-FUNCALL and DEFCFUN."
- (cond
- ;; All arguments have been translated, translate
- ;; the return value and perform the call.
- ((null args)
- (let ((parsed-type (parse-type rettype)))
- (if (translate-p parsed-type)
- `(translate-type-from-foreign ,call ,parsed-type)
- `(values ,call))))
- ;; More than one argument is available---translate the first
- ;; argument/type pair and recurse.
- (t `(with-object-translated (,(car syms) ,(car args) ,(car types))
- (translate-objects
- ,(rest syms) ,(rest args) ,(rest types) ,rettype ,call)))))
+(defun translate-objects (syms args types rettype call-form)
+ "Helper function for FOREIGN-FUNCALL and DEFCFUN."
+ (if (null args)
+ (expand-type-from-foreign call-form (parse-type rettype))
+ (expand-type-to-foreign-dyn
+ (car args) (car syms)
+ (list (translate-objects (cdr syms) (cdr args)
+ (cdr types) rettype call-form))
+ (parse-type (car types)))))
(defun parse-args-and-types (args)
"Returns 4 values. Types, canonicalized types, args and return type."
@@ -70,13 +64,13 @@
(multiple-value-bind (types ctypes fargs rettype)
(parse-args-and-types args)
(let ((syms (make-gensym-list (length fargs))))
- `(translate-objects
- ,syms ,fargs ,types ,rettype
- (,(if (stringp name-or-pointer)
+ (translate-objects
+ syms fargs types rettype
+ `(,(if (stringp name-or-pointer)
'%foreign-funcall
'%foreign-funcall-pointer)
- ,name-or-pointer ,@(mapcan #'list ctypes syms)
- ,(canonicalize-foreign-type rettype))))))
+ ,name-or-pointer ,@(mapcan #'list ctypes syms)
+ ,(canonicalize-foreign-type rettype))))))
(defun promote-varargs-type (builtin-type)
"Default argument promotions."
@@ -100,10 +94,10 @@
(parse-args-and-types varargs)
(let ((syms (make-gensym-list (+ (length fixed-fargs)
(length varargs-fargs)))))
- `(translate-objects
- ,syms ,(append fixed-fargs varargs-fargs)
- ,(append fixed-types varargs-types) ,rettype
- (,(if (stringp name-or-pointer)
+ (translate-objects
+ syms (append fixed-fargs varargs-fargs)
+ (append fixed-types varargs-types) rettype
+ `(,(if (stringp name-or-pointer)
'%foreign-funcall
'%foreign-funcall-pointer)
,name-or-pointer
@@ -148,13 +142,13 @@
(syms (make-gensym-list (length args))))
(multiple-value-bind (prelude caller)
(defcfun-helper-forms
- foreign-name lisp-name (canonicalize-foreign-type return-type)
- syms (mapcar #'canonicalize-foreign-type arg-types))
+ foreign-name lisp-name (canonicalize-foreign-type return-type)
+ syms (mapcar #'canonicalize-foreign-type arg-types))
`(progn
,prelude
(defun ,lisp-name ,arg-names
- (translate-objects
- ,syms ,arg-names ,arg-types ,return-type ,caller))))))
+ ,(translate-objects
+ syms arg-names arg-types return-type caller))))))
(defun %defcfun-varargs (lisp-name foreign-name return-type args)
(with-unique-names (varargs)
@@ -181,22 +175,25 @@
;;;# Defining Callbacks
-(defmacro inverse-translate-objects (args types rettype call)
- "Helper macro for DEFCALLBACK."
- (cond
- ((null args)
- (let ((parsed-type (parse-type rettype)))
- (if (translate-p parsed-type)
- `(translate-type-to-foreign ,call ,parsed-type)
- call)))
- (t
- (let ((type (parse-type (car types))))
- (if (translate-p type)
- `(let ((,(car args) (translate-type-from-foreign ,(car args) ,type)))
- (inverse-translate-objects ,(rest args) ,(rest types)
- ,rettype ,call))
- `(inverse-translate-objects ,(rest args) ,(rest types)
- ,rettype ,call))))))
+(defun inverse-translate-objects (args ignored-args types rettype call)
+ "Helper function for DEFCALLBACK."
+ (labels ((rec (args types)
+ (cond ((null args)
+ (expand-type-to-foreign call (parse-type rettype)))
+ ;; Don't apply translations for arguments that were
+ ;; declared ignored in order to avoid warnings.
+ ((not (member (car args) ignored-args))
+ `(let ((,(car args) ,(expand-type-from-foreign
+ (car args) (parse-type (car types)))))
+ ,(rec (cdr args) (cdr types))))
+ (t (rec (cdr args) (cdr types))))))
+ (rec args types)))
+
+(defun collect-ignored-args (declarations)
+ (loop for declaration in declarations
+ append (loop for decl in (cdr declaration)
+ when (eq (car decl) 'cl:ignore)
+ append (cdr decl))))
(defmacro defcallback (name return-type args &body body)
(multiple-value-bind (body docstring declarations)
@@ -208,8 +205,9 @@
(%defcallback ,name ,(canonicalize-foreign-type return-type)
,arg-names ,(mapcar #'canonicalize-foreign-type arg-types)
,@declarations
- (inverse-translate-objects ,arg-names ,arg-types ,return-type
- (block ,name ,@body)))
+ ,(inverse-translate-objects
+ arg-names (collect-ignored-args declarations) arg-types
+ return-type `(block ,name ,@body)))
',name))))
(defun get-callback (symbol)
diff -rN -u cffi-old/src/types.lisp cffi-new/src/types.lisp
--- cffi-old/src/types.lisp 2006-02-08 19:22:35.000000000 +0000
+++ cffi-new/src/types.lisp 2006-02-12 06:30:07.000000000 +0000
@@ -96,7 +96,6 @@
(:method (value name param)
(declare (ignore value name param))))
-
;;; Default translator to foreign for typedefs. We build a list out
;;; of the second value returned from each translator so we can pass
;;; each parameter to the appropriate free method when freeing the
@@ -123,17 +122,15 @@
;;;## Macroexpansion Time Translation
;;;
-;;; In this new implementation of type translation, this macro should
-;;; only be used when VAR should be translated and bound to VALUE, and
-;;; has dynamic extent during BODY. There is no need to use this
-;;; macro when converting values from C objects---just call
-;;; TRANSLATE-TYPE-FROM-FOREIGN directly.
+;;; The following expand-* generic functions are similar to their
+;;; translate-* counterparts but are usually called at macroexpansion
+;;; time. They offer a way to optimize the runtime translators.
;;;
-;;; If TYPE-SPEC refers to a built-in type, it will not be translated.
+;;; The default methods expand to forms calling the runtime translators
+;;; unless TRANSLATE-P returns NIL for the type.
-(defmacro with-object-translated ((var value type-spec) &body body)
- (let ((type (parse-type type-spec))
- (param (gensym "PARAM-")))
+(defun %expand-type-to-foreign-dyn (value var body type)
+ (with-unique-names (param)
(if (translate-p type)
`(multiple-value-bind (,var ,param)
(translate-type-to-foreign ,value ,type)
@@ -141,29 +138,113 @@
(progn ,@body)
(free-type-translated-object ,var ,type ,param)))
`(let ((,var ,value))
- ,@body))))
+ ,@body))))
+
+(defun %expand-type-to-foreign (value type)
+ (if (translate-p type)
+ `(translate-type-to-foreign ,value ,type)
+ value))
+
+(defun %expand-type-from-foreign (value type)
+ (if (translate-p type)
+ `(translate-type-from-foreign ,value ,type)
+ `(values ,value)))
+
+;;; This special variable is bound by the various :around methods below
+;;; to the respective form generated by the above %EXPAND-* functions.
+;;; This way, an expander can "bail out" by returning it.
+(defvar *runtime-translator-form*)
+
+(defgeneric expand-type-to-foreign-dyn (value var body type)
+ (:method :around (value var body type)
+ (let ((*runtime-translator-form*
+ (%expand-type-to-foreign-dyn value var body type)))
+ (call-next-method)))
+ (:method (value var body type)
+ ;; If COMPUTE-APPLICABLE-METHODS only finds one method it's
+ ;; the default one meaning that there is no to-foreign expander
+ ;; therefore we return *RUNTIME-TRANSLATOR-FORM* instead.
+ (if (< 1 (length (compute-applicable-methods
+ #'expand-type-to-foreign (list value type))))
+ `(let ((,var ,(expand-type-to-foreign value type)))
+ ,@body)
+ *runtime-translator-form*)))
+
+(defgeneric expand-type-to-foreign (value type)
+ (:method :around (value type)
+ (let ((*runtime-translator-form* (%expand-type-to-foreign value type)))
+ (call-next-method)))
+ (:method (value type)
+ (declare (ignore value type))
+ *runtime-translator-form*))
+
+(defgeneric expand-type-from-foreign (value type)
+ (:method :around (value type)
+ (let ((*runtime-translator-form* (%expand-type-from-foreign value type)))
+ (call-next-method)))
+ (:method (value type)
+ (declare (ignore value type))
+ *runtime-translator-form*))
+
+(defgeneric expand-to-foreign-dyn (value var body type))
+(defgeneric expand-to-foreign (value type))
+(defgeneric expand-from-foreign (value type))
+
+(defun applicablep (gf &rest args)
+ "Returns true if GF has any applicable methods for ARGS."
+ (not (null (compute-applicable-methods gf args))))
+
+(defmethod expand-type-to-foreign-dyn (value var body (type foreign-typedef))
+ (cond ((applicablep #'expand-to-foreign-dyn value var body (name type))
+ (expand-to-foreign-dyn value var body (name type)))
+ ;; If there is to-foreign _expansion_ we use that.
+ ((applicablep #'expand-to-foreign value (name type))
+ `(let ((,var ,(expand-to-foreign value (name type))))
+ ,@body))
+ ;; Else...
+ (t *runtime-translator-form*)))
+
+(defmethod expand-type-to-foreign (value (type foreign-typedef))
+ (if (applicablep #'expand-to-foreign value (name type))
+ (expand-to-foreign value (name type))
+ *runtime-translator-form*))
+
+(defmethod expand-type-from-foreign (value (type foreign-typedef))
+ (if (applicablep #'expand-from-foreign value (name type))
+ (expand-from-foreign value (name type))
+ *runtime-translator-form*))
;;;# Dereferencing Foreign Pointers
(defun mem-ref (ptr type &optional (offset 0))
"Return the value of TYPE at OFFSET bytes from PTR. If TYPE is aggregate,
we don't return its 'value' but a pointer to it, which is PTR itself."
- (let ((parsed-type (parse-type type)))
- (if (aggregatep parsed-type)
+ (let ((ptype (parse-type type)))
+ (if (aggregatep ptype)
(inc-pointer ptr offset)
- (%mem-ref ptr (canonicalize parsed-type) offset))))
+ (let ((raw-value (%mem-ref ptr (canonicalize ptype) offset)))
+ (if (translate-p ptype)
+ (translate-type-from-foreign raw-value ptype)
+ raw-value)))))
(define-compiler-macro mem-ref (&whole form ptr type &optional (offset 0))
"Compiler macro to open-code MEM-REF when TYPE is constant."
(if (constantp type)
- (if (aggregatep (parse-type (eval type)))
- `(inc-pointer ,ptr ,offset)
- `(%mem-ref ,ptr ,(canonicalize-foreign-type (eval type)) ,offset))
+ (let ((parsed-type (parse-type (eval type))))
+ (if (aggregatep parsed-type)
+ `(inc-pointer ,ptr ,offset)
+ (expand-type-from-foreign
+ `(%mem-ref ,ptr ,(canonicalize parsed-type) ,offset)
+ parsed-type)))
form))
(defun mem-set (value ptr type &optional (offset 0))
"Set the value of TYPE at OFFSET bytes from PTR to VALUE."
- (%mem-set value ptr (canonicalize-foreign-type type) offset))
+ (let ((ptype (parse-type type)))
+ (%mem-set (if (translate-p ptype)
+ (translate-type-to-foreign value ptype)
+ value)
+ ptr (canonicalize ptype) offset)))
(define-setf-expander mem-ref (ptr type &optional (offset 0) &environment env)
"SETF expander for MEM-REF that doesn't rebind TYPE.
@@ -196,7 +277,9 @@
(&whole form value ptr type &optional (offset 0))
"Compiler macro to open-code (SETF MEM-REF) when type is constant."
(if (constantp type)
- `(%mem-set ,value ,ptr ,(canonicalize-foreign-type (eval type)) ,offset)
+ (let ((parsed-type (parse-type (eval type))))
+ `(%mem-set ,(expand-type-to-foreign value parsed-type) ,ptr
+ ,(canonicalize parsed-type) ,offset))
form))
;;;# Dereferencing Foreign Arrays
@@ -314,36 +397,19 @@
(defmethod foreign-struct-slot-value (ptr (slot simple-struct-slot))
"Return the value of a simple SLOT from a struct at PTR."
- (let* ((type (slot-type slot))
- (parsed-type (parse-type type)))
- (translate-type-from-foreign
- (mem-ref ptr type (slot-offset slot)) parsed-type)))
+ (mem-ref ptr (slot-type slot) (slot-offset slot)))
(defmethod foreign-struct-slot-value-form (ptr (slot simple-struct-slot))
"Return a form to get the value of a slot from PTR."
- (let* ((type (slot-type slot))
- (parsed-type (parse-type type)))
- (if (translate-p parsed-type)
- `(translate-type-from-foreign
- (mem-ref ,ptr ',type ,(slot-offset slot))
- ,parsed-type)
- `(mem-ref ,ptr ',type ,(slot-offset slot)))))
+ `(mem-ref ,ptr ',(slot-type slot) ,(slot-offset slot)))
(defmethod (setf foreign-struct-slot-value) (value ptr (slot simple-struct-slot))
"Set the value of a simple SLOT to VALUE in PTR."
- (let* ((type (slot-type slot))
- (parsed-type (parse-type type)))
- (setf (mem-ref ptr type (slot-offset slot))
- (translate-type-to-foreign value parsed-type))))
+ (setf (mem-ref ptr (slot-type slot) (slot-offset slot)) value))
(defmethod foreign-struct-slot-set-form (value ptr (slot simple-struct-slot))
"Return a form to set the value of a simple structure slot."
- (let* ((type (slot-type slot))
- (parsed-type (parse-type type)))
- (if (translate-p parsed-type)
- `(setf (mem-ref ,ptr ',type ,(slot-offset slot))
- (translate-type-to-foreign ,value ,parsed-type))
- `(setf (mem-ref ,ptr ',type ,(slot-offset slot)) ,value))))
+ `(setf (mem-ref ,ptr ',(slot-type slot) ,(slot-offset slot)) ,value))
;;;### Aggregate Slots
@@ -727,6 +793,18 @@
(defmethod translate-from-foreign (value (name (eql :boolean)))
(not (zerop value)))
+(defmethod expand-to-foreign (value (name (eql :boolean)))
+ "Optimization for the :boolean type."
+ (if (constantp value)
+ (if (eval value) 1 0)
+ `(if ,value 1 0)))
+
+(defmethod expand-from-foreign (value (name (eql :boolean)))
+ "Optimization for the :boolean type."
+ (if (constantp value) ; very unlikely, heh
+ (not (zerop (eval value)))
+ `(not (zerop ,value))))
+
;;;# Built-In Types
(define-built-in-foreign-type :char)
--
Luís Oliveira
luismbo (@) gmail (.) com
Equipa Portuguesa do Translation Project
http://www.iro.umontreal.ca/translation/registry.cgi?team=pt
_______________________________________________
cffi-devel mailing list
cffi-devel@common-lisp.net
http://common-lisp.net/cgi-bin/mailman/listinfo/cffi-devel
