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   `(defpackage #:cl-glfw-opengl
  16      (:use #:cffi #:cl #:cl-glfw-types #:cl-glfw-scaffolding)
  17      (:nicknames #:gl #:opengl)
  18      (:shadowing-import-from #:cl-glfw-types #:boolean #:byte #:float #:char #:string)
  19      (:export
  20       #:enum #:boolean #:bitfield #:byte #:short #:int #:sizei #:ubyte #:ushort #:uint
  21       #:float #:clampf #:double #:clampd #:void #:uint64 #:int64
  22       #:intptr #:sizeiptr
  23       #:handle
  24       #:char #:string
  25       #:half
  26       ,@exports)))
  27
  28
  29 (defparameter *opengl-version-systems* '("cl-glfw-opengl-version_1_1"
  30                                          "cl-glfw-opengl-version_1_2"
  31                                          "cl-glfw-opengl-version_1_3"
  32                                          "cl-glfw-opengl-version_1_4"
  33                                          "cl-glfw-opengl-version_1_5"
  34                                          "cl-glfw-opengl-version_2_0"
  35                                          "cl-glfw-opengl-version_2_1")
  36   "List of versioned extensions for dependency generation.
  37 Must be in the correct order.")
  38
  39 (defun auto-generated-notice (out)
  40   (format out ";;;; This file was automatically generated by ~a~%" *load-truename*))
  41
  42 (defun plist-keys (plist)
  43   (do* ((it plist (cddr it))
  44         (res nil))
  45        ((not it) (nreverse res))
  46     (push (car it) res)))
  47
  48 (defun plist-values (plist)
  49   (do* ((it (cdr plist) (cddr it))
  50         (res nil))
  51        ((not it) (nreverse res))
  52     (push (car it) res)))
  53
  54 (defun string-ends-with (string ending)
  55   (and (>= (length string) (length ending))
  56        (equal (subseq string (- (length string) (length ending))) ending)))
  57 (defun string-strip-ending (string ending)
  58   (if (string-ends-with string ending)
  59       (subseq string 0 (- (length string) (length ending)))
  60       string))
  61 (defun string-strip-endings (string &rest endings)
  62   (if (= 1 (length endings))
  63       (string-strip-ending string (first endings))
  64       (apply #'string-strip-endings (cons (string-strip-ending string (first endings)) (rest endings)))))
  65
  66 (defun type-map-type-to-gl-type (type-map-type)
  67   (let ((s (string-strip-endings (symbol-name type-map-type)
  68                                  "NV" "ARB" "SGIX" "EXT" "ATI" "IBM" "3DFX" "SGIS"
  69                                  "SUNX" "HP" "GREMEDY" "APPLE" "MESA" "SUN" "INTEL"
  70                                  "WIN")))
  71     (cond ((equal s "*") :void)
  72           ((find #\* (format nil "~a" s)) :pointer)
  73           ((equal (subseq s 0 2) "GL") (intern (string-upcase (subseq s 2)) (find-package '#:gl)))
  74           ((equal s "_GLfuncptr") :pointer)
  75           (t s))))
  76
  77 (defun constantize (symbol)
  78   (format nil "+~a+"
  79           (map 'string #'(lambda (c) (if (alphanumericp c) c #\-))
  80                (symbol-name symbol))))
  81
  82 (defun deconstant (symbol)
  83   (if (not (constantp symbol))
  84       symbol
  85       (deconstant (intern (concatenate 'string "_" (symbol-name symbol))))))
  86
  87 (defmacro func-spec-accessors (names)
  88   `(progn ,@(mapcar #'(lambda (k)
  89                         `(defun ,k (func-spec)
  90                            (first
  91                             (getf (rest func-spec)
  92                                   ,(intern (symbol-name k) '#:keyword)))))
  93                     names)))
  94 (defun c-name (func-spec)
  95   (first (first func-spec)))
  96 (defun lisp-name (func-spec)
  97   (second (first func-spec)))
  98 (func-spec-accessors (offset wglflags glsopcode glxsingle version category dlflags param
  99                        glxropcode glxflags glsflags vectorequiv extension glxvendorpriv glsalias
 100                        alias glfflags glxvectorequiv beginend))
 101 (defun freturn (func-spec)
 102   (first (getf (rest func-spec) :return)))
 103 (defun args (func-spec)
 104   (getf (rest func-spec) :args))
 105
 106
 107 (defparameter *base* (merge-pathnames #P"../" *load-truename*))
 108
 109 (let* ((spec (with-open-file (in (merge-pathnames #P"src/gl.spec.lisp" *base*)) (read in)))
 110        (function-specs (rest (getf spec :functions)))
 111        (type-maps (getf spec :type-map))
 112        (enum-specs (getf spec :enum-spec))
 113        (base-categories '(|display-list| |drawing| |drawing-control| |feedback|
 114                           |framebuf| |misc| |modeling| |pixel-op| |pixel-rw|
 115                           |state-req| |xform|))
 116        (function-categories)
 117        (predefined-enumerants)
 118        (exports))
 119   (declare (optimize (debug 3)))
 120   (remf enum-specs :extensions)
 121
 122   ;; print out initial statistics
 123   (format t "~a functions~%" (length function-specs))
 124   (format t "~a type-maps~%" (/ (length type-maps) 2))
 125   (format t "~a enum-specs~%" (length enum-specs))
 126
 127
 128   ;; count up the properties of functions
 129   (let ((property-counts ()))
 130     (dolist (function-spec function-specs)
 131       (dolist (property (plist-keys (rest function-spec)))
 132         (setf (getf property-counts property) (1+ (getf property-counts property 0)))))
 133     (let ((*print-pretty* t))
 134       (format t "Property counts: ~a~%"  property-counts)))
 135
 136   ;; resolve any missing enums in the enumerations
 137   (labels ((resolve-enum (value enum-name)
 138              (cond ((listp value)
 139                     (do* ((all-enums (apply #'append (plist-values enum-specs)))
 140                           (cur-val (getf all-enums enum-name) (getf all-enums enum-name)))
 141                          ((or (null cur-val) (not (or (listp cur-val)
 142                                                       (symbolp cur-val))))
 143                           cur-val)
 144                       ;;(format t "cur-val ~a doesn't satisfy~%" cur-val)
 145                       (remf all-enums enum-name)))
 146                    ((symbolp value)
 147                     (resolve-enum nil value))
 148                    (t value))))
 149     (dolist (enum-group-name (plist-keys enum-specs))
 150       (symbol-macrolet ((enum-group (getf enum-specs enum-group-name)))
 151         (dolist (enum-name (plist-keys enum-group))
 152           (symbol-macrolet ((enum (getf enum-group enum-name)))
 153             (setf enum (resolve-enum enum enum-name)))))))
 154
 155   ;; turn type mapping destinations into actual symbols
 156   (dolist (type-map-pname (plist-keys type-maps))
 157     (setf (getf type-maps type-map-pname)
 158           (type-map-type-to-gl-type (getf type-maps type-map-pname))))
 159
 160   ;; collect arguments of functions into ordered list with all meta-data attached
 161   (dolist (func-spec function-specs)
 162     (let ((arg-specs))
 163       (do* ((arg-spec (getf (rest func-spec) :param) (getf (rest func-spec) :param)))
 164            ((not arg-spec))
 165         (setf (getf arg-specs (getf arg-spec :name))
 166               arg-spec)
 167         (remf (rest func-spec) :param))
 168       (setf (getf (rest func-spec) :args)
 169             (loop for arg-name in (args func-spec) collecting
 170                  (getf arg-specs arg-name)))))
 171
 172   ;; categorize functions
 173   (dolist (function-spec function-specs)
 174     (push function-spec
 175           (getf function-categories (intern (category function-spec)))))
 176
 177   (defun gl-extension-function-definition (func-spec)
 178     (push (lisp-name func-spec) exports)
 179     `(defglextfun ,func-spec))
 180
 181   (defun output-extension (category-name &optional (function-transform #'gl-extension-function-definition) extension-name)
 182     (unless extension-name (setf extension-name category-name))
 183     (with-open-file (out (merge-pathnames (format nil "lib/opengl-~a.lisp" extension-name) *base*)
 184                          :direction :output :if-exists :supersede)
 185       (auto-generated-notice out)
 186       (print '(in-package #:gl) out)
 187       (let ((enumerations
 188              (apply #'append
 189                     (loop while (getf enum-specs category-name) collecting
 190                          (prog1
 191                              (mapcar #'(lambda (enum-name)
 192                                          (gl-enumeration-definition category-name enum-name))
 193                                      (remove-if
 194                                       #'(lambda (enum-name)
 195                                           (find enum-name predefined-enumerants))
 196                                       (plist-keys (getf enum-specs category-name))))
 197                            (remf enum-specs category-name)))))
 198             (functions
 199              (apply #'append
 200                     (loop while (getf function-categories category-name) collecting
 201                          (prog1
 202                              (mapcar function-transform (getf function-categories category-name))
 203                            (remf function-categories category-name))))))
 204         (when (or enumerations functions)
 205           (format out "~&~%;;;; ~a~&" (symbol-name category-name))
 206           (dolist (enumeration enumerations) (print enumeration out))
 207           (dolist (function functions) (print function out)))))
 208     (with-open-file (out (merge-pathnames (format nil "lib/cl-glfw-opengl-~a.asd" extension-name) *base*)
 209                          :direction :output :if-exists :supersede)
 210       (auto-generated-notice out)
 211       (let* ((system-name (string-downcase (format nil "cl-glfw-opengl-~a" extension-name)))
 212              (system-package (make-symbol (string-upcase (concatenate 'string system-name "-system")))))
 213         (print `(defpackage ,system-package (:use #:asdf #:cl)) out)
 214         (print `(in-package ,system-package) out)
 215         (print `(defsystem ,(intern (string-upcase system-name))
 216                   :description ,(concatenate 'string "cl-glfw's " system-name " Binding")
 217                   :author ,(format nil "Generated by cl-glfw's ~a" *load-truename*)
 218                   :licence "Public Domain"
 219                   :depends-on (cl-glfw-opengl
 220                                ,@(let ((pos (position system-name *opengl-version-systems* :test 'equal)))
 221                                       (when (and pos (plusp pos))
 222                                         (list (intern (elt *opengl-version-systems* (1- pos)))))))
 223                   :components ((:file ,(concatenate 'string "opengl-"
 224                                                     (string-downcase (symbol-name extension-name))))))
 225                out))))
 226
 227   (defun gl-function-definition (func-spec)
 228     (push (lisp-name func-spec) exports)
 229     `(defglfun ,func-spec))
 230
 231   (defun gl-enumeration-definition (enumeration-group-name enumeration-name)
 232     (let ((constant-name
 233            (intern (string-upcase
 234                     (format nil "+~a+"
 235                             (map 'string #'(lambda (c) (if (alphanumericp c) c #\-))
 236                                  (symbol-name enumeration-name)))))))
 237       (push constant-name exports)
 238       `(defconstant ,constant-name
 239          ,(getf (getf enum-specs enumeration-group-name)
 240                 enumeration-name))))
 241
 242   (defun gl-enumeration-definitions (enumeration-group-name)
 243     (mapcar #'(lambda (enumeration-name)
 244                 (gl-enumeration-definition enumeration-group-name enumeration-name))
 245             (plist-keys (getf enum-specs enumeration-group-name))))
 246
 247
 248   (let ((*print-case* :downcase) (*print-radix* t) (*print-base* 16))
 249     (with-open-file (out (merge-pathnames #P"lib/opengl.lisp" *base*) :direction :output :if-exists :supersede)
 250       (auto-generated-notice out)
 251
 252       (defun output-category (category-name)
 253         (format out "~&~%;;;; ~a~%" category-name)
 254         (dolist (func-spec (getf function-categories category-name))
 255           (print (gl-function-definition func-spec) out))
 256         (remf function-categories category-name))
 257
 258       (print `(in-package #:cl-glfw-opengl) out)
 259
 260       (dolist (enumeration-group-name (plist-keys enum-specs))
 261         (when (or (not (getf function-categories enumeration-group-name))
 262                   (find enumeration-group-name base-categories))
 263           (let ((enumeration-names (plist-keys (getf enum-specs enumeration-group-name))))
 264             (when enumeration-names
 265               (format out "~&~%;;;; Enumerations: ~a~%" (symbol-name enumeration-group-name))
 266               (dolist (enumeration-name enumeration-names)
 267                 (if (find enumeration-name predefined-enumerants)
 268                     (format out "~&;; ~a already defined" enumeration-name)
 269                     (let ((*print-radix* t) (*print-base* 16))
 270                       (push enumeration-name predefined-enumerants)
 271                       (print (gl-enumeration-definition enumeration-group-name enumeration-name) out))))))
 272           (remf enum-specs enumeration-group-name)))
 273
 274       ;; generate the functions for all of the 1.0 functions
 275       (dolist (category-name base-categories)
 276         (output-category category-name)))
 277
 278     (output-extension '|1_1| #'gl-function-definition 'VERSION_1_1)
 279
 280     (output-extension 'VERSION_1_2 #'gl-function-definition)
 281     (output-extension 'VERSION_1_3 #'gl-function-definition)
 282     (output-extension 'VERSION_1_4 #'gl-function-definition)
 283     (output-extension 'VERSION_1_5 #'gl-function-definition)
 284     (output-extension 'VERSION_2_0 #'gl-function-definition)
 285     (output-extension 'VERSION_2_1 #'gl-function-definition)
 286
 287     (dolist (category-name (remove-duplicates
 288                             (union (plist-keys function-categories)
 289                                    (plist-keys enum-specs))))
 290       (output-extension category-name))
 291
 292     (with-open-file (out (merge-pathnames #P"lib/opengl-type-map.lisp" *base*) :direction :output :if-exists :supersede)
 293       (auto-generated-notice out)
 294       (print `(in-package #:cl-glfw-opengl) out)
 295       (print `(setf *type-map* ',type-maps) out))
 296
 297     (with-open-file (out (merge-pathnames #P"lib/opengl-package.lisp" *base*) :direction :output :if-exists :supersede)
 298       (auto-generated-notice out)
 299       (print (make-opengl-defpackage (mapcar #'make-symbol (mapcar #'symbol-name (remove-duplicates (nreverse exports))))) out)))
 300   (format t "Leftovers functions: ~%~s~%Leftover enums:~s" function-categories enum-specs))