From f7ec7cbc441f26ca39bfe4029245d9fb23099db9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 15 Feb 2008 18:08:01 -0800 Subject: [PATCH] ole32.dll bindings --- core/alien/alien-docs.factor | 18 ++++++++++- core/alien/alien.factor | 10 +++++- extra/opengl/shaders/shaders.factor | 9 +++--- extra/windows/ce/ce.factor | 1 + extra/windows/com/com.factor | 8 +++++ extra/windows/com/syntax/syntax.factor | 26 ++++++++++++++++ extra/windows/nt/nt.factor | 1 + extra/windows/ole32/ole32.factor | 43 ++++++++++++++++++++++++++ extra/windows/shell32/shell32.factor | 16 ++-------- 9 files changed, 112 insertions(+), 20 deletions(-) mode change 100644 => 100755 extra/opengl/shaders/shaders.factor mode change 100644 => 100755 extra/windows/ce/ce.factor create mode 100755 extra/windows/com/com.factor create mode 100755 extra/windows/com/syntax/syntax.factor mode change 100644 => 100755 extra/windows/nt/nt.factor create mode 100755 extra/windows/ole32/ole32.factor mode change 100644 => 100755 extra/windows/shell32/shell32.factor diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 19ee52b039..68509db37f 100755 --- a/core/alien/alien-docs.factor +++ b/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 -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:" diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 317dac803e..b644846393 100755 --- 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 @@ -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 ; diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor old mode 100644 new mode 100755 index 0ff708d6d4..7755df6513 --- a/extra/opengl/shaders/shaders.factor +++ b/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" - [ 0 swap glGetAttachedShaders ] keep - ] keep c-uint-array> ; + dup gl-program-shaders-length + dup "GLuint" + 0 swap + [ glGetAttachedShaders ] { 3 1 } out-keep + 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 new mode 100755 index 1180d78a2b..948612b2b2 --- 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.factor b/extra/windows/com/com.factor new file mode 100755 index 0000000000..9543ec7e6a --- /dev/null +++ b/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 ) ; diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor new file mode 100755 index 0000000000..12258644ae --- /dev/null +++ b/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 + + + +: COM-INTERFACE: + scan + parse-inheritance + ";" parse-tokens { ")" } split + [ + ; parsing + diff --git a/extra/windows/nt/nt.factor b/extra/windows/nt/nt.factor old mode 100644 new mode 100755 index 8a709416d8..1dc997b38a --- 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 index 0000000000..6d62e17d6c --- /dev/null +++ b/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" [ CLSIDFromString ole32-error ] keep ; +: guid>string ( guid -- string ) + GUID-STRING-LENGTH 1+ [ "ushort" ] keep + [ StringFromGUID2 drop ] { 2 } out-keep alien>u16-string ; + diff --git a/extra/windows/shell32/shell32.factor b/extra/windows/shell32/shell32.factor old mode 100644 new mode 100755 index 501f49edfe..1d8d67dad7 --- 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