forked from jingtaozf/burgled-batteries
-
Notifications
You must be signed in to change notification settings - Fork 10
/
cffi-output-args.lisp
79 lines (68 loc) · 3.39 KB
/
cffi-output-args.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
(in-package #:python3.cffi)
(define-foreign-type output-arg (cffi::enhanced-foreign-type)
((real-type :initarg :real-type :reader real-type)))
(define-foreign-type return (output-arg) ()
(:documentation "A RETURN foreign-type is like Clisp's :OUT."))
(define-parse-method return (real-type)
(make-instance 'return :actual-type :pointer :real-type (parse-type real-type)))
(define-foreign-type place (output-arg) ()
(:documentation "A PLACE foreign-type is like Clisp's :IN-OUT."))
(define-parse-method place (real-type)
(make-instance 'place :actual-type :pointer :real-type (parse-type real-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 gensym actual-type parsed-type)"
(cond
((eq arg '&rest) arg)
((listp arg)
(destructuring-bind (var type) arg
(let ((parsed-type (parse-type type)))
(cond
((typep parsed-type 'output-arg) (cl:list var (gensym (symbol-name var)) :pointer parsed-type))
(t (cl:list var (gensym (symbol-name var)) type parsed-type))))))
(t (error "oh noez!"))))
(defun %choose-symbol (arg)
(typecase (fourth arg)
(return (second arg))
(place (first arg))
(t (second arg))))
#+(or) ; Just an example
(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 (mapcar #'normalize-arg args))
(*values-accumulator* (gensym "ACCUM"))
(retval (gensym "RETVAL"))
(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 ((,*values-accumulator* (cl:list))
(,retval '#:you-should-never-see-this-value))
,(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) (defcfun* "foo" :void ((a :int) (b (return :boolean)) (c (place :boolean))))