100 lines
3.0 KiB
Factor
100 lines
3.0 KiB
Factor
USING: alien alien.c-types alien.data alien.accessors
|
|
alien.parser effects kernel windows.ole32 parser lexer splitting
|
|
grouping sequences namespaces assocs quotations generalizations
|
|
accessors words macros alien.syntax fry arrays layouts math
|
|
classes.struct windows.kernel32 locals ;
|
|
FROM: alien.parser.private => parse-pointers ;
|
|
IN: windows.com.syntax
|
|
|
|
<PRIVATE
|
|
|
|
MACRO: com-invoke ( n return parameters -- quot )
|
|
[ 2nip length ] 3keep
|
|
'[
|
|
_ npick void* deref _ cell * alien-cell _ _
|
|
stdcall alien-indirect
|
|
] ;
|
|
|
|
TUPLE: com-interface-definition word parent iid functions ;
|
|
C: <com-interface-definition> com-interface-definition
|
|
|
|
TUPLE: com-function-definition return name parameter-types parameter-names ;
|
|
C: <com-function-definition> com-function-definition
|
|
|
|
SYMBOL: +com-interface-definitions+
|
|
+com-interface-definitions+ get-global
|
|
[ H{ } +com-interface-definitions+ set-global ]
|
|
unless
|
|
|
|
ERROR: no-com-interface interface ;
|
|
|
|
: find-com-interface-definition ( name -- definition )
|
|
[
|
|
dup +com-interface-definitions+ get-global at*
|
|
[ nip ] [ drop no-com-interface ] if
|
|
] [ f ] if* ;
|
|
|
|
: save-com-interface-definition ( definition -- )
|
|
dup word>> +com-interface-definitions+ get-global set-at ;
|
|
|
|
: (parse-com-function) ( return name -- definition )
|
|
scan-c-args
|
|
[ pointer: void prefix ] [ "this" prefix ] bi*
|
|
<com-function-definition> ;
|
|
|
|
:: (parse-com-functions) ( functions -- )
|
|
scan-token dup ";" = [ drop ] [
|
|
parse-c-type scan-token parse-pointers
|
|
(parse-com-function) functions push
|
|
functions (parse-com-functions)
|
|
] if ;
|
|
|
|
: parse-com-functions ( -- functions )
|
|
V{ } clone [ (parse-com-functions) ] keep >array ;
|
|
|
|
: (iid-word) ( definition -- word )
|
|
word>> name>> "-iid" append create-word-in ;
|
|
|
|
: (function-word) ( function interface -- word )
|
|
swap [ word>> name>> "::" ] [ name>> ] bi*
|
|
3append create-word-in ;
|
|
|
|
: family-tree ( definition -- definitions )
|
|
dup parent>> [ family-tree ] [ { } ] if*
|
|
swap suffix ;
|
|
|
|
: family-tree-functions ( definition -- functions )
|
|
dup parent>> [ family-tree-functions ] [ { } ] if*
|
|
swap functions>> append ;
|
|
|
|
:: (define-word-for-function) ( function interface n -- )
|
|
function interface (function-word)
|
|
n function [ return>> ] [ parameter-types>> ] bi '[ _ _ _ com-invoke ]
|
|
function [ parameter-names>> ] [ return>> ] bi function-effect
|
|
define-declared ;
|
|
|
|
: define-words-for-com-interface ( definition -- )
|
|
[ [ (iid-word) ] [ iid>> 1quotation ] bi ( -- iid ) define-declared ]
|
|
[
|
|
dup family-tree-functions
|
|
[ (define-word-for-function) ] with each-index
|
|
] bi ;
|
|
|
|
PRIVATE>
|
|
|
|
SYNTAX: COM-INTERFACE:
|
|
CREATE-C-TYPE
|
|
void* over typedef
|
|
scan-object find-com-interface-definition
|
|
scan-token string>guid
|
|
parse-com-functions
|
|
<com-interface-definition>
|
|
dup save-com-interface-definition
|
|
define-words-for-com-interface ;
|
|
|
|
SYNTAX: GUID: scan-token string>guid suffix! ;
|
|
|
|
USE: vocabs.loader
|
|
|
|
{ "windows.com" "prettyprint" } "windows.com.prettyprint" require-when
|