Merge branch 'master' of git://factorcode.org/git/factor

Conflicts:

	extra/combinators/lib/lib.factor
	extra/io/windows/files/files.factor
	extra/opengl/demo-support/demo-support.factor
	extra/opengl/shaders/shaders.factor

diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index 0369d55fb3b059fff31c95d746844c9beced221d..b58c685cf8f9551802f938be3478c1eab5d699bf 100755 (executable)
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs kernel math namespaces sequences system
-kernel.private tuples bit-arrays byte-arrays float-arrays ;
+kernel.private tuples bit-arrays byte-arrays float-arrays 
+shuffle arrays macros ;
 IN: alien
 
 ! Some predicate classes used by the compiler for optimization

diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor
index 012aa1fd783865a5ca716c97e7332b145d3abaf7..6295e3b9ded137815cbf6f1f1a6b61894d3f18aa 100755 (executable)
--- 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 combinators.cleave ;
 IN: bunny.outlined

diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index 7c93f805cd6175fadc55cc742d46387666b715bd..e177e33c15e807de0c18eec29399e6366814290c 100755 (executable)
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -141,7 +141,10 @@ MACRO: map-call-with ( quots -- )
     [ 2drop ] append ;
 
 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 ;
@@ -163,5 +166,12 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
 : and? ( obj quot1 quot2 -- ? )
     >r keep r> rot [ call ] [ 2drop f ] if ; inline
 
+MACRO: multikeep ( word out-indexes -- ... )
+    [
+        dup >r [ \ npick \ >r 3array % ] each
+        %
+        r> [ drop \ r> , ] each
+    ] [ ] make ;
+
 : retry ( quot n -- )
     [ drop ] rot compose attempt-all ; inline

diff --git a/extra/opengl/gl/macosx/macosx.factor b/extra/opengl/gl/macosx/macosx.factor
index 3d4cb6ae93dd660e0181742a9b0cabee95fa95cd..eb8dda5e33ebd14345347a75d32dc20430e287f6 100644 (file)
--- a/extra/opengl/gl/macosx/macosx.factor
+++ b/extra/opengl/gl/macosx/macosx.factor
@@ -2,5 +2,5 @@ USING: kernel alien ;
 IN: opengl.gl.macosx
 
 : gl-function-context ( -- context ) 0 ; inline
-: gl-function-address ( name -- address ) "gl" load-library dlsym ; inline
+: gl-function-address ( name -- address ) f dlsym ; inline
 : gl-function-calling-convention ( -- str ) "cdecl" ; inline

diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor
index ceda434c752577aa1620991c4599d95c681397e0..7403b7cb0589887cde74a0c2c137b94546c0d3a0 100755 (executable)
--- 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 ;
+combinators.cleave macros arrays ;
 IN: opengl.shaders
 
 : with-gl-shader-source-ptr ( string quot -- )
@@ -92,10 +92,11 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
     GL_ATTACHED_SHADERS gl-program-get-int ; inline
 
 : gl-program-shaders ( program -- shaders )
-    dup gl-program-shaders-length [
-        dup "GLuint" <c-array>
-        [ 0 <int> swap glGetAttachedShaders ] keep
-    ] keep c-uint-array> ;
+    dup gl-program-shaders-length
+    dup "GLuint" <c-array>
+    0 <int> swap
+    [ glGetAttachedShaders ] { 3 1 } multikeep
+    c-uint-array> ;
 
 : delete-gl-program-only ( program -- )
     glDeleteProgram ; inline

diff --git a/extra/windows/ce/ce.factor b/extra/windows/ce/ce.factor
old mode 100644 (file)
new mode 100755 (executable)
index 1180d78..948612b
--- a/extra/windows/ce/ce.factor
+++ b/extra/windows/ce/ce.factor
@@ -11,4 +11,5 @@ USING: alien sequences ;
     ! { "gl"       "libGLES_CM.dll"         "stdcall" }
     ! { "glu"      "libGLES_CM.dll"         "stdcall" }
     ! { "freetype" "libfreetype-6.dll"      "stdcall" }
+    { "ole32"    "ole32.dll"    "stdcall" }
 } [ first3 add-library ] each

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

