mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 22:29:16 +02:00
196 lines
6.2 KiB
C
196 lines
6.2 KiB
C
|
|
#include <chibi/eval.h>
|
|
|
|
#define HASH_DEPTH 5
|
|
|
|
#define FNV_PRIME 16777619
|
|
#define FNV_OFFSET_BASIS 2166136261uL
|
|
|
|
#define sexp_hash_table_buckets(x) sexp_slot_ref(x, 0)
|
|
#define sexp_hash_table_size(x) sexp_slot_ref(x, 1)
|
|
#define sexp_hash_table_hash_fn(x) sexp_slot_ref(x, 2)
|
|
#define sexp_hash_table_eq_fn(x) sexp_slot_ref(x, 3)
|
|
|
|
static sexp_uint_t string_hash (char *str, sexp_uint_t bound) {
|
|
sexp_uint_t acc = FNV_OFFSET_BASIS;
|
|
while (*str) {acc *= FNV_PRIME; acc ^= *str++;}
|
|
return acc % bound;
|
|
}
|
|
|
|
static sexp sexp_string_hash (sexp ctx, sexp str, sexp bound) {
|
|
return sexp_make_fixnum(string_hash(sexp_string_data(str),
|
|
sexp_unbox_fixnum(bound)));
|
|
}
|
|
|
|
static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) {
|
|
sexp_uint_t acc = FNV_OFFSET_BASIS;
|
|
while (*str) {acc *= FNV_PRIME; acc ^= tolower(*str++);}
|
|
return acc % bound;
|
|
}
|
|
|
|
static sexp sexp_string_ci_hash (sexp ctx, sexp str, sexp bound) {
|
|
return sexp_make_fixnum(string_ci_hash(sexp_string_data(str),
|
|
sexp_unbox_fixnum(bound)));
|
|
}
|
|
|
|
static sexp_uint_t hash_one (sexp obj, sexp_uint_t bound, sexp_sint_t depth) {
|
|
sexp_uint_t acc = FNV_OFFSET_BASIS, size;
|
|
sexp_sint_t i, len;
|
|
sexp t, *p;
|
|
char *p0;
|
|
loop:
|
|
#if USE_FLONUMS
|
|
if (sexp_flonump(obj))
|
|
acc ^= (sexp_sint_t) sexp_flonum_value(obj);
|
|
else
|
|
#endif
|
|
if (sexp_pointerp(obj)) {
|
|
if (depth) {
|
|
t = &(sexp_type_specs[sexp_pointer_tag(obj)]);
|
|
p = (sexp*) (((char*)obj) + sexp_type_field_base(t));
|
|
p0 = ((char*)obj) + offsetof(struct sexp_struct, value);
|
|
if ((sexp)p == obj) p=(sexp*)p0;
|
|
/* hash trailing non-object data */
|
|
size = sexp_type_size_of_object(t, obj)-offsetof(struct sexp_struct, value);
|
|
p0 = ((char*)p + sexp_type_num_slots_of_object(t,obj)*sizeof(sexp));
|
|
if (((char*)obj + size) > p0)
|
|
for (i=0; i<size; i++) {acc *= FNV_PRIME; acc ^= p0[i];}
|
|
/* hash eq-object slots */
|
|
len = sexp_type_num_eq_slots_of_object(t, obj);
|
|
if (len > 0) {
|
|
depth--;
|
|
for (i=0; i<len-1; i++) {
|
|
acc *= FNV_PRIME;
|
|
acc ^= hash_one(p[i], 0, depth);
|
|
}
|
|
/* tail-recurse on the last value */
|
|
obj = p[len-1]; goto loop;
|
|
}
|
|
} else {
|
|
acc ^= sexp_pointer_tag(obj);
|
|
}
|
|
} else {
|
|
acc ^= (sexp_uint_t)obj;
|
|
}
|
|
return (bound ? acc % bound : acc);
|
|
}
|
|
|
|
static sexp_uint_t hash (sexp obj, sexp_uint_t bound) {
|
|
return hash_one(obj, bound, HASH_DEPTH);
|
|
}
|
|
|
|
static sexp sexp_hash (sexp ctx, sexp obj, sexp bound) {
|
|
return sexp_make_fixnum(hash(obj, sexp_unbox_fixnum(bound)));
|
|
}
|
|
|
|
static sexp sexp_hash_by_identity (sexp ctx, sexp obj, sexp bound) {
|
|
return sexp_make_fixnum((sexp_uint_t)obj % sexp_unbox_fixnum(bound));
|
|
}
|
|
|
|
static sexp sexp_get_bucket (sexp ctx, sexp ht, sexp obj) {
|
|
sexp_gc_var1(args);
|
|
sexp buckets = sexp_hash_table_buckets(ht), hash_fn, res;
|
|
sexp_uint_t len = sexp_vector_length(buckets);
|
|
hash_fn = sexp_hash_table_hash_fn(ht);
|
|
if (hash_fn == sexp_make_fixnum(1))
|
|
res = sexp_hash_by_identity(ctx, obj, sexp_make_fixnum(len));
|
|
else if (hash_fn == sexp_make_fixnum(2))
|
|
res = sexp_hash(ctx, obj, sexp_make_fixnum(len));
|
|
else {
|
|
sexp_gc_preserve1(ctx, args);
|
|
args = sexp_list2(ctx, obj, sexp_make_fixnum(len));
|
|
res = sexp_apply(ctx, hash_fn, args);
|
|
if (sexp_exceptionp(res)) {
|
|
args = sexp_eval_string(ctx, "(current-error-port)", sexp_context_env(ctx));
|
|
sexp_print_exception(ctx, res, args);
|
|
res = sexp_make_fixnum(0);
|
|
}
|
|
sexp_gc_release1(ctx);
|
|
}
|
|
return res;
|
|
}
|
|
|
|
static sexp sexp_scan_bucket (sexp ctx, sexp ls, sexp obj, sexp eq_fn) {
|
|
sexp_gc_var1(res);
|
|
sexp p;
|
|
res = SEXP_FALSE;
|
|
if ((eq_fn == sexp_make_fixnum(1))
|
|
|| ((eq_fn == sexp_make_fixnum(2))
|
|
&& (sexp_pointerp(obj) ?
|
|
(sexp_pointer_tag(obj) == SEXP_SYMBOL) : ! sexp_fixnump(obj)))) {
|
|
for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) {
|
|
if (sexp_caar(p) == obj) {
|
|
res = p;
|
|
break;
|
|
}
|
|
}
|
|
} else if (eq_fn == sexp_make_fixnum(2)) {
|
|
for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) {
|
|
if (sexp_truep(sexp_equalp(ctx, sexp_caar(p), obj))) {
|
|
res = p;
|
|
break;
|
|
}
|
|
}
|
|
} else {
|
|
sexp_gc_preserve1(ctx, res);
|
|
for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) {
|
|
res = sexp_list2(ctx, sexp_caar(p), obj);
|
|
if (sexp_truep(sexp_apply(ctx, eq_fn, res))) {
|
|
res = p;
|
|
break;
|
|
} else {
|
|
res = SEXP_FALSE;
|
|
}
|
|
}
|
|
sexp_gc_release1(ctx);
|
|
}
|
|
return res;
|
|
}
|
|
|
|
static sexp sexp_hash_table_cell (sexp ctx, sexp ht, sexp obj, sexp createp) {
|
|
sexp_gc_var1(res);
|
|
sexp_uint_t size;
|
|
sexp buckets=sexp_hash_table_buckets(ht), eq_fn=sexp_hash_table_eq_fn(ht),
|
|
i=sexp_get_bucket(ctx, ht, obj);
|
|
res = sexp_scan_bucket(ctx, sexp_vector_ref(buckets, i), obj, eq_fn);
|
|
if (sexp_truep(res)) {
|
|
res = sexp_car(res);
|
|
} else if (sexp_truep(createp)) {
|
|
sexp_gc_preserve1(ctx, res);
|
|
size = sexp_unbox_fixnum(sexp_hash_table_size(ht));
|
|
res = sexp_cons(ctx, obj, createp);
|
|
sexp_vector_set(buckets, i, sexp_cons(ctx, res, sexp_vector_ref(buckets, i)));
|
|
sexp_hash_table_size(ht) = sexp_make_fixnum(size+1);
|
|
sexp_gc_release1(ctx);
|
|
}
|
|
return res;
|
|
}
|
|
|
|
static sexp sexp_hash_table_delete (sexp ctx, sexp ht, sexp obj) {
|
|
sexp buckets=sexp_hash_table_buckets(ht), eq_fn=sexp_hash_table_eq_fn(ht),
|
|
i=sexp_get_bucket(ctx, ht, obj), p, res;
|
|
res = sexp_scan_bucket(ctx, sexp_vector_ref(buckets, i), obj, eq_fn);
|
|
if (sexp_pairp(res)) {
|
|
if (res == sexp_vector_ref(buckets, i)) {
|
|
sexp_vector_set(buckets, i, sexp_cdr(res));
|
|
} else {
|
|
for (p=sexp_vector_ref(buckets, i); sexp_cdr(p)!=res; p=sexp_cdr(p))
|
|
;
|
|
sexp_cdr(p) = sexp_cdr(res);
|
|
}
|
|
}
|
|
return SEXP_VOID;
|
|
}
|
|
|
|
sexp sexp_init_library (sexp ctx, sexp env) {
|
|
|
|
sexp_define_foreign(ctx, env, "string-hash", 2, sexp_string_hash);
|
|
sexp_define_foreign(ctx, env, "string-ci-hash", 2, sexp_string_ci_hash);
|
|
sexp_define_foreign(ctx, env, "hash", 2, sexp_hash);
|
|
sexp_define_foreign(ctx, env, "hash-by-identity", 2, sexp_hash_by_identity);
|
|
sexp_define_foreign(ctx, env, "hash-table-cell", 3, sexp_hash_table_cell);
|
|
sexp_define_foreign(ctx, env, "hash-table-delete!", 2, sexp_hash_table_delete);
|
|
|
|
return SEXP_VOID;
|
|
}
|
|
|