ARTICLE: "c-out-params" "Output parameters in C"
"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
$nl
-"Each numerical C type, together with " { $snippet "void*" } ", has an associated " { $emphasis "out parameter constructor" } " word which takes a Factor object as input, constructs a byte array of the correct size, and converts the Factor object to a C value stored into the byte array:"
-{ $subsections
- <char>
- <uchar>
- <short>
- <ushort>
- <int>
- <uint>
- <long>
- <ulong>
- <longlong>
- <ulonglong>
- <float>
- <double>
- <void*>
-}
-"You call the out parameter constructor with the required initial value, then pass the byte array to the C function, which receives a pointer to the start of the byte array's data area. The C function then returns, leaving the result in the byte array; you read it back using the next set of words:"
-{ $subsections
- *char
- *uchar
- *short
- *ushort
- *int
- *uint
- *long
- *ulong
- *longlong
- *ulonglong
- *float
- *double
- *void*
-}
+"To wrap Factor data for consumption by the FFI, we use a utility word that constructs a byte array of the correct size and converts the Factor object to a C value stored into that byte array:"
+{ $subsections <ref> }
+"You call the out parameter constructor with the required initial value, then pass the byte array to the C function, which receives a pointer to the start of the byte array's data area. The C function then returns, leaving the result in the byte array; you read it back using this word:"
+{ $subsections deref }
"Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link <void*> } " and " { $link *void* } " may be used." ;
ARTICLE: "c-types.primitives" "Primitive C types"
eval kernel tools.test sequences system libc alien.strings
io.encodings.ascii io.encodings.utf8 math.constants classes.struct classes
accessors compiler.units ;
+FROM: alien.c-types => short ;
IN: alien.c-types.tests
CONSTANT: xyz 123
[ 492 ] [ { int xyz } heap-size ] unit-test
-[ -1 ] [ -1 <char> *char ] unit-test
-[ -1 ] [ -1 <short> *short ] unit-test
-[ -1 ] [ -1 <int> *int ] unit-test
+[ -1 ] [ -1 char <ref> char deref ] unit-test
+[ -1 ] [ -1 short <ref> short deref ] unit-test
+[ -1 ] [ -1 int <ref> int deref ] unit-test
! I don't care if this throws an error or works, but at least
! it should be consistent between platforms
-[ -1 ] [ -1.0 <int> *int ] unit-test
-[ -1 ] [ -1.0 <long> *long ] unit-test
-[ -1 ] [ -1.0 <longlong> *longlong ] unit-test
-[ 1 ] [ 1.0 <uint> *uint ] unit-test
-[ 1 ] [ 1.0 <ulong> *ulong ] unit-test
-[ 1 ] [ 1.0 <ulonglong> *ulonglong ] unit-test
+[ -1 ] [ -1.0 int <ref> int deref ] unit-test
+[ -1 ] [ -1.0 long <ref> long deref ] unit-test
+[ -1 ] [ -1.0 longlong <ref> longlong deref ] unit-test
+[ 1 ] [ 1.0 uint <ref> uint deref ] unit-test
+[ 1 ] [ 1.0 ulong <ref> ulong deref ] unit-test
+[ 1 ] [ 1.0 ulonglong <ref> ulonglong deref ] unit-test
UNION-STRUCT: foo
{ a int }
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: byte-arrays arrays assocs delegate kernel kernel.private math
-math.order math.parser namespaces make parser sequences strings
-words splitting cpu.architecture alien alien.accessors
-alien.strings quotations layouts system compiler.units io
-io.files io.encodings.binary io.streams.memory accessors
-combinators effects continuations fry classes vocabs
-vocabs.loader words.symbol macros ;
+USING: accessors alien alien.accessors arrays byte-arrays
+classes combinators compiler.units cpu.architecture delegate
+fry kernel layouts locals macros math math.order quotations
+sequences system words words.symbol ;
QUALIFIED: math
IN: alien.c-types
SINGLETON: void
-DEFER: <int>
-DEFER: *char
+DEFER: <ref>
+DEFER: deref
TUPLE: abstract-c-type
{ class class initial: object }
M: c-type base-type ;
-: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
+: little-endian? ( -- ? ) 1 int <ref> char deref 1 = ; foldable
GENERIC: heap-size ( name -- size )
: c-type-clamp ( value c-type -- value' )
dup { float double } member-eq?
[ drop ] [ c-type-interval clamp ] if ; inline
+
+:: <ref> ( value c-type -- c-ptr )
+ c-type heap-size <byte-array> :> c-ptr
+ value c-ptr 0 c-type set-alien-value
+ c-ptr ; inline
+
+: deref ( c-ptr c-type -- value )
+ [ 0 ] dip alien-value ; inline
{
[ {
[ ascii string>alien ]
- [ <longlong> ]
- [ <float> ]
+ [ longlong <ref> ]
+ [ float <ref> ]
[ <complex-float> ]
- [ 1 0 ? <short> ]
+ [ 1 0 ? c:short <ref> ]
} spread ]
[ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ]
} 5 ncleave
[ drop ]
[ drop ]
[ drop ]
- [ *float ]
+ [ float deref ]
[ drop ]
[ drop ]
} spread
{
[ {
[ ascii string>alien ]
- [ <float> ]
+ [ float <ref> ]
[ ascii string>alien ]
} spread ]
[ { [ length ] [ drop ] [ length ] } spread ]
[ ascii alien>nstring ]
[ ]
[ ascii alien>nstring ]
- [ *float ]
+ [ float deref ]
[ ]
[ ascii alien>nstring ]
} spread
! (c) 2009 Joe Groff, see BSD license
-USING: accessors alien alien.c-types alien.complex alien.data
+USING: accessors alien alien.complex alien.c-types alien.data
alien.parser grouping alien.strings alien.syntax arrays ascii
assocs byte-arrays combinators combinators.short-circuit fry
generalizations kernel lexer macros math math.parser namespaces
M: integer-type (fortran-arg>c-args)
[
size>> {
- { f [ [ <int> ] [ drop ] ] }
- { 1 [ [ <char> ] [ drop ] ] }
- { 2 [ [ <short> ] [ drop ] ] }
- { 4 [ [ <int> ] [ drop ] ] }
- { 8 [ [ <longlong> ] [ drop ] ] }
+ { f [ [ c:int <ref> ] [ drop ] ] }
+ { 1 [ [ c:char <ref> ] [ drop ] ] }
+ { 2 [ [ c:short <ref> ] [ drop ] ] }
+ { 4 [ [ c:int <ref> ] [ drop ] ] }
+ { 8 [ [ c:longlong <ref> ] [ drop ] ] }
[ invalid-fortran-type ]
} case
] args?dims ;
M: real-type (fortran-arg>c-args)
[
size>> {
- { f [ [ <float> ] [ drop ] ] }
- { 4 [ [ <float> ] [ drop ] ] }
- { 8 [ [ <double> ] [ drop ] ] }
+ { f [ [ c:float <ref> ] [ drop ] ] }
+ { 4 [ [ c:float <ref> ] [ drop ] ] }
+ { 8 [ [ c:double <ref> ] [ drop ] ] }
[ invalid-fortran-type ]
} case
] args?dims ;
] args?dims ;
M: double-precision-type (fortran-arg>c-args)
- [ drop [ <double> ] [ drop ] ] args?dims ;
+ [ drop [ c:double <ref> ] [ drop ] ] args?dims ;
M: double-complex-type (fortran-arg>c-args)
[ drop [ <complex-double> ] [ drop ] ] args?dims ;
M: character-type (fortran-arg>c-args)
fix-character-type single-char?
- [ [ first <char> ] [ drop ] ]
+ [ [ first c:char <ref> ] [ drop ] ]
[ [ ascii string>alien ] [ length ] ] if ;
M: misc-type (fortran-arg>c-args)
[ dup dims>> [ drop { [ ] } ] ] dip if ; inline
M: integer-type (fortran-result>)
- [ size>> {
- { f [ { [ *int ] } ] }
- { 1 [ { [ *char ] } ] }
- { 2 [ { [ *short ] } ] }
- { 4 [ { [ *int ] } ] }
- { 8 [ { [ *longlong ] } ] }
- [ invalid-fortran-type ]
- } case ] result?dims ;
+ [
+ size>> {
+ { f [ { [ c:int deref ] } ] }
+ { 1 [ { [ c:char deref ] } ] }
+ { 2 [ { [ c:short deref ] } ] }
+ { 4 [ { [ c:int deref ] } ] }
+ { 8 [ { [ c:longlong deref ] } ] }
+ [ invalid-fortran-type ]
+ } case
+ ] result?dims ;
M: logical-type (fortran-result>)
[ call-next-method first [ zero? not ] append 1array ] result?dims ;
M: real-type (fortran-result>)
[ size>> {
- { f [ { [ *float ] } ] }
- { 4 [ { [ *float ] } ] }
- { 8 [ { [ *double ] } ] }
+ { f [ { [ c:float deref ] } ] }
+ { 4 [ { [ c:float deref ] } ] }
+ { 8 [ { [ c:double deref ] } ] }
[ invalid-fortran-type ]
} case ] result?dims ;
} case ] result?dims ;
M: double-precision-type (fortran-result>)
- [ drop { [ *double ] } ] result?dims ;
+ [ drop { [ c:double deref ] } ] result?dims ;
M: double-complex-type (fortran-result>)
[ drop { [ *complex-double ] } ] result?dims ;
M: character-type (fortran-result>)
fix-character-type single-char?
- [ { [ *char 1string ] } ]
+ [ { [ c:char deref 1string ] } ]
[ { [ ] [ ascii alien>nstring ] } ] if ;
M: misc-type (fortran-result>)
[ 4294967295 B{ 255 255 255 255 } -1 ]
[
- -1 <int> -1 <int>
+ -1 int <ref>
+ -1 int <ref>
[ [ 0 alien-unsigned-4 swap ] [ 0 alien-signed-2 ] bi ]
compile-call
] unit-test
alien.accessors alien.c-types alien.data alien.syntax alien.strings
namespaces libc io.encodings.ascii classes compiler.test ;
FROM: math => float ;
+FROM: alien.c-types => short ;
IN: compiler.tests.intrinsics
! Make sure that intrinsic ops compile to correct code.
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
-[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
-[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
+[ -100 ] [ -100 char <ref> [ { byte-array } declare char deref ] compile-call ] unit-test
+[ 156 ] [ -100 uchar <ref> [ { byte-array } declare uchar deref ] compile-call ] unit-test
-[ -100 ] [ -100 \ <char> def>> [ { fixnum } declare ] prepend compile-call *char ] unit-test
-[ 156 ] [ -100 \ <uchar> def>> [ { fixnum } declare ] prepend compile-call *uchar ] unit-test
+[ -100 ] [ -100 \ <char> def>> [ { fixnum } declare ] prepend compile-call char deref ] unit-test
+[ 156 ] [ -100 \ <uchar> def>> [ { fixnum } declare ] prepend compile-call uchar deref ] unit-test
-[ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-call ] unit-test
-[ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-call ] unit-test
+[ -1000 ] [ -1000 short <ref> [ { byte-array } declare short deref ] compile-call ] unit-test
+[ 64536 ] [ -1000 ushort <ref> [ { byte-array } declare ushort deref ] compile-call ] unit-test
-[ -1000 ] [ -1000 \ <short> def>> [ { fixnum } declare ] prepend compile-call *short ] unit-test
-[ 64536 ] [ -1000 \ <ushort> def>> [ { fixnum } declare ] prepend compile-call *ushort ] unit-test
+[ -1000 ] [ -1000 \ <short> def>> [ { fixnum } declare ] prepend compile-call short deref ] unit-test
+[ 64536 ] [ -1000 \ <ushort> def>> [ { fixnum } declare ] prepend compile-call ushort deref ] unit-test
-[ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-call ] unit-test
-[ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-call ] unit-test
+[ -100000 ] [ -100000 int <ref> [ { byte-array } declare int deref ] compile-call ] unit-test
+[ 4294867296 ] [ -100000 uint <ref> [ { byte-array } declare uint deref ] compile-call ] unit-test
-[ -100000 ] [ -100000 \ <int> def>> [ { fixnum } declare ] prepend compile-call *int ] unit-test
-[ 4294867296 ] [ -100000 \ <uint> def>> [ { fixnum } declare ] prepend compile-call *uint ] unit-test
+[ -100000 ] [ -100000 \ <int> def>> [ { fixnum } declare ] prepend compile-call int deref ] unit-test
+[ 4294867296 ] [ -100000 \ <uint> def>> [ { fixnum } declare ] prepend compile-call uint deref ] unit-test
-[ t ] [ pi pi <double> *double = ] unit-test
+[ t ] [ pi pi double <ref> double deref = ] unit-test
-[ t ] [ pi <double> [ { byte-array } declare *double ] compile-call pi = ] unit-test
+[ t ] [ pi double <ref> [ { byte-array } declare double deref ] compile-call pi = ] unit-test
! Silly
[ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-call ] keep *float pi - -0.001 0.001 between? ] unit-test
-[ t ] [ pi <float> [ { byte-array } declare *float ] compile-call pi - -0.001 0.001 between? ] unit-test
+[ t ] [ pi float <ref> [ { byte-array } declare float deref ] compile-call pi - -0.001 0.001 between? ] unit-test
[ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-call ] keep *double pi = ] unit-test
] when
[ t ] [
- [ B{ 1 0 } *short 0 number= ]
+ [ B{ 1 0 } short deref 0 number= ]
\ number= inlined?
] unit-test
[ t ] [
- [ B{ 1 0 } *short 0 { number number } declare number= ]
+ [ B{ 1 0 } short deref 0 { number number } declare number= ]
\ number= inlined?
] unit-test
[ t ] [
- [ B{ 1 0 } *short 0 = ]
+ [ B{ 1 0 } short deref 0 = ]
\ number= inlined?
] unit-test
[ t ] [
- [ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
+ [ B{ 1 0 } short deref dup number? [ 0 number= ] [ drop f ] if ]
\ number= inlined?
] unit-test
GENERIC: <CFNumber> ( number -- alien )
M: integer <CFNumber>
- [ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
+ [ f kCFNumberLongLongType ] dip longlong <ref> CFNumberCreate ;
M: float <CFNumber>
- [ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
+ [ f kCFNumberDoubleType ] dip double <ref> CFNumberCreate ;
M: t <CFNumber>
- drop f kCFNumberIntType 1 <int> CFNumberCreate ;
+ drop f kCFNumberIntType 1 int <ref> CFNumberCreate ;
M: f <CFNumber>
- drop f kCFNumberIntType 0 <int> CFNumberCreate ;
+ drop f kCFNumberIntType 0 int <ref> CFNumberCreate ;
SINGLETONS: big-endian little-endian ;
: compute-native-endianness ( -- class )
- 1 <int> *char 0 = big-endian little-endian ? ;
+ 1 int <ref> char deref 0 = big-endian little-endian ? ;
SYMBOL: native-endianness
native-endianness [ compute-native-endianness ] initialize
} 2cleave ;
: read-device-buffer ( device buffer count -- buffer count' )
- [ DIDEVICEOBJECTDATA heap-size ] 2dip <uint>
- [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
+ [ DIDEVICEOBJECTDATA heap-size ] 2dip uint <def>
+ [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep uint deref ;
: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
[ dwData>> 32 >signed ] [ dwOfs>> ] bi {
: wait-for-stdin ( stdin -- size )
[ control>> CHAR: X over io:stream-write1 io:stream-flush ]
- [ size>> ssize_t heap-size swap io:stream-read *int ]
+ [ size>> ssize_t heap-size swap io:stream-read int deref ]
bi ;
:: refill-stdin ( buffer stdin size -- )
M: stdin cancel-operation
[ size>> ] [ control>> ] bi [ cancel-operation ] bi@ ;
-: control-write-fd ( -- fd ) &: control_write *uint ;
+: control-write-fd ( -- fd ) &: control_write uint deref ;
-: size-read-fd ( -- fd ) &: size_read *uint ;
+: size-read-fd ( -- fd ) &: size_read uint deref ;
-: data-read-fd ( -- fd ) &: stdin_read *uint ;
+: data-read-fd ( -- fd ) &: stdin_read uint deref ;
: <stdin> ( -- stdin )
stdin new-disposable
ERROR: invalid-file-size n ;
: handle>file-size ( handle -- n )
- 0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
+ 0 ulonglong <ref> [ GetFileSizeEx win32-error=0/f ] keep ulonglong deref ;
ERROR: seek-before-start n ;
GetLastError ERROR_ALREADY_EXISTS = not ;
: set-file-pointer ( handle length method -- )
- [ [ handle>> ] dip d>w/w <uint> ] dip SetFilePointer
+ [ [ handle>> ] dip d>w/w uint <ref> ] dip SetFilePointer
INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ;
M: windows (file-reader) ( path -- stream )
[ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ]
[ "USERPROFILE" os-env ]
[ my-documents ]
- } 0|| ;
\ No newline at end of file
+ } 0|| ;
[ recursive>> 1 0 ? ]
} cleave
FILE_NOTIFY_CHANGE_ALL
- 0 <uint>
+ 0 uint <ref>
(make-overlapped)
[ f ReadDirectoryChangesW win32-error=0/f ] keep ;
swap
[ port>> htons >>port ]
[ host>> "0.0.0.0" or ]
- [ inet-pton *uint >>addr ] tri ;
+ [ inet-pton uint deref >>addr ] tri ;
M: ipv4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
- [ addr>> <uint> ] dip inet-ntop <ipv4> ;
+ [ addr>> uint <ref> ] dip inet-ntop <ipv4> ;
TUPLE: inet4 < ipv4 { port integer read-only } ;
socket dup io-error <fd> init-fd |dispose ;
: set-socket-option ( fd level opt -- )
- [ handle-fd ] 2dip 1 <int> dup byte-length setsockopt io-error ;
+ [ handle-fd ] 2dip 1 int <ref> dup byte-length setsockopt io-error ;
M: unix addrinfo-error ( n -- )
[ gai_strerror throw ] unless-zero ;
! Client sockets - TCP and Unix domain
M: object (get-local-address) ( handle remote -- sockaddr )
- [ handle-fd ] dip empty-sockaddr/size <int>
+ [ handle-fd ] dip empty-sockaddr/size int <ref>
[ getsockname io-error ] 2keep drop ;
M: object (get-remote-address) ( handle local -- sockaddr )
- [ handle-fd ] dip empty-sockaddr/size <int>
+ [ handle-fd ] dip empty-sockaddr/size int <ref>
[ getpeername io-error ] 2keep drop ;
: init-client-socket ( fd -- )
] with-destructors ;
: do-accept ( server addrspec -- fd sockaddr )
- [ handle>> handle-fd ] [ empty-sockaddr/size <int> ] bi*
+ [ handle>> handle-fd ] [ empty-sockaddr/size int <ref> ] bi*
[ accept ] 2keep drop ; inline
M: object (accept) ( server addrspec -- fd sockaddr )
packet-size ! nbytes
0 ! flags
sockaddr ! from
- len <int> ! fromlen
+ len int <ref> ! fromlen
recvfrom dup 0 >=
[ receive-buffer get-global swap memory>byte-array sockaddr ]
[ drop f f ]
opened-socket ;\r
\r
M: object (get-local-address) ( socket addrspec -- sockaddr )\r
- [ handle>> ] dip empty-sockaddr/size <int>\r
+ [ handle>> ] dip empty-sockaddr/size int <ref>\r
[ getsockname socket-error ] 2keep drop ;\r
\r
M: object (get-remote-address) ( socket addrspec -- sockaddr )\r
- [ handle>> ] dip empty-sockaddr/size <int>\r
+ [ handle>> ] dip empty-sockaddr/size int <ref>\r
[ getpeername socket-error ] 2keep drop ;\r
\r
: bind-socket ( win32-socket sockaddr len -- )\r
[ SOCK_RAW server-socket ] with-destructors ;\r
\r
: malloc-int ( n -- alien )\r
- <int> malloc-byte-array ; inline\r
+ int <ref> malloc-byte-array ; inline\r
\r
M: winnt WSASocket-flags ( -- DWORD )\r
WSA_FLAG_OVERLAPPED ;\r
} cleave AcceptEx drop winsock-error ; inline\r
\r
: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )\r
- f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;\r
+ f <void*> 0 int <ref> f <void*> [ 0 int <ref> GetAcceptExSockaddrs ] keep *void* ;\r
\r
: extract-remote-address ( AcceptEx -- sockaddr )\r
[\r
[\r
[ port>> addr>> empty-sockaddr dup ]\r
[ lpFrom>> ]\r
- [ lpFromLen>> *int ]\r
+ [ lpFromLen>> int deref ]\r
tri memcpy\r
] bi ; inline\r
\r
swap make-send-buffer >>lpBuffers\r
1 >>dwBufferCount\r
0 >>dwFlags\r
- 0 <uint> >>lpNumberOfBytesSent\r
+ 0 uint <ref> >>lpNumberOfBytesSent\r
(make-overlapped) >>lpOverlapped ; inline\r
\r
: call-WSASendTo ( WSASendTo -- )\r
[ 1 { uint } ] dip with-out-parameters ; inline
: (delete-gl-object) ( id quot -- )
- [ 1 swap <uint> ] dip call ; inline
+ [ 1 swap uint <ref> ] dip call ; inline
: gen-gl-buffer ( -- id )
[ glGenBuffers ] (gen-gl-object) ;
: gl-shader-info-log ( shader -- log )
dup gl-shader-info-log-length dup [
1 calloc &free
- [ 0 <int> swap glGetShaderInfoLog ] keep
+ [ 0 int <ref> swap glGetShaderInfoLog ] keep
ascii alien>string
] with-destructors ;
: gl-program-info-log ( program -- log )
dup gl-program-info-log-length dup [
1 calloc &free
- [ 0 <int> swap glGetProgramInfoLog ] keep
+ [ 0 int <ref> swap glGetProgramInfoLog ] keep
ascii alien>string
] with-destructors ;
: gl-program-shaders ( program -- shaders )
dup gl-program-shaders-length 2 *
- 0 <int>
+ 0 int <ref>
over <uint-array>
[ glGetAttachedShaders ] keep [ zero? not ] filter ;
secure-random-generator get swap with-random ; inline
: uniform-random-float ( min max -- n )
- 4 random-bytes underlying>> *uint >float
- 4 random-bytes underlying>> *uint >float
+ 4 random-bytes underlying>> uint deref >float
+ 4 random-bytes underlying>> uint deref >float
2.0 32 ^ * +
[ over - 2.0 -64 ^ * ] dip
* + ; inline
""
"FUNCTION: void get_device_info ( int* length ) ;"
""
- "0 <int> [ get_device_info ] keep <direct-int-array> ."
+ "0 int <ref> [ get_device_info ] keep <direct-int-array> ."
}
"For a full discussion of Factor heap allocation versus unmanaged memory allocation, see " { $link "byte-arrays-gc" } "."
$nl
FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, void* newp, size_t newlen ) ;
: make-int-array ( seq -- byte-array )
- [ <int> ] map concat ;
+ [ int <ref> ] map concat ;
: (sysctl-query) ( name namelen oldp oldlenp -- oldp )
over [ f 0 sysctl io-error ] dip ;
: sysctl-query ( seq n -- byte-array )
[ [ make-int-array ] [ length ] bi ] dip
- [ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
+ [ <byte-array> ] [ uint <ref> ] bi (sysctl-query) ;
: sysctl-query-string ( seq -- n )
4096 sysctl-query utf8 alien>string ;
: sysctl-query-uint ( seq -- n )
- 4 sysctl-query *uint ;
+ 4 sysctl-query uint deref ;
: sysctl-query-ulonglong ( seq -- n )
- 8 sysctl-query *ulonglong ;
+ 8 sysctl-query ulonglong deref ;
: machine ( -- str ) { 6 1 } sysctl-query-string ;
: model ( -- str ) { 6 2 } sysctl-query-string ;
: computer-name ( -- string )
MAX_COMPUTERNAME_LENGTH 1 +
- [ <byte-array> dup ] keep <uint>
+ [ <byte-array> dup ] keep uint <ref>
GetComputerName win32-error=0/f alien>native-string ;
: username ( -- string )
UNLEN 1 +
- [ <byte-array> dup ] keep <uint>
+ [ <byte-array> dup ] keep uint <ref>
GetUserName win32-error=0/f alien>native-string ;
: make-context-transparent ( view -- )
-> openGLContext
- 0 <int> NSOpenGLCPSurfaceOpacity -> setValues:forParameter: ;
+ 0 int <ref> NSOpenGLCPSurfaceOpacity -> setValues:forParameter: ;
M:: cocoa-ui-backend (open-window) ( world -- )
world [ [ dim>> ] dip <FactorView> ]
]
: sync-refresh-to-screen ( GLView -- )
- -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
+ -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 int <ref>
CGLSetParameter drop ;
: <FactorView> ( dim pixel-format -- view )
>WGL_ARB
[ drop f ] [
[ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
- first <int> { int }
+ first int <ref> { int }
[ wglGetPixelFormatAttribivARB win32-error=0/f ]
with-out-parameters
] if-empty ;
PRIVATE>
-: lo-word ( wparam -- lo ) <short> *short ; inline
+: lo-word ( wparam -- lo ) short <ref> short deref ; inline
: hi-word ( wparam -- hi ) -16 shift lo-word ; inline
: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
: GET_APPCOMMAND_LPARAM ( lParam -- appCommand )
<PRIVATE
: >groups ( byte-array n -- groups )
- [ 4 grouping:group ] dip head-slice [ *uint group-name ] map ;
+ [ 4 grouping:group ] dip head-slice [ uint deref group-name ] map ;
: (user-groups) ( string -- seq )
#! first group is -1337, legacy unix code
-1337 unix.ffi:NGROUPS_MAX [ 4 * <byte-array> ] keep
- <int> [ [ unix.ffi:getgrouplist ] unix-system-call drop ] 2keep
- [ 4 tail-slice ] [ *int 1 - ] bi* >groups ;
+ int <ref> [ [ unix.ffi:getgrouplist ] unix-system-call drop ] 2keep
+ [ 4 tail-slice ] [ int deref 1 - ] bi* >groups ;
PRIVATE>
TYPEDEF: int pid_t
TYPEDEF: int time_t
-ALIAS: <time_t> <int>
+: <time_t> ( n -- time_t ) int <ref> ;
cell-bits {
{ 32 [ "unix.types.netbsd.32" require ] }
TYPEDEF: int pid_t
TYPEDEF: int time_t
-ALIAS: <time_t> <int>
\ No newline at end of file
+: <time_t> ( n -- time_t ) int <ref> ;
[ key subkey mode ] dip n>win32-error-string
open-key-failed
] if
- ] keep *uint ;
+ ] keep uint deref ;
:: create-key* ( hKey lpSubKey lpClass dwOptions samDesired lpSecurityAttributes -- hkey new? )
hKey lpSubKey 0 lpClass dwOptions samDesired lpSecurityAttributes
DWORD <c-object>
f :> ret!
[ RegCreateKeyEx ret! ] 2keep
- [ *uint ]
- [ *uint REG_CREATED_NEW_KEY = ] bi*
+ [ uint deref ]
+ [ uint deref REG_CREATED_NEW_KEY = ] bi*
ret ERROR_SUCCESS = [
[
hKey lpSubKey 0 lpClass dwOptions samDesired
length 2 * <byte-array> ;
:: reg-query-value-ex ( key subkey ptr1 ptr2 buffer -- buffer )
- buffer length <uint> :> pdword
+ buffer length uint <ref> :> pdword
key subkey ptr1 ptr2 buffer pdword [ RegQueryValueEx ] 2keep
rot :> ret
ret ERROR_SUCCESS = [
- *uint head
+ uint deref head
] [
ret ERROR_MORE_DATA = [
2drop
key
MAX_PATH
dup TCHAR <c-array> dup :> class-buffer
- swap <int> dup :> class-buffer-length
+ swap int <ref> dup :> class-buffer-length
f
DWORD <c-object> dup :> sub-keys
DWORD <c-object> dup :> longest-subkey
ret ERROR_SUCCESS = [
key
class-buffer
- sub-keys *uint
- longest-subkey *uint
- longest-class-string *uint
- #values *uint
- max-value *uint
- max-value-data *uint
- security-descriptor *uint
+ sub-keys uint deref
+ longest-subkey uint deref
+ longest-class-string uint deref
+ #values uint deref
+ max-value uint deref
+ max-value-data uint deref
+ security-descriptor uint deref
last-write-time FILETIME>timestamp
registry-info boa
] [
21 2^ <byte-array> reg-query-value-ex ;
: read-registry ( key subkey -- registry-info )
- KEY_READ [ reg-query-info-key ] with-open-registry-key ;
\ No newline at end of file
+ KEY_READ [ reg-query-info-key ] with-open-registry-key ;
: window-property ( win prop delete? -- string )
[ [ dpy get ] 2dip 0 -1 ] dip AnyPropertyType
- 0 <Atom> 0
<int> 0 <ulong> 0 <ulong> f <void*>
+ 0 <Atom> 0
int <ref> 0 <ulong> 0 <ulong> f <void*>
[ XGetWindowProperty drop ] keep snarf-property ;
: selection-from-event ( event window -- string )
[ dpy get ] dip
[ requestor>> ]
[ property>> XA_TIMESTAMP 32 PropModeReplace ]
- [ time>> <int> ] tri
+ [ time>> int <ref> ] tri
1 XChangeProperty drop ;
: send-notify ( evt prop -- )
: lookup-string ( event xic -- string keysym )
[
prepare-lookup
- swap keybuf get buf-size keysym get 0 <int>
+ swap keybuf get buf-size keysym get 0 int <ref>
XwcLookupString
finish-lookup
] with-scope ;
IN: x11.xinput2
: (xi2-available?) ( display -- ? )
- 2 0 [ <int> ] bi@
+ 2 0 [ int <ref> ] bi@
XIQueryVersion
{
{ BadRequest [ f ] }
"_Z" head? ;
:: demangle ( mangled-name -- c++-name )
- 0 <ulong> :> length
- 0 <int> :> status [
+ 0 ulong <ref> :> length
+ 0 int <ref> :> status [
mangled-name ascii string>alien f length status __cxa_demangle &(free) :> demangled-buf
- mangled-name status *int demangle-error
+ mangled-name status int deref demangle-error
demangled-buf ascii alien>string
] with-destructors ;
cuCtxSynchronize cuda-error ; inline
: context-device ( -- n )
- CUdevice <c-object> [ cuCtxGetDevice cuda-error ] keep *int ; inline
+ CUdevice <c-object> [ cuCtxGetDevice cuda-error ] keep int deref ; inline
: destroy-context ( context -- ) cuCtxDestroy cuda-error ; inline
IN: cuda.devices
: #cuda-devices ( -- n )
- int <c-object> [ cuDeviceGetCount cuda-error ] keep *int ;
+ int <c-object> [ cuDeviceGetCount cuda-error ] keep int deref ;
: n>cuda-device ( n -- device )
- [ CUdevice <c-object> ] dip [ cuDeviceGet cuda-error ] 2keep drop *int ;
+ [ CUdevice <c-object> ] dip [ cuDeviceGet cuda-error ] 2keep
+ drop int deref ;
: enumerate-cuda-devices ( -- devices )
#cuda-devices iota [ n>cuda-device ] map ;
: cuda-device-capability ( n -- pair )
[ int <c-object> int <c-object> ] dip
[ cuDeviceComputeCapability cuda-error ]
- [ drop [ *int ] bi@ ] 3bi 2array ;
+ [ drop [ int deref ] bi@ ] 3bi 2array ;
: cuda-device-memory ( n -- bytes )
[ uint <c-object> ] dip
[ cuDeviceTotalMem cuda-error ]
- [ drop *uint ] 2bi ;
+ [ drop uint deref ] 2bi ;
: cuda-device-attribute ( attribute n -- n )
[ int <c-object> ] 2dip
[ cuDeviceGetAttribute cuda-error ]
- [ 2drop *int ] 3bi ;
+ [ 2drop int deref ] 3bi ;
: cuda-device. ( n -- )
{
[ 1 swap <void*> f cuGraphicsMapResources cuda-error ] [
[ CUdeviceptr <c-object> uint <c-object> ] dip
[ cuGraphicsResourceGetMappedPointer cuda-error ] 3keep drop
- [ *uint ] [ *uint ] bi*
+ [ uint deref ] [ uint deref ] bi*
] bi ; inline
: unmap-resource ( resource -- )
:: ecdsa-sign ( DGST -- sig )
ec-key-handle :> KEY
KEY ECDSA_size dup ssl-error <byte-array> :> SIG
- 0 <uint> :> LEN
+ 0 uint <ref> :> LEN
0 DGST dup length SIG LEN KEY ECDSA_sign ssl-error
- LEN *uint SIG resize ;
+ LEN uint deref SIG resize ;
: ecdsa-verify ( dgst sig -- ? )
ec-key-handle [ 0 -rot [ dup length ] bi@ ] dip ECDSA_verify 0 > ;
} case ; inline
: get-buffer-int ( target enum -- value )
- 0 <int> [ glGetBufferParameteriv ] keep *int ; inline
+ 0 int <ref> [ glGetBufferParameteriv ] keep int deref ; inline
: bind-buffer ( buffer -- target )
[ kind>> gl-target dup ] [ handle>> glBindBuffer ] bi ; inline
<PRIVATE
: get-framebuffer-int ( enum -- value )
- GL_RENDERBUFFER swap 0 <int> [ glGetRenderbufferParameteriv ] keep *int ;
+ GL_RENDERBUFFER swap 0 int <ref>
+ [ glGetRenderbufferParameteriv ] keep int deref ;
PRIVATE>
name length 1 + :> name-buffer-length
{
index name-buffer-length dup
- [ f 0 <int> 0 <int> ] dip <byte-array>
+ [ f 0 int <ref> 0 int <ref> ] dip <byte-array>
[ glGetTransformFeedbackVarying ] 3keep
ascii alien>string
vertex-attribute assert-feedback-attribute
[ set-gpu-state* ] if ; inline
: get-gl-bool ( enum -- value )
- 0 <uchar> [ glGetBooleanv ] keep *uchar c-bool> ;
+ 0 uchar <ref> [ glGetBooleanv ] keep uchar deref c-bool> ;
: get-gl-int ( enum -- value )
- 0 <int> [ glGetIntegerv ] keep *int ;
+ 0 int <ref> [ glGetIntegerv ] keep int deref ;
: get-gl-float ( enum -- value )
- 0 <float> [ glGetFloatv ] keep *float ;
+ 0 float <ref> [ glGetFloatv ] keep float deref ;
: get-gl-bools ( enum count -- value )
<byte-array> [ glGetBooleanv ] keep [ c-bool> ] { } map-as ;
FUNCTION: void alutLoadWAVFile ( c-string fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
M: macosx load-wav-file ( path -- format data size frequency )
- 0 <int> f <void*> 0 <int> 0 <int>
+ 0 int <ref> f <void*> 0 int <ref> 0 int <ref>
[ alutLoadWAVFile ] 4 nkeep
- [ [ [ *int ] dip *void* ] dip *int ] dip *int ;
+ [ [ [ int deref ] dip *void* ] dip int deref ] dip int deref ;
FUNCTION: void alutLoadWAVFile ( c-string fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
M: object load-wav-file ( filename -- format data size frequency )
- 0 <int> f <void*> 0 <int> 0 <int>
- [ 0 <char> alutLoadWAVFile ] 4 nkeep
- { [ *int ] [ *void* ] [ *int ] [ *int ] } spread ;
+ 0 int <ref>
+ f <void*>
+ 0 int <ref>
+ 0 int <ref>
+ [ 0 char <ref> alutLoadWAVFile ] 4 nkeep
+ { [ int deref ] [ *void* ] [ int deref ] [ int deref ] } spread ;
alSourcei ;
: get-source-param ( source param -- value )
- 0 <uint> dup [ alGetSourcei ] dip *uint ;
+ 0 uint <ref> dup [ alGetSourcei ] dip uint deref ;
: set-buffer-param ( source param value -- )
alBufferi ;
: get-buffer-param ( source param -- value )
- 0 <uint> dup [ alGetBufferi ] dip *uint ;
+ 0 uint <ref> dup [ alGetBufferi ] dip uint deref ;
: source-play ( source -- ) alSourcePlay ;
str-alien str-buffer dup length memcpy str-alien ;
:: opencl-square ( in -- out )
- 0 f 0 <uint> [ clGetPlatformIDs cl-success ] keep *uint
+ 0 f 0 uint <ref> [ clGetPlatformIDs cl-success ] keep uint deref
dup <void*-array> [ f clGetPlatformIDs cl-success ] keep first
CL_DEVICE_TYPE_DEFAULT 1 f <void*> [ f clGetDeviceIDs cl-success ] keep *void* :> device-id
- f 1 device-id <void*> f f 0 <int> [ clCreateContext ] keep *int cl-success :> context
- context device-id 0 0 <int> [ clCreateCommandQueue ] keep *int cl-success :> queue
+ f 1 device-id <void*> f f 0 int <ref> [ clCreateContext ] keep int deref cl-success :> context
+ context device-id 0 0 int <ref> [ clCreateCommandQueue ] keep int deref cl-success :> queue
[
context 1 kernel-source cl-string-array <void*>
- f 0 <int> [ clCreateProgramWithSource ] keep *int cl-success
+ f 0 int <ref> [ clCreateProgramWithSource ] keep int deref cl-success
[ 0 f f f f clBuildProgram cl-success ]
- [ "square" cl-string-array 0 <int> [ clCreateKernel ] keep *int cl-success ]
+ [ "square" cl-string-array 0 int <ref> [ clCreateKernel ] keep int deref cl-success ]
[ ] tri
] with-destructors :> ( kernel program )
context CL_MEM_READ_ONLY in byte-length f
- 0 <int> [ clCreateBuffer ] keep *int cl-success :> input
+ 0 int <ref> [ clCreateBuffer ] keep int deref cl-success :> input
context CL_MEM_WRITE_ONLY in byte-length f
- 0 <int> [ clCreateBuffer ] keep *int cl-success :> output
+ 0 int <ref> [ clCreateBuffer ] keep int deref cl-success :> output
queue input CL_TRUE 0 in byte-length in 0 f f clEnqueueWriteBuffer cl-success
kernel 0 cl_mem heap-size input <void*> clSetKernelArg cl-success
kernel 1 cl_mem heap-size output <void*> clSetKernelArg cl-success
- kernel 2 uint heap-size in length <uint> clSetKernelArg cl-success
+ kernel 2 uint heap-size in length uint <ref> clSetKernelArg cl-success
- queue kernel 1 f in length <ulonglong> f
+ queue kernel 1 f in length ulonglong <ref> f
0 f f clEnqueueNDRangeKernel cl-success
queue clFinish cl-success
cl-read-access num-bytes in <cl-buffer> &dispose :> in-buffer
cl-write-access num-bytes f <cl-buffer> &dispose :> out-buffer
- kernel in-buffer out-buffer num-floats <uint> 3array
+ kernel in-buffer out-buffer num-floats uint <ref> 3array
{ num-floats } [ ] cl-queue-kernel &dispose drop
cl-finish
dup f = [ cl-error ] [ drop ] if ; inline
: info-data-size ( handle name info-quot -- size_t )
- [ 0 f 0 <size_t> ] dip [ call cl-success ] 2keep drop *size_t ; inline
+ [ 0 f 0 <size_t> ] dip [ call cl-success ] 2keep drop size_t deref ; inline
: info-data-bytes ( handle name info-quot size -- bytes )
swap [ dup <byte-array> f ] dip [ call cl-success ] 3keep 2drop ; inline
[ 3dup info-data-size info-data-bytes ] dip call ; inline
: 2info-data-size ( handle1 handle2 name info-quot -- size_t )
- [ 0 f 0 <size_t> ] dip [ call cl-success ] 2keep drop *size_t ; inline
+ [ 0 f 0 <size_t> ] dip [ call cl-success ] 2keep drop size_t deref ; inline
: 2info-data-bytes ( handle1 handle2 name info-quot size -- bytes )
swap [ dup <byte-array> f ] dip [ call cl-success ] 3keep 2drop ; inline
[ 4dup 2info-data-size 2info-data-bytes ] dip call ; inline
: info-bool ( handle name quot -- ? )
- [ *uint CL_TRUE = ] info ; inline
+ [ uint deref CL_TRUE = ] info ; inline
: info-ulong ( handle name quot -- ulong )
- [ *ulonglong ] info ; inline
+ [ ulonglong deref ] info ; inline
: info-int ( handle name quot -- int )
- [ *int ] info ; inline
+ [ int deref ] info ; inline
: info-uint ( handle name quot -- uint )
- [ *uint ] info ; inline
+ [ uint deref ] info ; inline
: info-size_t ( handle name quot -- size_t )
- [ *size_t ] info ; inline
+ [ size_t deref ] info ; inline
: 2info-size_t ( handle1 handle2 name quot -- size_t )
- [ *size_t ] 2info ; inline
+ [ size_t deref ] 2info ; inline
: info-string ( handle name quot -- string )
[ ascii decode 1 head* ] info ; inline
: platform-devices ( platform-id -- devices )
CL_DEVICE_TYPE_ALL [
- 0 f 0 <uint> [ clGetDeviceIDs cl-success ] keep *uint
+ 0 f 0 uint <ref> [ clGetDeviceIDs cl-success ] keep uint deref
] [
rot dup <void*-array> [ f clGetDeviceIDs cl-success ] keep
] 2bi ; inline
[ length ]
[ strings>char*-array ]
[ [ length ] size_t-array{ } map-as ] tri
- 0 <int> [ clCreateProgramWithSource ] keep *int cl-success
+ 0 int <ref> [ clCreateProgramWithSource ] keep int deref cl-success
] with-destructors ;
:: (build-program) ( program-handle device options -- program )
] dip bind ; inline
: cl-platforms ( -- platforms )
- 0 f 0 <uint> [ clGetPlatformIDs cl-success ] keep *uint
+ 0 f 0 uint <ref> [ clGetPlatformIDs cl-success ] keep uint deref
dup <void*-array> [ f clGetPlatformIDs cl-success ] keep
[
dup
: <cl-context> ( devices -- cl-context )
[ f ] dip
[ length ] [ [ id>> ] void*-array{ } map-as ] bi
- f f 0 <int> [ clCreateContext ] keep *int cl-success
+ f f 0 int <ref> [ clCreateContext ] keep int deref cl-success
cl-context new-disposable swap >>handle ;
: <cl-queue> ( context device out-of-order? profiling? -- command-queue )
[ [ handle>> ] [ id>> ] bi* ] 2dip
[ [ CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE ] [ 0 ] if ]
[ [ CL_QUEUE_PROFILING_ENABLE ] [ 0 ] if ] bi* bitor
- 0 <int> [ clCreateCommandQueue ] keep *int cl-success
+ 0 int <ref> [ clCreateCommandQueue ] keep int deref cl-success
cl-queue new-disposable swap >>handle ;
: cl-out-of-order-execution? ( command-queue -- ? )
[ buffer-access-constant ]
[ [ CL_MEM_COPY_HOST_PTR ] [ CL_MEM_ALLOC_HOST_PTR ] if ] tri* bitor
] 2dip
- 0 <int> [ clCreateBuffer ] keep *int cl-success
+ 0 int <ref> [ clCreateBuffer ] keep int deref cl-success
cl-buffer new-disposable swap >>handle ;
: cl-read-buffer ( buffer-range -- byte-array )
[ [ CL_TRUE ] [ CL_FALSE ] if ]
[ addressing-mode-constant ]
[ filter-mode-constant ]
- tri* 0 <int> [ clCreateSampler ] keep *int cl-success
+ tri* 0 int <ref> [ clCreateSampler ] keep int deref cl-success
cl-sampler new-disposable swap >>handle ;
: cl-normalized-coords? ( sampler -- ? )
: <cl-kernel> ( program kernel-name -- kernel )
[ handle>> ] [ ascii encode 0 suffix ] bi*
- 0 <int> [ clCreateKernel ] keep *int cl-success
+ 0 int <ref> [ clCreateKernel ] keep int deref cl-success
cl-kernel new-disposable swap >>handle ; inline
: cl-kernel-name ( kernel -- string )
M: TYPE dispose* [ DBDEL f ] change-handle drop ;
M: TYPE at* ( key db -- value/f ? )
- handle>> swap object>bytes dup length 0 <int>
+ handle>> swap object>bytes dup length 0 int <ref>
DBGET [ [ memory>object ] [ tcfree ] bi t ] [ f f ] if* ;
M: TYPE assoc-size ( db -- size ) handle>> DBRNUM ;
: DBKEYS ( db -- keys )
[ assoc-size <vector> ] [ handle>> ] bi
- dup DBITERINIT drop 0 <int>
+ dup DBITERINIT drop 0 int <ref>
[ 2dup DBITERNEXT dup ] [
[ memory>object ] [ tcfree ] bi
[ pick ] dip swap push
projects / factor.git / commitdiff