basis/windows/com/syntax/syntax.factor

   1 USING: alien alien.c-types effects kernel windows.ole32
   2 parser lexer splitting grouping sequences namespaces
   3 assocs quotations generalizations accessors words macros alien.syntax
   4 fry arrays ;
   5 IN: windows.com.syntax
   6
   7 <PRIVATE
   8
   9 C-STRUCT: com-interface
  10     { "void*" "vtbl" } ;
  11
  12 MACRO: com-invoke ( n return parameters -- )
  13     dup length -roll
  14     '[
  15         _ npick com-interface-vtbl _ swap void*-nth _ _
  16         "stdcall" alien-indirect
  17     ] ;
  18
  19 TUPLE: com-interface-definition name parent iid functions ;
  20 C: <com-interface-definition> com-interface-definition
  21
  22 TUPLE: com-function-definition name return parameters ;
  23 C: <com-function-definition> com-function-definition
  24
  25 SYMBOL: +com-interface-definitions+
  26 +com-interface-definitions+ get-global
  27 [ H{ } +com-interface-definitions+ set-global ]
  28 unless
  29
  30 : find-com-interface-definition ( name -- definition )
  31     dup "f" = [ drop f ] [
  32         dup +com-interface-definitions+ get-global at*
  33         [ nip ]
  34         [ swap " COM interface hasn't been defined" append throw ]
  35         if
  36     ] if ;
  37
  38 : save-com-interface-definition ( definition -- )
  39     dup name>> +com-interface-definitions+ get-global set-at ;
  40
  41 : (parse-com-function) ( tokens -- definition )
  42     [ second ]
  43     [ first ]
  44     [ 3 tail [ CHAR: , swap remove ] map 2 group { "void*" "this" } prefix ]
  45     tri
  46     <com-function-definition> ;
  47
  48 : parse-com-functions ( -- functions )
  49     ";" parse-tokens { ")" } split harvest
  50     [ (parse-com-function) ] map ;
  51
  52 : (iid-word) ( definition -- word )
  53     name>> "-iid" append create-in ;
  54
  55 : (function-word) ( function interface -- word )
  56     name>> "::" rot name>> 3append create-in ;
  57
  58 : family-tree ( definition -- definitions )
  59     dup parent>> [ family-tree ] [ { } ] if*
  60     swap suffix ;
  61
  62 : family-tree-functions ( definition -- functions )
  63     dup parent>> [ family-tree-functions ] [ { } ] if*
  64     swap functions>> append ;
  65
  66 : (invocation-quot) ( function return parameters -- quot )
  67     [ first ] map [ com-invoke ] 3curry ;
  68
  69 : (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect )
  70     swap
  71     [ [ second ] map ]
  72     [ dup "void" = [ drop { } ] [ 1array ] if ] bi*
  73     <effect> ;
  74
  75 : (define-word-for-function) ( function interface n -- )
  76     -rot [ (function-word) swap ] 2keep drop
  77     [ return>> ] [ parameters>> ] bi
  78     [ (invocation-quot) ] 2keep
  79     (stack-effect-from-return-and-parameters)
  80     define-declared ;
  81
  82 : define-words-for-com-interface ( definition -- )
  83     [ [ (iid-word) ] [ iid>> 1quotation ] bi (( -- iid )) define-declared ]
  84     [ name>> "com-interface" swap typedef ]
  85     [
  86         dup family-tree-functions
  87         [ (define-word-for-function) ] with each-index
  88     ]
  89     tri ;
  90
  91 PRIVATE>
  92
  93 : COM-INTERFACE:
  94     scan
  95     scan find-com-interface-definition
  96     scan string>guid
  97     parse-com-functions
  98     <com-interface-definition>
  99     dup save-com-interface-definition
 100     define-words-for-com-interface
 101     ; parsing
 102
 103 : GUID: scan string>guid parsed ; parsing