factor/native/vector.c

#include "factor.h"

F_VECTOR* vector(F_FIXNUM capacity)
{
	F_VECTOR* vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
	vector->top = 0;
	vector->array = tag_object(array(capacity,F));
	return vector;
}

void primitive_vector(void)
{
	maybe_garbage_collection();
	drepl(tag_object(vector(to_fixnum(dpeek()))));
}

void primitive_vector_length(void)
{
	drepl(tag_fixnum(untag_vector(dpeek())->top));
}

void primitive_set_vector_length(void)
{
	F_VECTOR* vector;
	F_FIXNUM length;
	F_ARRAY* array;

	maybe_garbage_collection();

	vector = untag_vector(dpop());
	length = to_fixnum(dpop());
	array = untag_array(vector->array);

	if(length < 0)
		range_error(tag_object(vector),length,vector->top);
	vector->top = length;
	if(length > array->capacity)
		vector->array = tag_object(grow_array(array,length,F));
}

void primitive_vector_nth(void)
{
	F_VECTOR* vector = untag_vector(dpop());
	CELL index = to_fixnum(dpop());

	if(index < 0 || index >= vector->top)
		range_error(tag_object(vector),index,vector->top);
	dpush(array_nth(untag_array(vector->array),index));
}

void vector_ensure_capacity(F_VECTOR* vector, CELL index)
{
	F_ARRAY* array = untag_array(vector->array);
	CELL capacity = array->capacity;
	if(index >= capacity)
		array = grow_array(array,index * 2 + 1,F);
	vector->top = index + 1;
	vector->array = tag_object(array);
}

void primitive_set_vector_nth(void)
{
	F_VECTOR* vector;
	F_FIXNUM index;
	CELL value;

	maybe_garbage_collection();

	vector = untag_vector(dpop());
	index = to_fixnum(dpop());
	value = dpop();

	if(index < 0)
		range_error(tag_object(vector),index,vector->top);
	else if(index >= vector->top)
		vector_ensure_capacity(vector,index);

	/* the following does not check bounds! */
	set_array_nth(untag_array(vector->array),index,value);
}

void fixup_vector(F_VECTOR* vector)
{
	fixup(&vector->array);
}

void collect_vector(F_VECTOR* vector)
{
	copy_object(&vector->array);
}