/* Copyright 1989-93 GROUPE BULL -- See license conditions in file COPYRIGHT */
/************************\
* *
* KlO Hash *
* BODY *
* *
\************************/
#include "EXTERN.h"
#include "klone.h"
#include "kl_number.h"
#include "kl_atom.h"
#include "kl_list.h"
#include "kl_func.h"
#include "INTERN.h"
#include "kl_hash.h"
KlHash KlErrorUnRecoverableTable;
#define KlHashFunc(table, key) (((UInt) key) % table->limit)
#define KlHashCellCreate(cell, obj, key, Next) \
cell = (KlHashCell) Malloc(sizeof(struct _KlHashCell));\
cell->object = obj;\
cell->next = Next;\
cell->key = key
/* KlHashMake
* creates a hash table from a plist (which may be nil)
* default is to manage the ref count of the objects & keys
* KLONE_CALLABLE
*/
KlHash
KlHashAlloc(size)
int size;
{
KlHash obj = (KlHash) KlOMake(KlHashType);
KlOZero(obj, (size_t) sizeof(struct _KlHash));
if (size > KlHashInitialSize) {
obj->limit = KlHashFixSize(size);
} else {
obj->limit = KlHashInitialSize;
}
obj->table = (KlHashCell *) Calloc((size_t) obj->limit,
(size_t) sizeof(KlHashCell));
obj->ref_counted = KlHashRefK | KlHashRefV;
obj->curcell = 0;
return obj;
}
KlHash
KlHashMake(list)
KlList list;
{
KlHash obj = KlHashAlloc(list->size);
int i;
for (i = 1; i < list->size; i += 2) {
if (KlIsASymbol(list->list[i - 1])) {
KlHashPut(obj, list->list[i - 1], list->list[i]);
} else {
KlHashPutEqual(obj, list->list[i - 1], list->list[i]);
}
}
return obj;
}
/* KlHashRestore
* called when existing violently from a KlDoHash
*/
KlO
KlHashRestore(table, i)
KlHash table;
int i;
{
table->ref_counted &= ~KlHashFrozen; /* unfreeze */
table->curcell = 0;
return (KlO) table;
}
KlO
KlHashCopy(table)
KlHash table;
{
KlHash obj = KlHashAlloc(table->size);
int i;
KlHashFORBEGIN(table, cell) {
KlHashPutEqual(obj, cell->key, cell->object);
} KlHashFOREND;
return (KlO) obj;
}
KlO
KlHashLength(table)
KlHash table;
{
return (KlO) KlNumberMake(table->size);
}
/*ARGSUSED*/
KlO
KlHashCoerceListToHash(ht, obj)
KlType ht;
KlO obj;
{
return (KlO) KlHashMake(obj);
}
/* KlHashFixSize
* takes a desired size, and returns smallest optimal size
*/
int
KlHashFixSize(size)
int size;
{
int valid_size = KlHashInitialSize;
while (valid_size < size)
valid_size = (valid_size << 1) + 1;
return valid_size;
}
/* KlHashFree
*/
KlO
KlHashFree(table)
KlHash table;
{
int i;
KlHashCell old_cell, cell;
for (i = 0; i < table->limit; i++) {
if (table->table[i]) {
cell = table->table[i];
do {
if (table->ref_counted & KlHashRefV)
KlDecRef(cell->object);
if (table->ref_counted & KlHashRefK)
KlDecRef(cell->key);
old_cell = cell;
cell = cell->next;
Free(old_cell);
} while (cell);
}
}
Free(table->table);
Free(table);
return (KlO) table;
}
/* KlHashGrows
* grows table by moving cells from table to table
*/
KlHashGrows(table)
KlHash table;
{
KlHashCell *slot, cell, *last_slot, newcell;
KlHashCell *oldtable = table->table;
int newslot;
if (table->limit < 0) {
KlError1(KlE_NO_MODIFY, table);
}
slot = table->table;
last_slot = slot + table->limit;
table->limit = KlHashFixSize(table->size);
table->table = (KlHashCell *) Calloc((size_t) table->limit,
sizeof(KlHashCell));
if (table->ref_counted & KlHashRefK) {
while (slot < last_slot) {
if (*slot) {
for (cell = *slot; cell; cell = newcell) {
newslot = KlHashFunc(table, KlSend_hash(cell->key));
newcell = cell->next;
cell->next = table->table[newslot];
table->table[newslot] = cell;
}
}
slot++;
}
} else {
while (slot < last_slot) {
if (*slot) {
for (cell = *slot; cell; cell = newcell) {
newslot = KlHashFunc(table, KlHashFunc(table, cell->key));
newcell = cell->next;
cell->next = table->table[newslot];
table->table[newslot] = cell;
}
}
slot++;
}
}
Free(oldtable);
}
KlHashDohash(table, var, val, argc, argv)
KlHash table;
KlO var;
KlO val;
int argc;
KlO *argv;
{
KlGCMark();
KlHashProtectedFORBEGIN(table, cell) {
KlSend_setq(var, cell->key);
KlSend_setq(val, cell->object);
KlProgn(argc, argv);
KlGC();
} KlHashProtectedFOREND(table, cell);
}
/*****************************************************************************\
* primitive fast routines (EQ) *
\*****************************************************************************/
/* these routines are fast ones working by EQ, to be used (from C) only
* when dealing with symbols as keys
*/
/* KlHashPut
*/
KlO
KlHashPut(table, key, obj)
KlHash table;
KlO key;
KlO obj;
{
int slot = KlHashFunc(table, key);
KlHashCell newcell, cell = table->table[slot];
while (cell) {
if (key == cell->key) { /* update existing cell */
if (table->ref_counted & KlHashRefV) {
KlDecRef(cell->object);
KlIncRef(cell->object = obj);
} else {
cell->object = obj;
}
return (KlO) table;
}
cell = cell->next;
}
/* add new cell */
if (table->ref_counted & KlHashFrozen)
KlError1(KlE_NO_MODIFY, table);
KlHashCellCreate(newcell, obj, key, table->table[slot]);
table->table[slot] = newcell;
if (table->ref_counted & KlHashRefV)
KlIncRef(obj);
if (table->ref_counted & KlHashRefK)
KlIncRef(key);
if (table->size++ > table->limit) /* realloc */
KlHashGrows(table);
return (KlO) table;
}
/* KlHashGet
* primitive (from C) fast get with EQ semantics only
*/
KlO
KlHashGet(table, key, obj)
KlHash table;
KlO key;
KlO obj; /* default, can be 0 */
{
KlHashCell cell = table->table[KlHashFunc(table, key)];
while (cell) {
if (key == cell->key) { /* found */
return cell->object;
}
cell = cell->next;
}
/* not found, returns default */
if (table->ref_counted & KlHashRefV)
/* eval default only on klone values */
return obj ? KlSend_eval(obj) : 0;
else
return obj;
}
/* KlHashDelete
* returns TRU if success, NIL if wasn't there
*/
KlO
KlHashDelete(table, key)
KlHash table;
KlO key;
{
KlHashCell *slot = table->table + KlHashFunc(table, key);
KlHashCell cell = *slot;
while (cell) {
if (key == cell->key) { /* found */
if (table->curcell && cell != table->curcell->cell)
KlError1(KlE_NO_MODIFY, table);
if (table->ref_counted & KlHashRefV)
KlDecRef(cell->object);
if (table->ref_counted & KlHashRefK)
KlDecRef(cell->key);
*slot = cell->next;
Free(cell);
table->size--;
return (KlO) table;
}
slot = &((*slot)->next);
cell = cell->next;
}
/* not found */
return (KlO) table;
}
/******************************************** klone interface to EQ functions */
KlO
KlHashGetEQ(table, key, obj)
KlHash table;
KlO key;
KlO obj; /* default */
{
KlMustBeHash(table, 0);
return KlHashGet(table, key, obj);
}
KlO
KlHashPutEQ(table, key, obj)
KlHash table;
KlO key;
KlO obj;
{
KlMustBeHash(table, 0);
return KlHashPut(table, key, obj);
}
KlO
KlHashDeleteEQ(table, key)
KlHash table;
KlO key;
{
KlMustBeHash(table, 0);
return KlHashDelete(table, key);
}
/*****************************************************************************\
* generic Klone routines (EQUAL) *
\*****************************************************************************/
/* this is the general way to use them. Only entry point from klone
*/
/* KlHashPutEqual
*/
KlO
KlHashPutEqual(table, key, obj)
KlHash table;
KlO key;
KlO obj;
{
int slot = KlHashFunc(table, KlSend_hash(key));
KlHashCell newcell, cell = table->table[slot];
while (cell) {
if (KlSend_equal(key, cell->key) != NIL) { /* update existing cell */
if (table->ref_counted & KlHashRefV) {
KlDecRef(cell->object);
KlIncRef(cell->object = obj);
} else {
cell->object = obj;
}
return (KlO) table;
}
cell = cell->next;
}
/* add new cell */
if (table->ref_counted & KlHashFrozen)
KlError1(KlE_NO_MODIFY, table);
KlHashCellCreate(newcell, obj, key, table->table[slot]);
table->table[slot] = newcell;
if (table->ref_counted & KlHashRefV)
KlIncRef(obj);
if (table->ref_counted & KlHashRefK)
KlIncRef(key);
if (table->size++ > table->limit) /* realloc */
KlHashGrows(table);
return (KlO) table;
}
/* KlHashGetEqual
*/
KlO
KlHashGetEqual(table, key, obj)
KlHash table;
KlO key;
KlO obj; /* default */
{
KlHashCell cell = table->table[KlHashFunc(table, KlSend_hash(key))];
while (cell) {
if (KlSend_equal(key, cell->key) != NIL) { /* found */
return cell->object;
}
cell = cell->next;
}
/* not found, returns default */
if (table->ref_counted & KlHashRefV)
return KlExecuteGetDefault(table, key, obj); /* eval default only on klone values */
else
return obj;
}
/* KlHashDeleteEqual
* returns TRU if success, NIL if wasn't there
*/
KlO
KlHashDeleteEqual(table, key)
KlHash table;
KlO key;
{
KlHashCell *slot = table->table + KlHashFunc(table, KlSend_hash(key));
KlHashCell cell = *slot;
while (cell) {
if (KlSend_equal(key, cell->key) != NIL) { /* found */
if (table->curcell && cell != table->curcell->cell)
KlError1(KlE_NO_MODIFY, table);
if (table->ref_counted & KlHashRefV)
KlDecRef(cell->object);
if (table->ref_counted & KlHashRefK)
KlDecRef(cell->key);
*slot = cell->next;
Free(cell);
table->size--;
return (KlO) table;
}
slot = &(cell->next);
cell = cell->next;
}
/* not found */
return (KlO) table;
}
/**************************************************************************\
* Methods *
\**************************************************************************/
KlO
KlHashEqual(h1, h2)
KlHash h1;
KlHash h2;
{
KlO val;
if (!(KlIsAHash(h2) && h2->size == h1->size))
return NIL;
KlHashFORBEGIN(h1, cell) {
if ((val = KlHashGetEqual(h2, cell->key, 0)) == 0
|| KlFalseP(KlSend_equal(cell->object, val))) {
return NIL;
}
} KlHashFOREND;
return (KlO) h1;
}
KlO
KlHashHash(table)
KlHash table;
{
UInt result = 0;
KlHashFORBEGIN(table, cell) {
result += (UInt) KlSend_hash(cell->object);
} KlHashFOREND;
return (KlO) result;
}
/* KlHashLinks
* used to set the "Refcount" hint of a hashtable
* (hashtable-links table arg)
* arg = () return links as a number
* key refcounted: 1
* value refcounted: 2
* both (default): 3
*/
KlO
KlHashLinks(ht, flags)
KlHash ht;
KlNumber flags;
{
KlMustBeHash(ht, 0);
if (KlTrueP(flags)) { /* returns current hints */
KlMustBeNumber(flags, 1);
ht->ref_counted = (flags->number) & (KlHashRefK | KlHashRefV);
}
return (KlO) KlNumberMake(ht->ref_counted);
}
/*****************************************************************************\
* TYPE INIT *
\*****************************************************************************/
KlHashInit()
{
KlDeclareType(&KlStructuredType, "Structured", 0);
KlDeclareSubType(&KlHashType, "Hashtable", KlStructuredType,
sizeof(struct _KlHash));
KlDeclareTrait(KlHashType, KlTrait_table);
KlDeclareMethod1(KlHashType, KlSelFree, KlHashFree);
KlDeclareMethod1(KlHashType, KlSelEqual, KlHashEqual);
KlDeclareMethod1(KlHashType, KlSelHash, KlHashHash);
KlDeclareMethod1(KlHashType, KlSelGet, KlHashGetEqual);
KlDeclareMethod1(KlHashType, KlSelPut, KlHashPutEqual);
KlDeclareMethod1(KlHashType, KlSelDelete, KlHashDeleteEqual);
KlDeclareMethod1(KlHashType, KlSelCopy, KlHashCopy);
KlDeclareMethod1(KlHashType, KlSelLength, KlHashLength);
KlDeclareMethod1(KlHashType, KlSelDohash, (KlMethod) KlHashDohash);
KlDeclareSubr(KlHashLinks, "*:hashtable-links", 2);
KlDeclareSubr(KlHashGetEQ, "hash-get-eq", 3);
KlDeclareSubr(KlHashPutEQ, "hash-put-eq", 3);
KlDeclareSubr(KlHashDeleteEQ, "hash-delete-eq", 2);
/* built-in-tables to access klone objects by their names */
KlDeclareAtom("Errors:Unrecoverable",
KlErrorUnRecoverableTable = KlHashAlloc(20));
}
syntax highlighted by Code2HTML, v. 0.9.1