lib/scaffolding.lisp

   1 (defpackage #:cl-glfw-scaffolding
   2   (:use #:cl #:cffi #:cl-glfw-types)
   3   (:shadowing-import-from #:cl-glfw-types #:boolean #:byte #:float
   4                           #:char #:pointer)
   5   (:export #:defglfun #:defglextfun #:*type-map* #:make-extension-loader))
   6
   7 (in-package #:cl-glfw-scaffolding)
   8
   9 (defparameter *type-map* nil)
  10
  11 (defun c-name-of (func-spec) (first func-spec))
  12 (defun lisp-name-of (func-spec) (second func-spec))
  13 (defun freturn-of (func-spec) (getf (cddr func-spec) :return))
  14 (defun args-of (func-spec) (getf (cddr func-spec) :args))
  15 (defun category-of (func-spec) (getf (cddr func-spec) :category))
  16 (defun alias-of (func-spec) (getf (cddr func-spec) :alias))
  17 (defun core-of (func-spec) (getf (cddr func-spec) :core))
  18
  19 (defun deconstant (symbol)
  20   (if (not (constantp symbol))
  21       symbol
  22       (deconstant (intern (concatenate 'cl:string "_" (symbol-name symbol))))))
  23
  24 (defun final-arg-name (arg)
  25   (deconstant (intern (string-upcase (symbol-name (getf arg :name))))))
  26
  27 (defun get-type (sym)
  28   (let ((type-string (cl:string (getf *type-map* sym))))
  29     ;;    (format t "Type string ~S " type-string)
  30     (if (string-equal "string" type-string)
  31         (intern type-string :keyword)
  32         (intern type-string :cl-glfw-types))))
  33
  34 (defun final-arg-type (arg)
  35   (let ((type (get-type (getf arg :type))))
  36     (cond
  37       ((equal "VOID" (symbol-name type)) 'cl-glfw-types:pointer)
  38       ((getf arg :array) (if (equal (symbol-name type) "CHAR") :string 'cl-glfw-types:pointer))
  39       (t type))))
  40
  41 (defun arg-element-type (arg)
  42   (get-type (getf arg :type)))
  43
  44 (defun conc-symbols (&rest symbols)
  45   (intern (apply #'concatenate (cons 'cl:string (mapcar #'symbol-name symbols)))))
  46
  47 (defun array-wrappable-p (arg #|args|#)
  48   (let ((resolved-type (get-type (getf arg :type))))
  49     (and (getf arg :array)
  50          ;; we must have a type, ie. not a void* pointer
  51          (not (equal "VOID" (symbol-name resolved-type)))
  52          ;; opengl cannot retain this pointer, as we would destroy it after passing it
  53          (not (getf arg :retained))
  54          ;; can we guarantee a size? - used to do this, but the app programmer must get it right himself for OpenGL anyway
  55          ;; so doing it this way is consistent with the C-interface, though more dangerous
  56          #|
  57          (or (integerp (getf arg :size))
  58          (and (symbolp (getf arg :size))
  59          (find-if #'(lambda (other-arg)
  60          (eql (getf arg :size) (final-arg-name other-arg)))
  61          args)))|#
  62          ;; our own hook
  63          (not (getf arg :wrapped)))))
  64
  65 (defun gl-function-definition (func-spec &optional (c-prefix "gl") (lisp-prefix '#:||))
  66   `(defcfun (,(concatenate 'cl:string c-prefix (c-name-of func-spec))
  67               ,(conc-symbols lisp-prefix (lisp-name-of func-spec)))
  68        ,(get-type (intern (freturn-of func-spec)))
  69      ,@(mapcar #'(lambda (arg) (list (final-arg-name arg) (final-arg-type arg)))
  70                (args-of func-spec))))
  71
  72 (defun gl-funcall-definition (func-spec fpointer)
  73   `(cffi:foreign-funcall-pointer
  74     ,fpointer
  75     ,@(mapcan #'(lambda (arg) (list (final-arg-type arg) (final-arg-name arg)))
  76               (args-of func-spec))
  77     ,(get-type (intern (freturn-of func-spec)))))
  78
  79 (defun expand-a-wrapping (func-spec final-content)
  80   (let* ((func-spec (copy-tree func-spec)) ; duplicate because we're not supposed to modify macro params
  81          (args (args-of func-spec))
  82          (first-wrappable (position-if #'array-wrappable-p args)))
  83     (if first-wrappable
  84         (let* ((arg (elt (args-of func-spec) first-wrappable))
  85                (original-array-name (gensym (symbol-name (final-arg-name arg))))
  86                (array-name (final-arg-name arg)))
  87           ;; set it wrapped by non-consingly attaching a wrapped property on the end
  88           (nconc arg (list :wrapped t))
  89           `(if (and (typep ,array-name 'sequence) (not (stringp ,array-name)))
  90                ;; the actual allocation
  91                (let* ((,original-array-name ,array-name)
  92                       (,array-name (foreign-alloc ',(arg-element-type arg)
  93                                                   ;; we used to base it on the count of whatever the spec said
  94                                                   #|:count ,(getf arg :size)|#
  95                                                   ;; but now, we'll use the user's sequence size, or just their content
  96                                                   ,@(if (eql (getf arg :direction) :in)
  97                                                         `(:initial-contents ,original-array-name)
  98                                                         `(:count (length ,original-array-name))))))
  99                  ;; (format t "Copying ~a elements of ~a: ~a into ~a~%"
 100                  ;; ,(getf arg :size) ',array-name ,original-array-name ,array-name)
 101                  (unwind-protect
 102                       (prog1
 103                           ;; recurse in case there are more
 104                           ,(expand-a-wrapping func-spec final-content)
 105                         ;; custom coersion of output values, after call
 106                         ,(when (eql (getf arg :direction) :out)
 107                            `(cond
 108                               ((listp ,original-array-name)
 109                                (loop for i from 0
 110                                   for cel = ,original-array-name then (cdr cel)
 111                                   while cel
 112                                   do (setf (car cel) (mem-aref ,array-name ',(arg-element-type arg) i))))
 113                               ((vectorp ,original-array-name)
 114                                (loop for i below (length ,original-array-name) do
 115                                     (setf (aref ,original-array-name i)
 116                                           (mem-aref ,array-name ',(arg-element-type arg) i)))))))
 117                    (foreign-free ,array-name)))
 118                ;; in the case the arg wasn't a sequence, pass it straight through
 119                ,(expand-a-wrapping func-spec final-content)))
 120         ;; in the case that there is no more wrapping to be done, emit the final content to start unwinding
 121         final-content)))
 122
 123 (defun proc-parameter-name-of (func-spec)
 124   (intern (format nil "*PROC-~A*" (lisp-name-of func-spec))))
 125
 126 (defun gl-function-name-of (func-spec)
 127   (concatenate 'cl:string "gl" (c-name-of func-spec)))
 128
 129 (defun wrapped-win32-gl-function-definition (func-spec)
 130   (let ((parameter-name (proc-parameter-name-of func-spec)))
 131     `(progn
 132        (defparameter ,parameter-name nil)
 133        (defun ,(lisp-name-of func-spec)
 134            ,(mapcar #'(lambda (arg) (final-arg-name arg))
 135                     (args-of func-spec))
 136          ,(let ((args (args-of func-spec))
 137                 (funcall-definition (gl-funcall-definition func-spec parameter-name)))
 138                ;; if there is more than 0 wrappable arrays
 139                (if (some #'array-wrappable-p args)
 140                    (expand-a-wrapping func-spec funcall-definition)
 141                    funcall-definition))))))
 142
 143
 144 (eval-when (:compile-toplevel :load-toplevel :execute)
 145   (defun extract-numbers (string max-numbers)
 146     (loop with i = 0
 147        for j below max-numbers
 148        while (setf i (position-if #'digit-char-p string :start i))
 149        collect
 150        (multiple-value-bind (number position)
 151            (parse-integer string :start i :junk-allowed t)
 152          (setf i position)
 153          number))))
 154
 155
 156 (eval-when (:compile-toplevel :load-toplevel :execute)
 157  (defun version-at-least-p (version min-version)
 158    (declare (type (cons integer (cons integer null)) version min-version))
 159    (cond
 160      ((> (first version)
 161          (first min-version))
 162       t)
 163      ((= (first version)
 164          (first min-version))
 165       (>= (second version)
 166           (second min-version)))
 167      (t
 168       nil))))
 169
 170
 171 (defmacro make-extension-loader (extension-name (&rest function-specs))
 172   `(defun ,(intern (concatenate 'string "LOAD-" (string-upcase (string extension-name)))) ()
 173      (cond
 174        ((,(find-symbol "EXTENSION-AVAILABLE-P" (find-package '#:cl-glfw-opengl-extensions))
 175           ,(string extension-name))
 176         #+win32
 177         (setf
 178          ;;Won't refer to gl:get-proc-address symbol directly here, as it's loaded after the scaffolding
 179          ,@(let ((get-proc-address-func (find-symbol "GET-PROC-ADDRESS" (find-package '#:cl-glfw-opengl))))
 180                 (loop for function-spec in function-specs nconcing
 181                      (list (proc-parameter-name-of function-spec)
 182                            (list get-proc-address-func (gl-function-name-of function-spec))))))
 183         t)
 184        ;;Are all the extension's functions alias to core functions? Which version would we need?
 185        ,@(let ((extension-core-from-version
 186                 (block get-function-max-version
 187                   (let ((max-version (list 1 0)))
 188                     (dolist (function-spec function-specs)
 189                       (let ((aliased-spec (alias-of function-spec)))
 190                         (if (and (core-of aliased-spec)
 191                                  (stringp (category-of aliased-spec)))
 192                             (let ((version (extract-numbers (category-of aliased-spec) 2)))
 193                               (when (version-at-least-p version max-version)
 194                                 (setf max-version version)))
 195                             (return-from get-function-max-version nil))))
 196                     max-version))))
 197               (when extension-core-from-version
 198                 ;;Is the OpenGL context one that has all the functions
 199                 `(((version-at-least-p (extract-numbers (,(find-symbol "GET-STRING" '#:cl-glfw-opengl)
 200                                                           ,(find-symbol "+VERSION+" '#:cl-glfw-opengl)) 2)
 201                                        ',extension-core-from-version)
 202                    #+win32
 203                    (setf
 204                     ;;Won't refer to gl:get-proc-address symbol directly here, as it's loaded after the scaffolding
 205                     ,@(let ((get-proc-address-func (find-symbol "GET-PROC-ADDRESS" '#:cl-glfw-opengl)))
 206                            (loop for function-spec in function-specs nconcing
 207                                 (list (proc-parameter-name-of function-spec)
 208                                       (list get-proc-address-func (concatenate 'string "gl" (c-name-of function-spec)))))))
 209                    t)))))))
 210
 211 (defun wrapped-gl-function-definition (func-spec)
 212   (let ((args (args-of func-spec)))
 213     ;; if there is more than 0 wrappable arrays
 214     (if (some #'array-wrappable-p args)
 215         `(progn
 216            ;; make an inlined function prefixed with %
 217            (declaim (inline ,(conc-symbols '#:% (lisp-name-of func-spec))))
 218            ,(gl-function-definition func-spec "gl" '#:%)
 219            ;; the exposed function with wrappings
 220            (defun ,(lisp-name-of func-spec) ,(mapcar #'final-arg-name (args-of func-spec))
 221              ,(expand-a-wrapping func-spec
 222                                  `(,(conc-symbols '#:% (lisp-name-of func-spec))
 223                                     ,@(mapcar #'final-arg-name (args-of func-spec))))))
 224         (gl-function-definition func-spec))))
 225
 226 (defmacro defglfun (&rest func-spec)
 227   (wrapped-gl-function-definition func-spec))
 228
 229 (defmacro defglextfun (&rest func-spec)
 230   #+win32 (wrapped-win32-gl-function-definition func-spec)
 231   #-win32 (wrapped-gl-function-definition func-spec))
 232