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                       ;; we must have a type, ie. not a void* pointer
  79                       (not (eql 'void resolved-type))
  80                       (not (eql :void resolved-type))
  81                       ;; opengl cannot retain this pointer, as we would destroy it after passing it
  82                       (not (getf arg :retained))
  83                       ;; can we guarantee a size? - used to do this, but the app programmer must get it right himself for OpenGL anyway
  84                       ;; so doing it this way is consistent with the C-interface, though more dangerous
  85                       #|
  86                       (or (integerp (getf arg :size))
  87                           (and (symbolp (getf arg :size))
  88                                (find-if #'(lambda (other-arg)
  89                                             (eql (getf arg :size) (final-arg-name other-arg)))
  90                                         args)))|#
  91                       ;; our own hook
  92                       (not (getf arg :wrapped)))))
  93              (gl-function-definition (func-spec &optional (c-prefix "gl") (lisp-prefix '#:||))
  94                `(defcfun (,(concatenate 'string c-prefix (c-name func-spec))
  95                            ,(conc-symbols lisp-prefix (lisp-name func-spec)))
  96                     ,(getf type-maps (intern (freturn func-spec)))
  97                   ,@(mapcar #'(lambda (arg) (list (final-arg-name arg) (final-arg-type arg)))
  98                             (args func-spec))))
  99              (gl-funcall-definition (func-spec fpointer)
 100                `(foreign-funcall ,fpointer
 101                                  ,@(mapcan #'(lambda (arg)
 102                                                `(,(final-arg-type arg) ,(final-arg-name arg)))
 103                                            (args func-spec))
 104                                  ,(getf type-maps (intern (freturn func-spec)))))
 105              (expand-a-wrapping (func-spec final-content)
 106                (let* ((func-spec (copy-tree func-spec)) ; duplicate because we're not supposed to modify macro params
 107                       (args (args func-spec))
 108                       (first-wrappable (position-if #'array-wrappable-p args)))
 109                  (if first-wrappable
 110                      (let* ((arg (elt (args func-spec) first-wrappable))
 111                             (original-array-name (gensym (symbol-name (final-arg-name arg))))
 112                             (array-name (final-arg-name arg)))
 113                        ;; set it wrapped by non-consingly attaching a wrapped property on the end
 114                        (nconc arg (list :wrapped t))
 115                        `(if (typep ,array-name 'sequence)
 116                             ;; the actual allocation
 117                             (let* ((,original-array-name ,array-name)
 118                                    (,array-name (foreign-alloc ',(arg-element-type arg)
 119                                                                ;; we used to base it on the count of whatever the spec said
 120                                                                #|:count ,(getf arg :size)|#
 121                                                                ;; but now, we'll use the user's sequence size, or just their content
 122                                                                ,@(if (eql (getf arg :direction) :in)
 123                                                                      `(:initial-contents ,original-array-name)
 124                                                                      `(:count (length ,original-array-name))))))
 125                               ;; (format t "Copying ~a elements of ~a: ~a into ~a~%"
 126                               ;; ,(getf arg :size) ',array-name ,original-array-name ,array-name)
 127                               (unwind-protect
 128                                    (prog1
 129                                        #| as input values are set above, we don't use this now (and above is a prog1, it was prog2 before)
 130                                        ;; custom coersion of input values, before call ;
 131                                        ,(when (eql (getf arg :direction) :in)
 132                                        `(cond
 133                                        ((listp ,original-array-name)
 134                                        (loop for i upfrom 0 for e in ,original-array-name
 135                                        do (setf (mem-aref ,array-name ',(arg-element-type arg) i) e)))
 136                                        ((vectorp ,original-array-name)
 137                                        (loop for i upfrom 0 for e across ,original-array-name
 138                                        do (setf (mem-aref ,array-name ',(arg-element-type arg) i) e)))))
 139                                        |#
 140                                        ;; recurse in case there are more
 141                                        ,(expand-a-wrapping func-spec final-content)
 142                                      ;; custom coersion of output values, after call
 143                                      ,(when (eql (getf arg :direction) :out)
 144                                             `(cond
 145                                                ((listp ,original-array-name)
 146                                                 (do ((i 0 (1+ i))
 147                                                      (ce ,original-array-name (cdr ce)))
 148                                                     ((not ce))
 149                                                     #|((or (not ce)
 150                                                            (>= i ,(getf arg :size))))|#
 151                                                   (setf (car ce)
 152                                                         (mem-aref ,array-name ',(arg-element-type arg) i))))
 153                                                ((vectorp ,original-array-name)
 154                                                 (do ((i 0 (1+ i)))
 155                                                     ((>= i (length ,original-array-name)))
 156                                                   #|((or (>= i (length ,original-array-name))
 157                                                   (>= i ,(getf arg :size))))|#
 158                                                   (setf (aref ,original-array-name i)
 159                                                         (mem-aref ,array-name ',(arg-element-type arg) i)))))))
 160                                 (foreign-free ,array-name)))
 161                             ;; in the case the arg wasn't a sequence, pass it straight through
 162                             ,(expand-a-wrapping func-spec final-content)))
 163                      ;; in the case that there is no more wrapping to be done, emit the final content to start unwinding
 164                      final-content))))
 165
 166       (defun wrapped-win32-gl-function-definition (func-spec)
 167         `(let ((fpointer (foreign-funcall "wglGetProcAddress"
 168                                           :string ,(concatenate 'string "gl" (c-name func-spec))
 169                                           :pointer)))
 170            ;; I know the CFFI guide recommends against holding pointers, but for extensions on win,
 171            ;; function pointers are the only way to do it. I don't think the locations are compiled
 172            ;; in-to the fasl files, as it's a top-level form.
 173            (when (null-pointer-p fpointer)
 174              (error 'simple-error "Error! Can't find function ~a" (first func-spec)))
 175            (defun ,(lisp-name func-spec)
 176                ,(mapcar #'(lambda (arg) (final-arg-name arg))
 177                         (args func-spec))
 178              ;; if there is more than 0 wrappable arrays
 179              ,(let ((args (args func-spec)))
 180                    (if (some #'array-wrappable-p args)
 181                        (expand-a-wrapping func-spec
 182                                           (gl-funcall-definition func-spec 'fpointer))
 183                        (gl-funcall-definition func-spec 'fpointer))))))
 184
 185       (defun wrapped-gl-function-definition (func-spec)
 186         (let ((args (args func-spec)))
 187           ;; if there is more than 0 wrappable arrays
 188           (if (some #'array-wrappable-p args)
 189               `(progn
 190                  ;; make an inlined function prefixed with %
 191                  (declaim (inline ,(conc-symbols '#:% (lisp-name func-spec))))
 192                  ,(gl-function-definition func-spec "gl" '#:%)
 193                  ;; the exposed function with wrappings
 194                  (defun ,(lisp-name func-spec) ,(mapcar #'final-arg-name (args func-spec))
 195                    ,(expand-a-wrapping func-spec
 196                                        `(,(conc-symbols '#:% (lisp-name func-spec))
 197                                           ,@(mapcar #'final-arg-name (args func-spec))))))
 198               (gl-function-definition func-spec)))))))
 199
 200 (defmacro defglfun (func-spec)
 201   (wrapped-gl-function-definition func-spec))
 202
 203 (defmacro defglextfun (func-spec)
 204   #+win32 (wrapped-win32-gl-function-definition func-spec)
 205   #-win32 (wrapped-gl-function-definition func-spec))
 206
 207
 208 @BODY@