Rename out-keep to multikeep and move it into combinators.lib
							parent
							
								
									c65c7755fa
								
							
						
					
					
						commit
						5f79372789
					
				| 
						 | 
				
			
			@ -145,23 +145,7 @@ HELP: alien-callback
 | 
			
		|||
}
 | 
			
		||||
{ $errors "Throws an " { $link alien-callback-error } " if the word calling " { $link alien-callback } " is not compiled." } ;
 | 
			
		||||
 | 
			
		||||
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
 | 
			
		||||
{ alien-invoke alien-indirect alien-callback } related-words
 | 
			
		||||
 | 
			
		||||
ARTICLE: "aliens" "Alien addresses"
 | 
			
		||||
"Instances of the " { $link alien } " class represent pointers to C data outside the Factor heap:"
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -90,10 +90,3 @@ 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 ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -167,3 +167,10 @@ 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 ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -95,7 +95,7 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
 | 
			
		|||
    dup gl-program-shaders-length
 | 
			
		||||
    dup "GLuint" <c-array>
 | 
			
		||||
    0 <int> swap
 | 
			
		||||
    [ glGetAttachedShaders ] { 3 1 } out-keep
 | 
			
		||||
    [ glGetAttachedShaders ] { 3 1 } multikeep
 | 
			
		||||
    c-uint-array> ;
 | 
			
		||||
 | 
			
		||||
: delete-gl-program-only ( program -- )
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,5 +1,5 @@
 | 
			
		|||
USING: alien alien.syntax alien.c-types math kernel sequences
 | 
			
		||||
windows windows.types ;
 | 
			
		||||
windows windows.types combinators.lib ;
 | 
			
		||||
IN: windows.ole32
 | 
			
		||||
 | 
			
		||||
LIBRARY: ole32
 | 
			
		||||
| 
						 | 
				
			
			@ -39,5 +39,5 @@ FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
 | 
			
		|||
    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 ;
 | 
			
		||||
    [ StringFromGUID2 drop ] { 2 } multikeep alien>u16-string ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue