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
9 C-STRUCT: com-interface
12 MACRO: com-invoke ( n return parameters -- )
15 _ npick com-interface-vtbl _ swap void*-nth _ _
16 "stdcall" alien-indirect
19 TUPLE: com-interface-definition name parent iid functions ;
20 C: <com-interface-definition> com-interface-definition
22 TUPLE: com-function-definition name return parameters ;
23 C: <com-function-definition> com-function-definition
25 SYMBOL: +com-interface-definitions+
26 +com-interface-definitions+ get-global
27 [ H{ } +com-interface-definitions+ set-global ]
30 : find-com-interface-definition ( name -- definition )
31 dup "f" = [ drop f ] [
32 dup +com-interface-definitions+ get-global at*
34 [ swap " COM interface hasn't been defined" append throw ]
38 : save-com-interface-definition ( definition -- )
39 dup name>> +com-interface-definitions+ get-global set-at ;
41 : (parse-com-function) ( tokens -- definition )
44 [ 3 tail [ CHAR: , swap remove ] map 2 group { "void*" "this" } prefix ]
46 <com-function-definition> ;
48 : parse-com-functions ( -- functions )
49 ";" parse-tokens { ")" } split harvest
50 [ (parse-com-function) ] map ;
52 : (iid-word) ( definition -- word )
53 name>> "-iid" append create-in ;
55 : (function-word) ( function interface -- word )
56 name>> "::" rot name>> 3append create-in ;
58 : family-tree ( definition -- definitions )
59 dup parent>> [ family-tree ] [ { } ] if*
62 : family-tree-functions ( definition -- functions )
63 dup parent>> [ family-tree-functions ] [ { } ] if*
64 swap functions>> append ;
66 : (invocation-quot) ( function return parameters -- quot )
67 [ first ] map [ com-invoke ] 3curry ;
69 : (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect )
72 [ dup "void" = [ drop { } ] [ 1array ] if ] bi*
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)
82 : define-words-for-com-interface ( definition -- )
83 [ [ (iid-word) ] [ iid>> 1quotation ] bi (( -- iid )) define-declared ]
84 [ name>> "com-interface" swap typedef ]
86 dup family-tree-functions
87 [ (define-word-for-function) ] with each-index
95 scan find-com-interface-definition
98 <com-interface-definition>
99 dup save-com-interface-definition
100 define-words-for-com-interface
103 : GUID: scan string>guid parsed ; parsing