1/* BEGIN LICENSE BLOCK 2 * Version: CMPL 1.1 3 * 4 * The contents of this file are subject to the Cisco-style Mozilla Public 5 * License Version 1.1 (the "License"); you may not use this file except 6 * in compliance with the License. You may obtain a copy of the License 7 * at www.eclipse-clp.org/license. 8 * 9 * Software distributed under the License is distributed on an "AS IS" 10 * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 11 * the License for the specific language governing rights and limitations 12 * under the License. 13 * 14 * The Original Code is The ECLiPSe Constraint Logic Programming System. 15 * The Initial Developer of the Original Code is Cisco Systems, Inc. 16 * Portions created by the Initial Developer are 17 * Copyright (C) 1996-2006 Cisco Systems, Inc. All Rights Reserved. 18 * 19 * Contributor(s): 20 * 21 * END LICENSE BLOCK */ 22 23/*---------------------------------------------------------------------- 24 * System: ECLiPSe Constraint Logic Programming System 25 * Version: $Id: bip_store.c,v 1.2 2010/03/19 05:52:16 jschimpf Exp $ 26 * 27 * Contents: Built-ins for the store-primitives 28 * 29 * This file has been factored out of bip_record.c in 05/2006 30 *----------------------------------------------------------------------*/ 31 32#include "config.h" 33#include "sepia.h" 34#include "types.h" 35#include "embed.h" 36#include "error.h" 37#include "mem.h" 38#include "dict.h" 39#include "property.h" 40 41#include <stdio.h> /* for sprintf() */ 42 43/*---------------------------------------------------------------------- 44 * Heap hash tables ("stores") 45 * 46 * A "store" is either identified by an (anonymous) handle, 47 * or it is the (module-local) property of a functor. 48 * Keys must be ground terms, values can be arbitrary terms. 49 * 50 * store_create(-Handle) 51 * argument is uninstantiated, it creates an anonymous store 52 * and returns a handle for it. 53 * local store(+Term) 54 * argument is instantiated (atom or name/arity), it creates a store 55 * as a property (local to the caller module) of the given functor 56 * 57 * All the subsequent predicates take a Store argument which is either 58 * a handle or a term whose functor identifies the store. 59 * 60 * store_set(+Store, ++Key, +Value) is det 61 * add or replace an entry for Key 62 * 63 * store_inc(+Store, ++Key) is det 64 * increment an existing integer entry, or initialise to 1 65 * 66 * store_get(+Store, ++Key, -Value) is semidet 67 * get the entry for Key, or fail 68 * 69 * store_delete(+Store, ++Key) is det 70 * delete the entry for key, if any 71 * 72 * store_contains(+Store, ++Key) is semidet 73 * succeed if Store contains an entry for Key 74 * 75 * stored_keys(+Store, -Keys) 76 * get a list of all keys in Store 77 * 78 * stored_keys_and_values(+Store, -KeysValues) 79 * get a list of all Key-Value pairs 80 * 81 * store_erase(+Store) is det 82 * delete all entries 83 * 84 * store_count(+Store, -Count) is det 85 * get number of entries 86 * 87 * current_store(+Store) is det 88 * current_store(-Store) is nondet 89 * get/check named stores 90 * 91 * 92 * Following the naming scheme of lib(m_map) we could redundantly have: 93 * 94 * store_insert(+Store, ++Key, +Value) is semidet 95 * fail if already in store 96 * store_det_insert(+Store, ++Key, +Value) is det 97 * abort if already in store 98 * store_update(+Store, ++Key, +Value) is semidet 99 * fail if not already in store 100 * store_det_update(+Store, ++Key, +Value) is det 101 * abort if not already in store 102 * store_lookup(+Store, ++Key, -Value) is det 103 * abort if not in store 104 * store_remove(+Store, ++Key, -Value) is semidet 105 * get+delete, fail if not in store 106 * store_det_remove(+Store, ++Key, -Value) is det 107 * get+delete, abort if not in store 108 *----------------------------------------------------------------------*/ 109 110#define HTABLE_MIN_SIZE 16 111#define HTABLE_MAX_SIZE 1048576 112#define HTABLE_EXPAND_FACTOR 4 113 114 115/* METHODS */ 116 117void htable_free(t_heap_htable *obj); 118static t_heap_htable * _copy_heap_htable(t_heap_htable *obj); 119static void _mark_heap_htable(t_heap_htable *obj); 120static int _tostr_heap_htable(t_heap_htable *obj, char *buf, int quoted); 121static int _strsz_heap_htable(t_heap_htable *obj, int quoted); 122 123 124/* CLASS DESCRIPTOR (method table) */ 125 126t_ext_type heap_htable_tid = { 127 (void (*)(t_ext_ptr)) htable_free, 128 (t_ext_ptr (*)(t_ext_ptr)) _copy_heap_htable, 129 (void (*)(t_ext_ptr)) _mark_heap_htable, 130 (int (*)(t_ext_ptr,int)) _strsz_heap_htable, 131 (int (*)(t_ext_ptr,char *,int)) _tostr_heap_htable, 132 0, /* equal */ 133 (t_ext_ptr (*)(t_ext_ptr)) _copy_heap_htable, 134 0, /* get */ 135 0 /* set */ 136}; 137 138 139/* PROLOG INTERFACE */ 140 141/* 142 * Get a pointer to the hash table either from a handle 143 * or from the HTABLE_PROP property of a functor 144 */ 145#define Get_Heap_Htable(vhandle, thandle, vmod, tmod, obj) \ 146 if (IsTag(thandle.kernel, THANDLE)) { \ 147 Get_Typed_Object(vhandle, thandle, &heap_htable_tid, obj); \ 148 } else { \ 149 dident name_did; \ 150 int err; \ 151 pword *prop; \ 152 Get_Key_Did(name_did, vhandle, thandle); \ 153 prop = get_modular_property(name_did, HTABLE_PROP, vmod.did, tmod, LOCAL_PROP, &err); \ 154 if (!prop) { \ 155 Bip_Error(err == PERROR ? NO_LOCAL_REC : err); \ 156 } \ 157 obj = (t_heap_htable *) prop->val.wptr; \ 158 } 159 160 161t_heap_htable * 162htable_new(int internal) 163{ 164 t_heap_htable *obj; 165 uword i; 166 167 /* INSTANCE INITIALISATION */ 168 if (internal) { 169 obj = (t_heap_htable *) 170 hp_alloc_size(sizeof(t_heap_htable)); 171 obj->htable = (t_htable_elem **) 172 hp_alloc_size(HTABLE_MIN_SIZE * sizeof(t_htable_elem *)); 173 } else { 174 obj = (t_heap_htable *) 175 hg_alloc_size(sizeof(t_heap_htable)); 176 obj->htable = (t_htable_elem **) 177 hg_alloc_size(HTABLE_MIN_SIZE * sizeof(t_htable_elem *)); 178 } 179 180 obj->internal = internal; 181 obj->ref_ctr = 1; 182 obj->size = HTABLE_MIN_SIZE; 183 obj->nentries = 0; 184 for (i = 0; i < obj->size; ++i) 185 { 186 obj->htable[i] = NULL; 187 } 188 return obj; 189} 190 191 192static int 193p_is_store(value vhandle, type thandle, value vmod, type tmod) 194{ 195 int err; 196 pword *prop; 197 dident name_did; 198 199 Get_Key_Did(name_did, vhandle, thandle); 200 prop = get_modular_property(name_did, HTABLE_PROP, vmod.did, tmod, LOCAL_PROP, &err); 201 Succeed_If(prop); 202} 203 204 205static int 206p_store_create(value vhtable, type thtable) 207{ 208 pword htable; 209 210 Check_Ref(thtable); 211 htable = ec_handle(&heap_htable_tid, (t_ext_ptr) htable_new(0)); 212 Return_Unify_Pw(vhtable, thtable, htable.val, htable.tag); 213} 214 215 216static int 217p_store_create_named(value vhtable, type thtable, value vmod, type tmod) 218{ 219 pword *prop; 220 dident name_did; 221 int err; 222 223 Get_Functor_Did(vhtable, thtable, name_did); 224 prop = set_modular_property(name_did, HTABLE_PROP, vmod.did, tmod, 225 LOCAL_PROP, &err); 226 if (prop) 227 { 228 prop->tag.kernel = TPTR; 229 prop->val.wptr = (uword *) htable_new(0); 230 Succeed_; 231 } 232 else if (err == PERROR) 233 { 234 Succeed_; 235 } 236 else 237 { 238 Bip_Error(err); 239 } 240 241} 242 243 244/* 245 * Grow the hash table by HTABLE_EXPAND_FACTOR 246 */ 247 248static void 249_htable_expand(t_heap_htable *obj) 250{ 251 uword new_size = obj->size * HTABLE_EXPAND_FACTOR; 252 t_htable_elem **new_htable; 253 uword i; 254 255 /* make and initialize a larger table */ 256 if (obj->internal) { 257 new_htable = (t_htable_elem **) 258 hp_alloc_size(new_size * sizeof(t_htable_elem *)); 259 } 260 else { 261 new_htable = (t_htable_elem **) 262 hg_alloc_size(new_size * sizeof(t_htable_elem *)); 263 } 264 265 for (i = 0; i < new_size; ++i) 266 { 267 new_htable[i] = NULL; 268 } 269 270 /* redistribute the entries from the old table */ 271 for (i = 0; i < obj->size; ++i) 272 { 273 t_htable_elem *elem; 274 for(elem = obj->htable[i]; elem; ) 275 { 276 t_htable_elem **new_slot = &new_htable[elem->hash % new_size]; 277 t_htable_elem *next_elem = elem->next; 278 elem->next = *new_slot; 279 *new_slot = elem; 280 elem = next_elem; 281 } 282 } 283 284 /* free the old table */ 285 if (obj->internal) { 286 hp_free_size(obj->htable, obj->size * sizeof(t_htable_elem *)); 287 } 288 else { 289 hg_free_size(obj->htable, obj->size * sizeof(t_htable_elem *)); 290 } 291 292 /* assign the new one */ 293 obj->htable = new_htable; 294 obj->size = new_size; 295} 296 297 298/* 299 * Auxiliary function to look up vkey/tkey with hash value hash 300 */ 301 302static t_htable_elem * 303_htable_find(t_heap_htable *obj, uword hash, value vkey, type tkey, t_htable_elem ***ppslot) 304{ 305 t_htable_elem *pelem; 306 t_htable_elem **pslot; 307 pslot = &obj->htable[hash % obj->size]; 308 for(pelem = *pslot; pelem; pslot = &pelem->next, pelem = *pslot) 309 { 310 if (pelem->hash == hash 311 && ec_compare_terms(vkey, tkey, pelem->key.val, pelem->key.tag) == 0) 312 { 313 *ppslot = pslot; 314 return pelem; 315 } 316 } 317 *ppslot = pslot; 318 return NULL; 319} 320 321 322/* 323 * store_set(+Handle, +Key, +Value) 324 * add or replace an entry for Key 325 * 326 * we could have variants of this which 327 * - fail if key already exists 328 * - add another entry for key (saves the lookup) 329 */ 330 331static int 332p_store_set(value vhandle, type thandle, value vkey, type tkey, value vval, type tval, value vmod, type tmod) 333{ 334 t_heap_htable *obj; 335 uword hash; 336 pword copy_key, copy_value; 337 t_htable_elem **pslot; 338 t_htable_elem *pelem; 339 int res = PSUCCEED; 340 341 Get_Heap_Htable(vhandle, thandle, vmod, tmod, obj); 342 hash = ec_term_hash(vkey, tkey, MAX_U_WORD, &res); 343 if (res != PSUCCEED) 344 { 345 Bip_Error(res); 346 } 347 348 pelem = _htable_find(obj, hash, vkey, tkey, &pslot); 349 if (pelem) /* an entry for key exists already */ 350 { 351 pword copy_value; 352 if ((res = create_heapterm(©_value, vval, tval)) != PSUCCEED) 353 { 354 Bip_Error(res); 355 } 356 free_heapterm(&pelem->value); 357 move_heapterm(©_value, &pelem->value); 358 } 359 else /* make a new entry for key */ 360 { 361 pelem = (t_htable_elem *) hg_alloc_size(sizeof(t_htable_elem)); 362 pelem->hash = hash; 363 if ((res = create_heapterm(&pelem->key, vkey, tkey)) != PSUCCEED) 364 { 365 hg_free_size(pelem, sizeof(t_htable_elem)); 366 Bip_Error(res); 367 } 368 if ((res = create_heapterm(&pelem->value, vval, tval)) != PSUCCEED) 369 { 370 free_heapterm(&pelem->key); 371 hg_free_size(pelem, sizeof(t_htable_elem)); 372 Bip_Error(res); 373 } 374 pelem->next = *pslot; 375 *pslot = pelem; 376 ++obj->nentries; 377 378 /* expand table if too full */ 379 if (obj->nentries > obj->size && obj->size < HTABLE_MAX_SIZE) 380 { 381 _htable_expand(obj); 382 } 383 } 384 Succeed_; 385} 386 387 388static int 389p_store_inc(value vhandle, type thandle, value vkey, type tkey, value vmod, type tmod) 390{ 391 t_heap_htable *obj; 392 uword hash; 393 pword copy_key, copy_value; 394 t_htable_elem **pslot; 395 t_htable_elem *pelem; 396 int res = PSUCCEED; 397 398 Get_Heap_Htable(vhandle, thandle, vmod, tmod, obj); 399 hash = ec_term_hash(vkey, tkey, MAX_U_WORD, &res); 400 if (res != PSUCCEED) 401 { 402 Bip_Error(res); 403 } 404 405 pelem = _htable_find(obj, hash, vkey, tkey, &pslot); 406 if (pelem) /* an entry for key exists already */ 407 { 408 Check_Integer(pelem->value.tag); 409 if (pelem->value.val.nint == MAX_S_WORD) 410 { 411 Bip_Error(RANGE_ERROR); 412 } 413 ++pelem->value.val.nint; /* increment */ 414 } 415 else /* make a new entry for key */ 416 { 417 pelem = (t_htable_elem *) hg_alloc_size(sizeof(t_htable_elem)); 418 pelem->hash = hash; 419 if ((res = create_heapterm(&pelem->key, vkey, tkey)) != PSUCCEED) 420 { 421 hg_free_size(pelem, sizeof(t_htable_elem)); 422 Bip_Error(res); 423 } 424 Make_Integer(&pelem->value, 1); /* initialise to 1 */ 425 pelem->next = *pslot; 426 *pslot = pelem; 427 ++obj->nentries; 428 429 /* expand table if too full */ 430 if (obj->nentries > obj->size && obj->size < HTABLE_MAX_SIZE) 431 { 432 _htable_expand(obj); 433 } 434 } 435 Succeed_; 436} 437 438 439static int 440p_store_contains(value vhandle, type thandle, value vkey, type tkey, value vmod, type tmod) 441{ 442 t_heap_htable *obj; 443 t_htable_elem *pelem; 444 t_htable_elem **pslot; 445 uword hash; 446 int res = PSUCCEED; 447 448 Get_Heap_Htable(vhandle, thandle, vmod, tmod, obj); 449 hash = ec_term_hash(vkey, tkey, MAX_U_WORD, &res); 450 if (res != PSUCCEED) 451 { 452 Bip_Error(res); 453 } 454 Succeed_If(_htable_find(obj, hash, vkey, tkey, &pslot)); 455} 456 457 458static int 459p_store_get(value vhandle, type thandle, value vkey, type tkey, value vval, type tval, value vmod, type tmod) 460{ 461 t_heap_htable *obj; 462 t_htable_elem *pelem; 463 t_htable_elem **pslot; 464 pword elem_value; 465 uword hash; 466 int res = PSUCCEED; 467 468 Get_Heap_Htable(vhandle, thandle, vmod, tmod, obj); 469 hash = ec_term_hash(vkey, tkey, MAX_U_WORD, &res); 470 if (res != PSUCCEED) 471 { 472 Bip_Error(res); 473 } 474 pelem = _htable_find(obj, hash, vkey, tkey, &pslot); 475 if (!pelem) 476 { 477 Fail_; 478 } 479 get_heapterm(&pelem->value, &elem_value); 480 if (IsRef(elem_value.tag) && elem_value.val.ptr == &elem_value) 481 { 482 Succeed_; 483 } 484 Return_Unify_Pw(vval, tval, elem_value.val, elem_value.tag); 485} 486 487 488static int 489p_store_delete(value vhandle, type thandle, value vkey, type tkey, value vmod, type tmod) 490{ 491 t_heap_htable *obj; 492 t_htable_elem *pelem; 493 t_htable_elem **pslot; 494 uword hash; 495 int res = PSUCCEED; 496 497 Get_Heap_Htable(vhandle, thandle, vmod, tmod, obj); 498 hash = ec_term_hash(vkey, tkey, MAX_U_WORD, &res); 499 if (res != PSUCCEED) 500 { 501 Bip_Error(res); 502 } 503 pelem = _htable_find(obj, hash, vkey, tkey, &pslot); 504 if (pelem) 505 { 506 *pslot = pelem->next; /* unlink element */ 507 free_heapterm(&pelem->key); 508 free_heapterm(&pelem->value); 509 hg_free_size(pelem, sizeof(t_htable_elem)); 510 --obj->nentries; 511 } 512 Succeed_; 513} 514 515 516static int 517p_store_count(value vhandle, type thandle, value vn, type tn, value vmod, type tmod) 518{ 519 t_heap_htable *obj; 520 Get_Heap_Htable(vhandle, thandle, vmod, tmod, obj); 521 Return_Unify_Integer(vn, tn, obj->nentries); 522} 523 524 525static int 526p_store_info(value vhandle, type thandle, value vmod, type tmod) 527{ 528 t_heap_htable *obj; 529 uword entry_count = 0; 530 uword max_chain = 0; 531 uword used_slots = 0; 532 uword i; 533 534 Get_Heap_Htable(vhandle, thandle, vmod, tmod, obj); 535 536 for(i = 0; i < obj->size; ++i) 537 { 538 uword chain_length = 0; 539 t_htable_elem *pelem = obj->htable[i]; 540 if (pelem) 541 ++used_slots; 542 for(; pelem; pelem = pelem->next) 543 ++chain_length; 544 entry_count += chain_length; 545 if (chain_length > max_chain) 546 max_chain = chain_length; 547 } 548 549 p_fprintf(current_err_, "\nStore at 0x%08x", obj); 550 p_fprintf(current_err_, "\nref_ctr %d", obj->ref_ctr); 551 p_fprintf(current_err_, "\nsize %d", obj->size); 552 p_fprintf(current_err_, "\nnentries %d", obj->nentries); 553 p_fprintf(current_err_, "\nused slots %d", used_slots); 554 p_fprintf(current_err_, "\nmax chain %d", max_chain); 555 p_fprintf(current_err_, "\navg chain %f", ((double) entry_count)/used_slots); 556 if (entry_count != obj->nentries) 557 p_fprintf(current_err_, "\n!!! Deviating entry count %d", entry_count); 558 ec_newline(current_err_); 559 Succeed_; 560} 561 562 563static int 564p_stored_keys(value vhandle, type thandle, value vresult, type tresult, value vmod, type tmod) 565{ 566 t_heap_htable *obj; 567 t_htable_elem *pelem; 568 uword i; 569 pword result, *ptail; 570 571 Get_Heap_Htable(vhandle, thandle, vmod, tmod, obj); 572 ptail = &result; 573 for(i = 0; i < obj->size; ++i) 574 { 575 for(pelem = obj->htable[i]; pelem; pelem = pelem->next) 576 { 577 pword *pw = TG; 578 Make_List(ptail, pw); 579 Push_List_Frame(); 580 ptail = pw+1; 581 get_heapterm(&pelem->key, pw); 582 } 583 } 584 Make_Nil(ptail); 585 Return_Unify_Pw(vresult, tresult, result.val, result.tag); 586} 587 588 589static int 590p_stored_keys_and_values(value vhandle, type thandle, value vresult, type tresult, value vmod, type tmod) 591{ 592 t_heap_htable *obj; 593 t_htable_elem *pelem; 594 uword i; 595 pword result, *ptail; 596 597 Get_Heap_Htable(vhandle, thandle, vmod, tmod, obj); 598 ptail = &result; 599 for(i = 0; i < obj->size; ++i) 600 { 601 for(pelem = obj->htable[i]; pelem; pelem = pelem->next) 602 { 603 pword *pw = TG; 604 Make_List(ptail, pw); 605 Push_List_Frame(); 606 ptail = pw+1; 607 Make_Struct(pw, TG); 608 pw = TG; 609 Push_Struct_Frame(d_.minus); 610 get_heapterm(&pelem->key, pw+1); 611 get_heapterm(&pelem->value, pw+2); 612 } 613 } 614 Make_Nil(ptail); 615 Return_Unify_Pw(vresult, tresult, result.val, result.tag); 616} 617 618 619static void 620_htable_erase(t_heap_htable *obj) 621{ 622 uword i; 623 for(i = 0; i < obj->size; ++i) 624 { 625 t_htable_elem *elem = obj->htable[i]; 626 if (elem) 627 { 628 obj->htable[i] = NULL; 629 do { 630 t_htable_elem *next_elem = elem->next; 631 if (obj->internal) { 632 hp_free_size(elem, sizeof(t_htable_elem)); 633 } else { 634 free_heapterm(&elem->key); 635 free_heapterm(&elem->value); 636 hg_free_size(elem, sizeof(t_htable_elem)); 637 } 638 elem = next_elem; 639#ifdef DEBUG_RECORD 640 p_fprintf(current_err_, "\nfree element"); 641 ec_flush(current_err_); 642#endif 643 } while(elem); 644 } 645 } 646 obj->nentries = 0; 647} 648 649 650static int 651p_store_erase(value vhandle, type thandle, value vmod, type tmod) 652{ 653 t_heap_htable *obj; 654 655 Get_Heap_Htable(vhandle, thandle, vmod, tmod, obj); 656 _htable_erase(obj); 657 Succeed_; 658} 659 660 661void 662htable_free(t_heap_htable *obj) /* obj != NULL */ 663{ 664#ifdef DEBUG_RECORD 665 p_fprintf(current_err_, "\nlosing reference to htable(0x%x)", obj); 666 ec_flush(current_err_); 667#endif 668 if (--obj->ref_ctr <= 0) 669 { 670 _htable_erase(obj); 671 if (obj->internal) { 672 hp_free_size(obj->htable, obj->size * sizeof(t_htable_elem *)); 673 hp_free_size(obj, sizeof(t_heap_htable)); 674 } else { 675 hg_free_size(obj->htable, obj->size * sizeof(t_htable_elem *)); 676 hg_free_size(obj, sizeof(t_heap_htable)); 677 } 678#ifdef DEBUG_RECORD 679 p_fprintf(current_err_, "\nhtable_free(0x%x)", obj); 680 ec_flush(current_err_); 681#endif 682 } 683} 684 685 686static t_heap_htable * 687_copy_heap_htable(t_heap_htable *obj) /* obj != NULL */ 688{ 689 ++obj->ref_ctr; 690 return obj; 691} 692 693 694static void 695_mark_heap_htable(t_heap_htable *obj) /* obj != NULL */ 696{ 697 uword i; 698#ifdef DEBUG_RECORD 699 p_fprintf(current_err_, "\n_mark_heap_htable(0x%x)", obj); 700 ec_flush(current_err_); 701#endif 702 for(i = 0; i < obj->size; ++i) 703 { 704 t_htable_elem *elem; 705 for(elem = obj->htable[i]; elem; elem = elem->next) 706 { 707 mark_dids_from_heapterm(&elem->key); 708 mark_dids_from_heapterm(&elem->value); 709 } 710 } 711} 712 713 714static int 715_tostr_heap_htable(t_heap_htable *obj, char *buf, int quoted) /* obj != NULL */ 716{ 717#define STRSZ_STORE 20 718 sprintf(buf, "'STORE'(16'%08x)", (int)(word) obj); /* possibly truncated */ 719 return STRSZ_STORE; 720} 721 722 723static int 724_strsz_heap_htable(t_heap_htable *obj, int quoted) /* obj != NULL */ 725{ 726 return STRSZ_STORE; 727} 728 729 730/*---------------------------------------------------------------------- 731 * Short-lived hash tables based upon the store_*() routines. 732 * The tables are used internally by ECLipSe and must be explicitly 733 * allocated/deallocated. 734 *----------------------------------------------------------------------*/ 735 736/* 737 * store_set(obj, vkey, tkey, valpw) 738 * Store the target of pword pointer 'valpw' in the store 'obj' 739 * for the key with value 'vkey' and type 'tkey'. A heap copy 740 * of the target of 'valpw' is not made - it is assumed suitable 741 * allocation has already been performed. 742 * 743 * This routine adds an element to the store, assuming that no 744 * entry for the given key exists. 745 */ 746 747int 748store_set(t_heap_htable *obj, value vkey, type tkey, pword *valpw) 749{ 750 t_htable_elem *pelem; 751 t_htable_elem **pslot; 752 uword hash; 753 int res = PSUCCEED; 754 755 hash = ec_term_hash(vkey, tkey, MAX_U_WORD, &res); 756 if (res != PSUCCEED) { 757 Bip_Error(res); 758 } 759 760 /* Store the element */ 761 pelem = (t_htable_elem *) hp_alloc_size(sizeof(t_htable_elem)); 762 pelem->hash = hash; 763 pelem->key.val = vkey; 764 pelem->key.tag = tkey; 765 pelem->value = *valpw; 766 pslot = &obj->htable[hash % obj->size]; 767 pelem->next = *pslot; 768 *pslot = pelem; 769 ++obj->nentries; 770 771 /* expand table if too full */ 772 if (obj->nentries > obj->size && obj->size < HTABLE_MAX_SIZE) { 773 _htable_expand(obj); 774 } 775 Succeed_; 776} 777 778/* 779 * store_get(obj, vkey, tkey, valpw) 780 * Return a pword reference 'valpw' to the element referenced by 781 * the store 'obj' with key value 'vkey' and key type 'tkey'. A 782 * global stack copy of the target of 'valpw' is not made. 783 * 784 * This routine retrieves an element from the store, assuming that an 785 * entry exists for the given key. 786 */ 787 788int 789store_get(t_heap_htable *obj, value vkey, type tkey, pword *valpw) 790{ 791 t_htable_elem *pelem; 792 t_htable_elem **pslot; 793 uword hash; 794 int res = PSUCCEED; 795 796 hash = ec_term_hash(vkey, tkey, MAX_U_WORD, &res); 797 if (res != PSUCCEED) { 798 Bip_Error(res); 799 } 800 pelem = _htable_find(obj, hash, vkey, tkey, &pslot); 801 if (pelem) { 802 *valpw = pelem->value; 803 Succeed_; 804 } 805 806 Fail_; 807} 808 809/* Fail_ is not found but successfully entered in table! */ 810/* 811 * store_get_else_set(obj, vkey, tkey, valpw) 812 * Return a pword reference 'valpw' to the element referenced by 813 * the store 'obj' with key value 'vkey' and key type 'tkey'. A 814 * global stack copy of the target of 'valpw' is not made. 815 * 816 * This routine retrieves an element from the store, if an 817 * entry exists for the given key. If it does, the routine 818 * returns 'PSUCCEED'. 819 * If no entry exists, then the target of pword pointer 'valpw' is 820 * stored in the store 'obj' for the key with value 'vkey' and 821 * type 'tkey'. A heap copy of the target of 'valpw' is not made 822 * - it is assumed suitable allocation has already been performed. 823 * In this case, the entry is created and the routine returns 'PFAIL'. 824 */ 825 826 827int 828store_get_else_set(t_heap_htable *obj, value vkey, type tkey, pword *valpw) 829{ 830 t_htable_elem *pelem; 831 t_htable_elem **pslot; 832 uword hash; 833 int res = PSUCCEED; 834 835 hash = ec_term_hash(vkey, tkey, MAX_U_WORD, &res); 836 if (res != PSUCCEED) { 837 Bip_Error(res); 838 } 839 pelem = _htable_find(obj, hash, vkey, tkey, &pslot); 840 if (pelem) { 841 *valpw = pelem->value; 842 Succeed_; 843 } 844 845 /* Store the element */ 846 pelem = (t_htable_elem *) hp_alloc_size(sizeof(t_htable_elem)); 847 pelem->hash = hash; 848 pelem->key.val = vkey; 849 pelem->key.tag = tkey; 850 pelem->value = *valpw; 851 pelem->next = *pslot; 852 *pslot = pelem; 853 ++obj->nentries; 854 855 /* expand table if too full */ 856 if (obj->nentries > obj->size && obj->size < HTABLE_MAX_SIZE) { 857 _htable_expand(obj); 858 } 859 Fail_; 860} 861 862 863/*---------------------------------------------------------------------- 864 * Initialisation 865 *----------------------------------------------------------------------*/ 866 867void 868bip_store_init(int flags) 869{ 870 if (flags & INIT_SHARED) 871 { 872 (void) built_in(in_dict("store_create", 1), p_store_create, B_SAFE|U_SIMPLE); 873 (void) built_in(in_dict("store_create_named_", 2), p_store_create_named, B_SAFE|U_SIMPLE); 874 (void) built_in(in_dict("store_count_", 3), p_store_count, B_SAFE); 875 (void) built_in(in_dict("store_erase_", 2), p_store_erase, B_SAFE); 876 (void) built_in(in_dict("store_set_",4), p_store_set, B_SAFE); 877 (void) built_in(in_dict("store_delete_",3), p_store_delete, B_SAFE); 878 (void) built_in(in_dict("store_contains_",3), p_store_contains, B_SAFE); 879 (void) local_built_in(in_dict("is_store_",2), p_is_store, B_SAFE); 880 (void) built_in(in_dict("store_inc_",3), p_store_inc, B_SAFE); 881 (void) built_in(in_dict("store_info_",2), p_store_info, B_SAFE); 882 (void) built_in(in_dict("store_get_",4), p_store_get, B_UNSAFE|U_FRESH); 883 built_in(in_dict("stored_keys_",3), p_stored_keys, B_UNSAFE|U_FRESH) 884 ->mode = BoundArg(2,GROUND); 885 (void) built_in(in_dict("stored_keys_and_values_",3), p_stored_keys_and_values, B_UNSAFE|U_FRESH); 886 } 887} 888 889