diff --git a/mps/example/scheme/scheme-malloc.c b/mps/example/scheme/scheme-malloc.c index 1eeb9f40b96..009de7aaee3 100644 --- a/mps/example/scheme/scheme-malloc.c +++ b/mps/example/scheme/scheme-malloc.c @@ -585,18 +585,30 @@ static int eqp(obj_t obj1, obj_t obj2) static unsigned long eqv_hash(obj_t obj) { - if(TYPE(obj) == TYPE_INTEGER) + switch(TYPE(obj)) { + case TYPE_INTEGER: return obj->integer.integer; - else + case TYPE_CHARACTER: + return obj->character.c; + default: return eq_hash(obj); + } } static int eqvp(obj_t obj1, obj_t obj2) { - return obj1 == obj2 || - (TYPE(obj1) == TYPE_INTEGER && - TYPE(obj2) == TYPE_INTEGER && - obj1->integer.integer == obj2->integer.integer); + if (obj1 == obj2) + return 1; + if (TYPE(obj1) != TYPE(obj2)) + return 0; + switch(TYPE(obj1)) { + case TYPE_INTEGER: + return obj1->integer.integer == obj2->integer.integer; + case TYPE_CHARACTER: + return obj1->character.c == obj2->character.c; + default: + return 0; + } } static unsigned long string_hash(obj_t obj) @@ -2924,6 +2936,22 @@ static obj_t entry_string_hash(obj_t env, obj_t op_env, obj_t operator, obj_t op } +static obj_t entry_eq_hash(obj_t env, obj_t op_env, obj_t operator, obj_t operands) +{ + obj_t arg; + eval_args(operator->operator.name, env, op_env, operands, 1, &arg); + return make_integer(eq_hash(arg)); +} + + +static obj_t entry_eqv_hash(obj_t env, obj_t op_env, obj_t operator, obj_t operands) +{ + obj_t arg; + eval_args(operator->operator.name, env, op_env, operands, 1, &arg); + return make_integer(eqv_hash(arg)); +} + + static obj_t make_hashtable(obj_t operator, obj_t rest, hash_t hashf, cmp_t cmpf) { size_t length; @@ -2996,10 +3024,17 @@ static obj_t entry_make_hashtable(obj_t env, obj_t op_env, obj_t operator, obj_t error("%s: first argument must be a procedure", operator->operator.name); unless(TYPE(cmpf) == TYPE_OPERATOR) error("%s: first argument must be a procedure", operator->operator.name); - unless(hashf->operator.entry == entry_string_hash - && cmpf->operator.entry == entry_string_equalp) - error("%s: arguments not supported", operator->operator.name); - return make_hashtable(operator, rest, string_hash, string_equalp); + if (hashf->operator.entry == entry_eq_hash + && cmpf->operator.entry == entry_eqp) + return make_hashtable(operator, rest, eq_hash, eqp); + if (hashf->operator.entry == entry_eqv_hash + && cmpf->operator.entry == entry_eqvp) + return make_hashtable(operator, rest, eqv_hash, eqvp); + if (hashf->operator.entry == entry_string_hash + && cmpf->operator.entry == entry_string_equalp) + return make_hashtable(operator, rest, string_hash, string_equalp); + error("%s: arguments not supported", operator->operator.name); + return obj_undefined; } @@ -3248,6 +3283,8 @@ static struct {char *name; entry_t entry;} funtab[] = { {"hashtable-contains?", entry_hashtable_containsp}, {"hashtable-keys", entry_hashtable_keys}, {"string-hash", entry_string_hash}, + {"eq-hash", entry_eq_hash}, + {"eqv-hash", entry_eqv_hash}, }; diff --git a/mps/example/scheme/test-mps.scm b/mps/example/scheme/test-mps.scm index 4f9b0b72faf..c6dd71e295e 100644 --- a/mps/example/scheme/test-mps.scm +++ b/mps/example/scheme/test-mps.scm @@ -47,8 +47,10 @@ (check '(ht-test (make-hashtable string-hash string=?) stringify) #t) (define (symbolize n) (string->symbol (make-string n #\a))) (check '(ht-test (make-eq-hashtable) symbolize) #t) +(check '(ht-test (make-hashtable eq-hash eq?) symbolize) #t) (define (identity n) n) (check '(ht-test (make-eqv-hashtable) identity) #t) +(check '(ht-test (make-hashtable eqv-hash eqv?) identity) #t) (write-string "All tests pass.") (newline)