COM unit tests. Remove redundant call-with word and use cleave instead.

extra/bunny/outlined/outlined.factor

@@ -1,5 +1,5 @@
 USING: arrays bunny.model bunny.cel-shaded
-combinators.lib continuations kernel math multiline
+combinators.cleave continuations kernel math multiline
 opengl opengl.shaders opengl.framebuffers opengl.gl
 opengl.capabilities sequences ui.gadgets ;
 IN: bunny.outlined
@@ -177,7 +177,7 @@ TUPLE: bunny-outlined
             [ bunny-outlined-normal-texture [ delete-texture ] when* ]
             [ bunny-outlined-depth-texture  [ delete-texture ] when* ]
             [ f swap set-bunny-outlined-framebuffer-dim ]
-        } call-with
+        } cleave
     ] [ drop ] if ;
 
 : remake-framebuffer-if-needed ( draw -- )
@@ -237,4 +237,4 @@ M: bunny-outlined dispose
         [ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
         [ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
         [ dispose-framebuffer ]
-    } call-with ;
+    } cleave ;

extra/combinators/lib/lib.factor

@@ -130,24 +130,14 @@ MACRO: parallel-call ( quots -- )
 ! map-call and friends
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: (make-call-with) ( quots -- quot ) 
-    [ [ keep ] curry ] map concat [ drop ] append ;
-
-MACRO: call-with ( quots -- )
-    (make-call-with) ;
-
 MACRO: map-call-with ( quots -- )
-    [ (make-call-with) ] keep length [ narray ] curry compose ;
-
-: (make-call-with2) ( quots -- quot )
-    [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
-    [ 2drop ] append ;
-
-MACRO: call-with2 ( quots -- )
-    (make-call-with2) ;
+    [ [ [ keep ] curry ] map concat [ drop ] append ] keep length [ narray ] curry compose ;
 
 MACRO: map-call-with2 ( quots -- )
-    [ (make-call-with2) ] keep length [ narray ] curry append ;
+    [
+        [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
+        [ 2drop ] append    
+    ] keep length [ narray ] curry append ;
 
 MACRO: map-exec-with ( words -- )
     [ 1quotation ] map [ map-call-with ] curry ;

extra/io/windows/files/files.factor

@@ -3,7 +3,8 @@
 USING: alien.c-types io.files io.windows kernel
 math windows windows.kernel32 combinators.cleave
 windows.time calendar combinators math.functions
-sequences combinators.lib namespaces words symbols ;
+sequences combinators.lib combinators.cleave
+namespaces words symbols ;
 IN: io.windows.files
 
 SYMBOLS: +read-only+ +hidden+ +system+
@@ -19,7 +20,7 @@ SYMBOLS: +read-only+ +hidden+ +system+
         [
             first2 expand-constants
             [ swapd mask? [ , ] [ drop ] if ] 2curry
-        ] map call-with
+        ] map cleave
     ] { } make ;
 
 : win32-file-attributes ( n -- seq )

extra/opengl/demo-support/demo-support.factor

@@ -1,4 +1,5 @@
-USING: arrays combinators.lib kernel math math.functions math.vectors namespaces
+USING: arrays combinators.lib combinators.cleave kernel math
+       math.functions math.vectors namespaces
        opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ;
 IN: opengl.demo-support
 
@@ -49,7 +50,7 @@ M: demo-gadget pref-dim* ( gadget -- dim )
     glLoadIdentity
     { [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ]
       [ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ]
-      [ demo-gadget-yaw   0.0 1.0 0.0 glRotatef ] } call-with ;
+      [ demo-gadget-yaw   0.0 1.0 0.0 glRotatef ] } cleave ;
 
 : reset-last-drag-rel ( -- )
     { 0 0 } last-drag-loc set ;

extra/opengl/shaders/shaders.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel opengl.gl alien.c-types continuations namespaces
 assocs alien libc opengl math sequences combinators.lib 
-macros arrays ;
+combinators.cleave macros arrays ;
 IN: opengl.shaders
 
 : with-gl-shader-source-ptr ( string quot -- )
@@ -118,7 +118,7 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
 : (make-with-gl-program) ( uniforms quot -- q )
     [
         \ dup ,
-        [ swap (with-gl-program-uniforms) , \ call-with , % ]
+        [ swap (with-gl-program-uniforms) , \ cleave , % ]
         [ ] make ,
         \ (with-gl-program) ,
     ] [ ] make ;

extra/windows/com/com-tests.factor

