/* Look up an external library symbol referenced by a compiled code block */
void *factor_vm::get_rel_symbol(array *literals, cell index)
{
cell symbol = array_nth(literals,index);
cell library = array_nth(literals,index + 1);
dll *d = (library == F ? NULL : untag<dll>(library));
if(d != NULL && !d->dll)
return (void *)factor::undefined_symbol;
switch(tagged<object>(symbol).type())
{
case BYTE_ARRAY_TYPE:
{
symbol_char *name = alien_offset(symbol);
void *sym = ffi_dlsym(d,name);
if(sym)
return sym;
else
{
return (void *)factor::undefined_symbol;
}
}
case ARRAY_TYPE:
{
cell i;
array *names = untag<array>(symbol);
for(i = 0; i < array_capacity(names); i++)
{
symbol_char *name = alien_offset(array_nth(names,i));
void *sym = ffi_dlsym(d,name);
if(sym)
return sym;
}
return (void *)factor::undefined_symbol;
}
default:
critical_error("Bad symbol specifier",symbol);
return (void *)factor::undefined_symbol;
}
}
/* Look up an external library symbol referenced by a compiled code block */
cell factor_vm::compute_dlsym_address(array *parameters, cell index)
{
cell symbol = array_nth(parameters,index);
cell library = array_nth(parameters,index + 1);
dll *d = (to_boolean(library) ? untag<dll>(library) : NULL);
void* undefined_symbol = (void*)factor::undefined_symbol;
undefined_symbol = FUNCTION_CODE_POINTER(undefined_symbol);
if(d != NULL && !d->handle)
return (cell)undefined_symbol;
switch(tagged<object>(symbol).type())
{
case BYTE_ARRAY_TYPE:
{
symbol_char *name = alien_offset(symbol);
void *sym = ffi_dlsym(d,name);
if(sym)
return (cell)sym;
else
return (cell)undefined_symbol;
}
case ARRAY_TYPE:
{
array *names = untag<array>(symbol);
for(cell i = 0; i < array_capacity(names); i++)
{
symbol_char *name = alien_offset(array_nth(names,i));
void *sym = ffi_dlsym(d,name);
if(sym)
return (cell)sym;
}
return (cell)undefined_symbol;
}
default:
critical_error("Bad symbol specifier",symbol);
return (cell)undefined_symbol;
}
}
void factor_vm::primitive_fwrite() {
FILE* file = pop_file_handle();
cell length = to_cell(ctx->pop());
char* text = alien_offset(ctx->pop());
if (length == 0)
return;
size_t written = safe_fwrite(text, 1, length, file);
if (written != length)
io_error_if_not_EINTR();
}
// Allocates memory (from_unsigned_cell())
void factor_vm::primitive_fread() {
FILE* file = pop_file_handle();
void* buf = (void*)alien_offset(ctx->pop());
cell size = unbox_array_size();
if (size == 0) {
ctx->push(from_unsigned_cell(0));
return;
}
size_t c = safe_fread(buf, 1, size, file);
if (c == 0 || feof(file))
clearerr(file);
ctx->push(from_unsigned_cell(c));
}
/* gets the address of an object representing a C pointer */
char *factorvm::alien_offset(cell obj)
{
switch(tagged<object>(obj).type())
{
case BYTE_ARRAY_TYPE:
return untag<byte_array>(obj)->data<char>();
case ALIEN_TYPE:
{
alien *ptr = untag<alien>(obj);
if(ptr->expired != F)
general_error(ERROR_EXPIRED,obj,F,NULL);
return alien_offset(ptr->alien) + ptr->displacement;
}
case F_TYPE:
return NULL;
default:
type_error(ALIEN_TYPE,obj);
return NULL; /* can't happen */
}
}
/* gets the address of an object representing a C pointer */
void *alien_offset(CELL object)
{
F_ALIEN *alien;
F_BYTE_ARRAY *byte_array;
switch(type_of(object))
{
case BYTE_ARRAY_TYPE:
byte_array = untag_object(object);
return byte_array + 1;
case ALIEN_TYPE:
alien = untag_object(object);
if(alien->expired != F)
general_error(ERROR_EXPIRED,object,F,NULL);
return alien_offset(alien->alien) + alien->displacement;
case F_TYPE:
return NULL;
default:
type_error(ALIEN_TYPE,object);
return NULL; /* can't happen */
}
}
void factor_vm::primitive_free_callback() {
void* entry_point = alien_offset(ctx->pop());
code_block* stub = (code_block*)entry_point - 1;
callbacks->allocator->free(stub);
}
void factor_yield(void)
{
void (*callback)() = alien_offset(userenv[YIELD_CALLBACK_ENV]);
callback();
}
void factor_vm::factor_sleep(long us)
{
void (*callback)(long) = (void (*)(long))alien_offset(special_objects[OBJ_SLEEP_CALLBACK]);
callback(us);
}
char *factor_vm::factor_eval_string(char *string)
{
char *(*callback)(char *) = (char *(*)(char *))alien_offset(special_objects[OBJ_EVAL_CALLBACK]);
return callback(string);
}
/* pop an object representing a C pointer */
void *unbox_alien(void)
{
return alien_offset(dpop());
}
FILE* factor_vm::peek_file_handle() { return (FILE*)alien_offset(ctx->peek()); }
/* for FFI calls passing structs by value */
void factorvm::to_value_struct(cell src, void *dest, cell size)
{
memcpy(dest,alien_offset(src),size);
}
/* pop an object representing a C pointer */
char *factorvm::unbox_alien()
{
return alien_offset(dpop());
}
/* for FFI calls passing structs by value */
void to_value_struct(CELL src, void *dest, CELL size)
{
memcpy(dest,alien_offset(src),size);
}
void factorvm::factor_yield()
{
void (*callback)() = (void (*)())alien_offset(userenv[YIELD_CALLBACK_ENV]);
callback();
}
void factorvm::factor_sleep(long us)
{
void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]);
callback(us);
}
void factor_vm::ffi_dlopen(dll* dll) {
dll->handle = LoadLibraryEx((WCHAR*)alien_offset(dll->path), NULL, 0);
}
void ffi_dlopen(F_DLL *dll)
{
dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY);
}
void factor_vm::factor_yield()
{
void (*callback)() = (void (*)())alien_offset(special_objects[OBJ_YIELD_CALLBACK]);
callback();
}
char* factor_vm::factor_eval_string(char* string) {
void* func = alien_offset(special_objects[OBJ_EVAL_CALLBACK]);
CODE_TO_FUNCTION_POINTER(func);
return ((char * (*)(char*)) func)(string);
}
// pop ( alien n ) from datastack, return alien's address plus n
void* factor_vm::alien_pointer() {
fixnum offset = to_fixnum(ctx->pop());
return alien_offset(ctx->pop()) + offset;
}
void factor_vm::factor_yield() {
void* func = alien_offset(special_objects[OBJ_YIELD_CALLBACK]);
CODE_TO_FUNCTION_POINTER(func);
((void(*)()) func)();
}
char *factor_eval_string(char *string)
{
char* (*callback)(char*) = alien_offset(userenv[EVAL_CALLBACK_ENV]);
return callback(string);
}
void factor_vm::factor_sleep(long us) {
void* func = alien_offset(special_objects[OBJ_SLEEP_CALLBACK]);
CODE_TO_FUNCTION_POINTER(func);
((void(*)(long)) func)(us);
}
void factor_sleep(long us)
{
void (*callback)() = alien_offset(userenv[SLEEP_CALLBACK_ENV]);
callback(us);
}
void factor_vm::ffi_dlopen(dll *dll)
{
dll->handle = dlopen(alien_offset(dll->path), RTLD_LAZY);
}
