libguile/hashtab.c

   1 /*      Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45 #include "alist.h"
  46 #include "hash.h"
  47 #include "eval.h"
  48
  49 #include "hashtab.h"
  50 \f
  51
  52
  53 SCM
  54 scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure)
  55      SCM table;
  56      SCM obj;
  57      unsigned int (*hash_fn)();
  58      SCM (*assoc_fn)();
  59      void * closure;
  60 {
  61   unsigned int k;
  62   SCM h;
  63
  64   SCM_ASSERT (SCM_NIMP (table) && SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_get_handle");
  65   if (SCM_LENGTH (table) == 0)
  66     return SCM_EOL;
  67   k = hash_fn (obj, SCM_LENGTH (table), closure);
  68   SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)),
  69               scm_ulong2num (k),
  70               SCM_OUTOFRANGE,
  71               "hash_fn_get_handle");
  72   h = assoc_fn (obj, SCM_VELTS (table)[k], closure);
  73   return h;
  74 }
  75
  76
  77
  78 SCM
  79 scm_hash_fn_create_handle_x (table, obj, init, hash_fn, assoc_fn, closure)
  80      SCM table;
  81      SCM obj;
  82      SCM init;
  83      unsigned int (*hash_fn)();
  84      SCM (*assoc_fn)();
  85      void * closure;
  86 {
  87   unsigned int k;
  88   SCM it;
  89
  90   SCM_ASSERT (SCM_NIMP (table) && SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_create_handle_x");
  91   if (SCM_LENGTH (table) == 0)
  92     return SCM_EOL;
  93   k = hash_fn (obj, SCM_LENGTH (table), closure);
  94   SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)),
  95               scm_ulong2num (k),
  96               SCM_OUTOFRANGE,
  97               "hash_fn_create_handle_x");
  98   SCM_REDEFER_INTS;
  99   it = assoc_fn (obj, SCM_VELTS (table)[k], closure);
 100   if (SCM_NIMP (it))
 101     {
 102       return it;
 103     }
 104   {
 105     SCM new_bucket;
 106     SCM old_bucket;
 107     old_bucket = SCM_VELTS (table)[k];
 108     new_bucket = scm_acons (obj, init, old_bucket);
 109     SCM_VELTS(table)[k] = new_bucket;
 110     SCM_REALLOW_INTS;
 111     return SCM_CAR (new_bucket);
 112   }
 113 }
 114
 115
 116
 117
 118 SCM
 119 scm_hash_fn_ref (table, obj, dflt, hash_fn, assoc_fn, closure)
 120      SCM table;
 121      SCM obj;
 122      SCM dflt;
 123      unsigned int (*hash_fn)();
 124      SCM (*assoc_fn)();
 125      void * closure;
 126 {
 127   SCM it;
 128
 129   it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure);
 130   if (SCM_IMP (it))
 131     return dflt;
 132   else
 133     return SCM_CDR (it);
 134 }
 135
 136
 137
 138
 139 SCM
 140 scm_hash_fn_set_x (table, obj, val, hash_fn, assoc_fn, closure)
 141      SCM table;
 142      SCM obj;
 143      SCM val;
 144      unsigned int (*hash_fn)();
 145      SCM (*assoc_fn)();
 146      void * closure;
 147 {
 148   SCM it;
 149
 150   it = scm_hash_fn_create_handle_x (table, obj, SCM_BOOL_F, hash_fn, assoc_fn, closure);
 151   SCM_SETCDR (it, val);
 152   return val;
 153 }
 154
 155
 156
 157
 158
 159 SCM
 160 scm_hash_fn_remove_x (table, obj, hash_fn, assoc_fn, delete_fn, closure)
 161      SCM table;
 162      SCM obj;
 163      unsigned int (*hash_fn)();
 164      SCM (*assoc_fn)();
 165      SCM (*delete_fn)();
 166      void * closure;
 167 {
 168   unsigned int k;
 169   SCM h;
 170
 171   SCM_ASSERT (SCM_NIMP (table) && SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_remove_x");
 172   if (SCM_LENGTH (table) == 0)
 173     return SCM_EOL;
 174   k = hash_fn (obj, SCM_LENGTH (table), closure);
 175   SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)),
 176               scm_ulong2num (k),
 177               SCM_OUTOFRANGE,
 178               "hash_fn_remove_x");
 179   h = assoc_fn (obj, SCM_VELTS (table)[k], closure);
 180   SCM_VELTS(table)[k] = delete_fn (h, SCM_VELTS(table)[k]);
 181   return h;
 182 }
 183
 184
 185 \f
 186
 187 SCM_PROC (s_hashq_get_handle, "hashq-get-handle", 2, 0, 0, scm_hashq_get_handle);
 188
 189 SCM
 190 scm_hashq_get_handle (table, obj)
 191      SCM table;
 192      SCM obj;
 193 {
 194   return scm_hash_fn_get_handle (table, obj, scm_ihashq, scm_sloppy_assq, 0);
 195 }
 196
 197
 198 SCM_PROC (s_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0, scm_hashq_create_handle_x);
 199
 200 SCM
 201 scm_hashq_create_handle_x (table, obj, init)
 202      SCM table;
 203      SCM obj;
 204      SCM init;
 205 {
 206   return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashq, scm_sloppy_assq, 0);
 207 }
 208
 209
 210 SCM_PROC (s_hashq_ref, "hashq-ref", 2, 1, 0, scm_hashq_ref);
 211
 212 SCM
 213 scm_hashq_ref (table, obj, dflt)
 214      SCM table;
 215      SCM obj;
 216      SCM dflt;
 217 {
 218   if (dflt == SCM_UNDEFINED)
 219     dflt = SCM_BOOL_F;
 220   return scm_hash_fn_ref (table, obj, dflt, scm_ihashq, scm_sloppy_assq, 0);
 221 }
 222
 223
 224
 225 SCM_PROC (s_hashq_set_x, "hashq-set!", 3, 0, 0, scm_hashq_set_x);
 226
 227 SCM
 228 scm_hashq_set_x (table, obj, val)
 229      SCM table;
 230      SCM obj;
 231      SCM val;
 232 {
 233   return scm_hash_fn_set_x (table, obj, val, scm_ihashq, scm_sloppy_assq, 0);
 234 }
 235
 236
 237
 238 SCM_PROC (s_hashq_remove_x, "hashq-remove!", 2, 0, 0, scm_hashq_remove_x);
 239
 240 SCM
 241 scm_hashq_remove_x (table, obj)
 242      SCM table;
 243      SCM obj;
 244 {
 245   return scm_hash_fn_remove_x (table, obj, scm_ihashq, scm_sloppy_assq, scm_delq_x, 0);
 246 }
 247
 248
 249 \f
 250
 251 SCM_PROC (s_hashv_get_handle, "hashv-get-handle", 2, 0, 0, scm_hashv_get_handle);
 252
 253 SCM
 254 scm_hashv_get_handle (table, obj)
 255      SCM table;
 256      SCM obj;
 257 {
 258   return scm_hash_fn_get_handle (table, obj, scm_ihashv, scm_sloppy_assv, 0);
 259 }
 260
 261
 262 SCM_PROC (s_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, scm_hashv_create_handle_x);
 263
 264 SCM
 265 scm_hashv_create_handle_x (table, obj, init)
 266      SCM table;
 267      SCM obj;
 268      SCM init;
 269 {
 270   return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashv, scm_sloppy_assv, 0);
 271 }
 272
 273
 274 SCM_PROC (s_hashv_ref, "hashv-ref", 2, 1, 0, scm_hashv_ref);
 275
 276 SCM
 277 scm_hashv_ref (table, obj, dflt)
 278      SCM table;
 279      SCM obj;
 280      SCM dflt;
 281 {
 282   if (dflt == SCM_UNDEFINED)
 283     dflt = SCM_BOOL_F;
 284   return scm_hash_fn_ref (table, obj, dflt, scm_ihashv, scm_sloppy_assv, 0);
 285 }
 286
 287
 288
 289 SCM_PROC (s_hashv_set_x, "hashv-set!", 3, 0, 0, scm_hashv_set_x);
 290
 291 SCM
 292 scm_hashv_set_x (table, obj, val)
 293      SCM table;
 294      SCM obj;
 295      SCM val;
 296 {
 297   return scm_hash_fn_set_x (table, obj, val, scm_ihashv, scm_sloppy_assv, 0);
 298 }
 299
 300
 301 SCM_PROC (s_hashv_remove_x, "hashv-remove!", 2, 0, 0, scm_hashv_remove_x);
 302
 303 SCM
 304 scm_hashv_remove_x (table, obj)
 305      SCM table;
 306      SCM obj;
 307 {
 308   return scm_hash_fn_remove_x (table, obj, scm_ihashv, scm_sloppy_assv, scm_delv_x, 0);
 309 }
 310
 311 \f
 312
 313 SCM_PROC (s_hash_get_handle, "hash-get-handle", 2, 0, 0, scm_hash_get_handle);
 314
 315 SCM
 316 scm_hash_get_handle (table, obj)
 317      SCM table;
 318      SCM obj;
 319 {
 320   return scm_hash_fn_get_handle (table, obj, scm_ihash, scm_sloppy_assoc, 0);
 321 }
 322
 323
 324 SCM_PROC (s_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, scm_hash_create_handle_x);
 325
 326 SCM
 327 scm_hash_create_handle_x (table, obj, init)
 328      SCM table;
 329      SCM obj;
 330      SCM init;
 331 {
 332   return scm_hash_fn_create_handle_x (table, obj, init, scm_ihash, scm_sloppy_assoc, 0);
 333 }
 334
 335
 336 SCM_PROC (s_hash_ref, "hash-ref", 2, 1, 0, scm_hash_ref);
 337
 338 SCM
 339 scm_hash_ref (table, obj, dflt)
 340      SCM table;
 341      SCM obj;
 342      SCM dflt;
 343 {
 344   if (dflt == SCM_UNDEFINED)
 345     dflt = SCM_BOOL_F;
 346   return scm_hash_fn_ref (table, obj, dflt, scm_ihash, scm_sloppy_assoc, 0);
 347 }
 348
 349
 350
 351 SCM_PROC (s_hash_set_x, "hash-set!", 3, 0, 0, scm_hash_set_x);
 352
 353 SCM
 354 scm_hash_set_x (table, obj, val)
 355      SCM table;
 356      SCM obj;
 357      SCM val;
 358 {
 359   return scm_hash_fn_set_x (table, obj, val, scm_ihash, scm_sloppy_assoc, 0);
 360 }
 361
 362
 363
 364 SCM_PROC (s_hash_remove_x, "hash-remove!", 2, 0, 0, scm_hash_remove_x);
 365
 366 SCM
 367 scm_hash_remove_x (table, obj)
 368      SCM table;
 369      SCM obj;
 370 {
 371   return scm_hash_fn_remove_x (table, obj, scm_ihash, scm_sloppy_assoc, scm_delete_x, 0);
 372 }
 373
 374 \f
 375
 376
 377 struct scm_ihashx_closure
 378 {
 379   SCM hash;
 380   SCM assoc;
 381   SCM delete;
 382 };
 383
 384
 385
 386 static unsigned int scm_ihashx SCM_P ((SCM obj, unsigned int n, struct scm_ihashx_closure * closure));
 387
 388 static unsigned int
 389 scm_ihashx (obj, n, closure)
 390      SCM obj;
 391      unsigned int n;
 392      struct scm_ihashx_closure * closure;
 393 {
 394   SCM answer;
 395   SCM_ALLOW_INTS;
 396   answer = scm_apply (closure->hash,
 397                       scm_listify (obj, scm_ulong2num ((unsigned long)n), SCM_UNDEFINED),
 398                       SCM_EOL);
 399   SCM_DEFER_INTS;
 400   return SCM_INUM (answer);
 401 }
 402
 403
 404
 405 static SCM scm_sloppy_assx SCM_P ((SCM obj, SCM alist, struct scm_ihashx_closure * closure));
 406
 407 static SCM
 408 scm_sloppy_assx (obj, alist, closure)
 409      SCM obj;
 410      SCM alist;
 411      struct scm_ihashx_closure * closure;
 412 {
 413   SCM answer;
 414   SCM_ALLOW_INTS;
 415   answer = scm_apply (closure->assoc,
 416                       scm_listify (obj, alist, SCM_UNDEFINED),
 417                       SCM_EOL);
 418   SCM_DEFER_INTS;
 419   return answer;
 420 }
 421
 422
 423
 424
 425 static SCM scm_delx_x SCM_P ((SCM obj, SCM alist, struct scm_ihashx_closure * closure));
 426
 427 static SCM
 428 scm_delx_x (obj, alist, closure)
 429      SCM obj;
 430      SCM alist;
 431      struct scm_ihashx_closure * closure;
 432 {
 433   SCM answer;
 434   SCM_ALLOW_INTS;
 435   answer = scm_apply (closure->delete,
 436                       scm_listify (obj, alist, SCM_UNDEFINED),
 437                       SCM_EOL);
 438   SCM_DEFER_INTS;
 439   return answer;
 440 }
 441
 442
 443
 444 SCM_PROC (s_hashx_get_handle, "hashx-get-handle", 4, 0, 0, scm_hashx_get_handle);
 445
 446 SCM
 447 scm_hashx_get_handle (hash, assoc, table, obj)
 448      SCM hash;
 449      SCM assoc;
 450      SCM table;
 451      SCM obj;
 452 {
 453   struct scm_ihashx_closure closure;
 454   closure.hash = hash;
 455   closure.assoc = assoc;
 456   return scm_hash_fn_get_handle (table, obj, scm_ihashx, scm_sloppy_assx, (void *)&closure);
 457 }
 458
 459
 460 SCM_PROC (s_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, scm_hashx_create_handle_x);
 461
 462 SCM
 463 scm_hashx_create_handle_x (hash, assoc, table, obj, init)
 464      SCM hash;
 465      SCM assoc;
 466      SCM table;
 467      SCM obj;
 468      SCM init;
 469 {
 470   struct scm_ihashx_closure closure;
 471   closure.hash = hash;
 472   closure.assoc = assoc;
 473   return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashx, scm_sloppy_assx, (void *)&closure);
 474 }
 475
 476
 477
 478 SCM_PROC (s_hashx_ref, "hashx-ref", 4, 1, 0, scm_hashx_ref);
 479
 480 SCM
 481 scm_hashx_ref (hash, assoc, table, obj, dflt)
 482      SCM hash;
 483      SCM assoc;
 484      SCM table;
 485      SCM obj;
 486      SCM dflt;
 487 {
 488   struct scm_ihashx_closure closure;
 489   if (dflt == SCM_UNDEFINED)
 490     dflt = SCM_BOOL_F;
 491   closure.hash = hash;
 492   closure.assoc = assoc;
 493   return scm_hash_fn_ref (table, obj, dflt, scm_ihashx, scm_sloppy_assx, (void *)&closure);
 494 }
 495
 496
 497
 498
 499 SCM_PROC (s_hashx_set_x, "hashx-set!", 5, 0, 0, scm_hashx_set_x);
 500
 501 SCM
 502 scm_hashx_set_x (hash, assoc, table, obj, val)
 503      SCM hash;
 504      SCM assoc;
 505      SCM table;
 506      SCM obj;
 507      SCM val;
 508 {
 509   struct scm_ihashx_closure closure;
 510   closure.hash = hash;
 511   closure.assoc = assoc;
 512   return scm_hash_fn_set_x (table, obj, val, scm_ihashx, scm_sloppy_assx, (void *)&closure);
 513 }
 514
 515
 516
 517 SCM
 518 scm_hashx_remove_x (hash, assoc, delete, table, obj)
 519      SCM hash;
 520      SCM assoc;
 521      SCM delete;
 522      SCM table;
 523      SCM obj;
 524 {
 525   struct scm_ihashx_closure closure;
 526   closure.hash = hash;
 527   closure.assoc = assoc;
 528   closure.delete = delete;
 529   return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx, scm_delx_x, 0);
 530 }
 531
 532 static SCM
 533 fold_proc (void *proc, SCM key, SCM data, SCM value)
 534 {
 535   return scm_apply ((SCM) proc, SCM_LIST3 (key, data, value), SCM_EOL);
 536 }
 537
 538 SCM_PROC (s_hash_fold, "hash-fold", 3, 0, 0, scm_hash_fold);
 539
 540 SCM
 541 scm_hash_fold (SCM proc, SCM init, SCM table)
 542 {
 543   SCM_ASSERT (SCM_NIMP (table) && SCM_VECTORP (table),
 544               table, SCM_ARG1, s_hash_fold);
 545   SCM_ASSERT (SCM_NIMP (proc) && SCM_NFALSEP (scm_procedure_p (proc)),
 546               proc, SCM_ARG2, s_hash_fold);
 547   return scm_internal_hash_fold (fold_proc, (void *) proc, init, table);
 548 }
 549
 550 SCM
 551 scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table)
 552 {
 553   int i, n = SCM_LENGTH (table);
 554   SCM result = init;
 555   for (i = 0; i < n; ++i)
 556     {
 557       SCM ls = SCM_VELTS (table)[i], handle;
 558       while (SCM_NNULLP (ls))
 559         {
 560           SCM_ASSERT (SCM_NIMP (ls) && SCM_CONSP (ls),
 561                       table, SCM_ARG1, s_hash_fold);
 562           handle = SCM_CAR (ls);
 563           SCM_ASSERT (SCM_NIMP (handle) && SCM_CONSP (handle),
 564                       table, SCM_ARG1, s_hash_fold);
 565           result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
 566           ls = SCM_CDR (ls);
 567         }
 568     }
 569   return result;
 570 }
 571
 572 \f
 573
 574
 575 void
 576 scm_init_hashtab ()
 577 {
 578 #include "hashtab.x"
 579 }