src/opengl-template.lisp

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