generators/make-bindings-from-spec.lisp

   1 ;; You should nominially invoke this file via ./generators/make-opengl-bindings.rb
   2 ;; as that performs the necessary setup.
   3
   4 (declaim (optimize (debug 3)))
   5 ;;; {{{ PARAMETERS
   6
   7 (defparameter *reports* '(:type-map nil
   8                           :property-counts nil
   9                           :leftover-functions t
  10                           :leftover-enums t
  11                           :files-output nil
  12                           :function-category-counts nil))
  13
  14
  15 (defparameter *opengl-version-systems* '("cl-glfw-opengl-version_1_1"
  16                                          "cl-glfw-opengl-version_1_2"
  17                                          "cl-glfw-opengl-version_1_3"
  18                                          "cl-glfw-opengl-version_1_4"
  19                                          "cl-glfw-opengl-version_1_5"
  20                                          "cl-glfw-opengl-version_2_0"
  21                                          "cl-glfw-opengl-version_2_1")
  22   "List of versioned extensions for dependency generation.
  23 Must be in the correct order.")
  24
  25
  26 (defparameter *base* (merge-pathnames #P"../" (load-time-value *load-truename*)))
  27 (defparameter *spec* nil)
  28 (defparameter *type-map* nil)
  29
  30 (defparameter *enum-specs* nil)
  31 (defparameter *function-specs* nil)
  32
  33 (defparameter *base-categories*
  34   '(|display-list| |drawing| |drawing-control| |feedback|
  35     |framebuf| |misc| |modeling| |pixel-op| |pixel-rw|
  36     |state-req| |xform|))
  37
  38 (defparameter *exports* nil)
  39
  40 (defparameter *function-categories* nil)
  41
  42 (defparameter *predefined-enumerants* nil)
  43 ;;; }}}
  44
  45
  46 ;;; {{{ UTILITY
  47 (defun plist-keys (plist)
  48   "Return all of the keys of a plist"
  49   (loop for key in plist by #'cddr collect key))
  50
  51 (defun plist-values (plist)
  52   "Return all of the values of a plist"
  53   (loop for key in (cdr plist) by #'cddr collect key))
  54
  55 (defun constantize (symbol)
  56   "Converts a symbol into a nice constant-style symbol,
  57 changing non-alphanumeric characters to - and surrounding it
  58 with +s."
  59   (intern (format nil "+~a+"
  60                   (map 'string #'(lambda (c) (if (alphanumericp c) c #\-))
  61                        (string-upcase (string symbol))))))
  62
  63 (defun deconstant (symbol)
  64   "Sometimes argument names of OpenGL™ functions have silly names like
  65 't', this is a generalised way to rename them to something more sensible."
  66   (if (not (constantp symbol))
  67       symbol
  68       (deconstant (intern (concatenate 'string "_" (symbol-name symbol))))))
  69
  70 ;;}}}
  71
  72 ;;; {{{ FUNC-SPEC
  73 (defmacro func-spec-accessors (names)
  74   "Makes a bunch of nice “name-of” accessors for a func-spec plist
  75 to all symbols listed in names.  "
  76   `(progn ,@(mapcar #'(lambda (k)
  77                         `(defun ,(intern (concatenate 'string (string k) "-OF")) (func-spec)
  78                            (first
  79                             (getf (rest func-spec)
  80                                   ,(intern (symbol-name k) '#:keyword)))))
  81                     names)))
  82
  83 (defun c-name-of (func-spec)
  84   (first (first func-spec)))
  85
  86 (defun lisp-name-of (func-spec)
  87   (second (first func-spec)))
  88
  89 (func-spec-accessors (offset wglflags glsopcode glxsingle version category dlflags param
  90                              glxropcode glxflags glsflags vectorequiv extension glxvendorpriv glsalias
  91                              alias glfflags glxvectorequiv beginend))
  92
  93 (defun freturn-of (func-spec)
  94   "Returns the return type of the func-spec"
  95   (first (getf (rest func-spec) :return)))
  96
  97 (defun args-of (func-spec)
  98   "Returns the list of argument plists of the func-spec"
  99   (getf (rest func-spec) :args))
 100 ;;; }}}
 101
 102 ;;; {{{ FIX TYPE-MAPS
 103 (defparameter *strippable-type-endings*
 104   (list "NV" "ARB" "SGIX" "EXT" "ATI" "IBM" "3DFX" "SGIS"
 105         "SUNX" "HP" "GREMEDY" "APPLE" "MESA" "SUN" "INTEL"
 106         "WIN"))
 107
 108 (defun string-ends-with (string ending)
 109   "Returns t if string ends with ending."
 110   (and (>= (length string) (length ending))
 111        (string= string ending :start1 (- (length string) (length ending)))))
 112
 113 (defun string-strip-ending (string ending)
 114   "Returns string (with ending removed, if it was there)."
 115   (if (string-ends-with string ending)
 116       (subseq string 0 (- (length string) (length ending)))
 117       string))
 118
 119 (defun string-strip-endings (string endings)
 120   "Removes any of multiple endings from string, if it has any of them."
 121   (if (cdr endings)
 122       (string-strip-endings (string-strip-ending string (car endings)) (cdr endings))
 123       (string-strip-ending string (first endings))))
 124
 125 (defun type-map-type-to-gl-type (type-map-type)
 126   "Strips the extension suffix off a type and returns an appropriate type symbol
 127 suitable for cl-glfw-types or CFFI."
 128   (let ((s (string-strip-endings (symbol-name type-map-type) *strippable-type-endings*)))
 129     (cond ((equal s "*") :void)
 130           ((find #\* (format nil "~a" s)) :pointer)
 131           ((equal (subseq s 0 2) "GL") (intern (string-upcase (subseq s 2))))
 132           ((equal s "_GLfuncptr") :pointer)
 133           (t s))))
 134
 135 (defun set-type-maps ()
 136   "Fix mappings of specification type names onto valid cl-glfw-types/CFFI symbols."
 137   (setf
 138    *type-map*
 139    (loop for src-type in (getf *spec* :type-map) by #'cddr
 140       for dst-type in (cdr (getf *spec* :type-map)) by #'cddr
 141       nconc (list src-type (type-map-type-to-gl-type dst-type)))))
 142
 143 ;;; }}}
 144
 145 ;;; {{{ FIX ENUM SPECS
 146 (defun set-enum-specs ()
 147   "Extract the enum specs from *spec* and resolve all the values"
 148   (setf
 149    *enum-specs*
 150    (labels ((resolve-enum (enum-name enum-value &optional used-groups)
 151               (cond
 152                 ;; the only end-value type (there are no strings or anything)
 153                 ((numberp enum-value) enum-value)
 154                 ;; nil value means we have to look everywhere for a value
 155                 ((null enum-value)
 156                  (resolve-enum
 157                   enum-name
 158                   (block find-value
 159                     (loop for enum-group-name in (getf *spec* :enum-spec) by #'cddr
 160                        for enum-group in (cdr (getf *spec* :enum-spec)) by #'cddr
 161                        do (unless (find enum-group-name used-groups)
 162                             (let ((resolved-value (getf enum-group enum-name)))
 163                               (when resolved-value
 164                                 (push enum-group-name used-groups)
 165                                 (return-from find-value resolved-value)))))
 166                     (return-from resolve-enum :unable-to-resolve))
 167                   used-groups))
 168                 ;; it's a name of another symbol, re-resolve with that name
 169                 ((symbolp enum-value) (resolve-enum enum-value nil))
 170                 ;; a use list means we look in another group for it
 171                 ((and (listp enum-value)
 172                       (eql (first enum-value) :use))
 173                  (resolve-enum
 174                   enum-name
 175                   (getf (getf (getf *spec* :enum-spec) (second enum-value))
 176                         enum-name)
 177                   used-groups))
 178                 (t (error "I don't know what to do with the enum definition ~s -> ~s" enum-name enum-value)))))
 179      (loop for enum-group-name in (getf *spec* :enum-spec) by #'cddr
 180         for enum-group in (cdr (getf *spec* :enum-spec)) by #'cddr
 181         unless (eql enum-group-name :extensions)
 182         when enum-group
 183         nconcing
 184         (list enum-group-name
 185               (loop for enum-name in enum-group by #'cddr
 186                  for enum-value in (cdr enum-group) by #'cddr
 187                  nconcing
 188                  (list enum-name
 189                        (resolve-enum enum-name enum-value (list enum-group-name)))))))))
 190 ;;; }}}
 191
 192 ;;; {{{ LOAD
 193 (defun load-spec ()
 194   (setf *spec* (with-open-file (in (merge-pathnames #P"src/gl.spec.lisp" *base*)) (read in))
 195         *function-specs* (rest (getf *spec* :functions)))
 196   (set-type-maps)
 197   (when (getf *reports* :type-map)
 198     (loop for n-v in
 199          (sort (loop for name in *type-map* by #'cddr
 200                   for value in (cdr *type-map*) by #'cddr
 201                   collect (cons name value))
 202                #'(lambda (a b)
 203                    (string-lessp (string (cdr a)) (string (cdr b)))))
 204          do (format t "~&  ~s:~40t~s~%" (car n-v) (cdr n-v))))
 205
 206   (set-enum-specs)
 207   (remf *enum-specs* :extensions)
 208   ;; print out initial statistics
 209   (format t "~a functions~%" (length *function-specs*))
 210   (format t "~a type-maps~%" (/ (length *type-map*) 2))
 211   (format t "~a enum-specs~%" (length *enum-specs*))
 212
 213
 214   (when (getf *reports* :property-counts)
 215     ;; count up the properties of functions, what's useful for parsing?
 216     (let ((property-counts ()))
 217       (dolist (function-spec *function-specs*)
 218         (dolist (property (plist-keys (rest function-spec)))
 219           (incf (getf property-counts property 0))))
 220       (let ((*print-pretty* t))
 221         (format t "Property counts: ~a~%"  property-counts))))
 222
 223   ;; collect arguments of functions into ordered list with all meta-data attached
 224   (dolist (func-spec *function-specs*)
 225     (let ((arg-specs))
 226       (do* ((arg-spec (getf (rest func-spec) :param) (getf (rest func-spec) :param)))
 227            ((not arg-spec))
 228         (setf (getf arg-specs (getf arg-spec :name))
 229               arg-spec)
 230         (remf (rest func-spec) :param))
 231       (setf (getf (rest func-spec) :args)
 232             (loop for arg-name in (args-of func-spec) collecting
 233                  (getf arg-specs arg-name)))))
 234
 235   ;; categorize functions
 236   (dolist (function-spec *function-specs*)
 237     (push function-spec
 238           (getf *function-categories* (intern (category-of function-spec)))))
 239   (when (getf *reports* :function-category-counts)
 240     (format t "Category counts:~%")
 241     (loop for cat-name in *function-categories* by #'cddr
 242          for cat-contents in (cdr *function-categories*) by #'cddr
 243          do (format t "  ~S: ~S~%" cat-name (length cat-contents)))))
 244 ;;; }}}
 245
 246
 247 (defun gl-extension-function-definition (func-spec)
 248   (push (lisp-name-of func-spec) *exports*)
 249   `(defglextfun ,func-spec))
 250
 251 (defun gl-function-definition (func-spec)
 252   (push (lisp-name-of func-spec) *exports*)
 253   `(defglfun ,func-spec))
 254
 255
 256 ;;; {{{ EMIT OUTPUT
 257
 258
 259 ;; this is the real template opengl defpackage
 260 (defun make-opengl-defpackage (exports)
 261   "Returns the defpackage for opengl with the exports list given."
 262   `(defpackage #:cl-glfw-opengl
 263      (:use #:cffi #:cl #:cl-glfw-types #:cl-glfw-scaffolding)
 264      (:nicknames #:gl #:opengl)
 265      (:shadowing-import-from #:cl-glfw-types #:boolean #:byte #:float #:char #:string)
 266      (:export
 267       #:enum #:boolean #:bitfield #:byte #:short #:int #:sizei #:ubyte #:ushort #:uint
 268       #:float #:clampf #:double #:clampd #:void #:uint64 #:int64
 269       #:intptr #:sizeiptr
 270       #:handle
 271       #:char #:string
 272       #:half
 273       ,@(mapcar #'make-symbol (mapcar #'string-upcase (mapcar #'string exports))))))
 274
 275
 276 (defmacro with-output-file ((out name) &body forms)
 277   (declare (type symbol out))
 278   `(with-open-file (,out (merge-pathnames ,name *base*) :direction :output :if-exists :supersede)
 279      (if (getf *reports* :files-output)
 280          (format t "Generating ~s~%" (truename ,out))
 281          (progn (write-char #\.)
 282                 (force-output)))
 283      (format ,out ";;;; This file was automatically generated by ~a~%" (load-time-value *load-truename*))
 284      ,@forms
 285      (fresh-line ,out)))
 286
 287
 288
 289 (defun output-extension (category-name &optional (function-transform #'gl-extension-function-definition) (extension-name category-name))
 290   "write out the extension named by category name"
 291
 292   ;; collect up the elements of the extension, the enums and functions
 293   (let ((enumerations
 294          (loop while (getf *enum-specs* category-name) nconcing
 295               (prog1 (loop for enum-name in (getf *enum-specs* category-name) by #'cddr
 296                         for enum-value in (cdr (getf *enum-specs* category-name)) by #'cddr
 297                         unless (find enum-name *predefined-enumerants*)
 298                         collecting
 299                         (let ((constant-name (constantize enum-name)))
 300                           (push constant-name *exports*)
 301                           `(defconstant ,constant-name ,enum-value)))
 302                 (remf *enum-specs* category-name))))
 303         (functions
 304          (loop while (getf *function-categories* category-name) nconcing
 305               (prog1
 306                   (mapcar function-transform (getf *function-categories* category-name))
 307                 (remf *function-categories* category-name)))))
 308     ;; only when we have either of these components, actually generate a system
 309     (when (or enumerations functions)
 310       ;; write out the ASD definition
 311       (with-output-file (out (format nil "lib/cl-glfw-opengl-~a.asd" extension-name))
 312         (let* ((system-name (string-downcase (format nil "cl-glfw-opengl-~a" extension-name)))
 313                (system-package (make-symbol (string-upcase (concatenate 'string system-name "-system")))))
 314           (print `(defpackage ,system-package (:use #:asdf #:cl)) out)
 315           (print `(in-package ,system-package) out)
 316           (print `(defsystem ,(intern (string-upcase system-name))
 317                     :description ,(format nil "cl-glfw's ~a binding" extension-name)
 318                     :author ,(format nil "Generated by cl-glfw's ~a" (load-time-value *load-truename*))
 319                     :licence "Public Domain"
 320                     :depends-on (cl-glfw-opengl
 321                                  ,@(let ((pos (position system-name *opengl-version-systems* :test 'equal)))
 322                                         (when (and pos (plusp pos))
 323                                           (list (intern (elt *opengl-version-systems* (1- pos)))))))
 324                     :components ((:file ,(concatenate 'string "opengl-"
 325                                                       (string-downcase (symbol-name extension-name))))))
 326                  out)))
 327
 328       ;; write the enumerations and function bindings
 329       (with-output-file (out (format nil "lib/opengl-~a.lisp" extension-name))
 330         (print '(in-package #:cl-glfw-opengl) out)
 331         (format out "~&~%;;;; ~a~&" category-name)
 332         (dolist (enumeration enumerations) (print enumeration out))
 333         (dolist (function functions) (print function out))))))
 334
 335
 336 (defun output-category (category-name out)
 337   "Output a whole category and remove it from the list."
 338   (dolist (func-spec (getf *function-categories* category-name))
 339     (print (gl-function-definition func-spec) out))
 340   (remf *function-categories* category-name))
 341
 342 (defun output-core ()
 343   ;; write the main bindings file...
 344   (with-output-file (out #P"lib/opengl.lisp")
 345
 346     (print `(in-package #:cl-glfw-opengl) out)
 347
 348     ;; dump all enumerations not in an extension
 349     (loop for enum-group-name in *enum-specs* by #'cddr
 350        for enum-group in (cdr *enum-specs*) by #'cddr
 351        unless (getf *function-categories* enum-group-name)
 352        do
 353        ;; when this group is not empty and there is a name that isn't already defined
 354        (when (and enum-group
 355                   (loop for enum-name in enum-group by #'cddr
 356                        when (not (find enum-name *predefined-enumerants*))
 357                        return t))
 358          (format out "~&~%;;;; {{{ ~a~%" enum-group-name)
 359          (loop for enum-name in enum-group by #'cddr
 360             for enum-value in (cdr enum-group) by #'cddr
 361             unless (find enum-name *predefined-enumerants*)
 362             do
 363             (push enum-name *predefined-enumerants*)
 364             (let ((constant-name (constantize enum-name)))
 365               (push constant-name *exports*)
 366               (print `(defconstant ,constant-name ,enum-value) out)))
 367          (format out "~&~%;;;; }}}~%"))
 368        (remf *enum-specs* enum-group))
 369
 370     ;; all base 1.0 categories
 371     (loop for category-name in *base-categories*
 372        do
 373        (format out "~&~%;;;; {{{ ~a~%" category-name)
 374        (output-category category-name out)
 375        (format out "~&~%;;;; }}}~%"))))
 376
 377
 378 (defun output-everything ()
 379   ;; some nice printing options
 380   (let ((*print-case* :downcase)
 381         (*print-radix* t)
 382         (*print-base* 16))
 383
 384     (output-core)
 385
 386     (output-extension '|1_1| #'gl-function-definition 'VERSION_1_1)
 387
 388     (output-extension 'VERSION_1_2 #'gl-function-definition)
 389     (output-extension 'VERSION_1_3 #'gl-function-definition)
 390     (output-extension 'VERSION_1_4 #'gl-function-definition)
 391     (output-extension 'VERSION_1_5 #'gl-function-definition)
 392     (output-extension 'VERSION_2_0 #'gl-function-definition)
 393     (output-extension 'VERSION_2_1 #'gl-function-definition)
 394
 395     (dolist (category-name (remove-duplicates
 396                             (nconc (plist-keys *function-categories*)
 397                                    (plist-keys *enum-specs*))))
 398       (output-extension category-name))
 399
 400     (with-output-file (out #P"lib/opengl-type-map.lisp")
 401       (print `(in-package #:cl-glfw-opengl) out)
 402       (print `(setf *type-map* ',*type-map*) out))
 403
 404     (with-output-file (out #P"lib/opengl-package.lisp")
 405       (print (make-opengl-defpackage (remove-duplicates (nreverse *exports*))) out)))
 406
 407   (when (and (getf *reports* :leftover-functions)
 408              *function-categories*)
 409     (format t "~&Leftover functions:~%  ~s~%" *function-categories*))
 410
 411   (when (and (getf *reports* :leftover-enums)
 412              *enum-specs*)
 413     (format t "~&Leftover enums:~%  ~s~%" *enum-specs*)))
 414
 415 ;;; }}}
 416
 417 (defun main ()
 418   (load-spec)
 419   (output-everything)
 420   (fresh-line))