1 (defun plist-keys (plist)
2 (do* ((it plist
(cddr it
))
4 ((not it
) (nreverse res
))
7 (defun plist-values (plist)
8 (do* ((it (cdr plist
) (cddr it
))
10 ((not it
) (nreverse res
))
13 (defun string-ends-with (string ending
)
14 (and (>= (length string
) (length ending
))
15 (equal (subseq string
(- (length string
) (length ending
))) ending
)))
16 (defun string-strip-ending (string ending
)
17 (if (string-ends-with string ending
)
18 (subseq string
0 (- (length string
) (length ending
)))
20 (defun string-strip-endings (string &rest endings
)
21 (if (= 1 (length endings
))
22 (string-strip-ending string
(first endings
))
23 (apply #'string-strip-endings
(cons (string-strip-ending string
(first endings
)) (rest endings
)))))
25 (defun type-map-type-to-gl-type (type-map-type)
26 (let ((s (string-strip-endings (symbol-name type-map-type
)
27 "NV" "ARB" "SGIX" "EXT" "ATI" "IBM" "3DFX" "SGIS"
28 "SUNX" "HP" "GREMEDY" "APPLE" "MESA" "SUN" "INTEL"
30 (cond ((equal s
"*") :void
)
31 ((find #\
* (format nil
"~a" s
)) :pointer
)
32 ((equal (subseq s
0 2) "GL") (intern (string-upcase (subseq s
2))))
33 ((equal s
"_GLfuncptr") :pointer
)
36 (defun constantize (symbol)
38 (map 'string
#'(lambda (c) (if (alphanumericp c
) c
#\-
))
39 (symbol-name symbol
))))
41 (defun deconstant (symbol)
42 (if (not (constantp symbol
))
44 (deconstant (intern (concatenate 'string
"_" (symbol-name symbol
))))))
46 (defmacro func-spec-accessors
(names)
47 `(progn ,@(mapcar #'(lambda (k)
48 `(defun ,k
(func-spec)
50 (getf (rest func-spec
)
51 ,(intern (symbol-name k
) '#:keyword
)))))
53 (defun c-name (func-spec)
54 (first (first func-spec
)))
55 (defun lisp-name (func-spec)
56 (second (first func-spec
)))
57 (func-spec-accessors (offset wglflags glsopcode glxsingle version category dlflags param
58 glxropcode glxflags glsflags vectorequiv extension glxvendorpriv glsalias
59 alias glfflags glxvectorequiv beginend
))
60 (defun freturn (func-spec)
61 (first (getf (rest func-spec
) :return
)))
62 (defun args (func-spec)
63 (getf (rest func-spec
) :args
))
66 (defparameter *base
* (merge-pathnames #P
"../" *load-pathname
*))
68 (let* ((spec (with-open-file (in (merge-pathnames #P
"src/gl.spec.lisp" *base
*)) (read in
)))
69 (function-specs (rest (getf spec
:functions
)))
70 (type-maps (getf spec
:type-map
))
71 (enum-specs (getf spec
:enum-spec
))
72 (base-categories '(|display-list| |drawing| |drawing-control| |feedback|
73 |framebuf| |misc| |modeling| |pixel-op| |pixel-rw|
76 (predefined-enumerants)
78 (declare (optimize (debug 3)))
79 (remf enum-specs
:extensions
)
81 ;; print out initial statistics
82 (format t
"~a functions~%" (length function-specs
))
83 (format t
"~a type-maps~%" (/ (length type-maps
) 2))
84 (format t
"~a enum-specs~%" (length enum-specs
))
87 ;; count up the properties of functions
88 (let ((property-counts ()))
89 (dolist (function-spec function-specs
)
90 (dolist (property (plist-keys (rest function-spec
)))
91 (setf (getf property-counts property
) (1+ (getf property-counts property
0)))))
92 (let ((*print-pretty
* t
))
93 (format t
"Property counts: ~a~%" property-counts
)))
95 ;; resolve any missing enums in the enumerations
96 (labels ((resolve-enum (value enum-name
)
98 (do* ((all-enums (apply #'append
(plist-values enum-specs
)))
99 (cur-val (getf all-enums enum-name
) (getf all-enums enum-name
)))
100 ((or (null cur-val
) (not (or (listp cur-val
)
103 ;;(format t "cur-val ~a doesn't satisfy~%" cur-val)
104 (remf all-enums enum-name
)))
106 (resolve-enum nil value
))
108 (dolist (enum-group-name (plist-keys enum-specs
))
109 (symbol-macrolet ((enum-group (getf enum-specs enum-group-name
)))
110 (dolist (enum-name (plist-keys enum-group
))
111 (symbol-macrolet ((enum (getf enum-group enum-name
)))
112 (setf enum
(resolve-enum enum enum-name
)))))))
114 ;; turn type mapping destinations into actual symbols
115 (dolist (type-map-pname (plist-keys type-maps
))
116 (setf (getf type-maps type-map-pname
)
117 (type-map-type-to-gl-type (getf type-maps type-map-pname
))))
119 ;; collect arguments of functions into ordered list with all meta-data attached
120 (dolist (func-spec function-specs
)
122 (do* ((arg-spec (getf (rest func-spec
) :param
) (getf (rest func-spec
) :param
)))
124 (setf (getf arg-specs
(getf arg-spec
:name
))
126 (remf (rest func-spec
) :param
))
127 (setf (getf (rest func-spec
) :args
)
128 (loop for arg-name in
(args func-spec
) collecting
129 (getf arg-specs arg-name
)))))
131 ;; categorize functions
132 (dolist (function-spec function-specs
)
134 (getf function-categories
(intern (category function-spec
)))))
136 (defun gl-extension-function-definition (func-spec)
137 (push (lisp-name func-spec
) exports
)
138 `(defglextfun ,func-spec
))
140 (defun output-extension (category-name &optional
(function-transform #'gl-extension-function-definition
) extension-name
)
141 (unless extension-name
(setf extension-name category-name
))
142 (with-open-file (out (merge-pathnames (format nil
"lib/opengl-~a.lisp" extension-name
) *base
*)
143 :direction
:output
:if-exists
:supersede
)
144 (print '(in-package #:gl
) out
)
147 (loop while
(getf enum-specs category-name
) collecting
149 (mapcar #'(lambda (enum-name)
150 (gl-enumeration-definition category-name enum-name
))
152 #'(lambda (enum-name)
153 (find enum-name predefined-enumerants
))
154 (plist-keys (getf enum-specs category-name
))))
155 (remf enum-specs category-name
)))))
158 (loop while
(getf function-categories category-name
) collecting
160 (mapcar function-transform
(getf function-categories category-name
))
161 (remf function-categories category-name
))))))
162 (when (or enumerations functions
)
163 (format out
"~&~%;;;; ~a~&" (symbol-name category-name
))
164 (let ((loader-name (intern (concatenate 'string
"load-extension-" (symbol-name extension-name
)))))
165 (dolist (enumeration enumerations
) (print enumeration out
))
166 (dolist (function functions
) (print function out
))
167 (push loader-name exports
))))))
169 (defun gl-function-definition (func-spec)
170 (push (lisp-name func-spec
) exports
)
171 `(defglfun ,func-spec
))
173 (defun gl-enumeration-definition (enumeration-group-name enumeration-name
)
175 (intern (string-upcase
177 (map 'string
#'(lambda (c) (if (alphanumericp c
) c
#\-
))
178 (symbol-name enumeration-name
)))))))
179 (push constant-name exports
)
180 `(defconstant ,constant-name
181 ,(getf (getf enum-specs enumeration-group-name
)
184 (defun gl-enumeration-definitions (enumeration-group-name)
185 (mapcar #'(lambda (enumeration-name)
186 (gl-enumeration-definition enumeration-group-name enumeration-name
))
187 (plist-keys (getf enum-specs enumeration-group-name
))))
190 (let ((*print-case
* :downcase
) (*print-radix
* t
) (*print-base
* 16))
191 (with-open-file (out (merge-pathnames #P
"src/opengl-body.lisp" *base
*) :direction
:output
:if-exists
:supersede
)
193 (defun output-category (category-name)
194 (format out
"~&~%;;;; ~a~%" category-name
)
195 (dolist (func-spec (getf function-categories category-name
))
196 (print (gl-function-definition func-spec
) out
))
197 (remf function-categories category-name
))
200 (dolist (enumeration-group-name (plist-keys enum-specs
))
201 (when (or (not (getf function-categories enumeration-group-name
))
202 (find enumeration-group-name base-categories
))
203 (let ((enumeration-names (plist-keys (getf enum-specs enumeration-group-name
))))
204 (when enumeration-names
205 (format out
"~&~%;;;; Enumerations: ~a~%" (symbol-name enumeration-group-name
))
206 (dolist (enumeration-name enumeration-names
)
207 (if (find enumeration-name predefined-enumerants
)
208 (format out
"~&;; ~a already defined" enumeration-name
)
209 (let ((*print-radix
* t
) (*print-base
* 16))
210 (push enumeration-name predefined-enumerants
)
211 (print (gl-enumeration-definition enumeration-group-name enumeration-name
) out
))))))
212 (remf enum-specs enumeration-group-name
)))
214 ;; generate the functions for all of the 1.0 functions
215 (dolist (category-name base-categories
)
216 (output-category category-name
)))
218 (output-extension '|
1_1|
#'gl-function-definition
'VERSION_1_1
)
220 (output-extension 'VERSION_1_2
#'gl-function-definition
)
221 (output-extension 'VERSION_1_3
#'gl-function-definition
)
222 (output-extension 'VERSION_1_4
#'gl-function-definition
)
223 (output-extension 'VERSION_1_5
#'gl-function-definition
)
224 (output-extension 'VERSION_2_0
#'gl-function-definition
)
225 (output-extension 'VERSION_2_1
#'gl-function-definition
)
227 (dolist (category-name (remove-duplicates
228 (union (plist-keys function-categories
)
229 (plist-keys enum-specs
))))
230 (output-extension category-name
))
232 (with-open-file (out (merge-pathnames #P
"src/opengl-type-maps.lisp" *base
*) :direction
:output
:if-exists
:supersede
)
233 (print type-maps out
))
235 (with-open-file (out (merge-pathnames #P
"src/opengl-exports.lisp" *base
*) :direction
:output
:if-exists
:supersede
)
236 (dolist (export (remove-duplicates (nreverse exports
)))
237 (print export out
))))
238 (format t
"Leftovers functions: ~%~s~%Leftover enums:~s" function-categories enum-specs
))