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