bit-vectors byte-vectors float-vectors

core/bit-arrays/bit-arrays-tests.factor

@@ -46,3 +46,9 @@ IN: temporary
 [ ?{ f } ] [
     1 2 { t f t f } <slice> >bit-array
 ] unit-test
+
+[ ?{ t f t f f f } ] [ 6 ?{ t f t } resize-bit-array ] unit-test
+
+[ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test
+
+[ -10 ?{ } resize-bit-array ] unit-test-fails

core/bit-vectors/bit-vectors-docs.factor

@@ -0,0 +1,33 @@
+USING: arrays bit-arrays help.markup help.syntax kernel
+bit-vectors.private combinators ;
+IN: bit-vectors
+
+ARTICLE: "bit-vectors" "Bit vectors"
+"A bit vector is a resizable mutable sequence of bits. The literal syntax is covered in " { $link "syntax-bit-vectors" } ". Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
+$nl
+"Bit vectors form a class:"
+{ $subsection bit-vector }
+{ $subsection bit-vector? }
+"Creating bit vectors:"
+{ $subsection >bit-vector }
+{ $subsection <bit-vector> }
+"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"
+{ $code "?V{ } clone" } ;
+
+ABOUT: "bit-vectors"
+
+HELP: bit-vector
+{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ;
+
+HELP: <bit-vector>
+{ $values { "n" "a positive integer specifying initial capacity" } { "vector" vector } }
+{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;
+
+HELP: >bit vector
+{ $values { "seq" "a sequence" } { "vector" vector } }
+{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;
+
+HELP: bit-array>vector
+{ $values { "bit-array" "an array" } { "capacity" "a non-negative integer" } { "bit-vector" bit-vector } }
+{ $description "Creates a new bit vector using the array for underlying storage with the specified initial length." }
+{ $warning "This word is in the " { $vocab-link "bit-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >bit-vector } " instead." } ;

core/bit-vectors/bit-vectors-tests.factor

@@ -0,0 +1,12 @@
+IN: temporary
+USING: tools.test bit-vectors vectors sequences kernel math ;
+
+[ 0 ] [ 123 <bit-vector> length ] unit-test
+
+: do-it
+    1234 swap [ >r even? r> push ] curry each ;
+
+[ t ] [
+    3 <bit-vector> dup do-it
+    3 <vector> dup do-it sequence=
+] unit-test

core/bit-vectors/bit-vectors.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private math sequences
-sequences.private growable ;
+sequences.private growable bit-arrays ;
 IN: bit-vectors
 
 <PRIVATE

core/bootstrap/primitives.factor

@@ -390,45 +390,45 @@ builtins get num-tags get tail f union-class define-class
 "byte-vector" "byte-vectors" create
 {
     {
-        { "array-capacity" "sequences.private" }
-        "fill"
-        { "length" "sequences" }
-        { "set-fill" "growable" }
-    } {
         { "byte-array" "byte-arrays" }
         "underlying"
         { "underlying" "growable" }
         { "set-underlying" "growable" }
+    } {
+        { "array-capacity" "sequences.private" }
+        "fill"
+        { "length" "sequences" }
+        { "set-fill" "growable" }
     }
 } define-tuple-class
 
 "bit-vector" "bit-vectors" create
 {
     {
-        { "array-capacity" "sequences.private" }
-        "fill"
-        { "length" "sequences" }
-        { "set-fill" "growable" }
-    } {
         { "bit-array" "bit-arrays" }
         "underlying"
         { "underlying" "growable" }
         { "set-underlying" "growable" }
+    } {
+        { "array-capacity" "sequences.private" }
+        "fill"
+        { "length" "sequences" }
+        { "set-fill" "growable" }
     }
 } define-tuple-class
 
 "float-vector" "float-vectors" create
 {
     {
-        { "array-capacity" "sequences.private" }
-        "fill"
-        { "length" "sequences" }
-        { "set-fill" "growable" }
-    } {
         { "float-array" "float-arrays" }
         "underlying"
         { "underlying" "growable" }
         { "set-underlying" "growable" }
+    } {
+        { "array-capacity" "sequences.private" }
+        "fill"
+        { "length" "sequences" }
+        { "set-fill" "growable" }
     }
 } define-tuple-class
 
@@ -628,6 +628,9 @@ builtins get num-tags get tail f union-class define-class
     { "set-innermost-frame-quot" "kernel.private" }
     { "call-clear" "kernel" }
     { "(os-envs)" "system" }
+    { "resize-byte-array" "byte-arrays" }
+    { "resize-bit-array" "bit-arrays" }
+    { "resize-float-array" "float-arrays" }
 }
 dup length [ >r first2 r> make-primitive ] 2each
 

core/byte-arrays/byte-arrays-tests.factor

@@ -0,0 +1,8 @@
+IN: temporary
+USING: tools.test byte-arrays ;
+
+[ B{ 1 2 3 0 0 0 } ] [ 6 B{ 1 2 3 } resize-byte-array ] unit-test
+
+[ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test
+
+[ -10 B{ } resize-byte-array ] unit-test-fails

core/byte-vectors/byte-vectors-docs.factor

@@ -0,0 +1,34 @@
+USING: arrays byte-arrays help.markup help.syntax kernel
+byte-vectors.private combinators ;
+IN: byte-vectors
+
+ARTICLE: "byte-vectors" "Byte vectors"
+"A byte vector is a resizable mutable sequence of unsigned bytes. The literal syntax is covered in " { $link "syntax-byte-vectors" } ". Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary."
+$nl
+"Byte vectors form a class:"
+{ $subsection byte-vector }
+{ $subsection byte-vector? }
+"Creating byte vectors:"
+{ $subsection >byte-vector }
+{ $subsection <byte-vector> }
+"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"
+{ $code "BV{ } clone" } ;
+
+ABOUT: "byte-vectors"
+
+HELP: byte-vector
+{ $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ;
+
+HELP: <byte-vector>
+{ $values { "n" "a positive integer specifying initial capacity" } { "vector" vector } }
+{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;
+
+HELP: >byte vector
+{ $values { "seq" "a sequence" } { "vector" vector } }
+{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }
+{ $errors "Throws an error if the sequence contains elements other than integers." } ;
+
+HELP: byte-array>vector
+{ $values { "byte-array" "an array" } { "capacity" "a non-negative integer" } { "byte-vector" byte-vector } }
+{ $description "Creates a new byte vector using the array for underlying storage with the specified initial length." }
+{ $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ;

core/byte-vectors/byte-vectors-tests.factor

@@ -0,0 +1,12 @@
+IN: temporary
+USING: tools.test byte-vectors vectors sequences kernel ;
+
+[ 0 ] [ 123 <byte-vector> length ] unit-test
+
+: do-it
+    123 [ over push ] each ;
+
+[ t ] [
+    3 <byte-vector> do-it
+    3 <vector> do-it sequence=
+] unit-test

core/byte-vectors/byte-vectors.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private math sequences
-sequences.private growable ;
+sequences.private growable byte-arrays ;
 IN: byte-vectors
 
 <PRIVATE
 
-: byte-array>vector ( byte-array -- byte-vector )
+: byte-array>vector ( byte-array capacity -- byte-vector )
     byte-vector construct-boa ; inline
 
 PRIVATE>

core/float-arrays/float-arrays-tests.factor

@@ -2,3 +2,9 @@ IN: temporary
 USING: float-arrays tools.test ;
 
 [ F{ 1.0 1.0 1.0 } ] [ 3 1.0 <float-array> ] unit-test
+
+[ F{ 1 2 3 0 0 0 } ] [ 6 F{ 1 2 3 } resize-float-array ] unit-test
+
+[ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize-float-array ] unit-test
+
+[ -10 F{ } resize-float-array ] unit-test-fails

core/float-vectors/float-vectors-tests.factor

@@ -0,0 +1,12 @@
+IN: temporary
+USING: tools.test float-vectors vectors sequences kernel ;
+
+[ 0 ] [ 123 <float-vector> length ] unit-test
+
+: do-it
+    12345 [ over push ] each ;
+
+[ t ] [
+    3 <float-vector> do-it
+    3 <vector> do-it sequence=
+] unit-test

core/float-vectors/float-vectors.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private math sequences
-sequences.private growable ;
+sequences.private growable float-arrays ;
 IN: float-vectors
 
 <PRIVATE
@@ -12,7 +12,7 @@ IN: float-vectors
 PRIVATE>
 
 : <float-vector> ( n -- float-vector )
-    <float-array> 0 float-array>vector ; inline
+    0.0 <float-array> 0 float-array>vector ; inline
 
 : >float-vector ( seq -- float-vector ) V{ } clone-like ;
 

core/syntax/syntax-docs.factor

@@ -151,6 +151,18 @@ ARTICLE: "syntax-byte-arrays" "Byte array syntax"
 { $subsection POSTPONE: B{ }
 "Byte arrays are documented in " { $link "byte-arrays" } "." ;
 
+ARTICLE: "syntax-bit-vectors" "Bit vector syntax"
+{ $subsection POSTPONE: ?V{ }
+"Bit vectors are documented in " { $link "bit-vectors" } "." ;
+
+ARTICLE: "syntax-float-vectors" "Float vector syntax"
+{ $subsection POSTPONE: FV{ }
+"Float vectors are documented in " { $link "float-vectors" } "." ;
+
+ARTICLE: "syntax-byte-vectors" "Byte vector syntax"
+{ $subsection POSTPONE: BV{ }
+"Byte vectors are documented in " { $link "byte-vectors" } "." ;
+
 ARTICLE: "syntax-pathnames" "Pathname syntax"
 { $subsection POSTPONE: P" }
 "Pathnames are documented in " { $link "file-streams" } "." ;
@@ -165,11 +177,15 @@ $nl
 { $subsection "syntax-words" }
 { $subsection "syntax-quots" }
 { $subsection "syntax-arrays" }
-{ $subsection "syntax-vectors" }
 { $subsection "syntax-strings" }
-{ $subsection "syntax-sbufs" }
-{ $subsection "syntax-byte-arrays" }
 { $subsection "syntax-bit-arrays" }
+{ $subsection "syntax-byte-arrays" }
+{ $subsection "syntax-float-arrays" }
+{ $subsection "syntax-vectors" }
+{ $subsection "syntax-sbufs" }
+{ $subsection "syntax-bit-vectors" }
+{ $subsection "syntax-byte-vectors" }
+{ $subsection "syntax-float-vectors" }
 { $subsection "syntax-hashtables" }
 { $subsection "syntax-tuples" }
 { $subsection "syntax-pathnames" } ;
@@ -273,12 +289,30 @@ HELP: B{
 { $description "Marks the beginning of a literal byte array. Literal byte arrays are terminated by " { $link POSTPONE: } } "." } 
 { $examples { $code "B{ 1 2 3 }" } } ;
 
+HELP: BV{
+{ $syntax "BV{ elements... }" }
+{ $values { "elements" "a list of bytes" } }
+{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } 
+{ $examples { $code "BV{ 1 2 3 12 }" } } ;
+
 HELP: ?{
 { $syntax "?{ elements... }" }
 { $values { "elements" "a list of booleans" } }
 { $description "Marks the beginning of a literal bit array. Literal bit arrays are terminated by " { $link POSTPONE: } } "." } 
 { $examples { $code "?{ t f t }" } } ;
 
+HELP: ?V{
+{ $syntax "?V{ elements... }" }
+{ $values { "elements" "a list of booleans" } }
+{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." } 
+{ $examples { $code "?V{ t f t }" } } ;
+
+HELP: FV{
+{ $syntax "FV{ elements... }" }
+{ $values { "elements" "a list of real numbers" } }
+{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." } 
+{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ;
+
 HELP: F{
 { $syntax "F{ elements... }" }
 { $values { "elements" "a list of real numbers" } }

core/vectors/vectors-docs.factor

@@ -33,7 +33,7 @@ HELP: >vector
 HELP: array>vector ( array length -- vector )
 { $values { "array" "an array" } { "length" "a non-negative integer" } { "vector" vector } }
 { $description "Creates a new vector using the array for underlying storage with the specified initial length." }
-{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >vector } " instead." } ;
+{ $warning "This word is in the " { $vocab-link "vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >vector } " instead." } ;
 
 HELP: 1vector
 { $values { "x" object } { "vector" vector } }

vm/alien.h

@@ -41,11 +41,7 @@ DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size);
 DLLEXPORT void box_value_struct(void *src, CELL size);
 DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size);
 
-INLINE F_DLL *untag_dll(CELL tagged)
+DEFINE_UNTAG(F_DLL,DLL_TYPE,dll)
-{
-	type_check(DLL_TYPE,tagged);
-	return (F_DLL*)UNTAG(tagged);
-}
 
 DECLARE_PRIMITIVE(dlopen);
 DECLARE_PRIMITIVE(dlsym);

vm/errors.h

@@ -39,6 +39,13 @@ INLINE void type_check(CELL type, CELL tagged)
 	if(type_of(tagged) != type) type_error(type,tagged);
 }
 
+#define DEFINE_UNTAG(type,check,name) \
+	INLINE type *untag_##name(CELL obj) \
+	{ \
+		type_check(check,obj); \
+		return untag_object(obj); \
+	}
+
 /* Global variables used to pass fault handler state from signal handler to
 user-space */
 CELL signal_number;

vm/primitives.c

@@ -192,4 +192,7 @@ void *primitives[] = {
 	primitive_set_innermost_stack_frame_quot,
 	primitive_call_clear,
 	primitive_os_envs,
+	primitive_resize_byte_array,
+	primitive_resize_bit_array,
+	primitive_resize_float_array,
 };

vm/types.c

@@ -12,6 +12,105 @@ bool to_boolean(CELL value)
 	return value != F;
 }
 
+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(array_to_vector)
+{
+	F_VECTOR *vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
+	vector->top = dpop();
+	vector->array = dpop();
+	dpush(tag_object(vector));
+}
+
+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));
+}
+
+/* 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)
@@ -38,41 +137,6 @@ F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill)
 	return array;
 }
 
-/* size is in bytes this time */
-F_BYTE_ARRAY *allot_byte_array(CELL size)
-{
-	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);
-
-	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 */
 DEFINE_PRIMITIVE(array)
 {
@@ -81,89 +145,6 @@ DEFINE_PRIMITIVE(array)
 	dpush(tag_object(allot_array(ARRAY_TYPE,size,initial)));
 }
 
-/* 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)
-{
-	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)));
-}
-
-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_1(CELL obj)
 {
 	REGISTER_ROOT(obj);
@@ -235,42 +216,6 @@ DEFINE_PRIMITIVE(resize_array)
 	dpush(tag_object(reallot_array(array,capacity,F)));
 }
 
-F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
-{
-	CELL to_copy = array_capacity(array);
-	if(capacity < to_copy)
-		to_copy = capacity;
-
-	REGISTER_UNTAGGED(array);
-
-	F_BYTE_ARRAY *new_array = allot_array_internal(untag_header(array->header),capacity);
-
-	UNREGISTER_UNTAGGED(array);
-
-	memcpy(new_array + 1,array + 1,to_copy * CELLS);
-	memset(AREF(new_array,to_copy),0,capacity - to_copy)   ;
-
-	for(i = to_copy; i < capacity; i++)
-		set_array_nth(new_array,i,fill);
-
-	return new_array;
-}
-
-DEFINE_PRIMITIVE(resize_array)
-{
-	F_ARRAY* array = untag_array(dpop());
-	CELL capacity = unbox_array_size();
-	dpush(tag_object(reallot_array(array,capacity,F)));
-}
-
-DEFINE_PRIMITIVE(array_to_vector)
-{
-	F_VECTOR *vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
-	vector->top = dpop();
-	vector->array = dpop();
-	dpush(tag_object(vector));
-}
-
 F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count)
 {
 	REGISTER_ROOT(elt);
@@ -307,6 +252,199 @@ F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
 	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);
+	if(capacity < to_copy)
+		to_copy = capacity;
+
+	REGISTER_UNTAGGED(array);
+	F_BYTE_ARRAY *new_array = allot_byte_array(capacity);
+	UNREGISTER_UNTAGGED(array);
+
+	memcpy(new_array + 1,array + 1,to_copy);
+
+	return new_array;
+}
+
+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)));
+}
+
+/* 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_bit_array)
+{
+	F_BYTE_ARRAY* array = untag_bit_array(dpop());
+	CELL capacity = unbox_array_size();
+	dpush(tag_object(reallot_bit_array(array,capacity)));
+}
+
+/* Float arrays */
+
+/* size is in 8-byte doubles */
+F_FLOAT_ARRAY *allot_float_array_internal(CELL size)
+{
+	F_FLOAT_ARRAY *array = allot_object(FLOAT_ARRAY_TYPE,
+		float_array_size(size));
+	array->capacity = tag_fixnum(size);
+	return array;
+}
+
+F_FLOAT_ARRAY *allot_float_array(CELL size, double initial)
+{
+	F_FLOAT_ARRAY *array = allot_float_array_internal(size);
+
+	double *elements = (double *)AREF(array,0);
+	int i;
+	for(i = 0; i < size; i++)
+		elements[i] = initial;
+
+	return array;
+}
+
+/* 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 *reallot_float_array(F_FLOAT_ARRAY* array, CELL capacity)
+{
+	F_FLOAT_ARRAY* new_array;
+
+	CELL to_copy = array_capacity(array);
+	if(capacity < to_copy)
+		to_copy = capacity;
+
+	REGISTER_UNTAGGED(array);
+	new_array = allot_float_array(capacity,0.0);
+	UNREGISTER_UNTAGGED(array);
+
+	memcpy(new_array + 1,array + 1,to_copy * sizeof(double));
+
+	return new_array;
+}
+
+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)));
+}
+
+/* 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)
 {
@@ -497,70 +635,3 @@ DEFINE_PRIMITIVE(set_char_slot)
 	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));
-}

vm/types.h

@@ -14,6 +14,8 @@ INLINE CELL string_size(CELL size)
 	return sizeof(F_STRING) + (size + 1) * CHARS;
 }
 
+DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array)
+
 INLINE CELL byte_array_capacity(F_BYTE_ARRAY *array)
 {
 	return untag_fixnum_fast(array->capacity);
@@ -24,6 +26,8 @@ INLINE CELL byte_array_size(CELL size)
 	return sizeof(F_BYTE_ARRAY) + size;
 }
 
+DEFINE_UNTAG(F_BIT_ARRAY,BIT_ARRAY_TYPE,bit_array)
+
 INLINE CELL bit_array_capacity(F_BIT_ARRAY *array)
 {
 	return untag_fixnum_fast(array->capacity);
@@ -34,6 +38,8 @@ INLINE CELL bit_array_size(CELL size)
 	return sizeof(F_BIT_ARRAY) + (size + 7) / 8;
 }
 
+DEFINE_UNTAG(F_FLOAT_ARRAY,FLOAT_ARRAY_TYPE,float_array)
+
 INLINE CELL float_array_capacity(F_FLOAT_ARRAY *array)
 {
 	return untag_fixnum_fast(array->capacity);
@@ -49,22 +55,14 @@ INLINE CELL callstack_size(CELL size)
 	return sizeof(F_CALLSTACK) + size;
 }
 
-INLINE F_CALLSTACK *untag_callstack(CELL obj)
+DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack)
-{
-	type_check(CALLSTACK_TYPE,obj);
-	return untag_object(obj);
-}
 
 INLINE CELL tag_boolean(CELL untagged)
 {
 	return (untagged == false ? F : T);
 }
 
-INLINE F_ARRAY* untag_array(CELL tagged)
+DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array)
-{
-	type_check(ARRAY_TYPE,tagged);
-	return untag_object(tagged);
-}
 
 #define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
 #define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS)
@@ -103,17 +101,9 @@ INLINE void set_string_nth(F_STRING* string, CELL index, u16 value)
 	cput(SREF(string,index),value);
 }
 
-INLINE F_QUOTATION *untag_quotation(CELL tagged)
+DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation)
-{
-	type_check(QUOTATION_TYPE,tagged);
-	return untag_object(tagged);
-}
 
-INLINE F_WORD *untag_word(CELL tagged)
+DEFINE_UNTAG(F_WORD,WORD_TYPE,word)
-{
-	type_check(WORD_TYPE,tagged);
-	return untag_object(tagged);
-}
 
 INLINE CELL tag_tuple(F_ARRAY *tuple)
 {
@@ -144,6 +134,9 @@ DECLARE_PRIMITIVE(to_tuple);
 
 F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
 DECLARE_PRIMITIVE(resize_array);
+DECLARE_PRIMITIVE(resize_byte_array);
+DECLARE_PRIMITIVE(resize_bit_array);
+DECLARE_PRIMITIVE(resize_float_array);
 
 DECLARE_PRIMITIVE(array_to_vector);