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 Csar 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 */ 47 static unsigned long LispHashKey(LispObj*, int); 48 static LispObj *LispHash(LispBuiltin*, int); 49 static void LispRehash(LispHashTable*); 50 static void LispFreeHashEntries(LispHashEntry*, long); 51 52 /* 53 * Initialization 54 */ 55 extern LispObj *Oeq, *Oeql, *Oequal, *Oequalp; 56 57 /* Hash tables will have one of these sizes, unless the user 58 * specified a very large size */ 59 static 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 */ 70 static unsigned long 71 LispHashKey(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 175 hash_key_done: 176 return (key); 177 } 178 179 static LispObj * 180 LispHash(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 236 found_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 300 static void 301 LispRehash(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 349 out_of_memory: 350 if (entries) 351 LispFreeHashEntries(entries, size); 352 LispDestroy("out of memory"); 353 } 354 355 static void 356 LispFreeHashEntries(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 367 void 368 LispFreeHashTable(LispHashTable *hash) 369 { 370 LispFreeHashEntries(hash->entries, hash->num_entries); 371 free(hash); 372 } 373 374 LispObj * 375 Lisp_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 400 LispObj * 401 Lisp_Gethash(LispBuiltin *builtin) 402 /* 403 gethash key hash-table &optional default 404 */ 405 { 406 return (LispHash(builtin, GET_HASH)); 407 } 408 409 LispObj * 410 Lisp_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 420 LispObj * 421 Lisp_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 433 LispObj * 434 Lisp_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 446 LispObj * 447 Lisp_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 459 LispObj * 460 Lisp_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 472 LispObj * 473 Lisp_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 485 LispObj * 486 Lisp_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 511 LispObj * 512 Lisp_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 643 LispObj * 644 Lisp_Remhash(LispBuiltin *builtin) 645 /* 646 remhash key hash-table 647 */ 648 { 649 return (LispHash(builtin, REM_HASH)); 650 } 651 652 LispObj * 653 Lisp_XeditPuthash(LispBuiltin *builtin) 654 /* 655 lisp::puthash key hash-table value 656 */ 657 { 658 return (LispHash(builtin, PUT_HASH)); 659 } 660
Indexes created Wed Aug 19 00:25:20 UTC 2026