Use define-declared to stick explicit stack effects on windows.com words

extra/windows/com/com-tests.factor

@@ -1,7 +1,7 @@
 USING: kernel windows.com windows.com.syntax windows.ole32
 alien alien.syntax tools.test libc alien.c-types arrays.lib 
 namespaces arrays continuations accessors math windows.com.wrapper
-windows.com.wrapper.private destructors ;
+windows.com.wrapper.private destructors effects ;
 IN: windows.com.tests
 
 COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
@@ -21,6 +21,12 @@ COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c}
 "{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test
 "{b06ac3f4-30e4-406b-a7cd-c29cead4552c}" string>guid 1array [ IUnrelated-iid ] unit-test
 
+{ (( -- iid )) } [ \ ISimple-iid stack-effect ] unit-test
+{ (( this -- HRESULT )) } [ \ ISimple::returnOK stack-effect ] unit-test
+{ (( this -- int )) } [ \ IInherited::getX stack-effect ] unit-test
+{ (( this newX -- )) } [ \ IInherited::setX stack-effect ] unit-test
+{ (( this mul add -- int )) } [ \ IUnrelated::xMulAdd stack-effect ] unit-test
+
 SYMBOL: +test-wrapper+
 SYMBOL: +guinea-pig-implementation+
 SYMBOL: +orig-wrapped-objects+
@@ -49,7 +55,11 @@ dup +test-wrapper+ set [
 
         S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test
         E_FAIL <long> *long 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
-        20 1array [ +guinea-pig-implementation+ get dup 20 IInherited::setX IInherited::getX ] unit-test
+        20 1array [
+            +guinea-pig-implementation+ get
+            [ 20 IInherited::setX ]
+            [ IInherited::getX ] bi
+        ] unit-test
         420 1array [
             +guinea-pig-implementation+ get
             IUnrelated-iid com-query-interface

extra/windows/com/syntax/syntax.factor

@@ -1,7 +1,7 @@
-USING: alien alien.c-types kernel windows.ole32 combinators.lib
+USING: alien alien.c-types effects kernel windows.ole32 combinators.lib
 parser splitting grouping sequences.lib sequences namespaces
 assocs quotations shuffle accessors words macros alien.syntax
-fry ;
+fry arrays ;
 IN: windows.com.syntax
 
 <PRIVATE
@@ -41,7 +41,7 @@ unless
 : (parse-com-function) ( tokens -- definition )
     [ second ]
     [ first ]
-    [ 3 tail 2 group [ first ] map "void*" prefix ]
+    [ 3 tail [ CHAR: , swap remove ] map 2 group { "void*" "this" } prefix ]
     tri
     <com-function-definition> ;
 
@@ -63,14 +63,24 @@ unless
     dup parent>> [ family-tree-functions ] [ { } ] if*
     swap functions>> append ;
 
+: (invocation-quot) ( function return parameters -- quot )
+    [ first ] map [ com-invoke ] 3curry ;
+
+: (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect )
+    swap
+    [ [ second ] map ]
+    [ dup "void" = [ drop { } ] [ 1array ] if ] bi*
+    <effect> ;
+
 : (define-word-for-function) ( function interface n -- )
     -rot [ (function-word) swap ] 2keep drop
     { return>> parameters>> } get-slots
-    [ com-invoke ] 3curry
-    define ;
+    [ (invocation-quot) ] 2keep
+    (stack-effect-from-return-and-parameters)
+    define-declared ;
 
 : define-words-for-com-interface ( definition -- )
-    [ [ (iid-word) ] [ iid>> 1quotation ] bi define ]
+    [ [ (iid-word) ] [ iid>> 1quotation ] bi (( -- iid )) define-declared ]
     [ name>> "com-interface" swap typedef ]
     [
         dup family-tree-functions

extra/windows/com/wrapper/wrapper.factor

@@ -29,7 +29,7 @@ unless
             >r find-com-interface-definition family-tree
             r> 1quotation [ >r iid>> r> 2array ] curry map
         ] map-index concat
-        [ f ] suffix ,
+        [ drop f ] suffix ,
         \ case ,
         "void*" heap-size
         [ * rot <displaced-alien> com-add-ref 0 rot set-void*-nth S_OK ]
@@ -69,13 +69,14 @@ unless
 
 : compile-alien-callback ( return parameters abi quot -- alien )
     [ alien-callback ] 4 ncurry
-    [ gensym [ swap define ] keep ] with-compilation-unit
+    [ gensym [ swap (( -- alien )) define-declared ] keep ]
+    with-compilation-unit
     execute ;
 
 : (make-vtbl) ( interface-name quots iunknown-methods n -- )
     (thunk) (thunked-quots)
     swap find-com-interface-definition family-tree-functions [
-        { return>> parameters>> } get-slots
+        [ return>> ] [ parameters>> [ first ] map ] bi
         dup length 1- roll [
             first dup empty?
             [ 2drop [ ] ]