This is elhash.c in view mode; [Download] [Up]
/*
This file is part of XEmacs.
XEmacs is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 2, or (at your option) any
later version.
XEmacs is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with XEmacs; see the file COPYING. If not, write to the Free
Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
/* Synched up with: Not in FSF. */
#include <config.h>
#include "lisp.h"
#include "hash.h"
#include "elhash.h"
#include "bytecode.h"
Lisp_Object Qhashtablep;
#define LISP_OBJECTS_PER_HENTRY (sizeof (hentry) / sizeof (Lisp_Object))/* 2 */
struct hashtable_struct
{
struct lcrecord_header header;
unsigned int fullness;
unsigned long (*hash_function) (CONST void *);
int (*test_function) (CONST void *, CONST void *);
Lisp_Object zero_entry;
Lisp_Object harray;
enum hashtable_type type; /* whether and how this hashtable is weak */
Lisp_Object next_weak; /* Used to chain together all of the weak
hashtables. Don't mark through this. */
};
static Lisp_Object Vweak_hash_tables;
DECLARE_LRECORD (hashtable, struct hashtable_struct);
#define XHASHTABLE(x) XRECORD (x, hashtable, struct hashtable_struct)
#define XSETHASHTABLE(x, p) XSETRECORD (x, p, hashtable)
#define HASHTABLEP(x) RECORDP (x, hashtable)
#define CHECK_HASHTABLE(x, i) CHECK_RECORD (x, hashtable)
static Lisp_Object mark_hashtable (Lisp_Object, void (*) (Lisp_Object));
static void print_hashtable (Lisp_Object, Lisp_Object, int);
DEFINE_LRECORD_IMPLEMENTATION ("hashtable", hashtable,
mark_hashtable, print_hashtable, 0, 0, 0,
struct hashtable_struct);
static Lisp_Object
mark_hashtable (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
struct hashtable_struct *table = XHASHTABLE (obj);
if (table->type != HASHTABLE_NONWEAK)
{
/* If the table is weak, we don't want to mark the keys and values
(we scan over them after everything else has been marked,
and mark or remove them as necessary). Note that we will mark
the table->harray itself at the same time; it's hard to mark
that here without also marking its contents. */
return Qnil;
}
((markobj) (table->zero_entry));
return (table->harray);
}
static void
print_hashtable (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
struct hashtable_struct *table = XHASHTABLE (obj);
char buf[200];
if (print_readably)
error ("printing unreadable object #<hashtable 0x%x>",
table->header.uid);
sprintf (buf, GETTEXT ("#<%shashtable %d/%ld 0x%x>"),
(table->type == HASHTABLE_WEAK ? "weak " :
table->type == HASHTABLE_KEY_WEAK ? "key-weak " :
table->type == HASHTABLE_VALUE_WEAK ? "value-weak " :
""),
table->fullness,
(vector_length (XVECTOR (table->harray)) / LISP_OBJECTS_PER_HENTRY),
table->header.uid);
write_c_string (buf, printcharfun);
}
static void
ht_copy_to_c (struct hashtable_struct *ht,
c_hashtable c_table)
{
int len;
c_table->harray = (void *) vector_data (XVECTOR (ht->harray));
c_table->zero_set = (!EQ (ht->zero_entry, Qunbound));
c_table->zero_entry = LISP_TO_VOID (ht->zero_entry);
len = vector_length (XVECTOR (ht->harray));
if (len < 0)
{
/* #### if alloc.c mark_object() changes, this must change too. */
/* barf gag retch. When a vector is marked, its len is
made less than 0. In the prune_weak_hashtables() stage,
we are called on vectors that are like this, and we must
be able to deal. */
assert (gc_in_progress);
len = -1 - len;
}
c_table->size = len/LISP_OBJECTS_PER_HENTRY;
c_table->fullness = ht->fullness;
c_table->hash_function = ht->hash_function;
c_table->test_function = ht->test_function;
XSETHASHTABLE (c_table->elisp_table, ht);
}
static void
ht_copy_from_c (c_hashtable c_table,
struct hashtable_struct *ht)
{
struct Lisp_Vector dummy;
/* C is truly hateful */
void *vec_addr
= ((char *) c_table->harray
- ((char *) &(dummy.contents) - (char *) &dummy));
XSETVECTOR (ht->harray, vec_addr);
if (c_table->zero_set)
VOID_TO_LISP (ht->zero_entry, c_table->zero_entry);
else
ht->zero_entry = Qunbound;
ht->fullness = c_table->fullness;
}
static struct hashtable_struct *
new_hashtable (void)
{
struct hashtable_struct *table
= alloc_lcrecord (sizeof (struct hashtable_struct), lrecord_hashtable);
table->harray = Qnil;
table->zero_entry = Qunbound;
table->fullness = 0;
table->hash_function = 0;
table->test_function = 0;
return (table);
}
char *
elisp_hvector_malloc (unsigned int bytes, Lisp_Object table)
{
Lisp_Object new_vector;
struct hashtable_struct *ht;
ht = XHASHTABLE (table);
assert (bytes > vector_length (XVECTOR (ht->harray)) * sizeof (Lisp_Object));
new_vector = make_vector ((bytes / sizeof (Lisp_Object)), Qzero);
return ((char *) (vector_data (XVECTOR (new_vector))));
}
void
elisp_hvector_free (void *ptr, Lisp_Object table)
{
struct hashtable_struct *ht = XHASHTABLE (table);
#if defined (USE_ASSERTIONS) || defined (DEBUG_XEMACS)
Lisp_Object current_vector = ht->harray;
#endif
assert (((void *) vector_data (XVECTOR (current_vector))) == ptr);
ht->harray = Qnil; /* Let GC do its job */
return;
}
DEFUN ("hashtablep", Fhashtablep, Shashtablep, 1, 1, 0,
"Return t if OBJ is a hashtable, else nil.")
(obj)
Lisp_Object obj;
{
return ((HASHTABLEP (obj)) ? Qt : Qnil);
}
/* C code can specify test and hash function for hash tables of lisp objects
(including weak tables) but lisp code can only create EQ tables because we
don't have a general lisp object hash function.
*/
Lisp_Object
make_lisp_hashtable (int size,
int (*test_function) (CONST void*, CONST void*),
unsigned long (*hash_function) (CONST void*),
enum hashtable_type type)
{
Lisp_Object result;
struct hashtable_struct *table = new_hashtable ();
table->harray = make_vector ((compute_harray_size (size)
* LISP_OBJECTS_PER_HENTRY),
Qzero);
table->test_function = test_function;
table->hash_function = hash_function;
table->type = type;
XSETHASHTABLE (result, table);
if (table->type != HASHTABLE_NONWEAK)
{
table->next_weak = Vweak_hash_tables;
Vweak_hash_tables = result;
}
else
table->next_weak = Qunbound;
return (result);
}
DEFUN ("make-hashtable", Fmake_hashtable, Smake_hashtable, 1, 1, 0,
"Make a hashtable of initial size SIZE.")
(size)
Lisp_Object size;
{
CHECK_NATNUM (size, 0);
return make_lisp_hashtable (XINT (size), 0, 0, HASHTABLE_NONWEAK);
}
DEFUN ("copy-hashtable", Fcopy_hashtable, Scopy_hashtable, 1, 1, 0,
"Make a new hashtable which contains the same keys and values\n\
as the given table. The keys and values will not themselves be copied.")
(old_table)
Lisp_Object old_table;
{
struct _C_hashtable old_htbl;
struct _C_hashtable new_htbl;
struct hashtable_struct *old_ht;
struct hashtable_struct *new_ht;
Lisp_Object result;
CHECK_HASHTABLE (old_table, 0);
old_ht = XHASHTABLE (old_table);
ht_copy_to_c (old_ht, &old_htbl);
/* we can't just call Fmake_hashtable() here because that will make a
table that is slightly larger than the one we're trying to copy,
which will make copy_hash() blow up. */
new_ht = new_hashtable ();
new_ht->fullness = 0;
new_ht->zero_entry = Qunbound;
new_ht->hash_function = old_ht->hash_function;
new_ht->test_function = old_ht->test_function;
new_ht->harray = Fmake_vector (Flength (old_ht->harray), Qzero);
ht_copy_to_c (new_ht, &new_htbl);
copy_hash (&new_htbl, &old_htbl);
ht_copy_from_c (&new_htbl, new_ht);
new_ht->type = old_ht->type;
XSETHASHTABLE (result, new_ht);
if (EQ (old_ht->next_weak, Qunbound))
new_ht->next_weak = Qunbound;
else
{
new_ht->next_weak = Vweak_hash_tables;
Vweak_hash_tables = result;
}
return (result);
}
DEFUN ("gethash", Fgethash, Sgethash, 2, 3, 0,
"Find hash value for KEY in TABLE.\n\
If there is no corresponding value, return DEFAULT (defaults to nil).")
(key, table, defalt)
Lisp_Object key, table, defalt; /* One can't even spell correctly in C */
{
CONST void *vval;
struct _C_hashtable htbl;
if (!gc_in_progress)
CHECK_HASHTABLE (table, 0);
ht_copy_to_c (XHASHTABLE (table), &htbl);
if (gethash (LISP_TO_VOID (key), &htbl, &vval))
{
Lisp_Object val;
CVOID_TO_LISP (val, vval);
return val;
}
else
return defalt;
}
DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
"Remove hash value for KEY in TABLE.")
(key, table)
Lisp_Object key, table;
{
struct _C_hashtable htbl;
CHECK_HASHTABLE (table, 0);
ht_copy_to_c (XHASHTABLE (table), &htbl);
remhash (LISP_TO_VOID (key), &htbl);
ht_copy_from_c (&htbl, XHASHTABLE (table));
return Qnil;
}
DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
"Hash KEY to VAL in TABLE.")
(key, val, table)
Lisp_Object key, val, table;
{
struct hashtable_struct *ht;
void *vkey = LISP_TO_VOID (key);
CHECK_HASHTABLE (table, 0);
ht = XHASHTABLE (table);
if (!vkey)
ht->zero_entry = val;
else
{
struct gcpro gcpro1, gcpro2, gcpro3;
struct _C_hashtable htbl;
ht_copy_to_c (XHASHTABLE (table), &htbl);
GCPRO3 (key, val, table);
puthash (vkey, LISP_TO_VOID (val), &htbl);
ht_copy_from_c (&htbl, XHASHTABLE (table));
UNGCPRO;
}
return (val);
}
DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
"Flush TABLE.")
(table)
Lisp_Object table;
{
struct _C_hashtable htbl;
CHECK_HASHTABLE (table, 0);
ht_copy_to_c (XHASHTABLE (table), &htbl);
clrhash (&htbl);
ht_copy_from_c (&htbl, XHASHTABLE (table));
return Qnil;
}
DEFUN ("hashtable-fullness", Fhashtable_fullness, Shashtable_fullness, 1, 1, 0,
"Return number of entries in TABLE.")
(table)
Lisp_Object table;
{
struct _C_hashtable htbl;
CHECK_HASHTABLE (table, 0);
ht_copy_to_c (XHASHTABLE (table), &htbl);
return (make_number (htbl.fullness));
}
static void
verify_function (Lisp_Object function, char *description)
{
if (SYMBOLP (function))
{
if (NILP (function))
return;
else
function = indirect_function (function, 1);
}
if (SUBRP (function) || BYTECODEP (function))
return;
else if (CONSP (function))
{
Lisp_Object funcar = Fcar (function);
if ((SYMBOLP (funcar))
&& (EQ (funcar, Qlambda)
#ifdef MOCKLISP_SUPPORT
|| EQ (funcar, Qmocklisp)
#endif
|| EQ (funcar, Qautoload)))
return;
}
signal_error (Qinvalid_function, list1 (function));
}
static void
lisp_maphash_function (CONST void *void_key,
void *void_val,
void *void_fn)
{
/* This function can GC */
Lisp_Object key, val, fn;
CVOID_TO_LISP (key, void_key);
VOID_TO_LISP (val, void_val);
VOID_TO_LISP (fn, void_fn);
call2 (fn, key, val);
}
DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0,
"Map FUNCTION over entries in TABLE, calling it with two args,\n\
each key and value in the table.")
(function, table)
Lisp_Object function, table;
{
struct _C_hashtable htbl;
struct gcpro gcpro1, gcpro2;
verify_function (function, GETTEXT ("hashtable mapping function"));
CHECK_HASHTABLE (table, 0);
ht_copy_to_c (XHASHTABLE (table), &htbl);
GCPRO2 (table, function);
maphash (lisp_maphash_function, &htbl, LISP_TO_VOID (function));
UNGCPRO;
return Qnil;
}
/* This function is for mapping a *C* function over the elements of a
lisp hashtable.
*/
void
elisp_maphash (maphash_function function, Lisp_Object table, void *closure)
{
struct _C_hashtable htbl;
if (!gc_in_progress) CHECK_HASHTABLE (table, 0);
ht_copy_to_c (XHASHTABLE (table), &htbl);
maphash (function, &htbl, closure);
}
void
elisp_map_remhash (remhash_predicate function,
Lisp_Object table,
void *closure)
{
struct _C_hashtable htbl;
if (!gc_in_progress) CHECK_HASHTABLE (table, 0);
ht_copy_to_c (XHASHTABLE (table), &htbl);
map_remhash (function, &htbl, closure);
ht_copy_from_c (&htbl, XHASHTABLE (table));
}
#if 0
void
elisp_table_op (Lisp_Object table, generic_hashtable_op op, void *arg1,
void *arg2, void *arg3)
{
struct _C_hashtable htbl;
CHECK_HASHTABLE (table, 0);
ht_copy_to_c (XHASHTABLE (table), &htbl);
(*op) (&htbl, arg1, arg2, arg3);
ht_copy_from_c (&htbl, XHASHTABLE (table));
}
#endif /* 0 */
DEFUN ("make-weak-hashtable", Fmake_weak_hashtable, Smake_weak_hashtable,
1, 1, 0,
"Make a fully weak hashtable of initial size SIZE.\n\
A weak hashtable is one whose pointers do not count as GC referents:\n\
for any key-value pair in the hashtable, if the only remaining pointer\n\
to either the key or the value is in a weak hash table, then the pair\n\
will be removed from the table, and the key and value collected. A\n\
non-weak hash table (or any other pointer) would prevent the object\n\
from being collected.\n\
\n\
You can also create semi-weak hashtables; see `make-key-weak-hashtable'\n\
and `make-value-weak-hashtable'.")
(size)
Lisp_Object size;
{
CHECK_NATNUM (size, 0);
return make_lisp_hashtable (XINT (size), 0, 0, HASHTABLE_WEAK);
}
DEFUN ("make-key-weak-hashtable", Fmake_key_weak_hashtable,
Smake_key_weak_hashtable, 1, 1, 0,
"Make a key-weak hashtable of initial size SIZE.\n\
A key-weak hashtable is similar to a fully-weak hashtable (see\n\
`make-weak-hashtable') except that a key-value pair will be removed\n\
only if the key remains unmarked outside of weak hashtables. The pair\n\
will remain in the hashtable if the key is pointed to by something other\n\
than a weak hashtable, even if the value is not.")
(size)
Lisp_Object size;
{
CHECK_NATNUM (size, 0);
return make_lisp_hashtable (XINT (size), 0, 0, HASHTABLE_KEY_WEAK);
}
DEFUN ("make-value-weak-hashtable", Fmake_value_weak_hashtable,
Smake_value_weak_hashtable, 1, 1, 0,
"Make a value-weak hashtable of initial size SIZE.\n\
A value-weak hashtable is similar to a fully-weak hashtable (see\n\
`make-weak-hashtable') except that a key-value pair will be removed only\n\
if the value remains unmarked outside of weak hashtables. The pair will\n\
remain in the hashtable if the value is pointed to by something other\n\
than a weak hashtable, even if the key is not.")
(size)
Lisp_Object size;
{
CHECK_NATNUM (size, 0);
return make_lisp_hashtable (XINT (size), 0, 0, HASHTABLE_VALUE_WEAK);
}
struct marking_closure
{
int (*obj_marked_p) (Lisp_Object);
void (*markobj) (Lisp_Object);
enum hashtable_type type;
int did_mark;
};
static void
marking_mapper (CONST void *key, void *contents, void *closure)
{
Lisp_Object keytem, valuetem;
struct marking_closure *fmh =
(struct marking_closure *) closure;
/* This function is called over each pair in the hashtable.
We complete the marking for semi-weak hashtables. */
CVOID_TO_LISP (keytem, key);
CVOID_TO_LISP (valuetem, contents);
switch (fmh->type)
{
case HASHTABLE_KEY_WEAK:
if ((fmh->obj_marked_p) (keytem) &&
!(fmh->obj_marked_p) (valuetem))
{
(fmh->markobj) (valuetem);
fmh->did_mark = 1;
}
break;
case HASHTABLE_VALUE_WEAK:
if ((fmh->obj_marked_p) (valuetem) &&
!(fmh->obj_marked_p) (keytem))
{
(fmh->markobj) (keytem);
fmh->did_mark = 1;
}
break;
default:
abort (); /* Huh? */
}
return;
}
int
finish_marking_weak_hashtables (int (*obj_marked_p) (Lisp_Object),
void (*markobj) (Lisp_Object))
{
Lisp_Object rest;
int did_mark = 0;
for (rest = Vweak_hash_tables;
!NILP (rest);
rest = XHASHTABLE (rest)->next_weak)
{
enum hashtable_type type;
if (! ((*obj_marked_p) (rest)))
/* The hashtable is probably garbage. Ignore it. */
continue;
type = XHASHTABLE (rest)->type;
if (type == HASHTABLE_KEY_WEAK || type == HASHTABLE_VALUE_WEAK)
{
struct marking_closure fmh;
fmh.obj_marked_p = obj_marked_p;
fmh.markobj = markobj;
fmh.type = type;
fmh.did_mark = 0;
/* Now, scan over all the pairs. For all pairs that are
half-marked, we may need to mark the other half if we're
keeping this pair. */
elisp_maphash (marking_mapper, rest, &fmh);
if (fmh.did_mark)
did_mark = 1;
}
/* #### If alloc.c mark_object changes, this must change also... */
{
/* Now mark the vector itself. (We don't need to call markobj
here because we know that everything *in* it is already marked,
we just need to prevent the vector itself from disappearing.)
(The remhash above has taken care of zero_entry.)
*/
struct Lisp_Vector *ptr = XVECTOR (XHASHTABLE (rest)->harray);
int len = vector_length (ptr);
if (len >= 0)
{
ptr->size = -1 - len;
did_mark = 1;
}
/* else it's already marked (remember, this function is iterated
until marking stops) */
}
}
return did_mark;
}
struct pruning_closure
{
int (*obj_marked_p) (Lisp_Object);
};
static int
pruning_mapper (CONST void *key, CONST void *contents, void *closure)
{
Lisp_Object keytem, valuetem;
struct pruning_closure *fmh =
(struct pruning_closure *) closure;
/* This function is called over each pair in the hashtable.
We remove the pairs that aren't completely marked (everything
that is going to stay ought to have been marked already
by the finish_marking stage). */
CVOID_TO_LISP (keytem, key);
CVOID_TO_LISP (valuetem, contents);
return (! ((*fmh->obj_marked_p) (keytem) &&
(*fmh->obj_marked_p) (valuetem)));
}
void
prune_weak_hashtables (int (*obj_marked_p) (Lisp_Object))
{
Lisp_Object rest, prev = Qnil;
for (rest = Vweak_hash_tables;
!NILP (rest);
rest = XHASHTABLE (rest)->next_weak)
{
if (! ((*obj_marked_p) (rest)))
{
/* This table itself is garbage. Remove it from the list. */
if (NILP (prev))
Vweak_hash_tables = XHASHTABLE (rest)->next_weak;
else
XHASHTABLE (prev)->next_weak = XHASHTABLE (rest)->next_weak;
}
else
{
struct pruning_closure fmh;
fmh.obj_marked_p = obj_marked_p;
/* Now, scan over all the pairs. Remove all of the pairs
in which the key or value, or both, is unmarked
(depending on the type of weak hashtable). */
elisp_map_remhash (pruning_mapper, rest, &fmh);
prev = rest;
}
}
}
/* equality and hash functions for Lisp strings */
int
lisp_string_equal (CONST void *x1, CONST void *x2)
{
Lisp_Object str1, str2;
CVOID_TO_LISP (str1, x1);
CVOID_TO_LISP (str2, x2);
return !strcmp ((char *) string_data (XSTRING (str1)),
(char *) string_data (XSTRING (str2)));
}
unsigned long
lisp_string_hash (CONST void *x)
{
Lisp_Object str;
CVOID_TO_LISP (str, x);
return hash_string (string_data (XSTRING (str)),
string_length (XSTRING (str)));
}
/* Return a hash value for a Lisp_Object. This is for use when hashing
objects with the comparison being `equal' (for `eq', you can just
use the Lisp_Object itself as the hash value). You need to make a
tradeoff between the speed of the hash function and how good the
hashing is. In particular, the hash function needs to be FAST,
so you can't just traipse down the whole tree hashing everything
together. Most of the time, objects will differ in the first
few elements you hash. Thus, we only go to a short depth (5)
and only hash at most 5 elements out of a vector. Theoretically
we could still take 5^5 time (a big big number) to compute a
hash, but practically this won't ever happen. */
unsigned long
internal_hash (Lisp_Object obj, int depth)
{
if (depth > 5)
return 0;
if (CONSP (obj))
{
/* no point in worrying about tail recursion, since we're not
going very deep */
return HASH2 (internal_hash (XCAR (obj), depth + 1),
internal_hash (XCDR (obj), depth + 1));
}
#ifndef LRECORD_VECTOR
else if (VECTORP (obj))
{
int i;
struct Lisp_Vector *v = XVECTOR (obj);
int len = vector_length (v);
unsigned long hash = 0;
if (len <= 5)
{
for (i = 0; i < len; i++)
hash = HASH2 (hash, internal_hash (v->contents[i], depth + 1));
return hash;
}
/* just pick five elements scattered throughout the vector.
A slightly better approach would be to offset by some
noise factor from the points chosen below. */
for (i = 0; i < 5; i++)
hash = HASH2 (hash, internal_hash (v->contents[i*len/5], depth + 1));
return hash;
}
#endif /* !LRECORD_VECTOR */
else if (STRINGP (obj))
return hash_string (string_data (XSTRING (obj)),
string_length (XSTRING (obj)));
else if (LRECORDP (obj))
{
CONST struct lrecord_implementation
*imp = XRECORD_LHEADER (obj)->implementation;
if (imp->hash)
return ((imp->hash) (obj, depth));
}
return LISP_HASH (obj);
}
/************************************************************************/
/* initialization */
/************************************************************************/
void
syms_of_elhash (void)
{
defsubr (&Smake_hashtable);
defsubr (&Scopy_hashtable);
defsubr (&Shashtablep);
defsubr (&Sgethash);
defsubr (&Sputhash);
defsubr (&Sremhash);
defsubr (&Sclrhash);
defsubr (&Smaphash);
defsubr (&Shashtable_fullness);
defsubr (&Smake_weak_hashtable);
defsubr (&Smake_key_weak_hashtable);
defsubr (&Smake_value_weak_hashtable);
defsymbol (&Qhashtablep, "hashtablep");
}
void
vars_of_elhash (void)
{
/* This must not be staticpro'd */
Vweak_hash_tables = Qnil;
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.