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 IN: opengl.gl.extensions
   5
   6 ERROR: unknown-gl-platform ;
   7 << {
   8     { [ os windows? ] [ "opengl.gl.windows" ] }
   9     { [ os macosx? ]  [ "opengl.gl.macosx" ] }
  10     { [ os unix? ] [ "opengl.gl.gtk" ] }
  11     [ throw-unknown-gl-platform ]
  12 } cond use-vocab >>
  13
  14 SYMBOL: +gl-function-counter+
  15 SYMBOL: +gl-function-pointers+
  16
  17 : reset-gl-function-number-counter ( -- )
  18     0 +gl-function-counter+ set-global ;
  19 : reset-gl-function-pointers ( -- )
  20     100 <hashtable> +gl-function-pointers+ set-global ;
  21
  22 [ reset-gl-function-pointers ] "opengl.gl" add-startup-hook
  23 reset-gl-function-pointers
  24 reset-gl-function-number-counter
  25
  26 : gl-function-counter ( -- n )
  27     +gl-function-counter+ get-global
  28     dup 1 + +gl-function-counter+ set-global ;
  29
  30 : gl-function-pointer ( names n -- funptr )
  31     gl-function-context 2array dup +gl-function-pointers+ get-global at
  32     [ 2nip ] [
  33         [
  34             [ gl-function-address ] map [ ] find nip
  35             dup [ "OpenGL function not available" throw ] unless
  36             dup
  37         ] dip
  38         +gl-function-pointers+ get-global set-at
  39     ] if* ;
  40
  41 : indirect-quot ( function-ptr-quot return types abi -- quot )
  42     '[ @  _ _ _ alien-indirect ] ;
  43
  44 :: define-indirect ( abi return function-name function-ptr-quot types names -- )
  45     function-name create-function
  46     function-ptr-quot return types abi indirect-quot
  47     names return function-effect
  48     define-declared ;
  49
  50 SYNTAX: GL-FUNCTION:
  51     gl-function-calling-convention
  52     scan-function-name
  53     "{" expect "}" parse-tokens over suffix
  54     gl-function-counter '[ _ _ gl-function-pointer ]
  55     scan-c-args define-indirect ;