168 lines
2.8 KiB
C
168 lines
2.8 KiB
C
#include "factor.h"
|
|
|
|
DLL* untag_dll(CELL tagged)
|
|
{
|
|
DLL* dll = (DLL*)UNTAG(tagged);
|
|
type_check(DLL_TYPE,tagged);
|
|
if(dll->dll == NULL)
|
|
general_error(ERROR_EXPIRED,tagged);
|
|
return (DLL*)UNTAG(tagged);
|
|
}
|
|
|
|
#ifdef FFI
|
|
CELL unbox_alien(void)
|
|
{
|
|
return untag_alien(dpop())->ptr;
|
|
}
|
|
|
|
void box_alien(CELL ptr)
|
|
{
|
|
ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
|
|
alien->ptr = ptr;
|
|
alien->local = false;
|
|
dpush(tag_object(alien));
|
|
}
|
|
|
|
INLINE CELL alien_pointer(void)
|
|
{
|
|
F_FIXNUM offset = unbox_integer();
|
|
ALIEN* alien = untag_alien(dpop());
|
|
CELL ptr = alien->ptr;
|
|
|
|
if(ptr == NULL)
|
|
general_error(ERROR_EXPIRED,tag_object(alien));
|
|
|
|
return ptr + offset;
|
|
}
|
|
#endif
|
|
|
|
void primitive_alien(void)
|
|
{
|
|
#ifdef FFI
|
|
CELL ptr = unbox_integer();
|
|
maybe_garbage_collection();
|
|
box_alien(ptr);
|
|
#else
|
|
general_error(ERROR_FFI_DISABLED,F);
|
|
#endif
|
|
}
|
|
|
|
void primitive_local_alien(void)
|
|
{
|
|
#ifdef FFI
|
|
CELL length = unbox_integer();
|
|
ALIEN* alien;
|
|
F_STRING* local;
|
|
maybe_garbage_collection();
|
|
alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
|
|
local = string(length / CHARS,'\0');
|
|
alien->ptr = (CELL)local + sizeof(F_STRING);
|
|
alien->local = true;
|
|
dpush(tag_object(alien));
|
|
#else
|
|
general_error(ERROR_FFI_DISABLED,F);
|
|
#endif
|
|
}
|
|
|
|
void primitive_alien_cell(void)
|
|
{
|
|
#ifdef FFI
|
|
box_integer(get(alien_pointer()));
|
|
#else
|
|
general_error(ERROR_FFI_DISABLED,F);
|
|
#endif
|
|
}
|
|
|
|
void primitive_set_alien_cell(void)
|
|
{
|
|
#ifdef FFI
|
|
CELL ptr = alien_pointer();
|
|
CELL value = unbox_integer();
|
|
put(ptr,value);
|
|
#else
|
|
general_error(ERROR_FFI_DISABLED,F);
|
|
#endif
|
|
}
|
|
|
|
void primitive_alien_4(void)
|
|
{
|
|
#ifdef FFI
|
|
CELL ptr = alien_pointer();
|
|
box_integer(*(int*)ptr);
|
|
#else
|
|
general_error(ERROR_FFI_DISABLED,F);
|
|
#endif
|
|
}
|
|
|
|
void primitive_set_alien_4(void)
|
|
{
|
|
#ifdef FFI
|
|
CELL ptr = alien_pointer();
|
|
CELL value = unbox_integer();
|
|
*(int*)ptr = value;
|
|
#else
|
|
general_error(ERROR_FFI_DISABLED,F);
|
|
#endif
|
|
}
|
|
|
|
void primitive_alien_2(void)
|
|
{
|
|
#ifdef FFI
|
|
CELL ptr = alien_pointer();
|
|
box_signed_2(*(uint16_t*)ptr);
|
|
#else
|
|
general_error(ERROR_FFI_DISABLED,F);
|
|
#endif
|
|
}
|
|
|
|
void primitive_set_alien_2(void)
|
|
{
|
|
#ifdef FFI
|
|
CELL ptr = alien_pointer();
|
|
CELL value = unbox_signed_2();
|
|
*(uint16_t*)ptr = value;
|
|
#else
|
|
general_error(ERROR_FFI_DISABLED,F);
|
|
#endif
|
|
}
|
|
|
|
void primitive_alien_1(void)
|
|
{
|
|
#ifdef FFI
|
|
box_signed_1(bget(alien_pointer()));
|
|
#else
|
|
general_error(ERROR_FFI_DISABLED,F);
|
|
#endif
|
|
}
|
|
|
|
void primitive_set_alien_1(void)
|
|
{
|
|
#ifdef FFI
|
|
CELL ptr = alien_pointer();
|
|
BYTE value = value = unbox_signed_1();
|
|
bput(ptr,value);
|
|
#else
|
|
general_error(ERROR_FFI_DISABLED,F);
|
|
#endif
|
|
}
|
|
|
|
void fixup_dll(DLL* dll)
|
|
{
|
|
dll->dll = NULL;
|
|
}
|
|
|
|
void fixup_alien(ALIEN* alien)
|
|
{
|
|
alien->ptr = NULL;
|
|
}
|
|
|
|
void collect_alien(ALIEN* alien)
|
|
{
|
|
if(alien->local && alien->ptr != NULL)
|
|
{
|
|
F_STRING* ptr = (F_STRING*)(alien->ptr - sizeof(F_STRING));
|
|
ptr = copy_untagged_object(ptr,SSIZE(ptr));
|
|
alien->ptr = (CELL)ptr + sizeof(F_STRING);
|
|
}
|
|
}
|