factor/native/ffi.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);
	}
}