From fe9ab0e26ba5a272bf3dbf97aecdcf4e3375eac4 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 15 Mar 2008 17:45:05 -0700
Subject: [PATCH] COM unit tests. Remove redundant call-with word and use
cleave instead.
---
extra/bunny/outlined/outlined.factor | 6 +-
extra/combinators/lib/lib.factor | 20 ++---
extra/io/windows/files/files.factor | 5 +-
extra/opengl/demo-support/demo-support.factor | 5 +-
extra/opengl/shaders/shaders.factor | 4 +-
extra/windows/com/com-tests.factor | 87 +++++++++++++++++++
extra/windows/com/com.factor | 19 ++--
extra/windows/com/syntax/syntax.factor | 4 -
8 files changed, 117 insertions(+), 33 deletions(-)
create mode 100755 extra/windows/com/com-tests.factor
diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor
index d7064ebdde..67617b0273 100644
--- a/extra/bunny/outlined/outlined.factor
+++ b/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 ;
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index 99386272f3..c617466d1b 100755
--- a/extra/combinators/lib/lib.factor
+++ b/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 ;
diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor
index 3d51e65116..afd2a09e08 100644
--- a/extra/io/windows/files/files.factor
+++ b/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 )
diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor
index 59b7a3bcc3..f7df84cbda 100644
--- a/extra/opengl/demo-support/demo-support.factor
+++ b/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 ;
diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor
index c8186e55c3..7403b7cb05 100755
--- a/extra/opengl/shaders/shaders.factor
+++ b/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 ;
diff --git a/extra/windows/com/com-tests.factor b/extra/windows/com/com-tests.factor
new file mode 100755
index 0000000000..2e6e8a9c22
--- /dev/null
+++ b/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
+
diff --git a/extra/windows/com/com.factor b/extra/windows/com/com.factor
index 9543ec7e6a..477eaad038 100755
--- a/extra/windows/com/com.factor
+++ b/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
diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor
index 12258644ae..0895c0e201 100755
--- a/extra/windows/com/syntax/syntax.factor
+++ b/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: