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