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 ; + +: ( x -- imp ) + "test-implementation" (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 ISimple::returnOK ] unit-test +E_FAIL 1array [ 0 ISimple::returnError ] unit-test +1984 1array [ 0 dup 1984 IInherited::setX IInherited::getX ] unit-test + +! Test that the helper functions for QueryInterface, AddRef, Release work + +: ( x -- imp ) + "test-implementation" heap-size malloc (make-test-implementation) ; + +SYMBOL: +guinea-pig-implementation+ + +0 +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 [ 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: