native/unix/read.o \
native/unix/write.o \
native/unix/ffi.o \
- native/debug.o
+ native/debug.o \
+ native/hashtable.o
default:
@echo "Run 'make' with one of the following parameters:"
USE: generic
USE: math-internals
USE: kernel
+USE: lists
! An array is a range of memory storing pointers to other
! objects. Arrays are not used directly, and their access words
BUILTIN: array 8
-: array-capacity ( array -- n ) 1 integer-slot ; inline
+: array-capacity ( array -- n ) 1 slot ; inline
: vector-array ( vec -- array ) 2 slot ; inline
: set-vector-array ( array vec -- ) 2 set-slot ; inline
: set-array-nth ( obj n array -- )
swap 2 fixnum+ set-slot ; inline
+
+: (array>list) ( n i array -- list )
+ pick pick fixnum<= [
+ 3drop [ ]
+ ] [
+ 2dup array-nth >r >r 1 fixnum+ r> (array>list) r>
+ swap cons
+ ] ifte ;
+
+: array>list ( n array -- list )
+ 0 swap (array>list) ;
IN: image
USE: errors
USE: generic
+USE: kernel-internals
USE: hashtables
USE: kernel
USE: lists
: cons-tag BIN: 010 ; inline
: object-tag BIN: 011 ; inline
-: f-type 6 ; inline
-: t-type 7 ; inline
-: array-type 8 ; inline
-: vector-type 11 ; inline
-: string-type 12 ; inline
-: word-type 17 ; inline
+: t-type 7 ; inline
+: array-type 8 ; inline
+: hashtable-type 10 ; inline
+: vector-type 11 ; inline
+: string-type 12 ; inline
+: word-type 17 ; inline
: immediate ( x tag -- tagged ) swap tag-bits shift bitor ;
: >header ( id -- tagged ) object-tag immediate ;
( Fixnums )
+: emit-fixnum ( n -- ) fixnum-tag immediate emit ;
+
M: fixnum ' ( n -- tagged ) fixnum-tag immediate ;
( Bignums )
[[ 0 [ 1 0 ] ]]
[[ -1 [ 2 1 1 ] ]]
[[ 1 [ 2 0 1 ] ]]
- ] assoc [ emit ] each align-here r> ;
+ ] assoc unswons emit-fixnum [ emit ] each align-here r> ;
( Special objects )
: -1, -1 >bignum ' drop ;
( Beginning of the image )
-! The image proper begins with the header, then T,
+! The image begins with the header, then T,
! and the bignums 0, 1, and -1.
: begin ( -- ) header t, 0, 1, -1, ;
object-tag here-as swap
string-type >header emit
dup str-length emit
- dup hashcode fixnum-tag immediate emit
+ dup hashcode emit-fixnum
pack-string
align-here ;
[ ' ] map
object-tag here-as >r
array-type >header emit
- dup length emit
+ dup length emit-fixnum
( elements -- ) [ emit ] each
align-here r> ;
dup vector>list emit-array swap vector-length
object-tag here-as >r
vector-type >header emit
- emit ( length )
+ emit-fixnum ( length )
emit ( array ptr )
align-here r> ;
: rehash ( hashtable -- )
! Now make a rehashing boot quotation
dup hash>alist [
- >r dup vector-length [
- [ f swap pick set-vector-nth ] keep
- ] repeat r>
+ over hash-clear
[ unswons rot set-hash ] each-with
] cons cons
boot-quot [ append ] change ;
+: emit-hashtable ( hash -- pointer )
+ dup buckets>list emit-array swap hash-size
+ object-tag here-as >r
+ hashtable-type >header emit
+ emit-fixnum ( length )
+ emit ( array ptr )
+ align-here r> ;
+
M: hashtable ' ( hashtable -- pointer )
#! Only hashtables are pooled, not vectors!
dup pooled-object [
- [ dup emit-vector [ pool-object ] keep ] keep rehash
+ [ dup emit-hashtable [ pool-object ] keep ] keep rehash
] ?unless ;
( End of the image )
: vocabularies, ( vocabularies -- )
[
- cdr dup vector? [
+ cdr dup hashtable? [
[
cdr dup word? [ word, ] [ drop ] ifte
] hash-each
[[ "vectors" ">vector" ]]
[[ "strings" ">string" ]]
[[ "words" ">word" ]]
+ [[ "hashtables" ">hashtable" ]]
[[ "kernel-internals" "slot" ]]
[[ "kernel-internals" "set-slot" ]]
[[ "kernel-internals" "integer-slot" ]]
[[ "kernel-internals" "set-integer-slot" ]]
[[ "kernel-internals" "grow-array" ]]
+ [[ "hashtables" "<hashtable>" ]]
+ [[ "kernel-internals" "<array>" ]]
] [
unswons create swap 1 + [ f define ] keep
] each drop
! Traits metaclass for user-defined classes based on hashtables
: traits ( object -- symbol )
- dup vector? [ \ traits swap hash ] [ drop f ] ifte ;
+ dup hashtable? [ \ traits swap hash ] [ drop f ] ifte ;
! Hashtable slot holding an optional delegate. Any undefined
! methods are called on the delegate. The object can also
] ifte ;
: add-traits-dispatch ( word vtable -- )
- >r unit [ car traits-dispatch call ] cons \ vector r>
+ >r unit [ car traits-dispatch call ] cons \ hashtable r>
set-vtable ;
\ traits [
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-IN: kernel-internals
+IN: hashtables
USE: generic
USE: kernel
USE: lists
USE: math
USE: vectors
-: hash-array vector-array ; inline
-: bucket-count >vector hash-array array-capacity ; inline
+BUILTIN: hashtable 10
+
+! A hashtable is implemented as an array of buckets. The
+! array index is determined using a hash function, and the
+! buckets are associative lists which are searched
+! linearly.
+
+IN: kernel-internals
+
+: hash-array 2 slot ; inline
: hash-bucket ( n hash -- alist )
- swap >fixnum swap >vector hash-array array-nth ; inline
+ swap >fixnum swap >hashtable hash-array array-nth ; inline
: set-hash-bucket ( obj n hash -- )
- >r >fixnum r> hash-array set-array-nth ; inline
+ swap >fixnum swap >hashtable hash-array set-array-nth ;
+ inline
-IN: hashtables
+: hash-size+ ( hash -- )
+ >hashtable dup 1 slot 1 + swap 1 set-slot ; inline
+
+: hash-size- ( hash -- )
+ >hashtable dup 1 slot 1 - swap 1 set-slot ; inline
-! Note that the length of a hashtable vector must not change
-! for the lifetime of the hashtable, otherwise problems will
-! occur. Do not use vector words with hashtables.
+IN: hashtables
-PREDICATE: vector hashtable ( obj -- ? )
- [ assoc? ] vector-all? ;
+: hash-size ( hash -- n )
+ #! Number of elements in the hashtable.
+ >hashtable 1 slot ;
-: <hashtable> ( buckets -- )
- #! A hashtable is implemented as an array of buckets. The
- #! array index is determined using a hash function, and the
- #! buckets are associative lists which are searched
- #! linearly. The number of buckets must be a power of two.
- empty-vector ;
+: bucket-count ( hash -- n )
+ >hashtable hash-array array-capacity ; inline
: (hashcode) ( key table -- index )
#! Compute the index of the bucket for a key.
: set-hash* ( key table quot -- )
#! Apply the quotation to yield a new association list.
+ #! If the association list already contains the key,
+ #! decrement the hash size, since it will get removed.
>r
2dup (hashcode)
r> pick >r
#! Store the value in the hashtable. Either replaces an
#! existing value in the appropriate bucket, or adds a new
#! key/value pair.
+ dup hash-size+
[ set-assoc ] set-hash* ;
: remove-hash ( key table -- )
#! Remove a value from a hashtable.
[ remove-assoc ] set-hash* ;
-: hash-each ( hash code -- )
- #! Apply the code to each key/value pair of the hashtable.
- swap [ swap dup >r each r> ] vector-each drop ; inline
+: hash-clear ( hash -- )
+ #! Remove all entries from a hashtable.
+ dup bucket-count [
+ [ f swap pick set-hash-bucket ] keep
+ ] repeat drop ;
+
+: buckets>list ( hash -- list )
+ #! Push a list of key/value pairs in a hashtable.
+ dup bucket-count swap hash-array array>list ;
+
+: (hash>alist) ( alist n hash -- alist )
+ 2dup bucket-count >= [
+ 2drop
+ ] [
+ [ hash-bucket [ swons ] each ] 2keep
+ >r 1 + r> (hash>alist)
+ ] ifte ;
+
+: hash>alist ( hash -- alist )
+ #! Push a list of key/value pairs in a hashtable.
+ [ ] 0 rot (hash>alist) ;
+
+: alist>hash ( alist -- hash )
+ dup length <hashtable> swap [ unswons pick set-hash ] each ;
: hash-keys ( hash -- list )
#! Push a list of keys in a hashtable.
- [ ] swap [ car swons ] hash-each ;
+ hash>alist [ car ] map ;
: hash-values ( hash -- alist )
#! Push a list of values in a hashtable.
- [ ] swap [ cdr swons ] hash-each ;
+ hash>alist [ cdr ] map ;
-: hash>alist ( hash -- list )
- #! Push a list of key/value pairs in a hashtable.
- [ ] swap [ swons ] hash-each ;
-
-: alist>hash ( alist -- hash )
- 37 <hashtable> swap [ unswons pick set-hash ] each ;
+: hash-each ( hash code -- )
+ #! Apply the code to each key/value pair of the hashtable.
+ >r hash>alist r> each ; inline
: >n ( namespace -- n:namespace )
#! Push a namespace on the namespace stack.
- >vector namestack cons set-namestack ; inline
+ >hashtable namestack cons set-namestack ; inline
: n> ( n:namespace -- namespace )
#! Pop the top of the namespace stack.
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: alien
+USE: hashtables
DEFER: alien
DEFER: dll
[ >cons [ [ object ] [ cons ] ] ]
[ >vector [ [ object ] [ vector ] ] ]
[ >string [ [ object ] [ string ] ] ]
- [ >word [ [ word ] [ word ] ] ]
+ [ >word [ [ object ] [ word ] ] ]
+ [ >hashtable [ [ object ] [ hashtable ] ] ]
[ slot [ [ object fixnum ] [ object ] ] ]
[ set-slot [ [ object object fixnum ] [ ] ] ]
[ integer-slot [ [ object fixnum ] [ integer ] ] ]
[ set-integer-slot [ [ integer object fixnum ] [ ] ] ]
[ grow-array [ [ integer array ] [ object ] ] ]
+ [ <hashtable> [ [ number ] [ hashtable ] ] ]
+ [ <array> [ [ number ] [ array ] ] ]
] [
2unlist dup string? [
"stack-effect" set-word-property
"visual basic" "testhash" get remove-hash
"visual basic" "testhash" get hash*
] unit-test
+
+[ 4 ] [
+ "hey"
+ {{ [[ "hey" 4 ]] [[ "whey" 5 ]] }} 2dup (hashcode)
+ >r buckets>list r> [ cdr ] times car assoc
+] unit-test
+
+! Testing the hash element counting
+
+<namespace> "counting" set
+"key" "value" "counting" get set-hash
+[ 1 ] [ "counting" get hash-size ] unit-test
+"key" "value" "counting" get set-hash
+[ 1 ] [ "counting" get hash-size ] unit-test
[ "funky" ] [ "funny-stack" get vector-pop ] unit-test
[ t ] [
- 10 <vector> dup vector-array array-capacity
+ { 1 2 3 4 } dup vector-array array-capacity
>r vector-clone vector-array array-capacity r>
=
] unit-test
BUILTIN: vector 11
-: vector-length ( vec -- len ) >vector 1 integer-slot ; inline
+: vector-length ( vec -- len ) >vector 1 slot ; inline
IN: kernel-internals
-: (set-vector-length) ( len vec -- ) 1 set-integer-slot ; inline
+: (set-vector-length) ( len vec -- ) 1 set-slot ; inline
: assert-positive ( fx -- )
0 fixnum<
: >pop> ( stack -- stack )
dup vector-pop drop ;
-: (vector>list) ( i vec -- list )
- 2dup vector-length >= [
- 2drop [ ]
- ] [
- 2dup vector-nth >r >r 1 + r> (vector>list) r> swons
- ] ifte ;
-
-: vector>list ( str -- list )
- 0 swap (vector>list) ;
+: vector>list ( vec -- list )
+ dup vector-length swap vector-array array>list ;
: vector-each ( vector quotation -- )
#! Execute the quotation with each element of the vector
{
F_ARRAY* array;
array = allot_object(type,sizeof(F_ARRAY) + capacity * CELLS);
- array->capacity = capacity;
+ array->capacity = tag_fixnum(capacity);
return array;
}
return array;
}
+void primitive_array(void)
+{
+ F_FIXNUM capacity = to_fixnum(dpop());
+ if(capacity < 0)
+ general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity));
+ maybe_garbage_collection();
+ dpush(tag_object(array(capacity,F)));
+}
+
F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill)
{
/* later on, do an optimization: if end of array is here, just grow */
int i;
F_ARRAY* new_array;
+ CELL curr_cap = untag_fixnum_fast(array->capacity);
- if(array->capacity >= capacity)
+ if(curr_cap >= capacity)
return array;
new_array = allot_array(untag_header(array->header),capacity);
memcpy(new_array + 1,array + 1,array->capacity * CELLS);
- for(i = array->capacity; i < capacity; i++)
+ for(i = curr_cap; i < capacity; i++)
put(AREF(new_array,i),fill);
return new_array;
void primitive_grow_array(void)
{
- F_ARRAY* array = untag_array(dpop());
- CELL capacity = to_fixnum(dpop());
+ F_ARRAY* array;
+ CELL capacity;
+ maybe_garbage_collection();
+ array = untag_array(dpop());
+ capacity = to_fixnum(dpop());
dpush(tag_object(grow_array(array,capacity,F)));
}
void fixup_array(F_ARRAY* array)
{
int i = 0;
- for(i = 0; i < array->capacity; i++)
+ CELL capacity = untag_fixnum_fast(array->capacity);
+ for(i = 0; i < capacity; i++)
data_fixup((void*)AREF(array,i));
}
void collect_array(F_ARRAY* array)
{
int i = 0;
- for(i = 0; i < array->capacity; i++)
+ CELL capacity = untag_fixnum_fast(array->capacity);
+ for(i = 0; i < capacity; i++)
copy_object((void*)AREF(array,i));
}
typedef struct {
CELL header;
- /* untagged */
+ /* tagged */
CELL capacity;
} F_ARRAY;
INLINE F_ARRAY* untag_array(CELL tagged)
{
- /* type_check(ARRAY_TYPE,tagged); */
- return (F_ARRAY*)UNTAG(tagged); /* FIXME */
+ type_check(ARRAY_TYPE,tagged);
+ return (F_ARRAY*)UNTAG(tagged);
}
F_ARRAY* allot_array(CELL type, CELL capacity);
F_ARRAY* array(CELL capacity, CELL fill);
+void primitive_array(void);
F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill);
void primitive_grow_array(void);
F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity);
#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
#define ASIZE(pointer) align8(sizeof(F_ARRAY) + \
- ((F_ARRAY*)(pointer))->capacity * CELLS)
+ untag_fixnum_fast(((F_ARRAY*)(pointer))->capacity) * CELLS)
void fixup_array(F_ARRAY* array);
void collect_array(F_ARRAY* array);
#include "image.h"
#include "primitives.h"
#include "vector.h"
+#include "hashtable.h"
#include "stack.h"
#include "compiler.h"
#include "relocate.h"
case ARRAY_TYPE:
collect_array((F_ARRAY*)scan);
break;
+ case HASHTABLE_TYPE:
+ collect_hashtable((F_HASHTABLE*)scan);
+ break;
case VECTOR_TYPE:
collect_vector((F_VECTOR*)scan);
break;
if(tag == FIXNUM_TYPE)
return;
+ if(headerp(pointer))
+ critical_error("Asked to copy header",pointer);
+
header = get(UNTAG(pointer));
if(TAG(header) == GC_COLLECTED)
newpointer = UNTAG(header);
--- /dev/null
+#include "factor.h"
+
+F_HASHTABLE* hashtable(F_FIXNUM capacity)
+{
+ F_HASHTABLE* hash;
+ if(capacity < 0)
+ general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity));
+ hash = allot_object(HASHTABLE_TYPE,sizeof(F_VECTOR));
+ hash->count = tag_fixnum(0);
+ hash->array = tag_object(array(capacity,F));
+ return hash;
+}
+
+void primitive_hashtable(void)
+{
+ maybe_garbage_collection();
+ drepl(tag_object(hashtable(to_fixnum(dpeek()))));
+}
+
+void primitive_to_hashtable(void)
+{
+ type_check(HASHTABLE_TYPE,dpeek());
+}
+
+void fixup_hashtable(F_HASHTABLE* hashtable)
+{
+ data_fixup(&hashtable->array);
+}
+
+void collect_hashtable(F_HASHTABLE* hashtable)
+{
+ copy_object(&hashtable->array);
+}
--- /dev/null
+typedef struct {
+ /* always tag_header(HASHTABLE_TYPE) */
+ CELL header;
+ /* tagged */
+ CELL count;
+ /* tagged */
+ CELL array;
+} F_HASHTABLE;
+
+F_HASHTABLE* hashtable(F_FIXNUM capacity);
+
+void primitive_hashtable(void);
+void primitive_to_hashtable(void);
+void fixup_hashtable(F_HASHTABLE* hashtable);
+void collect_hashtable(F_HASHTABLE* hashtable);
primitive_to_vector,
primitive_to_string,
primitive_to_word,
+ primitive_to_hashtable,
primitive_slot,
primitive_set_slot,
primitive_integer_slot,
primitive_set_integer_slot,
- primitive_grow_array
+ primitive_grow_array,
+ primitive_hashtable,
+ primitive_array
};
CELL primitive_to_xt(CELL primitive)
case ARRAY_TYPE:
fixup_array((F_ARRAY*)relocating);
break;
+ case HASHTABLE_TYPE:
+ fixup_hashtable((F_HASHTABLE*)relocating);
+ break;
case VECTOR_TYPE:
fixup_vector((F_VECTOR*)relocating);
break;
#define BIGNUM_START_PTR(bignum) \
((BIGNUM_TO_POINTER (bignum)) + 1)
-#define BIGNUM_LENGTH(bignum) ((bignum)->capacity - 1)
+#define BIGNUM_LENGTH(bignum) (untag_fixnum_fast((bignum)->capacity) - 1)
#define BIGNUM_NEGATIVE_P(bignum) (get(AREF(bignum,0)) != 0)
#define BIGNUM_SET_NEGATIVE_P(bignum,neg) put(AREF(bignum,0),neg)
F_VECTOR* v = vector(depth);
F_ARRAY* a = untag_array(v->array);
memcpy(a + 1,(void*)bottom,depth * CELLS);
- v->top = depth;
+ v->top = tag_fixnum(depth);
return v;
}
CELL vector_to_stack(F_VECTOR* vector, CELL bottom)
{
CELL start = bottom;
- CELL len = vector->top * CELLS;
+ CELL len = untag_fixnum_fast(vector->top) * CELLS;
memcpy((void*)start,untag_array(vector->array) + 1,len);
return start + len - CELLS;
}
case BIGNUM_TYPE:
size = ASIZE(pointer);
break;
+ case HASHTABLE_TYPE:
+ size = sizeof(F_HASHTABLE);
+ break;
case VECTOR_TYPE:
size = sizeof(F_VECTOR);
break;
#define F_TYPE 9
#define F RETAG(0,OBJECT_TYPE)
+#define HASHTABLE_TYPE 10
#define VECTOR_TYPE 11
#define STRING_TYPE 12
#define SBUF_TYPE 13
if(capacity < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity));
vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));
- vector->top = 0;
+ vector->top = tag_fixnum(0);
vector->array = tag_object(array(capacity,F));
return vector;
}
typedef struct {
/* always tag_header(VECTOR_TYPE) */
CELL header;
- /* untagged */
+ /* tagged */
CELL top;
/* tagged */
CELL array;
projects / factor.git / commitdiff