alien.data: remove second quotation parameter from with-out-parameters, now all values are copied properly and calling 'clone' on structs in this quotation is not necessary
parent
5803419b9d
commit
446ee6896d
|
@ -56,6 +56,9 @@ M: string-type c-type-unboxer-quot
|
||||||
M: string-type c-type-getter
|
M: string-type c-type-getter
|
||||||
drop [ alien-cell ] ;
|
drop [ alien-cell ] ;
|
||||||
|
|
||||||
|
M: string-type c-type-copier
|
||||||
|
drop [ ] ;
|
||||||
|
|
||||||
M: string-type c-type-setter
|
M: string-type c-type-setter
|
||||||
drop [ set-alien-cell ] ;
|
drop [ set-alien-cell ] ;
|
||||||
|
|
||||||
|
|
|
@ -89,6 +89,10 @@ GENERIC: c-type-getter ( name -- quot )
|
||||||
|
|
||||||
M: c-type c-type-getter getter>> ;
|
M: c-type c-type-getter getter>> ;
|
||||||
|
|
||||||
|
GENERIC: c-type-copier ( name -- quot )
|
||||||
|
|
||||||
|
M: c-type c-type-copier drop [ ] ;
|
||||||
|
|
||||||
GENERIC: c-type-setter ( name -- quot )
|
GENERIC: c-type-setter ( name -- quot )
|
||||||
|
|
||||||
M: c-type c-type-setter setter>> ;
|
M: c-type c-type-setter setter>> ;
|
||||||
|
@ -118,6 +122,9 @@ MIXIN: value-type
|
||||||
MACRO: alien-value ( c-type -- quot: ( c-ptr offset -- value ) )
|
MACRO: alien-value ( c-type -- quot: ( c-ptr offset -- value ) )
|
||||||
[ c-type-getter ] [ c-type-boxer-quot ] bi append ;
|
[ c-type-getter ] [ c-type-boxer-quot ] bi append ;
|
||||||
|
|
||||||
|
MACRO: alien-copy-value ( c-type -- quot: ( c-ptr offset -- value ) )
|
||||||
|
[ c-type-getter ] [ c-type-copier ] [ c-type-boxer-quot ] tri 3append ;
|
||||||
|
|
||||||
MACRO: set-alien-value ( c-type -- quot: ( value c-ptr offset -- ) )
|
MACRO: set-alien-value ( c-type -- quot: ( value c-ptr offset -- ) )
|
||||||
[ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
|
[ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
|
||||||
[ c-type-setter ]
|
[ c-type-setter ]
|
||||||
|
@ -139,6 +146,7 @@ PROTOCOL: c-type-protocol
|
||||||
c-type-unboxer-quot
|
c-type-unboxer-quot
|
||||||
c-type-rep
|
c-type-rep
|
||||||
c-type-getter
|
c-type-getter
|
||||||
|
c-type-copier
|
||||||
c-type-setter
|
c-type-setter
|
||||||
c-type-align
|
c-type-align
|
||||||
c-type-align-first
|
c-type-align-first
|
||||||
|
|
|
@ -76,7 +76,7 @@ scoped-allocation-test ."
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: with-out-parameters
|
HELP: with-out-parameters
|
||||||
{ $values { "c-types" "a list of scoped allocation specifiers" } { "quot" quotation } { "finish" quotation } { "values..." "zero or more values" } }
|
{ $values { "c-types" "a list of scoped allocation specifiers" } { "quot" quotation } { "values..." "zero or more values" } }
|
||||||
{ $description "Allocates values on the call stack, calls the quotation, then copies all stack allocated values to the data heap after the quotation returns."
|
{ $description "Allocates values on the call stack, calls the quotation, then copies all stack allocated values to the data heap after the quotation returns."
|
||||||
$nl
|
$nl
|
||||||
"A scoped allocation specifier is either:"
|
"A scoped allocation specifier is either:"
|
||||||
|
|
|
@ -70,7 +70,10 @@ M: value-type c-type-rep drop int-rep ;
|
||||||
M: value-type c-type-getter
|
M: value-type c-type-getter
|
||||||
drop [ swap <displaced-alien> ] ;
|
drop [ swap <displaced-alien> ] ;
|
||||||
|
|
||||||
M: value-type c-type-setter ( type -- quot )
|
M: value-type c-type-copier
|
||||||
|
heap-size '[ _ memory>byte-array ] ;
|
||||||
|
|
||||||
|
M: value-type c-type-setter
|
||||||
[ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ;
|
[ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ;
|
||||||
|
|
||||||
M: array c-type-boxer-quot
|
M: array c-type-boxer-quot
|
||||||
|
@ -117,7 +120,7 @@ MACRO: box-values ( c-types -- quot )
|
||||||
|
|
||||||
MACRO: out-parameters ( c-types -- quot )
|
MACRO: out-parameters ( c-types -- quot )
|
||||||
[ dup hairy-local-allot? [ first ] when ] map
|
[ dup hairy-local-allot? [ first ] when ] map
|
||||||
[ length ] [ [ '[ 0 _ alien-value ] ] map ] bi
|
[ length ] [ [ '[ 0 _ alien-copy-value ] ] map ] bi
|
||||||
'[ _ nkeep _ spread ] ;
|
'[ _ nkeep _ spread ] ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
@ -126,8 +129,8 @@ PRIVATE>
|
||||||
[ [ (local-allots) ] [ box-values ] bi ] dip call
|
[ [ (local-allots) ] [ box-values ] bi ] dip call
|
||||||
(cleanup-allot) ; inline
|
(cleanup-allot) ; inline
|
||||||
|
|
||||||
: with-out-parameters ( c-types quot finish -- values... )
|
: with-out-parameters ( c-types quot -- values... )
|
||||||
[ [ drop (local-allots) ] [ swap out-parameters ] 2bi ] dip call
|
[ drop (local-allots) ] [ swap out-parameters ] 2bi
|
||||||
(cleanup-allot) ; inline
|
(cleanup-allot) ; inline
|
||||||
|
|
||||||
GENERIC: binary-zero? ( value -- ? )
|
GENERIC: binary-zero? ( value -- ? )
|
||||||
|
@ -137,4 +140,3 @@ M: f binary-zero? drop t ; inline
|
||||||
M: integer binary-zero? zero? ; inline
|
M: integer binary-zero? zero? ; inline
|
||||||
M: math:float binary-zero? double>bits zero? ; inline
|
M: math:float binary-zero? double>bits zero? ; inline
|
||||||
M: complex binary-zero? >rect [ binary-zero? ] both? ; inline
|
M: complex binary-zero? >rect [ binary-zero? ] both? ; inline
|
||||||
|
|
||||||
|
|
|
@ -48,9 +48,8 @@ M: evp-md-context dispose*
|
||||||
: digest-value ( ctx -- value )
|
: digest-value ( ctx -- value )
|
||||||
handle>>
|
handle>>
|
||||||
{ { int EVP_MAX_MD_SIZE } int }
|
{ { int EVP_MAX_MD_SIZE } int }
|
||||||
[ EVP_DigestFinal_ex ssl-error ]
|
[ EVP_DigestFinal_ex ssl-error ] with-out-parameters
|
||||||
[ memory>byte-array ]
|
memory>byte-array ;
|
||||||
with-out-parameters ;
|
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
|
@ -216,7 +216,7 @@ ERROR: no-objc-type name ;
|
||||||
objc-methods get set-at ;
|
objc-methods get set-at ;
|
||||||
|
|
||||||
: each-method-in-class ( class quot -- )
|
: each-method-in-class ( class quot -- )
|
||||||
[ { uint } [ class_copyMethodList ] [ ] with-out-parameters ] dip
|
[ { uint } [ class_copyMethodList ] with-out-parameters ] dip
|
||||||
over 0 = [ 3drop ] [
|
over 0 = [ 3drop ] [
|
||||||
[ <direct-void*-array> ] dip
|
[ <direct-void*-array> ] dip
|
||||||
[ each ] [ drop (free) ] 2bi
|
[ each ] [ drop (free) ] 2bi
|
||||||
|
|
|
@ -16,6 +16,6 @@ IN: cocoa.nibs
|
||||||
|
|
||||||
: nib-objects ( anNSNib -- objects/f )
|
: nib-objects ( anNSNib -- objects/f )
|
||||||
f
|
f
|
||||||
{ void* } [ -> instantiateNibWithOwner:topLevelObjects: ] [ ]
|
{ void* } [ -> instantiateNibWithOwner:topLevelObjects: ]
|
||||||
with-out-parameters
|
with-out-parameters
|
||||||
swap [ CF>array ] [ drop f ] if ;
|
swap [ CF>array ] [ drop f ] if ;
|
|
@ -38,7 +38,7 @@ DEFER: plist>
|
||||||
: (read-plist) ( NSData -- id )
|
: (read-plist) ( NSData -- id )
|
||||||
NSPropertyListSerialization swap kCFPropertyListImmutable f
|
NSPropertyListSerialization swap kCFPropertyListImmutable f
|
||||||
{ void* }
|
{ void* }
|
||||||
[ -> propertyListFromData:mutabilityOption:format:errorDescription: ] [ ]
|
[ -> propertyListFromData:mutabilityOption:format:errorDescription: ]
|
||||||
with-out-parameters
|
with-out-parameters
|
||||||
[ -> release "read-plist failed" throw ] when* ;
|
[ -> release "read-plist failed" throw ] when* ;
|
||||||
|
|
||||||
|
|
|
@ -777,18 +777,18 @@ mingw? [
|
||||||
[ 3 ] [ blah ] unit-test
|
[ 3 ] [ blah ] unit-test
|
||||||
|
|
||||||
: out-param-test-1 ( -- b )
|
: out-param-test-1 ( -- b )
|
||||||
{ int } [ [ 12 ] dip 0 int set-alien-value ] [ ] with-out-parameters ;
|
{ int } [ [ 12 ] dip 0 int set-alien-value ] with-out-parameters ;
|
||||||
|
|
||||||
[ 12 ] [ out-param-test-1 ] unit-test
|
[ 12 ] [ out-param-test-1 ] unit-test
|
||||||
|
|
||||||
: out-param-test-2 ( -- b )
|
: out-param-test-2 ( -- b )
|
||||||
{ { int initial: 12 } } [ drop ] [ ] with-out-parameters ;
|
{ { int initial: 12 } } [ drop ] with-out-parameters ;
|
||||||
|
|
||||||
[ 12 ] [ out-param-test-2 ] unit-test
|
[ 12 ] [ out-param-test-2 ] unit-test
|
||||||
|
|
||||||
: out-param-test-3 ( -- x y )
|
: out-param-test-3 ( -- x y )
|
||||||
{ { RECT initial: S{ RECT { x 3 } { y 4 } } } } [ drop ]
|
{ { RECT initial: S{ RECT { x 3 } { y 4 } } } } [ drop ]
|
||||||
[ clone ] with-out-parameters
|
with-out-parameters
|
||||||
[ x>> ] [ y>> ] bi ;
|
[ x>> ] [ y>> ] bi ;
|
||||||
|
|
||||||
[ 3.0 4.0 ] [ out-param-test-3 ] unit-test
|
[ 3.0 4.0 ] [ out-param-test-3 ] unit-test
|
||||||
|
@ -801,6 +801,6 @@ mingw? [
|
||||||
{ int } [
|
{ int } [
|
||||||
swap void { int pointer: int } cdecl
|
swap void { int pointer: int } cdecl
|
||||||
alien-indirect
|
alien-indirect
|
||||||
] [ ] with-out-parameters ;
|
] with-out-parameters ;
|
||||||
|
|
||||||
[ 12 ] [ 6 out-param-callback out-param-indirect ] unit-test
|
[ 12 ] [ 6 out-param-callback out-param-indirect ] unit-test
|
||||||
|
|
|
@ -454,7 +454,6 @@ STRUCT: BitmapData { Scan0 void* } ;
|
||||||
[
|
[
|
||||||
{ BitmapData }
|
{ BitmapData }
|
||||||
[ BitmapData memory>struct ALIEN: 123 >>Scan0 drop ]
|
[ BitmapData memory>struct ALIEN: 123 >>Scan0 drop ]
|
||||||
[ clone ]
|
|
||||||
with-out-parameters Scan0>>
|
with-out-parameters Scan0>>
|
||||||
] compile-call
|
] compile-call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -78,8 +78,7 @@ FUNCTION: CFStringRef CFStringCreateWithCString (
|
||||||
[ 0 swap <CFRange> kCFStringEncodingUTF8 0 f ] keep
|
[ 0 swap <CFRange> kCFStringEncodingUTF8 0 f ] keep
|
||||||
4 * 1 + <byte-array> [
|
4 * 1 + <byte-array> [
|
||||||
dup length
|
dup length
|
||||||
{ CFIndex } [ CFStringGetBytes drop ] [ ]
|
{ CFIndex } [ CFStringGetBytes drop ] with-out-parameters
|
||||||
with-out-parameters
|
|
||||||
] keep
|
] keep
|
||||||
swap head-slice utf8 decode ;
|
swap head-slice utf8 decode ;
|
||||||
|
|
||||||
|
|
|
@ -51,7 +51,7 @@ TUPLE: line < disposable line metrics image loc dim ;
|
||||||
|
|
||||||
: typographic-bounds ( line -- width ascent descent leading )
|
: typographic-bounds ( line -- width ascent descent leading )
|
||||||
{ CGFloat CGFloat CGFloat }
|
{ CGFloat CGFloat CGFloat }
|
||||||
[ CTLineGetTypographicBounds ] [ ] with-out-parameters ; inline
|
[ CTLineGetTypographicBounds ] with-out-parameters ; inline
|
||||||
|
|
||||||
: store-typographic-bounds ( metrics width ascent descent leading -- metrics )
|
: store-typographic-bounds ( metrics width ascent descent leading -- metrics )
|
||||||
{
|
{
|
||||||
|
|
|
@ -146,7 +146,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
|
||||||
] [
|
] [
|
||||||
&postgresql-free
|
&postgresql-free
|
||||||
] if
|
] if
|
||||||
] [ ] with-out-parameters memory>byte-array
|
] with-out-parameters memory>byte-array
|
||||||
] with-destructors
|
] with-destructors
|
||||||
] [
|
] [
|
||||||
drop pq-get-is-null nip [ f ] [ B{ } clone ] if
|
drop pq-get-is-null nip [ f ] [ B{ } clone ] if
|
||||||
|
|
|
@ -27,7 +27,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
|
||||||
|
|
||||||
: sqlite-open ( path -- db )
|
: sqlite-open ( path -- db )
|
||||||
normalize-path
|
normalize-path
|
||||||
{ void* } [ sqlite3_open sqlite-check-result ] [ ]
|
{ void* } [ sqlite3_open sqlite-check-result ]
|
||||||
with-out-parameters ;
|
with-out-parameters ;
|
||||||
|
|
||||||
: sqlite-close ( db -- )
|
: sqlite-close ( db -- )
|
||||||
|
@ -36,8 +36,8 @@ ERROR: sqlite-sql-error < sql-error n string ;
|
||||||
: sqlite-prepare ( db sql -- handle )
|
: sqlite-prepare ( db sql -- handle )
|
||||||
utf8 encode dup length
|
utf8 encode dup length
|
||||||
{ void* void* }
|
{ void* void* }
|
||||||
[ sqlite3_prepare_v2 sqlite-check-result ] [ drop ]
|
[ sqlite3_prepare_v2 sqlite-check-result ]
|
||||||
with-out-parameters ;
|
with-out-parameters drop ;
|
||||||
|
|
||||||
: sqlite-bind-parameter-index ( handle name -- index )
|
: sqlite-bind-parameter-index ( handle name -- index )
|
||||||
sqlite3_bind_parameter_index ;
|
sqlite3_bind_parameter_index ;
|
||||||
|
|
|
@ -89,7 +89,7 @@ M: x11-game-input-backend read-keyboard
|
||||||
: query-pointer ( -- x y buttons )
|
: query-pointer ( -- x y buttons )
|
||||||
dpy get dup XDefaultRootWindow
|
dpy get dup XDefaultRootWindow
|
||||||
{ int int int int int int int }
|
{ int int int int int int int }
|
||||||
[ XQueryPointer drop ] [ ] with-out-parameters
|
[ XQueryPointer drop ] with-out-parameters
|
||||||
[ 4 ndrop ] 3dip ;
|
[ 4 ndrop ] 3dip ;
|
||||||
|
|
||||||
SYMBOL: mouse-reset?
|
SYMBOL: mouse-reset?
|
||||||
|
|
|
@ -56,7 +56,7 @@ M: winnt add-completion ( win32-handle -- )
|
||||||
nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
|
nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
|
||||||
master-completion-port get-global
|
master-completion-port get-global
|
||||||
{ int void* pointer: OVERLAPPED }
|
{ int void* pointer: OVERLAPPED }
|
||||||
[ timeout GetQueuedCompletionStatus zero? ] [ ] with-out-parameters
|
[ timeout GetQueuedCompletionStatus zero? ] with-out-parameters
|
||||||
:> ( error? bytes key overlapped )
|
:> ( error? bytes key overlapped )
|
||||||
bytes overlapped error? ;
|
bytes overlapped error? ;
|
||||||
|
|
||||||
|
|
|
@ -15,7 +15,7 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
|
||||||
: (open-process-token) ( handle -- handle )
|
: (open-process-token) ( handle -- handle )
|
||||||
flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY }
|
flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY }
|
||||||
{ PHANDLE }
|
{ PHANDLE }
|
||||||
[ OpenProcessToken win32-error=0/f ] [ ]
|
[ OpenProcessToken win32-error=0/f ]
|
||||||
with-out-parameters ;
|
with-out-parameters ;
|
||||||
|
|
||||||
: open-process-token ( -- handle )
|
: open-process-token ( -- handle )
|
||||||
|
|
|
@ -21,7 +21,7 @@ IN: io.files.info.windows
|
||||||
TUPLE: windows-file-info < file-info attributes ;
|
TUPLE: windows-file-info < file-info attributes ;
|
||||||
|
|
||||||
: get-compressed-file-size ( path -- n )
|
: get-compressed-file-size ( path -- n )
|
||||||
{ DWORD } [ GetCompressedFileSize ] [ ] with-out-parameters
|
{ DWORD } [ GetCompressedFileSize ] with-out-parameters
|
||||||
over INVALID_FILE_SIZE = [ win32-error-string throw ] [ >64bit ] if ;
|
over INVALID_FILE_SIZE = [ win32-error-string throw ] [ >64bit ] if ;
|
||||||
|
|
||||||
: set-windows-size-on-disk ( file-info path -- file-info )
|
: set-windows-size-on-disk ( file-info path -- file-info )
|
||||||
|
@ -100,12 +100,12 @@ CONSTANT: path-length $[ MAX_PATH 1 + ]
|
||||||
: volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
|
: volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
|
||||||
{ { ushort path-length } DWORD DWORD DWORD { ushort path-length } }
|
{ { ushort path-length } DWORD DWORD DWORD { ushort path-length } }
|
||||||
[ [ path-length ] 4dip path-length GetVolumeInformation win32-error=0/f ]
|
[ [ path-length ] 4dip path-length GetVolumeInformation win32-error=0/f ]
|
||||||
[ [ utf16n alien>string ] 4dip utf16n alien>string ]
|
with-out-parameters
|
||||||
with-out-parameters ;
|
[ utf16n alien>string ] 4dip utf16n alien>string ;
|
||||||
|
|
||||||
: file-system-space ( normalized-path -- available-space total-space free-space )
|
: file-system-space ( normalized-path -- available-space total-space free-space )
|
||||||
{ ULARGE_INTEGER ULARGE_INTEGER ULARGE_INTEGER }
|
{ ULARGE_INTEGER ULARGE_INTEGER ULARGE_INTEGER }
|
||||||
[ GetDiskFreeSpaceEx win32-error=0/f ] [ ]
|
[ GetDiskFreeSpaceEx win32-error=0/f ]
|
||||||
with-out-parameters ;
|
with-out-parameters ;
|
||||||
|
|
||||||
: calculate-file-system-info ( file-system-info -- file-system-info' )
|
: calculate-file-system-info ( file-system-info -- file-system-info' )
|
||||||
|
@ -149,24 +149,21 @@ CONSTANT: names-buf-length 16384
|
||||||
: volume>paths ( string -- array )
|
: volume>paths ( string -- array )
|
||||||
{ { ushort names-buf-length } uint }
|
{ { ushort names-buf-length } uint }
|
||||||
[ [ names-buf-length ] dip GetVolumePathNamesForVolumeName win32-error=0/f ]
|
[ [ names-buf-length ] dip GetVolumePathNamesForVolumeName win32-error=0/f ]
|
||||||
[ head utf16n alien>string { CHAR: \0 } split ]
|
with-out-parameters
|
||||||
with-out-parameters ;
|
head utf16n alien>string { CHAR: \0 } split ;
|
||||||
|
|
||||||
: find-first-volume ( -- string handle )
|
: find-first-volume ( -- string handle )
|
||||||
{ { ushort path-length } }
|
{ { ushort path-length } }
|
||||||
[ path-length FindFirstVolume dup win32-error=0/f ]
|
[ path-length FindFirstVolume dup win32-error=0/f ]
|
||||||
[ utf16n alien>string ]
|
with-out-parameters utf16n alien>string swap ;
|
||||||
with-out-parameters swap ;
|
|
||||||
|
|
||||||
: find-next-volume ( handle -- string/f )
|
: find-next-volume ( handle -- string/f )
|
||||||
{ { ushort path-length } }
|
{ { ushort path-length } }
|
||||||
[ path-length FindNextVolume ]
|
[ path-length FindNextVolume ] with-out-parameters
|
||||||
[
|
swap 0 = [
|
||||||
swap 0 = [
|
GetLastError ERROR_NO_MORE_FILES =
|
||||||
GetLastError ERROR_NO_MORE_FILES =
|
[ drop f ] [ win32-error-string throw ] if
|
||||||
[ drop f ] [ win32-error-string throw ] if
|
] [ utf16n alien>string ] if ;
|
||||||
] [ utf16n alien>string ] if
|
|
||||||
] with-out-parameters ;
|
|
||||||
|
|
||||||
: find-volumes ( -- array )
|
: find-volumes ( -- array )
|
||||||
find-first-volume
|
find-first-volume
|
||||||
|
@ -189,8 +186,8 @@ M: winnt file-systems ( -- array )
|
||||||
normalize-path open-read &dispose handle>>
|
normalize-path open-read &dispose handle>>
|
||||||
{ FILETIME FILETIME FILETIME }
|
{ FILETIME FILETIME FILETIME }
|
||||||
[ GetFileTime win32-error=0/f ]
|
[ GetFileTime win32-error=0/f ]
|
||||||
[ [ FILETIME>timestamp >local-time ] tri@ ]
|
|
||||||
with-out-parameters
|
with-out-parameters
|
||||||
|
[ FILETIME>timestamp >local-time ] tri@
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
: set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
|
: set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
|
||||||
|
|
|
@ -95,7 +95,7 @@ TUPLE: signal n ;
|
||||||
dup WIFSIGNALED [ WTERMSIG signal boa ] [ WEXITSTATUS ] if ;
|
dup WIFSIGNALED [ WTERMSIG signal boa ] [ WEXITSTATUS ] if ;
|
||||||
|
|
||||||
M: unix wait-for-processes ( -- ? )
|
M: unix wait-for-processes ( -- ? )
|
||||||
{ int } [ -1 swap WNOHANG waitpid ] [ ] with-out-parameters
|
{ int } [ -1 swap WNOHANG waitpid ] with-out-parameters
|
||||||
swap dup 0 <= [
|
swap dup 0 <= [
|
||||||
2drop t
|
2drop t
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -159,7 +159,7 @@ M: windows kill-process* ( handle -- )
|
||||||
|
|
||||||
: exit-code ( process -- n )
|
: exit-code ( process -- n )
|
||||||
hProcess>>
|
hProcess>>
|
||||||
{ DWORD } [ GetExitCodeProcess ] [ ] with-out-parameters
|
{ DWORD } [ GetExitCodeProcess ] with-out-parameters
|
||||||
swap win32-error=0/f ;
|
swap win32-error=0/f ;
|
||||||
|
|
||||||
: process-exited ( process -- )
|
: process-exited ( process -- )
|
||||||
|
|
|
@ -26,7 +26,7 @@ M: winnt WSASocket-flags ( -- DWORD )
|
||||||
WSAIoctl SOCKET_ERROR = [
|
WSAIoctl SOCKET_ERROR = [
|
||||||
winsock-error-string throw
|
winsock-error-string throw
|
||||||
] when
|
] when
|
||||||
] [ ] with-out-parameters ;
|
] with-out-parameters ;
|
||||||
|
|
||||||
TUPLE: ConnectEx-args port
|
TUPLE: ConnectEx-args port
|
||||||
s name namelen lpSendBuffer dwSendDataLength
|
s name namelen lpSendBuffer dwSendDataLength
|
||||||
|
|
|
@ -131,11 +131,11 @@ TUPLE: mach-error error-code error-string ;
|
||||||
dup KERN_SUCCESS = [ drop ] [ <mach-error> throw ] if ;
|
dup KERN_SUCCESS = [ drop ] [ <mach-error> throw ] if ;
|
||||||
|
|
||||||
: master-port ( -- port )
|
: master-port ( -- port )
|
||||||
MACH_PORT_NULL { uint } [ IOMasterPort mach-error ] [ ] with-out-parameters ;
|
MACH_PORT_NULL { uint } [ IOMasterPort mach-error ] with-out-parameters ;
|
||||||
|
|
||||||
: io-services-matching-dictionary ( nsdictionary -- iterator )
|
: io-services-matching-dictionary ( nsdictionary -- iterator )
|
||||||
master-port swap
|
master-port swap
|
||||||
{ uint } [ IOServiceGetMatchingServices mach-error ] [ ] with-out-parameters ;
|
{ uint } [ IOServiceGetMatchingServices mach-error ] with-out-parameters ;
|
||||||
|
|
||||||
: io-services-matching-service ( service -- iterator )
|
: io-services-matching-service ( service -- iterator )
|
||||||
IOServiceMatching io-services-matching-dictionary ;
|
IOServiceMatching io-services-matching-dictionary ;
|
||||||
|
|
|
@ -684,7 +684,7 @@ USE: alien
|
||||||
{ c:int float-4 } [
|
{ c:int float-4 } [
|
||||||
[ 123 swap 0 c:int c:set-alien-value ]
|
[ 123 swap 0 c:int c:set-alien-value ]
|
||||||
[ float-4{ 1 2 3 4 } swap 0 float-4 c:set-alien-value ] bi*
|
[ float-4{ 1 2 3 4 } swap 0 float-4 c:set-alien-value ] bi*
|
||||||
] [ ] with-out-parameters ;
|
] with-out-parameters ;
|
||||||
|
|
||||||
[ 123 float-4{ 1 2 3 4 } ] [ simd-stack-test ] unit-test
|
[ 123 float-4{ 1 2 3 4 } ] [ simd-stack-test ] unit-test
|
||||||
|
|
||||||
|
@ -696,7 +696,7 @@ USE: alien
|
||||||
{ c:int } [
|
{ c:int } [
|
||||||
123 swap 0 c:int c:set-alien-value
|
123 swap 0 c:int c:set-alien-value
|
||||||
>float (simd-stack-spill-test) float-4-with swap cos v*n
|
>float (simd-stack-spill-test) float-4-with swap cos v*n
|
||||||
] [ ] with-out-parameters ;
|
] with-out-parameters ;
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
1.047197551196598 simd-stack-spill-test
|
1.047197551196598 simd-stack-spill-test
|
||||||
|
|
|
@ -51,4 +51,4 @@ IN: opengl.framebuffers
|
||||||
|
|
||||||
: framebuffer-attachment ( attachment -- id )
|
: framebuffer-attachment ( attachment -- id )
|
||||||
GL_FRAMEBUFFER swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME
|
GL_FRAMEBUFFER swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME
|
||||||
{ uint } [ glGetFramebufferAttachmentParameteriv ] [ ] with-out-parameters ;
|
{ uint } [ glGetFramebufferAttachmentParameteriv ] with-out-parameters ;
|
||||||
|
|
|
@ -139,7 +139,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
||||||
swap glPushAttrib call glPopAttrib ; inline
|
swap glPushAttrib call glPopAttrib ; inline
|
||||||
|
|
||||||
: (gen-gl-object) ( quot -- id )
|
: (gen-gl-object) ( quot -- id )
|
||||||
[ 1 { uint } ] dip [ ] with-out-parameters ; inline
|
[ 1 { uint } ] dip with-out-parameters ; inline
|
||||||
|
|
||||||
: (delete-gl-object) ( id quot -- )
|
: (delete-gl-object) ( id quot -- )
|
||||||
[ 1 swap <uint> ] dip call ; inline
|
[ 1 swap <uint> ] dip call ; inline
|
||||||
|
|
|
@ -20,7 +20,7 @@ IN: opengl.shaders
|
||||||
dup integer? [ glIsShader c-bool> ] [ drop f ] if ;
|
dup integer? [ glIsShader c-bool> ] [ drop f ] if ;
|
||||||
|
|
||||||
: gl-shader-get-int ( shader enum -- value )
|
: gl-shader-get-int ( shader enum -- value )
|
||||||
{ int } [ glGetShaderiv ] [ ] with-out-parameters ;
|
{ int } [ glGetShaderiv ] with-out-parameters ;
|
||||||
|
|
||||||
: gl-shader-ok? ( shader -- ? )
|
: gl-shader-ok? ( shader -- ? )
|
||||||
GL_COMPILE_STATUS gl-shader-get-int c-bool> ;
|
GL_COMPILE_STATUS gl-shader-get-int c-bool> ;
|
||||||
|
@ -79,7 +79,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
|
||||||
dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;
|
dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;
|
||||||
|
|
||||||
: gl-program-get-int ( program enum -- value )
|
: gl-program-get-int ( program enum -- value )
|
||||||
{ int } [ glGetProgramiv ] [ ] with-out-parameters ;
|
{ int } [ glGetProgramiv ] with-out-parameters ;
|
||||||
|
|
||||||
: gl-program-ok? ( program -- ? )
|
: gl-program-ok? ( program -- ? )
|
||||||
GL_LINK_STATUS gl-program-get-int c-bool> ;
|
GL_LINK_STATUS gl-program-get-int c-bool> ;
|
||||||
|
|
|
@ -406,7 +406,7 @@ PRIVATE>
|
||||||
[ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
|
[ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
|
||||||
|
|
||||||
: get-texture-float ( target level enum -- value )
|
: get-texture-float ( target level enum -- value )
|
||||||
{ float } [ glGetTexLevelParameterfv ] [ ] with-out-parameters ; inline
|
{ float } [ glGetTexLevelParameterfv ] with-out-parameters ; inline
|
||||||
|
|
||||||
: get-texture-int ( target level enum -- value )
|
: get-texture-int ( target level enum -- value )
|
||||||
{ int } [ glGetTexLevelParameteriv ] [ ] with-out-parameters ; inline
|
{ int } [ glGetTexLevelParameteriv ] with-out-parameters ; inline
|
||||||
|
|
|
@ -137,7 +137,7 @@ SYMBOL: dpi
|
||||||
: line-offset>x ( layout n -- x )
|
: line-offset>x ( layout n -- x )
|
||||||
#! n is an index into the UTF8 encoding of the text
|
#! n is an index into the UTF8 encoding of the text
|
||||||
[ drop first-line ] [ swap string>> >utf8-index ] 2bi
|
[ drop first-line ] [ swap string>> >utf8-index ] 2bi
|
||||||
0 { int } [ pango_layout_line_index_to_x ] [ ] with-out-parameters
|
0 { int } [ pango_layout_line_index_to_x ] with-out-parameters
|
||||||
pango>float ;
|
pango>float ;
|
||||||
|
|
||||||
: x>line-offset ( layout x -- n )
|
: x>line-offset ( layout x -- n )
|
||||||
|
@ -146,7 +146,7 @@ SYMBOL: dpi
|
||||||
[ first-line ] dip
|
[ first-line ] dip
|
||||||
float>pango
|
float>pango
|
||||||
{ int int }
|
{ int int }
|
||||||
[ pango_layout_line_x_to_index drop ] [ ] with-out-parameters
|
[ pango_layout_line_x_to_index drop ] with-out-parameters
|
||||||
swap
|
swap
|
||||||
] [ drop string>> ] 2bi utf8-index> + ;
|
] [ drop string>> ] 2bi utf8-index> + ;
|
||||||
|
|
||||||
|
|
|
@ -23,7 +23,7 @@ CONSTANT: factor-crypto-container "FactorCryptoContainer"
|
||||||
type
|
type
|
||||||
flags
|
flags
|
||||||
CryptAcquireContextW
|
CryptAcquireContextW
|
||||||
] [ ] with-out-parameters ;
|
] with-out-parameters ;
|
||||||
|
|
||||||
: acquire-crypto-context ( provider type -- handle )
|
: acquire-crypto-context ( provider type -- handle )
|
||||||
CRYPT_MACHINE_KEYSET
|
CRYPT_MACHINE_KEYSET
|
||||||
|
|
|
@ -57,7 +57,7 @@ M: cocoa-ui-backend (pixel-format-attribute)
|
||||||
[ drop f ]
|
[ drop f ]
|
||||||
[
|
[
|
||||||
first
|
first
|
||||||
{ int } [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] [ ]
|
{ int } [ swap 0 -> getValues:forAttribute:forVirtualScreen: ]
|
||||||
with-out-parameters
|
with-out-parameters
|
||||||
] if-empty ;
|
] if-empty ;
|
||||||
|
|
||||||
|
|
|
@ -60,14 +60,14 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: WGL_ARB { $ WGL_SUPPORT_OPENGL_ARB 1 } H{
|
||||||
|
|
||||||
: arb-make-pixel-format ( world attributes -- pf )
|
: arb-make-pixel-format ( world attributes -- pf )
|
||||||
[ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 { int int }
|
[ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 { int int }
|
||||||
[ wglChoosePixelFormatARB win32-error=0/f ] [ ] with-out-parameters drop ;
|
[ wglChoosePixelFormatARB win32-error=0/f ] with-out-parameters drop ;
|
||||||
|
|
||||||
: arb-pixel-format-attribute ( pixel-format attribute -- value )
|
: arb-pixel-format-attribute ( pixel-format attribute -- value )
|
||||||
>WGL_ARB
|
>WGL_ARB
|
||||||
[ drop f ] [
|
[ drop f ] [
|
||||||
[ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
|
[ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
|
||||||
first <int> { int }
|
first <int> { int }
|
||||||
[ wglGetPixelFormatAttribivARB win32-error=0/f ] [ ]
|
[ wglGetPixelFormatAttribivARB win32-error=0/f ]
|
||||||
with-out-parameters
|
with-out-parameters
|
||||||
] if-empty ;
|
] if-empty ;
|
||||||
|
|
||||||
|
|
|
@ -39,11 +39,11 @@ SINGLETON: x11-ui-backend
|
||||||
XGetWindowProperty
|
XGetWindowProperty
|
||||||
Success assert=
|
Success assert=
|
||||||
]
|
]
|
||||||
|
with-out-parameters
|
||||||
[| type format n-atoms bytes-after atoms |
|
[| type format n-atoms bytes-after atoms |
|
||||||
atoms n-atoms <direct-ulong-array> >array
|
atoms n-atoms <direct-ulong-array> >array
|
||||||
atoms XFree
|
atoms XFree
|
||||||
]
|
] call ;
|
||||||
with-out-parameters ;
|
|
||||||
|
|
||||||
: net-wm-hint-supported? ( atom -- ? )
|
: net-wm-hint-supported? ( atom -- ? )
|
||||||
supported-net-wm-hints member? ;
|
supported-net-wm-hints member? ;
|
||||||
|
@ -93,7 +93,7 @@ M: x11-ui-backend (pixel-format-attribute)
|
||||||
[ handle>> ] [ >glx-visual ] bi*
|
[ handle>> ] [ >glx-visual ] bi*
|
||||||
[ 2drop f ] [
|
[ 2drop f ] [
|
||||||
first
|
first
|
||||||
{ int } [ glXGetConfig drop ] [ ] with-out-parameters
|
{ int } [ glXGetConfig drop ] with-out-parameters
|
||||||
] if-empty ;
|
] if-empty ;
|
||||||
|
|
||||||
CONSTANT: modifiers
|
CONSTANT: modifiers
|
||||||
|
|
|
@ -34,5 +34,5 @@ CONSTANT: WM_DWMCOMPOSITIONCHANGED HEX: 31E
|
||||||
|
|
||||||
: composition-enabled? ( -- ? )
|
: composition-enabled? ( -- ? )
|
||||||
windows-major 6 >=
|
windows-major 6 >=
|
||||||
[ { bool } [ DwmIsCompositionEnabled drop ] [ ] with-out-parameters ]
|
[ { bool } [ DwmIsCompositionEnabled drop ] with-out-parameters ]
|
||||||
[ f ] if ;
|
[ f ] if ;
|
||||||
|
|
|
@ -27,7 +27,7 @@ IN: windows.offscreen
|
||||||
[ nip ]
|
[ nip ]
|
||||||
[
|
[
|
||||||
swap (bitmap-info) DIB_RGB_COLORS { void* }
|
swap (bitmap-info) DIB_RGB_COLORS { void* }
|
||||||
[ f 0 CreateDIBSection ] [ ] with-out-parameters
|
[ f 0 CreateDIBSection ] with-out-parameters
|
||||||
] 2bi
|
] 2bi
|
||||||
[ [ SelectObject drop ] keep ] dip ;
|
[ [ SelectObject drop ] keep ] dip ;
|
||||||
|
|
||||||
|
|
|
@ -20,12 +20,12 @@ TUPLE: script-string < disposable font string metrics ssa size image ;
|
||||||
swap ! icp
|
swap ! icp
|
||||||
FALSE ! fTrailing
|
FALSE ! fTrailing
|
||||||
] if
|
] if
|
||||||
{ int } [ ScriptStringCPtoX ole32-error ] [ ] with-out-parameters ;
|
{ int } [ ScriptStringCPtoX ole32-error ] with-out-parameters ;
|
||||||
|
|
||||||
: x>line-offset ( x script-string -- n trailing )
|
: x>line-offset ( x script-string -- n trailing )
|
||||||
ssa>> ! ssa
|
ssa>> ! ssa
|
||||||
swap ! iX
|
swap ! iX
|
||||||
{ int int } [ ScriptStringXtoCP ole32-error ] [ ] with-out-parameters ;
|
{ int int } [ ScriptStringXtoCP ole32-error ] with-out-parameters ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue