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
  15 (defparameter *opengl-version-systems* '("cl-glfw-opengl-version_1_1"
  16                                          "cl-glfw-opengl-version_1_2"
  17                                          "cl-glfw-opengl-version_1_3"
  18                                          "cl-glfw-opengl-version_1_4"
  19                                          "cl-glfw-opengl-version_1_5"
  20                                          "cl-glfw-opengl-version_2_0"
  21                                          "cl-glfw-opengl-version_2_1")
  22   "List of versioned extensions for dependency generation.
  23 Must be in the correct order.")
  24
  25
  26 (defparameter *base* (merge-pathnames #P"../" (load-time-value *load-truename*)))
  27 (defparameter *spec* nil)
  28 (defparameter *type-map* nil)
  29
  30 (defparameter *enum-specs* nil)
  31 (defparameter *function-specs* nil)
  32
  33 (defparameter *base-categories*
  34   '(|display-list| |drawing| |drawing-control| |feedback|
  35     |framebuf| |misc| |modeling| |pixel-op| |pixel-rw|
  36     |state-req| |xform|))
  37
  38 (defparameter *exports* nil)
  39
  40 (defparameter *function-categories* nil)
  41
  42 (defparameter *predefined-enumerants* nil)
  43 ;;; }}}
  44
  45
  46 ;;; {{{ UTILITY
  47 (defun plist-keys (plist)
  48   "Return all of the keys of a plist"
  49   (loop for key in plist by #'cddr collect key))
  50
  51 (defun plist-values (plist)
  52   "Return all of the values of a plist"
  53   (loop for key in (cdr plist) by #'cddr collect key))
  54
  55 (defun constantize (symbol)
  56   "Converts a symbol into a nice constant-style symbol,
  57 changing non-alphanumeric characters to - and surrounding it
  58 with +s."
  59   (intern (format nil "+~a+"
  60                   (map 'string #'(lambda (c) (if (alphanumericp c) c #\-))
  61                        (string-upcase (string symbol))))))
  62
  63 (defun deconstant (symbol)
  64   "Sometimes argument names of OpenGL™ functions have silly names like
  65 't', this is a generalised way to rename them to something more sensible."
  66   (if (not (constantp symbol))
  67       symbol
  68       (deconstant (intern (concatenate 'string "_" (symbol-name symbol))))))
  69
  70 ;;}}}
  71
  72 ;;; {{{ FUNC-SPEC
  73 (defun c-name-of (func-spec) (first func-spec))
  74 (defun lisp-name-of (func-spec) (second func-spec))
  75 (defun freturn-of (func-spec) (getf (cddr func-spec) :return))
  76 (defun args-of (func-spec) (getf (cddr func-spec) :args))
  77 (defun category-of (func-spec) (getf (cddr func-spec) :category))
  78 ;;; }}}
  79
  80 ;;; {{{ FIX TYPE-MAPS
  81 (defparameter *strippable-type-endings*
  82   (list "NV" "ARB" "SGIX" "EXT" "ATI" "IBM" "3DFX" "SGIS"
  83         "SUNX" "HP" "GREMEDY" "APPLE" "MESA" "SUN" "INTEL"
  84         "WIN"))
  85
  86 (defun string-ends-with (string ending)
  87   "Returns t if string ends with ending."
  88   (and (>= (length string) (length ending))
  89        (string= string ending :start1 (- (length string) (length ending)))))
  90
  91 (defun string-strip-ending (string ending)
  92   "Returns string (with ending removed, if it was there)."
  93   (if (string-ends-with string ending)
  94       (subseq string 0 (- (length string) (length ending)))
  95       string))
  96
  97 (defun string-strip-endings (string endings)
  98   "Removes any of multiple endings from string, if it has any of them."
  99   (if (cdr endings)
 100       (string-strip-endings (string-strip-ending string (car endings)) (cdr endings))
 101       (string-strip-ending string (first endings))))
 102
 103 (defun type-map-type-to-gl-type (type-map-type)
 104   "Strips the extension suffix off a type and returns an appropriate type symbol
 105 suitable for cl-glfw-types or CFFI."
 106   (let ((s (string-strip-endings (symbol-name type-map-type) *strippable-type-endings*)))
 107     (cond ((equal s "*") :void)
 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 (first (getf (rest func-spec) :category))
 183                    :version (first (getf (rest func-spec) :version))))))
 184 ;;; }}}
 185
 186 ;;; {{{ LOAD
 187 (defun load-spec ()
 188   (setf *spec* (with-open-file (in (merge-pathnames #P"src/gl.spec.lisp" *base*)) (read in)))
 189   (set-type-maps)
 190   (set-func-specs)
 191   (when (getf *reports* :type-map)
 192     (loop for n-v in
 193          (sort (loop for name in *type-map* by #'cddr
 194                   for value in (cdr *type-map*) by #'cddr
 195                   collect (cons name value))
 196                #'(lambda (a b)
 197                    (string-lessp (string (cdr a)) (string (cdr b)))))
 198          do (format t "~&  ~s:~40t~s~%" (car n-v) (cdr n-v))))
 199
 200   (set-enum-specs)
 201   (remf *enum-specs* :extensions)
 202   ;; print out initial statistics
 203   (format t "~a functions~%" (length *function-specs*))
 204   (format t "~a type-maps~%" (/ (length *type-map*) 2))
 205   (format t "~a enum-specs~%" (length *enum-specs*))
 206
 207
 208   (when (getf *reports* :property-counts)
 209     ;; count up the properties of functions, what's useful for parsing?
 210     (let ((property-counts ()))
 211       (dolist (function-spec *function-specs*)
 212         (dolist (property (plist-keys (rest function-spec)))
 213           (incf (getf property-counts property 0))))
 214       (let ((*print-pretty* t))
 215         (format t "Property counts: ~a~%"  property-counts))))
 216
 217   ;; categorize functions
 218   (dolist (function-spec *function-specs*)
 219     (push function-spec
 220           (getf *function-categories* (intern (category-of function-spec)))))
 221   (when (getf *reports* :function-category-counts)
 222     (format t "Category counts:~%")
 223     (loop for cat-name in *function-categories* by #'cddr
 224          for cat-contents in (cdr *function-categories*) by #'cddr
 225          do (format t "  ~S: ~S~%" cat-name (length cat-contents)))))
 226 ;;; }}}
 227
 228
 229 (defun gl-extension-function-definition (func-spec)
 230   (push (lisp-name-of func-spec) *exports*)
 231   `(defglextfun ,@func-spec))
 232
 233 (defun gl-function-definition (func-spec)
 234   (push (lisp-name-of func-spec) *exports*)
 235   `(defglfun ,@func-spec))
 236
 237
 238 ;;; {{{ EMIT OUTPUT
 239
 240
 241 ;; this is the real template opengl defpackage
 242 (defun make-opengl-defpackage (exports)
 243   "Returns the defpackage for opengl with the exports list given."
 244   `(defpackage #:cl-glfw-opengl
 245      (:use #:cffi #:cl #:cl-glfw-types #:cl-glfw-scaffolding)
 246      (:nicknames #:gl #:opengl)
 247      (:shadowing-import-from #:cl-glfw-types #:boolean #:byte #:float #:char #:string #:pointer)
 248      (:export
 249       #:enum #:boolean #:bitfield #:byte #:short #:int #:sizei #:ubyte #:ushort #:uint
 250       #:float #:clampf #:double #:clampd #:void #:uint64 #:int64
 251       #:intptr #:sizeiptr
 252       #:handle
 253       #:char #:string
 254       #:half
 255       ,@(mapcar #'make-symbol (mapcar #'string-upcase (mapcar #'string exports))))))
 256
 257
 258 (defmacro with-output-file ((out name) &body forms)
 259   (declare (type symbol out))
 260   `(with-open-file (,out (merge-pathnames ,name *base*) :direction :output :if-exists :supersede)
 261      (when (getf *reports* :files-output)
 262        (format t "Generating ~s~%" (truename ,out)))
 263      (format ,out ";;;; This file was automatically generated by ~a~%" (load-time-value *load-truename*))
 264      ,@forms
 265      (fresh-line ,out)))
 266
 267
 268
 269 (defun output-extension (category-name &optional (function-transform #'gl-extension-function-definition) (extension-name category-name))
 270   "write out the extension named by category name"
 271
 272   ;; collect up the elements of the extension, the enums and functions
 273   (let ((enumerations
 274          (loop while (getf *enum-specs* category-name) nconcing
 275               (prog1 (loop for enum-name in (getf *enum-specs* category-name) by #'cddr
 276                         for enum-value in (cdr (getf *enum-specs* category-name)) by #'cddr
 277                         unless (find enum-name *predefined-enumerants*)
 278                         collecting
 279                         (let ((constant-name (constantize enum-name)))
 280                           (push constant-name *exports*)
 281                           `(defconstant ,constant-name ,enum-value)))
 282                 (remf *enum-specs* category-name))))
 283         (functions
 284          (loop while (getf *function-categories* category-name) nconcing
 285               (prog1
 286                   (mapcar function-transform (getf *function-categories* category-name))
 287                 (remf *function-categories* category-name)))))
 288     ;; only when we have either of these components, actually generate a system
 289     (when (or enumerations functions)
 290       ;; write out the ASD definition
 291       (with-output-file (out (format nil "lib/cl-glfw-opengl-~a.asd" extension-name))
 292         (let* ((system-name (string-downcase (format nil "cl-glfw-opengl-~a" extension-name)))
 293                (system-package (make-symbol (string-upcase (concatenate 'string system-name "-system")))))
 294           (print `(defpackage ,system-package (:use #:asdf #:cl)) out)
 295           (print `(in-package ,system-package) out)
 296           (print `(defsystem ,(intern (string-upcase system-name))
 297                     :description ,(format nil "cl-glfw's ~a binding" extension-name)
 298                     :author ,(format nil "Generated by cl-glfw's ~a" (load-time-value *load-truename*))
 299                     :licence "Public Domain"
 300                     :depends-on (cl-glfw-opengl
 301                                  ,@(let ((pos (position system-name *opengl-version-systems* :test 'equal)))
 302                                         (when (and pos (plusp pos))
 303                                           (list (intern (elt *opengl-version-systems* (1- pos)))))))
 304                     :components ((:file ,(concatenate 'string "opengl-"
 305                                                       (string-downcase (symbol-name extension-name))))))
 306                  out)))
 307
 308       ;; write the enumerations and function bindings
 309       (with-output-file (out (format nil "lib/opengl-~a.lisp" extension-name))
 310         (print '(in-package #:cl-glfw-opengl) out)
 311         (format out "~&~%;;;; ~a~&" category-name)
 312         (dolist (enumeration enumerations) (print enumeration out))
 313         (dolist (function functions) (print function out))))))
 314
 315
 316 (defun output-category (category-name out)
 317   "Output a whole category and remove it from the list."
 318   (dolist (func-spec (getf *function-categories* category-name))
 319     (print (gl-function-definition func-spec) out))
 320   (remf *function-categories* category-name))
 321
 322 (defun output-core ()
 323   ;; write the main bindings file...
 324   (with-output-file (out #P"lib/opengl.lisp")
 325
 326     (print `(in-package #:cl-glfw-opengl) out)
 327
 328     ;; dump all enumerations not in an extension
 329     (loop for enum-group-name in *enum-specs* by #'cddr
 330        for enum-group in (cdr *enum-specs*) by #'cddr
 331        unless (getf *function-categories* enum-group-name)
 332        do
 333        ;; when this group is not empty and there is a name that isn't already defined
 334        (when (and enum-group
 335                   (loop for enum-name in enum-group by #'cddr
 336                        when (not (find enum-name *predefined-enumerants*))
 337                        return t))
 338          (format out "~&~%;;;; {{{ ~a~%" enum-group-name)
 339          (loop for enum-name in enum-group by #'cddr
 340             for enum-value in (cdr enum-group) by #'cddr
 341             unless (find enum-name *predefined-enumerants*)
 342             do
 343             (push enum-name *predefined-enumerants*)
 344             (let ((constant-name (constantize enum-name)))
 345               (push constant-name *exports*)
 346               (print `(defconstant ,constant-name ,enum-value) out)))
 347          (format out "~&~%;;;; }}}~%"))
 348        (remf *enum-specs* enum-group))
 349
 350     ;; all base 1.0 categories
 351     (loop for category-name in *base-categories*
 352        do
 353        (format out "~&~%;;;; {{{ ~a~%" category-name)
 354        (output-category category-name out)
 355        (format out "~&~%;;;; }}}~%"))))
 356
 357
 358 (defun output-everything ()
 359   ;; some nice printing options
 360   (let ((*print-case* :downcase)
 361         (*print-radix* t)
 362         (*print-base* 16))
 363
 364     (output-core)
 365
 366     (output-extension '|1_1| #'gl-function-definition 'VERSION_1_1)
 367
 368     (output-extension 'VERSION_1_2 #'gl-function-definition)
 369     (output-extension 'VERSION_1_3 #'gl-function-definition)
 370     (output-extension 'VERSION_1_4 #'gl-function-definition)
 371     (output-extension 'VERSION_1_5 #'gl-function-definition)
 372     (output-extension 'VERSION_2_0 #'gl-function-definition)
 373     (output-extension 'VERSION_2_1 #'gl-function-definition)
 374
 375     (dolist (category-name (remove-duplicates
 376                             (nconc (plist-keys *function-categories*)
 377                                    (plist-keys *enum-specs*))))
 378       (output-extension category-name))
 379
 380     (with-output-file (out #P"lib/opengl-type-map.lisp")
 381       (print `(in-package #:cl-glfw-opengl) out)
 382       (print `(setf *type-map* ',*type-map*) out))
 383
 384     (with-output-file (out #P"lib/opengl-package.lisp")
 385       (print (make-opengl-defpackage (remove-duplicates (nreverse *exports*))) out)))
 386
 387   (when (and (getf *reports* :leftover-functions)
 388              *function-categories*)
 389     (format t "~&Leftover functions:~%  ~s~%" *function-categories*))
 390
 391   (when (and (getf *reports* :leftover-enums)
 392              *enum-specs*)
 393     (format t "~&Leftover enums:~%  ~s~%" *enum-specs*)))
 394
 395 ;;; }}}
 396
 397 (defun main ()
 398   (load-spec)
 399   (output-everything)
 400   (fresh-line))