src/opengl-template.lisp

   1 (defpackage #:opengl
   2  (:use #:cffi #:cl)
   3  (:nicknames #:gl)
   4  (:export
   5   enum boolean bitfield byte short int sizei ubyte ushort uint float clampf
   6   double clampd void intptr sizeiptr char
   7   @EXPORTS@))
   8
   9 (in-package #:opengl)
  10
  11 (cffi:load-foreign-library '(:or (:framework "OpenGL")
  12                                  "opengl32.dll"
  13                                  (:default "libGL")
  14                                  (:default "opengl")
  15                                  (:default "opengl32")
  16                                  (:default "GL")
  17                                  (:default "gl")
  18                                  (:default "libOpenGL")
  19                                  (:default "OpenGL")))
  20
  21 ;; TYPES
  22
  23 (defctype enum :uint32)
  24 (defctype boolean :uint8)
  25 (defctype bitfield :uint32)
  26 (defctype byte :int8)
  27 (defctype short :int16)
  28 (defctype int :int32)
  29 (defctype sizei :int32)
  30 (defctype ubyte :uint8)
  31 (defctype ushort :uint16)
  32 (defctype uint :uint32)
  33 (defctype float :float)
  34 (defctype clampf :float)
  35 (defctype double :double)
  36 (defctype clampd :double)
  37 (defctype void :void)
  38
  39 (defctype uint64 :uint64)
  40 (defctype int64 :int64)
  41
  42 (defctype intptr #.(find-symbol (format nil "INT~d" (* 8 (cffi:foreign-type-size :pointer))) (find-package '#:keyword)))
  43 (defctype sizeiptr #.(find-symbol (format nil "INT~d" (* 8 (cffi:foreign-type-size :pointer))) (find-package '#:keyword)))
  44
  45 (defctype handle :unsigned-int)
  46
  47 (defctype char :char)
  48
  49 (defctype string :string)
  50
  51 (defctype half :unsigned-short) ;; this is how glext.h defines it anyway
  52
  53 (eval-when (:compile-toplevel :load-toplevel :execute)
  54   (let ((type-maps (quote @TYPE_MAPS@)))
  55     (labels ((c-name (func-spec)    (first (first func-spec)))
  56              (lisp-name (func-spec) (second (first func-spec)))
  57              (freturn (func-spec)   (first (getf (rest func-spec) :return)))
  58              (args (func-spec)      (getf (rest func-spec) :args))
  59              (deconstant (symbol)
  60                (if (not (constantp symbol))
  61                    symbol
  62                    (deconstant (intern (concatenate 'string "_" (symbol-name symbol))))))
  63              (final-arg-name (arg)
  64                (deconstant (intern (string-upcase (symbol-name (getf arg :name))))))
  65              (final-arg-type (arg)
  66                (let ((type (getf type-maps (getf arg :type))))
  67                  (cond
  68                    ((eql 'void type) :pointer)
  69                    ((getf arg :array) :pointer)
  70                    (t type))))
  71              (arg-element-type (arg)
  72                (getf type-maps (getf arg :type)))
  73              (conc-symbols (&rest symbols)
  74                (intern (apply #'concatenate (cons 'string (mapcar #'symbol-name symbols)))))
  75              (array-wrappable-p (arg args)
  76                (let ((resolved-type (getf type-maps (getf arg :type))))
  77                  (and (getf arg :array)
  78                       (not (eql 'void resolved-type))
  79                       (not (eql :void resolved-type))
  80                       (not (getf arg :retained))
  81                       (or (integerp (getf arg :size))
  82                           (and (symbolp (getf arg :size))
  83                                (find-if #'(lambda (other-arg)
  84                                             (eql (getf arg :size) (final-arg-name other-arg)))
  85                                         args)))
  86                       ;; our own hook
  87                       (not (getf arg :wrapped)))))
  88              (gl-function-definition (func-spec &optional (c-prefix "gl") (lisp-prefix '#:||))
  89                `(defcfun (,(concatenate 'string c-prefix (c-name func-spec))
  90                            ,(conc-symbols lisp-prefix (lisp-name func-spec)))
  91                     ,(getf type-maps (intern (freturn func-spec)))
  92                   ,@(mapcar #'(lambda (arg) (list (final-arg-name arg) (final-arg-type arg)))
  93                             (args func-spec))))
  94              (gl-funcall-definition (func-spec fpointer)
  95                `(foreign-funcall ,fpointer
  96                                  ,@(mapcan #'(lambda (arg)
  97                                                `(,(final-arg-type arg) ,(final-arg-name arg)))
  98                                            (args func-spec))
  99                                  ,(getf type-maps (intern (freturn func-spec)))))
 100              (expand-a-wrapping (func-spec final-content)
 101                (let* ((func-spec (copy-tree func-spec)) ; duplicate because we're not supposed to modify macro params
 102                       (args (args func-spec))
 103                       (first-wrappable (position-if #'(lambda (arg) (array-wrappable-p arg args))
 104                                                     args)))
 105                  (if first-wrappable
 106                      (let* ((arg (elt (args func-spec) first-wrappable))
 107                             (original-array-name (gensym (symbol-name (final-arg-name arg))))
 108                             (array-name (final-arg-name arg)))
 109                        ;; set it wrapped by non-consingly attaching a wrapped property on the end
 110                        (nconc arg (list :wrapped t))
 111                        `(if (typep ,array-name 'sequence)
 112                             ;; the actual allocation
 113                             (let ((,original-array-name ,array-name)
 114                                   (,array-name (foreign-alloc ',(arg-element-type arg)
 115                                                               :count ,(getf arg :size))))
 116                               ;; (format t "Copying ~a elements of ~a: ~a into ~a~%"
 117                               ;; ,(getf arg :size) ',array-name ,original-array-name ,array-name)
 118                               (unwind-protect
 119                                    (prog2
 120                                        ;; custom coersion of input values, before call
 121                                        ,(when (eql (getf arg :direction) :in)
 122                                               `(cond
 123                                                  ((listp ,original-array-name)
 124                                                   (loop for i upfrom 0 for e in ,original-array-name
 125                                                      do (setf (mem-aref ,array-name ',(arg-element-type arg) i) e)))
 126                                                  ((vectorp ,original-array-name)
 127                                                   (loop for i upfrom 0 for e across ,original-array-name
 128                                                      do (setf (mem-aref ,array-name ',(arg-element-type arg) i) e)))))
 129                                        ;; recurse in case there are more
 130                                        ,(expand-a-wrapping func-spec final-content)
 131                                      ;; custom coersion of output values, after call
 132                                      ,(when (eql (getf arg :direction) :out)
 133                                             `(cond
 134                                                ((listp ,original-array-name)
 135                                                 (do ((i 0 (1+ i))
 136                                                      (ce ,original-array-name (cdr ce)))
 137                                                     ((or (not ce)
 138                                                          (>= i ,(getf arg :size))))
 139                                                   (setf (car ce)
 140                                                         (mem-aref ,array-name ',(arg-element-type arg) i))))
 141                                                ((vectorp ,original-array-name)
 142                                                 (do ((i 0 (1+ i)))
 143                                                     ((or (>= i (length ,original-array-name))
 144                                                          (>= i ,(getf arg :size))))
 145                                                   (setf (aref ,original-array-name i)
 146                                                         (mem-aref ,array-name ',(arg-element-type arg) i)))))))
 147                                 (foreign-free ,array-name)))
 148                             ;; in the case the arg wasn't a sequence, pass it straight through
 149                             ,(expand-a-wrapping func-spec final-content)))
 150                      ;; in the case that there is no more wrapping to be done, emit the final content to start unwinding
 151                      final-content))))
 152
 153       (defun wrapped-win32-gl-function-definition (func-spec)
 154         `(let ((fpointer (foreign-funcall "wglGetProcAddress"
 155                                           :string ,(concatenate 'string "gl" (c-name func-spec))
 156                                           :pointer)))
 157            ;; I know the CFFI guide recommends against holding pointers, but for extensions on win,
 158            ;; function pointers are the only way to do it. I don't think the locations are compiled
 159            ;; in-to the fasl files, as it's a top-level form.
 160            (when (null-pointer-p fpointer)
 161              (error 'simple-error "Error! Can't find function ~a" (first func-spec)))
 162            (defun ,(lisp-name func-spec)
 163                ,(mapcar #'(lambda (arg) (final-arg-name arg))
 164                         (args func-spec))
 165              ;; if there is more than 0 wrappable arrays
 166              ,(let ((args (args func-spec)))
 167                    (if (some #'(lambda (arg) (array-wrappable-p arg args)) args)
 168                        (expand-a-wrapping func-spec
 169                                           (gl-funcall-definition func-spec 'fpointer))
 170                        (gl-funcall-definition func-spec 'fpointer))))))
 171
 172       (defun wrapped-gl-function-definition (func-spec)
 173         (let ((args (args func-spec)))
 174           ;; if there is more than 0 wrappable arrays
 175           (if (some #'(lambda (arg) (array-wrappable-p arg args)) args)
 176               `(progn
 177                  ;; make an inlined function prefixed with %
 178                  (declaim (inline ,(conc-symbols '#:% (lisp-name func-spec))))
 179                  ,(gl-function-definition func-spec "gl" '#:%)
 180                  ;; the exposed function with wrappings
 181                  (defun ,(lisp-name func-spec) ,(mapcar #'final-arg-name (args func-spec))
 182                    ,(expand-a-wrapping func-spec
 183                                        `(,(conc-symbols '#:% (lisp-name func-spec))
 184                                           ,@(mapcar #'final-arg-name (args func-spec))))))
 185               (gl-function-definition func-spec)))))))
 186
 187 (defmacro defglfun (func-spec)
 188   (wrapped-gl-function-definition func-spec))
 189
 190 (defmacro defglextfun (func-spec)
 191   #+win32 (wrapped-win32-gl-function-definition func-spec)
 192   #-win32 (wrapped-gl-function-definition func-spec))
 193
 194
 195 @BODY@