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