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