lib/opengl-types.lisp

   1
   2 (in-package #:cl-glfw-opengl)
   3
   4 (cffi:load-foreign-library '(:or (:framework "OpenGL")
   5                              "opengl32.dll"
   6                              (:default "libGL")
   7                              (:default "opengl")
   8                              (:default "opengl32")
   9                              (:default "GL")
  10                              (:default "gl")
  11                              (:default "libOpenGL")
  12                              (:default "OpenGL")))
  13
  14 ;; TYPES
  15
  16 (defctype enum :uint32)
  17 (defctype boolean :uint8)
  18 (defctype bitfield :uint32)
  19 (defctype byte :int8)
  20 (defctype short :int16)
  21 (defctype int :int32)
  22 (defctype sizei :int32)
  23 (defctype ubyte :uint8)
  24 (defctype ushort :uint16)
  25 (defctype uint :uint32)
  26 (defctype float :float)
  27 (defctype clampf :float)
  28 (defctype double :double)
  29 (defctype clampd :double)
  30 (defctype void :void)
  31
  32 #-cffi-features:no-long-long
  33 (defctype uint64 :uint64)
  34 #-cffi-features:no-long-long
  35 (defctype int64 :int64)
  36
  37 (defctype intptr #.(find-symbol (format nil "INT~d" (* 8 (cffi:foreign-type-size :pointer))) (find-package '#:keyword)))
  38 (defctype sizeiptr #.(find-symbol (format nil "INT~d" (* 8 (cffi:foreign-type-size :pointer))) (find-package '#:keyword)))
  39
  40 (defctype handle :unsigned-int)
  41
  42 (defctype char :char)
  43
  44 (defctype string :string)
  45
  46 (defctype half :unsigned-short) ; this is how glext.h defines it anyway
  47
  48 (defmethod cffi:expand-to-foreign (value (type (eql 'boolean)))
  49   `(if ,value gl:+true+ gl:+false+))
  50
  51 (defmethod cffi:expand-from-foreign (value (type (eql 'boolean)))
  52   `(not (= ,value gl:+false+)))
  53
  54 (defmethod cffi:expand-to-foreign (value (type (eql 'clampf)))
  55   `(coerce ,value 'single-float))
  56
  57 (defmethod cffi:expand-to-foreign (value (type (eql 'clampd)))
  58   `(coerce ,value 'double-float))
  59
  60 (defmethod cffi:expand-to-foreign (value (type (eql 'float)))
  61   `(coerce ,value 'single-float))
  62
  63 (defmethod cffi:expand-to-foreign (value (type (eql 'double)))
  64   `(coerce ,value 'double-float))
  65
  66 (defparameter *type-maps*
  67   '(|AccumOp| cl-glfw-opengl:enum |AlphaFunction| cl-glfw-opengl:enum |AttribMask| cl-glfw-opengl:bitfield
  68     |BeginMode| cl-glfw-opengl:enum |BinormalPointerTypeEXT| cl-glfw-opengl:enum
  69     |BlendEquationMode| cl-glfw-opengl:enum |BlendEquationModeEXT| cl-glfw-opengl:enum
  70     |BlendFuncSeparateParameterEXT| cl-glfw-opengl:enum |BlendingFactorDest| cl-glfw-opengl:enum
  71     |BlendingFactorSrc| cl-glfw-opengl:enum |Boolean| cl-glfw-opengl:boolean |BooleanPointer|
  72     :pointer |Char| cl-glfw-opengl:char |CharPointer| :pointer |CheckedFloat32|
  73     cl-glfw-opengl:float |CheckedInt32| cl-glfw-opengl:int |ClampColorTargetARB| cl-glfw-opengl:enum
  74     |ClampColorModeARB| cl-glfw-opengl:enum |ClampedColorF| cl-glfw-opengl:clampf |ClampedFloat32|
  75     cl-glfw-opengl:clampf |ClampedFloat64| cl-glfw-opengl:clampd |ClampedStencilValue| cl-glfw-opengl:int
  76     |ClearBufferMask| cl-glfw-opengl:bitfield |ClientAttribMask| cl-glfw-opengl:bitfield
  77     |ClipPlaneName| cl-glfw-opengl:enum |ColorB| cl-glfw-opengl:byte |ColorD| cl-glfw-opengl:double
  78     |ColorF| cl-glfw-opengl:float |ColorI| cl-glfw-opengl:int |ColorIndexValueD| cl-glfw-opengl:double
  79     |ColorIndexValueF| cl-glfw-opengl:float |ColorIndexValueI| cl-glfw-opengl:int
  80     |ColorIndexValueS| cl-glfw-opengl:short |ColorIndexValueUB| cl-glfw-opengl:ubyte
  81     |ColorMaterialParameter| cl-glfw-opengl:enum |ColorPointerType| cl-glfw-opengl:enum |ColorS|
  82     cl-glfw-opengl:short |ColorTableParameterPName| cl-glfw-opengl:enum
  83     |ColorTableParameterPNameSGI| cl-glfw-opengl:enum |ColorTableTarget| cl-glfw-opengl:enum
  84     |ColorTableTargetSGI| cl-glfw-opengl:enum |ColorUB| cl-glfw-opengl:ubyte |ColorUI| cl-glfw-opengl:uint
  85     |ColorUS| cl-glfw-opengl:ushort |CombinerBiasNV| cl-glfw-opengl:enum
  86     |CombinerComponentUsageNV| cl-glfw-opengl:enum |CombinerMappingNV| cl-glfw-opengl:enum
  87     |CombinerParameterNV| cl-glfw-opengl:enum |CombinerPortionNV| cl-glfw-opengl:enum
  88     |CombinerRegisterNV| cl-glfw-opengl:enum |CombinerScaleNV| cl-glfw-opengl:enum
  89     |CombinerStageNV| cl-glfw-opengl:enum |CombinerVariableNV| cl-glfw-opengl:enum
  90     |CompressedTextureARB| cl-glfw-opengl:void |ControlPointNV| cl-glfw-opengl:void
  91     |ControlPointTypeNV| cl-glfw-opengl:enum |ConvolutionParameter| cl-glfw-opengl:enum
  92     |ConvolutionParameterEXT| cl-glfw-opengl:enum |ConvolutionTarget| cl-glfw-opengl:enum
  93     |ConvolutionTargetEXT| cl-glfw-opengl:enum |CoordD| cl-glfw-opengl:double |CoordF|
  94     cl-glfw-opengl:float |CoordI| cl-glfw-opengl:int |CoordS| cl-glfw-opengl:short |CullFaceMode|
  95     cl-glfw-opengl:enum |CullParameterEXT| cl-glfw-opengl:enum |DepthFunction| cl-glfw-opengl:enum
  96     |DrawBufferMode| cl-glfw-opengl:enum |DrawElementsType| cl-glfw-opengl:enum
  97     |ElementPointerTypeATI| cl-glfw-opengl:enum |EnableCap| cl-glfw-opengl:enum |ErrorCode|
  98     cl-glfw-opengl:enum |EvalMapsModeNV| cl-glfw-opengl:enum |EvalTargetNV| cl-glfw-opengl:enum
  99     |FeedbackElement| cl-glfw-opengl:float |FeedbackType| cl-glfw-opengl:enum |FenceNV|
 100     cl-glfw-opengl:uint |FenceConditionNV| cl-glfw-opengl:enum |FenceParameterNameNV| cl-glfw-opengl:enum
 101     |FfdMaskSGIX| cl-glfw-opengl:bitfield |FfdTargetSGIX| cl-glfw-opengl:enum |Float32|
 102     cl-glfw-opengl:float |Float32Pointer| :pointer |Float64| cl-glfw-opengl:double
 103     |Float64Pointer| :pointer |FogParameter| cl-glfw-opengl:enum |FogPointerTypeEXT|
 104     cl-glfw-opengl:enum |FogPointerTypeIBM| cl-glfw-opengl:enum |FragmentLightModelParameterSGIX|
 105     cl-glfw-opengl:enum |FragmentLightNameSGIX| cl-glfw-opengl:enum |FragmentLightParameterSGIX|
 106     cl-glfw-opengl:enum |FramebufferAttachment| cl-glfw-opengl:enum |FramebufferTarget|
 107     cl-glfw-opengl:enum |FrontFaceDirection| cl-glfw-opengl:enum |FunctionPointer| :pointer
 108     |GetColorTableParameterPName| cl-glfw-opengl:enum |GetColorTableParameterPNameSGI|
 109     cl-glfw-opengl:enum |GetConvolutionParameterPName| cl-glfw-opengl:enum
 110     |GetHistogramParameterPName| cl-glfw-opengl:enum |GetHistogramParameterPNameEXT|
 111     cl-glfw-opengl:enum |GetMapQuery| cl-glfw-opengl:enum |GetMinmaxParameterPName| cl-glfw-opengl:enum
 112     |GetMinmaxParameterPNameEXT| cl-glfw-opengl:enum |GetPName| cl-glfw-opengl:enum
 113     |GetPointervPName| cl-glfw-opengl:enum |GetTextureParameter| cl-glfw-opengl:enum |HintMode|
 114     cl-glfw-opengl:enum |HintTarget| cl-glfw-opengl:enum |HintTargetPGI| cl-glfw-opengl:enum
 115     |HistogramTarget| cl-glfw-opengl:enum |HistogramTargetEXT| cl-glfw-opengl:enum
 116     |IglooFunctionSelectSGIX| cl-glfw-opengl:enum |IglooParameterSGIX| cl-glfw-opengl:void
 117     |ImageTransformPNameHP| cl-glfw-opengl:enum |ImageTransformTargetHP| cl-glfw-opengl:enum
 118     |IndexFunctionEXT| cl-glfw-opengl:enum |IndexMaterialParameterEXT| cl-glfw-opengl:enum
 119     |IndexPointerType| cl-glfw-opengl:enum |Int16| cl-glfw-opengl:short |Int32| cl-glfw-opengl:int |Int8|
 120     cl-glfw-opengl:byte |InterleavedArrayFormat| cl-glfw-opengl:enum |LightEnvParameterSGIX|
 121     cl-glfw-opengl:enum |LightModelParameter| cl-glfw-opengl:enum |LightName| cl-glfw-opengl:enum
 122     |LightParameter| cl-glfw-opengl:enum |LightTextureModeEXT| cl-glfw-opengl:enum
 123     |LightTexturePNameEXT| cl-glfw-opengl:enum |LineStipple| cl-glfw-opengl:ushort |List|
 124     cl-glfw-opengl:uint |ListMode| cl-glfw-opengl:enum |ListNameType| cl-glfw-opengl:enum
 125     |ListParameterName| cl-glfw-opengl:enum |LogicOp| cl-glfw-opengl:enum |MapAttribParameterNV|
 126     cl-glfw-opengl:enum |MapParameterNV| cl-glfw-opengl:enum |MapTarget| cl-glfw-opengl:enum |MapTargetNV|
 127     cl-glfw-opengl:enum |MapTypeNV| cl-glfw-opengl:enum |MaskedColorIndexValueF| cl-glfw-opengl:float
 128     |MaskedColorIndexValueI| cl-glfw-opengl:uint |MaskedStencilValue| cl-glfw-opengl:uint
 129     |MaterialFace| cl-glfw-opengl:enum |MaterialParameter| cl-glfw-opengl:enum
 130     |MatrixIndexPointerTypeARB| cl-glfw-opengl:enum |MatrixMode| cl-glfw-opengl:enum
 131     |MatrixTransformNV| cl-glfw-opengl:enum |MeshMode1| cl-glfw-opengl:enum |MeshMode2|
 132     cl-glfw-opengl:enum |MinmaxTarget| cl-glfw-opengl:enum |MinmaxTargetEXT| cl-glfw-opengl:enum
 133     |NormalPointerType| cl-glfw-opengl:enum |NurbsCallback| cl-glfw-opengl:enum |NurbsObj|
 134     :pointer |NurbsProperty| cl-glfw-opengl:enum |NurbsTrim| cl-glfw-opengl:enum
 135     |OcclusionQueryParameterNameNV| cl-glfw-opengl:enum |PixelCopyType| cl-glfw-opengl:enum
 136     |PixelFormat| cl-glfw-opengl:enum |PixelInternalFormat| cl-glfw-opengl:enum |PixelMap|
 137     cl-glfw-opengl:enum |PixelStoreParameter| cl-glfw-opengl:enum |PixelTexGenModeSGIX|
 138     cl-glfw-opengl:enum |PixelTexGenParameterNameSGIS| cl-glfw-opengl:enum
 139     |PixelTransferParameter| cl-glfw-opengl:enum |PixelTransformPNameEXT| cl-glfw-opengl:enum
 140     |PixelTransformTargetEXT| cl-glfw-opengl:enum |PixelType| cl-glfw-opengl:enum
 141     |PointParameterNameARB| cl-glfw-opengl:enum |PolygonMode| cl-glfw-opengl:enum |ProgramNV|
 142     cl-glfw-opengl:uint |ProgramCharacterNV| cl-glfw-opengl:ubyte |ProgramParameterNV| cl-glfw-opengl:enum
 143     |ProgramParameterPName| cl-glfw-opengl:enum |QuadricCallback| cl-glfw-opengl:enum
 144     |QuadricDrawStyle| cl-glfw-opengl:enum |QuadricNormal| cl-glfw-opengl:enum |QuadricObj|
 145     :pointer |QuadricOrientation| cl-glfw-opengl:enum |ReadBufferMode| cl-glfw-opengl:enum
 146     |RenderbufferTarget| cl-glfw-opengl:enum |RenderingMode| cl-glfw-opengl:enum
 147     |ReplacementCodeSUN| cl-glfw-opengl:uint |ReplacementCodeTypeSUN| cl-glfw-opengl:enum
 148     |SamplePassARB| cl-glfw-opengl:enum |SamplePatternEXT| cl-glfw-opengl:enum |SamplePatternSGIS|
 149     cl-glfw-opengl:enum |SecondaryColorPointerTypeIBM| cl-glfw-opengl:enum |SelectName|
 150     cl-glfw-opengl:uint |SeparableTarget| cl-glfw-opengl:enum |SeparableTargetEXT| cl-glfw-opengl:enum
 151     |ShadingModel| cl-glfw-opengl:enum |SizeI| cl-glfw-opengl:sizei |SpriteParameterNameSGIX|
 152     cl-glfw-opengl:enum |StencilFunction| cl-glfw-opengl:enum |StencilFaceDirection| cl-glfw-opengl:enum
 153     |StencilOp| cl-glfw-opengl:enum |StencilValue| cl-glfw-opengl:int |String| cl-glfw-opengl:string
 154     |StringName| cl-glfw-opengl:enum |TangentPointerTypeEXT| cl-glfw-opengl:enum |TessCallback|
 155     cl-glfw-opengl:enum |TessContour| cl-glfw-opengl:enum |TessProperty| cl-glfw-opengl:enum
 156     |TesselatorObj| :pointer |TexCoordPointerType| cl-glfw-opengl:enum |Texture|
 157     cl-glfw-opengl:uint |TextureComponentCount| cl-glfw-opengl:int |TextureCoordName| cl-glfw-opengl:enum
 158     |TextureEnvParameter| cl-glfw-opengl:enum |TextureEnvTarget| cl-glfw-opengl:enum
 159     |TextureFilterSGIS| cl-glfw-opengl:enum |TextureGenParameter| cl-glfw-opengl:enum
 160     |TextureNormalModeEXT| cl-glfw-opengl:enum |TextureParameterName| cl-glfw-opengl:enum
 161     |TextureTarget| cl-glfw-opengl:enum |TextureUnit| cl-glfw-opengl:enum |UInt16| cl-glfw-opengl:ushort
 162     |UInt32| cl-glfw-opengl:uint |UInt8| cl-glfw-opengl:ubyte |VertexAttribEnum| cl-glfw-opengl:enum
 163     |VertexAttribEnumNV| cl-glfw-opengl:enum |VertexAttribPointerTypeNV| cl-glfw-opengl:enum
 164     |VertexPointerType| cl-glfw-opengl:enum |VertexWeightPointerTypeEXT| cl-glfw-opengl:enum
 165     |Void| cl-glfw-opengl:void |VoidPointer| :pointer |ConstVoidPointer| :pointer
 166     |WeightPointerTypeARB| cl-glfw-opengl:enum |WinCoord| cl-glfw-opengl:int |void| :void
 167     |ArrayObjectPNameATI| cl-glfw-opengl:enum |ArrayObjectUsageATI| cl-glfw-opengl:enum
 168     |ConstFloat32| cl-glfw-opengl:float |ConstInt32| cl-glfw-opengl:int |ConstUInt32| cl-glfw-opengl:uint
 169     |ConstVoid| cl-glfw-opengl:void |DataTypeEXT| cl-glfw-opengl:enum |FragmentOpATI| cl-glfw-opengl:enum
 170     |GetTexBumpParameterATI| cl-glfw-opengl:enum |GetVariantValueEXT| cl-glfw-opengl:enum
 171     |ParameterRangeEXT| cl-glfw-opengl:enum |PreserveModeATI| cl-glfw-opengl:enum
 172     |ProgramFormatARB| cl-glfw-opengl:enum |ProgramTargetARB| cl-glfw-opengl:enum |ProgramTarget|
 173     cl-glfw-opengl:enum |ProgramPropertyARB| cl-glfw-opengl:enum |ProgramStringPropertyARB|
 174     cl-glfw-opengl:enum |ScalarType| cl-glfw-opengl:enum |SwizzleOpATI| cl-glfw-opengl:enum
 175     |TexBumpParameterATI| cl-glfw-opengl:enum |VariantCapEXT| cl-glfw-opengl:enum
 176     |VertexAttribPointerPropertyARB| cl-glfw-opengl:enum |VertexAttribPointerTypeARB|
 177     cl-glfw-opengl:enum |VertexAttribPropertyARB| cl-glfw-opengl:enum |VertexShaderCoordOutEXT|
 178     cl-glfw-opengl:enum |VertexShaderOpEXT| cl-glfw-opengl:enum |VertexShaderParameterEXT|
 179     cl-glfw-opengl:enum |VertexShaderStorageTypeEXT| cl-glfw-opengl:enum
 180     |VertexShaderTextureUnitParameter| cl-glfw-opengl:enum |VertexShaderWriteMaskEXT|
 181     cl-glfw-opengl:enum |VertexStreamATI| cl-glfw-opengl:enum |PNTrianglesPNameATI| cl-glfw-opengl:enum
 182     |BufferOffset| cl-glfw-opengl:intptr |BufferSize| cl-glfw-opengl:sizeiptr |BufferAccessARB|
 183     cl-glfw-opengl:enum |BufferOffsetARB| cl-glfw-opengl:intptr |BufferPNameARB| cl-glfw-opengl:enum
 184     |BufferPointerNameARB| cl-glfw-opengl:enum |BufferSizeARB| cl-glfw-opengl:sizeiptr
 185     |BufferTargetARB| cl-glfw-opengl:enum |BufferUsageARB| cl-glfw-opengl:enum |ObjectTypeAPPLE|
 186     cl-glfw-opengl:enum |VertexArrayPNameAPPLE| cl-glfw-opengl:enum |DrawBufferModeATI|
 187     cl-glfw-opengl:enum |Half16NV| cl-glfw-opengl:half |PixelDataRangeTargetNV| cl-glfw-opengl:enum
 188     |GLenum| cl-glfw-opengl:enum |handleARB| cl-glfw-opengl:handle |charARB| cl-glfw-opengl:char
 189     |charPointerARB| :pointer |Int64EXT| cl-glfw-opengl:int64 |UInt64EXT| cl-glfw-opengl:uint64))
 190
 191 (defun c-name (func-spec)    (first (first func-spec)))
 192 (defun lisp-name (func-spec) (second (first func-spec)))
 193 (defun freturn (func-spec)   (first (getf (rest func-spec) :return)))
 194 (defun args (func-spec)      (getf (rest func-spec) :args))
 195
 196 (defun deconstant (symbol)
 197   (if (not (constantp symbol))
 198       symbol
 199       (deconstant (intern (concatenate 'cl:string "_" (symbol-name symbol))))))
 200
 201 (defun final-arg-name (arg)
 202   (deconstant (intern (string-upcase (symbol-name (getf arg :name))))))
 203
 204 (defun final-arg-type (arg)
 205   (let ((type (getf *type-maps* (getf arg :type))))
 206     (cond
 207       ((eql 'void type) :pointer)
 208       ((getf arg :array) (if (eql type 'char) :string :pointer))
 209       (t type))))
 210
 211 (defun arg-element-type (arg)
 212   (getf *type-maps* (getf arg :type)))
 213
 214 (defun conc-symbols (&rest symbols)
 215   (intern (apply #'concatenate (cons 'cl:string (mapcar #'symbol-name symbols)))))
 216
 217 (defun array-wrappable-p (arg #|args|#)
 218   (let ((resolved-type (getf *type-maps* (getf arg :type))))
 219     (and (getf arg :array)
 220          ;; we must have a type, ie. not a void* pointer
 221          (not (eql 'void resolved-type))
 222          (not (eql :void resolved-type))
 223          ;; opengl cannot retain this pointer, as we would destroy it after passing it
 224          (not (getf arg :retained))
 225          ;; can we guarantee a size? - used to do this, but the app programmer must get it right himself for OpenGL anyway
 226          ;; so doing it this way is consistent with the C-interface, though more dangerous
 227          #|
 228          (or (integerp (getf arg :size))
 229          (and (symbolp (getf arg :size))
 230          (find-if #'(lambda (other-arg)
 231          (eql (getf arg :size) (final-arg-name other-arg)))
 232          args)))|#
 233          ;; our own hook
 234          (not (getf arg :wrapped)))))
 235
 236 (defun gl-function-definition (func-spec &optional (c-prefix "gl") (lisp-prefix '#:||))
 237   `(defcfun (,(concatenate 'cl:string c-prefix (c-name func-spec))
 238               ,(conc-symbols lisp-prefix (lisp-name func-spec)))
 239        ,(getf *type-maps* (intern (freturn func-spec)))
 240      ,@(mapcar #'(lambda (arg) (list (final-arg-name arg) (final-arg-type arg)))
 241                (args func-spec))))
 242
 243 (defun gl-funcall-definition (func-spec fpointer)
 244   `(foreign-funcall ,fpointer
 245                     ,@(mapcan #'(lambda (arg)
 246                                   `(,(final-arg-type arg) ,(final-arg-name arg)))
 247                               (args func-spec))
 248                     ,(getf *type-maps* (intern (freturn func-spec)))))
 249
 250 (defun expand-a-wrapping (func-spec final-content)
 251   (let* ((func-spec (copy-tree func-spec)) ; duplicate because we're not supposed to modify macro params
 252          (args (args func-spec))
 253          (first-wrappable (position-if #'array-wrappable-p args)))
 254     (if first-wrappable
 255         (let* ((arg (elt (args func-spec) first-wrappable))
 256                (original-array-name (gensym (symbol-name (final-arg-name arg))))
 257                (array-name (final-arg-name arg)))
 258           ;; set it wrapped by non-consingly attaching a wrapped property on the end
 259           (nconc arg (list :wrapped t))
 260           `(if (and (typep ,array-name 'sequence) (not (stringp ,array-name)))
 261                ;; the actual allocation
 262                (let* ((,original-array-name ,array-name)
 263                       (,array-name (foreign-alloc ',(arg-element-type arg)
 264                                                   ;; we used to base it on the count of whatever the spec said
 265                                                   #|:count ,(getf arg :size)|#
 266                                                   ;; but now, we'll use the user's sequence size, or just their content
 267                                                   ,@(if (eql (getf arg :direction) :in)
 268                                                         `(:initial-contents ,original-array-name)
 269                                                         `(:count (length ,original-array-name))))))
 270                  ;; (format t "Copying ~a elements of ~a: ~a into ~a~%"
 271                  ;; ,(getf arg :size) ',array-name ,original-array-name ,array-name)
 272                  (unwind-protect
 273                       (prog1
 274                           #| as input values are set above, we don't use this now (and above is a prog1, it was prog2 before)
 275                           ;; custom coersion of input values, before call ; ; ; ; ; ; ; ; ; ; ;
 276          ,(when (eql (getf arg :direction) :in)
 277                           `(cond
 278                           ((listp ,original-array-name)
 279                           (loop for i upfrom 0 for e in ,original-array-name
 280                           do (setf (mem-aref ,array-name ',(arg-element-type arg) i) e)))
 281                           ((vectorp ,original-array-name)
 282                           (loop for i upfrom 0 for e across ,original-array-name
 283                           do (setf (mem-aref ,array-name ',(arg-element-type arg) i) e)))))
 284          |#
 285                           ;; recurse in case there are more
 286                           ,(expand-a-wrapping func-spec final-content)
 287                         ;; custom coersion of output values, after call
 288                         ,(when (eql (getf arg :direction) :out)
 289                            `(cond
 290                               ((listp ,original-array-name)
 291                                (do ((i 0 (1+ i))
 292                                     (ce ,original-array-name (cdr ce)))
 293                                    ((not ce))
 294                                  #|((or (not ce)
 295                                  (>= i ,(getf arg :size))))|#
 296                                  (setf (car ce)
 297                                        (mem-aref ,array-name ',(arg-element-type arg) i))))
 298                               ((vectorp ,original-array-name)
 299                                (do ((i 0 (1+ i)))
 300                                    ((>= i (length ,original-array-name)))
 301                                  #|((or (>= i (length ,original-array-name))
 302                                  (>= i ,(getf arg :size))))|#
 303                                  (setf (aref ,original-array-name i)
 304                                        (mem-aref ,array-name ',(arg-element-type arg) i)))))))
 305                    (foreign-free ,array-name)))
 306                ;; in the case the arg wasn't a sequence, pass it straight through
 307                ,(expand-a-wrapping func-spec final-content)))
 308         ;; in the case that there is no more wrapping to be done, emit the final content to start unwinding
 309         final-content)))
 310
 311 (defun wrapped-win32-gl-function-definition (func-spec)
 312   `(let ((fpointer (foreign-funcall "wglGetProcAddress"
 313                                     :string ,(concatenate 'cl:string "gl" (c-name func-spec))
 314                                     :pointer)))
 315      ;; I know the CFFI guide recommends against holding pointers, but for extensions on win,
 316      ;; function pointers are the only way to do it. I don't think the locations are compiled
 317      ;; in-to the fasl files, as it's a top-level form.
 318      (when (null-pointer-p fpointer)
 319        (error 'simple-error "Error! Can't find function ~a" (first func-spec)))
 320      (defun ,(lisp-name func-spec)
 321          ,(mapcar #'(lambda (arg) (final-arg-name arg))
 322            (args func-spec))
 323        ;; if there is more than 0 wrappable arrays
 324        ,(let ((args (args func-spec)))
 325           (if (some #'array-wrappable-p args)
 326               (expand-a-wrapping func-spec
 327                                  (gl-funcall-definition func-spec 'fpointer))
 328               (gl-funcall-definition func-spec 'fpointer))))))
 329
 330 (defun wrapped-gl-function-definition (func-spec)
 331   (let ((args (args func-spec)))
 332     ;; if there is more than 0 wrappable arrays
 333     (if (some #'array-wrappable-p args)
 334         `(progn
 335            ;; make an inlined function prefixed with %
 336            (declaim (inline ,(conc-symbols '#:% (lisp-name func-spec))))
 337            ,(gl-function-definition func-spec "gl" '#:%)
 338            ;; the exposed function with wrappings
 339            (defun ,(lisp-name func-spec) ,(mapcar #'final-arg-name (args func-spec))
 340              ,(expand-a-wrapping func-spec
 341                                  `(,(conc-symbols '#:% (lisp-name func-spec))
 342                                     ,@(mapcar #'final-arg-name (args func-spec))))))
 343         (gl-function-definition func-spec))))