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