hash.c revision 5dfecf96 
1/*
2 * Copyright (c) 2002 by The XFree86 Project, Inc.
3 *
4 * Permission is hereby granted, free of charge, to any person obtaining a
5 * copy of this software and associated documentation files (the "Software"),
6 * to deal in the Software without restriction, including without limitation
7 * the rights to use, copy, modify, merge, publish, distribute, sublicense,
8 * and/or sell copies of the Software, and to permit persons to whom the
9 * Software is furnished to do so, subject to the following conditions:
10 *
11 * The above copyright notice and this permission notice shall be included in
12 * all copies or substantial portions of the Software.
13 *
14 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
17 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
18 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
19 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
20 * SOFTWARE.
21 *
22 * Except as contained in this notice, the name of the XFree86 Project shall
23 * not be used in advertising or otherwise to promote the sale, use or other
24 * dealings in this Software without prior written authorization from the
25 * XFree86 Project.
26 *
27 * Author: Paulo César Pereira de Andrade
28 */
29
30/* $XFree86: xc/programs/xedit/lisp/hash.c,v 1.5 2003/04/27 18:17:32 tsi Exp $ */
31
32#include "lisp/hash.h"
33
34/* A simple hash-table implementation
35 * TODO: implement SXHASH and WITH-HASH-TABLE-ITERATOR
36 * May need a rewrite for better performance, and will
37 * need a rewrite if images/bytecode saved on disk.
38 */
39
40#define	GET_HASH	1
41#define PUT_HASH	2
42#define REM_HASH	3
43
44/*
45 * Prototypes
46 */
47static unsigned long LispHashKey(LispObj*, int);
48static LispObj *LispHash(LispBuiltin*, int);
49static void LispRehash(LispHashTable*);
50static void LispFreeHashEntries(LispHashEntry*, long);
51
52/*
53 * Initialization
54 */
55extern LispObj *Oeq, *Oeql, *Oequal, *Oequalp;
56
57/*  Hash tables will have one of these sizes, unless the user
58 * specified a very large size */
59static long some_primes[] = {
60       5,   11,   17,   23,
61      31,   47,   71,   97,
62     139,  199,  307,  401,
63     607,  809, 1213, 1619,
64    2437, 3251, 4889, 6521
65};
66
67/*
68 * Implementation
69 */
70static unsigned long
71LispHashKey(LispObj *object, int function)
72{
73    mpi *bigi;
74    char *string;
75    long i, length;
76    unsigned long key = ((unsigned long)object) >> 4;
77
78    /* Must be the same object for EQ */
79    if (function == FEQ)
80	goto hash_key_done;
81
82    if (function == FEQUALP) {
83	switch (OBJECT_TYPE(object)) {
84	    case LispSChar_t:
85		key = (unsigned long)toupper(SCHAR_VALUE(object));
86		goto hash_key_done;
87	    case LispString_t:
88		string = THESTR(object);
89		length = STRLEN(object);
90		if (length > 32)
91		    length = 32;
92		for (i = 0, key = 0; i < length; i++)
93		    key = (key << 1) ^ toupper(string[i]);
94		goto hash_key_done;
95	    default:
96		break;
97	}
98    }
99
100    /* Function is EQL, EQUAL or EQUALP */
101    switch (OBJECT_TYPE(object)) {
102	case LispFixnum_t:
103	case LispSChar_t:
104	    key = (unsigned long)FIXNUM_VALUE(object);
105	    goto hash_key_done;
106	case LispInteger_t:
107	    key = (unsigned long)INT_VALUE(object);
108	    goto hash_key_done;
109	case LispRatio_t:
110	    key = (object->data.ratio.numerator << 16) ^
111		   object->data.ratio.denominator;
112	    goto hash_key_done;
113	case LispDFloat_t:
114	    key = (unsigned long)DFLOAT_VALUE(object);
115	    break;
116	case LispComplex_t:
117	    key = (LispHashKey(object->data.complex.imag, function) << 16) ^
118		   LispHashKey(object->data.complex.real, function);
119	    goto hash_key_done;
120	case LispBignum_t:
121	    bigi = object->data.mp.integer;
122	    length = bigi->size;
123	    if (length > 8)
124		length = 8;
125	    key = bigi->sign;
126	    for (i = 0; i < length; i++)
127		key = (key << 8) ^ bigi->digs[i];
128	    goto hash_key_done;
129	case LispBigratio_t:
130	    bigi = mpr_num(object->data.mp.ratio);
131	    length = bigi->size;
132	    if (length > 4)
133		length = 4;
134	    key = bigi->sign;
135	    for (i = 0; i < length; i++)
136		key = (key << 4) ^ bigi->digs[i];
137	    bigi = mpr_den(object->data.mp.ratio);
138	    length = bigi->size;
139	    if (length > 4)
140		length = 4;
141	    for (i = 0; i < length; i++)
142		key = (key << 4) ^ bigi->digs[i];
143	    goto hash_key_done;
144	default:
145	    break;
146    }
147
148    /* Anything else must be the same object for EQL */
149    if (function == FEQL)
150	goto hash_key_done;
151
152    switch (OBJECT_TYPE(object)) {
153	case LispString_t:
154	    string = THESTR(object);
155	    length = STRLEN(object);
156	    if (length > 32)
157		length = 32;
158	    for (i = 0, key = 0; i < length; i++)
159		key = (key << 1) ^ string[i];
160	    break;
161	case LispCons_t:
162	    key = (LispHashKey(CAR(object), function) << 16) ^
163		   LispHashKey(CDR(object), function);
164	    break;
165	case LispQuote_t:
166	case LispBackquote_t:
167	case LispPathname_t:
168	    key = LispHashKey(object->data.pathname, function);
169	    break;
170	case LispRegex_t:
171	    key = LispHashKey(object->data.regex.pattern, function);
172	    break;
173	default:
174	    break;
175    }
176
177hash_key_done:
178    return (key);
179}
180
181static LispObj *
182LispHash(LispBuiltin *builtin, int code)
183{
184    LispHashEntry *entry;
185    LispHashTable *hash;
186    unsigned long key;
187    LispObj *result;
188    int found;
189    long i;
190
191    LispObj *okey, *hash_table, *value;
192
193    if (code == REM_HASH)
194	value = NIL;
195    else {
196	value = ARGUMENT(2);
197	if (value == UNSPEC)
198	    value = NIL;
199    }
200    hash_table = ARGUMENT(1);
201    okey = ARGUMENT(0);
202
203    CHECK_HASHTABLE(hash_table);
204
205    /* get hash entry */
206    hash = hash_table->data.hash.table;
207    key = LispHashKey(okey, hash->function) % hash->num_entries;
208    entry = hash->entries + key;
209
210    /* search entry in the hash table */
211    if (entry->count == 0)
212	i = 0;
213    else {
214	if (hash->function == FEQ) {
215	    for (i = entry->cache; i >= 0; i--) {
216		if (entry->keys[i] == okey)
217		    goto found_key;
218	    }
219	    for (i = entry->cache + 1; i < entry->count; i++) {
220		if (entry->keys[i] == okey)
221		    break;
222	    }
223	}
224	else {
225	    for (i = entry->cache; i >= 0; i--) {
226		if (LispObjectCompare(entry->keys[i], okey,
227				      hash->function) == T)
228		    goto found_key;
229	    }
230	    for (i = entry->cache + 1; i < entry->count; i++) {
231		if (LispObjectCompare(entry->keys[i], okey,
232				      hash->function) == T)
233		    break;
234	    }
235	}
236    }
237
238found_key:
239    result = value;
240    if ((found = i < entry->count) == 0)
241	i = entry->count;
242
243    switch (code) {
244	case GET_HASH:
245	    RETURN_COUNT = 1;
246	    if (found) {
247		RETURN(0) = T;
248		entry->cache = i;
249		result = entry->values[i];
250	    }
251	    else
252		RETURN(0) = NIL;
253	    break;
254	case PUT_HASH:
255	    entry->cache = i;
256	    if (found)
257		/* Just replace current entry */
258		entry->values[i] = value;
259	    else {
260		if ((i % 4) == 0) {
261		    LispObj **keys, **values;
262
263		    keys = realloc(entry->keys, sizeof(LispObj*) * (i + 4));
264		    if (keys == NULL)
265			LispDestroy("out of memory");
266		    values = realloc(entry->values, sizeof(LispObj*) * (i + 4));
267		    if (values == NULL) {
268			free(keys);
269			LispDestroy("out of memory");
270		    }
271		    entry->keys = keys;
272		    entry->values = values;
273		}
274		entry->keys[i] = okey;
275		entry->values[i] = value;
276		++entry->count;
277		++hash->count;
278		if (hash->count > hash->rehash_threshold * hash->num_entries)
279		    LispRehash(hash);
280	    }
281	    break;
282	case REM_HASH:
283	    if (found) {
284		result = T;
285		--entry->count;
286		--hash->count;
287		if (i < entry->count) {
288		    memmove(entry->keys + i, entry->keys + i + 1,
289			    (entry->count - i) * sizeof(LispObj*));
290		    memmove(entry->values + i, entry->values + i + 1,
291			    (entry->count - i) * sizeof(LispObj*));
292		}
293		if (entry->cache && entry->cache == entry->count)
294		    --entry->cache;
295	    }
296	    break;
297    }
298
299    return (result);
300}
301
302static void
303LispRehash(LispHashTable *hash)
304{
305    unsigned long key;
306    LispHashEntry *entries, *nentry, *entry, *last;
307    long i, size = hash->num_entries * hash->rehash_size;
308
309    for (i = 0; i < sizeof(some_primes) / sizeof(some_primes[0]); i++)
310	if (some_primes[i] >= size) {
311	    size = some_primes[i];
312	    break;
313	}
314
315    entries = calloc(1, sizeof(LispHashEntry) * size);
316    if (entries == NULL)
317	goto out_of_memory;
318
319    for (entry = hash->entries, last = entry + hash->num_entries;
320	 entry < last; entry++) {
321	for (i = 0; i < entry->count; i++) {
322	    key = LispHashKey(entry->keys[i], hash->function) % size;
323	    nentry = entries + key;
324	    if ((nentry->count % 4) == 0) {
325		LispObj **keys, **values;
326
327		keys = realloc(nentry->keys, sizeof(LispObj*) *
328			       (nentry->count + 4));
329		if (keys == NULL)
330		    goto out_of_memory;
331		values = realloc(nentry->values, sizeof(LispObj*) *
332				 (nentry->count + 4));
333		if (values == NULL) {
334		    free(keys);
335		    goto out_of_memory;
336		}
337		nentry->keys = keys;
338		nentry->values = values;
339	    }
340	    nentry->keys[nentry->count] = entry->keys[i];
341	    nentry->values[nentry->count] = entry->values[i];
342	    ++nentry->count;
343
344	}
345    }
346    LispFreeHashEntries(hash->entries, hash->num_entries);
347    hash->entries = entries;
348    hash->num_entries = size;
349    return;
350
351out_of_memory:
352    if (entries)
353	LispFreeHashEntries(entries, size);
354    LispDestroy("out of memory");
355}
356
357static void
358LispFreeHashEntries(LispHashEntry *entries, long num_entries)
359{
360    LispHashEntry *entry, *last;
361
362    for (entry = entries, last = entry + num_entries; entry < last; entry++) {
363	free(entry->keys);
364	free(entry->values);
365    }
366    free(entries);
367}
368
369void
370LispFreeHashTable(LispHashTable *hash)
371{
372    LispFreeHashEntries(hash->entries, hash->num_entries);
373    free(hash);
374}
375
376LispObj *
377Lisp_Clrhash(LispBuiltin *builtin)
378/*
379 clrhash hash-table
380 */
381{
382    LispHashTable *hash;
383    LispHashEntry *entry, *last;
384
385    LispObj *hash_table = ARGUMENT(0);
386
387    CHECK_HASHTABLE(hash_table);
388
389    hash = hash_table->data.hash.table;
390    for (entry = hash->entries, last = entry + hash->num_entries;
391	entry < last; entry++) {
392	free(entry->keys);
393	free(entry->values);
394	entry->keys = entry->values = NULL;
395	entry->count = entry->cache = 0;
396    }
397    hash->count = 0;
398
399    return (hash_table);
400}
401
402LispObj *
403Lisp_Gethash(LispBuiltin *builtin)
404/*
405 gethash key hash-table &optional default
406 */
407{
408    return (LispHash(builtin, GET_HASH));
409}
410
411LispObj *
412Lisp_HashTableP(LispBuiltin *builtin)
413/*
414 hash-table-p object
415 */
416{
417    LispObj *object = ARGUMENT(0);
418
419    return (HASHTABLEP(object) ? T : NIL);
420}
421
422LispObj *
423Lisp_HashTableCount(LispBuiltin *builtin)
424/*
425 hash-table-count hash-table
426 */
427{
428    LispObj *hash_table = ARGUMENT(0);
429
430    CHECK_HASHTABLE(hash_table);
431
432    return (FIXNUM(hash_table->data.hash.table->count));
433}
434
435LispObj *
436Lisp_HashTableRehashSize(LispBuiltin *builtin)
437/*
438 hash-table-rehash-size hash-table
439 */
440{
441    LispObj *hash_table = ARGUMENT(0);
442
443    CHECK_HASHTABLE(hash_table);
444
445    return (DFLOAT(hash_table->data.hash.table->rehash_size));
446}
447
448LispObj *
449Lisp_HashTableRehashThreshold(LispBuiltin *builtin)
450/*
451 hash-table-rehash-threshold hash-table
452 */
453{
454    LispObj *hash_table = ARGUMENT(0);
455
456    CHECK_HASHTABLE(hash_table);
457
458    return (DFLOAT(hash_table->data.hash.table->rehash_threshold));
459}
460
461LispObj *
462Lisp_HashTableSize(LispBuiltin *builtin)
463/*
464 hash-table-size hash-table
465 */
466{
467    LispObj *hash_table = ARGUMENT(0);
468
469    CHECK_HASHTABLE(hash_table);
470
471    return (FIXNUM(hash_table->data.hash.table->num_entries));
472}
473
474LispObj *
475Lisp_HashTableTest(LispBuiltin *builtin)
476/*
477 hash-table-test hash-table
478 */
479{
480    LispObj *hash_table = ARGUMENT(0);
481
482    CHECK_HASHTABLE(hash_table);
483
484    return (hash_table->data.hash.test);
485}
486
487LispObj *
488Lisp_Maphash(LispBuiltin *builtin)
489/*
490 maphash function hash-table
491 */
492{
493    long i;
494    LispHashEntry *entry, *last;
495
496    LispObj *function, *hash_table;
497
498    hash_table = ARGUMENT(1);
499    function = ARGUMENT(0);
500
501    CHECK_HASHTABLE(hash_table);
502
503    for (entry = hash_table->data.hash.table->entries,
504	 last = entry + hash_table->data.hash.table->num_entries;
505	 entry < last; entry++) {
506	for (i = 0; i < entry->count; i++)
507	    APPLY2(function, entry->keys[i], entry->values[i]);
508    }
509
510    return (NIL);
511}
512
513LispObj *
514Lisp_MakeHashTable(LispBuiltin *builtin)
515/*
516 make-hash-table &key test size rehash-size rehash-threshold initial-contents
517 */
518{
519    int function = FEQL;
520    unsigned long i, isize, xsize;
521    double drsize, drthreshold;
522    LispHashTable *hash_table;
523    LispObj *cons, *result;
524
525    LispObj *test, *size, *rehash_size, *rehash_threshold, *initial_contents;
526
527    initial_contents = ARGUMENT(4);
528    rehash_threshold = ARGUMENT(3);
529    rehash_size = ARGUMENT(2);
530    size = ARGUMENT(1);
531    test = ARGUMENT(0);
532
533    if (test != UNSPEC) {
534	if (FUNCTIONP(test))
535	    test = test->data.atom->object;
536	if (test == Oeq)
537	    function = FEQ;
538	else if (test == Oeql)
539	    function = FEQL;
540	else if (test == Oequal)
541	    function = FEQUAL;
542	else if (test == Oequalp)
543	    function = FEQUALP;
544	else
545	    LispDestroy("%s: :TEST must be EQ, EQL, EQUAL, "
546			"or EQUALP, not %s", STRFUN(builtin), STROBJ(test));
547    }
548    else
549	test = Oeql;
550
551    if (size != UNSPEC) {
552	CHECK_INDEX(size);
553	isize = FIXNUM_VALUE(size);
554    }
555    else
556	isize = 1;
557
558    if (rehash_size != UNSPEC) {
559	CHECK_DFLOAT(rehash_size);
560	if (DFLOAT_VALUE(rehash_size) <= 1.0)
561	    LispDestroy("%s: :REHASH-SIZE must a float > 1, not %s",
562			STRFUN(builtin), STROBJ(rehash_size));
563	drsize = DFLOAT_VALUE(rehash_size);
564    }
565    else
566	drsize = 1.5;
567
568    if (rehash_threshold != UNSPEC) {
569	CHECK_DFLOAT(rehash_threshold);
570	if (DFLOAT_VALUE(rehash_threshold) < 0.0 ||
571	    DFLOAT_VALUE(rehash_threshold) > 1.0)
572	    LispDestroy("%s: :REHASH-THRESHOLD must a float "
573			"in the range 0.0 - 1.0, not %s",
574			STRFUN(builtin), STROBJ(rehash_threshold));
575	drthreshold = DFLOAT_VALUE(rehash_threshold);
576    }
577    else
578	drthreshold = 0.75;
579
580    if (initial_contents == UNSPEC)
581	initial_contents = NIL;
582    CHECK_LIST(initial_contents);
583    for (xsize = 0, cons = initial_contents;
584	 CONSP(cons);
585	 xsize++, cons = CDR(cons))
586	CHECK_CONS(CAR(cons));
587
588    if (xsize > isize)
589	isize = xsize;
590
591    for (i = 0; i < sizeof(some_primes) / sizeof(some_primes[0]); i++)
592	if (some_primes[i] >= isize) {
593	    isize = some_primes[i];
594	    break;
595	}
596
597    hash_table = LispMalloc(sizeof(LispHashTable));
598    hash_table->entries = LispCalloc(1, sizeof(LispHashEntry) * isize);
599    hash_table->num_entries = isize;
600    hash_table->count = 0;
601    hash_table->function = function;
602    hash_table->rehash_size = drsize;
603    hash_table->rehash_threshold = drthreshold;
604
605    result = LispNew(NIL, NIL);
606    result->type = LispHashTable_t;
607    result->data.hash.table = hash_table;
608    result->data.hash.test = test;
609
610    LispMused(hash_table);
611    LispMused(hash_table->entries);
612
613    if (initial_contents != UNSPEC) {
614	unsigned long key;
615	LispHashEntry *entry;
616
617	for (cons = initial_contents; CONSP(cons); cons = CDR(cons)) {
618	    key = LispHashKey(CAAR(cons), function) % isize;
619	    entry = hash_table->entries + key;
620
621	    if ((entry->count % 4) == 0) {
622		LispObj **keys, **values;
623
624		keys = realloc(entry->keys, sizeof(LispObj*) * (i + 4));
625		if (keys == NULL)
626		    LispDestroy("out of memory");
627		values = realloc(entry->values, sizeof(LispObj*) * (i + 4));
628		if (values == NULL) {
629		    free(keys);
630		    LispDestroy("out of memory");
631		}
632		entry->keys = keys;
633		entry->values = values;
634	    }
635	    entry->keys[entry->count] = CAAR(cons);
636	    entry->values[entry->count] = CDAR(cons);
637	    ++entry->count;
638	}
639	hash_table->count = xsize;
640    }
641
642    return (result);
643}
644
645LispObj *
646Lisp_Remhash(LispBuiltin *builtin)
647/*
648 remhash key hash-table
649 */
650{
651    return (LispHash(builtin, REM_HASH));
652}
653
654LispObj *
655Lisp_XeditPuthash(LispBuiltin *builtin)
656/*
657 lisp::puthash key hash-table value
658 */
659{
660    return (LispHash(builtin, PUT_HASH));
661}
662