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
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47 #include <stdio.h>
  48 #include "_scm.h"
  49 #include "alist.h"
  50 #include "hash.h"
  51 #include "eval.h"
  52
  53 #include "scm_validate.h"
  54 #include "hashtab.h"
  55 \f
  56
  57
  58 SCM
  59 scm_hash_fn_get_handle (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn)(),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 (SCM table,SCM obj,SCM init,unsigned int (*hash_fn)(),
  80                              SCM (*assoc_fn)(),void * closure)
  81 {
  82   unsigned int k;
  83   SCM it;
  84
  85   SCM_ASSERT (SCM_NIMP (table) && SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_create_handle_x");
  86   if (SCM_LENGTH (table) == 0)
  87     return SCM_EOL;
  88   k = hash_fn (obj, SCM_LENGTH (table), closure);
  89   SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)),
  90               scm_ulong2num (k),
  91               SCM_OUTOFRANGE,
  92               "hash_fn_create_handle_x");
  93   SCM_REDEFER_INTS;
  94   it = assoc_fn (obj, SCM_VELTS (table)[k], closure);
  95   if (SCM_NIMP (it))
  96     {
  97       return it;
  98     }
  99   {
 100     SCM new_bucket;
 101     SCM old_bucket;
 102     old_bucket = SCM_VELTS (table)[k];
 103     new_bucket = scm_acons (obj, init, old_bucket);
 104     SCM_VELTS(table)[k] = new_bucket;
 105     SCM_REALLOW_INTS;
 106     return SCM_CAR (new_bucket);
 107   }
 108 }
 109
 110
 111
 112
 113 SCM
 114 scm_hash_fn_ref (SCM table,SCM obj,SCM dflt,unsigned int (*hash_fn)(),
 115                  SCM (*assoc_fn)(),void * closure)
 116 {
 117   SCM it;
 118
 119   it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure);
 120   if (SCM_IMP (it))
 121     return dflt;
 122   else
 123     return SCM_CDR (it);
 124 }
 125
 126
 127
 128
 129 SCM
 130 scm_hash_fn_set_x (SCM table,SCM obj,SCM val,unsigned int (*hash_fn)(),
 131                    SCM (*assoc_fn)(),void * closure)
 132 {
 133   SCM it;
 134
 135   it = scm_hash_fn_create_handle_x (table, obj, SCM_BOOL_F, hash_fn, assoc_fn, closure);
 136   SCM_SETCDR (it, val);
 137   return val;
 138 }
 139
 140
 141
 142
 143
 144 SCM
 145 scm_hash_fn_remove_x (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn)(),
 146                       SCM (*delete_fn)(),void * closure)
 147 {
 148   unsigned int k;
 149   SCM h;
 150
 151   SCM_ASSERT (SCM_NIMP (table) && SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_remove_x");
 152   if (SCM_LENGTH (table) == 0)
 153     return SCM_EOL;
 154   k = hash_fn (obj, SCM_LENGTH (table), closure);
 155   SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)),
 156               scm_ulong2num (k),
 157               SCM_OUTOFRANGE,
 158               "hash_fn_remove_x");
 159   h = assoc_fn (obj, SCM_VELTS (table)[k], closure);
 160   SCM_VELTS(table)[k] = delete_fn (h, SCM_VELTS(table)[k]);
 161   return h;
 162 }
 163
 164
 165 \f
 166
 167 GUILE_PROC (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0,
 168             (SCM table, SCM obj),
 169 "@deffnx primitive hashv-get-handle table key
 170 @deffnx primitive hash-get-handle table key
 171 @deffnx primitive hashx-get-handle hasher assoc table key
 172 These procedures are similar to their @code{-ref} cousins, but return a
 173 @dfn{handle} from the hash table rather than the value associated with
 174 @var{key}.  By convention, a handle in a hash table is the pair which
 175 associates a key with a value.  Where @code{hashq-ref table key} returns
 176 only a @code{value}, @code{hashq-get-handle table key} returns the pair
 177 @code{(key . value)}.")
 178 #define FUNC_NAME s_scm_hashq_get_handle
 179 {
 180   return scm_hash_fn_get_handle (table, obj, scm_ihashq, scm_sloppy_assq, 0);
 181 }
 182 #undef FUNC_NAME
 183
 184
 185 GUILE_PROC (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0,
 186             (SCM table, SCM obj, SCM init),
 187 "@deffnx primitive hashv-create-handle! table key init
 188 @deffnx primitive hash-create-handle! table key init
 189 @deffnx primitive hashx-create-handle! hasher assoc table key init
 190 These functions look up @var{key} in @var{table} and return its handle,
 191 If @var{key} is not already present, a new handle is created which
 192 associates @var{key} with @var{init}.")
 193 #define FUNC_NAME s_scm_hashq_create_handle_x
 194 {
 195   return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashq, scm_sloppy_assq, 0);
 196 }
 197 #undef FUNC_NAME
 198
 199
 200 GUILE_PROC (scm_hashq_ref, "hashq-ref", 2, 1, 0,
 201             (SCM table, SCM obj, SCM dflt),
 202 "@deffnx primitive hashv-ref table key [default]
 203 @deffnx primitive hash-ref table key [default]
 204 Look up @var{key} in the hash table @var{table}, and return the
 205 value (if any) associated with it.  If @var{key} is not found,
 206 return @var{default} (or @code{#f} if no @var{default} argument is
 207 supplied).")
 208 #define FUNC_NAME s_scm_hashq_ref
 209 {
 210   if (dflt == SCM_UNDEFINED)
 211     dflt = SCM_BOOL_F;
 212   return scm_hash_fn_ref (table, obj, dflt, scm_ihashq, scm_sloppy_assq, 0);
 213 }
 214 #undef FUNC_NAME
 215
 216
 217
 218 GUILE_PROC (scm_hashq_set_x, "hashq-set!", 3, 0, 0,
 219             (SCM table, SCM obj, SCM val),
 220 "@deffnx primitive hashv-set! table key value
 221 @deffnx primitive hash-set! table key value
 222 Find the entry in @var{table} associated with @var{key}, and store
 223 @var{value} there.")
 224 #define FUNC_NAME s_scm_hashq_set_x
 225 {
 226   return scm_hash_fn_set_x (table, obj, val, scm_ihashq, scm_sloppy_assq, 0);
 227 }
 228 #undef FUNC_NAME
 229
 230
 231
 232 GUILE_PROC (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0,
 233             (SCM table, SCM obj),
 234 "@deffnx primitive hashv-remove! table key
 235 @deffnx primitive hash-remove! table key
 236 Remove @var{key} (and any value associated with it) from @var{table}.")
 237 #define FUNC_NAME s_scm_hashq_remove_x
 238 {
 239   return scm_hash_fn_remove_x (table, obj, scm_ihashq, scm_sloppy_assq, scm_delq_x, 0);
 240 }
 241 #undef FUNC_NAME
 242
 243
 244 \f
 245
 246 GUILE_PROC (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0,
 247             (SCM table, SCM obj),
 248 "")
 249 #define FUNC_NAME s_scm_hashv_get_handle
 250 {
 251   return scm_hash_fn_get_handle (table, obj, scm_ihashv, scm_sloppy_assv, 0);
 252 }
 253 #undef FUNC_NAME
 254
 255
 256 GUILE_PROC (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0,
 257             (SCM table, SCM obj, SCM init),
 258 "")
 259 #define FUNC_NAME s_scm_hashv_create_handle_x
 260 {
 261   return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashv, scm_sloppy_assv, 0);
 262 }
 263 #undef FUNC_NAME
 264
 265
 266 GUILE_PROC (scm_hashv_ref, "hashv-ref", 2, 1, 0,
 267             (SCM table, SCM obj, SCM dflt),
 268 "")
 269 #define FUNC_NAME s_scm_hashv_ref
 270 {
 271   if (dflt == SCM_UNDEFINED)
 272     dflt = SCM_BOOL_F;
 273   return scm_hash_fn_ref (table, obj, dflt, scm_ihashv, scm_sloppy_assv, 0);
 274 }
 275 #undef FUNC_NAME
 276
 277
 278
 279 GUILE_PROC (scm_hashv_set_x, "hashv-set!", 3, 0, 0,
 280             (SCM table, SCM obj, SCM val),
 281 "")
 282 #define FUNC_NAME s_scm_hashv_set_x
 283 {
 284   return scm_hash_fn_set_x (table, obj, val, scm_ihashv, scm_sloppy_assv, 0);
 285 }
 286 #undef FUNC_NAME
 287
 288
 289 GUILE_PROC (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0,
 290             (SCM table, SCM obj),
 291 "")
 292 #define FUNC_NAME s_scm_hashv_remove_x
 293 {
 294   return scm_hash_fn_remove_x (table, obj, scm_ihashv, scm_sloppy_assv, scm_delv_x, 0);
 295 }
 296 #undef FUNC_NAME
 297
 298 \f
 299
 300 GUILE_PROC (scm_hash_get_handle, "hash-get-handle", 2, 0, 0,
 301             (SCM table, SCM obj),
 302 "")
 303 #define FUNC_NAME s_scm_hash_get_handle
 304 {
 305   return scm_hash_fn_get_handle (table, obj, scm_ihash, scm_sloppy_assoc, 0);
 306 }
 307 #undef FUNC_NAME
 308
 309
 310 GUILE_PROC (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0,
 311             (SCM table, SCM obj, SCM init),
 312 "")
 313 #define FUNC_NAME s_scm_hash_create_handle_x
 314 {
 315   return scm_hash_fn_create_handle_x (table, obj, init, scm_ihash, scm_sloppy_assoc, 0);
 316 }
 317 #undef FUNC_NAME
 318
 319
 320 GUILE_PROC (scm_hash_ref, "hash-ref", 2, 1, 0,
 321             (SCM table, SCM obj, SCM dflt),
 322 "")
 323 #define FUNC_NAME s_scm_hash_ref
 324 {
 325   if (dflt == SCM_UNDEFINED)
 326     dflt = SCM_BOOL_F;
 327   return scm_hash_fn_ref (table, obj, dflt, scm_ihash, scm_sloppy_assoc, 0);
 328 }
 329 #undef FUNC_NAME
 330
 331
 332
 333 GUILE_PROC (scm_hash_set_x, "hash-set!", 3, 0, 0,
 334             (SCM table, SCM obj, SCM val),
 335 "")
 336 #define FUNC_NAME s_scm_hash_set_x
 337 {
 338   return scm_hash_fn_set_x (table, obj, val, scm_ihash, scm_sloppy_assoc, 0);
 339 }
 340 #undef FUNC_NAME
 341
 342
 343
 344 GUILE_PROC (scm_hash_remove_x, "hash-remove!", 2, 0, 0,
 345             (SCM table, SCM obj),
 346 "")
 347 #define FUNC_NAME s_scm_hash_remove_x
 348 {
 349   return scm_hash_fn_remove_x (table, obj, scm_ihash, scm_sloppy_assoc, scm_delete_x, 0);
 350 }
 351 #undef FUNC_NAME
 352
 353 \f
 354
 355
 356 struct scm_ihashx_closure
 357 {
 358   SCM hash;
 359   SCM assoc;
 360   SCM delete;
 361 };
 362
 363
 364
 365 static unsigned int
 366 scm_ihashx (SCM obj,unsigned int n,struct scm_ihashx_closure * closure)
 367 {
 368   SCM answer;
 369   SCM_ALLOW_INTS;
 370   answer = scm_apply (closure->hash,
 371                       scm_listify (obj, scm_ulong2num ((unsigned long)n), SCM_UNDEFINED),
 372                       SCM_EOL);
 373   SCM_DEFER_INTS;
 374   return SCM_INUM (answer);
 375 }
 376
 377
 378
 379 static SCM
 380 scm_sloppy_assx (SCM obj,SCM alist,struct scm_ihashx_closure * closure)
 381 {
 382   SCM answer;
 383   SCM_ALLOW_INTS;
 384   answer = scm_apply (closure->assoc,
 385                       scm_listify (obj, alist, SCM_UNDEFINED),
 386                       SCM_EOL);
 387   SCM_DEFER_INTS;
 388   return answer;
 389 }
 390
 391
 392
 393
 394 static SCM
 395 scm_delx_x (SCM obj,SCM alist,struct scm_ihashx_closure * closure)
 396 {
 397   SCM answer;
 398   SCM_ALLOW_INTS;
 399   answer = scm_apply (closure->delete,
 400                       scm_listify (obj, alist, SCM_UNDEFINED),
 401                       SCM_EOL);
 402   SCM_DEFER_INTS;
 403   return answer;
 404 }
 405
 406
 407
 408 GUILE_PROC (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0,
 409             (SCM hash, SCM assoc, SCM table, SCM obj),
 410 "")
 411 #define FUNC_NAME s_scm_hashx_get_handle
 412 {
 413   struct scm_ihashx_closure closure;
 414   closure.hash = hash;
 415   closure.assoc = assoc;
 416   return scm_hash_fn_get_handle (table, obj, scm_ihashx, scm_sloppy_assx, (void *)&closure);
 417 }
 418 #undef FUNC_NAME
 419
 420
 421 GUILE_PROC (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0,
 422             (SCM hash,SCM assoc,SCM table,SCM obj,SCM init),
 423 "")
 424 #define FUNC_NAME s_scm_hashx_create_handle_x
 425 {
 426   struct scm_ihashx_closure closure;
 427   closure.hash = hash;
 428   closure.assoc = assoc;
 429   return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashx, scm_sloppy_assx, (void *)&closure);
 430 }
 431 #undef FUNC_NAME
 432
 433
 434
 435 GUILE_PROC (scm_hashx_ref, "hashx-ref", 4, 1, 0,
 436             (SCM hash,SCM assoc,SCM table,SCM obj,SCM dflt),
 437 "@deffnx primitive hashx-set! hasher assoc table key value
 438 @deffnx primitive hashx-remove! hasher assoc table key
 439 These behave the same way as the corresponding @code{ref} and
 440 @code{set!} functions described above, but use @var{hasher} as a
 441 hash function and @var{assoc} to compare keys.  @code{hasher} must
 442 be a function that takes two arguments, a key to be hashed and a
 443 table size.  @code{assoc} must be an associator function, like
 444 @code{assoc}, @code{assq} or @code{assv}.
 445
 446 By way of illustration, @code{hashq-ref table key} is equivalent
 447 to @code{hashx-ref hashq assq table key}.")
 448 #define FUNC_NAME s_scm_hashx_ref
 449 {
 450   struct scm_ihashx_closure closure;
 451   if (dflt == SCM_UNDEFINED)
 452     dflt = SCM_BOOL_F;
 453   closure.hash = hash;
 454   closure.assoc = assoc;
 455   return scm_hash_fn_ref (table, obj, dflt, scm_ihashx, scm_sloppy_assx, (void *)&closure);
 456 }
 457 #undef FUNC_NAME
 458
 459
 460
 461
 462 GUILE_PROC (scm_hashx_set_x, "hashx-set!", 5, 0, 0,
 463             (SCM hash, SCM assoc, SCM table, SCM obj, SCM val),
 464 "")
 465 #define FUNC_NAME s_scm_hashx_set_x
 466 {
 467   struct scm_ihashx_closure closure;
 468   closure.hash = hash;
 469   closure.assoc = assoc;
 470   return scm_hash_fn_set_x (table, obj, val, scm_ihashx, scm_sloppy_assx, (void *)&closure);
 471 }
 472 #undef FUNC_NAME
 473
 474
 475
 476 SCM
 477 scm_hashx_remove_x (SCM hash,SCM assoc,SCM delete,SCM table,SCM obj)
 478 {
 479   struct scm_ihashx_closure closure;
 480   closure.hash = hash;
 481   closure.assoc = assoc;
 482   closure.delete = delete;
 483   return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx, scm_delx_x, 0);
 484 }
 485
 486 static SCM
 487 fold_proc (void *proc, SCM key, SCM data, SCM value)
 488 {
 489   return scm_apply ((SCM) proc, SCM_LIST3 (key, data, value), SCM_EOL);
 490 }
 491
 492 GUILE_PROC (scm_hash_fold, "hash-fold", 3, 0, 0,
 493             (SCM proc, SCM init, SCM table),
 494 "")
 495 #define FUNC_NAME s_scm_hash_fold
 496 {
 497   SCM_VALIDATE_PROC(1,proc);
 498   SCM_VALIDATE_VECTOR(3,table);
 499   return scm_internal_hash_fold (fold_proc, (void *) proc, init, table);
 500 }
 501 #undef FUNC_NAME
 502
 503 SCM
 504 scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table)
 505 {
 506   int i, n = SCM_LENGTH (table);
 507   SCM result = init;
 508   for (i = 0; i < n; ++i)
 509     {
 510       SCM ls = SCM_VELTS (table)[i], handle;
 511       while (SCM_NNULLP (ls))
 512         {
 513           SCM_ASSERT (SCM_NIMP (ls) && SCM_CONSP (ls),
 514                       table, SCM_ARG1, s_scm_hash_fold);
 515           handle = SCM_CAR (ls);
 516           SCM_ASSERT (SCM_NIMP (handle) && SCM_CONSP (handle),
 517                       table, SCM_ARG1, s_scm_hash_fold);
 518           result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
 519           ls = SCM_CDR (ls);
 520         }
 521     }
 522   return result;
 523 }
 524
 525 \f
 526
 527
 528 void
 529 scm_init_hashtab ()
 530 {
 531 #include "hashtab.x"
 532 }