From 0cd2f857fe0931213a3bc61fa678a00e97c64b0f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 29 Jan 2008 15:04:26 -0600 Subject: [PATCH] bit-vectors byte-vectors float-vectors --- core/bit-arrays/bit-arrays-tests.factor | 6 + core/bit-vectors/bit-vectors-docs.factor | 33 ++ core/bit-vectors/bit-vectors-tests.factor | 12 + core/bit-vectors/bit-vectors.factor | 2 +- core/bootstrap/primitives.factor | 33 +- core/byte-arrays/byte-arrays-tests.factor | 8 + core/byte-vectors/byte-vectors-docs.factor | 34 ++ core/byte-vectors/byte-vectors-tests.factor | 12 + core/byte-vectors/byte-vectors.factor | 4 +- core/float-arrays/float-arrays-tests.factor | 6 + core/float-vectors/float-vectors-tests.factor | 12 + core/float-vectors/float-vectors.factor | 4 +- core/syntax/syntax-docs.factor | 40 +- core/vectors/vectors-docs.factor | 2 +- vm/alien.h | 6 +- vm/errors.h | 7 + vm/primitives.c | 3 + vm/types.c | 513 ++++++++++-------- vm/types.h | 33 +- 19 files changed, 500 insertions(+), 270 deletions(-) mode change 100644 => 100755 core/bit-arrays/bit-arrays-tests.factor create mode 100755 core/bit-vectors/bit-vectors-docs.factor create mode 100755 core/bit-vectors/bit-vectors-tests.factor create mode 100755 core/byte-arrays/byte-arrays-tests.factor create mode 100755 core/byte-vectors/byte-vectors-docs.factor create mode 100755 core/byte-vectors/byte-vectors-tests.factor mode change 100644 => 100755 core/float-arrays/float-arrays-tests.factor create mode 100755 core/float-vectors/float-vectors-tests.factor mode change 100644 => 100755 core/vectors/vectors-docs.factor mode change 100644 => 100755 vm/alien.h diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor old mode 100644 new mode 100755 index 48698ad91d..f605eba24c --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -46,3 +46,9 @@ IN: temporary [ ?{ f } ] [ 1 2 { t f t f } >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 diff --git a/core/bit-vectors/bit-vectors-docs.factor b/core/bit-vectors/bit-vectors-docs.factor new file mode 100755 index 0000000000..b4b6d8e845 --- /dev/null +++ b/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 } +"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: +{ $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." } ; diff --git a/core/bit-vectors/bit-vectors-tests.factor b/core/bit-vectors/bit-vectors-tests.factor new file mode 100755 index 0000000000..2af9141ace --- /dev/null +++ b/core/bit-vectors/bit-vectors-tests.factor @@ -0,0 +1,12 @@ +IN: temporary +USING: tools.test bit-vectors vectors sequences kernel math ; + +[ 0 ] [ 123 length ] unit-test + +: do-it + 1234 swap [ >r even? r> push ] curry each ; + +[ t ] [ + 3 dup do-it + 3 dup do-it sequence= +] unit-test diff --git a/core/bit-vectors/bit-vectors.factor b/core/bit-vectors/bit-vectors.factor index 713f7b8a93..b22e3c2eef 100755 --- a/core/bit-vectors/bit-vectors.factor +++ b/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 r first2 r> make-primitive ] 2each diff --git a/core/byte-arrays/byte-arrays-tests.factor b/core/byte-arrays/byte-arrays-tests.factor new file mode 100755 index 0000000000..b39551eb86 --- /dev/null +++ b/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 diff --git a/core/byte-vectors/byte-vectors-docs.factor b/core/byte-vectors/byte-vectors-docs.factor new file mode 100755 index 0000000000..e4bd1bd096 --- /dev/null +++ b/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 } +"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: +{ $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." } ; diff --git a/core/byte-vectors/byte-vectors-tests.factor b/core/byte-vectors/byte-vectors-tests.factor new file mode 100755 index 0000000000..888d6957b2 --- /dev/null +++ b/core/byte-vectors/byte-vectors-tests.factor @@ -0,0 +1,12 @@ +IN: temporary +USING: tools.test byte-vectors vectors sequences kernel ; + +[ 0 ] [ 123 length ] unit-test + +: do-it + 123 [ over push ] each ; + +[ t ] [ + 3 do-it + 3 do-it sequence= +] unit-test diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index bf3f01fb72..060ac94472 100755 --- a/core/byte-vectors/byte-vectors.factor +++ b/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 vector ( byte-array -- byte-vector ) +: byte-array>vector ( byte-array capacity -- byte-vector ) byte-vector construct-boa ; inline PRIVATE> diff --git a/core/float-arrays/float-arrays-tests.factor b/core/float-arrays/float-arrays-tests.factor old mode 100644 new mode 100755 index 811c380e41..afadaac0db --- a/core/float-arrays/float-arrays-tests.factor +++ b/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 ] 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 diff --git a/core/float-vectors/float-vectors-tests.factor b/core/float-vectors/float-vectors-tests.factor new file mode 100755 index 0000000000..11f87f1f52 --- /dev/null +++ b/core/float-vectors/float-vectors-tests.factor @@ -0,0 +1,12 @@ +IN: temporary +USING: tools.test float-vectors vectors sequences kernel ; + +[ 0 ] [ 123 length ] unit-test + +: do-it + 12345 [ over push ] each ; + +[ t ] [ + 3 do-it + 3 do-it sequence= +] unit-test diff --git a/core/float-vectors/float-vectors.factor b/core/float-vectors/float-vectors.factor index fe623801dd..fa19e3aaf8 100755 --- a/core/float-vectors/float-vectors.factor +++ b/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 : ( n -- float-vector ) - 0 float-array>vector ; inline + 0.0 0 float-array>vector ; inline : >float-vector ( seq -- float-vector ) V{ } clone-like ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 9cf9647e41..df96743e3d 100755 --- a/core/syntax/syntax-docs.factor +++ b/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" } } diff --git a/core/vectors/vectors-docs.factor b/core/vectors/vectors-docs.factor old mode 100644 new mode 100755 index 56c59fac46..7093c684a9 --- a/core/vectors/vectors-docs.factor +++ b/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 } } diff --git a/vm/alien.h b/vm/alien.h old mode 100644 new mode 100755 index a3ca0753a4..3357b0a3c0 --- a/vm/alien.h +++ b/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) -{ - type_check(DLL_TYPE,tagged); - return (F_DLL*)UNTAG(tagged); -} +DEFINE_UNTAG(F_DLL,DLL_TYPE,dll) DECLARE_PRIMITIVE(dlopen); DECLARE_PRIMITIVE(dlsym); diff --git a/vm/errors.h b/vm/errors.h index 5fe5b08e0d..747a3415ba 100755 --- a/vm/errors.h +++ b/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; diff --git a/vm/primitives.c b/vm/primitives.c index 7151d139bf..78dbc28358 100755 --- a/vm/primitives.c +++ b/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, }; diff --git a/vm/types.c b/vm/types.c index 063b5e966a..9f5dfb1248 100755 --- a/vm/types.c +++ b/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; +} + +/* ( 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; -} - -/* ( 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)); -} diff --git a/vm/types.h b/vm/types.h index 356b944133..ae27f1130a 100755 --- a/vm/types.h +++ b/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);