1 ;; proto-package for type-mappings only
5 (:shadow boolean byte float char string
)
7 enum boolean bitfield byte short int sizei ubyte ushort uint float clampf
8 double clampd void uint64 int64 intptr sizeiptr handle char string half
))
10 (defparameter *opengl-version-systems
* '("cl-glfw-opengl-version_1_1"
11 "cl-glfw-opengl-version_1_2"
12 "cl-glfw-opengl-version_1_3"
13 "cl-glfw-opengl-version_1_4"
14 "cl-glfw-opengl-version_1_5"
15 "cl-glfw-opengl-version_2_0"
16 "cl-glfw-opengl-version_2_1")
17 "List of versioned extensions for dependency generation.
18 Must be in the correct order.")
20 (defun plist-keys (plist)
21 (do* ((it plist
(cddr it
))
23 ((not it
) (nreverse res
))
26 (defun plist-values (plist)
27 (do* ((it (cdr plist
) (cddr it
))
29 ((not it
) (nreverse res
))
32 (defun string-ends-with (string ending
)
33 (and (>= (length string
) (length ending
))
34 (equal (subseq string
(- (length string
) (length ending
))) ending
)))
35 (defun string-strip-ending (string ending
)
36 (if (string-ends-with string ending
)
37 (subseq string
0 (- (length string
) (length ending
)))
39 (defun string-strip-endings (string &rest endings
)
40 (if (= 1 (length endings
))
41 (string-strip-ending string
(first endings
))
42 (apply #'string-strip-endings
(cons (string-strip-ending string
(first endings
)) (rest endings
)))))
44 (defun type-map-type-to-gl-type (type-map-type)
45 (let ((s (string-strip-endings (symbol-name type-map-type
)
46 "NV" "ARB" "SGIX" "EXT" "ATI" "IBM" "3DFX" "SGIS"
47 "SUNX" "HP" "GREMEDY" "APPLE" "MESA" "SUN" "INTEL"
49 (cond ((equal s
"*") :void
)
50 ((find #\
* (format nil
"~a" s
)) :pointer
)
51 ((equal (subseq s
0 2) "GL") (intern (string-upcase (subseq s
2)) (find-package '#:gl
)))
52 ((equal s
"_GLfuncptr") :pointer
)
55 (defun constantize (symbol)
57 (map 'string
#'(lambda (c) (if (alphanumericp c
) c
#\-
))
58 (symbol-name symbol
))))
60 (defun deconstant (symbol)
61 (if (not (constantp symbol
))
63 (deconstant (intern (concatenate 'string
"_" (symbol-name symbol
))))))
65 (defmacro func-spec-accessors
(names)
66 `(progn ,@(mapcar #'(lambda (k)
67 `(defun ,k
(func-spec)
69 (getf (rest func-spec
)
70 ,(intern (symbol-name k
) '#:keyword
)))))
72 (defun c-name (func-spec)
73 (first (first func-spec
)))
74 (defun lisp-name (func-spec)
75 (second (first func-spec
)))
76 (func-spec-accessors (offset wglflags glsopcode glxsingle version category dlflags param
77 glxropcode glxflags glsflags vectorequiv extension glxvendorpriv glsalias
78 alias glfflags glxvectorequiv beginend
))
79 (defun freturn (func-spec)
80 (first (getf (rest func-spec
) :return
)))
81 (defun args (func-spec)
82 (getf (rest func-spec
) :args
))
85 (defparameter *base
* (merge-pathnames #P
"../" *load-truename
*))
87 (let* ((spec (with-open-file (in (merge-pathnames #P
"src/gl.spec.lisp" *base
*)) (read in
)))
88 (function-specs (rest (getf spec
:functions
)))
89 (type-maps (getf spec
:type-map
))
90 (enum-specs (getf spec
:enum-spec
))
91 (base-categories '(|display-list| |drawing| |drawing-control| |feedback|
92 |framebuf| |misc| |modeling| |pixel-op| |pixel-rw|
95 (predefined-enumerants)
97 (declare (optimize (debug 3)))
98 (remf enum-specs
:extensions
)
100 ;; print out initial statistics
101 (format t
"~a functions~%" (length function-specs
))
102 (format t
"~a type-maps~%" (/ (length type-maps
) 2))
103 (format t
"~a enum-specs~%" (length enum-specs
))
106 ;; count up the properties of functions
107 (let ((property-counts ()))
108 (dolist (function-spec function-specs
)
109 (dolist (property (plist-keys (rest function-spec
)))
110 (setf (getf property-counts property
) (1+ (getf property-counts property
0)))))
111 (let ((*print-pretty
* t
))
112 (format t
"Property counts: ~a~%" property-counts
)))
114 ;; resolve any missing enums in the enumerations
115 (labels ((resolve-enum (value enum-name
)
117 (do* ((all-enums (apply #'append
(plist-values enum-specs
)))
118 (cur-val (getf all-enums enum-name
) (getf all-enums enum-name
)))
119 ((or (null cur-val
) (not (or (listp cur-val
)
122 ;;(format t "cur-val ~a doesn't satisfy~%" cur-val)
123 (remf all-enums enum-name
)))
125 (resolve-enum nil value
))
127 (dolist (enum-group-name (plist-keys enum-specs
))
128 (symbol-macrolet ((enum-group (getf enum-specs enum-group-name
)))
129 (dolist (enum-name (plist-keys enum-group
))
130 (symbol-macrolet ((enum (getf enum-group enum-name
)))
131 (setf enum
(resolve-enum enum enum-name
)))))))
133 ;; turn type mapping destinations into actual symbols
134 (dolist (type-map-pname (plist-keys type-maps
))
135 (setf (getf type-maps type-map-pname
)
136 (type-map-type-to-gl-type (getf type-maps type-map-pname
))))
138 ;; collect arguments of functions into ordered list with all meta-data attached
139 (dolist (func-spec function-specs
)
141 (do* ((arg-spec (getf (rest func-spec
) :param
) (getf (rest func-spec
) :param
)))
143 (setf (getf arg-specs
(getf arg-spec
:name
))
145 (remf (rest func-spec
) :param
))
146 (setf (getf (rest func-spec
) :args
)
147 (loop for arg-name in
(args func-spec
) collecting
148 (getf arg-specs arg-name
)))))
150 ;; categorize functions
151 (dolist (function-spec function-specs
)
153 (getf function-categories
(intern (category function-spec
)))))
155 (defun gl-extension-function-definition (func-spec)
156 (push (lisp-name func-spec
) exports
)
157 `(defglextfun ,func-spec
))
159 (defun output-extension (category-name &optional
(function-transform #'gl-extension-function-definition
) extension-name
)
160 (unless extension-name
(setf extension-name category-name
))
161 (with-open-file (out (merge-pathnames (format nil
"lib/opengl-~a.lisp" extension-name
) *base
*)
162 :direction
:output
:if-exists
:supersede
)
163 (print '(in-package #:gl
) out
)
166 (loop while
(getf enum-specs category-name
) collecting
168 (mapcar #'(lambda (enum-name)
169 (gl-enumeration-definition category-name enum-name
))
171 #'(lambda (enum-name)
172 (find enum-name predefined-enumerants
))
173 (plist-keys (getf enum-specs category-name
))))
174 (remf enum-specs category-name
)))))
177 (loop while
(getf function-categories category-name
) collecting
179 (mapcar function-transform
(getf function-categories category-name
))
180 (remf function-categories category-name
))))))
181 (when (or enumerations functions
)
182 (format out
"~&~%;;;; ~a~&" (symbol-name category-name
))
183 (dolist (enumeration enumerations
) (print enumeration out
))
184 (dolist (function functions
) (print function out
)))))
185 (with-open-file (out (merge-pathnames (format nil
"lib/cl-glfw-opengl-~a.asd" extension-name
) *base
*)
186 :direction
:output
:if-exists
:supersede
)
187 (let* ((system-name (string-downcase (format nil
"cl-glfw-opengl-~a" extension-name
)))
188 (system-package (make-symbol (string-upcase (concatenate 'string system-name
"-system")))))
189 (print `(defpackage ,system-package
(:use
#:asdf
#:cl
)) out
)
190 (print `(in-package ,system-package
) out
)
191 (print `(defsystem ,(intern (string-upcase system-name
))
192 :description
,(concatenate 'string
"cl-glfw's " system-name
" Binding")
193 :author
,(format nil
"Generated by cl-glfw's ~a" *load-truename
*)
194 :license
"Public Domain"
195 :depends-on
(cl-glfw ,@(let ((pos (position system-name
*opengl-version-systems
* :test
'equal
)))
196 (when (and pos
(plusp pos
))
197 (list (intern (elt *opengl-version-systems
* (1- pos
)))))))
198 :components
((:file
,(concatenate 'string
"opengl-"
199 (string-downcase (symbol-name extension-name
))))))
202 (defun gl-function-definition (func-spec)
203 (push (lisp-name func-spec
) exports
)
204 `(defglfun ,func-spec
))
206 (defun gl-enumeration-definition (enumeration-group-name enumeration-name
)
208 (intern (string-upcase
210 (map 'string
#'(lambda (c) (if (alphanumericp c
) c
#\-
))
211 (symbol-name enumeration-name
)))))))
212 (push constant-name exports
)
213 `(defconstant ,constant-name
214 ,(getf (getf enum-specs enumeration-group-name
)
217 (defun gl-enumeration-definitions (enumeration-group-name)
218 (mapcar #'(lambda (enumeration-name)
219 (gl-enumeration-definition enumeration-group-name enumeration-name
))
220 (plist-keys (getf enum-specs enumeration-group-name
))))
223 (let ((*print-case
* :downcase
) (*print-radix
* t
) (*print-base
* 16))
224 (with-open-file (out (merge-pathnames #P
"src/opengl-body.lisp" *base
*) :direction
:output
:if-exists
:supersede
)
226 (defun output-category (category-name)
227 (format out
"~&~%;;;; ~a~%" category-name
)
228 (dolist (func-spec (getf function-categories category-name
))
229 (print (gl-function-definition func-spec
) out
))
230 (remf function-categories category-name
))
233 (dolist (enumeration-group-name (plist-keys enum-specs
))
234 (when (or (not (getf function-categories enumeration-group-name
))
235 (find enumeration-group-name base-categories
))
236 (let ((enumeration-names (plist-keys (getf enum-specs enumeration-group-name
))))
237 (when enumeration-names
238 (format out
"~&~%;;;; Enumerations: ~a~%" (symbol-name enumeration-group-name
))
239 (dolist (enumeration-name enumeration-names
)
240 (if (find enumeration-name predefined-enumerants
)
241 (format out
"~&;; ~a already defined" enumeration-name
)
242 (let ((*print-radix
* t
) (*print-base
* 16))
243 (push enumeration-name predefined-enumerants
)
244 (print (gl-enumeration-definition enumeration-group-name enumeration-name
) out
))))))
245 (remf enum-specs enumeration-group-name
)))
247 ;; generate the functions for all of the 1.0 functions
248 (dolist (category-name base-categories
)
249 (output-category category-name
)))
251 (output-extension '|
1_1|
#'gl-function-definition
'VERSION_1_1
)
253 (output-extension 'VERSION_1_2
#'gl-function-definition
)
254 (output-extension 'VERSION_1_3
#'gl-function-definition
)
255 (output-extension 'VERSION_1_4
#'gl-function-definition
)
256 (output-extension 'VERSION_1_5
#'gl-function-definition
)
257 (output-extension 'VERSION_2_0
#'gl-function-definition
)
258 (output-extension 'VERSION_2_1
#'gl-function-definition
)
260 (dolist (category-name (remove-duplicates
261 (union (plist-keys function-categories
)
262 (plist-keys enum-specs
))))
263 (output-extension category-name
))
265 (with-open-file (out (merge-pathnames #P
"src/opengl-type-maps.lisp" *base
*) :direction
:output
:if-exists
:supersede
)
266 (print type-maps out
))
268 (with-open-file (out (merge-pathnames #P
"src/opengl-exports.lisp" *base
*) :direction
:output
:if-exists
:supersede
)
269 (dolist (export (remove-duplicates (nreverse exports
)))
270 (print export out
))))
271 (format t
"Leftovers functions: ~%~s~%Leftover enums:~s" function-categories enum-specs
))