mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-22 04:21:16 -08:00
Code Issues Projects Releases Packages Wiki Activity
ecl/src/c/hash.d

1273 lines
35 KiB
C
Raw Blame History

/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
/*
* hash.d - hash tables
*
* Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
* Copyright (c) 1990 Giuseppe Attardi
* Copyright (c) 2001 Juan Jose Garcia Ripoll
* Copyright (c) 2017 Daniel Kochmanski
*
* See file 'LICENSE' for the copyright details.
*
*/
/* for ECL_MATHERR_* */
#define ECL_INCLUDE_MATH_H
#include <ecl/ecl.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <ecl/ecl-inl.h>
#include <ecl/internal.h>
#include "newhash.h"
#define SYMBOL_NAME(x) (Null(x)? ECL_NIL_SYMBOL->symbol.name : (x)->symbol.name)
static void ECL_INLINE
assert_type_hash_table(cl_object function, cl_narg narg, cl_object p)
{
unlikely_if (!ECL_HASH_TABLE_P(p))
FEwrong_type_nth_arg(function, narg, p, @[hash-table]);
}
static cl_hashkey
_hash_eql(cl_hashkey h, cl_object x)
{
switch (ecl_t_of(x)) {
case t_bignum:
return hash_string(h, (unsigned char*)ECL_BIGNUM_LIMBS(x),
labs(ECL_BIGNUM_SIZE(x)) *
sizeof(mp_limb_t));
case t_ratio:
h = _hash_eql(h, x->ratio.num);
return _hash_eql(h, x->ratio.den);
case t_singlefloat:
return hash_string(h, (unsigned char*)&ecl_single_float(x), sizeof(ecl_single_float(x)));
case t_doublefloat:
return hash_string(h, (unsigned char*)&ecl_double_float(x), sizeof(ecl_double_float(x)));
#ifdef ECL_LONG_FLOAT
case t_longfloat: {
/* We coerce to double because long double has extra bits
* that give rise to different hash key and are not
* meaningful */
struct { double mantissa; int exponent; int sign; } aux;
aux.mantissa = frexpl(ecl_long_float(x), &aux.exponent);
aux.sign = (ecl_long_float(x) < 0)? -1: 1;
return hash_string(h, (unsigned char*)&aux, sizeof(aux));
}
#endif
case t_complex:
h = _hash_eql(h, x->complex.real);
return _hash_eql(h, x->complex.imag);
case t_character:
return hash_word(h, ECL_CHAR_CODE(x));
#ifdef ECL_SSE2
case t_sse_pack:
return hash_string(h, x->sse.data.b8, 16);
#endif
default:
return hash_word(h, ((cl_hashkey)x >> 2));
}
}
static cl_hashkey
_hash_equal(int depth, cl_hashkey h, cl_object x)
{
switch (ecl_t_of(x)) {
case t_list:
if (Null(x)) {
return _hash_equal(depth, h, ECL_NIL_SYMBOL->symbol.name);
}
if (--depth == 0) {
return h;
} else {
h = _hash_equal(depth, h, ECL_CONS_CAR(x));
return _hash_equal(depth, h, ECL_CONS_CDR(x));
}
case t_symbol:
x = x->symbol.name;
#ifdef ECL_UNICODE
case t_base_string:
return hash_base_string((ecl_base_char *)x->base_string.self,
x->base_string.fillp, h);
case t_string:
return hash_full_string(x->string.self, x->string.fillp, h);
#else
case t_base_string:
return hash_string(h, (ecl_base_char *)x->base_string.self,
x->base_string.fillp);
#endif
case t_pathname:
h = _hash_equal(0, h, x->pathname.directory);
h = _hash_equal(0, h, x->pathname.name);
h = _hash_equal(0, h, x->pathname.type);
h = _hash_equal(0, h, x->pathname.host);
h = _hash_equal(0, h, x->pathname.device);
return _hash_equal(0, h, x->pathname.version);
case t_bitvector:
/* Notice that we may round out some bits. We must do this
* because the fill pointer may be set in the middle of a byte.
* If so, the extra bits _must_ _not_ take part in the hash,
* because otherwise two bit arrays which are EQUAL might
* have different hash keys. */
return hash_string(h, x->vector.self.bc, x->vector.fillp / 8);
case t_random: {
cl_object array = x->random.value;
return hash_string
(h, (unsigned char*)array->vector.self.b8, 4*624);
}
#ifdef ECL_SIGNED_ZERO
case t_singlefloat: {
float f = ecl_single_float(x);
if (f == 0.0) f = 0.0;
return hash_string(h, (unsigned char*)&f, sizeof(f));
}
case t_doublefloat: {
double f = ecl_double_float(x);
if (f == 0.0) f = 0.0;
return hash_string(h, (unsigned char*)&f, sizeof(f));
}
# ifdef ECL_LONG_FLOAT
case t_longfloat: {
/* We coerce to double because long double has extra bits
* that give rise to different hash key and are not
* meaningful */
struct { double mantissa; int exponent; int sign; } aux;
aux.mantissa = frexpl(ecl_long_float(x), &aux.exponent);
aux.sign = (ecl_long_float(x) < 0)? -1: 1;
if (aux.mantissa == 0.0) aux.mantissa = 0.0;
return hash_string(h, (unsigned char*)&aux, sizeof(aux));
}
# endif
case t_complex: {
h = _hash_equal(depth, h, x->complex.real);
return _hash_equal(depth, h, x->complex.imag);
}
#endif
default:
return _hash_eql(h, x);
}
}
static cl_hashkey
_hash_equalp(int depth, cl_hashkey h, cl_object x)
{
cl_index i, len;
switch (ecl_t_of(x)) {
case t_character:
return hash_word(h, ecl_char_upcase(ECL_CHAR_CODE(x)));
case t_list:
if (Null(x)) {
return _hash_equalp(depth, h, ECL_NIL_SYMBOL->symbol.name);
}
if (--depth == 0) {
return h;
} else {
h = _hash_equalp(depth, h, ECL_CONS_CAR(x));
return _hash_equalp(depth, h, ECL_CONS_CDR(x));
}
#ifdef ECL_UNICODE
case t_string:
#endif
case t_base_string:
case t_vector:
case t_bitvector:
len = x->vector.fillp;
goto SCAN;
case t_array:
len = x->vector.dim;
SCAN: if (--depth) {
for (i = 0; i < len; i++) {
h = _hash_equalp(depth, h, ecl_aref_unsafe(x, i));
}
}
return h;
case t_fixnum:
return hash_word(h, ecl_fixnum(x));
case t_singlefloat:
/* FIXME! We should be more precise here! */
return hash_word(h, (cl_index)ecl_single_float(x));
case t_doublefloat:
/* FIXME! We should be more precise here! */
return hash_word(h, (cl_index)ecl_double_float(x));
case t_bignum:
/* FIXME! We should be more precise here! */
return hash_string(h, (unsigned char*)x->big.big_num->_mp_d,
abs(x->big.big_num->_mp_size) *
sizeof(mp_limb_t));
case t_ratio:
h = _hash_equalp(0, h, x->ratio.num);
return _hash_equalp(0, h, x->ratio.den);
case t_complex:
h = _hash_equalp(0, h, x->complex.real);
return _hash_equalp(0, h, x->complex.imag);
case t_instance:
case t_hashtable:
/* FIXME! We should be more precise here! */
return hash_word(h, 42);
default:
return _hash_equal(depth, h, x);
}
}
#define HASH_TABLE_LOOP(hkey,hvalue,h,HASH_TABLE_LOOP_TEST) { \
cl_index hsize = hashtable->hash.size; \
cl_index i = h % hsize, j = hsize, k; \
for (k = 0; k < hsize; i = (i + 1) % hsize, k++) { \
struct ecl_hashtable_entry *e = hashtable->hash.data + i; \
cl_object hkey = e->key, hvalue = e->value; \
if (hkey == OBJNULL) { \
if (hvalue == OBJNULL) { \
if (j == hsize) \
return e; \
else \
return hashtable->hash.data + j; \
} else { \
if (j == hsize) \
j = i; \
else if (j == i) \
return e; \
} \
continue; \
} \
if (HASH_TABLE_LOOP_TEST) return hashtable->hash.data + i; \
} \
return hashtable->hash.data + j; \
}
#if 0
#define HASH_TABLE_SET(h,loop,compute_key,store_key)
#else
#define HASH_TABLE_SET(h,loop,compute_key,store_key) { \
cl_hashkey h = compute_key; \
struct ecl_hashtable_entry *e; \
AGAIN: \
e = loop(h, key, hashtable); \
if (e->key == OBJNULL) { \
cl_index i = hashtable->hash.entries + 1; \
if (i >= hashtable->hash.limit) { \
hashtable = ecl_extend_hashtable(hashtable); \
goto AGAIN; \
} \
hashtable->hash.entries = i; \
e->key = store_key; \
} \
e->value = value; \
return hashtable; \
}
#endif
/*
* EQ HASHTABLES
*/
#if 0
#define _hash_eq(k) ((cl_hashkey)(k) ^ ((cl_hashkey)(k) >> 16))
#else
#define _hash_eq(k) ((cl_hashkey)(k) >> 2)
#endif
static struct ecl_hashtable_entry *
_ecl_hash_loop_eq(cl_hashkey h, cl_object key, cl_object hashtable)
{
HASH_TABLE_LOOP(hkey, hvalue, h, key == hkey);
}
static cl_object
_ecl_gethash_eq(cl_object key, cl_object hashtable, cl_object def)
{
cl_hashkey h = _hash_eq(key);
struct ecl_hashtable_entry *e = _ecl_hash_loop_eq(h, key, hashtable);
return (e->key == OBJNULL)? def : e->value;
}
static bool
_ecl_remhash_eq(cl_object key, cl_object hashtable)
{
cl_hashkey h = _hash_eq(key);
struct ecl_hashtable_entry *e = _ecl_hash_loop_eq(h, key, hashtable);
if (e->key == OBJNULL) {
return 0;
} else {
e->key = OBJNULL;
e->value = ECL_NIL;
hashtable->hash.entries--;
return 1;
}
}
static cl_object
_ecl_sethash_eq(cl_object key, cl_object hashtable, cl_object value)
{
HASH_TABLE_SET(h, _ecl_hash_loop_eq, _hash_eq(key), key);
}
/*
* EQL HASHTABLES
*/
static struct ecl_hashtable_entry *
_ecl_hash_loop_eql(cl_hashkey h, cl_object key, cl_object hashtable)
{
HASH_TABLE_LOOP(hkey, hvalue, h, ecl_eql(key, hkey));
}
static cl_object
_ecl_gethash_eql(cl_object key, cl_object hashtable, cl_object def)
{
cl_hashkey h = _hash_eql(0, key);
struct ecl_hashtable_entry *e = _ecl_hash_loop_eql(h, key, hashtable);
return (e->key == OBJNULL)? def : e->value;
}
static cl_object
_ecl_sethash_eql(cl_object key, cl_object hashtable, cl_object value)
{
HASH_TABLE_SET(h, _ecl_hash_loop_eql, _hash_eql(0, key), key);
}
static bool
_ecl_remhash_eql(cl_object key, cl_object hashtable)
{
cl_hashkey h = _hash_eql(0, key);
struct ecl_hashtable_entry *e = _ecl_hash_loop_eql(h, key, hashtable);
if (e->key == OBJNULL) {
return 0;
} else {
e->key = OBJNULL;
e->value = ECL_NIL;
hashtable->hash.entries--;
return 1;
}
}
/*
* EQUAL HASHTABLES
*/
static struct ecl_hashtable_entry *
_ecl_hash_loop_equal(cl_hashkey h, cl_object key, cl_object hashtable)
{
HASH_TABLE_LOOP(hkey, hvalue, h, ecl_equal(key, hkey));
}
static cl_object
_ecl_gethash_equal(cl_object key, cl_object hashtable, cl_object def)
{
cl_hashkey h = _hash_equal(3, 0, key);
struct ecl_hashtable_entry *e = _ecl_hash_loop_equal(h, key, hashtable);
return (e->key == OBJNULL)? def : e->value;
}
static cl_object
_ecl_sethash_equal(cl_object key, cl_object hashtable, cl_object value)
{
HASH_TABLE_SET(h, _ecl_hash_loop_equal, _hash_equal(3, 0, key), key);
}
static bool
_ecl_remhash_equal(cl_object key, cl_object hashtable)
{
cl_hashkey h = _hash_equal(3, 0, key);
struct ecl_hashtable_entry *e = _ecl_hash_loop_equal(h, key, hashtable);
if (e->key == OBJNULL) {
return 0;
} else {
e->key = OBJNULL;
e->value = ECL_NIL;
hashtable->hash.entries--;
return 1;
}
}
/*
* EQUALP HASHTABLES
*/
static struct ecl_hashtable_entry *
_ecl_hash_loop_equalp(cl_hashkey h, cl_object key, cl_object hashtable)
{
HASH_TABLE_LOOP(hkey, hvalue, h, ecl_equalp(key, hkey));
}
static cl_object
_ecl_gethash_equalp(cl_object key, cl_object hashtable, cl_object def)
{
cl_hashkey h = _hash_equalp(3, 0, key);
struct ecl_hashtable_entry *e = _ecl_hash_loop_equalp(h, key, hashtable);
return (e->key == OBJNULL)? def : e->value;
}
static cl_object
_ecl_sethash_equalp(cl_object key, cl_object hashtable, cl_object value)
{
HASH_TABLE_SET(h, _ecl_hash_loop_equalp, _hash_equalp(3, 0, key), key);
}
static bool
_ecl_remhash_equalp(cl_object key, cl_object hashtable)
{
cl_hashkey h = _hash_equalp(3, 0, key);
struct ecl_hashtable_entry *e = _ecl_hash_loop_equalp(h, key, hashtable);
if (e->key == OBJNULL) {
return 0;
} else {
e->key = OBJNULL;
e->value = ECL_NIL;
hashtable->hash.entries--;
return 1;
}
}
/*
* PACKAGE HASHTABLES
*/
static struct ecl_hashtable_entry *
_ecl_hash_loop_pack(cl_hashkey h, cl_object key, cl_object hashtable)
{
cl_object ho = ecl_make_fixnum(h & 0xFFFFFFF);
HASH_TABLE_LOOP(hkey, hvalue, h, (ho==hkey) && ecl_string_eq(key,SYMBOL_NAME(hvalue)));
}
static cl_object
_ecl_gethash_pack(cl_object key, cl_object hashtable, cl_object def)
{
cl_hashkey h = _hash_equal(3, 0, key);
struct ecl_hashtable_entry *e = _ecl_hash_loop_pack(h, key, hashtable);
return (e->key == OBJNULL)? def : e->value;
}
static cl_object
_ecl_sethash_pack(cl_object key, cl_object hashtable, cl_object value)
{
HASH_TABLE_SET(h, _ecl_hash_loop_pack, _hash_equal(3, 0, key), ecl_make_fixnum(h & 0xFFFFFFF));
}
static bool
_ecl_remhash_pack(cl_object key, cl_object hashtable)
{
cl_hashkey h = _hash_equal(3, 0, key);
struct ecl_hashtable_entry *e = _ecl_hash_loop_pack(h, key, hashtable);
if (e->key == OBJNULL) {
return 0;
} else {
e->key = OBJNULL;
e->value = ECL_NIL;
hashtable->hash.entries--;
return 1;
}
}
/*
* WEAK HASH TABLES
*/
#ifndef ECL_WEAK_HASH
#define copy_entry(e,h) *(e)
#endif
#ifdef ECL_WEAK_HASH
static cl_hashkey
_ecl_hash_key(cl_object h, cl_object o) {
switch (h->hash.test) {
case ecl_htt_eq: return _hash_eq(o);
case ecl_htt_eql: return _hash_eql(0, o);
case ecl_htt_equal: return _hash_equal(3, 0, o);
case ecl_htt_equalp:
default: return _hash_equalp(3, 0, o);
}
}
static void *
normalize_weak_key_entry(struct ecl_hashtable_entry *e) {
return (void*)(e->key = e->key->weak.value);
}
static void *
normalize_weak_value_entry(struct ecl_hashtable_entry *e) {
return (void*)(e->value = e->value->weak.value);
}
static void *
normalize_weak_key_and_value_entry(struct ecl_hashtable_entry *e) {
if ((e->key = e->key->weak.value) && (e->value = e->value->weak.value))
return (void*)e;
else
return 0;
}
static void *
normalize_weak_key_or_value_entry(struct ecl_hashtable_entry *e) {
if ((e->key = e->key->weak.value) || (e->value = e->value->weak.value))
return (void*)e;
else
return 0;
}
static struct ecl_hashtable_entry
copy_entry(struct ecl_hashtable_entry *e, cl_object h)
{
if (e->key == OBJNULL) {
return *e;
} else {
struct ecl_hashtable_entry output = *e;
switch (h->hash.weak) {
case ecl_htt_weak_key:
if (GC_call_with_alloc_lock((GC_fn_type)normalize_weak_key_entry,
&output)) {
return output;
}
break;
case ecl_htt_weak_value:
if (GC_call_with_alloc_lock((GC_fn_type)normalize_weak_value_entry,
&output)) {
return output;
}
break;
case ecl_htt_weak_key_and_value:
if (GC_call_with_alloc_lock((GC_fn_type)normalize_weak_key_and_value_entry,
&output)) {
return output;
}
break;
case ecl_htt_weak_key_or_value:
if (GC_call_with_alloc_lock((GC_fn_type)normalize_weak_key_or_value_entry,
&output)) {
return output;
}
break;
case ecl_htt_not_weak:
default:
return output;
}
h->hash.entries--;
output.key = OBJNULL;
output.value = ECL_NIL;
return *e = output;
}
}
static struct ecl_hashtable_entry *
_ecl_weak_hash_loop(cl_hashkey h, cl_object key, cl_object hashtable,
struct ecl_hashtable_entry *aux)
{
cl_index hsize = hashtable->hash.size;
cl_index i = h % hsize, j = hsize, k;
for (k = 0; k < hsize; i = (i + 1) % hsize, k++) {
struct ecl_hashtable_entry *p = hashtable->hash.data + i;
struct ecl_hashtable_entry e = *aux = copy_entry(p, hashtable);
if (e.key == OBJNULL) {
if (e.value == OBJNULL) {
if (j == hsize) {
return p;
} else {
return hashtable->hash.data + j;
}
} else {
if (j == hsize) {
j = i;
} else if (j == i) {
return p;
}
}
continue;
}
switch (hashtable->hash.test) {
case ecl_htt_eq:
if (e.key == key) return p;
case ecl_htt_eql:
if (ecl_eql(e.key, key)) return p;
case ecl_htt_equal:
if (ecl_equal(e.key, key)) return p;
case ecl_htt_equalp:
if (ecl_equalp(e.key, key)) return p;
}
}
return hashtable->hash.data + j;
}
static cl_object
_ecl_gethash_weak(cl_object key, cl_object hashtable, cl_object def)
{
cl_hashkey h = _ecl_hash_key(hashtable, key);
struct ecl_hashtable_entry aux[1];
_ecl_weak_hash_loop(h, key, hashtable, aux);
if (aux->key != OBJNULL) {
return aux->value;
} else {
return def;
}
}
static cl_object
_ecl_sethash_weak(cl_object key, cl_object hashtable, cl_object value)
{
cl_hashkey h = _ecl_hash_key(hashtable, key);
struct ecl_hashtable_entry aux[1];
struct ecl_hashtable_entry *e;
AGAIN:
e = _ecl_weak_hash_loop(h, key, hashtable, aux);
if (aux->key == OBJNULL) {
cl_index i = hashtable->hash.entries + 1;
if (i >= hashtable->hash.limit) {
hashtable = ecl_extend_hashtable(hashtable);
goto AGAIN;
}
hashtable->hash.entries = i;
switch (hashtable->hash.weak) {
case ecl_htt_weak_key:
key = si_make_weak_pointer(key);
break;
case ecl_htt_weak_value:
value = si_make_weak_pointer(value);
break;
case ecl_htt_weak_key_and_value:
case ecl_htt_weak_key_or_value:
default:
key = si_make_weak_pointer(key);
value = si_make_weak_pointer(value);
break;
}
e->key = key;
}
e->value = value;
return hashtable;
}
static bool
_ecl_remhash_weak(cl_object key, cl_object hashtable)
{
cl_hashkey h = _ecl_hash_key(hashtable, key);
struct ecl_hashtable_entry aux[1];
struct ecl_hashtable_entry *e =
_ecl_weak_hash_loop(h, key, hashtable, aux);
if (aux->key != OBJNULL) {
hashtable->hash.entries--;
e->key = OBJNULL;
e->value = ECL_NIL;
return 1;
} else {
return 0;
}
}
#endif
/* SYNCHRONIZED HASH TABLES */
#ifdef ECL_THREADS
static cl_object
_ecl_sethash_sync(cl_object key, cl_object hashtable, cl_object value)
{
cl_object output = ECL_NIL;
cl_object sync_lock = hashtable->hash.sync_lock;
mp_get_rwlock_write_wait(sync_lock);
output = hashtable->hash.set_unsafe(key, hashtable, value);
mp_giveup_rwlock_write(sync_lock);
return output;
}
static cl_object
_ecl_gethash_sync(cl_object key, cl_object hashtable, cl_object def)
{
cl_object output = ECL_NIL;
cl_object sync_lock = hashtable->hash.sync_lock;
mp_get_rwlock_read_wait(sync_lock);
output = hashtable->hash.get_unsafe(key, hashtable, def);
mp_giveup_rwlock_read(sync_lock);
return output;
}
static bool
_ecl_remhash_sync(cl_object key, cl_object hashtable)
{
bool output = 0;
cl_object sync_lock = hashtable->hash.sync_lock;
mp_get_rwlock_write_wait(sync_lock);
output = hashtable->hash.rem_unsafe(key, hashtable);
mp_giveup_rwlock_write(sync_lock);
return output;
}
#endif
/*
* HIGHER LEVEL INTERFACE
*/
cl_object
ecl_gethash(cl_object key, cl_object hashtable)
{
assert_type_hash_table(@[gethash], 2, hashtable);
return hashtable->hash.get(key, hashtable, OBJNULL);
}
cl_object
ecl_gethash_safe(cl_object key, cl_object hashtable, cl_object def)
{
assert_type_hash_table(@[gethash], 2, hashtable);
return hashtable->hash.get(key, hashtable, def);
}
cl_object
_ecl_sethash(cl_object key, cl_object hashtable, cl_object value)
{
return hashtable->hash.set(key, hashtable, value);
}
cl_object
ecl_sethash(cl_object key, cl_object hashtable, cl_object value)
{
assert_type_hash_table(@[si::hash-set], 2, hashtable);
hashtable = hashtable->hash.set(key, hashtable, value);
return hashtable;
}
cl_object
ecl_extend_hashtable(cl_object hashtable)
{
cl_object old, new;
cl_index old_size, new_size, i;
cl_object new_size_obj;
assert_type_hash_table(@[si::hash-set], 2, hashtable);
old_size = hashtable->hash.size;
/* We do the computation with lisp datatypes, just in case the sizes contain
* weird numbers */
if (ECL_FIXNUMP(hashtable->hash.rehash_size)) {
new_size_obj = ecl_plus(hashtable->hash.rehash_size,
ecl_make_fixnum(old_size));
} else {
new_size_obj = ecl_times(hashtable->hash.rehash_size,
ecl_make_fixnum(old_size));
new_size_obj = ecl_ceiling1(new_size_obj);
}
if (!ECL_FIXNUMP(new_size_obj)) {
/* New size is too large */
new_size = old_size * 2;
} else {
new_size = ecl_fixnum(new_size_obj);
}
if (hashtable->hash.test == ecl_htt_pack) {
new = ecl_alloc_object(t_hashtable);
new->hash = hashtable->hash;
old = hashtable;
} else {
old = ecl_alloc_object(t_hashtable);
old->hash = hashtable->hash;
new = hashtable;
}
new->hash.data = NULL; /* for GC sake */
new->hash.entries = 0;
new->hash.size = new_size;
new->hash.limit = new->hash.size * new->hash.factor;
new->hash.data = (struct ecl_hashtable_entry *)
ecl_alloc(new_size * sizeof(struct ecl_hashtable_entry));
for (i = 0; i < new_size; i++) {
new->hash.data[i].key = OBJNULL;
new->hash.data[i].value = OBJNULL;
}
for (i = 0; i < old_size; i++) {
struct ecl_hashtable_entry e =
copy_entry(old->hash.data + i, old);
if (e.key != OBJNULL) {
new = new->hash.set(new->hash.test == ecl_htt_pack?
SYMBOL_NAME(e.value) : e.key,
new, e.value);
}
}
return new;
}
@(defun make_hash_table (&key (test @'eql')
(weakness ECL_NIL)
(synchronized ECL_NIL)
(size ecl_make_fixnum(1024))
(rehash_size cl_core.rehash_size)
(rehash_threshold cl_core.rehash_threshold))
@ {
cl_object hash = cl__make_hash_table(test, size, rehash_size, rehash_threshold);
#ifdef ECL_WEAK_HASH
if (!Null(weakness)) {
if (weakness == @':key') {
hash->hash.weak = ecl_htt_weak_key;
} else if (weakness == @':value') {
hash->hash.weak = ecl_htt_weak_value;
} else if (weakness == @':key-and-value') {
hash->hash.weak = ecl_htt_weak_key_and_value;
} else if (weakness == @':key-or-value') {
hash->hash.weak = ecl_htt_weak_key_or_value;
} else {
FEwrong_type_key_arg(@[make-hash-table],
@[:weakness],
cl_list(5, @'member',
ECL_NIL, @':key', @':value',
@':key-and-value', @':key-or-value'),
weakness);
}
hash->hash.get = _ecl_gethash_weak;
hash->hash.set = _ecl_sethash_weak;
hash->hash.rem = _ecl_remhash_weak;
}
#endif
if (!Null(synchronized)) {
#ifdef ECL_THREADS
hash->hash.sync_lock = ecl_make_rwlock(ECL_NIL);
hash->hash.get_unsafe = hash->hash.get;
hash->hash.set_unsafe = hash->hash.set;
hash->hash.rem_unsafe = hash->hash.rem;
hash->hash.get = _ecl_gethash_sync;
hash->hash.set = _ecl_sethash_sync;
hash->hash.rem = _ecl_remhash_sync;
#else
/* for hash-table-synchronized-p predicate */
hash->hash.sync_lock = ECL_T;
#endif
}
@(return hash);
} @)
static void
do_clrhash(cl_object ht)
{
/*
* Fill a hash with null pointers and ensure it does not have
* any entry. We separate this routine because it is needed
* both by clrhash and hash table initialization.
*/
cl_index i;
ht->hash.entries = 0;
for(i = 0; i < ht->hash.size; i++) {
ht->hash.data[i].key = OBJNULL;
ht->hash.data[i].value = OBJNULL;
}
}
ecl_def_ct_single_float(min_threshold, 0.1, static, const);
cl_object
cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size,
cl_object rehash_threshold)
{
int htt;
cl_index hsize;
cl_object h;
cl_object (*get)(cl_object, cl_object, cl_object);
cl_object (*set)(cl_object, cl_object, cl_object);
bool (*rem)(cl_object, cl_object);
/*
* Argument checking
*/
if (test == @'eq' || test == ECL_SYM_FUN(@'eq')) {
htt = ecl_htt_eq;
get = _ecl_gethash_eq;
set = _ecl_sethash_eq;
rem = _ecl_remhash_eq;
} else if (test == @'eql' || test == ECL_SYM_FUN(@'eql')) {
htt = ecl_htt_eql;
get = _ecl_gethash_eql;
set = _ecl_sethash_eql;
rem = _ecl_remhash_eql;
} else if (test == @'equal' || test == ECL_SYM_FUN(@'equal')) {
htt = ecl_htt_equal;
get = _ecl_gethash_equal;
set = _ecl_sethash_equal;
rem = _ecl_remhash_equal;
} else if (test == @'equalp' || test == ECL_SYM_FUN(@'equalp')) {
htt = ecl_htt_equalp;
get = _ecl_gethash_equalp;
set = _ecl_sethash_equalp;
rem = _ecl_remhash_equalp;
} else if (test == @'package') {
htt = ecl_htt_pack;
get = _ecl_gethash_pack;
set = _ecl_sethash_pack;
rem = _ecl_remhash_pack;
} else {
FEerror("~S is an illegal hash-table test function.",
1, test);
}
if (ecl_unlikely(!ECL_FIXNUMP(size) ||
ecl_fixnum_minusp(size) ||
ecl_fixnum_geq(size,ecl_make_fixnum(ECL_ARRAY_TOTAL_LIMIT)))) {
FEwrong_type_key_arg(@[make-hash-table], @[:size], size,
ecl_make_integer_type(ecl_make_fixnum(0),
ecl_make_fixnum(ECL_ARRAY_TOTAL_LIMIT)));
}
hsize = ecl_fixnum(size);
if (hsize < 16) {
hsize = 16;
}
AGAIN:
if (ecl_minusp(rehash_size)) {
ERROR1:
rehash_size =
ecl_type_error(@'make-hash-table',"rehash-size",
rehash_size,
ecl_read_from_cstring("(OR (INTEGER 1 *) (FLOAT 0 (1)))"));
goto AGAIN;
}
if (floatp(rehash_size)) {
if (ecl_number_compare(rehash_size, ecl_make_fixnum(1)) < 0 ||
ecl_minusp(rehash_size)) {
goto ERROR1;
}
rehash_size = ecl_make_double_float(ecl_to_double(rehash_size));
} else if (!ECL_FIXNUMP(rehash_size)) {
goto ERROR1;
}
while (!ecl_numberp(rehash_threshold) ||
ecl_minusp(rehash_threshold) ||
ecl_number_compare(rehash_threshold, ecl_make_fixnum(1)) > 0)
{
rehash_threshold =
ecl_type_error(@'make-hash-table',"rehash-threshold",
rehash_threshold,
ecl_read_from_cstring("(REAL 0 1)"));
}
/*
* Build actual hash.
*/
h = ecl_alloc_object(t_hashtable);
h->hash.test = htt;
h->hash.weak = ecl_htt_not_weak;
h->hash.get = get;
h->hash.set = set;
h->hash.rem = rem;
h->hash.size = hsize;
h->hash.entries = 0;
h->hash.rehash_size = rehash_size;
h->hash.threshold = rehash_threshold;
rehash_threshold = cl_max(2, min_threshold, rehash_threshold);
h->hash.factor = ecl_to_double(rehash_threshold);
h->hash.limit = h->hash.size * h->hash.factor;
h->hash.data = NULL; /* for GC sake */
h->hash.data = (struct ecl_hashtable_entry *)
ecl_alloc(hsize * sizeof(struct ecl_hashtable_entry));
do_clrhash(h);
return h;
}
#ifdef ECL_EXTERNALIZABLE
void
ecl_reconstruct_serialized_hashtable(cl_object h) {
switch (h->hash.test) {
case ecl_htt_eq:
h->hash.get = _ecl_gethash_eq;
h->hash.set = _ecl_sethash_eq;
h->hash.rem = _ecl_remhash_eq;
break;
case ecl_htt_eql:
h->hash.get = _ecl_gethash_eql;
h->hash.set = _ecl_sethash_eql;
h->hash.rem = _ecl_remhash_eql;
break;
case ecl_htt_equal:
h->hash.get = _ecl_gethash_equal;
h->hash.set = _ecl_sethash_equal;
h->hash.rem = _ecl_remhash_equal;
break;
case ecl_htt_equalp:
h->hash.get = _ecl_gethash_equalp;
h->hash.set = _ecl_sethash_equalp;
h->hash.rem = _ecl_remhash_equalp;
break;
case ecl_htt_pack:
h->hash.get = _ecl_gethash_pack;
h->hash.set = _ecl_sethash_pack;
h->hash.rem = _ecl_remhash_pack;
break;
}
if (h->hash.weak != ecl_htt_not_weak) {
h->hash.get = _ecl_gethash_weak;
h->hash.set = _ecl_sethash_weak;
h->hash.rem = _ecl_remhash_weak;
}
if (h->hash.sync_lock != OBJNULL
&& (ecl_t_of(h->hash.sync_lock) == t_lock
|| ecl_t_of(h->hash.sync_lock) == t_rwlock)) {
h->hash.get_unsafe = h->hash.get;
h->hash.set_unsafe = h->hash.set;
h->hash.rem_unsafe = h->hash.rem;
h->hash.get = _ecl_gethash_sync;
h->hash.set = _ecl_sethash_sync;
h->hash.rem = _ecl_remhash_sync;
}
}
#endif
cl_object
cl_hash_table_p(cl_object ht)
{
@(return (ECL_HASH_TABLE_P(ht) ? ECL_T : ECL_NIL));
}
cl_object
si_hash_table_weakness(cl_object ht)
{
cl_object output = ECL_NIL;
#ifdef ECL_WEAK_HASH
switch (ht->hash.weak) {
case ecl_htt_weak_key: output = @':key'; break;
case ecl_htt_weak_value: output = @':value'; break;
case ecl_htt_weak_key_and_value: output = @':key-and-value'; break;
case ecl_htt_weak_key_or_value: output = @':key-or-value'; break;
case ecl_htt_not_weak: default: output = ECL_NIL; break;
}
#endif
@(return output);
}
cl_object
si_hash_table_synchronized_p(cl_object ht)
{
if (!Null(ht->hash.sync_lock)) {
return ECL_T;
}
return ECL_NIL;
}
@(defun gethash (key ht &optional (no_value ECL_NIL))
@
{
assert_type_hash_table(@[gethash], 2, ht);
{
cl_object v = ht->hash.get(key, ht, OBJNULL);
if (v != OBJNULL) {
@(return v ECL_T);
} else {
@(return no_value ECL_NIL);
}
}
}
@)
cl_object
si_hash_set(cl_object key, cl_object ht, cl_object val)
{
/* INV: ecl_sethash() checks the type of hashtable */
ecl_sethash(key, ht, val);
@(return val);
}
bool
ecl_remhash(cl_object key, cl_object hashtable)
{
assert_type_hash_table(@[remhash], 2, hashtable);
return hashtable->hash.rem(key, hashtable);
}
cl_object
cl_remhash(cl_object key, cl_object ht)
{
/* INV: _ecl_remhash() checks the type of hashtable */
@(return (ecl_remhash(key, ht)? ECL_T : ECL_NIL));
}
cl_object
cl_clrhash(cl_object ht)
{
assert_type_hash_table(@[clrhash], 1, ht);
if (ht->hash.entries) {
do_clrhash(ht);
}
@(return ht);
}
cl_object
cl_hash_table_test(cl_object ht)
{
cl_object output;
assert_type_hash_table(@[hash-table-test], 1, ht);
switch(ht->hash.test) {
case ecl_htt_eq: output = @'eq'; break;
case ecl_htt_eql: output = @'eql'; break;
case ecl_htt_equal: output = @'equal'; break;
case ecl_htt_equalp: output = @'equalp'; break;
case ecl_htt_pack:
default: output = @'equal';
}
@(return output);
}
cl_object
cl_hash_table_size(cl_object ht)
{
assert_type_hash_table(@[hash-table-size], 1, ht);
@(return ecl_make_fixnum(ht->hash.size));
}
cl_index
ecl_hash_table_count(cl_object ht)
{
if (ht->hash.weak == ecl_htt_not_weak) {
return ht->hash.entries;
} else if (ht->hash.size) {
cl_index i, j;
for (i = j = 0; i < ht->hash.size; i++) {
struct ecl_hashtable_entry output =
copy_entry(ht->hash.data + i, ht);
if (output.key != OBJNULL) {
if (++j == ht->hash.size)
break;
}
}
return ht->hash.entries = j;
} else {
return 0;
}
}
cl_object
cl_hash_table_count(cl_object ht)
{
assert_type_hash_table(@[hash-table-count], 1, ht);
@(return (ecl_make_fixnum(ecl_hash_table_count(ht))));
}
static cl_object
si_hash_table_iterate(cl_narg narg)
{
const cl_env_ptr the_env = ecl_process_env();
cl_object env = the_env->function->cclosure.env;
cl_object index = CAR(env);
cl_object ht = CADR(env);
cl_fixnum i;
if (!Null(index)) {
i = ecl_fixnum(index);
if (i < 0)
i = -1;
for (; ++i < ht->hash.size; ) {
struct ecl_hashtable_entry e =
copy_entry(ht->hash.data + i, ht);
if (e.key != OBJNULL) {
cl_object ndx = ecl_make_fixnum(i);
ECL_RPLACA(env, ndx);
@(return ndx e.key e.value);
}
}
ECL_RPLACA(env, ECL_NIL);
}
@(return ECL_NIL);
}
cl_object
si_hash_table_iterator(cl_object ht)
{
assert_type_hash_table(@[si::hash-table-iterator], 1, ht);
@(return ecl_make_cclosure_va((cl_objectfn)si_hash_table_iterate,
cl_list(2, ecl_make_fixnum(-1), ht),
@'si::hash-table-iterator'));
}
cl_object
cl_hash_table_rehash_size(cl_object ht)
{
assert_type_hash_table(@[hash-table-rehash-size], 1, ht);
@(return ht->hash.rehash_size);
}
cl_object
cl_hash_table_rehash_threshold(cl_object ht)
{
assert_type_hash_table(@[hash-table-rehash-threshold], 1, ht);
@(return ht->hash.threshold);
}
cl_object
cl_sxhash(cl_object key)
{
cl_index output = _hash_equal(3, 0, key);
const cl_index mask = ((cl_index)1 << (ECL_FIXNUM_BITS - 3)) - 1;
@(return ecl_make_fixnum(output & mask));
}
@(defun si::hash-eql (&rest args)
cl_index h;
@
for (h = 0; narg; narg--) {
cl_object o = ecl_va_arg(args);
h = _hash_eql(h, o);
}
@(return ecl_make_fixnum(h));
@)
@(defun si::hash-equal (&rest args)
cl_index h;
@
for (h = 0; narg; narg--) {
cl_object o = ecl_va_arg(args);
h = _hash_equal(3, h, o);
}
@(return ecl_make_fixnum(h));
@)
@(defun si::hash-equalp (&rest args)
cl_index h;
@
for (h = 0; narg; narg--) {
cl_object o = ecl_va_arg(args);
h = _hash_equalp(3, h, o);
}
@(return ecl_make_fixnum(h));
@)
cl_object
cl_maphash(cl_object fun, cl_object ht)
{
cl_index i;
assert_type_hash_table(@[maphash], 2, ht);
for (i = 0; i < ht->hash.size; i++) {
struct ecl_hashtable_entry e = ht->hash.data[i];
if(e.key != OBJNULL)
funcall(3, fun, e.key, e.value);
}
@(return ECL_NIL);
}
cl_object
si_hash_table_content(cl_object ht)
{
cl_index i;
cl_object output = ECL_NIL;
assert_type_hash_table(@[ext::hash-table-content], 2, ht);
for (i = 0; i < ht->hash.size; i++) {
struct ecl_hashtable_entry e = ht->hash.data[i];
if (e.key != OBJNULL)
output = ecl_cons(ecl_cons(e.key, e.value), output);
}
@(return output);
}
cl_object
si_hash_table_fill(cl_object ht, cl_object values)
{
assert_type_hash_table(@[ext::hash-table-fill], 2, ht);
while (!Null(values)) {
cl_object pair = ecl_car(values);
cl_object key = ecl_car(pair);
cl_object value = ECL_CONS_CDR(pair);
values = ECL_CONS_CDR(values);
ecl_sethash(key, ht, value);
}
@(return ht);
}
cl_object
si_copy_hash_table(cl_object orig)
{
cl_object hash;
hash = cl__make_hash_table(cl_hash_table_test(orig),
cl_hash_table_size(orig),
cl_hash_table_rehash_size(orig),
cl_hash_table_rehash_threshold(orig));
memcpy(hash->hash.data, orig->hash.data,
orig->hash.size * sizeof(*orig->hash.data));
hash->hash.entries = orig->hash.entries;
@(return hash);
}
Reference in a new issue View git blame Copy permalink