M: string-type c-type-getter
drop [ alien-cell ] ;
+M: string-type c-type-copier
+ drop [ ] ;
+
M: string-type c-type-setter
drop [ set-alien-cell ] ;
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 )
M: c-type c-type-setter setter>> ;
MACRO: alien-value ( c-type -- quot: ( c-ptr offset -- value ) )
[ 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 -- ) )
[ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
[ c-type-setter ]
c-type-unboxer-quot
c-type-rep
c-type-getter
+ c-type-copier
c-type-setter
c-type-align
c-type-align-first
} ;
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."
$nl
"A scoped allocation specifier is either:"
M: value-type c-type-getter
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 ] ;
M: array c-type-boxer-quot
MACRO: out-parameters ( c-types -- quot )
[ dup hairy-local-allot? [ first ] when ] map
- [ length ] [ [ '[ 0 _ alien-value ] ] map ] bi
+ [ length ] [ [ '[ 0 _ alien-copy-value ] ] map ] bi
'[ _ nkeep _ spread ] ;
PRIVATE>
[ [ (local-allots) ] [ box-values ] bi ] dip call
(cleanup-allot) ; inline
-: with-out-parameters ( c-types quot finish -- values... )
- [ [ drop (local-allots) ] [ swap out-parameters ] 2bi ] dip call
+: with-out-parameters ( c-types quot -- values... )
+ [ drop (local-allots) ] [ swap out-parameters ] 2bi
(cleanup-allot) ; inline
GENERIC: binary-zero? ( value -- ? )
M: integer binary-zero? zero? ; inline
M: math:float binary-zero? double>bits zero? ; inline
M: complex binary-zero? >rect [ binary-zero? ] both? ; inline
-
: digest-value ( ctx -- value )
handle>>
{ { int EVP_MAX_MD_SIZE } int }
- [ EVP_DigestFinal_ex ssl-error ]
- [ memory>byte-array ]
- with-out-parameters ;
+ [ EVP_DigestFinal_ex ssl-error ] with-out-parameters
+ memory>byte-array ;
PRIVATE>
objc-methods get set-at ;
: each-method-in-class ( class quot -- )
- [ { uint } [ class_copyMethodList ] [ ] with-out-parameters ] dip
+ [ { uint } [ class_copyMethodList ] with-out-parameters ] dip
over 0 = [ 3drop ] [
[ <direct-void*-array> ] dip
[ each ] [ drop (free) ] 2bi
: nib-objects ( anNSNib -- objects/f )
f
- { void* } [ -> instantiateNibWithOwner:topLevelObjects: ] [ ]
+ { void* } [ -> instantiateNibWithOwner:topLevelObjects: ]
with-out-parameters
swap [ CF>array ] [ drop f ] if ;
\ No newline at end of file
: (read-plist) ( NSData -- id )
NSPropertyListSerialization swap kCFPropertyListImmutable f
{ void* }
- [ -> propertyListFromData:mutabilityOption:format:errorDescription: ] [ ]
+ [ -> propertyListFromData:mutabilityOption:format:errorDescription: ]
with-out-parameters
[ -> release "read-plist failed" throw ] when* ;
[ 3 ] [ blah ] unit-test
: 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
: 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
: out-param-test-3 ( -- x y )
{ { RECT initial: S{ RECT { x 3 } { y 4 } } } } [ drop ]
- [ clone ] with-out-parameters
+ with-out-parameters
[ x>> ] [ y>> ] bi ;
[ 3.0 4.0 ] [ out-param-test-3 ] unit-test
{ int } [
swap void { int pointer: int } cdecl
alien-indirect
- ] [ ] with-out-parameters ;
+ ] with-out-parameters ;
[ 12 ] [ 6 out-param-callback out-param-indirect ] unit-test
[
{ BitmapData }
[ BitmapData memory>struct ALIEN: 123 >>Scan0 drop ]
- [ clone ]
with-out-parameters Scan0>>
] compile-call
] unit-test
[ 0 swap <CFRange> kCFStringEncodingUTF8 0 f ] keep
4 * 1 + <byte-array> [
dup length
- { CFIndex } [ CFStringGetBytes drop ] [ ]
- with-out-parameters
+ { CFIndex } [ CFStringGetBytes drop ] with-out-parameters
] keep
swap head-slice utf8 decode ;
: typographic-bounds ( line -- width ascent descent leading )
{ CGFloat CGFloat CGFloat }
- [ CTLineGetTypographicBounds ] [ ] with-out-parameters ; inline
+ [ CTLineGetTypographicBounds ] with-out-parameters ; inline
: store-typographic-bounds ( metrics width ascent descent leading -- metrics )
{
] [
&postgresql-free
] if
- ] [ ] with-out-parameters memory>byte-array
+ ] with-out-parameters memory>byte-array
] with-destructors
] [
drop pq-get-is-null nip [ f ] [ B{ } clone ] if
: sqlite-open ( path -- db )
normalize-path
- { void* } [ sqlite3_open sqlite-check-result ] [ ]
+ { void* } [ sqlite3_open sqlite-check-result ]
with-out-parameters ;
: sqlite-close ( db -- )
: sqlite-prepare ( db sql -- handle )
utf8 encode dup length
{ void* void* }
- [ sqlite3_prepare_v2 sqlite-check-result ] [ drop ]
- with-out-parameters ;
+ [ sqlite3_prepare_v2 sqlite-check-result ]
+ with-out-parameters drop ;
: sqlite-bind-parameter-index ( handle name -- index )
sqlite3_bind_parameter_index ;
: query-pointer ( -- x y buttons )
dpy get dup XDefaultRootWindow
{ int int int int int int int }
- [ XQueryPointer drop ] [ ] with-out-parameters
+ [ XQueryPointer drop ] with-out-parameters
[ 4 ndrop ] 3dip ;
SYMBOL: mouse-reset?
nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
master-completion-port get-global
{ int void* pointer: OVERLAPPED }
- [ timeout GetQueuedCompletionStatus zero? ] [ ] with-out-parameters
+ [ timeout GetQueuedCompletionStatus zero? ] with-out-parameters
:> ( error? bytes key overlapped )
bytes overlapped error? ;
: (open-process-token) ( handle -- handle )
flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY }
{ PHANDLE }
- [ OpenProcessToken win32-error=0/f ] [ ]
+ [ OpenProcessToken win32-error=0/f ]
with-out-parameters ;
: open-process-token ( -- handle )
TUPLE: windows-file-info < file-info attributes ;
: 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 ;
: set-windows-size-on-disk ( file-info path -- file-info )
: volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
{ { ushort path-length } DWORD DWORD DWORD { ushort path-length } }
[ [ 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 )
{ ULARGE_INTEGER ULARGE_INTEGER ULARGE_INTEGER }
- [ GetDiskFreeSpaceEx win32-error=0/f ] [ ]
+ [ GetDiskFreeSpaceEx win32-error=0/f ]
with-out-parameters ;
: calculate-file-system-info ( file-system-info -- file-system-info' )
: volume>paths ( string -- array )
{ { ushort names-buf-length } uint }
[ [ 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 )
{ { ushort path-length } }
[ path-length FindFirstVolume dup win32-error=0/f ]
- [ utf16n alien>string ]
- with-out-parameters swap ;
+ with-out-parameters utf16n alien>string swap ;
: find-next-volume ( handle -- string/f )
{ { ushort path-length } }
- [ path-length FindNextVolume ]
- [
- swap 0 = [
- GetLastError ERROR_NO_MORE_FILES =
- [ drop f ] [ win32-error-string throw ] if
- ] [ utf16n alien>string ] if
- ] with-out-parameters ;
+ [ path-length FindNextVolume ] with-out-parameters
+ swap 0 = [
+ GetLastError ERROR_NO_MORE_FILES =
+ [ drop f ] [ win32-error-string throw ] if
+ ] [ utf16n alien>string ] if ;
: find-volumes ( -- array )
find-first-volume
normalize-path open-read &dispose handle>>
{ FILETIME FILETIME FILETIME }
[ GetFileTime win32-error=0/f ]
- [ [ FILETIME>timestamp >local-time ] tri@ ]
with-out-parameters
+ [ FILETIME>timestamp >local-time ] tri@
] with-destructors ;
: set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
dup WIFSIGNALED [ WTERMSIG signal boa ] [ WEXITSTATUS ] if ;
M: unix wait-for-processes ( -- ? )
- { int } [ -1 swap WNOHANG waitpid ] [ ] with-out-parameters
+ { int } [ -1 swap WNOHANG waitpid ] with-out-parameters
swap dup 0 <= [
2drop t
] [
: exit-code ( process -- n )
hProcess>>
- { DWORD } [ GetExitCodeProcess ] [ ] with-out-parameters
+ { DWORD } [ GetExitCodeProcess ] with-out-parameters
swap win32-error=0/f ;
: process-exited ( process -- )
WSAIoctl SOCKET_ERROR = [
winsock-error-string throw
] when
- ] [ ] with-out-parameters ;
+ ] with-out-parameters ;
TUPLE: ConnectEx-args port
s name namelen lpSendBuffer dwSendDataLength
dup KERN_SUCCESS = [ drop ] [ <mach-error> throw ] if ;
: 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 )
master-port swap
- { uint } [ IOServiceGetMatchingServices mach-error ] [ ] with-out-parameters ;
+ { uint } [ IOServiceGetMatchingServices mach-error ] with-out-parameters ;
: io-services-matching-service ( service -- iterator )
IOServiceMatching io-services-matching-dictionary ;
{ c:int float-4 } [
[ 123 swap 0 c:int c:set-alien-value ]
[ 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
{ c:int } [
123 swap 0 c:int c:set-alien-value
>float (simd-stack-spill-test) float-4-with swap cos v*n
- ] [ ] with-out-parameters ;
+ ] with-out-parameters ;
[ ] [
1.047197551196598 simd-stack-spill-test
: framebuffer-attachment ( attachment -- id )
GL_FRAMEBUFFER swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME
- { uint } [ glGetFramebufferAttachmentParameteriv ] [ ] with-out-parameters ;
+ { uint } [ glGetFramebufferAttachmentParameteriv ] with-out-parameters ;
swap glPushAttrib call glPopAttrib ; inline
: (gen-gl-object) ( quot -- id )
- [ 1 { uint } ] dip [ ] with-out-parameters ; inline
+ [ 1 { uint } ] dip with-out-parameters ; inline
: (delete-gl-object) ( id quot -- )
[ 1 swap <uint> ] dip call ; inline
dup integer? [ glIsShader c-bool> ] [ drop f ] if ;
: gl-shader-get-int ( shader enum -- value )
- { int } [ glGetShaderiv ] [ ] with-out-parameters ;
+ { int } [ glGetShaderiv ] with-out-parameters ;
: gl-shader-ok? ( shader -- ? )
GL_COMPILE_STATUS gl-shader-get-int c-bool> ;
dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;
: gl-program-get-int ( program enum -- value )
- { int } [ glGetProgramiv ] [ ] with-out-parameters ;
+ { int } [ glGetProgramiv ] with-out-parameters ;
: gl-program-ok? ( program -- ? )
GL_LINK_STATUS gl-program-get-int c-bool> ;
[ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
: 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 )
- { int } [ glGetTexLevelParameteriv ] [ ] with-out-parameters ; inline
+ { int } [ glGetTexLevelParameteriv ] with-out-parameters ; inline
: line-offset>x ( layout n -- x )
#! n is an index into the UTF8 encoding of the text
[ 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 ;
: x>line-offset ( layout x -- n )
[ first-line ] dip
float>pango
{ int int }
- [ pango_layout_line_x_to_index drop ] [ ] with-out-parameters
+ [ pango_layout_line_x_to_index drop ] with-out-parameters
swap
] [ drop string>> ] 2bi utf8-index> + ;
type
flags
CryptAcquireContextW
- ] [ ] with-out-parameters ;
+ ] with-out-parameters ;
: acquire-crypto-context ( provider type -- handle )
CRYPT_MACHINE_KEYSET
[ drop f ]
[
first
- { int } [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] [ ]
+ { int } [ swap 0 -> getValues:forAttribute:forVirtualScreen: ]
with-out-parameters
] if-empty ;
: arb-make-pixel-format ( world attributes -- pf )
[ 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 )
>WGL_ARB
[ drop f ] [
[ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
first <int> { int }
- [ wglGetPixelFormatAttribivARB win32-error=0/f ] [ ]
+ [ wglGetPixelFormatAttribivARB win32-error=0/f ]
with-out-parameters
] if-empty ;
XGetWindowProperty
Success assert=
]
+ with-out-parameters
[| type format n-atoms bytes-after atoms |
atoms n-atoms <direct-ulong-array> >array
atoms XFree
- ]
- with-out-parameters ;
+ ] call ;
: net-wm-hint-supported? ( atom -- ? )
supported-net-wm-hints member? ;
[ handle>> ] [ >glx-visual ] bi*
[ 2drop f ] [
first
- { int } [ glXGetConfig drop ] [ ] with-out-parameters
+ { int } [ glXGetConfig drop ] with-out-parameters
] if-empty ;
CONSTANT: modifiers
: composition-enabled? ( -- ? )
windows-major 6 >=
- [ { bool } [ DwmIsCompositionEnabled drop ] [ ] with-out-parameters ]
+ [ { bool } [ DwmIsCompositionEnabled drop ] with-out-parameters ]
[ f ] if ;
[ nip ]
[
swap (bitmap-info) DIB_RGB_COLORS { void* }
- [ f 0 CreateDIBSection ] [ ] with-out-parameters
+ [ f 0 CreateDIBSection ] with-out-parameters
] 2bi
[ [ SelectObject drop ] keep ] dip ;
swap ! icp
FALSE ! fTrailing
] if
- { int } [ ScriptStringCPtoX ole32-error ] [ ] with-out-parameters ;
+ { int } [ ScriptStringCPtoX ole32-error ] with-out-parameters ;
: x>line-offset ( x script-string -- n trailing )
ssa>> ! ssa
swap ! iX
- { int int } [ ScriptStringXtoCP ole32-error ] [ ] with-out-parameters ;
+ { int int } [ ScriptStringXtoCP ole32-error ] with-out-parameters ;
<PRIVATE