basis/opengl/gl/extensions/extensions.factor

   1 USING: alien alien.syntax alien.parser combinators
   2 kernel parser sequences system words namespaces hashtables init
   3 math arrays assocs continuations lexer fry locals vocabs.parser
   4 vocabs.platforms ;
   5 IN: opengl.gl.extensions
   6
   7 USE-WINDOWS: opengl.gl.windows
   8 USE-MACOSX: opengl.gl.macosx
   9 ! We can't have two gl-function-context in scope here
  10 ! so load either macosx or unix
  11 <!MACOSX
  12     USE-UNIX: opengl.gl.gtk
  13 !MACOSX>
  14
  15 SYMBOL: +gl-function-counter+
  16 SYMBOL: +gl-function-pointers+
  17
  18 : reset-gl-function-number-counter ( -- )
  19     0 +gl-function-counter+ set-global ;
  20 : reset-gl-function-pointers ( -- )
  21     100 <hashtable> +gl-function-pointers+ set-global ;
  22
  23 STARTUP-HOOK: reset-gl-function-pointers
  24
  25 reset-gl-function-pointers
  26 reset-gl-function-number-counter
  27
  28 : gl-function-counter ( -- n )
  29     +gl-function-counter+ counter ;
  30
  31 : gl-function-pointer ( names n -- funptr )
  32     gl-function-context 2array dup +gl-function-pointers+ get-global at
  33     [ 2nip ] [
  34         [
  35             [ gl-function-address ] map [ ] find nip
  36             dup [ "OpenGL function not available" throw ] unless
  37             dup
  38         ] dip
  39         +gl-function-pointers+ get-global set-at
  40     ] if* ;
  41
  42 : indirect-quot ( function-ptr-quot return types abi -- quot )
  43     '[ @  _ _ _ alien-indirect ] ;
  44
  45 :: define-indirect ( abi return function-name function-ptr-quot types names -- )
  46     function-name create-function
  47     function-ptr-quot return types abi indirect-quot
  48     names return function-effect
  49     define-declared ;
  50
  51 : gl-function-calling-convention ( -- symbol )
  52     os windows? [ stdcall ] [ cdecl ] if ;
  53
  54 SYNTAX: GL-FUNCTION:
  55     gl-function-calling-convention
  56     scan-function-name
  57     "{" expect "}" parse-tokens over suffix
  58     gl-function-counter '[ _ _ gl-function-pointer ]
  59     scan-c-args define-indirect ;