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