ole32.dll bindings

core/alien/alien-docs.factor

@@ -145,7 +145,23 @@ HELP: alien-callback
 }
 { $errors "Throws an " { $link alien-callback-error } " if the word calling " { $link alien-callback } " is not compiled." } ;
 
-{ alien-invoke alien-indirect alien-callback } related-words
+HELP: out-keep
+{ $values { "quot" "A quotation" } { "out-indexes" "A sequence of indexes relative to the top of the stack" } }
+{ $description
+    "Invokes " { $snippet "quot" } ", restoring the values to the stack indicated by " { $snippet "out-indexes" } ". This word is useful for calling C functions with out parameters. " { $snippet "quot" } " can invoke the function and manipulate its return value, after which the actually interesting values stored in the out parameters are brought back to the top of the stack." }
+{ $notes "The indexes in " { $snippet "out-indexes" } " are relative to the top of the stack, with " { $snippet "1" } " indicating the topmost value. This means that the indexes are reversed relative to the order in the C prototype; 1 indicates the rightmost parameter, and higher numbers count leftward." }
+{ $examples
+    "A simple wrapper around memcpy (pretending that the return value is not equal to the out parameter):"
+    { $code
+        "LIBRARY: libc"
+        "FUNCTION: void* memcpy ( void* out, void* in, size_t n ) ;"
+        ": copy-byte-array ( a -- a' )"
+        "    dup length dup <byte-array> -rot"
+        "    [ memcpy drop ] { 3 } out-keep ;"
+    }
+} ;
+
+{ alien-invoke alien-indirect alien-callback out-keep } related-words
 
 ARTICLE: "aliens" "Alien addresses"
 "Instances of the " { $link alien } " class represent pointers to C data outside the Factor heap:"

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
@@ -89,3 +90,10 @@ TUPLE: alien-invoke-error library symbol ;
 
 : alien-invoke ( ... return library function parameters -- ... )
     2over \ alien-invoke-error construct-boa throw ;
+
+MACRO: out-keep ( word out-indexes -- ... )
+    [
+        dup >r [ \ npick \ >r 3array % ] each
+        %
+        r> [ drop \ r> , ] each
+    ] [ ] make ;

extra/opengl/shaders/shaders.factor

@@ -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 } out-keep
+    c-uint-array> ;
 
 : delete-gl-program-only ( program -- )
     glDeleteProgram ; inline

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

extra/windows/com/com.factor

@@ -0,0 +1,8 @@
+USING: alien alien.c-types windows.com.syntax windows.ole32
+windows.types ;
+IN: windows.com
+
+COM-INTERFACE: IUnknown f
+    HRESULT QueryInterface ( void* this, REFGUID iid, void** ppvObject )
+    ULONG AddRef ( void* this )
+    ULONG Release ( void* this ) ;

extra/windows/com/syntax/syntax.factor

@@ -0,0 +1,26 @@
+USING: alien alien.c-types kernel windows windows.ole32
+combinators.lib parser splitting sequences.lib ;
+IN: windows.com.syntax
+
+<PRIVATE
+
+: vtbl ( interface -- vtbl )
+    *void* ; inline
+: com-invoke ( ... interface n funcptr return parameters -- )
+    "stdcall" [
+        swap vtbl swap void*-nth
+    ] 4 ndip alien-indirect ;
+
+: parse-inheritance
+    scan dup {
+    } case ;
+
+PRIVATE>
+
+: COM-INTERFACE:
+    scan
+    parse-inheritance
+    ";" parse-tokens { ")" } split
+    [ 
+    ; parsing
+

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

extra/windows/ole32/ole32.factor

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

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