Permalink
Browse files

Reimplement output-args in terms of expand-to-foreign-dyn for a more …

…CFFI-ish feel

Ignore-this: 599e80fd355831eb719037eca25b22eb

darcs-hash:20111017193448-0344a-da35f3c3b3c74a321aaf032e0ba81c6b3346ab80.gz
  • Loading branch information...
pinterface
pinterface committed Oct 17, 2011
1 parent b43d9f4 commit 0c903b501a5e38e72c3319025febc7cd8a759671
Showing with 44 additions and 47 deletions.
  1. +34 −35 cffi-output-args.lisp
  2. +10 −12 ffi-definers.lisp
View
@@ -13,29 +13,30 @@
(define-parse-method place (real-type)
(make-instance 'place :actual-type :pointer :real-type (parse-type real-type)))
(defun %wrap-arg (arg-list body accum)
(destructuring-bind (val var real-type parsed-type)
(first arg-list)
(declare (ignore real-type))
(let* ((to-wrap (if (rest arg-list)
(%wrap-arg (rest arg-list) body accum)
body))
(real-type (ignore-errors (real-type parsed-type)))
(canonical-type (when real-type (cffi::canonicalize real-type))))
(typecase parsed-type
(return `((with-foreign-object (,var :pointer)
,@to-wrap
(push ,(expand-from-foreign `(mem-ref ,var ,canonical-type) real-type) ,accum))))
(place `(,(expand-to-foreign-dyn val var
`((with-foreign-object (,val :pointer)
(setf (mem-ref ,val ,canonical-type) ,var)
,@to-wrap
(push ,(expand-from-foreign `(mem-ref ,val ,canonical-type) real-type) ,accum)))
real-type)))
(t `(,(expand-to-foreign-dyn val var to-wrap parsed-type)))))))
(defgeneric include-in-argument-list-p (foreign-type)
(:documentation "Returns true if the given foreign-type should be included in the argument list of a function, false if it should be excluded.")
(:method ((foreign-type return)) nil)
(:method ((foreign-type t)) t))
(defvar *values-accumulator*)
(defmethod expand-to-foreign-dyn (value var body (type output-arg))
(let* ((real-type (real-type type))
(canonical-type (cffi::canonicalize real-type)))
`(with-foreign-object (,var :pointer)
,@body
(push ,(expand-from-foreign `(mem-ref ,var ,canonical-type) real-type) ,*values-accumulator*))))
(defmethod expand-to-foreign-dyn (value var body (type place))
(let* ((real-type (real-type type))
(canonical-type (cffi::canonicalize real-type)))
(expand-to-foreign-dyn
value var
`(,(call-next-method var value `((setf (mem-ref ,value ,canonical-type) ,var) ,@body) type))
real-type)))
(defun normalize-arg (arg)
"Returns (list var real-type parsed-type)"
"Returns (list var gensym actual-type parsed-type)"
(cond
((eq arg '&rest) arg)
((listp arg)
@@ -46,35 +47,33 @@
(t (cl:list var (gensym (symbol-name var)) type parsed-type))))))
(t (error "oh noez!"))))
(defun normalize-args (args)
(mapcar #'normalize-arg args))
(defun %choose-symbol (arg)
(typecase (fourth arg)
(return (second arg))
(place (first arg))
(t (second arg))))
#+(or) ; Just an example
(defmacro define-c-function (name return-type args)
(defmacro defcfun* (name return-type args)
(multiple-value-bind (lisp-name foreign-name options)
(cffi::parse-name-and-options name)
(let* ((internal-lisp-name (symbolicate "%" lisp-name))
(args (normalize-args args))
(accum (gensym "ACCUM"))
(args (mapcar #'normalize-arg args))
(*values-accumulator* (gensym "ACCUM"))
(retval (gensym "RETVAL"))
(lisp-args (mapcar #'first (remove-if (rcurry #'typep 'return) args :key #'fourth))))
(lisp-args (mapcar #'first (remove-if-not #'include-in-argument-list-p args :key #'fourth))))
`(progn
(defcfun (,foreign-name ,internal-lisp-name ,@options)
,return-type
,@(mapcar (lambda (arg) (cl:list (first arg) (third arg))) args))
(defun ,lisp-name ,lisp-args
(let ((,accum (cl:list))
(let ((,*values-accumulator* (cl:list))
(,retval '#:you-should-never-see-this-value))
,@(%wrap-arg args
`((setf ,retval (,internal-lisp-name ,@(mapcar #'%choose-symbol args))))
accum)
(push ,retval ,accum)
(values-list ,accum)))))))
,(loop :for (value var actual-type parsed-type) :in (cons '(nil nil nil nil) (reverse args))
:for body = `(setf ,retval (,internal-lisp-name ,@(mapcar #'%choose-symbol args)))
:then (expand-to-foreign-dyn value var (cl:list body) parsed-type)
:finally (cl:return body))
(push ,retval ,*values-accumulator*)
(values-list ,*values-accumulator*)))))))
#+(or) (define-c-function "foo" :void ((a :int) (b (return :boolean)) (c (place object))))
#+(or) (defcfun* "foo" :void ((a :int) (b (return :boolean)) (c (place :boolean))))
View
@@ -122,15 +122,16 @@ OPTIONS is a list of any, none, or all, of the following forms:
,@(when docstring `(,docstring))
,@args)))
(%make-cwrapper (internal-name lisp-name args)
(with-unique-names (accum retval)
(with-unique-names ((*values-accumulator* accum) retval)
`(defun ,lisp-name ,(mapcar #'first (remove-if (rcurry #'typep 'return) args :key #'fourth))
(let ((,accum (cl:list))
(let ((,*values-accumulator* (cl:list))
(,retval '#:you-should-never-see-this-value))
,@(%wrap-arg args
`((setf ,retval (,internal-name ,@(mapcar #'%choose-symbol args))))
accum)
(push ,retval ,accum)
(values-list ,accum)))))
,(loop :for (value var actual-type parsed-type) :in (cons '(nil nil nil nil) (reverse args))
:for body = `(setf ,retval (,internal-name ,@(mapcar #'%choose-symbol args)))
:then (expand-to-foreign-dyn value var (cl:list body) parsed-type)
:finally (cl:return body))
(push ,retval ,*values-accumulator*)
(values-list ,*values-accumulator*)))))
(%make-altfun (c-name lisp-name return-type c-args alt-body)
(multiple-value-bind (alt-body decl doc)
(parse-body alt-body :documentation t)
@@ -191,21 +192,18 @@ OPTIONS is a list of any, none, or all, of the following forms:
(requires (assoc-value options :requires))
(if-not-exist (or (assoc-value options :if-not-exist)
`((error "The C function ~S does not appear to exist." ,name))))
(normalized-args (normalize-args args))
(normalized-args (mapcar #'normalize-arg args))
(use-wrapper (some (lambda (a) (and (consp a) (typep (fourth a) 'output-arg))) normalized-args)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
,(cond
((and (foreign-symbol-pointer name)
use-wrapper)
(let ((internal-name (symbolicate "%" lisp-name))
(args (normalize-args args)))
(args normalized-args))
`(progn
,(%make-defcfun name internal-name return-type
(mapcar (lambda (arg) (cl:list (first arg) (third arg))) args)
documentation)
#+(or)
(defcfun (,name ,internal-name) ,return-type
,@(mapcar (lambda (arg) (cl:list (first arg) (third arg))) args))
,(%make-cwrapper internal-name lisp-name args)
,(%make-cwrapper internal-name (symbolicate lisp-name "*")
(mapcar (lambda (arg) `(,@(butlast arg)

0 comments on commit 0c903b5

Please sign in to comment.