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*))
   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
  17 (defun deconstant (symbol)
  18   (if (not (constantp symbol))
  19       symbol
  20       (deconstant (intern (concatenate 'cl:string "_" (symbol-name symbol))))))
  21
  22 (defun final-arg-name (arg)
  23   (deconstant (intern (string-upcase (symbol-name (getf arg :name))))))
  24
  25 (defun get-type (sym)
  26   (let ((type-string (cl:string (getf *type-map* sym))))
  27 ;;    (format t "Type string ~S " type-string)
  28     (if (string-equal "string" type-string)
  29       (intern type-string :keyword)
  30       (intern type-string :cl-glfw-types))))
  31
  32 (defun final-arg-type (arg)
  33   (let ((type (get-type (getf arg :type))))
  34     (cond
  35       ((equal "VOID" (symbol-name type)) 'cl-glfw-types:pointer)
  36       ((getf arg :array) (if (equal (symbol-name type) "CHAR") :string 'cl-glfw-types:pointer))
  37       (t type))))
  38
  39 (defun arg-element-type (arg)
  40   (get-type (getf arg :type)))
  41
  42 (defun conc-symbols (&rest symbols)
  43   (intern (apply #'concatenate (cons 'cl:string (mapcar #'symbol-name symbols)))))
  44
  45 (defun array-wrappable-p (arg #|args|#)
  46   (let ((resolved-type (get-type (getf arg :type))))
  47     (and (getf arg :array)
  48          ;; we must have a type, ie. not a void* pointer
  49          (not (equal "VOID" (symbol-name resolved-type)))
  50          ;; opengl cannot retain this pointer, as we would destroy it after passing it
  51          (not (getf arg :retained))
  52          ;; can we guarantee a size? - used to do this, but the app programmer must get it right himself for OpenGL anyway
  53          ;; so doing it this way is consistent with the C-interface, though more dangerous
  54          #|
  55          (or (integerp (getf arg :size))
  56          (and (symbolp (getf arg :size))
  57          (find-if #'(lambda (other-arg)
  58          (eql (getf arg :size) (final-arg-name other-arg)))
  59          args)))|#
  60          ;; our own hook
  61          (not (getf arg :wrapped)))))
  62
  63 (defun gl-function-definition (func-spec &optional (c-prefix "gl") (lisp-prefix '#:||))
  64   `(defcfun (,(concatenate 'cl:string c-prefix (c-name-of func-spec))
  65               ,(conc-symbols lisp-prefix (lisp-name-of func-spec)))
  66        ,(get-type (intern (freturn-of func-spec)))
  67      ,@(mapcar #'(lambda (arg) (list (final-arg-name arg) (final-arg-type arg)))
  68                (args-of func-spec))))
  69
  70 (defun gl-funcall-definition (func-spec fpointer)
  71   `(foreign-funcall ,fpointer
  72                     ,@(mapcan #'(lambda (arg)
  73                                   `(,(final-arg-type arg) ,(final-arg-name arg)))
  74                               (args-of func-spec))
  75                     ,(get-type (intern (freturn-of func-spec)))))
  76
  77 (defun expand-a-wrapping (func-spec final-content)
  78   (let* ((func-spec (copy-tree func-spec)) ; duplicate because we're not supposed to modify macro params
  79          (args (args-of func-spec))
  80          (first-wrappable (position-if #'array-wrappable-p args)))
  81     (if first-wrappable
  82         (let* ((arg (elt (args-of func-spec) first-wrappable))
  83                (original-array-name (gensym (symbol-name (final-arg-name arg))))
  84                (array-name (final-arg-name arg)))
  85           ;; set it wrapped by non-consingly attaching a wrapped property on the end
  86           (nconc arg (list :wrapped t))
  87           `(if (and (typep ,array-name 'sequence) (not (stringp ,array-name)))
  88                ;; the actual allocation
  89                (let* ((,original-array-name ,array-name)
  90                       (,array-name (foreign-alloc ',(arg-element-type arg)
  91                                                   ;; we used to base it on the count of whatever the spec said
  92                                                   #|:count ,(getf arg :size)|#
  93                                                   ;; but now, we'll use the user's sequence size, or just their content
  94                                                   ,@(if (eql (getf arg :direction) :in)
  95                                                         `(:initial-contents ,original-array-name)
  96                                                         `(:count (length ,original-array-name))))))
  97                  ;; (format t "Copying ~a elements of ~a: ~a into ~a~%"
  98                  ;; ,(getf arg :size) ',array-name ,original-array-name ,array-name)
  99                  (unwind-protect
 100                       (prog1
 101                           ;; recurse in case there are more
 102                           ,(expand-a-wrapping func-spec final-content)
 103                         ;; custom coersion of output values, after call
 104                         ,(when (eql (getf arg :direction) :out)
 105                            `(cond
 106                               ((listp ,original-array-name)
 107                                (loop for i from 0
 108                                   for cel = ,original-array-name then (cdr cel)
 109                                   while cel
 110                                   do (setf (car cel) (mem-aref ,array-name ',(arg-element-type arg) i))))
 111                               ((vectorp ,original-array-name)
 112                                (loop for i below (length ,original-array-name) do
 113                                     (setf (aref ,original-array-name i)
 114                                           (mem-aref ,array-name ',(arg-element-type arg) i)))))))
 115                    (foreign-free ,array-name)))
 116                ;; in the case the arg wasn't a sequence, pass it straight through
 117                ,(expand-a-wrapping func-spec final-content)))
 118         ;; in the case that there is no more wrapping to be done, emit the final content to start unwinding
 119         final-content)))
 120
 121 (defun wrapped-win32-gl-function-definition (func-spec)
 122   `(let ((fpointer (foreign-funcall "wglGetProcAddress"
 123                                     :string ,(concatenate 'cl:string "gl" (c-name-of func-spec))
 124                                     :pointer)))
 125      ;; I know the CFFI guide recommends against holding pointers, but for extensions on win,
 126      ;; function pointers are the only way to do it. I don't think the locations are compiled
 127      ;; in-to the fasl files, as it's a top-level form.
 128      (when (null-pointer-p fpointer)
 129        (warn "Can't find function ~a" (first func-spec)))
 130      (defun ,(lisp-name-of func-spec)
 131          ,(mapcar #'(lambda (arg) (final-arg-name arg))
 132            (args-of func-spec))
 133        ;; if there is more than 0 wrappable arrays
 134        ,(let ((args (args-of func-spec)))
 135           (if (some #'array-wrappable-p args)
 136               (expand-a-wrapping func-spec
 137                                  (gl-funcall-definition func-spec 'fpointer))
 138               (gl-funcall-definition func-spec 'fpointer))))))
 139
 140 (defun wrapped-gl-function-definition (func-spec)
 141   (let ((args (args-of func-spec)))
 142     ;; if there is more than 0 wrappable arrays
 143     (if (some #'array-wrappable-p args)
 144         `(progn
 145            ;; make an inlined function prefixed with %
 146            (declaim (inline ,(conc-symbols '#:% (lisp-name-of func-spec))))
 147            ,(gl-function-definition func-spec "gl" '#:%)
 148            ;; the exposed function with wrappings
 149            (defun ,(lisp-name-of func-spec) ,(mapcar #'final-arg-name (args-of func-spec))
 150              ,(expand-a-wrapping func-spec
 151                                  `(,(conc-symbols '#:% (lisp-name-of func-spec))
 152                                     ,@(mapcar #'final-arg-name (args-of func-spec))))))
 153         (gl-function-definition func-spec))))
 154
 155 (defmacro defglfun (&rest func-spec)
 156   (wrapped-gl-function-definition func-spec))
 157
 158 (defmacro defglextfun (&rest func-spec)
 159   #+win32 (wrapped-win32-gl-function-definition func-spec)
 160   #-win32 (wrapped-gl-function-definition func-spec))
 161