"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." ;
+{ $subsections deref } ;
ARTICLE: "c-types.primitives" "Primitive C types"
"The following numerical types are defined in the " { $vocab-link "alien.c-types" } " vocabulary; a " { $snippet "u" } " prefix denotes an unsigned type:"
[ ] [ "hello world" ascii malloc-string "s" set ] unit-test
"s" get [
- [ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call ascii alien>string ] unit-test
- [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call ascii alien>string ] unit-test
+ [ "hello world" ] [ "s" get <void*> [ { byte-array } declare void* deref ] compile-call ascii alien>string ] unit-test
+ [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare void* deref ] compile-call ascii alien>string ] unit-test
[ ] [ "s" get free ] unit-test
] when
-[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare <void*> ] compile-call *void* ] unit-test
-[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare <void*> ] compile-call *void* ] unit-test
-[ f ] [ f [ { POSTPONE: f } declare <void*> ] compile-call *void* ] unit-test
+[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare <void*> ] compile-call void* deref ] unit-test
+[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare <void*> ] compile-call void* deref ] unit-test
+[ f ] [ f [ { POSTPONE: f } declare void* <ref> ] compile-call void* deref ] unit-test
[ 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 <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 deref ] unit-test
-[ 156 ] [ -100 \ <uchar> def>> [ { fixnum } declare ] prepend compile-call uchar deref ] unit-test
+[ -100 ] [ -100 [ char <ref> ] [ { fixnum } declare ] prepend compile-call char deref ] unit-test
+[ 156 ] [ -100 [ uchar <ref> ] [ { fixnum } declare ] prepend compile-call uchar deref ] 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 deref ] unit-test
-[ 64536 ] [ -1000 \ <ushort> def>> [ { fixnum } declare ] prepend compile-call ushort deref ] unit-test
+[ -1000 ] [ -1000 [ short <ref> ] [ { fixnum } declare ] prepend compile-call short deref ] unit-test
+[ 64536 ] [ -1000 [ ushort <ref> ] [ { fixnum } declare ] prepend compile-call ushort deref ] 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 deref ] unit-test
-[ 4294867296 ] [ -100000 \ <uint> def>> [ { fixnum } declare ] prepend compile-call uint deref ] unit-test
+[ -100000 ] [ -100000 [ int <ref> ] [ { fixnum } declare ] prepend compile-call int deref ] unit-test
+[ 4294867296 ] [ -100000 [ uint <ref> ] [ { fixnum } declare ] prepend compile-call uint deref ] unit-test
[ t ] [ pi pi double <ref> double deref = ] unit-test
M: unix unset-os-env ( key -- ) unsetenv io-error ;
M: unix (os-envs) ( -- seq )
- environ *void* utf8 alien>strings ;
+ environ void* deref utf8 alien>strings ;
: set-void* ( value alien -- ) 0 set-alien-cell ;
: create-dinput ( -- )
f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
- f <void*> [ f DirectInput8Create ole32-error ] keep *void*
+ f void* <ref> [ f DirectInput8Create ole32-error ] keep void* deref
+dinput+ set-global ;
: delete-dinput ( -- )
+dinput+ [ com-release f ] change-global ;
: device-for-guid ( guid -- device )
- +dinput+ get-global swap f <void*>
- [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
+ +dinput+ get-global swap f void* <ref>
+ [ f IDirectInput8W::CreateDevice ole32-error ] keep void* deref ;
: set-coop-level ( device -- )
+device-change-window+ get-global DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
M: linux find-next-file ( DIR* -- dirent )
dirent <struct>
- f <void*>
+ f void* <ref>
[ [ readdir64_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep
- *void* [ drop f ] unless ;
+ void* deref [ drop f ] unless ;
M: unix find-next-file ( DIR* -- byte-array )
dirent <struct>
- f <void*>
+ f void* <ref>
[ readdir_r 0 = [ (io-error) ] unless ] 2keep
- *void* [ drop f ] unless ;
+ void* deref [ drop f ] unless ;
: dirent-type>file-type ( ch -- type )
{
io-size owner type-id filesystem-subtype ;
M: macosx file-systems ( -- array )
- f <void*> dup 0 getmntinfo64 dup io-error
- [ *void* ] dip <direct-statfs64-array>
+ f void* <ref> dup 0 getmntinfo64 dup io-error
+ [ void* deref ] dip <direct-statfs64-array>
[ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ;
M: macosx new-file-system-info macosx-file-system-info new ;
GetCurrentProcess ! source process
swap handle>> ! handle
GetCurrentProcess ! target process
- f <void*> [ ! target handle
+ f void* <ref> [ ! target handle
DUPLICATE_SAME_ACCESS ! desired access
TRUE ! inherit handle
0 ! options
DuplicateHandle win32-error=0/f
- ] keep *void* <win32-handle> &dispose ;
+ ] keep void* deref <win32-handle> &dispose ;
! /dev/null simulation
: null-input ( -- pipe )
C: <inet> inet
M: string resolve-host
- f prepare-addrinfo f <void*>
- [ getaddrinfo addrinfo-error ] keep *void* addrinfo memory>struct
+ f prepare-addrinfo f void* <ref>
+ [ getaddrinfo addrinfo-error ] keep void* deref addrinfo memory>struct
[ parse-addrinfo-list ] keep freeaddrinfo ;
M: string with-port <inet> ;
} cleave AcceptEx drop winsock-error ; inline\r
\r
: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )\r
- f <void*> 0 int <ref> f <void*> [ 0 int <ref> GetAcceptExSockaddrs ] keep *void* ;\r
+ f void* <ref> 0 int <ref> f void* <ref>\r
+ [ 0 int <ref> GetAcceptExSockaddrs ] keep void* deref ;\r
\r
: extract-remote-address ( AcceptEx -- sockaddr )\r
[\r
io-objects-from-iterator* [ release-io-object ] dip ;
: properties-from-io-object ( o -- o nsdictionary )
- dup f <void*> [
+ dup f void* <ref> [
kCFAllocatorDefault kNilOptions
IORegistryEntryCreateCFProperties mach-error
]
- keep *void* ;
+ keep void* deref ;
: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
[ \ unix.ffi:group <struct> ] dip over 4096
- [ <byte-array> ] keep f <void*> ;
+ [ <byte-array> ] keep f void* <ref> ;
: check-group-struct ( group-struct ptr -- group-struct/f )
- *void* [ drop f ] unless ;
+ void* deref [ drop f ] unless ;
M: integer group-struct ( id -- group/f )
(group-struct)
SPECIALIZED-ARRAY: void*
: more? ( alien -- ? )
- { [ ] [ *void* ] } 1&& ;
+ { [ ] [ void* deref ] } 1&& ;
: advance ( void* -- void* )
cell swap <displaced-alien> ;
: alien>strings ( alien encoding -- strings )
[ [ dup more? ] ] dip
- '[ [ advance ] [ *void* _ alien>string ] bi ]
+ '[ [ advance ] [ void* deref _ alien>string ] bi ]
produce nip ;
: strings>alien ( strings encoding -- array )
MACRO: com-invoke ( n return parameters -- )
[ 2nip length ] 3keep
'[
- _ npick *void* _ cell * alien-cell _ _
+ _ npick void* deref _ cell * alien-cell _ _
stdcall alien-indirect
] ;
f ! piDx
f ! pTabdef
f ! pbInClass
- f <void*> ! pssa
+ f void* <ref> ! pssa
[ ScriptStringAnalyse ] keep
- [ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
+ [ ole32-error ] [ |ScriptStringFree void* deref ] bi* ;
: set-dc-colors ( dc font -- )
[ background>> color>RGB SetBkColor drop ]
PRIVATE>
M: script-string dispose*
- ssa>> <void*> ScriptStringFree ole32-error ;
+ ssa>> void* <ref> ScriptStringFree ole32-error ;
SYMBOL: cached-script-strings
CurrentTime XConvertSelection drop ;
: snarf-property ( prop-return -- string )
- dup *void* [ *void* utf8 alien>string ] [ drop f ] if ;
+ dup void* deref [ void* deref utf8 alien>string ] [ drop f ] if ;
: window-property ( win prop delete? -- string )
[ [ dpy get ] 2dip 0 -1 ] dip AnyPropertyType
- 0 <Atom> 0 int <ref> 0 <ulong> 0 <ulong> f <void*>
+ 0 <Atom> 0 int <ref> 0 ulong <ref> 0 ulong <ref> f void* <ref>
[ XGetWindowProperty drop ] keep snarf-property ;
: selection-from-event ( event window -- string )
[ init-vorbis-codec ] if ;
: get-pending-decoded-audio ( vorbis-stream -- pcm len )
- dsp-state>> f <void*> [ vorbis_synthesis_pcmout ] keep *void* swap ;
+ dsp-state>> f void* <ref> [ vorbis_synthesis_pcmout ] keep void* deref swap ;
: float>short-sample ( float -- short )
-32767.5 * 0.5 - >integer -32768 32767 clamp ; inline
: create-context ( device flags -- context )
swap
[ CUcontext <c-object> ] 2dip
- [ cuCtxCreate cuda-error ] 3keep 2drop *void* ; inline
+ [ cuCtxCreate cuda-error ] 3keep 2drop void* deref ; inline
: sync-context ( -- )
cuCtxSynchronize cuda-error ; inline
: create-gl-cuda-context ( device flags -- context )
swap
[ CUcontext <c-object> ] 2dip
- [ cuGLCtxCreate cuda-error ] 3keep 2drop *void* ; inline
+ [ cuGLCtxCreate cuda-error ] 3keep 2drop void* deref ; inline
: with-gl-cuda-context ( device flags quot -- )
[ set-up-cuda-context create-gl-cuda-context ] dip (with-cuda-context) ; inline
: gl-buffer>resource ( gl-buffer flags -- resource )
enum>number
[ CUgraphicsResource <c-object> ] 2dip
- [ cuGraphicsGLRegisterBuffer cuda-error ] 3keep 2drop *void* ; inline
+ [ cuGraphicsGLRegisterBuffer cuda-error ] 3keep 2drop void* deref ; inline
: buffer>resource ( buffer flags -- resource )
[ handle>> ] dip gl-buffer>resource ; inline
: map-resource ( resource -- device-ptr size )
- [ 1 swap <void*> f cuGraphicsMapResources cuda-error ] [
+ [ 1 swap void* <ref> f cuGraphicsMapResources cuda-error ] [
[ CUdeviceptr <c-object> uint <c-object> ] dip
[ cuGraphicsResourceGetMappedPointer cuda-error ] 3keep drop
[ uint deref ] [ uint deref ] bi*
] bi ; inline
: unmap-resource ( resource -- )
- 1 swap <void*> f cuGraphicsUnmapResources cuda-error ; inline
+ 1 swap void* <ref> f cuGraphicsUnmapResources cuda-error ; inline
DESTRUCTOR: unmap-resource
: load-module ( path -- module )
[ CUmodule <c-object> ] dip
- [ cuModuleLoad cuda-error ] 2keep drop c:*void* ;
+ [ cuModuleLoad cuda-error ] 2keep drop c:void* c:deref ;
: unload-module ( module -- )
cuModuleUnload cuda-error ;
: get-function-ptr ( module string -- function )
[ CUfunction <c-object> ] 2dip
- [ cuModuleGetFunction cuda-error ] 3keep 2drop c:*void* ;
+ [ cuModuleGetFunction cuda-error ] 3keep 2drop c:void* c:deref ;
: cached-module ( module-name -- alien )
lookup-cuda-library
: eval-js ( string -- result-string )
[ js-context get dup ] dip
JSStringCreateWithUTF8CString f f 0 JSValueRef <c-object>
- [ JSEvaluateScript ] keep *void*
+ [ JSEvaluateScript ] keep void* deref
dup [ nip JSValueRef>string javascriptcore-error ] [ drop JSValueRef>string ] if ;
: eval-js-standalone ( string -- result-string )
LLVMGetFirstFunction dup ALIEN: 0 = [ drop ] [ (remove-functions) ] if ;
: remove-provider ( provider -- )
- current-jit ee>> value>> swap value>> f <void*> f <void*>
- [ LLVMRemoveModuleProvider drop ] 2keep *void* [ llvm-throw ] when*
- *void* module new swap >>value
+ current-jit ee>> value>> swap value>> f void* <ref> f void* <ref>
+ [ LLVMRemoveModuleProvider drop ] 2keep void* deref [ llvm-throw ] when*
+ void* deref module new swap >>value
[ value>> remove-functions ] with-disposal ;
: remove-module ( name -- )
: function-pointer ( name -- alien )
current-jit ee>> value>> dup
- rot f <void*> [ LLVMFindFunction drop ] keep
- *void* LLVMGetPointerToGlobal ;
\ No newline at end of file
+ rot f void* <ref> [ LLVMFindFunction drop ] keep
+ void* deref LLVMGetPointerToGlobal ;
: buffer>module ( buffer -- module )
[
- value>> f <void*> f <void*>
+ value>> f void* <ref> f void* <ref>
[ LLVMParseBitcode drop ] 2keep
- *void* [ llvm-throw ] when* *void*
+ void* deref [ llvm-throw ] when* void* deref
module new swap >>value
] with-disposal ;
<buffer> buffer>module ;
: load-into-jit ( path name -- )
- [ load-module ] dip add-module ;
\ No newline at end of file
+ [ load-module ] dip add-module ;
: (engine) ( provider -- engine )
[
- value>> f <void*> f <void*>
+ value>> f void* <ref> f void* <ref>
[ swapd 0 swap LLVMCreateJITCompiler drop ] 2keep
- *void* [ llvm-throw ] when* *void*
+ void* deref [ llvm-throw ] when* void* deref
]
[ t >>disposed drop ] bi
engine <dispose> ;
M: buffer dispose* value>> LLVMDisposeMemoryBuffer ;
: <buffer> ( path -- module )
- f <void*> f <void*>
+ f void* <ref> f void* <ref>
[ LLVMCreateMemoryBufferWithContentsOfFile drop ] 2keep
- *void* [ llvm-throw ] when* *void* buffer <dispose> ;
\ No newline at end of file
+ void* deref [ llvm-throw ] when* void* deref buffer <dispose> ;
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 <ref> f <void*> 0 int <ref> 0 int <ref>
+ 0 int <ref> f void* <ref> 0 int <ref> 0 int <ref>
[ alutLoadWAVFile ] 4 nkeep
- [ [ [ int deref ] dip *void* ] dip int deref ] dip int deref ;
+ [ [ [ int deref ] dip void* deref ] dip int deref ] dip int deref ;
M: object load-wav-file ( filename -- format data size frequency )
0 int <ref>
- f <void*>
+ f void* <ref>
0 int <ref>
0 int <ref>
[ 0 char <ref> alutLoadWAVFile ] 4 nkeep
- { [ int deref ] [ *void* ] [ int deref ] [ int deref ] } spread ;
+ { [ int deref ] [ void* deref ] [ int deref ] [ int deref ] } spread ;
:: opencl-square ( in -- out )
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 <ref> [ clCreateContext ] keep int deref cl-success :> context
+ CL_DEVICE_TYPE_DEFAULT 1 f void* <ref> [ f clGetDeviceIDs cl-success ] keep void* deref :> device-id
+ f 1 device-id void* <ref> 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*>
+ context 1 kernel-source cl-string-array void* <ref>
f 0 int <ref> [ clCreateProgramWithSource ] keep int deref cl-success
[ 0 f f f f clBuildProgram cl-success ]
[ "square" cl-string-array 0 int <ref> [ clCreateKernel ] keep int deref cl-success ]
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 0 cl_mem heap-size input void* <ref> clSetKernelArg cl-success
+ kernel 1 cl_mem heap-size output void* <ref> clSetKernelArg cl-success
kernel 2 uint heap-size in length uint <ref> clSetKernelArg cl-success
queue kernel 1 f in length ulonglong <ref> f
[ clGetEventProfilingInfo ] info-ulong ;
: bind-kernel-arg-buffer ( kernel index buffer -- )
- [ handle>> ] [ cl_mem heap-size ] [ handle>> <void*> ] tri*
+ [ handle>> ] [ cl_mem heap-size ] [ handle>> void* deref ] tri*
clSetKernelArg cl-success ; inline
: bind-kernel-arg-data ( kernel index byte-array -- )
[ [ buffer>> handle>> ] [ offset>> ] bi ]
tri* swapd
] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty
- f <void*> [ clEnqueueCopyBuffer cl-success ] keep *void* cl-event
+ f void* <ref> [ clEnqueueCopyBuffer cl-success ] keep void* deref cl-event
new-disposable swap >>handle ;
: cl-queue-read-buffer ( buffer-range alien dependent-events -- event )
[ (current-cl-queue) handle>> ] dip
[ buffer>> handle>> CL_FALSE ] [ offset>> ] [ size>> ] tri
] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty
- f <void*> [ clEnqueueReadBuffer cl-success ] keep *void* cl-event
+ f void* <ref> [ clEnqueueReadBuffer cl-success ] keep void* <ref> cl-event
new-disposable swap >>handle ;
: cl-queue-write-buffer ( buffer-range alien dependent-events -- event )
[ (current-cl-queue) handle>> ] dip
[ buffer>> handle>> CL_FALSE ] [ offset>> ] [ size>> ] tri
] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty
- f <void*> [ clEnqueueWriteBuffer cl-success ] keep *void* cl-event
+ f void* <ref> [ clEnqueueWriteBuffer cl-success ] keep void* deref cl-event
new-disposable swap >>handle ;
: <cl-sampler> ( normalized-coords? addressing-mode filter-mode -- sampler )
kernel handle>>
sizes [ length f ] [ [ ] size_t-array{ } map-as f ] bi
dependent-events [ length ] [ [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty ] bi
- f <void*> [ clEnqueueNDRangeKernel cl-success ] keep *void*
+ f void* <ref> [ clEnqueueNDRangeKernel cl-success ] keep void* deref
cl-event new-disposable swap >>handle ;
: cl-event-type ( event -- command-type )
: cl-marker ( -- event )
(current-cl-queue)
- f <void*> [ clEnqueueMarker cl-success ] keep *void* cl-event new-disposable
+ f void* <ref> [ clEnqueueMarker cl-success ] keep void* deref cl-event new-disposable
swap >>handle ; inline
: cl-barrier ( -- )
projects / factor.git / commitdiff