1 USING: alien alien.c-types alien.accessors effects kernel
2 windows.ole32 parser lexer splitting grouping sequences
3 namespaces assocs quotations generalizations accessors words
4 macros alien.syntax fry arrays layouts math classes.struct
5 windows.kernel32 prettyprint.custom prettyprint.sections ;
10 MACRO: com-invoke ( n return parameters -- )
13 _ npick *void* _ cell * alien-cell _ _
14 "stdcall" alien-indirect
17 TUPLE: com-interface-definition name parent iid functions ;
18 C: <com-interface-definition> com-interface-definition
20 TUPLE: com-function-definition name return parameters ;
21 C: <com-function-definition> com-function-definition
23 SYMBOL: +com-interface-definitions+
24 +com-interface-definitions+ get-global
25 [ H{ } +com-interface-definitions+ set-global ]
28 : find-com-interface-definition ( name -- definition )
29 dup "f" = [ drop f ] [
30 dup +com-interface-definitions+ get-global at*
32 [ " COM interface hasn't been defined" prepend throw ]
36 : save-com-interface-definition ( definition -- )
37 dup name>> +com-interface-definitions+ get-global set-at ;
39 : (parse-com-function) ( tokens -- definition )
42 [ 3 tail [ CHAR: , swap remove ] map 2 group { "void*" "this" } prefix ]
44 <com-function-definition> ;
46 : parse-com-functions ( -- functions )
47 ";" parse-tokens { ")" } split harvest
48 [ (parse-com-function) ] map ;
50 : (iid-word) ( definition -- word )
51 name>> "-iid" append create-in ;
53 : (function-word) ( function interface -- word )
54 name>> "::" rot name>> 3append create-in ;
56 : family-tree ( definition -- definitions )
57 dup parent>> [ family-tree ] [ { } ] if*
60 : family-tree-functions ( definition -- functions )
61 dup parent>> [ family-tree-functions ] [ { } ] if*
62 swap functions>> append ;
64 : (invocation-quot) ( function return parameters -- quot )
65 [ first ] map [ com-invoke ] 3curry ;
67 : (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect )
70 [ dup "void" = [ drop { } ] [ 1array ] if ] bi*
73 : (define-word-for-function) ( function interface n -- )
74 -rot [ (function-word) swap ] 2keep drop
75 [ return>> ] [ parameters>> ] bi
76 [ (invocation-quot) ] 2keep
77 (stack-effect-from-return-and-parameters)
80 : define-words-for-com-interface ( definition -- )
81 [ [ (iid-word) ] [ iid>> 1quotation ] bi (( -- iid )) define-declared ]
82 [ name>> "com-interface" swap typedef ]
84 dup family-tree-functions
85 [ (define-word-for-function) ] with each-index
91 SYNTAX: COM-INTERFACE:
93 scan find-com-interface-definition
96 <com-interface-definition>
97 dup save-com-interface-definition
98 define-words-for-com-interface ;
100 SYNTAX: GUID: scan string>guid parsed ;
102 M: GUID pprint* guid>string "GUID: " prepend text ;