generators/make-bindings-from-spec.lisp

   1 (defun plist-keys (plist)
   2   (do* ((it plist (cddr it))
   3         (res nil))
   4        ((not it) (nreverse res))
   5     (push (car it) res)))
   6
   7 (defun plist-values (plist)
   8   (do* ((it (cdr plist) (cddr it))
   9         (res nil))
  10        ((not it) (nreverse res))
  11     (push (car it) res)))
  12
  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)))
  19       string))
  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)))))
  24
  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"
  29                                  "WIN")))
  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)
  34           (t s))))
  35
  36 (defun constantize (symbol)
  37   (format nil "+~a+"
  38           (map 'string #'(lambda (c) (if (alphanumericp c) c #\-))
  39                (symbol-name symbol))))
  40
  41 (defun deconstant (symbol)
  42   (if (not (constantp symbol))
  43       symbol
  44       (deconstant (intern (concatenate 'string "_" (symbol-name symbol))))))
  45
  46 (defmacro func-spec-accessors (names)
  47   `(progn ,@(mapcar #'(lambda (k)
  48                         `(defun ,k (func-spec)
  49                            (first
  50                             (getf (rest func-spec)
  51                                   ,(intern (symbol-name k) '#:keyword)))))
  52                     names)))
  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))
  64
  65
  66 (defparameter *base* (merge-pathnames #P"../" *load-pathname*))
  67
  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|
  74                           |state-req| |xform|))
  75        (function-categories)
  76        (predefined-enumerants)
  77        (exports))
  78   (declare (optimize (debug 3)))
  79   (remf enum-specs :extensions)
  80
  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))
  85
  86
  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)))
  94
  95   ;; resolve any missing enums in the enumerations
  96   (labels ((resolve-enum (value enum-name)
  97              (cond ((listp value)
  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)
 101                                                       (symbolp cur-val))))
 102                           cur-val)
 103                       ;;(format t "cur-val ~a doesn't satisfy~%" cur-val)
 104                       (remf all-enums enum-name)))
 105                    ((symbolp value)
 106                     (resolve-enum nil value))
 107                    (t 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)))))))
 113
 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))))
 118
 119   ;; collect arguments of functions into ordered list with all meta-data attached
 120   (dolist (func-spec function-specs)
 121     (let ((arg-specs))
 122       (do* ((arg-spec (getf (rest func-spec) :param) (getf (rest func-spec) :param)))
 123            ((not arg-spec))
 124         (setf (getf arg-specs (getf arg-spec :name))
 125               arg-spec)
 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)))))
 130
 131   ;; categorize functions
 132   (dolist (function-spec function-specs)
 133     (push function-spec
 134           (getf function-categories (intern (category function-spec)))))
 135
 136   (defun gl-extension-function-definition (func-spec)
 137     (push (lisp-name func-spec) exports)
 138     `(defglextfun ,func-spec))
 139
 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)
 145       (let ((enumerations
 146              (apply #'append
 147                     (loop while (getf enum-specs category-name) collecting
 148                          (prog1
 149                              (mapcar #'(lambda (enum-name)
 150                                          (gl-enumeration-definition category-name enum-name))
 151                                      (remove-if
 152                                       #'(lambda (enum-name)
 153                                           (find enum-name predefined-enumerants))
 154                                       (plist-keys (getf enum-specs category-name))))
 155                            (remf enum-specs category-name)))))
 156             (functions
 157              (apply #'append
 158                     (loop while (getf function-categories category-name) collecting
 159                          (prog1
 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))))))
 168
 169   (defun gl-function-definition (func-spec)
 170     (push (lisp-name func-spec) exports)
 171     `(defglfun ,func-spec))
 172
 173   (defun gl-enumeration-definition (enumeration-group-name enumeration-name)
 174     (let ((constant-name
 175            (intern (string-upcase
 176                     (format nil "+~a+"
 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)
 182                 enumeration-name))))
 183
 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))))
 188
 189
 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)
 192
 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))
 198
 199
 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)))
 213
 214       ;; generate the functions for all of the 1.0 functions
 215       (dolist (category-name base-categories)
 216         (output-category category-name)))
 217
 218     (output-extension '|1_1| #'gl-function-definition 'VERSION_1_1)
 219
 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)
 226
 227     (dolist (category-name (remove-duplicates
 228                             (union (plist-keys function-categories)
 229                                    (plist-keys enum-specs))))
 230       (output-extension category-name))
 231
 232     (with-open-file (out (merge-pathnames #P"src/opengl-type-maps.lisp" *base*) :direction :output :if-exists :supersede)
 233       (print type-maps out))
 234
 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))