@@ -0,0 +1,87 @@
+USING: kernel windows.com windows.com.syntax windows.ole32
+alien alien.syntax tools.test libc ;
+IN: windows.com.tests
+
+! Create some test COM interfaces
+
+COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
+    HRESULT returnOK ( )
+    HRESULT returnError ( ) ;
+
+COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
+    int getX ( ) ;
+    void setX ( int newX ) ;
+
+! Implement the IInherited interface in factor using alien-callbacks
+
+: QueryInterface-callback
+    "HRESULT" { "void*" "REFGUID" "void**" } "stdcall" [ nip 0 -rot set-void*-nth ]
+    alien-callback ;
+: AddRef-callback
+    "ULONG" { "void*" } "stdcall" [ drop 2 ]
+    alien-callback ;
+: Release-callback
+    "ULONG" { "void*" } "stdcall" [ drop 1 ]
+    alien-callback ;
+: returnOK-callback
+    "HRESULT"{ "void*" } "stdcall" [ drop S_OK ]
+    alien-callback ;
+: returnError-callback
+    "HRESULT"{ "void*" } "stdcall" [ drop E_FAIL ]
+    alien-callback ;
+: getX-callback
+    "int" { "void*" } "stdcall" [ test-interface-x ]
+    alien-callback ;
+: setX-callback
+    "void" { "void*" "int" } "stdcall" [ swap set-test-interface-x ]
+    alien-callback ;
+
+SYMBOL: +test-implementation-vtbl+
+{
+    QueryInterface-callback
+    AddRef-callback
+    Release-callback
+    returnOK-callback
+    returnError-callback
+    getX-callback
+    setX-callback
+} [ execute ] map >c-void*-array
++test-implementation-vtbl+ set
+
+C-STRUCT: test-implementation
+    { "void*" "vtbl" }
+    { "int" "x" } ;
+
+: (make-test-implementation) ( x imp -- imp )
+    [ set-test-implementation-x ] keep
+    +test-implementation-vtbl+ get over set-test-implementation-vtbl ;
+
+: <test-implementation> ( x -- imp )
+    "test-implementation" <c-object> (make-test-implementation) ;
+
+! Test that the words defined by COM-INTERFACE: do their magic
+
+"{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test
+"{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test
+"{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test
+S_OK 1array [ 0 <test-implementation> ISimple::returnOK ] unit-test
+E_FAIL 1array [ 0 <test-implementation> ISimple::returnError ] unit-test
+1984 1array [ 0 <test-implementation> dup 1984 IInherited::setX IInherited::getX ] unit-test
+
+! Test that the helper functions for QueryInterface, AddRef, Release work
+
+: <malloced-test-implementation> ( x -- imp )
+    "test-implementation" heap-size malloc (make-test-implementation) ;
+
+SYMBOL: +guinea-pig-implementation+
+
+0 <malloced-test-implementation> +guinea-pig-implementation+ set
+[
+    +guinea-pig-implementation+ get 1array [
+        +guinea-pig-implementation+ get IUnknown-iid com-query-interface
+    ] unit-test
+
+    { } [ +guinea-pig-implementation+ get com-add-ref ] unit-test
+    { } [ +guinea-pig-implementation+ get com-release ] unit-test
+] [ +guinea-pig-implementation+ get free ] [ ] cleanup
+

extra/windows/com/com.factor

@@ -1,8 +1,17 @@
 USING: alien alien.c-types windows.com.syntax windows.ole32
-windows.types ;
+windows.types continuations ;
 IN: windows.com
 
-COM-INTERFACE: IUnknown f
-    HRESULT QueryInterface ( void* this, REFGUID iid, void** ppvObject )
-    ULONG AddRef ( void* this )
-    ULONG Release ( void* this ) ;
+COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
+    HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
+    ULONG AddRef ( )
+    ULONG Release ( ) ;
+
+: com-query-interface ( interface iid -- interface' )
+    f <void*> [ IUnknown::QueryInterface ] keep *void* ;
+
+: com-add-ref ( interface -- )
+    IUnknown::AddRef drop ; inline
+
+: com-release ( interface -- )
+    IUnknown::Release drop ; inline

extra/windows/com/syntax/syntax.factor

@@ -11,10 +11,6 @@ IN: windows.com.syntax
         swap vtbl swap void*-nth
     ] 4 ndip alien-indirect ;
 
-: parse-inheritance
-    scan dup {
-    } case ;
-
 PRIVATE>
 
 : COM-INTERFACE: