Merge branch 'master' of git://pgdn.org/factor
						commit
						8f521b07f2
					
				| 
						 | 
				
			
			@ -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
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -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
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -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
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -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
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -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
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -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
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -0,0 +1 @@
 | 
			
		|||
Joe Groff
 | 
			
		||||
| 
						 | 
				
			
			@ -0,0 +1,15 @@
 | 
			
		|||
USING: help.markup help.syntax io kernel math quotations
 | 
			
		||||
multiline ;
 | 
			
		||||
IN: windows.com
 | 
			
		||||
 | 
			
		||||
HELP: com-query-interface
 | 
			
		||||
{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } { "iid" "An interface GUID (IID)" } { "interface'" "Pointer to a COM interface implementing the interface indicated by " { $snippet "iid" } } }
 | 
			
		||||
{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be immediately retained using " { $link com-add-ref } ". The pointer must then be released using " { $link com-release } " when it is no longer needed." } ;
 | 
			
		||||
 | 
			
		||||
HELP: com-add-ref
 | 
			
		||||
{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }
 | 
			
		||||
{ $description "A small wrapper around " { $link IUnknown::AddRef } ". Increments the reference count on " { $snippet "interface" } ", keeping it on the stack. The reference count must be decremented with " { $link com-release } " when the reference is no longer held." } ;
 | 
			
		||||
 | 
			
		||||
HELP: com-release
 | 
			
		||||
{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }
 | 
			
		||||
{ $description "A small wrapper around " { $link IUnknown::Release } ". Decrements the reference count on " { $snippet "interface" } ", releasing the underlying object if the reference count has reached zero." } ;
 | 
			
		||||
| 
						 | 
				
			
			@ -0,0 +1,93 @@
 | 
			
		|||
USING: kernel windows.com windows.com.syntax windows.ole32
 | 
			
		||||
alien alien.syntax tools.test libc alien.c-types arrays.lib 
 | 
			
		||||
namespaces arrays continuations ;
 | 
			
		||||
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
 | 
			
		||||
 | 
			
		||||
C-STRUCT: test-implementation
 | 
			
		||||
    { "void*" "vtbl" }
 | 
			
		||||
    { "int" "x" } ;
 | 
			
		||||
 | 
			
		||||
: QueryInterface-callback
 | 
			
		||||
    "HRESULT" { "void*" "REFGUID" "void**" } "stdcall" [ nip 0 swap set-void*-nth S_OK ]
 | 
			
		||||
    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-implementation-x ]
 | 
			
		||||
    alien-callback ;
 | 
			
		||||
: setX-callback
 | 
			
		||||
    "void" { "void*" "int" } "stdcall" [ swap set-test-implementation-x ]
 | 
			
		||||
    alien-callback ;
 | 
			
		||||
 | 
			
		||||
SYMBOL: +test-implementation-vtbl+
 | 
			
		||||
SYMBOL: +guinea-pig-implementation+
 | 
			
		||||
 | 
			
		||||
: (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) ;
 | 
			
		||||
 | 
			
		||||
: <malloced-test-implementation> ( x -- imp )
 | 
			
		||||
    "test-implementation" heap-size malloc (make-test-implementation) ;
 | 
			
		||||
 | 
			
		||||
QueryInterface-callback
 | 
			
		||||
AddRef-callback
 | 
			
		||||
Release-callback
 | 
			
		||||
returnOK-callback
 | 
			
		||||
returnError-callback
 | 
			
		||||
getX-callback
 | 
			
		||||
setX-callback
 | 
			
		||||
7 narray >c-void*-array
 | 
			
		||||
dup byte-length [
 | 
			
		||||
    [ byte-array>memory ] keep
 | 
			
		||||
    +test-implementation-vtbl+ set
 | 
			
		||||
 | 
			
		||||
    ! 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 <long> *long 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
 | 
			
		||||
 | 
			
		||||
    0 <malloced-test-implementation> +guinea-pig-implementation+ set
 | 
			
		||||
    [
 | 
			
		||||
        +guinea-pig-implementation+ get 1array [
 | 
			
		||||
            +guinea-pig-implementation+ get com-add-ref
 | 
			
		||||
        ] unit-test
 | 
			
		||||
 | 
			
		||||
        { } [ +guinea-pig-implementation+ get com-release ] unit-test
 | 
			
		||||
 | 
			
		||||
        +guinea-pig-implementation+ get 1array [
 | 
			
		||||
            +guinea-pig-implementation+ get IUnknown-iid com-query-interface
 | 
			
		||||
        ] unit-test
 | 
			
		||||
 | 
			
		||||
    ] [ +guinea-pig-implementation+ get free ] [ ] cleanup
 | 
			
		||||
] with-malloc
 | 
			
		||||
| 
						 | 
				
			
			@ -0,0 +1,22 @@
 | 
			
		|||
USING: alien alien.c-types windows.com.syntax windows.ole32
 | 
			
		||||
windows.types continuations kernel ;
 | 
			
		||||
IN: windows.com
 | 
			
		||||
 | 
			
		||||
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 ole32-error ] keep
 | 
			
		||||
    *void* ;
 | 
			
		||||
 | 
			
		||||
: com-add-ref ( interface -- interface )
 | 
			
		||||
     [ IUnknown::AddRef drop ] keep ; inline
 | 
			
		||||
 | 
			
		||||
: com-release ( interface -- )
 | 
			
		||||
    IUnknown::Release drop ; inline
 | 
			
		||||
 | 
			
		||||
: with-com-interface ( interface quot -- )
 | 
			
		||||
    [ keep ] [ com-release ] [ ] cleanup ; inline
 | 
			
		||||
| 
						 | 
				
			
			@ -0,0 +1 @@
 | 
			
		|||
COM interface
 | 
			
		||||
| 
						 | 
				
			
			@ -0,0 +1 @@
 | 
			
		|||
Joe Groff
 | 
			
		||||
| 
						 | 
				
			
			@ -0,0 +1 @@
 | 
			
		|||
Parsing words for defining COM interfaces
 | 
			
		||||
| 
						 | 
				
			
			@ -0,0 +1,26 @@
 | 
			
		|||
USING: help.markup help.syntax io kernel math quotations
 | 
			
		||||
multiline ;
 | 
			
		||||
IN: windows.com.syntax
 | 
			
		||||
 | 
			
		||||
HELP: COM-INTERFACE:
 | 
			
		||||
{ $syntax <"
 | 
			
		||||
COM-INTERFACE: <interface> <parent> <iid>
 | 
			
		||||
    <function-1> ( <params1> )
 | 
			
		||||
    <function-2> ( <params2> )
 | 
			
		||||
    ... ;
 | 
			
		||||
"> }
 | 
			
		||||
{ $description "\nFor the interface " { $snippet "<interface>" } ", a word " { $snippet "<interface>-iid ( -- iid )" } " is defined to push the interface GUID (IID) onto the stack. Words of the form " { $snippet "<interface>::<function>" } " are also defined to invoke each method, as well as the methods inherited from " { $snippet "<parent>" } ". A " { $snippet "<parent>" } " of " { $snippet "f" } " indicates that the interface is a root interface. (Note that COM conventions demand that all interfaces at least inherit from " { $snippet "IUnknown" } ".)\n\nExample:" }
 | 
			
		||||
{ $code <"
 | 
			
		||||
COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
 | 
			
		||||
    HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
 | 
			
		||||
    ULONG AddRef ( )
 | 
			
		||||
    ULONG Release ( ) ;
 | 
			
		||||
 | 
			
		||||
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 ) ;
 | 
			
		||||
"> } ;
 | 
			
		||||
| 
						 | 
				
			
			@ -0,0 +1,90 @@
 | 
			
		|||
USING: alien alien.c-types kernel windows.ole32
 | 
			
		||||
combinators.lib parser splitting sequences.lib
 | 
			
		||||
sequences namespaces new-slots combinators.cleave
 | 
			
		||||
assocs quotations shuffle accessors words macros
 | 
			
		||||
alien.syntax fry ;
 | 
			
		||||
IN: windows.com.syntax
 | 
			
		||||
 | 
			
		||||
<PRIVATE
 | 
			
		||||
 | 
			
		||||
C-STRUCT: com-interface
 | 
			
		||||
    { "void*" "vtbl" } ;
 | 
			
		||||
 | 
			
		||||
MACRO: com-invoke ( n return parameters -- )
 | 
			
		||||
    dup length -roll
 | 
			
		||||
    '[
 | 
			
		||||
        , npick com-interface-vtbl , swap void*-nth , ,
 | 
			
		||||
        "stdcall" alien-indirect
 | 
			
		||||
    ] ;
 | 
			
		||||
 | 
			
		||||
TUPLE: com-interface-definition name parent iid functions ;
 | 
			
		||||
C: <com-interface-definition> com-interface-definition
 | 
			
		||||
 | 
			
		||||
TUPLE: com-function-definition name return parameters ;
 | 
			
		||||
C: <com-function-definition> com-function-definition
 | 
			
		||||
 | 
			
		||||
SYMBOL: +com-interface-definitions+
 | 
			
		||||
+com-interface-definitions+ get-global
 | 
			
		||||
[ H{ } +com-interface-definitions+ set-global ]
 | 
			
		||||
unless
 | 
			
		||||
 | 
			
		||||
: find-com-interface-definition ( name -- definition )
 | 
			
		||||
    dup "f" = [ drop f ] [
 | 
			
		||||
        dup +com-interface-definitions+ get-global at*
 | 
			
		||||
        [ nip ]
 | 
			
		||||
        [ swap " COM interface hasn't been defined" append throw ]
 | 
			
		||||
        if
 | 
			
		||||
    ] if ;
 | 
			
		||||
 | 
			
		||||
: save-com-interface-definition ( definition -- )
 | 
			
		||||
    dup name>> +com-interface-definitions+ get-global set-at ;
 | 
			
		||||
 | 
			
		||||
: (parse-com-function) ( tokens -- definition )
 | 
			
		||||
    [ second ]
 | 
			
		||||
    [ first ]
 | 
			
		||||
    [ 3 tail 2 group [ first ] map "void*" add* ]
 | 
			
		||||
    tri
 | 
			
		||||
    <com-function-definition> ;
 | 
			
		||||
 | 
			
		||||
: parse-com-functions ( -- functions )
 | 
			
		||||
    ";" parse-tokens { ")" } split
 | 
			
		||||
    [ empty? not ] subset
 | 
			
		||||
    [ (parse-com-function) ] map ;
 | 
			
		||||
 | 
			
		||||
: (iid-word) ( definition -- word )
 | 
			
		||||
    name>> "-iid" append create-in ;
 | 
			
		||||
 | 
			
		||||
: (function-word) ( function interface -- word )
 | 
			
		||||
    name>> "::" rot name>> 3append create-in ;
 | 
			
		||||
 | 
			
		||||
: all-functions ( definition -- functions )
 | 
			
		||||
    dup parent>> [ all-functions ] [ { } ] if*
 | 
			
		||||
    swap functions>> append ;
 | 
			
		||||
 | 
			
		||||
: (define-word-for-function) ( function interface n -- )
 | 
			
		||||
    -rot [ (function-word) swap ] 2keep drop
 | 
			
		||||
    { return>> parameters>> } get-slots
 | 
			
		||||
    [ com-invoke ] 3curry
 | 
			
		||||
    define ;
 | 
			
		||||
 | 
			
		||||
: define-words-for-com-interface ( definition -- )
 | 
			
		||||
    [ [ (iid-word) ] [ iid>> 1quotation ] bi define ]
 | 
			
		||||
    [ name>> "com-interface" swap typedef ]
 | 
			
		||||
    [
 | 
			
		||||
        dup all-functions
 | 
			
		||||
        [ (define-word-for-function) ] with each-index
 | 
			
		||||
    ]
 | 
			
		||||
    tri ;
 | 
			
		||||
 | 
			
		||||
PRIVATE>
 | 
			
		||||
 | 
			
		||||
: COM-INTERFACE:
 | 
			
		||||
    scan
 | 
			
		||||
    scan find-com-interface-definition
 | 
			
		||||
    scan string>guid
 | 
			
		||||
    parse-com-functions
 | 
			
		||||
    <com-interface-definition>
 | 
			
		||||
    dup save-com-interface-definition
 | 
			
		||||
    define-words-for-com-interface
 | 
			
		||||
    ; parsing
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -0,0 +1,3 @@
 | 
			
		|||
windows
 | 
			
		||||
com
 | 
			
		||||
bindings
 | 
			
		||||
| 
						 | 
				
			
			@ -0,0 +1,3 @@
 | 
			
		|||
windows
 | 
			
		||||
com
 | 
			
		||||
bindings
 | 
			
		||||
| 
						 | 
				
			
			@ -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
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -0,0 +1 @@
 | 
			
		|||
Joe Groff
 | 
			
		||||
| 
						 | 
				
			
			@ -0,0 +1,59 @@
 | 
			
		|||
USING: alien alien.syntax alien.c-types math kernel sequences
 | 
			
		||||
windows windows.types combinators.lib ;
 | 
			
		||||
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
 | 
			
		||||
TYPEDEF: ushort* LPCOLESTR
 | 
			
		||||
 | 
			
		||||
TYPEDEF: REFGUID REFIID
 | 
			
		||||
TYPEDEF: REFGUID REFCLSID
 | 
			
		||||
 | 
			
		||||
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
 | 
			
		||||
 | 
			
		||||
: MK_ALT HEX: 20 ; inline
 | 
			
		||||
: DROPEFFECT_NONE 0 ; inline
 | 
			
		||||
: DROPEFFECT_COPY 1 ; inline
 | 
			
		||||
: DROPEFFECT_MOVE 2 ; inline
 | 
			
		||||
: DROPEFFECT_LINK 4 ; inline
 | 
			
		||||
: DROPEFFECT_SCROLL HEX: 80000000 ; inline
 | 
			
		||||
: DD_DEFSCROLLINSET 11 ; inline
 | 
			
		||||
: DD_DEFSCROLLDELAY 50 ; inline
 | 
			
		||||
: DD_DEFSCROLLINTERVAL 50 ; inline
 | 
			
		||||
: DD_DEFDRAGDELAY 200 ; inline
 | 
			
		||||
: DD_DEFDRAGMINDIST 2 ; 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 } multikeep alien>u16-string ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -1,5 +1,6 @@
 | 
			
		|||
USING: alien alien.c-types alien.syntax combinators
 | 
			
		||||
kernel windows windows.user32 ;
 | 
			
		||||
kernel windows windows.user32 windows.ole32
 | 
			
		||||
windows.com windows.com.syntax ;
 | 
			
		||||
IN: windows.shell32
 | 
			
		||||
 | 
			
		||||
: CSIDL_DESKTOP HEX: 00 ; inline
 | 
			
		||||
| 
						 | 
				
			
			@ -68,10 +69,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 +86,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
 | 
			
		||||
| 
						 | 
				
			
			@ -130,3 +119,96 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi
 | 
			
		|||
 | 
			
		||||
: program-files-common-x86 ( -- str )
 | 
			
		||||
    CSIDL_PROGRAM_FILES_COMMONX86 shell32-directory ;
 | 
			
		||||
 | 
			
		||||
: SHCONTF_FOLDERS 32 ; inline
 | 
			
		||||
: SHCONTF_NONFOLDERS 64 ; inline
 | 
			
		||||
: SHCONTF_INCLUDEHIDDEN 128 ; inline
 | 
			
		||||
: SHCONTF_INIT_ON_FIRST_NEXT 256 ; inline
 | 
			
		||||
: SHCONTF_NETPRINTERSRCH 512 ; inline
 | 
			
		||||
: SHCONTF_SHAREABLE 1024 ; inline
 | 
			
		||||
: SHCONTF_STORAGE 2048 ; inline
 | 
			
		||||
 | 
			
		||||
TYPEDEF: DWORD SHCONTF
 | 
			
		||||
 | 
			
		||||
: SHGDN_NORMAL 0 ; inline
 | 
			
		||||
: SHGDN_INFOLDER 1 ; inline
 | 
			
		||||
: SHGDN_FOREDITING HEX: 1000 ; inline
 | 
			
		||||
: SHGDN_INCLUDE_NONFILESYS HEX: 2000 ; inline
 | 
			
		||||
: SHGDN_FORADDRESSBAR HEX: 4000 ; inline
 | 
			
		||||
: SHGDN_FORPARSING HEX: 8000 ; inline
 | 
			
		||||
 | 
			
		||||
TYPEDEF: DWORD SHGDNF
 | 
			
		||||
 | 
			
		||||
: SFGAO_CANCOPY           DROPEFFECT_COPY ; inline
 | 
			
		||||
: SFGAO_CANMOVE           DROPEFFECT_MOVE ; inline
 | 
			
		||||
: SFGAO_CANLINK           DROPEFFECT_LINK ; inline
 | 
			
		||||
: SFGAO_CANRENAME         HEX: 00000010 ; inline
 | 
			
		||||
: SFGAO_CANDELETE         HEX: 00000020 ; inline
 | 
			
		||||
: SFGAO_HASPROPSHEET      HEX: 00000040 ; inline
 | 
			
		||||
: SFGAO_DROPTARGET        HEX: 00000100 ; inline
 | 
			
		||||
: SFGAO_CAPABILITYMASK    HEX: 00000177 ; inline
 | 
			
		||||
: SFGAO_LINK              HEX: 00010000 ; inline
 | 
			
		||||
: SFGAO_SHARE             HEX: 00020000 ; inline
 | 
			
		||||
: SFGAO_READONLY          HEX: 00040000 ; inline
 | 
			
		||||
: SFGAO_GHOSTED           HEX: 00080000 ; inline
 | 
			
		||||
: SFGAO_HIDDEN            HEX: 00080000 ; inline
 | 
			
		||||
: SFGAO_DISPLAYATTRMASK   HEX: 000F0000 ; inline
 | 
			
		||||
: SFGAO_FILESYSANCESTOR   HEX: 10000000 ; inline
 | 
			
		||||
: SFGAO_FOLDER            HEX: 20000000 ; inline
 | 
			
		||||
: SFGAO_FILESYSTEM        HEX: 40000000 ; inline
 | 
			
		||||
: SFGAO_HASSUBFOLDER      HEX: 80000000 ; inline
 | 
			
		||||
: SFGAO_CONTENTSMASK      HEX: 80000000 ; inline
 | 
			
		||||
: SFGAO_VALIDATE          HEX: 01000000 ; inline
 | 
			
		||||
: SFGAO_REMOVABLE         HEX: 02000000 ; inline
 | 
			
		||||
: SFGAO_COMPRESSED        HEX: 04000000 ; inline
 | 
			
		||||
: SFGAO_BROWSABLE         HEX: 08000000 ; inline
 | 
			
		||||
: SFGAO_NONENUMERATED     HEX: 00100000 ; inline
 | 
			
		||||
: SFGAO_NEWCONTENT        HEX: 00200000 ; inline
 | 
			
		||||
 | 
			
		||||
TYPEDEF: ULONG SFGAOF
 | 
			
		||||
 | 
			
		||||
C-STRUCT: SHITEMID
 | 
			
		||||
    { "USHORT" "cb" }
 | 
			
		||||
    { "BYTE[1]" "abID" } ;
 | 
			
		||||
TYPEDEF: SHITEMID* LPSHITEMID
 | 
			
		||||
TYPEDEF: SHITEMID* LPCSHITEMID
 | 
			
		||||
 | 
			
		||||
C-STRUCT: ITEMIDLIST
 | 
			
		||||
    { "SHITEMID" "mkid" } ;
 | 
			
		||||
