-#include "factor.h"
+#include "master.h"
/* FFI calls this */
void box_boolean(bool value)
}
/* FFI calls this */
-bool unbox_boolean(void)
+bool to_boolean(CELL value)
{
- return (dpop() != F);
+ return value != F;
}
/* the array is full of undefined data, and must be correctly filled before the
next GC. size is in cells */
-F_ARRAY *allot_array_internal(CELL type, F_FIXNUM capacity)
+F_ARRAY *allot_array_internal(CELL type, CELL capacity)
{
- F_ARRAY *array;
-
- if(capacity < 0)
- {
- simple_error(ERROR_NEGATIVE_ARRAY_SIZE,allot_integer(capacity),F);
- return NULL;
- }
- else
- {
- array = allot_object(type,array_size(capacity));
- array->capacity = tag_fixnum(capacity);
- return array;
- }
+ F_ARRAY *array = allot_object(type,array_size(capacity));
+ array->capacity = tag_fixnum(capacity);
+ return array;
}
/* make a new array with an initial element */
-F_ARRAY *allot_array(CELL type, F_FIXNUM capacity, CELL fill)
+F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill)
{
int i;
REGISTER_ROOT(fill);
F_ARRAY* array = allot_array_internal(type, capacity);
UNREGISTER_ROOT(fill);
- for(i = 0; i < capacity; i++)
- set_array_nth(array,i,fill);
+ if(fill == 0)
+ memset((void*)AREF(array,0),'\0',capacity * CELLS);
+ else
+ {
+ for(i = 0; i < capacity; i++)
+ set_array_nth(array,i,fill);
+ }
return array;
}
/* size is in bytes this time */
-F_ARRAY *allot_byte_array(F_FIXNUM size)
+F_BYTE_ARRAY *allot_byte_array(CELL size)
{
- if(size < 0)
- {
- simple_error(ERROR_NEGATIVE_ARRAY_SIZE,allot_integer(size),F);
- return NULL;
- }
+ F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE,
+ byte_array_size(size));
+ array->capacity = tag_fixnum(size);
+ memset(array + 1,0,size);
+ return array;
+}
+
+/* size is in bits */
+F_BIT_ARRAY *allot_bit_array(CELL size)
+{
+ F_BIT_ARRAY *array = allot_object(BIT_ARRAY_TYPE,
+ bit_array_size(size));
+ array->capacity = tag_fixnum(size);
+ memset(array + 1,0,(size + 31) / 32 * 4);
+ return array;
+}
+
+/* size is in 8-byte doubles */
+F_BIT_ARRAY *allot_float_array(CELL size, double initial)
+{
+ F_FLOAT_ARRAY *array = allot_object(FLOAT_ARRAY_TYPE,
+ float_array_size(size));
+ array->capacity = tag_fixnum(size);
- CELL byte_size = (size + sizeof(CELL) - 1) / sizeof(CELL);
- return allot_array(BYTE_ARRAY_TYPE,byte_size,0);
+ double *elements = (double *)AREF(array,0);
+ int i;
+ for(i = 0; i < size; i++)
+ elements[i] = initial;
+
+ return array;
}
/* push a new array on the stack */
-void primitive_array(void)
+DEFINE_PRIMITIVE(array)
{
CELL initial = dpop();
- F_FIXNUM size = unbox_signed_cell();
+ CELL size = unbox_array_size();
dpush(tag_object(allot_array(ARRAY_TYPE,size,initial)));
}
-/* push a new byte on the stack */
-void primitive_byte_array(void)
+/* push a new tuple on the stack */
+DEFINE_PRIMITIVE(tuple)
+{
+ CELL size = unbox_array_size();
+ F_ARRAY *array = allot_array(TUPLE_TYPE,size,F);
+ set_array_nth(array,0,dpop());
+ dpush(tag_tuple(array));
+}
+
+/* push a new tuple on the stack, filling its slots from the stack */
+DEFINE_PRIMITIVE(tuple_boa)
+{
+ CELL size = unbox_array_size();
+ F_ARRAY *array = allot_array(TUPLE_TYPE,size,F);
+ set_array_nth(array,0,dpop());
+
+ CELL i;
+ for(i = size - 1; i >= 2; i--)
+ set_array_nth(array,i,dpop());
+
+ dpush(tag_tuple(array));
+}
+
+/* push a new byte array on the stack */
+DEFINE_PRIMITIVE(byte_array)
{
- F_FIXNUM size = unbox_signed_cell();
+ CELL size = unbox_array_size();
dpush(tag_object(allot_byte_array(size)));
}
+/* push a new bit array on the stack */
+DEFINE_PRIMITIVE(bit_array)
+{
+ CELL size = unbox_array_size();
+ dpush(tag_object(allot_bit_array(size)));
+}
+
+/* push a new float array on the stack */
+DEFINE_PRIMITIVE(float_array)
+{
+ double initial = untag_float(dpop());
+ CELL size = unbox_array_size();
+ dpush(tag_object(allot_float_array(size,initial)));
+}
+
+/* push a new quotation on the stack */
+DEFINE_PRIMITIVE(array_to_quotation)
+{
+ F_QUOTATION *quot = allot_object(QUOTATION_TYPE,sizeof(F_QUOTATION));
+ quot->array = dpeek();
+ quot->xt = NULL;
+
+ REGISTER_UNTAGGED(quot);
+ jit_compile(quot);
+ UNREGISTER_UNTAGGED(quot);
+
+ drepl(tag_object(quot));
+}
+
+DEFINE_PRIMITIVE(quotation_xt)
+{
+ F_QUOTATION *quot = untag_quotation(dpeek());
+ drepl(allot_cell((CELL)quot->xt));
+}
+
+CELL clone(CELL object)
+{
+ CELL size = object_size(object);
+ if(size == 0)
+ return object;
+ else
+ {
+ REGISTER_ROOT(object);
+ void *new_obj = allot_object(type_of(object),size);
+ UNREGISTER_ROOT(object);
+
+ CELL tag = TAG(object);
+ memcpy(new_obj,(void*)UNTAG(object),size);
+ return RETAG(new_obj,tag);
+ }
+}
+
+DEFINE_PRIMITIVE(clone)
+{
+ drepl(clone(dpeek()));
+}
+
+DEFINE_PRIMITIVE(tuple_to_array)
+{
+ CELL object = dpeek();
+ type_check(TUPLE_TYPE,object);
+ object = RETAG(clone(object),OBJECT_TYPE);
+ set_slot(object,0,tag_header(ARRAY_TYPE));
+ drepl(object);
+}
+
+DEFINE_PRIMITIVE(to_tuple)
+{
+ CELL object = RETAG(clone(dpeek()),TUPLE_TYPE);
+ set_slot(object,0,tag_header(TUPLE_TYPE));
+ drepl(object);
+}
+
+CELL allot_array_2(CELL v1, CELL v2)
+{
+ REGISTER_ROOT(v1);
+ REGISTER_ROOT(v2);
+ F_ARRAY *a = allot_array_internal(ARRAY_TYPE,2);
+ UNREGISTER_ROOT(v2);
+ UNREGISTER_ROOT(v1);
+ set_array_nth(a,0,v1);
+ set_array_nth(a,1,v2);
+ return tag_object(a);
+}
+
CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
{
REGISTER_ROOT(v1);
return tag_object(a);
}
-F_ARRAY *reallot_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill)
+F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill)
{
int i;
F_ARRAY* new_array;
if(capacity < to_copy)
to_copy = capacity;
- REGISTER_ARRAY(array);
+ REGISTER_UNTAGGED(array);
REGISTER_ROOT(fill);
new_array = allot_array_internal(untag_header(array->header),capacity);
UNREGISTER_ROOT(fill);
- UNREGISTER_ARRAY(array);
+ UNREGISTER_UNTAGGED(array);
memcpy(new_array + 1,array + 1,to_copy * CELLS);
return new_array;
}
-void primitive_resize_array(void)
+DEFINE_PRIMITIVE(resize_array)
{
F_ARRAY* array = untag_array(dpop());
- F_FIXNUM capacity = unbox_signed_cell();
+ CELL capacity = unbox_array_size();
dpush(tag_object(reallot_array(array,capacity,F)));
}
-void primitive_become(void)
-{
- CELL type = unbox_signed_cell();
- CELL obj = dpeek();
- put(SLOT(UNTAG(obj),0),tag_header(type));
-}
-
-void primitive_array_to_vector(void)
+DEFINE_PRIMITIVE(array_to_vector)
{
F_VECTOR *vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
- F_ARRAY *array = untag_array(dpeek());
- vector->top = array->capacity;
- vector->array = tag_object(array);
- drepl(tag_object(vector));
+ vector->top = dpop();
+ vector->array = dpop();
+ dpush(tag_object(vector));
}
/* untagged */
-F_STRING* allot_string_internal(F_FIXNUM capacity)
-{
- F_STRING* string;
-
- if(capacity < 0)
- {
- simple_error(ERROR_NEGATIVE_ARRAY_SIZE,allot_integer(capacity),F);
- return NULL;
- }
- else
- {
- string = allot_object(STRING_TYPE,
- sizeof(F_STRING) + (capacity + 1) * CHARS);
- /* strings are null-terminated in memory, even though they also
- have a length field. The null termination allows us to add
- the sizeof(F_STRING) to a Factor string to get a C-style
- UTF16 string for C library calls. */
- cput(SREF(string,capacity),(u16)'\0');
- string->length = tag_fixnum(capacity);
- string->hashcode = F;
- return string;
- }
+F_STRING* allot_string_internal(CELL capacity)
+{
+ F_STRING* string = allot_object(STRING_TYPE,
+ sizeof(F_STRING) + (capacity + 1) * CHARS);
+
+ /* strings are null-terminated in memory, even though they also
+ have a length field. The null termination allows us to add
+ the sizeof(F_STRING) to a Factor string to get a C-style
+ UCS-2 string for C library calls. */
+ cput(SREF(string,capacity),(u16)'\0');
+ string->length = tag_fixnum(capacity);
+ string->hashcode = F;
+ return string;
}
-/* call this after constructing a string */
-void rehash_string(F_STRING* str)
+void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill)
{
- s32 hash = 0;
- CELL i;
- CELL capacity = string_capacity(str);
- for(i = 0; i < capacity; i++)
- hash = (31*hash + string_nth(str,i));
- str->hashcode = (s32)tag_fixnum(hash);
-}
+ if(fill == 0)
+ memset((void*)SREF(string,start),'\0',
+ (capacity - start) * CHARS);
+ else
+ {
+ CELL i;
-void primitive_rehash_string(void)
-{
- rehash_string(untag_string(dpop()));
+ for(i = start; i < capacity; i++)
+ cput(SREF(string,i),fill);
+ }
}
/* untagged */
-F_STRING *allot_string(F_FIXNUM capacity, CELL fill)
+F_STRING *allot_string(CELL capacity, CELL fill)
{
- CELL i;
-
F_STRING* string = allot_string_internal(capacity);
-
- for(i = 0; i < capacity; i++)
- cput(SREF(string,i),fill);
-
- rehash_string(string);
-
+ fill_string(string,0,capacity,fill);
return string;
}
-void primitive_string(void)
+DEFINE_PRIMITIVE(string)
{
- CELL initial = unbox_unsigned_cell();
- F_FIXNUM length = unbox_signed_cell();
+ CELL initial = to_cell(dpop());
+ CELL length = unbox_array_size();
dpush(tag_object(allot_string(length,initial)));
}
-F_STRING* reallot_string(F_STRING* string, F_FIXNUM capacity, u16 fill)
+F_STRING* reallot_string(F_STRING* string, CELL capacity, u16 fill)
{
- /* later on, do an optimization: if end of array is here, just grow */
- CELL i;
CELL to_copy = string_capacity(string);
-
if(capacity < to_copy)
to_copy = capacity;
REGISTER_STRING(string);
-
F_STRING *new_string = allot_string_internal(capacity);
-
UNREGISTER_STRING(string);
memcpy(new_string + 1,string + 1,to_copy * CHARS);
-
- for(i = to_copy; i < capacity; i++)
- cput(SREF(new_string,i),fill);
+ fill_string(new_string,to_copy,capacity,fill);
return new_string;
}
-void primitive_resize_string(void)
+DEFINE_PRIMITIVE(resize_string)
{
F_STRING* string = untag_string(dpop());
- F_FIXNUM capacity = unbox_signed_cell();
+ CELL capacity = unbox_array_size();
dpush(tag_object(reallot_string(string,capacity,0)));
}
cput(SREF(s,i),(utype)*string); \
string++; \
} \
- rehash_string(s); \
return s; \
} \
- void primitive_memory_to_##type##_string(void) \
+ DEFINE_PRIMITIVE(memory_to_##type##_string) \
{ \
- CELL length = unbox_unsigned_cell(); \
- const type *string = (const type*)unbox_unsigned_cell(); \
+ CELL length = to_cell(dpop()); \
+ const type *string = unbox_alien(); \
dpush(tag_object(memory_to_##type##_string(string,length))); \
} \
F_STRING *from_##type##_string(const type *str) \
{ \
dpush(str ? tag_object(from_##type##_string(str)) : F); \
} \
- void primitive_alien_to_##type##_string(void) \
+ DEFINE_PRIMITIVE(alien_to_##type##_string) \
{ \
drepl(tag_object(from_##type##_string(alien_offset(dpeek())))); \
}
return true;
}
-F_ARRAY *allot_c_string(CELL capacity, CELL size)
+F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
{
- return allot_array_internal(BYTE_ARRAY_TYPE,capacity * size / CELLS + 1);
+ return allot_byte_array((capacity + 1) * size);
}
#define STRING_TO_MEMORY(type) \
for(i = 0; i < capacity; i++) \
string[i] = string_nth(s,i); \
} \
- void primitive_##type##_string_to_memory(void) \
+ DEFINE_PRIMITIVE(type##_string_to_memory) \
{ \
- type *address = (type*)unbox_unsigned_cell(); \
+ type *address = unbox_alien(); \
F_STRING *str = untag_string(dpop()); \
type##_string_to_memory(str,address); \
} \
- F_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \
+ F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \
{ \
CELL capacity = string_capacity(s); \
- F_ARRAY *_c_str; \
+ F_BYTE_ARRAY *_c_str; \
if(check && !check_string(s,sizeof(type))) \
- simple_error(ERROR_C_STRING,tag_object(s),F); \
+ general_error(ERROR_C_STRING,tag_object(s),F,NULL); \
REGISTER_STRING(s); \
_c_str = allot_c_string(capacity,sizeof(type)); \
UNREGISTER_STRING(s); \
if(sizeof(type) == sizeof(u16)) \
{ \
if(check && !check_string(s,sizeof(type))) \
- simple_error(ERROR_C_STRING,tag_object(s),F); \
+ general_error(ERROR_C_STRING,tag_object(s),F,NULL); \
return (type*)(s + 1); \
} \
else \
{ \
return to_##type##_string(untag_string(dpop()),true); \
} \
- void primitive_string_to_##type##_alien(void) \
+ DEFINE_PRIMITIVE(string_to_##type##_alien) \
{ \
CELL string, t; \
string = dpeek(); \
STRING_TO_MEMORY(char);
STRING_TO_MEMORY(u16);
-void primitive_char_slot(void)
+DEFINE_PRIMITIVE(char_slot)
{
- F_STRING* string = untag_string_fast(dpop());
+ F_STRING* string = untag_object(dpop());
CELL index = untag_fixnum_fast(dpop());
dpush(tag_fixnum(string_nth(string,index)));
}
-void primitive_set_char_slot(void)
+DEFINE_PRIMITIVE(set_char_slot)
{
- F_STRING* string = untag_string_fast(dpop());
+ F_STRING* string = untag_object(dpop());
CELL index = untag_fixnum_fast(dpop());
CELL value = untag_fixnum_fast(dpop());
set_string_nth(string,index,value);
}
-void primitive_string_to_sbuf(void)
+DEFINE_PRIMITIVE(string_to_sbuf)
{
F_SBUF *sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF));
- F_STRING *string = untag_string(dpeek());
- sbuf->top = string->length;
- sbuf->string = tag_object(string);
- drepl(tag_object(sbuf));
+ sbuf->top = dpop();
+ sbuf->string = dpop();
+ dpush(tag_object(sbuf));
}
-void primitive_hashtable(void)
+DEFINE_PRIMITIVE(hashtable)
{
F_HASHTABLE* hash = allot_object(HASHTABLE_TYPE,sizeof(F_HASHTABLE));
hash->count = F;
dpush(tag_object(hash));
}
-void update_xt(F_WORD* word)
-{
- word->compiledp = F;
- word->xt = primitive_to_xt(to_fixnum(word->primitive));
-}
-
/* <word> ( name vocabulary -- word ) */
F_WORD *allot_word(CELL vocab, CELL name)
{
word->hashcode = tag_fixnum(rand());
word->vocabulary = vocab;
word->name = name;
- word->primitive = tag_fixnum(0);
word->def = F;
word->props = F;
+ word->counter = tag_fixnum(0);
update_xt(word);
return word;
}
-void primitive_word(void)
+DEFINE_PRIMITIVE(word)
{
CELL vocab = dpop();
CELL name = dpop();
- dpush(tag_word(allot_word(vocab,name)));
+ dpush(tag_object(allot_word(vocab,name)));
}
-void primitive_update_xt(void)
+DEFINE_PRIMITIVE(update_xt)
{
update_xt(untag_word(dpop()));
}
-void primitive_word_xt(void)
+DEFINE_PRIMITIVE(word_xt)
{
F_WORD *word = untag_word(dpeek());
- drepl(allot_cell(word->xt));
+ drepl(allot_cell((CELL)word->xt));
}
-void fixup_word(F_WORD* word)
+DEFINE_PRIMITIVE(wrapper)
{
- /* If this is a compiled word, relocate the code pointer. Otherwise,
- reset it based on the primitive number of the word. */
- if(word->compiledp != F)
- code_fixup(&word->xt);
- else
- update_xt(word);
+ F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
+ wrapper->object = dpeek();
+ drepl(tag_object(wrapper));
}
-void primitive_wrapper(void)
+DEFINE_PRIMITIVE(curry)
{
- F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
- wrapper->object = dpeek();
- drepl(tag_wrapper(wrapper));
+ F_CURRY *curry = allot_object(CURRY_TYPE,sizeof(F_CURRY));
+ curry->quot = dpop();
+ curry->obj = dpop();
+ dpush(tag_object(curry));
}
projects / factor.git / blobdiff