generators/make-bindings-from-spec.lisp

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