TYPEDEF: ITEMIDLIST* LPITEMIDLIST
 | 
			
		||||
TYPEDEF: ITEMIDLIST* LPCITEMIDLIST
 | 
			
		||||
TYPEDEF: ITEMIDLIST ITEMID_CHILD
 | 
			
		||||
TYPEDEF: ITEMID_CHILD* PITEMID_CHILD
 | 
			
		||||
TYPEDEF: ITEMID_CHILD* PCUITEMID_CHILD
 | 
			
		||||
 | 
			
		||||
: STRRET_WSTR 0 ; inline
 | 
			
		||||
: STRRET_OFFSET 1 ; inline
 | 
			
		||||
: STRRET_CSTR 2 ; inline
 | 
			
		||||
 | 
			
		||||
C-UNION: STRRET-union "LPWSTR" "LPSTR" "UINT" "char[260]" ;
 | 
			
		||||
C-STRUCT: STRRET
 | 
			
		||||
    { "int" "uType" }
 | 
			
		||||
    { "STRRET-union" "union" } ;
 | 
			
		||||
 | 
			
		||||
COM-INTERFACE: IEnumIDList IUnknown {000214F2-0000-0000-C000-000000000046}
 | 
			
		||||
    HRESULT Next ( ULONG celt, LPITEMIDLIST* rgelt, ULONG* pceltFetched )
 | 
			
		||||
    HRESULT Skip ( ULONG celt )
 | 
			
		||||
    HRESULT Reset ( )
 | 
			
		||||
    HRESULT Clone ( IEnumIDList** ppenum ) ;
 | 
			
		||||
 | 
			
		||||
COM-INTERFACE: IShellFolder IUnknown {000214E6-0000-0000-C000-000000000046}
 | 
			
		||||
    HRESULT ParseDisplayName ( HWND hwndOwner, void* pbcReserved, LPOLESTR lpszDisplayName, ULONG* pchEaten, LPITEMIDLIST* ppidl, ULONG* pdwAttributes )
 | 
			
		||||
    HRESULT EnumObjects ( HWND hwndOwner, SHCONTF grfFlags, IEnumIDList** ppenumIDList )
 | 
			
		||||
    HRESULT BindToObject ( LPCITEMIDLIST pidl, void* pbcReserved, REFGUID riid, void** ppvOut )
 | 
			
		||||
    HRESULT BindToStorage ( LPCITEMIDLIST pidl, void* pbcReserved, REFGUID riid, void** ppvObj )
 | 
			
		||||
    HRESULT CompareIDs ( LPARAM lParam, LPCITEMIDLIST pidl1, LPCITEMIDLIST pidl2 )
 | 
			
		||||
    HRESULT CreateViewObject ( HWND hwndOwner, REFGUID riid, void** ppvOut )
 | 
			
		||||
    HRESULT GetAttributesOf ( UINT cidl, LPCITEMIDLIST* apidl, SFGAOF* rgfInOut )
 | 
			
		||||
    HRESULT GetUIObjectOf ( HWND hwndOwner, UINT cidl, LPCITEMIDLIST* apidl, REFGUID riid, UINT* prgfInOut, void** ppvOut )
 | 
			
		||||
    HRESULT GetDisplayNameOf ( LPCITEMIDLIST pidl, SHGDNF uFlags, STRRET* lpName )
 | 
			
		||||
    HRESULT SetNameOf ( HWND hwnd, LPCITEMIDLIST pidl, LPCOLESTR lpszName, SHGDNF uFlags, LPITEMIDLIST* ppidlOut ) ;
 | 
			
		||||
 | 
			
		||||
FUNCTION: HRESULT SHGetDesktopFolder ( IShellFolder** ppshf ) ;
 | 
			
		||||
 | 
			
		||||
FUNCTION: HRESULT StrRetToBufW ( STRRET *pstr, PCUITEMID_CHILD pidl, LPWSTR pszBuf, UINT cchBuf ) ;
 | 
			
		||||
: StrRetToBuf StrRetToBufW ; inline
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue