factor/native/stack.c

#include "factor.h"

void reset_datastack(void)
{
	env.ds = UNTAG(env.ds_bot) + sizeof(ARRAY);
	env.dt = empty;
}

void reset_callstack(void)
{
	env.cs = UNTAG(env.cs_bot) + sizeof(ARRAY);
	cpush(empty);
}

void primitive_drop(void)
{
	check_non_empty(env.dt);
	env.dt = dpop();
}

void primitive_dup(void)
{
	check_non_empty(env.dt);
	dpush(env.dt);
}

void primitive_swap(void)
{
	CELL top, next;
	check_non_empty(env.dt);
	check_non_empty(dpeek());
	top = env.dt;
	next = dpop();
	dpush(top);
	env.dt = next;
}

void primitive_over(void)
{
	CELL under = dpeek();
	check_non_empty(env.dt);
	check_non_empty(under);
	dpush(env.dt);
	env.dt = under;
}

void primitive_pick(void)
{
	CELL under = dpeek();
	CELL under_under = get(env.ds - CELLS * 2);
	check_non_empty(env.dt);
	check_non_empty(under);
	check_non_empty(under_under);
	dpush(env.dt);
	env.dt = under_under;
}

void primitive_nip(void)
{
	check_non_empty(dpeek());
	dpop();
}

void primitive_tuck(void)
{
	CELL under = dpeek();
	check_non_empty(env.dt);
	check_non_empty(under);
	dpop();
	dpush(env.dt);
	dpush(under);
}

void primitive_rot(void)
{
	CELL y, z;
	/* z y env.dt --> y env.dt z <top> */
	check_non_empty(env.dt);
	y = dpeek();
	check_non_empty(y);
	z = get(env.ds - CELLS * 2);
	check_non_empty(z);
	put(env.ds - CELLS * 2,y);
	put(env.ds - CELLS,env.dt);
	env.dt = z;
}

void primitive_to_r(void)
{
	check_non_empty(env.dt);
	cpush(env.dt);
	env.dt = dpop();
}

void primitive_from_r(void)
{
	check_non_empty(cpeek());
	dpush(env.dt);
	env.dt = cpop();
}

VECTOR* stack_to_vector(CELL top, CELL bottom)
{
	CELL depth = (top - bottom - sizeof(ARRAY)) / CELLS - 1;
	VECTOR* v = vector(depth);
	ARRAY* a = v->array;
	memcpy(a + 1,bottom + sizeof(ARRAY) + CELLS,depth * CELLS);
	v->top = depth;
	return v;
}

void primitive_datastack(void)
{
	dpush(env.dt);
	env.dt = tag_object(stack_to_vector(env.ds,UNTAG(env.ds_bot)));
}

void primitive_callstack(void)
{
	dpush(env.dt);
	env.dt = tag_object(stack_to_vector(env.cs,UNTAG(env.cs_bot)));
}

/* Returns top of stack */
CELL vector_to_stack(VECTOR* vector, CELL bottom)
{
	CELL start = bottom + sizeof(ARRAY) + CELLS;
	CELL len = vector->top * CELLS;
	memcpy(start,vector->array + 1,len);
	return start + len;
}

void primitive_set_datastack(void)
{
	env.ds = vector_to_stack(untag_vector(env.dt),UNTAG(env.ds_bot));
	env.dt = dpop();
}

void primitive_set_callstack(void)
{
	env.cs = vector_to_stack(untag_vector(env.dt),UNTAG(env.cs_bot));
	env.dt = dpop();
}