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 ;; proto-package for type-mappings only
   5 (defpackage #:cl-glfw-opengl
   6  (:use #:cl)
   7  (:nicknames #:gl #:opengl)
   8  (:shadow boolean byte float char string)
   9  (:export
  10   enum boolean bitfield byte short int sizei ubyte ushort uint float clampf
  11   double clampd void uint64 int64 intptr sizeiptr handle char string half))
  12
  13 ;; this is the real template opengl defpackage
  14 (defun make-opengl-defpackage (exports)
  15   "Returns the defpackage for opengl with the exports list given."
  16   `(defpackage #:cl-glfw-opengl
  17      (:use #:cffi #:cl #:cl-glfw-types #:cl-glfw-scaffolding)
  18      (:nicknames #:gl #:opengl)
  19      (:shadowing-import-from #:cl-glfw-types #:boolean #:byte #:float #:char #:string)
  20      (:export
  21       #:enum #:boolean #:bitfield #:byte #:short #:int #:sizei #:ubyte #:ushort #:uint
  22       #:float #:clampf #:double #:clampd #:void #:uint64 #:int64
  23       #:intptr #:sizeiptr
  24       #:handle
  25       #:char #:string
  26       #:half
  27       ,@(mapcar #'make-symbol (mapcar #'string-upcase (mapcar #'string exports))))))
  28
  29
  30 (defparameter *opengl-version-systems* '("cl-glfw-opengl-version_1_1"
  31                                          "cl-glfw-opengl-version_1_2"
  32                                          "cl-glfw-opengl-version_1_3"
  33                                          "cl-glfw-opengl-version_1_4"
  34                                          "cl-glfw-opengl-version_1_5"
  35                                          "cl-glfw-opengl-version_2_0"
  36                                          "cl-glfw-opengl-version_2_1")
  37   "List of versioned extensions for dependency generation.
  38 Must be in the correct order.")
  39
  40 (defun auto-generated-notice (out)
  41   "Print out the fact that a file is automatically generated to out stream."
  42   (format out ";;;; This file was automatically generated by ~a~%" *load-truename*))
  43
  44 (defun plist-keys (plist)
  45   "Return all of the keys of a plist"
  46   (loop for key in plist by #'cddr collect key))
  47
  48 (defun plist-values (plist)
  49   "Return all of the values of a plist"
  50   (loop for key in (cdr plist) by #'cddr collect key))
  51
  52 (defun constantize (symbol)
  53   "Converts a symbol into a nice constant-style symbol,
  54 changing non-alphanumeric characters to - and surrounding it
  55 with +s."
  56   (format nil "+~a+"
  57           (map 'string #'(lambda (c) (if (alphanumericp c) c #\-))
  58                (string-upcase (string symbol)))))
  59
  60 (defun deconstant (symbol)
  61   "Sometimes argument names of OpenGL™ functions have silly names like
  62 't', this is a generalised way to rename them to something more sensible."
  63   (if (not (constantp symbol))
  64       symbol
  65       (deconstant (intern (concatenate 'string "_" (symbol-name symbol))))))
  66
  67 (defmacro func-spec-accessors (names)
  68   "Makes a bunch of nice “name-of” accessors for a func-spec plist
  69 to all symbols listed in names.  "
  70   `(progn ,@(mapcar #'(lambda (k)
  71                         `(defun ,(intern (concatenate 'string (string k) "-OF")) (func-spec)
  72                            (first
  73                             (getf (rest func-spec)
  74                                   ,(intern (symbol-name k) '#:keyword)))))
  75                     names)))
  76
  77 (defun c-name-of (func-spec)
  78   (first (first func-spec)))
  79
  80 (defun lisp-name-of (func-spec)
  81   (second (first func-spec)))
  82 (func-spec-accessors (offset wglflags glsopcode glxsingle version category dlflags param
  83                        glxropcode glxflags glsflags vectorequiv extension glxvendorpriv glsalias
  84                        alias glfflags glxvectorequiv beginend))
  85
  86 (defun freturn-of (func-spec)
  87   "Returns the return type of the func-spec"
  88   (first (getf (rest func-spec) :return)))
  89
  90 (defun args-of (func-spec)
  91   "Returns the list of argument plists of the func-spec"
  92   (getf (rest func-spec) :args))
  93
  94
  95 (defparameter *base* (merge-pathnames #P"../" *load-truename*))
  96 (defparameter *spec*
  97   (with-open-file (in (merge-pathnames #P"src/gl.spec.lisp" *base*)) (read in)))
  98
  99 (defparameter *function-specs* (rest (getf *spec* :functions)))
 100
 101 (defun string-ends-with (string ending)
 102   "Returns t if string ends with ending."
 103   (and (>= (length string) (length ending))
 104        (string= string ending :start1 (- (length string) (length ending)))))
 105
 106 (defun string-strip-ending (string ending)
 107   "Returns string (with ending removed, if it was there)."
 108   (if (string-ends-with string ending)
 109       (subseq string 0 (- (length string) (length ending)))
 110       string))
 111
 112 (defun string-strip-endings (string &rest endings)
 113   "Removes any of multiple endings from string, if it has any of them."
 114   (if (= 1 (length endings))
 115       (string-strip-ending string (first endings))
 116       (apply #'string-strip-endings (cons (string-strip-ending string (first endings)) (rest endings)))))
 117
 118 (defun type-map-type-to-gl-type (type-map-type)
 119   "Strips the extension suffix off a type and returns an appropriate type symbol
 120 suitable for cl-glfw-types or CFFI."
 121   (let ((s (string-strip-endings (symbol-name type-map-type)
 122                                  "NV" "ARB" "SGIX" "EXT" "ATI" "IBM" "3DFX" "SGIS"
 123                                  "SUNX" "HP" "GREMEDY" "APPLE" "MESA" "SUN" "INTEL"
 124                                  "WIN")))
 125     (cond ((equal s "*") :void)
 126           ((find #\* (format nil "~a" s)) :pointer)
 127           ((equal (subseq s 0 2) "GL") (intern (string-upcase (subseq s 2)) (find-package '#:gl)))
 128           ((equal s "_GLfuncptr") :pointer)
 129           (t s))))
 130
 131 (defparameter *type-maps*
 132   (loop for src-type in (getf *spec* :type-map) by #'cddr
 133        for dst-type in (cdr (getf *spec* :type-map)) by #'cddr
 134        nconc (list src-type (type-map-type-to-gl-type dst-type)))
 135   "Fixed mappings of specification type names onto valid cl-glfw-types/CFFI symbols.")
 136
 137 ;; extract the enum specs from *spec* and resolve all the values
 138 (defparameter *enum-specs*
 139   (labels ((resolve-enum (enum-name enum-value &optional used-groups)
 140              (format t "resolve-enum ~s ~s~%" enum-name enum-value)
 141              (force-output)
 142              (cond
 143                ;; the only end-value type (there are no strings or anything)
 144                ((numberp enum-value) enum-value)
 145                ;; nil value means we have to look everywhere for a value
 146                ((null enum-value)
 147                 (resolve-enum
 148                  enum-name
 149                  (block find-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                      do (unless (find enum-group-name used-groups)
 153                           (let ((resolved-value (getf enum-group enum-name)))
 154                             (when resolved-value
 155                               (push enum-group-name used-groups)
 156                               (return-from find-value resolved-value)))))
 157                   (return-from resolve-enum :unable-to-resolve))
 158                  used-groups))
 159                ;; it's a name of another symbol, re-resolve with that name
 160                ((symbolp enum-value) (resolve-enum enum-value nil))
 161                ;; a use list means we look in another group for it
 162                ((and (listp enum-value)
 163                      (eql (first enum-value) :use))
 164                 (resolve-enum
 165                  enum-name
 166                  (getf (getf (getf *spec* :enum-spec) (second enum-value))
 167                        enum-name)
 168                  used-groups))
 169                (t (error "I don't know what to do with the enum definition ~s -> ~s" enum-name enum-value)))))
 170     (loop for enum-group-name in (getf *spec* :enum-spec) by #'cddr
 171        for enum-group in (cdr (getf *spec* :enum-spec)) by #'cddr
 172        unless (eql enum-group-name :extensions)
 173        nconcing
 174          (progn (format t "Resolving group ~s ~s~%" enum-group-name enum-group)
 175           (list enum-group-name
 176                 (loop for enum-name in enum-group by #'cddr
 177                    for enum-value in (cdr enum-group) by #'cddr
 178                    nconcing
 179                      (progn (format t "Resolving enum ~s ~s~%" enum-name enum-value)
 180                       (list enum-name
 181                             (resolve-enum enum-name enum-value (list enum-group-name))))))))))
 182
 183 (defparameter *base-categories*
 184   '(|display-list| |drawing| |drawing-control| |feedback|
 185     |framebuf| |misc| |modeling| |pixel-op| |pixel-rw|
 186     |state-req| |xform|))
 187
 188 (defparameter *exports* nil)
 189 (defparameter *function-categories* nil)
 190
 191 (let ((predefined-enumerants))
 192   (declare (optimize (debug 3)))
 193   (remf *enum-specs* :extensions)
 194
 195   ;; print out initial statistics
 196   (format t "~a functions~%" (length *function-specs*))
 197   (format t "~a type-maps~%" (/ (length *type-maps*) 2))
 198   (format t "~a enum-specs~%" (length *enum-specs*))
 199
 200
 201   ;; count up the properties of functions
 202   (let ((property-counts ()))
 203     (dolist (function-spec *function-specs*)
 204       (dolist (property (plist-keys (rest function-spec)))
 205         (incf (getf property-counts property 0))))
 206     (let ((*print-pretty* t))
 207       (format t "Property counts: ~a~%"  property-counts)))
 208
 209
 210   ;; collect arguments of functions into ordered list with all meta-data attached
 211   (dolist (func-spec *function-specs*)
 212     (let ((arg-specs))
 213       (do* ((arg-spec (getf (rest func-spec) :param) (getf (rest func-spec) :param)))
 214            ((not arg-spec))
 215         (setf (getf arg-specs (getf arg-spec :name))
 216               arg-spec)
 217         (remf (rest func-spec) :param))
 218       (setf (getf (rest func-spec) :args)
 219             (loop for arg-name in (args-of func-spec) collecting
 220                  (getf arg-specs arg-name)))))
 221
 222   ;; categorize functions
 223   (dolist (function-spec *function-specs*)
 224     (push function-spec
 225           (getf *function-categories* (intern (category-of function-spec)))))
 226
 227   (defun gl-extension-function-definition (func-spec)
 228     (push (lisp-name-of func-spec) *exports*)
 229     `(defglextfun ,func-spec))
 230
 231   (defun output-extension (category-name &optional (function-transform #'gl-extension-function-definition) extension-name)
 232     (unless extension-name (setf extension-name category-name))
 233     (with-open-file (out (merge-pathnames (format nil "lib/opengl-~a.lisp" extension-name) *base*)
 234                          :direction :output :if-exists :supersede)
 235       (auto-generated-notice out)
 236       (print '(in-package #:gl) out)
 237       (let ((enumerations
 238              (apply #'append
 239                     (loop while (getf *enum-specs* category-name) collecting
 240                          (prog1
 241                              (mapcar #'(lambda (enum-name)
 242                                          (gl-enumeration-definition category-name enum-name))
 243                                      (remove-if
 244                                       #'(lambda (enum-name)
 245                                           (find enum-name predefined-enumerants))
 246                                       (plist-keys (getf *enum-specs* category-name))))
 247                            (remf *enum-specs* category-name)))))
 248             (functions
 249              (apply #'append
 250                     (loop while (getf *function-categories* category-name) collecting
 251                          (prog1
 252                              (mapcar function-transform (getf *function-categories* category-name))
 253                            (remf *function-categories* category-name))))))
 254         (when (or enumerations functions)
 255           (format out "~&~%;;;; ~a~&" (symbol-name category-name))
 256           (dolist (enumeration enumerations) (print enumeration out))
 257           (dolist (function functions) (print function out)))))
 258     (with-open-file (out (merge-pathnames (format nil "lib/cl-glfw-opengl-~a.asd" extension-name) *base*)
 259                          :direction :output :if-exists :supersede)
 260       (auto-generated-notice out)
 261       (let* ((system-name (string-downcase (format nil "cl-glfw-opengl-~a" extension-name)))
 262              (system-package (make-symbol (string-upcase (concatenate 'string system-name "-system")))))
 263         (print `(defpackage ,system-package (:use #:asdf #:cl)) out)
 264         (print `(in-package ,system-package) out)
 265         (print `(defsystem ,(intern (string-upcase system-name))
 266                   :description ,(concatenate 'string "cl-glfw's " system-name " Binding")
 267                   :author ,(format nil "Generated by cl-glfw's ~a" *load-truename*)
 268                   :licence "Public Domain"
 269                   :depends-on (cl-glfw-opengl
 270                                ,@(let ((pos (position system-name *opengl-version-systems* :test 'equal)))
 271                                       (when (and pos (plusp pos))
 272                                         (list (intern (elt *opengl-version-systems* (1- pos)))))))
 273                   :components ((:file ,(concatenate 'string "opengl-"
 274                                                     (string-downcase (symbol-name extension-name))))))
 275                out))))
 276
 277   (defun gl-function-definition (func-spec)
 278     (push (lisp-name-of func-spec) *exports*)
 279     `(defglfun ,func-spec))
 280
 281   (defun gl-enumeration-definition (enumeration-group-name enumeration-name)
 282     (let ((constant-name
 283            (intern (string-upcase
 284                     (format nil "+~a+"
 285                             (map 'string #'(lambda (c) (if (alphanumericp c) c #\-))
 286                                  (symbol-name enumeration-name)))))))
 287       (push constant-name *exports*)
 288       `(defconstant ,constant-name
 289          ,(getf (getf *enum-specs* enumeration-group-name)
 290                 enumeration-name))))
 291
 292   (defun gl-enumeration-definitions (enumeration-group-name)
 293     (mapcar #'(lambda (enumeration-name)
 294                 (gl-enumeration-definition enumeration-group-name enumeration-name))
 295             (plist-keys (getf *enum-specs* enumeration-group-name))))
 296
 297
 298   (let ((*print-case* :downcase) (*print-radix* t) (*print-base* 16))
 299     (with-open-file (out (merge-pathnames #P"lib/opengl.lisp" *base*) :direction :output :if-exists :supersede)
 300       (auto-generated-notice out)
 301
 302       (defun output-category (category-name)
 303         (format out "~&~%;;;; ~a~%" category-name)
 304         (dolist (func-spec (getf *function-categories* category-name))
 305           (print (gl-function-definition func-spec) out))
 306         (remf *function-categories* category-name))
 307
 308       (print `(in-package #:cl-glfw-opengl) out)
 309
 310       (dolist (enumeration-group-name (plist-keys *enum-specs*))
 311         (when (or (not (getf *function-categories* enumeration-group-name))
 312                   (find enumeration-group-name *base-categories*))
 313           (let ((enumeration-names (plist-keys (getf *enum-specs* enumeration-group-name))))
 314             (when enumeration-names
 315               (format out "~&~%;;;; Enumerations: ~a~%" (symbol-name enumeration-group-name))
 316               (dolist (enumeration-name enumeration-names)
 317                 (if (find enumeration-name predefined-enumerants)
 318                     (format out "~&;; ~a already defined" enumeration-name)
 319                     (let ((*print-radix* t) (*print-base* 16))
 320                       (push enumeration-name predefined-enumerants)
 321                       (print (gl-enumeration-definition enumeration-group-name enumeration-name) out))))))
 322           (remf *enum-specs* enumeration-group-name)))
 323
 324       ;; generate the functions for all of the 1.0 functions
 325       (dolist (category-name *base-categories*)
 326         (output-category category-name)))
 327
 328     (output-extension '|1_1| #'gl-function-definition 'VERSION_1_1)
 329
 330     (output-extension 'VERSION_1_2 #'gl-function-definition)
 331     (output-extension 'VERSION_1_3 #'gl-function-definition)
 332     (output-extension 'VERSION_1_4 #'gl-function-definition)
 333     (output-extension 'VERSION_1_5 #'gl-function-definition)
 334     (output-extension 'VERSION_2_0 #'gl-function-definition)
 335     (output-extension 'VERSION_2_1 #'gl-function-definition)
 336
 337     (dolist (category-name (remove-duplicates
 338                             (union (plist-keys *function-categories*)
 339                                    (plist-keys *enum-specs*))))
 340       (output-extension category-name))
 341
 342     (with-open-file (out (merge-pathnames #P"lib/opengl-type-map.lisp" *base*) :direction :output :if-exists :supersede)
 343       (auto-generated-notice out)
 344       (print `(in-package #:cl-glfw-opengl) out)
 345       (print `(setf *type-map* ',*type-maps*) out))
 346
 347     (with-open-file (out (merge-pathnames #P"lib/opengl-package.lisp" *base*) :direction :output :if-exists :supersede)
 348       (auto-generated-notice out)
 349       (print (make-opengl-defpackage (remove-duplicates (nreverse *exports*))) out)))
 350   (format t "Leftovers functions: ~%~s~%Leftover enums:~s" *function-categories* *enum-specs*))