generators/make-bindings-from-spec.lisp

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