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 locals ;
   6 FROM: alien.parser.private => parse-pointers return-type-name ;
   7 IN: windows.com.syntax
   8
   9 <PRIVATE
  10
  11 MACRO: com-invoke ( n return parameters -- )
  12     [ 2nip length ] 3keep
  13     '[
  14         _ npick *void* _ cell * alien-cell _ _
  15         stdcall alien-indirect
  16     ] ;
  17
  18 TUPLE: com-interface-definition word parent iid functions ;
  19 C: <com-interface-definition> com-interface-definition
  20
  21 TUPLE: com-function-definition return name parameter-types parameter-names ;
  22 C: <com-function-definition> com-function-definition
  23
  24 SYMBOL: +com-interface-definitions+
  25 +com-interface-definitions+ get-global
  26 [ H{ } +com-interface-definitions+ set-global ]
  27 unless
  28
  29 ERROR: no-com-interface interface ;
  30
  31 : find-com-interface-definition ( name -- definition )
  32     [
  33         dup +com-interface-definitions+ get-global at*
  34         [ nip ] [ drop no-com-interface ] if
  35     ] [ f ] if* ;
  36
  37 : save-com-interface-definition ( definition -- )
  38     dup word>> +com-interface-definitions+ get-global set-at ;
  39
  40 : (parse-com-function) ( return name -- definition )
  41     ")" scan-c-args
  42     [ pointer: void prefix ] [ "this" prefix ] bi*
  43     <com-function-definition> ;
  44
  45 :: (parse-com-functions) ( functions -- )
  46     scan dup ";" = [ drop ] [
  47         parse-c-type scan parse-pointers
  48         (parse-com-function) functions push
  49         functions (parse-com-functions)
  50     ] if ;
  51
  52 : parse-com-functions ( -- functions )
  53     V{ } clone [ (parse-com-functions) ] keep >array ;
  54
  55 : (iid-word) ( definition -- word )
  56     word>> name>> "-iid" append create-in ;
  57
  58 : (function-word) ( function interface -- word )
  59     swap [ word>> name>> "::" ] [ name>> ] bi*
  60     3append create-in ;
  61
  62 : family-tree ( definition -- definitions )
  63     dup parent>> [ family-tree ] [ { } ] if*
  64     swap suffix ;
  65
  66 : family-tree-functions ( definition -- functions )
  67     dup parent>> [ family-tree-functions ] [ { } ] if*
  68     swap functions>> append ;
  69
  70 :: (define-word-for-function) ( function interface n -- )
  71     function interface (function-word)
  72     n function [ return>> ] [ parameter-types>> ] bi '[ _ _ _ com-invoke ]
  73     function [ parameter-names>> ] [ return>> ] bi function-effect
  74     define-declared ;
  75
  76 : define-words-for-com-interface ( definition -- )
  77     [ [ (iid-word) ] [ iid>> 1quotation ] bi (( -- iid )) define-declared ]
  78     [
  79         dup family-tree-functions
  80         [ (define-word-for-function) ] with each-index
  81     ] bi ;
  82
  83 PRIVATE>
  84
  85 SYNTAX: COM-INTERFACE:
  86     CREATE-C-TYPE
  87     void* over typedef
  88     scan-object find-com-interface-definition
  89     scan string>guid
  90     parse-com-functions
  91     <com-interface-definition>
  92     dup save-com-interface-definition
  93     define-words-for-com-interface ;
  94
  95 SYNTAX: GUID: scan string>guid suffix! ;
  96
  97 USE: vocabs.loader
  98
  99 { "windows.com" "prettyprint" } "windows.com.prettyprint" require-when