basis/windows/com/syntax/syntax.factor

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