diff --git a/extra/windows/com/com.factor b/extra/windows/com/com.factor
new file mode 100755 (executable)
index 0000000..477eaad
--- /dev/null
+++ b/extra/windows/com/com.factor
@@ -0,0 +1,17 @@
+USING: alien alien.c-types windows.com.syntax windows.ole32\r
+windows.types continuations ;\r
+IN: windows.com\r
+\r
+COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}\r
+    HRESULT QueryInterface ( REFGUID iid, void** ppvObject )\r
+    ULONG AddRef ( )\r
+    ULONG Release ( ) ;\r
+\r
+: com-query-interface ( interface iid -- interface' )\r
+    f <void*> [ IUnknown::QueryInterface ] keep *void* ;\r
+\r
+: com-add-ref ( interface -- )\r
+    IUnknown::AddRef drop ; inline\r
+\r
+: com-release ( interface -- )\r
+    IUnknown::Release drop ; inline\r

diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor
new file mode 100755 (executable)
index 0000000..0895c0e
--- /dev/null
+++ b/extra/windows/com/syntax/syntax.factor
@@ -0,0 +1,22 @@
+USING: alien alien.c-types kernel windows windows.ole32\r
+combinators.lib parser splitting sequences.lib ;\r
+IN: windows.com.syntax\r
+\r
+<PRIVATE\r
+\r
+: vtbl ( interface -- vtbl )\r
+    *void* ; inline\r
+: com-invoke ( ... interface n funcptr return parameters -- )\r
+    "stdcall" [\r
+        swap vtbl swap void*-nth\r
+    ] 4 ndip alien-indirect ;\r
+\r
+PRIVATE>\r
+\r
+: COM-INTERFACE:\r
+    scan\r
+    parse-inheritance\r
+    ";" parse-tokens { ")" } split\r
+    [ \r
+    ; parsing\r
+\r

diff --git a/extra/windows/nt/nt.factor b/extra/windows/nt/nt.factor
old mode 100644 (file)
new mode 100755 (executable)
index 8a70941..1dc997b
--- a/extra/windows/nt/nt.factor
+++ b/extra/windows/nt/nt.factor
@@ -12,4 +12,5 @@ USING: alien sequences ;
     { "gl"       "opengl32.dll" "stdcall" }
     { "glu"      "glu32.dll"    "stdcall" }
     { "freetype" "freetype6.dll" "cdecl"  }
+    { "ole32"    "ole32.dll"    "stdcall" }
 } [ first3 add-library ] each

diff --git a/extra/windows/ole32/ole32.factor b/extra/windows/ole32/ole32.factor
new file mode 100755 (executable)
index 0000000..ec0b02b
--- /dev/null
+++ b/extra/windows/ole32/ole32.factor
@@ -0,0 +1,43 @@
+USING: alien alien.syntax alien.c-types math kernel sequences\r
+windows windows.types combinators.lib ;\r
+IN: windows.ole32\r
+\r
+LIBRARY: ole32\r
+\r
+C-STRUCT: GUID\r
+    { "DWORD" "part1" }\r
+    { "DWORD" "part2" }\r
+    { "DWORD" "part3" }\r
+    { "DWORD" "part4" } ;\r
+\r
+TYPEDEF: void* REFGUID\r
+TYPEDEF: void* LPUNKNOWN\r
+TYPEDEF: ushort* LPOLESTR\r
+\r
+FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv ) ;\r
+FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 ) ;\r
+FUNCTION: int StringFromGUID2 ( REFGUID rguid, LPOLESTR lpsz, int cchMax ) ;\r
+FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;\r
+\r
+: S_OK 0 ; inline\r
+: S_FALSE 1 ; inline\r
+: E_FAIL HEX: 80004005 ; inline\r
+: E_INVALIDARG HEX: 80070057 ; inline\r
+\r
+: ole32-error ( n -- )\r
+    dup S_OK = [\r
+        drop\r
+    ] [ (win32-error-string) throw ] if ;\r
+\r
+: guid= ( a b -- ? )\r
+    IsEqualGUID c-bool> ;\r
+\r
+: GUID-STRING-LENGTH\r
+    "{01234567-89ab-cdef-0123-456789abcdef}" length ; inline\r
+\r
+: string>guid ( string -- guid )\r
+    string>u16-alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;\r
+: guid>string ( guid -- string )\r
+    GUID-STRING-LENGTH 1+ [ "ushort" <c-array> ] keep\r
+    [ StringFromGUID2 drop ] { 2 } multikeep alien>u16-string ;\r
+\r

diff --git a/extra/windows/shell32/shell32.factor b/extra/windows/shell32/shell32.factor
old mode 100644 (file)
new mode 100755 (executable)
index 501f49e..1d8d67d
--- a/extra/windows/shell32/shell32.factor
+++ b/extra/windows/shell32/shell32.factor
@@ -1,5 +1,5 @@
 USING: alien alien.c-types alien.syntax combinators
-kernel windows windows.user32 ;
+kernel windows windows.user32 windows.ole32 ;
 IN: windows.shell32
 
 : CSIDL_DESKTOP HEX: 00 ; inline
@@ -68,10 +68,6 @@ IN: windows.shell32
 : CSIDL_FLAG_MASK HEX: ff00 ; inline
 
 
-: S_OK 0 ; inline
-: S_FALSE 1 ; inline
-: E_FAIL HEX: 80004005 ; inline
-: E_INVALIDARG HEX: 80070057 ; inline
 : ERROR_FILE_NOT_FOUND 2 ; inline
 
 : SHGFP_TYPE_CURRENT 0 ; inline
@@ -89,15 +85,7 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi
     f "open" rot f f SW_SHOWNORMAL ShellExecute drop ;
 
 : shell32-error ( n -- )
-    dup S_OK = [
-        drop
-    ] [
-        {
-            ! { ERROR_FILE_NOT_FOUND [ "file not found" throw ] }
-            ! { E_INVALIDARG [ "invalid arg" throw ] }
-            [ (win32-error-string) throw ]
-        } case
-    ] if ;
+    ole32-error ; inline
 
 : shell32-directory ( n -- str )
     f swap f SHGFP_TYPE_DEFAULT