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