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	    for (i = 0, key = 0; i < length; i++)
157		key = (key << 1) ^ string[i];
158	    break;
159	case LispCons_t:
160	    key = (LispHashKey(CAR(object), function) << 16) ^
161		   LispHashKey(CDR(object), function);
162	    break;
163	case LispQuote_t:
164	case LispBackquote_t:
165	case LispPathname_t:
166	    key = LispHashKey(object->data.pathname, function);
167	    break;
168	case LispRegex_t:
169	    key = LispHashKey(object->data.regex.pattern, function);
170	    break;
171	default:
172	    break;
173    }
174
175hash_key_done:
176    return (key);
177}
178
179static LispObj *
180LispHash(LispBuiltin *builtin, int code)
181{
182    LispHashEntry *entry;
183    LispHashTable *hash;
184    unsigned long key;
185    LispObj *result;
186    int found;
187    long i;
188
189    LispObj *okey, *hash_table, *value;
190
191    if (code == REM_HASH)
192	value = NIL;
193    else {
194	value = ARGUMENT(2);
195	if (value == UNSPEC)
196	    value = NIL;
197    }
198    hash_table = ARGUMENT(1);
199    okey = ARGUMENT(0);
200
201    CHECK_HASHTABLE(hash_table);
202
203    /* get hash entry */
204    hash = hash_table->data.hash.table;
205    key = LispHashKey(okey, hash->function) % hash->num_entries;
206    entry = hash->entries + key;
207
208    /* search entry in the hash table */
209    if (entry->count == 0)
210	i = 0;
211    else {
212	if (hash->function == FEQ) {
213	    for (i = entry->cache; i >= 0; i--) {
214		if (entry->keys[i] == okey)
215		    goto found_key;
216	    }
217	    for (i = entry->cache + 1; i < entry->count; i++) {
218		if (entry->keys[i] == okey)
219		    break;
220	    }
221	}
222	else {
223	    for (i = entry->cache; i >= 0; i--) {
224		if (LispObjectCompare(entry->keys[i], okey,
225				      hash->function) == T)
226		    goto found_key;
227	    }
228	    for (i = entry->cache + 1; i < entry->count; i++) {
229		if (LispObjectCompare(entry->keys[i], okey,
230				      hash->function) == T)
231		    break;
232	    }
233	}
234    }
235
236found_key:
237    result = value;
238    if ((found = i < entry->count) == 0)
239	i = entry->count;
240
241    switch (code) {
242	case GET_HASH:
243	    RETURN_COUNT = 1;
244	    if (found) {
245		RETURN(0) = T;
246		entry->cache = i;
247		result = entry->values[i];
248	    }
249	    else
250		RETURN(0) = NIL;
251	    break;
252	case PUT_HASH:
253	    entry->cache = i;
254	    if (found)
255		/* Just replace current entry */
256		entry->values[i] = value;
257	    else {
258		if ((i % 4) == 0) {
259		    LispObj **keys, **values;
260
261		    keys = realloc(entry->keys, sizeof(LispObj*) * (i + 4));
262		    if (keys == NULL)
263			LispDestroy("out of memory");
264		    values = realloc(entry->values, sizeof(LispObj*) * (i + 4));
265		    if (values == NULL) {
266			free(keys);
267			LispDestroy("out of memory");
268		    }
269		    entry->keys = keys;
270		    entry->values = values;
271		}
272		entry->keys[i] = okey;
273		entry->values[i] = value;
274		++entry->count;
275		++hash->count;
276		if (hash->count > hash->rehash_threshold * hash->num_entries)
277		    LispRehash(hash);
278	    }
279	    break;
280	case REM_HASH:
281	    if (found) {
282		result = T;
283		--entry->count;
284		--hash->count;
285		if (i < entry->count) {
286		    memmove(entry->keys + i, entry->keys + i + 1,
287			    (entry->count - i) * sizeof(LispObj*));
288		    memmove(entry->values + i, entry->values + i + 1,
289			    (entry->count - i) * sizeof(LispObj*));
290		}
291		if (entry->cache && entry->cache == entry->count)
292		    --entry->cache;
293	    }
294	    break;
295    }
296
297    return (result);
298}
299
300static void
301LispRehash(LispHashTable *hash)
302{
303    unsigned long key;
304    LispHashEntry *entries, *nentry, *entry, *last;
305    long i, size = hash->num_entries * hash->rehash_size;
306
307    for (i = 0; i < sizeof(some_primes) / sizeof(some_primes[0]); i++)
308	if (some_primes[i] >= size) {
309	    size = some_primes[i];
310	    break;
311	}
312
313    entries = calloc(1, sizeof(LispHashEntry) * size);
314    if (entries == NULL)
315	goto out_of_memory;
316
317    for (entry = hash->entries, last = entry + hash->num_entries;
318	 entry < last; entry++) {
319	for (i = 0; i < entry->count; i++) {
320	    key = LispHashKey(entry->keys[i], hash->function) % size;
321	    nentry = entries + key;
322	    if ((nentry->count % 4) == 0) {
323		LispObj **keys, **values;
324
325		keys = realloc(nentry->keys, sizeof(LispObj*) *
326			       (nentry->count + 4));
327		if (keys == NULL)
328		    goto out_of_memory;
329		values = realloc(nentry->values, sizeof(LispObj*) *
330				 (nentry->count + 4));
331		if (values == NULL) {
332		    free(keys);
333		    goto out_of_memory;
334		}
335		nentry->keys = keys;
336		nentry->values = values;
337	    }
338	    nentry->keys[nentry->count] = entry->keys[i];
339	    nentry->values[nentry->count] = entry->values[i];
340	    ++nentry->count;
341
342	}
343    }
344    LispFreeHashEntries(hash->entries, hash->num_entries);
345    hash->entries = entries;
346    hash->num_entries = size;
347    return;
348
349out_of_memory:
350    if (entries)
351	LispFreeHashEntries(entries, size);
352    LispDestroy("out of memory");
353}
354
355static void
356LispFreeHashEntries(LispHashEntry *entries, long num_entries)
357{
358    LispHashEntry *entry, *last;
359
360    for (entry = entries, last = entry + num_entries; entry < last; entry++) {
361	free(entry->keys);
362	free(entry->values);
363    }
364    free(entries);
365}
366
367void
368LispFreeHashTable(LispHashTable *hash)
369{
370    LispFreeHashEntries(hash->entries, hash->num_entries);
371    free(hash);
372}
373
374LispObj *
375Lisp_Clrhash(LispBuiltin *builtin)
376/*
377 clrhash hash-table
378 */
379{
380    LispHashTable *hash;
381    LispHashEntry *entry, *last;
382
383    LispObj *hash_table = ARGUMENT(0);
384
385    CHECK_HASHTABLE(hash_table);
386
387    hash = hash_table->data.hash.table;
388    for (entry = hash->entries, last = entry + hash->num_entries;
389	entry < last; entry++) {
390	free(entry->keys);
391	free(entry->values);
392	entry->keys = entry->values = NULL;
393	entry->count = entry->cache = 0;
394    }
395    hash->count = 0;
396
397    return (hash_table);
398}
399
400LispObj *
401Lisp_Gethash(LispBuiltin *builtin)
402/*
403 gethash key hash-table &optional default
404 */
405{
406    return (LispHash(builtin, GET_HASH));
407}
408
409LispObj *
410Lisp_HashTableP(LispBuiltin *builtin)
411/*
412 hash-table-p object
413 */
414{
415    LispObj *object = ARGUMENT(0);
416
417    return (HASHTABLEP(object) ? T : NIL);
418}
419
420LispObj *
421Lisp_HashTableCount(LispBuiltin *builtin)
422/*
423 hash-table-count hash-table
424 */
425{
426    LispObj *hash_table = ARGUMENT(0);
427
428    CHECK_HASHTABLE(hash_table);
429
430    return (FIXNUM(hash_table->data.hash.table->count));
431}
432
433LispObj *
434Lisp_HashTableRehashSize(LispBuiltin *builtin)
435/*
436 hash-table-rehash-size hash-table
437 */
438{
439    LispObj *hash_table = ARGUMENT(0);
440
441    CHECK_HASHTABLE(hash_table);
442
443    return (DFLOAT(hash_table->data.hash.table->rehash_size));
444}
445
446LispObj *
447Lisp_HashTableRehashThreshold(LispBuiltin *builtin)
448/*
449 hash-table-rehash-threshold hash-table
450 */
451{
452    LispObj *hash_table = ARGUMENT(0);
453
454    CHECK_HASHTABLE(hash_table);
455
456    return (DFLOAT(hash_table->data.hash.table->rehash_threshold));
457}
458
459LispObj *
460Lisp_HashTableSize(LispBuiltin *builtin)
461/*
462 hash-table-size hash-table
463 */
464{
465    LispObj *hash_table = ARGUMENT(0);
466
467    CHECK_HASHTABLE(hash_table);
468
469    return (FIXNUM(hash_table->data.hash.table->num_entries));
470}
471
472LispObj *
473Lisp_HashTableTest(LispBuiltin *builtin)
474/*
475 hash-table-test hash-table
476 */
477{
478    LispObj *hash_table = ARGUMENT(0);
479
480    CHECK_HASHTABLE(hash_table);
481
482    return (hash_table->data.hash.test);
483}
484
485LispObj *
486Lisp_Maphash(LispBuiltin *builtin)
487/*
488 maphash function hash-table
489 */
490{
491    long i;
492    LispHashEntry *entry, *last;
493
494    LispObj *function, *hash_table;
495
496    hash_table = ARGUMENT(1);
497    function = ARGUMENT(0);
498
499    CHECK_HASHTABLE(hash_table);
500
501    for (entry = hash_table->data.hash.table->entries,
502	 last = entry + hash_table->data.hash.table->num_entries;
503	 entry < last; entry++) {
504	for (i = 0; i < entry->count; i++)
505	    APPLY2(function, entry->keys[i], entry->values[i]);
506    }
507
508    return (NIL);
509}
510
511LispObj *
512Lisp_MakeHashTable(LispBuiltin *builtin)
513/*
514 make-hash-table &key test size rehash-size rehash-threshold initial-contents
515 */
516{
517    int function = FEQL;
518    unsigned long i, isize, xsize;
519    double drsize, drthreshold;
520    LispHashTable *hash_table;
521    LispObj *cons, *result;
522
523    LispObj *test, *size, *rehash_size, *rehash_threshold, *initial_contents;
524
525    initial_contents = ARGUMENT(4);
526    rehash_threshold = ARGUMENT(3);
527    rehash_size = ARGUMENT(2);
528    size = ARGUMENT(1);
529    test = ARGUMENT(0);
530
531    if (test != UNSPEC) {
532	if (FUNCTIONP(test))
533	    test = test->data.atom->object;
534	if (test == Oeq)
535	    function = FEQ;
536	else if (test == Oeql)
537	    function = FEQL;
538	else if (test == Oequal)
539	    function = FEQUAL;
540	else if (test == Oequalp)
541	    function = FEQUALP;
542	else
543	    LispDestroy("%s: :TEST must be EQ, EQL, EQUAL, "
544			"or EQUALP, not %s", STRFUN(builtin), STROBJ(test));
545    }
546    else
547	test = Oeql;
548
549    if (size != UNSPEC) {
550	CHECK_INDEX(size);
551	isize = FIXNUM_VALUE(size);
552    }
553    else
554	isize = 1;
555
556    if (rehash_size != UNSPEC) {
557	CHECK_DFLOAT(rehash_size);
558	if (DFLOAT_VALUE(rehash_size) <= 1.0)
559	    LispDestroy("%s: :REHASH-SIZE must a float > 1, not %s",
560			STRFUN(builtin), STROBJ(rehash_size));
561	drsize = DFLOAT_VALUE(rehash_size);
562    }
563    else
564	drsize = 1.5;
565
566    if (rehash_threshold != UNSPEC) {
567	CHECK_DFLOAT(rehash_threshold);
568	if (DFLOAT_VALUE(rehash_threshold) < 0.0 ||
569	    DFLOAT_VALUE(rehash_threshold) > 1.0)
570	    LispDestroy("%s: :REHASH-THRESHOLD must a float "
571			"in the range 0.0 - 1.0, not %s",
572			STRFUN(builtin), STROBJ(rehash_threshold));
573	drthreshold = DFLOAT_VALUE(rehash_threshold);
574    }
575    else
576	drthreshold = 0.75;
577
578    if (initial_contents == UNSPEC)
579	initial_contents = NIL;
580    CHECK_LIST(initial_contents);
581    for (xsize = 0, cons = initial_contents;
582	 CONSP(cons);
583	 xsize++, cons = CDR(cons))
584	CHECK_CONS(CAR(cons));
585
586    if (xsize > isize)
587	isize = xsize;
588
589    for (i = 0; i < sizeof(some_primes) / sizeof(some_primes[0]); i++)
590	if (some_primes[i] >= isize) {
591	    isize = some_primes[i];
592	    break;
593	}
594
595    hash_table = LispMalloc(sizeof(LispHashTable));
596    hash_table->entries = LispCalloc(1, sizeof(LispHashEntry) * isize);
597    hash_table->num_entries = isize;
598    hash_table->count = 0;
599    hash_table->function = function;
600    hash_table->rehash_size = drsize;
601    hash_table->rehash_threshold = drthreshold;
602
603    result = LispNew(NIL, NIL);
604    result->type = LispHashTable_t;
605    result->data.hash.table = hash_table;
606    result->data.hash.test = test;
607
608    LispMused(hash_table);
609    LispMused(hash_table->entries);
610
611    if (initial_contents != UNSPEC) {
612	unsigned long key;
613	LispHashEntry *entry;
614
615	for (cons = initial_contents; CONSP(cons); cons = CDR(cons)) {
616	    key = LispHashKey(CAAR(cons), function) % isize;
617	    entry = hash_table->entries + key;
618
619	    if ((entry->count % 4) == 0) {
620		LispObj **keys, **values;
621
622		keys = realloc(entry->keys, sizeof(LispObj*) * (i + 4));
623		if (keys == NULL)
624		    LispDestroy("out of memory");
625		values = realloc(entry->values, sizeof(LispObj*) * (i + 4));
626		if (values == NULL) {
627		    free(keys);
628		    LispDestroy("out of memory");
629		}
630		entry->keys = keys;
631		entry->values = values;
632	    }
633	    entry->keys[entry->count] = CAAR(cons);
634	    entry->values[entry->count] = CDAR(cons);
635	    ++entry->count;
636	}
637	hash_table->count = xsize;
638    }
639
640    return (result);
641}
642
643LispObj *
644Lisp_Remhash(LispBuiltin *builtin)
645/*
646 remhash key hash-table
647 */
648{
649    return (LispHash(builtin, REM_HASH));
650}
651
652LispObj *
653Lisp_XeditPuthash(LispBuiltin *builtin)
654/*
655 lisp::puthash key hash-table value
656 */
657{
658    return (LispHash(builtin, PUT_HASH));
659}
660