bit-vectors byte-vectors float-vectors
Slava Pestov
parent
571c4c57ae
commit
0cd2f857fe
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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." } ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
|
|
|
|||
|
|
@ -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 } }
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
{
|
||||
type_check(DLL_TYPE,tagged);
|
||||
return (F_DLL*)UNTAG(tagged);
|
||||
}
|
||||
DEFINE_UNTAG(F_DLL,DLL_TYPE,dll)
|
||||
|
||||
DECLARE_PRIMITIVE(dlopen);
|
||||
DECLARE_PRIMITIVE(dlsym);
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
};
|
||||
|
|
|
|||
513
vm/types.c
513
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));
|
||||
}
|
||||
|
|
|
|||
33
vm/types.h
33
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)
|
||||
{
|
||||
type_check(CALLSTACK_TYPE,obj);
|
||||
return untag_object(obj);
|
||||
}
|
||||
DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack)
|
||||
|
||||
INLINE CELL tag_boolean(CELL untagged)
|
||||
{
|
||||
return (untagged == false ? F : T);
|
||||
}
|
||||
|
||||
INLINE F_ARRAY* untag_array(CELL tagged)
|
||||
{
|
||||
type_check(ARRAY_TYPE,tagged);
|
||||
return untag_object(tagged);
|
||||
}
|
||||
DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array)
|
||||
|
||||
#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)
|
||||
{
|
||||
type_check(QUOTATION_TYPE,tagged);
|
||||
return untag_object(tagged);
|
||||
}
|
||||
DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation)
|
||||
|
||||
INLINE F_WORD *untag_word(CELL tagged)
|
||||
{
|
||||
type_check(WORD_TYPE,tagged);
|
||||
return untag_object(tagged);
|
||||
}
|
||||
DEFINE_UNTAG(F_WORD,WORD_TYPE,word)
|
||||
|
||||
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);
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue