1 (defpackage #:cl-glfw-scaffolding
3 (:export
#:defglfun
#:defglextfun
#:*type-map
*))
4 (in-package #:cl-glfw-scaffolding
)
6 (defparameter *type-map
* nil
)
8 (defun c-name-of (func-spec) (first (first func-spec
)))
9 (defun lisp-name-of (func-spec) (second (first func-spec
)))
10 (defun freturn-of (func-spec) (first (getf (rest func-spec
) :return
)))
11 (defun args-of (func-spec) (getf (rest func-spec
) :args
))
13 (defun deconstant (symbol)
14 (if (not (constantp symbol
))
16 (deconstant (intern (concatenate 'cl
:string
"_" (symbol-name symbol
))))))
18 (defun final-arg-name (arg)
19 (deconstant (intern (string-upcase (symbol-name (getf arg
:name
))))))
22 (defun final-arg-type (arg)
23 (let ((type (getf *type-map
* (getf arg
:type
))))
25 ((equal "VOID" (symbol-name type
)) :pointer
)
26 ((getf arg
:array
) (if (equal (symbol-name type
) "CHAR") :string
:pointer
))
29 (defun arg-element-type (arg)
30 (getf *type-map
* (getf arg
:type
)))
32 (defun conc-symbols (&rest symbols
)
33 (intern (apply #'concatenate
(cons 'cl
:string
(mapcar #'symbol-name symbols
)))))
35 (defun array-wrappable-p (arg #|args|
#)
36 (let ((resolved-type (getf *type-map
* (getf arg
:type
))))
37 (and (getf arg
:array
)
38 ;; we must have a type, ie. not a void* pointer
39 (not (equal "VOID" (symbol-name resolved-type
)))
40 ;; opengl cannot retain this pointer, as we would destroy it after passing it
41 (not (getf arg
:retained
))
42 ;; can we guarantee a size? - used to do this, but the app programmer must get it right himself for OpenGL anyway
43 ;; so doing it this way is consistent with the C-interface, though more dangerous
45 (or (integerp (getf arg
:size
))
46 (and (symbolp (getf arg
:size
))
47 (find-if #'(lambda (other-arg)
48 (eql (getf arg
:size
) (final-arg-name other-arg
)))
51 (not (getf arg
:wrapped
)))))
53 (defun gl-function-definition (func-spec &optional
(c-prefix "gl") (lisp-prefix '#:||
))
54 `(defcfun (,(concatenate 'cl
:string c-prefix
(c-name-of func-spec
))
55 ,(conc-symbols lisp-prefix
(lisp-name-of func-spec
)))
56 ,(getf *type-map
* (intern (freturn-of func-spec
)))
57 ,@(mapcar #'(lambda (arg) (list (final-arg-name arg
) (final-arg-type arg
)))
58 (args-of func-spec
))))
60 (defun gl-funcall-definition (func-spec fpointer
)
61 `(foreign-funcall ,fpointer
62 ,@(mapcan #'(lambda (arg)
63 `(,(final-arg-type arg
) ,(final-arg-name arg
)))
65 ,(getf *type-map
* (intern (freturn-of func-spec
)))))
67 (defun expand-a-wrapping (func-spec final-content
)
68 (let* ((func-spec (copy-tree func-spec
)) ; duplicate because we're not supposed to modify macro params
69 (args (args-of func-spec
))
70 (first-wrappable (position-if #'array-wrappable-p args
)))
72 (let* ((arg (elt (args-of func-spec
) first-wrappable
))
73 (original-array-name (gensym (symbol-name (final-arg-name arg
))))
74 (array-name (final-arg-name arg
)))
75 ;; set it wrapped by non-consingly attaching a wrapped property on the end
76 (nconc arg
(list :wrapped t
))
77 `(if (and (typep ,array-name
'sequence
) (not (stringp ,array-name
)))
78 ;; the actual allocation
79 (let* ((,original-array-name
,array-name
)
80 (,array-name
(foreign-alloc ',(arg-element-type arg
)
81 ;; we used to base it on the count of whatever the spec said
82 #|
:count
,(getf arg
:size
)|
#
83 ;; but now, we'll use the user's sequence size, or just their content
84 ,@(if (eql (getf arg
:direction
) :in
)
85 `(:initial-contents
,original-array-name
)
86 `(:count
(length ,original-array-name
))))))
87 ;; (format t "Copying ~a elements of ~a: ~a into ~a~%"
88 ;; ,(getf arg :size) ',array-name ,original-array-name ,array-name)
91 ;; recurse in case there are more
92 ,(expand-a-wrapping func-spec final-content
)
93 ;; custom coersion of output values, after call
94 ,(when (eql (getf arg
:direction
) :out
)
96 ((listp ,original-array-name
)
97 (loop for i from
0 for cel
= ,original-array-name then
(cdr cel
) do
98 (setf (car cel
) (mem-aref ,array-name
',(arg-element-type arg
) i
))))
99 ((vectorp ,original-array-name
)
100 (loop for i below
(length ,original-array-name
) do
101 (setf (aref ,original-array-name i
)
102 (mem-aref ,array-name
',(arg-element-type arg
) i
)))))))
103 (foreign-free ,array-name
)))
104 ;; in the case the arg wasn't a sequence, pass it straight through
105 ,(expand-a-wrapping func-spec final-content
)))
106 ;; in the case that there is no more wrapping to be done, emit the final content to start unwinding
109 (defun wrapped-win32-gl-function-definition (func-spec)
110 `(let ((fpointer (foreign-funcall "wglGetProcAddress"
111 :string
,(concatenate 'cl
:string
"gl" (c-name-of func-spec
))
113 ;; I know the CFFI guide recommends against holding pointers, but for extensions on win,
114 ;; function pointers are the only way to do it. I don't think the locations are compiled
115 ;; in-to the fasl files, as it's a top-level form.
116 (when (null-pointer-p fpointer
)
117 (error 'simple-error
"Error! Can't find function ~a" (first func-spec
)))
118 (defun ,(lisp-name-of func-spec
)
119 ,(mapcar #'(lambda (arg) (final-arg-name arg
))
121 ;; if there is more than 0 wrappable arrays
122 ,(let ((args (args-of func-spec
)))
123 (if (some #'array-wrappable-p args
)
124 (expand-a-wrapping func-spec
125 (gl-funcall-definition func-spec
'fpointer
))
126 (gl-funcall-definition func-spec
'fpointer
))))))
128 (defun wrapped-gl-function-definition (func-spec)
129 (let ((args (args-of func-spec
)))
130 ;; if there is more than 0 wrappable arrays
131 (if (some #'array-wrappable-p args
)
133 ;; make an inlined function prefixed with %
134 (declaim (inline ,(conc-symbols '#:%
(lisp-name-of func-spec
))))
135 ,(gl-function-definition func-spec
"gl" '#:%
)
136 ;; the exposed function with wrappings
137 (defun ,(lisp-name-of func-spec
) ,(mapcar #'final-arg-name
(args-of func-spec
))
138 ,(expand-a-wrapping func-spec
139 `(,(conc-symbols '#:%
(lisp-name-of func-spec
))
140 ,@(mapcar #'final-arg-name
(args-of func-spec
))))))
141 (gl-function-definition func-spec
))))
143 (defmacro defglfun
(func-spec)
144 (wrapped-gl-function-definition func-spec
))
146 (defmacro defglextfun
(func-spec)
147 #+win32
(wrapped-win32-gl-function-definition func-spec
)
148 #-win32
(wrapped-gl-function-definition func-spec
))