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