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 (speed 0) (space 0) (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 (defun make-version-syms (&rest versions)
  15   (loop for version in versions
  16      collecting (intern (concatenate 'string "VERSION_" version))))
  17
  18 (defparameter *core-opengl-versions*
  19   (make-version-syms "1_0" "1_1"))
  20
  21 (defparameter *opengl-versions*
  22   (make-version-syms "1_0" "1_1" "1_2" "1_3" "1_4" "1_5"
  23                      "2_0" "2_1"
  24                      "3_0" "3_1" "3_2" "3_3"
  25                      "4_0" "4_1")
  26   "List of versioned extensions for dependency generation.
  27 Must be in the correct order.")
  28
  29 (defparameter *source-filename* (or #.*compile-file-truename*
  30                                     (load-time-value *load-truename*)))
  31
  32 (defparameter *extension-names* nil)
  33
  34 (defparameter *base* (merge-pathnames #P"../" *source-filename*))
  35 (defparameter *spec* nil)
  36 (defparameter *type-map* nil)
  37
  38 (defparameter *enum-specs* nil)
  39 (defparameter *function-specs* nil)
  40
  41 (defparameter *exports* (list '#:check-linked-program-arb '#:with-push-attrib '#:with-new-list
  42                               '#:check-linked-program '#:fallback-synchronizing-program
  43                               '#:check-compiled-shader '#:*fallback-synchronizing-program-arb*
  44                               '#:*fallback-synchronizing-program* '#:with-begin-query
  45                               '#:shader-source-from-stream-arb '#:with-setup-projection
  46                               '#:with-bind-buffer '#:with-use-program-arb '#:with-push-client-attrib
  47                               '#:fallback-synchronizing-program-arb '#:shader-source-from-stream
  48                               '#:with-use-program '#:synchronizing-program-arb '#:with-begin
  49                               '#:with-push-matrix '#:make-program '#:make-program-arb '#:make-shader
  50                               '#:synchronizing-shader-arb '#:with-projection-matrix
  51                               '#:clear-synchronizing-shaders '#:make-shader-arb
  52                               '#:check-compiled-shader-arb '#:with-map-buffer-arb
  53                               '#:with-bind-buffer-arb '#:with-push-name '#:with-map-buffer
  54                               '#:synchronizing-shader '#:synchronizing-program))
  55
  56 (defparameter *function-categories* nil)
  57
  58 (defparameter *predefined-enumerants* (make-hash-table))
  59 ;;; }}}
  60
  61
  62 ;;; {{{ UTILITY
  63 (defun plist-keys (plist)
  64   "Return all of the keys of a plist"
  65   (loop for key in plist by #'cddr collect key))
  66
  67 (defun plist-values (plist)
  68   "Return all of the values of a plist"
  69   (loop for key in (cdr plist) by #'cddr collect key))
  70
  71 (defun constantize (symbol)
  72   "Converts a symbol into a nice constant-style symbol,
  73 changing non-alphanumeric characters to - and surrounding it
  74 with +s."
  75   (intern (format nil "+~a+"
  76                   (map 'string #'(lambda (c) (if (alphanumericp c) c #\-))
  77                        (string-upcase (string symbol))))))
  78
  79 (defun deconstant (symbol)
  80   "Sometimes argument names of OpenGL™ functions have silly names like
  81 't', this is a generalised way to rename them to something more sensible."
  82   (if (not (constantp symbol))
  83       symbol
  84       (deconstant (intern (concatenate 'string "_" (symbol-name symbol))))))
  85
  86 ;;}}}
  87
  88 ;;; {{{ FUNC-SPEC
  89 (defun c-name-of (func-spec) (first func-spec))
  90 (defun lisp-name-of (func-spec) (second func-spec))
  91 (defun freturn-of (func-spec) (getf (cddr func-spec) :return))
  92 (defun args-of (func-spec) (getf (cddr func-spec) :args))
  93 (defun category-of (func-spec) (intern (getf (cddr func-spec) :category)))
  94 ;;; }}}
  95
  96 ;;; {{{ FIX TYPE-MAPS
  97 (defparameter *strippable-type-endings*
  98   (list "NV" "ARB" "SGIX" "EXT" "ATI" "IBM" "3DFX" "SGIS"
  99         "SUNX" "HP" "GREMEDY" "APPLE" "MESA" "SUN" "INTEL"
 100         "WIN"))
 101
 102 (defun string-ends-with (string ending)
 103   "Returns t if string ends with ending."
 104   (and (>= (length string) (length ending))
 105        (string= string ending :start1 (- (length string) (length ending)))))
 106
 107 (defun string-strip-ending (string ending)
 108   "Returns string (with ending removed, if it was there)."
 109   (if (string-ends-with string ending)
 110       (subseq string 0 (- (length string) (length ending)))
 111       string))
 112
 113 (defun string-strip-endings (string endings)
 114   "Removes any of multiple endings from string, if it has any of them."
 115   (if (cdr endings)
 116       (string-strip-endings (string-strip-ending string (car endings)) (cdr endings))
 117       (string-strip-ending string (first endings))))
 118
 119 (defun type-map-type-to-gl-type (type-map-type)
 120   "Strips the extension suffix off a type and returns an appropriate type symbol
 121 suitable for cl-glfw-types or CFFI."
 122   (let ((s (string-strip-endings (symbol-name type-map-type) *strippable-type-endings*)))
 123     (cond ((equal s "*") :void)
 124           ((equal s "const GLubyte *") 'string)
 125           ((find #\* (format nil "~a" s)) 'pointer)
 126           ((equal (subseq s 0 2) "GL") (intern (string-upcase (subseq s 2))))
 127           ((equal s "_GLfuncptr") 'pointer)
 128           (t s))))
 129
 130 (defun set-type-maps ()
 131   "Fix mappings of specification type names onto valid cl-glfw-types/CFFI symbols."
 132   (setf
 133    *type-map*
 134    (loop for src-type in (getf *spec* :type-map) by #'cddr
 135       for dst-type in (cdr (getf *spec* :type-map)) by #'cddr
 136       nconc (list src-type (type-map-type-to-gl-type dst-type)))))
 137
 138 ;;; }}}
 139
 140 ;;; {{{ FIX ENUM SPECS
 141 (defun set-enum-specs ()
 142   "Extract the enum specs from *spec* and resolve all the values"
 143   (setf
 144    *enum-specs*
 145    (labels ((resolve-enum (enum-name enum-value &optional used-groups)
 146               (cond
 147                 ;; the only end-value type (there are no strings or anything)
 148                 ((numberp enum-value) enum-value)
 149                 ;; nil value means we have to look everywhere for a value
 150                 ((null enum-value)
 151                  (resolve-enum
 152                   enum-name
 153                   (block find-value
 154                     (loop for enum-group-name in (getf *spec* :enum-spec) by #'cddr
 155                        for enum-group in (cdr (getf *spec* :enum-spec)) by #'cddr
 156                        do (unless (find enum-group-name used-groups)
 157                             (let ((resolved-value (getf enum-group enum-name)))
 158                               (when resolved-value
 159                                 (push enum-group-name used-groups)
 160                                 (return-from find-value resolved-value)))))
 161                     (return-from resolve-enum :unable-to-resolve))
 162                   used-groups))
 163                 ;; it's a name of another symbol, re-resolve with that name
 164                 ((symbolp enum-value) (resolve-enum enum-value nil))
 165                 ;; a use list means we look in another group for it
 166                 ((and (listp enum-value)
 167                       (eql (first enum-value) :use))
 168                  (resolve-enum
 169                   enum-name
 170                   (getf (getf (getf *spec* :enum-spec) (second enum-value))
 171                         enum-name)
 172                   used-groups))
 173                 (t (error "I don't know what to do with the enum definition ~s -> ~s" enum-name enum-value)))))
 174      (loop for enum-group-name in (getf *spec* :enum-spec) by #'cddr
 175         for enum-group in (cdr (getf *spec* :enum-spec)) by #'cddr
 176         unless (eql enum-group-name :extensions)
 177         when enum-group
 178         nconcing
 179         (list enum-group-name
 180               (loop for enum-name in enum-group by #'cddr
 181                  for enum-value in (cdr enum-group) by #'cddr
 182                  nconcing
 183                  (list enum-name
 184                        (resolve-enum enum-name enum-value (list enum-group-name)))))))))
 185 ;;; }}}
 186
 187 ;;; {{{ SET FUNC SPECS
 188 (defun set-func-specs ()
 189   (setf *function-specs*
 190         (loop for func-spec in (getf *spec* :functions)
 191              when func-spec
 192            collect
 193              (list (first (first func-spec))
 194                    (second (first func-spec))
 195                    :return (first (getf (rest func-spec) :return))
 196                    :args (loop while (getf (rest func-spec) :param) collect
 197                               (prog1 (getf (rest func-spec) :param)
 198                                 (remf (rest func-spec) :param)))
 199                    :category (string-strip-ending (first (getf (rest func-spec) :category)) "_DEPRECATED")
 200                    :deprecated (first (getf (rest func-spec) :deprecated))
 201                    :version (first (getf (rest func-spec) :version))))))
 202 ;;; }}}
 203
 204 ;;; {{{ LOAD
 205 (defun load-spec ()
 206   (setf *spec* (with-open-file (in (merge-pathnames #P"src/gl.spec.lisp" *base*)) (read in)))
 207   (set-type-maps)
 208   (set-func-specs)
 209   (when (getf *reports* :type-map)
 210     (loop for n-v in
 211          (sort (loop for name in *type-map* by #'cddr
 212                   for value in (cdr *type-map*) by #'cddr
 213                   collect (cons name value))
 214                #'(lambda (a b)
 215                    (string-lessp (string (cdr a)) (string (cdr b)))))
 216          do (format t "~&  ~s:~40t~s~%" (car n-v) (cdr n-v))))
 217
 218   (set-enum-specs)
 219
 220   (remf *enum-specs* :extensions)
 221
 222   ;; print out initial statistics
 223   (format t "~a functions~%" (length *function-specs*))
 224   (format t "~a type-maps~%" (/ (length *type-map*) 2))
 225   (format t "~a enum-specs~%" (length *enum-specs*))
 226
 227
 228   (when (getf *reports* :property-counts)
 229     ;; count up the properties of functions, what's useful for parsing?
 230     (let ((property-counts ()))
 231       (dolist (function-spec *function-specs*)
 232         (dolist (property (plist-keys (rest function-spec)))
 233           (incf (getf property-counts property 0))))
 234       (let ((*print-pretty* t))
 235         (format t "Property counts: ~a~%"  property-counts))))
 236
 237   ;; categorize functions
 238   (dolist (function-spec *function-specs*)
 239     (push function-spec
 240           (getf *function-categories* (category-of function-spec))))
 241
 242   ;;Work out which categories are actually extensions we want
 243   (dolist (category-sym (nconc (plist-keys *function-categories*)
 244                                 (plist-keys *enum-specs*)))
 245     (let* ((category-string (string category-sym))
 246            (underscore-pos (position #\_ category-string)))
 247       (when (and (integerp underscore-pos)
 248                  (plusp underscore-pos)
 249                  (every (lambda (char)
 250                           (or (upper-case-p char)
 251                               (digit-char-p char)))
 252                         (subseq category-string 0 underscore-pos))
 253                  (not (find category-sym *extension-names*)))
 254         (push category-sym *extension-names*))))
 255
 256   (when (getf *reports* :function-category-counts)
 257     (format t "Category function counts:~%")
 258     (loop for cat-name in *function-categories* by #'cddr
 259          for cat-contents in (cdr *function-categories*) by #'cddr
 260          do (format t "  ~S: ~S~%" cat-name (length cat-contents)))))
 261 ;;; }}}
 262
 263
 264 (defun gl-extension-function-definition (func-spec)
 265   (push (lisp-name-of func-spec) *exports*)
 266   `(defglextfun ,@func-spec))
 267
 268 (defun gl-function-definition (func-spec)
 269   (push (lisp-name-of func-spec) *exports*)
 270   `(defglfun ,@func-spec))
 271
 272
 273 ;;; {{{ EMIT OUTPUT
 274
 275
 276 ;; this is the real template opengl defpackage
 277 (defun make-opengl-defpackage (exports)
 278   "Returns the defpackage for opengl with the exports list given."
 279   `(defpackage #:cl-glfw-opengl
 280      (:use #:cffi #:cl #:cl-glfw-types #:cl-glfw-scaffolding)
 281      (:nicknames #:gl #:opengl)
 282      (:shadowing-import-from #:cl-glfw-types #:boolean #:byte #:float #:char #:string #:pointer)
 283      (:export
 284       #:enum #:boolean #:bitfield #:byte #:short #:int #:sizei #:ubyte #:ushort #:uint
 285       #:float #:clampf #:double #:clampd #:void #:uint64 #:int64
 286       #:intptr #:sizeiptr
 287       #:handle
 288       #:char #:string
 289       #:half
 290       ,@(mapcar #'make-symbol (mapcar #'string-upcase (mapcar #'string exports))))))
 291
 292
 293 (defmacro with-output-file ((out name) &body forms)
 294   (declare (type symbol out))
 295   `(with-open-file (,out (merge-pathnames ,name *base*) :direction :output :if-exists :supersede)
 296      (when (getf *reports* :files-output)
 297        (format t "Generating ~s~%" (truename ,out)))
 298      (format ,out ";;;; This file was automatically generated by ~a~%" *source-filename*)
 299      ,@forms
 300      (fresh-line ,out)))
 301
 302
 303
 304
 305
 306
 307
 308 (defun output-core ()
 309   ;; write the main bindings file...
 310   (with-output-file (out #P"lib/opengl-core.lisp")
 311
 312     (print `(in-package #:cl-glfw-opengl) out)
 313
 314     ;; dump all enumerations not in an extension
 315     (loop for enum-group-name in *enum-specs* by #'cddr
 316        for enum-group in (cdr *enum-specs*) by #'cddr
 317        unless (find enum-group-name *extension-names*)
 318        do
 319          (let ((enums-to-define
 320                 (loop for enum-name in enum-group by #'cddr
 321                    for enum-value in (cdr enum-group) by #'cddr
 322                    nconcing
 323                      (let ((existing (gethash enum-name *predefined-enumerants*)))
 324                        (cond
 325                          ((not existing)
 326                           (setf (gethash enum-name *predefined-enumerants*) enum-value)
 327                           (list (cons enum-name enum-value)))
 328                          ((eql existing enum-value)
 329                           nil)
 330                          (t
 331                           (warn "Won't redefine enum ~A as ~A, because it is already ~A"
 332                                 enum-name enum-value existing)
 333                           nil))))))
 334           ;; when this group is not empty and there is a name that isn't already defined
 335           (when enums-to-define
 336             (format out "~&~%;;;; {{{ ~A~%" (string enum-group-name))
 337             (loop for (enum-name . enum-value) in enums-to-define do
 338                  (let ((constant-name (constantize enum-name)))
 339                    (push constant-name *exports*)
 340                    (print `(defconstant ,constant-name ,enum-value) out)))
 341             (format out "~&~%;;;; }}}~%"))
 342           (remf *enum-specs* enum-group-name)))))
 343
 344 (defun output-category (name category-names)
 345   "write out the extension named by category name"
 346
 347   (let ((enum-specs (copy-tree *enum-specs*))
 348         (function-categories (copy-tree *function-categories*)))
 349
 350     ;; collect up the elements of the extension, the enums and functions
 351     (let* ((enumerations
 352             (loop for category-name in category-names nconcing
 353                  (loop while (getf enum-specs category-name) nconcing
 354                       (prog1 (loop for enum-name in (getf enum-specs category-name) by #'cddr
 355                                 for enum-value in (cdr (getf enum-specs category-name)) by #'cddr
 356                                 unless (gethash enum-name *predefined-enumerants*)
 357                                 collecting
 358                                 (let ((constant-name (constantize enum-name)))
 359                                   (push constant-name *exports*)
 360                                   `(defconstant ,constant-name ,enum-value)))
 361                         (remf enum-specs category-name)))))
 362            (function-specs
 363             (loop for category-name in category-names nconcing
 364                  (loop while (getf function-categories category-name) nconcing
 365                       (prog1
 366                           (loop for function in (getf function-categories category-name)
 367                              unless (let ((deprecated-at (getf function :deprecated)))
 368                                       (and deprecated-at
 369                                            (find (intern (concatenate 'string "VERSION_" (substitute #\_ #\. deprecated-at)))
 370                                                  category-names)))
 371                              collect function)
 372                         (remf function-categories category-name)))))
 373            (extension-specs)
 374            (core-definitions)
 375            (extension-definitions))
 376
 377       ;;
 378       (loop for function-spec in function-specs do
 379            (cond
 380              ((find (category-of function-spec) *core-opengl-versions*)
 381               (push (gl-function-definition function-spec) core-definitions))
 382              (t
 383               (push function-spec extension-specs)
 384               (push (gl-extension-function-definition function-spec) extension-definitions))))
 385
 386       (setf extension-specs (nreverse extension-specs)
 387             core-definitions (nreverse core-definitions)
 388             extension-definitions (nreverse extension-definitions))
 389
 390       (format t "~A from ~A:~D functions, ~D enumerations~%"
 391               (string name) (mapcar 'string category-names)
 392               (+ (length core-definitions)
 393                  (length extension-definitions))
 394               (length enumerations))
 395
 396       ;; only when we have either of these components, actually generate a system
 397       (when (or enumerations core-definitions extension-definitions)
 398         (let* ((core-version (find name *opengl-versions*))
 399                (top-level-asd core-version))
 400           ;; write out the ASD definition
 401           (with-output-file (out (format nil "~acl-glfw-opengl-~a.asd" (if top-level-asd "" "lib/") name))
 402             (let* ((system-name (string-downcase (format nil "cl-glfw-opengl-~a" name)))
 403                    (system-package (make-symbol (string-upcase (concatenate 'string system-name "-system")))))
 404               (print `(defpackage ,system-package (:use #:asdf #:cl)) out)
 405               (print `(in-package ,system-package) out)
 406               (print `(defsystem ,(intern (string-upcase system-name))
 407                         :description ,(format nil "cl-glfw's ~a binding" name)
 408                         :author ,(format nil "Generated by cl-glfw's ~a" *source-filename*)
 409                         :licence "Public Domain"
 410                         :depends-on (cl-glfw-opengl-core)
 411                         :components ((:file ,(concatenate 'string (if top-level-asd "lib/" "") "opengl-" (string-downcase (symbol-name name))))))
 412                      out)))
 413
 414           ;; write the enumerations and function bindings
 415           (with-output-file (out (format nil "lib/opengl-~a.lisp" name))
 416             (print '(in-package #:cl-glfw-opengl) out)
 417             (format out "~&~%;;;; ~a~&" name)
 418             (when core-version
 419               (print `(eval-when (:load-toplevel)
 420                         (when (and (boundp '*version-loaded*)
 421                                    (not (eq ',name *version-loaded*)))
 422                           (warn "Loading cl-glfw-opengl-~a over the top of already-loaded cl-glfw-opengl-~a~%" ',name *version-loaded*))
 423                         (defparameter *version-loaded* ',name)) out))
 424             (dolist (enumeration enumerations) (print enumeration out))
 425             (dolist (function core-definitions) (print function out))
 426             (dolist (function extension-definitions) (print function out))
 427             (when extension-specs
 428               (push (format nil "LOAD-~A" name) *exports*)
 429               (print `(make-extension-loader ,name ,extension-specs) out))))))))
 430
 431
 432 (defun output-everything ()
 433   ;; some nice printing options
 434   (let ((*print-case* :downcase)
 435         (*print-radix* t)
 436         (*print-base* 16))
 437
 438     (output-core)
 439
 440     ;;Write the bindings for the core versions
 441     (let (current-categories)
 442       (loop for extension-name in *opengl-versions* do
 443            (let ((deprecated-extension-name (intern (concatenate 'string (string extension-name) "_DEPRECATED")))
 444                  output)
 445              (when (find extension-name *extension-names*)
 446                (push extension-name current-categories)
 447                (setf output t))
 448              (when (find deprecated-extension-name *extension-names*)
 449                (push deprecated-extension-name current-categories)
 450                (setf output t))
 451              (when output
 452                (output-category extension-name (reverse current-categories)))))
 453       ;;Remove them from the lists to be processed
 454       (loop for name in current-categories do
 455            (loop while (getf *function-categories* name) do (remf *function-categories* name))
 456            (loop while (getf *enum-specs* name) do (remf *enum-specs* name))))
 457
 458     ;;Process all the extension categories
 459     (dolist (category-name *extension-names*)
 460       (output-category category-name (list category-name))
 461       (loop while (getf *function-categories* category-name) do (remf *function-categories* category-name))
 462       (loop while (getf *enum-specs* category-name) do (remf *enum-specs* category-name)))
 463
 464     (with-output-file (out #P"lib/opengl-type-map.lisp")
 465       (print `(in-package #:cl-glfw-opengl) out)
 466       (print `(setf *type-map* ',*type-map*) out))
 467
 468     (with-output-file (out #P"lib/opengl-package.lisp")
 469       (print (make-opengl-defpackage (remove-duplicates (nreverse *exports*))) out)))
 470
 471   (when (and (getf *reports* :leftover-functions)
 472              *function-categories*)
 473     (format t "~&Leftover functions:~%  ~s~%" *function-categories*))
 474
 475   (when (and (getf *reports* :leftover-enums)
 476              *enum-specs*)
 477     (format t "~&Leftover enums:~%  ~s~%" *enum-specs*)))
 478
 479 ;;; }}}
 480
 481 (defun main ()
 482   (load-spec)
 483   (output-everything)
 484   (fresh-line))