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, CELL capacity)
-{
- 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, CELL capacity, CELL fill)
+CELL clone(CELL object)
{
- int i;
- REGISTER_ROOT(fill);
- F_ARRAY* array = allot_array_internal(type, capacity);
- UNREGISTER_ROOT(fill);
- if(fill == 0)
- memset((void*)AREF(array,0),'\0',capacity * CELLS);
+ CELL size = object_size(object);
+ if(size == 0)
+ return object;
else
{
- for(i = 0; i < capacity; i++)
- set_array_nth(array,i,fill);
+ 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);
}
- return array;
}
-/* size is in bytes this time */
-F_BYTE_ARRAY *allot_byte_array(CELL size)
+DEFINE_PRIMITIVE(clone)
{
- 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;
+ drepl(clone(dpeek()));
}
-/* size is in bits */
-F_BIT_ARRAY *allot_bit_array(CELL size)
+DEFINE_PRIMITIVE(array_to_vector)
{
- 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;
+ F_VECTOR *vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
+ vector->top = dpop();
+ vector->array = dpop();
+ dpush(tag_object(vector));
}
-/* size is in 8-byte doubles */
-F_BIT_ARRAY *allot_float_array(CELL size, double initial)
+DEFINE_PRIMITIVE(string_to_sbuf)
{
- F_FLOAT_ARRAY *array = allot_object(FLOAT_ARRAY_TYPE,
- float_array_size(size));
- array->capacity = tag_fixnum(size);
-
- double *elements = (double *)AREF(array,0);
- int i;
- for(i = 0; i < size; i++)
- elements[i] = initial;
-
- return array;
+ F_SBUF *sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF));
+ sbuf->top = dpop();
+ sbuf->string = dpop();
+ dpush(tag_object(sbuf));
}
-/* push a new array on the stack */
-DEFINE_PRIMITIVE(array)
+DEFINE_PRIMITIVE(hashtable)
{
- CELL initial = dpop();
- CELL size = unbox_array_size();
- dpush(tag_object(allot_array(ARRAY_TYPE,size,initial)));
+ F_HASHTABLE* hash = allot_object(HASHTABLE_TYPE,sizeof(F_HASHTABLE));
+ hash->count = F;
+ hash->deleted = F;
+ hash->array = F;
+ dpush(tag_object(hash));
}
-/* push a new tuple on the stack */
-DEFINE_PRIMITIVE(tuple)
+F_WORD *allot_word(CELL vocab, CELL name)
{
- CELL size = unbox_array_size();
- F_ARRAY *array = allot_array(TUPLE_TYPE,size,F);
- set_array_nth(array,0,dpop());
- dpush(tag_tuple(array));
-}
+ REGISTER_ROOT(vocab);
+ REGISTER_ROOT(name);
+ F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD));
+ UNREGISTER_ROOT(name);
+ UNREGISTER_ROOT(vocab);
-/* 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());
+ word->hashcode = tag_fixnum(rand());
+ word->vocabulary = vocab;
+ word->name = name;
+ word->def = userenv[UNDEFINED_ENV];
+ word->props = F;
+ word->counter = tag_fixnum(0);
+ word->compiledp = F;
+ word->profiling = NULL;
- CELL i;
- for(i = size - 1; i >= 2; i--)
- set_array_nth(array,i,dpop());
+ REGISTER_UNTAGGED(word);
+ default_word_code(word,true);
+ UNREGISTER_UNTAGGED(word);
- dpush(tag_tuple(array));
-}
+ REGISTER_UNTAGGED(word);
+ update_word_xt(word);
+ UNREGISTER_UNTAGGED(word);
-/* push a new byte array on the stack */
-DEFINE_PRIMITIVE(byte_array)
-{
- CELL size = unbox_array_size();
- dpush(tag_object(allot_byte_array(size)));
+ return word;
}
-/* push a new bit array on the stack */
-DEFINE_PRIMITIVE(bit_array)
+/* <word> ( name vocabulary -- word ) */
+DEFINE_PRIMITIVE(word)
{
- CELL size = unbox_array_size();
- dpush(tag_object(allot_bit_array(size)));
+ CELL vocab = dpop();
+ CELL name = dpop();
+ dpush(tag_object(allot_word(vocab,name)));
}
-/* push a new float array on the stack */
-DEFINE_PRIMITIVE(float_array)
+/* word-xt ( word -- xt ) */
+DEFINE_PRIMITIVE(word_xt)
{
- double initial = untag_float(dpop());
- CELL size = unbox_array_size();
- dpush(tag_object(allot_float_array(size,initial)));
+ F_WORD *word = untag_word(dpeek());
+ drepl(allot_cell((CELL)word->xt));
}
-CELL clone(CELL object)
+DEFINE_PRIMITIVE(wrapper)
{
- 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);
- }
+ F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
+ wrapper->object = dpeek();
+ drepl(tag_object(wrapper));
}
-DEFINE_PRIMITIVE(clone)
+/* Arrays */
+
+/* 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, CELL capacity)
{
- drepl(clone(dpeek()));
+ F_ARRAY *array = allot_object(type,array_size(capacity));
+ array->capacity = tag_fixnum(capacity);
+ return array;
}
-DEFINE_PRIMITIVE(tuple_to_array)
+/* make a new array with an initial element */
+F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill)
{
- CELL object = dpeek();
- type_check(TUPLE_TYPE,object);
- object = RETAG(clone(object),OBJECT_TYPE);
- set_slot(object,0,tag_header(ARRAY_TYPE));
- drepl(object);
+ int i;
+ REGISTER_ROOT(fill);
+ F_ARRAY* array = allot_array_internal(type, capacity);
+ UNREGISTER_ROOT(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;
}
-DEFINE_PRIMITIVE(to_tuple)
+/* push a new array on the stack */
+DEFINE_PRIMITIVE(array)
{
- CELL object = RETAG(clone(dpeek()),TUPLE_TYPE);
- set_slot(object,0,tag_header(TUPLE_TYPE));
- drepl(object);
+ CELL initial = dpop();
+ CELL size = unbox_array_size();
+ dpush(tag_object(allot_array(ARRAY_TYPE,size,initial)));
}
CELL allot_array_1(CELL obj)
dpush(tag_object(reallot_array(array,capacity,F)));
}
+F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count)
+{
+ REGISTER_ROOT(elt);
+
+ if(*result_count == array_capacity(result))
+ {
+ result = reallot_array(result,
+ *result_count * 2,F);
+ }
+
+ UNREGISTER_ROOT(elt);
+ set_array_nth(result,*result_count,elt);
+ *result_count = *result_count + 1;
+
+ return result;
+}
+
+F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
+{
+ REGISTER_UNTAGGED(elts);
+
+ CELL elts_size = array_capacity(elts);
+ CELL new_size = *result_count + elts_size;
+
+ if(new_size >= array_capacity(result))
+ result = reallot_array(result,new_size * 2,F);
+
+ UNREGISTER_UNTAGGED(elts);
+
+ memcpy((void*)AREF(result,*result_count),(void*)AREF(elts,0),elts_size * CELLS);
+
+ *result_count += elts_size;
+
+ return result;
+}
+
+/* Byte arrays */
+
+/* must fill out array before next GC */
+F_BYTE_ARRAY *allot_byte_array_internal(CELL size)
+{
+ F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE,
+ byte_array_size(size));
+ array->capacity = tag_fixnum(size);
+ return array;
+}
+
+/* size is in bytes this time */
+F_BYTE_ARRAY *allot_byte_array(CELL size)
+{
+ F_BYTE_ARRAY *array = allot_byte_array_internal(size);
+ memset(array + 1,0,size);
+ return array;
+}
+
+/* push a new byte array on the stack */
+DEFINE_PRIMITIVE(byte_array)
+{
+ CELL size = unbox_array_size();
+ dpush(tag_object(allot_byte_array(size)));
+}
+
F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
{
CELL to_copy = array_capacity(array);
to_copy = capacity;
REGISTER_UNTAGGED(array);
+ F_BYTE_ARRAY *new_array = allot_byte_array(capacity);
+ UNREGISTER_UNTAGGED(array);
- F_BYTE_ARRAY *new_array = allot_array_internal(untag_header(array->header),capacity);
+ memcpy(new_array + 1,array + 1,to_copy);
- UNREGISTER_UNTAGGED(array);
+ return new_array;
+}
- memcpy(new_array + 1,array + 1,to_copy * CELLS);
- memset(AREF(new_array,to_copy),0,capacity - to_copy) ;
+DEFINE_PRIMITIVE(resize_byte_array)
+{
+ F_BYTE_ARRAY* array = untag_byte_array(dpop());
+ CELL capacity = unbox_array_size();
+ dpush(tag_object(reallot_byte_array(array,capacity)));
+}
- for(i = to_copy; i < capacity; i++)
- set_array_nth(new_array,i,fill);
+/* Bit arrays */
+
+/* size is in bits */
+
+F_BIT_ARRAY *allot_bit_array_internal(CELL size)
+{
+ F_BIT_ARRAY *array = allot_object(BIT_ARRAY_TYPE,bit_array_size(size));
+ array->capacity = tag_fixnum(size);
+ return array;
+}
+
+F_BIT_ARRAY *allot_bit_array(CELL size)
+{
+ F_BIT_ARRAY *array = allot_bit_array_internal(size);
+ memset(array + 1,0,bit_array_size(size));
+ return array;
+}
+
+/* push a new bit array on the stack */
+DEFINE_PRIMITIVE(bit_array)
+{
+ CELL size = unbox_array_size();
+ dpush(tag_object(allot_bit_array(size)));
+}
+
+F_BIT_ARRAY *reallot_bit_array(F_BIT_ARRAY *array, CELL capacity)
+{
+ CELL to_copy = array_capacity(array);
+ if(capacity < to_copy)
+ to_copy = capacity;
+
+ REGISTER_UNTAGGED(array);
+ F_BIT_ARRAY *new_array = allot_bit_array(capacity);
+ UNREGISTER_UNTAGGED(array);
+
+ memcpy(new_array + 1,array + 1,bit_array_size(to_copy));
return new_array;
}
-DEFINE_PRIMITIVE(resize_array)
+DEFINE_PRIMITIVE(resize_bit_array)
{
- F_ARRAY* array = untag_array(dpop());
+ F_BYTE_ARRAY* array = untag_bit_array(dpop());
CELL capacity = unbox_array_size();
- dpush(tag_object(reallot_array(array,capacity,F)));
+ dpush(tag_object(reallot_bit_array(array,capacity)));
}
-DEFINE_PRIMITIVE(array_to_vector)
+/* Float arrays */
+
+/* size is in 8-byte doubles */
+F_FLOAT_ARRAY *allot_float_array_internal(CELL size)
{
- F_VECTOR *vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
- vector->top = dpop();
- vector->array = dpop();
- dpush(tag_object(vector));
+ F_FLOAT_ARRAY *array = allot_object(FLOAT_ARRAY_TYPE,
+ float_array_size(size));
+ array->capacity = tag_fixnum(size);
+ return array;
}
-F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count)
+F_FLOAT_ARRAY *allot_float_array(CELL size, double initial)
{
- REGISTER_ROOT(elt);
+ F_FLOAT_ARRAY *array = allot_float_array_internal(size);
- if(*result_count == array_capacity(result))
- {
- result = reallot_array(result,
- *result_count * 2,F);
- }
+ double *elements = (double *)AREF(array,0);
+ int i;
+ for(i = 0; i < size; i++)
+ elements[i] = initial;
- UNREGISTER_ROOT(elt);
- set_array_nth(result,*result_count,elt);
- *result_count = *result_count + 1;
+ return array;
+}
- return result;
+/* 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)));
}
-F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
+F_ARRAY *reallot_float_array(F_FLOAT_ARRAY* array, CELL capacity)
{
- REGISTER_UNTAGGED(elts);
+ F_FLOAT_ARRAY* new_array;
- CELL elts_size = array_capacity(elts);
- CELL new_size = *result_count + elts_size;
+ CELL to_copy = array_capacity(array);
+ if(capacity < to_copy)
+ to_copy = capacity;
- if(new_size >= array_capacity(result))
- result = reallot_array(result,new_size * 2,F);
+ REGISTER_UNTAGGED(array);
+ new_array = allot_float_array(capacity,0.0);
+ UNREGISTER_UNTAGGED(array);
- UNREGISTER_UNTAGGED(elts);
+ memcpy(new_array + 1,array + 1,to_copy * sizeof(double));
- memcpy((void*)AREF(result,*result_count),(void*)AREF(elts,0),elts_size * CELLS);
+ return new_array;
+}
- *result_count += elts_size;
+DEFINE_PRIMITIVE(resize_float_array)
+{
+ F_FLOAT_ARRAY* array = untag_float_array(dpop());
+ CELL capacity = unbox_array_size();
+ dpush(tag_object(reallot_float_array(array,capacity)));
+}
- return result;
+/* Tuples */
+
+/* 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));
}
+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);
+}
+
+/* Strings */
+
/* untagged */
F_STRING* allot_string_internal(CELL capacity)
{
CELL value = untag_fixnum_fast(dpop());
set_string_nth(string,index,value);
}
-
-DEFINE_PRIMITIVE(string_to_sbuf)
-{
- F_SBUF *sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF));
- sbuf->top = dpop();
- sbuf->string = dpop();
- dpush(tag_object(sbuf));
-}
-
-DEFINE_PRIMITIVE(hashtable)
-{
- F_HASHTABLE* hash = allot_object(HASHTABLE_TYPE,sizeof(F_HASHTABLE));
- hash->count = F;
- hash->deleted = F;
- hash->array = F;
- dpush(tag_object(hash));
-}
-
-F_WORD *allot_word(CELL vocab, CELL name)
-{
- REGISTER_ROOT(vocab);
- REGISTER_ROOT(name);
- F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD));
- UNREGISTER_ROOT(name);
- UNREGISTER_ROOT(vocab);
-
- word->hashcode = tag_fixnum(rand());
- word->vocabulary = vocab;
- word->name = name;
- word->def = userenv[UNDEFINED_ENV];
- word->props = F;
- word->counter = tag_fixnum(0);
- word->compiledp = F;
- word->profiling = NULL;
-
- REGISTER_UNTAGGED(word);
- default_word_code(word,true);
- UNREGISTER_UNTAGGED(word);
-
- REGISTER_UNTAGGED(word);
- update_word_xt(word);
- UNREGISTER_UNTAGGED(word);
-
- return word;
-}
-
-/* <word> ( name vocabulary -- word ) */
-DEFINE_PRIMITIVE(word)
-{
- CELL vocab = dpop();
- CELL name = dpop();
- dpush(tag_object(allot_word(vocab,name)));
-}
-
-/* word-xt ( word -- xt ) */
-DEFINE_PRIMITIVE(word_xt)
-{
- F_WORD *word = untag_word(dpeek());
- drepl(allot_cell((CELL)word->xt));
-}
-
-DEFINE_PRIMITIVE(wrapper)
-{
- F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
- wrapper->object = dpeek();
- drepl(tag_object(wrapper));
-}
projects / factor.git / commitdiff