lib/scaffolding.lisp

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