basis/windows/com/syntax/syntax.factor

   1 USING: alien alien.c-types alien.accessors alien.parser
   2 effects kernel windows.ole32 parser lexer splitting grouping
   3 sequences namespaces assocs quotations generalizations
   4 accessors words macros alien.syntax fry arrays layouts math
   5 classes.struct 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 word 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 ERROR: no-com-interface interface ;
  29
  30 : find-com-interface-definition ( name -- definition )
  31     [
  32         dup +com-interface-definitions+ get-global at*
  33         [ nip ] [ drop no-com-interface ] if
  34     ] [ f ] if* ;
  35
  36 : save-com-interface-definition ( definition -- )
  37     dup word>> +com-interface-definitions+ get-global set-at ;
  38
  39 : (parse-com-function) ( tokens -- definition )
  40     [ second ]
  41     [ first ]
  42     [
  43         3 tail [ CHAR: , swap remove ] map
  44         2 group [ first2 normalize-c-arg 2array ] map
  45         { 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     word>> name>> "-iid" append create-in ;
  55
  56 : (function-word) ( function interface -- word )
  57     swap [ word>> name>> "::" ] [ name>> ] bi*
  58     3append create-in ;
  59
  60 : family-tree ( definition -- definitions )
  61     dup parent>> [ family-tree ] [ { } ] if*
  62     swap suffix ;
  63
  64 : family-tree-functions ( definition -- functions )
  65     dup parent>> [ family-tree-functions ] [ { } ] if*
  66     swap functions>> append ;
  67
  68 : (invocation-quot) ( function return parameters -- quot )
  69     [ first ] map [ com-invoke ] 3curry ;
  70
  71 : (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect )
  72     swap
  73     [ [ second ] map ]
  74     [ dup void? [ drop { } ] [ 1array ] if ] bi*
  75     <effect> ;
  76
  77 : (define-word-for-function) ( function interface n -- )
  78     -rot [ (function-word) swap ] 2keep drop
  79     [ return>> ] [ parameters>> ] bi
  80     [ (invocation-quot) ] 2keep
  81     (stack-effect-from-return-and-parameters)
  82     define-declared ;
  83
  84 : define-words-for-com-interface ( definition -- )
  85     [ [ (iid-word) ] [ iid>> 1quotation ] bi (( -- iid )) define-declared ]
  86     [ word>> void* swap typedef ]
  87     [
  88         dup family-tree-functions
  89         [ (define-word-for-function) ] with each-index
  90     ]
  91     tri ;
  92
  93 PRIVATE>
  94
  95 SYNTAX: COM-INTERFACE:
  96     CREATE-C-TYPE
  97     scan-object find-com-interface-definition
  98     scan string>guid
  99     parse-com-functions
 100     <com-interface-definition>
 101     dup save-com-interface-definition
 102     define-words-for-com-interface ;
 103
 104 SYNTAX: GUID: scan string>guid parsed ;
 105
 106 USING: vocabs vocabs.loader ;
 107
 108 "prettyprint" vocab [
 109     "windows.com.prettyprint" require
 110 ] when