diff --git a/library/generic/standard-combination.factor b/library/generic/standard-combination.factor index df13aaf1de..69b8734f1f 100644 --- a/library/generic/standard-combination.factor +++ b/library/generic/standard-combination.factor @@ -52,30 +52,36 @@ TUPLE: no-method object generic ; : simplify-alist ( class assoc -- default assoc ) 0 swap (simplify-alist) ; +: default-method ( dispatch# word -- pair ) + empty-method object bootstrap-word swap 2array ; + : methods* ( dispatch# word -- assoc ) #! Make a class->method association, together with a #! default delegating method at the end. - [ - empty-method object bootstrap-word swap 2array 1array - ] keep methods append ; + dup methods -rot default-method add* ; -: small-generic ( dispatch# word -- def ) - dupd methods* object bootstrap-word swap simplify-alist +: method-alist>quot ( dispatch# word base-class -- quot ) + bootstrap-word swap simplify-alist swapd class-predicates alist>quot ; -: vtable-methods ( dispatch# alist-seq -- alist-seq ) +: small-generic ( dispatch# word -- def ) + dupd methods* object method-alist>quot ; + +: build-type-vtable ( dispatch# alist-seq -- alist-seq ) dup length [ type>class [ swap simplify-alist ] [ first second [ ] ] if* >r over r> class-predicates alist>quot ] 2map nip ; -: ( dispatch# word n -- vtable ) +: ( dispatch# word n -- vtable ) #! n is vtable size; either num-types or num-tags. - >r dupd methods* r> sort-methods vtable-methods ; + >r dupd methods* r> sort-methods build-type-vtable ; -: big-generic ( dispatch# word n dispatcher -- def ) - [ >r pick picker % r> , , \ dispatch , ] [ ] make ; +: type-generic ( dispatch# word n dispatcher -- quot ) + [ + >r pick picker % r> , , \ dispatch , + ] [ ] make ; : tag-generic? ( word -- ? ) #! If all the types we dispatch upon can be identified @@ -85,16 +91,35 @@ TUPLE: no-method object generic ; : small-generic? ( word -- ? ) generic-tags length 3 <= ; +: build-class-vtable ( vtable pair -- ) + dup first hashcode pick length rem rot nth push ; + +: ( dispatch# word assoc -- table ) + >r dupd default-method r> + [ length 3 + [ drop 1array >vector ] map-with ] keep + [ dupd build-class-vtable ] each + [ object method-alist>quot ] map-with ; + +: class-generic ( dispatch# word -- quot ) + dup methods dup empty? [ + drop default-method + ] [ + [ + pick picker % [ class hashcode ] % + dup length , \ rem , , \ dispatch , + ] [ ] make + ] if ; + : standard-combination ( word dispatch# -- quot ) swap { - { [ dup tag-generic? ] [ num-tags \ tag big-generic ] } + { [ dup tag-generic? ] [ num-tags \ tag type-generic ] } { [ dup small-generic? ] [ small-generic ] } - { [ t ] [ num-types \ type big-generic ] } + { [ t ] [ class-generic ] } + { [ t ] [ num-types \ type type-generic ] } } cond ; : define-generic ( word -- ) [ 0 standard-combination ] define-generic* ; PREDICATE: generic standard-generic - 1 swap "combination" word-prop ?nth - \ standard-combination eq? ; + "combination" word-prop [ standard-combination ] tail? ; diff --git a/vm/factor.c b/vm/factor.c index d2e7eaa561..8a35c5ff82 100644 --- a/vm/factor.c +++ b/vm/factor.c @@ -4,6 +4,7 @@ void init_factor(const char* image, CELL ds_size, CELL rs_size, CELL cs_size, CELL gen_count, CELL young_size, CELL aging_size, CELL code_size) { + srand(current_millis()); init_ffi(); init_data_heap(gen_count,young_size,aging_size); init_code_heap(code_size); diff --git a/vm/types.c b/vm/types.c index 6fd7b2f0cd..b45ba532ea 100644 --- a/vm/types.c +++ b/vm/types.c @@ -434,7 +434,7 @@ void primitive_word(void) vocabulary = dpop(); name = dpop(); word = allot_object(WORD_TYPE,sizeof(F_WORD)); - word->hashcode = tag_fixnum((CELL)word); /* initial address */ + word->hashcode = tag_fixnum(rand()); word->name = name; word->vocabulary = vocabulary; word->primitive = tag_fixnum(0);