More Win32 IO work; FFI updates
Mackenzie Straight
parent
e06d3e29ac
commit
4b92b047ed
|
|
@ -25,7 +25,7 @@
|
|||
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
||||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
IN: buffer
|
||||
IN: kernel-internals
|
||||
|
||||
USE: alien
|
||||
USE: errors
|
||||
|
|
@ -36,49 +36,76 @@ USE: namespaces
|
|||
USE: strings
|
||||
USE: win32-api
|
||||
|
||||
SYMBOL: buf-size
|
||||
SYMBOL: buf-ptr
|
||||
SYMBOL: buf-fill
|
||||
SYMBOL: buf-pos
|
||||
|
||||
: imalloc ( size -- address )
|
||||
"int" "libc" "malloc" [ "int" ] alien-invoke ;
|
||||
|
||||
: ifree ( address -- )
|
||||
"void" "libc" "free" [ "int" ] alien-invoke ;
|
||||
|
||||
: irealloc ( address size -- address )
|
||||
"int" "libc" "realloc" [ "int" "int" ] alien-invoke ;
|
||||
|
||||
: <buffer> ( size -- buffer )
|
||||
#! Allocates and returns a new buffer.
|
||||
<namespace> [
|
||||
dup "size" set
|
||||
imalloc "buffer" set
|
||||
0 "fill" set
|
||||
0 "pos" set
|
||||
dup buf-size set
|
||||
imalloc buf-ptr set
|
||||
0 buf-fill set
|
||||
0 buf-pos set
|
||||
] extend ;
|
||||
|
||||
: buffer-free ( buffer -- )
|
||||
#! Frees the C memory associated with the buffer.
|
||||
[ "buffer" get ifree ] bind ;
|
||||
[ buf-ptr get ifree ] bind ;
|
||||
|
||||
: buffer-contents ( buffer -- string )
|
||||
#! Returns the current contents of the buffer.
|
||||
[
|
||||
"buffer" get "pos" get +
|
||||
"fill" get "pos" get -
|
||||
buf-ptr get buf-pos get +
|
||||
buf-fill get buf-pos get -
|
||||
memory>string
|
||||
] bind ;
|
||||
|
||||
: buffer-first-n ( count buffer -- string )
|
||||
[
|
||||
buf-fill get buf-pos get - min
|
||||
buf-ptr get buf-pos get +
|
||||
swap memory>string
|
||||
] bind ;
|
||||
|
||||
: buffer-reset ( count buffer -- )
|
||||
#! Reset the position to 0 and the fill pointer to count.
|
||||
[ 0 "pos" set "fill" set ] bind ;
|
||||
[ 0 buf-pos set buf-fill set ] bind ;
|
||||
|
||||
: buffer-consume ( count buffer -- )
|
||||
#! Consume count characters from the beginning of the buffer.
|
||||
[ "pos" [ + "fill" get min ] change ] bind ;
|
||||
[
|
||||
buf-pos [ + buf-fill get min ] change
|
||||
buf-pos get buf-fill get = [
|
||||
0 buf-pos set 0 buf-fill set
|
||||
] when
|
||||
] bind ;
|
||||
|
||||
: buffer-length ( buffer -- length )
|
||||
#! Returns the amount of unconsumed input in the buffer.
|
||||
[ "fill" get "pos" get - max ] bind ;
|
||||
[ buf-fill get buf-pos get - 0 max ] bind ;
|
||||
|
||||
: buffer-size ( buffer -- size )
|
||||
[ buf-size get ] bind ;
|
||||
|
||||
: buffer-capacity ( buffer -- int )
|
||||
#! Returns the amount of data that may be added to the buffer.
|
||||
[ buf-size get buf-fill get - ] bind ;
|
||||
|
||||
: buffer-set ( string buffer -- )
|
||||
#! Set the contents of a buffer to string.
|
||||
[
|
||||
dup "buffer" get string>memory
|
||||
dup buf-ptr get string>memory
|
||||
str-length namespace buffer-reset
|
||||
] bind ;
|
||||
|
||||
|
|
@ -86,19 +113,27 @@ USE: win32-api
|
|||
#! Appends a string to the end of the buffer. If it doesn't fit,
|
||||
#! an error is thrown.
|
||||
[
|
||||
dup "size" get "fill" get - swap str-length < [
|
||||
dup buf-size get buf-fill get - swap str-length < [
|
||||
"Buffer overflow" throw
|
||||
] when
|
||||
dup "buffer" get "fill" get + string>memory
|
||||
"fill" [ swap str-length + ] change
|
||||
dup buf-ptr get buf-fill get + string>memory
|
||||
buf-fill [ swap str-length + ] change
|
||||
] bind ;
|
||||
|
||||
: buffer-fill ( buffer quot -- )
|
||||
#! Execute quot with buffer as its argument, passing its result to
|
||||
#! buffer-reset.
|
||||
swap dup >r swap call r> buffer-reset ; inline
|
||||
: buffer-extend ( length buffer -- )
|
||||
#! Increases the size of the buffer by length.
|
||||
[
|
||||
buf-size get + dup buf-ptr get swap irealloc
|
||||
buf-ptr set buf-size set
|
||||
] bind ;
|
||||
|
||||
: buffer-fill ( count buffer -- )
|
||||
#! Increases the fill pointer by count.
|
||||
[ buf-fill [ + ] change ] bind ;
|
||||
|
||||
: buffer-ptr ( buffer -- pointer )
|
||||
#! Returns the memory address of the buffer area.
|
||||
[ "buffer" get ] bind ;
|
||||
[ buf-ptr get ] bind ;
|
||||
|
||||
: buffer-pos ( buffer -- int )
|
||||
[ buf-ptr get buf-pos get + ] bind ;
|
||||
|
|
|
|||
|
|
@ -84,3 +84,5 @@ M: win32-console-stream fwrite-attr ( string style stream -- )
|
|||
C: win32-console-stream ( stream -- stream )
|
||||
[ delegate set -11 GetStdHandle handle set ] extend ;
|
||||
|
||||
global [ [ <win32-console-stream> ] smart-term-hook set ] bind
|
||||
|
||||
|
|
|
|||
|
|
@ -27,20 +27,42 @@
|
|||
|
||||
IN: win32-io-internals
|
||||
USE: alien
|
||||
USE: errors
|
||||
USE: kernel
|
||||
USE: kernel-internals
|
||||
USE: lists
|
||||
USE: math
|
||||
USE: namespaces
|
||||
USE: prettyprint
|
||||
USE: vectors
|
||||
USE: win32-api
|
||||
|
||||
SYMBOL: completion-port
|
||||
SYMBOL: io-queue
|
||||
SYMBOL: free-list
|
||||
SYMBOL: callbacks
|
||||
|
||||
: handle-io-error ( -- )
|
||||
#! If a write or read call fails unexpectedly, throw an error.
|
||||
GetLastError [
|
||||
ERROR_IO_PENDING ERROR_HANDLE_EOF ERROR_SUCCESS
|
||||
] contains? [
|
||||
win32-throw-error
|
||||
] unless ;
|
||||
|
||||
: win32-init-stdio ( -- )
|
||||
INVALID_HANDLE_VALUE NULL NULL 1 CreateIoCompletionPort
|
||||
"completion-port" set ;
|
||||
completion-port set
|
||||
|
||||
<namespace> [
|
||||
32 <vector> callbacks set
|
||||
f free-list set
|
||||
] extend io-queue set ;
|
||||
|
||||
: get-access ( -- file-mode )
|
||||
0 "file-mode" get uncons >r
|
||||
[ GENERIC_WRITE ] [ 0 ] ifte bitor r>
|
||||
[ GENERIC_READ ] [ 0 ] ifte bitor ;
|
||||
"file-mode" get uncons
|
||||
[ GENERIC_WRITE ] [ 0 ] ifte >r
|
||||
[ GENERIC_READ ] [ 0 ] ifte r> bitor ;
|
||||
|
||||
: get-sharemode ( -- share-mode )
|
||||
FILE_SHARE_READ FILE_SHARE_WRITE bitor FILE_SHARE_DELETE bitor ;
|
||||
|
|
@ -57,6 +79,53 @@ USE: win32-api
|
|||
cons "file-mode" set
|
||||
get-access get-sharemode NULL get-create FILE_FLAG_OVERLAPPED NULL
|
||||
CreateFile dup INVALID_HANDLE_VALUE = [ win32-throw-error ] when
|
||||
dup "completion-port" get NULL 1 CreateIoCompletionPort drop
|
||||
dup completion-port get NULL 1 CreateIoCompletionPort drop
|
||||
] with-scope ;
|
||||
|
||||
BEGIN-STRUCT: indirect-pointer
|
||||
FIELD: int value
|
||||
END-STRUCT
|
||||
|
||||
: num-callbacks ( -- len )
|
||||
#! Returns the length of the callback vector.
|
||||
io-queue get [ callbacks get vector-length ] bind ;
|
||||
|
||||
: set-callback-quot ( quot index -- )
|
||||
io-queue get [
|
||||
dup >r callbacks get vector-nth car swap cons
|
||||
r> callbacks get set-vector-nth
|
||||
] bind ;
|
||||
|
||||
: new-overlapped ( -- index )
|
||||
#! Allocates and returns a new entry for the io queue.
|
||||
#! The new index in the callback vector is returned.
|
||||
io-queue get [
|
||||
"overlapped-ext" c-type [ "width" get ] bind imalloc <alien>
|
||||
dup num-callbacks swap
|
||||
set-overlapped-ext-user-data
|
||||
unit num-callbacks dup >r callbacks get set-vector-nth r>
|
||||
] bind ;
|
||||
|
||||
: alloc-io-task ( quot -- overlapped )
|
||||
io-queue get [
|
||||
free-list get [
|
||||
uncons free-list set
|
||||
] [ new-overlapped ] ifte*
|
||||
[ set-callback-quot ] keep
|
||||
callbacks get vector-nth car
|
||||
] bind ;
|
||||
|
||||
: get-io-callback ( index -- callback )
|
||||
#! Returns and frees the io queue entry at index.
|
||||
io-queue get [
|
||||
dup free-list [ cons ] change
|
||||
callbacks get vector-nth cdr
|
||||
] bind ;
|
||||
|
||||
: win32-next-io-task ( -- quot )
|
||||
completion-port get <indirect-pointer> dup >r <indirect-pointer>
|
||||
<indirect-pointer> dup >r INFINITE GetQueuedCompletionStatus
|
||||
[ handle-io-error ] unless
|
||||
r> r> indirect-pointer-value swap indirect-pointer-value <alien>
|
||||
overlapped-ext-user-data get-io-callback call ;
|
||||
|
||||
|
|
|
|||
|
|
@ -27,38 +27,122 @@
|
|||
|
||||
IN: win32-stream
|
||||
USE: alien
|
||||
USE: buffer
|
||||
USE: continuations
|
||||
USE: generic
|
||||
USE: kernel
|
||||
USE: kernel-internals
|
||||
USE: lists
|
||||
USE: math
|
||||
USE: namespaces
|
||||
USE: prettyprint
|
||||
USE: stdio
|
||||
USE: streams
|
||||
USE: strings
|
||||
USE: threads
|
||||
USE: win32-api
|
||||
USE: win32-io-internals
|
||||
|
||||
TRAITS: win32-stream
|
||||
GENERIC: update-file-pointer
|
||||
|
||||
SYMBOL: handle
|
||||
SYMBOL: in-buffer
|
||||
SYMBOL: out-buffer
|
||||
SYMBOL: fileptr
|
||||
SYMBOL: file-size
|
||||
|
||||
: init-overlapped ( overlapped -- overlapped )
|
||||
0 over set-overlapped-ext-internal
|
||||
0 over set-overlapped-ext-internal-high
|
||||
fileptr get over set-overlapped-ext-offset
|
||||
0 over set-overlapped-ext-offset-high
|
||||
0 over set-overlapped-ext-event ;
|
||||
|
||||
: update-file-pointer ( whence -- )
|
||||
file-size get [ fileptr [ + ] change ] when ;
|
||||
|
||||
: flush-output ( -- )
|
||||
[
|
||||
alloc-io-task init-overlapped >r
|
||||
handle get out-buffer get [ buffer-pos ] keep buffer-length
|
||||
NULL r> WriteFile [ handle-io-error ] unless win32-next-io-task
|
||||
] callcc1
|
||||
|
||||
dup out-buffer get [ buffer-consume ] keep
|
||||
swap namespace update-file-pointer
|
||||
buffer-length 0 > [ flush-output ] when ;
|
||||
|
||||
: do-write ( str -- )
|
||||
dup str-length out-buffer get buffer-capacity <= [
|
||||
out-buffer get buffer-append
|
||||
] [
|
||||
dup str-length out-buffer get buffer-size > [
|
||||
dup str-length out-buffer get buffer-extend do-write
|
||||
] [ flush-output do-write ] ifte
|
||||
] ifte ;
|
||||
|
||||
: fill-input ( -- )
|
||||
[
|
||||
alloc-io-task init-overlapped >r
|
||||
handle get in-buffer get [ buffer-pos ] keep
|
||||
buffer-capacity file-size get [ fileptr get - min ] when*
|
||||
NULL r>
|
||||
ReadFile [ handle-io-error ] unless win32-next-io-task
|
||||
] callcc1
|
||||
|
||||
dup in-buffer get buffer-fill
|
||||
namespace update-file-pointer ;
|
||||
|
||||
: consume-input ( count -- str )
|
||||
in-buffer get buffer-length 0 = [ fill-input ] when
|
||||
in-buffer get buffer-size min
|
||||
dup in-buffer get buffer-first-n
|
||||
swap in-buffer get buffer-consume ;
|
||||
|
||||
: do-read-count ( sbuf count -- str )
|
||||
dup 0 = [
|
||||
drop sbuf>str
|
||||
] [
|
||||
dup consume-input
|
||||
dup str-length dup 0 = [
|
||||
3drop dup sbuf-length 0 > [ sbuf>str ] [ drop f ] ifte
|
||||
] [
|
||||
>r swap r> - >r swap [ sbuf-append ] keep r> do-read-count
|
||||
] ifte
|
||||
] ifte ;
|
||||
|
||||
M: win32-stream fwrite-attr ( str style stream -- )
|
||||
nip fwrite ;
|
||||
nip [ do-write ] bind ;
|
||||
|
||||
M: win32-stream freadln ( stream -- str )
|
||||
drop f ;
|
||||
|
||||
M: win32-stream fread# ( count stream -- str )
|
||||
drop f ;
|
||||
[ dup <sbuf> swap do-read-count ] bind ;
|
||||
|
||||
M: win32-stream fflush ( stream -- )
|
||||
drop ;
|
||||
[ flush-output ] bind ;
|
||||
|
||||
M: win32-stream fclose ( stream -- )
|
||||
[ "handle" get CloseHandle drop "buffer" get buffer-free ] bind ;
|
||||
[
|
||||
flush-output
|
||||
handle get CloseHandle drop
|
||||
in-buffer get buffer-free
|
||||
out-buffer get buffer-free
|
||||
] bind ;
|
||||
|
||||
C: win32-stream ( handle -- stream )
|
||||
[ "handle" set 4096 <buffer> "buffer" set 0 "fp" set ] extend ;
|
||||
[
|
||||
dup NULL GetFileSize dup INVALID_FILE_SIZE = not [
|
||||
file-size set
|
||||
] [ drop f file-size set ] ifte
|
||||
handle set
|
||||
4096 <buffer> in-buffer set
|
||||
4096 <buffer> out-buffer set
|
||||
0 fileptr set
|
||||
] extend ;
|
||||
|
||||
: <win32-filecr> ( path -- stream )
|
||||
t f win32-open-file <win32-stream> ;
|
||||
|
||||
: <win32-filecw> ( path -- stream )
|
||||
f t win32-open-file <win32-stream> ;
|
||||
|
|
|
|||
|
|
@ -29,8 +29,20 @@ IN: win32-api
|
|||
USE: buffer
|
||||
USE: errors
|
||||
USE: kernel
|
||||
USE: kernel-internals
|
||||
USE: lists
|
||||
USE: math
|
||||
USE: parser
|
||||
USE: alien
|
||||
USE: words
|
||||
|
||||
: CONSTANT: CREATE
|
||||
[ [ [ parsed ] each ] cons define-compound POSTPONE: parsing ]
|
||||
[ ] ; parsing
|
||||
|
||||
CONSTANT: ERROR_SUCCESS 0 ;
|
||||
CONSTANT: ERROR_HANDLE_EOF 38 ;
|
||||
CONSTANT: ERROR_IO_PENDING 997 ;
|
||||
|
||||
: FORMAT_MESSAGE_ALLOCATE_BUFFER HEX: 00000100 ;
|
||||
: FORMAT_MESSAGE_IGNORE_INSERTS HEX: 00000200 ;
|
||||
|
|
|
|||
|
|
@ -70,10 +70,16 @@ END-STRUCT
|
|||
: STD_ERROR_HANDLE -12 ;
|
||||
|
||||
: INVALID_HANDLE_VALUE -1 <alien> ;
|
||||
: INVALID_FILE_SIZE HEX: FFFFFFFF ;
|
||||
|
||||
: INFINITE HEX: FFFFFFFF ;
|
||||
|
||||
: GetStdHandle ( id -- handle )
|
||||
"void*" "kernel32" "GetStdHandle" [ "int" ] alien-invoke ;
|
||||
|
||||
: GetFileSize ( handle out -- int )
|
||||
"int" "kernel32" "GetFileSize" [ "void*" "void*" ] alien-invoke ;
|
||||
|
||||
: SetConsoleTextAttribute ( handle attrs -- ? )
|
||||
"bool" "kernel32" "SetConsoleTextAttribute" [ "void*" "int" ]
|
||||
alien-invoke ;
|
||||
|
|
@ -99,6 +105,12 @@ END-STRUCT
|
|||
[ "void*" "void*" "void*" "int" ]
|
||||
alien-invoke ;
|
||||
|
||||
: GetQueuedCompletionStatus
|
||||
( port out-len out-key out-overlapped timeout -- ? )
|
||||
"bool" "kernel32" "GetQueuedCompletionStatus"
|
||||
[ "void*" "void*" "void*" "void*" "int" ]
|
||||
alien-invoke ;
|
||||
|
||||
: CreateFile ( name access sharemode security create flags template -- handle )
|
||||
"void*" "kernel32" "CreateFileA"
|
||||
[ "char*" "int" "int" "void*" "int" "int" "void*" ]
|
||||
|
|
|
|||
30
native/ffi.c
30
native/ffi.c
|
|
@ -1,5 +1,35 @@
|
|||
#include "factor.h"
|
||||
|
||||
void primitive_dlopen(void)
|
||||
{
|
||||
maybe_garbage_collection();
|
||||
dpush(tag_object(ffi_dlopen(untag_string(dpop()))));
|
||||
}
|
||||
|
||||
void primitive_dlsym(void)
|
||||
{
|
||||
DLL *dll;
|
||||
F_STRING *sym;
|
||||
|
||||
maybe_garbage_collection();
|
||||
|
||||
dll = untag_dll(dpop());
|
||||
sym = untag_string(dpop());
|
||||
dpush(tag_cell(ffi_dlsym(dll, sym)));
|
||||
}
|
||||
|
||||
void primitive_dlclose(void)
|
||||
{
|
||||
maybe_garbage_collection();
|
||||
ffi_dlclose(untag_dll(dpop()));
|
||||
}
|
||||
|
||||
void primitive_dlsym_self(void)
|
||||
{
|
||||
maybe_garbage_collection();
|
||||
dpush(tag_cell(ffi_dlsym(NULL, untag_string(dpop()))));
|
||||
}
|
||||
|
||||
DLL* untag_dll(CELL tagged)
|
||||
{
|
||||
DLL* dll = (DLL*)UNTAG(tagged);
|
||||
|
|
|
|||
|
|
@ -18,6 +18,10 @@ INLINE ALIEN* untag_alien(CELL tagged)
|
|||
return (ALIEN*)UNTAG(tagged);
|
||||
}
|
||||
|
||||
DLL *ffi_dlopen(F_STRING *path);
|
||||
void *ffi_dlsym(DLL *dll, F_STRING *symbol);
|
||||
void ffi_dlclose(DLL *dll);
|
||||
|
||||
void primitive_dlopen(void);
|
||||
void primitive_dlsym(void);
|
||||
void primitive_dlsym_self(void);
|
||||
|
|
|
|||
|
|
@ -106,8 +106,7 @@ void relocate_primitive(F_REL* rel, bool relative)
|
|||
void relocate_dlsym(F_REL* rel, bool relative)
|
||||
{
|
||||
F_STRING* str = untag_string(get(rel->argument));
|
||||
char* c_str = to_c_string(str);
|
||||
put(rel->offset,(CELL)dlsym(NULL,c_str)
|
||||
put(rel->offset,(CELL)ffi_dlsym(NULL,str)
|
||||
- (relative ? rel->offset + CELLS : 0));
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -1,16 +1,12 @@
|
|||
#include "../factor.h"
|
||||
|
||||
void primitive_dlopen(void)
|
||||
DLL *ffi_dlopen(F_STRING *path)
|
||||
{
|
||||
#ifdef FFI
|
||||
char* path;
|
||||
void* dllptr;
|
||||
DLL* dll;
|
||||
|
||||
maybe_garbage_collection();
|
||||
|
||||
path = unbox_c_string();
|
||||
dllptr = dlopen(path,RTLD_LAZY);
|
||||
dllptr = dlopen(to_c_string(path), RTLD_LAZY);
|
||||
|
||||
if(dllptr == NULL)
|
||||
{
|
||||
|
|
@ -20,47 +16,31 @@ void primitive_dlopen(void)
|
|||
|
||||
dll = allot_object(DLL_TYPE,sizeof(DLL));
|
||||
dll->dll = dllptr;
|
||||
dpush(tag_object(dll));
|
||||
return dll;
|
||||
#else
|
||||
general_error(ERROR_FFI_DISABLED,F);
|
||||
#endif
|
||||
}
|
||||
|
||||
void primitive_dlsym(void)
|
||||
void *ffi_dlsym(DLL *dll, F_STRING *symbol)
|
||||
{
|
||||
#ifdef FFI
|
||||
DLL* dll = untag_dll(dpop());
|
||||
void* sym = dlsym(dll->dll,unbox_c_string());
|
||||
void* sym = dlsym(dll ? dll->dll : NULL, to_c_string(symbol));
|
||||
if(sym == NULL)
|
||||
{
|
||||
general_error(ERROR_FFI,tag_object(
|
||||
from_c_string(dlerror())));
|
||||
}
|
||||
dpush(tag_cell((CELL)sym));
|
||||
return sym;
|
||||
#else
|
||||
general_error(ERROR_FFI_DISABLED,F);
|
||||
#endif
|
||||
}
|
||||
|
||||
void primitive_dlsym_self(void)
|
||||
{
|
||||
#if defined(FFI)
|
||||
void* sym = dlsym(NULL,unbox_c_string());
|
||||
if(sym == NULL)
|
||||
{
|
||||
general_error(ERROR_FFI,tag_object(
|
||||
from_c_string(dlerror())));
|
||||
}
|
||||
dpush(tag_cell((CELL)sym));
|
||||
#else
|
||||
general_error(ERROR_FFI_DISABLED,F);
|
||||
#endif
|
||||
}
|
||||
|
||||
void primitive_dlclose(void)
|
||||
void ffi_dlclose(DLL *dll)
|
||||
{
|
||||
#ifdef FFI
|
||||
DLL* dll = untag_dll(dpop());
|
||||
if(dlclose(dll->dll) == -1)
|
||||
{
|
||||
general_error(ERROR_FFI,tag_object(
|
||||
|
|
|
|||
|
|
@ -1,66 +1,46 @@
|
|||
#include "../factor.h"
|
||||
|
||||
void primitive_dlopen (void)
|
||||
DLL *ffi_dlopen (F_STRING *path)
|
||||
{
|
||||
#ifdef FFI
|
||||
char *path;
|
||||
HMODULE module;
|
||||
DLL *dll;
|
||||
|
||||
maybe_garbage_collection();
|
||||
|
||||
path = unbox_c_string();
|
||||
module = LoadLibrary(path);
|
||||
module = LoadLibrary(to_c_string(path));
|
||||
|
||||
if (!module)
|
||||
general_error(ERROR_FFI, tag_object(last_error()));
|
||||
|
||||
dll = allot_object(DLL_TYPE, sizeof(DLL));
|
||||
dll->dll = module;
|
||||
dpush(tag_object(dll));
|
||||
|
||||
return dll;
|
||||
#else
|
||||
general_error(ERROR_FFI_DISABLED, F);
|
||||
#endif
|
||||
}
|
||||
|
||||
void primitive_dlsym (void)
|
||||
void *ffi_dlsym (DLL *dll, F_STRING *symbol)
|
||||
{
|
||||
#ifdef FFI
|
||||
DLL *dll = untag_dll(dpop());
|
||||
void *sym = GetProcAddress((HMODULE)dll->dll, unbox_c_string());
|
||||
|
||||
void *sym = GetProcAddress(dll ? (HMODULE)dll->dll : GetModuleHandle(NULL),
|
||||
to_c_string(symbol));
|
||||
|
||||
if (!sym)
|
||||
general_error(ERROR_FFI, tag_object(last_error()));
|
||||
|
||||
dpush(tag_cell((CELL)sym));
|
||||
return sym;
|
||||
#else
|
||||
general_error(ERROR_FFI_DISABLED, F);
|
||||
#endif
|
||||
}
|
||||
|
||||
void primitive_dlclose (void)
|
||||
void ffi_dlclose (DLL *dll)
|
||||
{
|
||||
#ifdef FFI
|
||||
DLL *dll = untag_dll(dpop());
|
||||
FreeLibrary((HMODULE)dll->dll);
|
||||
dll->dll = NULL;
|
||||
#else
|
||||
general_error(ERROR_FFI_DISABLED, F);
|
||||
#endif
|
||||
}
|
||||
|
||||
void primitive_dlsym_self (void)
|
||||
{
|
||||
#ifdef FFI
|
||||
void *sym = GetProcAddress(GetModuleHandle(NULL), unbox_c_string());
|
||||
|
||||
if(sym == NULL)
|
||||
{
|
||||
general_error(ERROR_FFI, tag_object(last_error()));
|
||||
}
|
||||
dpush(tag_cell((CELL)sym));
|
||||
#else
|
||||
general_error(ERROR_FFI_DISABLED, F);
|
||||
#endif
|
||||
}
|
||||
}
|
||||
Loading…
Reference in New Issue