src/opengl-template.lisp

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