123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080 |
- /* Copyright 1995-1996,1998-2001,2003-2004,2006,2008-2013,2018
- Free Software Foundation, Inc.
- This file is part of Guile.
- Guile is free software: you can redistribute it and/or modify it
- under the terms of the GNU Lesser General Public License as published
- by the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
- Guile is distributed in the hope that it will be useful, but WITHOUT
- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
- FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
- License for more details.
- You should have received a copy of the GNU Lesser General Public
- License along with Guile. If not, see
- <https://www.gnu.org/licenses/>. */
- #ifdef HAVE_CONFIG_H
- # include <config.h>
- #endif
- #include <alloca.h>
- #include <assert.h>
- #include <stdio.h>
- #include "alist.h"
- #include "bdw-gc.h"
- #include "boolean.h"
- #include "eq.h"
- #include "eval.h"
- #include "gsubr.h"
- #include "hash.h"
- #include "list.h"
- #include "numbers.h"
- #include "pairs.h"
- #include "ports.h"
- #include "procs.h"
- #include "vectors.h"
- #include "weak-table.h"
- #include "hashtab.h"
- /* A hash table is a cell containing a vector of association lists.
- *
- * Growing or shrinking, with following rehashing, is triggered when
- * the load factor
- *
- * L = N / S (N: number of items in table, S: bucket vector length)
- *
- * passes an upper limit of 0.9 or a lower limit of 0.25.
- *
- * The implementation stores the upper and lower number of items which
- * trigger a resize in the hashtable object.
- *
- * Possible hash table sizes (primes) are stored in the array
- * hashtable_size.
- */
- static unsigned long hashtable_size[] = {
- 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
- 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
- #if SIZEOF_UINTPTR_T > 4
- /* vector lengths are stored in the first word of vectors, shifted by
- 8 bits for the tc8, so for 32-bit we only get 2^24-1 = 16777215
- elements. But we allow a few more sizes for 64-bit. */
- , 28762081, 57524111, 115048217, 230096423, 460192829
- #endif
- };
- #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
- static char *s_hashtable = "hashtable";
- static SCM
- make_hash_table (unsigned long k, const char *func_name)
- {
- SCM vector;
- scm_t_hashtable *t;
- int i = 0, n = k ? k : 31;
- while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i])
- ++i;
- n = hashtable_size[i];
- vector = scm_c_make_vector (n, SCM_EOL);
- t = scm_gc_malloc_pointerless (sizeof (*t), s_hashtable);
- t->min_size_index = t->size_index = i;
- t->n_items = 0;
- t->lower = 0;
- t->upper = 9 * n / 10;
- /* FIXME: we just need two words of storage, not three */
- return scm_double_cell (scm_tc7_hashtable, SCM_UNPACK (vector),
- (scm_t_bits)t, 0);
- }
- void
- scm_i_rehash (SCM table,
- scm_t_hash_fn hash_fn,
- void *closure,
- const char* func_name)
- {
- SCM buckets, new_buckets;
- int i;
- unsigned long old_size;
- unsigned long new_size;
- if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
- {
- /* rehashing is not triggered when i <= min_size */
- i = SCM_HASHTABLE (table)->size_index;
- do
- --i;
- while (i > SCM_HASHTABLE (table)->min_size_index
- && SCM_HASHTABLE_N_ITEMS (table) < hashtable_size[i] / 4);
- }
- else
- {
- i = SCM_HASHTABLE (table)->size_index + 1;
- if (i >= HASHTABLE_SIZE_N)
- /* don't rehash */
- return;
- }
- SCM_HASHTABLE (table)->size_index = i;
-
- new_size = hashtable_size[i];
- if (i <= SCM_HASHTABLE (table)->min_size_index)
- SCM_HASHTABLE (table)->lower = 0;
- else
- SCM_HASHTABLE (table)->lower = new_size / 4;
- SCM_HASHTABLE (table)->upper = 9 * new_size / 10;
- buckets = SCM_HASHTABLE_VECTOR (table);
- new_buckets = scm_c_make_vector (new_size, SCM_EOL);
- SCM_SET_HASHTABLE_VECTOR (table, new_buckets);
- SCM_SET_HASHTABLE_N_ITEMS (table, 0);
- old_size = SCM_SIMPLE_VECTOR_LENGTH (buckets);
- for (i = 0; i < old_size; ++i)
- {
- SCM ls, cell, handle;
- ls = SCM_SIMPLE_VECTOR_REF (buckets, i);
- SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_EOL);
- while (scm_is_pair (ls))
- {
- unsigned long h;
- cell = ls;
- handle = SCM_CAR (cell);
- ls = SCM_CDR (ls);
- h = hash_fn (SCM_CAR (handle), new_size, closure);
- if (h >= new_size)
- scm_out_of_range (func_name, scm_from_ulong (h));
- SCM_SETCDR (cell, SCM_SIMPLE_VECTOR_REF (new_buckets, h));
- SCM_SIMPLE_VECTOR_SET (new_buckets, h, cell);
- SCM_HASHTABLE_INCREMENT (table);
- }
- }
- }
- void
- scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
- {
- scm_puts ("#<hash-table ", port);
- scm_uintprint (SCM_UNPACK (exp), 16, port);
- scm_putc (' ', port);
- scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
- scm_putc ('/', port);
- scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
- 10, port);
- scm_puts (">", port);
- }
- SCM
- scm_c_make_hash_table (unsigned long k)
- {
- return make_hash_table (k, "scm_c_make_hash_table");
- }
- SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0,
- (SCM n),
- "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
- #define FUNC_NAME s_scm_make_hash_table
- {
- return make_hash_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), FUNC_NAME);
- }
- #undef FUNC_NAME
- #define SCM_WEAK_TABLE_P(x) (scm_is_true (scm_weak_table_p (x)))
- SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is an abstract hash table object.")
- #define FUNC_NAME s_scm_hash_table_p
- {
- return scm_from_bool (SCM_HASHTABLE_P (obj) || SCM_WEAK_TABLE_P (obj));
- }
- #undef FUNC_NAME
- /* Accessing hash table entries. */
- SCM
- scm_hash_fn_get_handle (SCM table, SCM obj,
- scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
- void * closure)
- #define FUNC_NAME "scm_hash_fn_get_handle"
- {
- unsigned long k;
- SCM buckets, h;
- SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
- buckets = SCM_HASHTABLE_VECTOR (table);
- if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
- return SCM_BOOL_F;
- k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
- if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
- scm_out_of_range (FUNC_NAME, scm_from_ulong (k));
- h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
- return h;
- }
- #undef FUNC_NAME
- SCM
- scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init,
- scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
- void * closure)
- #define FUNC_NAME "scm_hash_fn_create_handle_x"
- {
- unsigned long k;
- SCM buckets, it;
- SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
- buckets = SCM_HASHTABLE_VECTOR (table);
- if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
- SCM_MISC_ERROR ("void hashtable", SCM_EOL);
- k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
- if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
- scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
- it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
- if (scm_is_pair (it))
- return it;
- else if (scm_is_true (it))
- scm_wrong_type_arg_msg (NULL, 0, it, "a pair");
- else
- {
- SCM handle, new_bucket;
- handle = scm_cons (obj, init);
- new_bucket = scm_cons (handle, SCM_EOL);
- if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets))
- {
- buckets = SCM_HASHTABLE_VECTOR (table);
- k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
- if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
- scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
- }
- SCM_SETCDR (new_bucket, SCM_SIMPLE_VECTOR_REF (buckets, k));
- SCM_SIMPLE_VECTOR_SET (buckets, k, new_bucket);
- SCM_HASHTABLE_INCREMENT (table);
- /* Maybe rehash the table. */
- if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table)
- || SCM_HASHTABLE_N_ITEMS (table) > SCM_HASHTABLE_UPPER (table))
- scm_i_rehash (table, hash_fn, closure, FUNC_NAME);
- return SCM_CAR (new_bucket);
- }
- }
- #undef FUNC_NAME
- SCM
- scm_hash_fn_ref (SCM table, SCM obj, SCM dflt,
- scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
- void *closure)
- {
- SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure);
- if (scm_is_pair (it))
- return SCM_CDR (it);
- else
- return dflt;
- }
- SCM
- scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
- scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
- void *closure)
- {
- SCM pair;
- pair = scm_hash_fn_create_handle_x (table, obj, val,
- hash_fn, assoc_fn, closure);
- if (!scm_is_eq (SCM_CDR (pair), val))
- SCM_SETCDR (pair, val);
-
- return val;
- }
- SCM
- scm_hash_fn_remove_x (SCM table, SCM obj,
- scm_t_hash_fn hash_fn,
- scm_t_assoc_fn assoc_fn,
- void *closure)
- #define FUNC_NAME "hash_fn_remove_x"
- {
- unsigned long k;
- SCM buckets, h;
- SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
- buckets = SCM_HASHTABLE_VECTOR (table);
- if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
- return SCM_EOL;
- k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
- if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
- scm_out_of_range (FUNC_NAME, scm_from_ulong (k));
- h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
- if (scm_is_true (h))
- {
- SCM_SIMPLE_VECTOR_SET
- (buckets, k, scm_delq_x (h, SCM_SIMPLE_VECTOR_REF (buckets, k)));
- SCM_HASHTABLE_DECREMENT (table);
- if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
- scm_i_rehash (table, hash_fn, closure, FUNC_NAME);
- }
- return h;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hash_clear_x, "hash-clear!", 1, 0, 0,
- (SCM table),
- "Remove all items from @var{table} (without triggering a resize).")
- #define FUNC_NAME s_scm_hash_clear_x
- {
- if (SCM_WEAK_TABLE_P (table))
- {
- scm_weak_table_clear_x (table);
- return SCM_UNSPECIFIED;
- }
- SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
- scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL);
- SCM_SET_HASHTABLE_N_ITEMS (table, 0);
- return SCM_UNSPECIFIED;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0,
- (SCM table, SCM key),
- "This procedure returns the @code{(key . value)} pair from the\n"
- "hash table @var{table}. If @var{table} does not hold an\n"
- "associated value for @var{key}, @code{#f} is returned.\n"
- "Uses @code{eq?} for equality testing.")
- #define FUNC_NAME s_scm_hashq_get_handle
- {
- return scm_hash_fn_get_handle (table, key,
- (scm_t_hash_fn) scm_ihashq,
- (scm_t_assoc_fn) scm_sloppy_assq,
- 0);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0,
- (SCM table, SCM key, SCM init),
- "This function looks up @var{key} in @var{table} and returns its handle.\n"
- "If @var{key} is not already present, a new handle is created which\n"
- "associates @var{key} with @var{init}.")
- #define FUNC_NAME s_scm_hashq_create_handle_x
- {
- return scm_hash_fn_create_handle_x (table, key, init,
- (scm_t_hash_fn) scm_ihashq,
- (scm_t_assoc_fn) scm_sloppy_assq,
- 0);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0,
- (SCM table, SCM key, SCM dflt),
- "Look up @var{key} in the hash table @var{table}, and return the\n"
- "value (if any) associated with it. If @var{key} is not found,\n"
- "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
- "is supplied). Uses @code{eq?} for equality testing.")
- #define FUNC_NAME s_scm_hashq_ref
- {
- if (SCM_UNBNDP (dflt))
- dflt = SCM_BOOL_F;
- if (SCM_WEAK_TABLE_P (table))
- return scm_weak_table_refq (table, key, dflt);
- return scm_hash_fn_ref (table, key, dflt,
- (scm_t_hash_fn) scm_ihashq,
- (scm_t_assoc_fn) scm_sloppy_assq,
- 0);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0,
- (SCM table, SCM key, SCM val),
- "Find the entry in @var{table} associated with @var{key}, and\n"
- "store @var{val} there. Uses @code{eq?} for equality testing.")
- #define FUNC_NAME s_scm_hashq_set_x
- {
- if (SCM_WEAK_TABLE_P (table))
- {
- scm_weak_table_putq_x (table, key, val);
- return val;
- }
- return scm_hash_fn_set_x (table, key, val,
- (scm_t_hash_fn) scm_ihashq,
- (scm_t_assoc_fn) scm_sloppy_assq,
- 0);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0,
- (SCM table, SCM key),
- "Remove @var{key} (and any value associated with it) from\n"
- "@var{table}. Uses @code{eq?} for equality tests.")
- #define FUNC_NAME s_scm_hashq_remove_x
- {
- if (SCM_WEAK_TABLE_P (table))
- {
- scm_weak_table_remq_x (table, key);
- /* This return value is for historical compatibility with
- hash-remove!, which returns either the "handle" corresponding
- to the entry, or #f. Since weak tables don't have handles, we
- have to return #f. */
- return SCM_BOOL_F;
- }
- return scm_hash_fn_remove_x (table, key,
- (scm_t_hash_fn) scm_ihashq,
- (scm_t_assoc_fn) scm_sloppy_assq,
- 0);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0,
- (SCM table, SCM key),
- "This procedure returns the @code{(key . value)} pair from the\n"
- "hash table @var{table}. If @var{table} does not hold an\n"
- "associated value for @var{key}, @code{#f} is returned.\n"
- "Uses @code{eqv?} for equality testing.")
- #define FUNC_NAME s_scm_hashv_get_handle
- {
- return scm_hash_fn_get_handle (table, key,
- (scm_t_hash_fn) scm_ihashv,
- (scm_t_assoc_fn) scm_sloppy_assv,
- 0);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0,
- (SCM table, SCM key, SCM init),
- "This function looks up @var{key} in @var{table} and returns its handle.\n"
- "If @var{key} is not already present, a new handle is created which\n"
- "associates @var{key} with @var{init}.")
- #define FUNC_NAME s_scm_hashv_create_handle_x
- {
- return scm_hash_fn_create_handle_x (table, key, init,
- (scm_t_hash_fn) scm_ihashv,
- (scm_t_assoc_fn) scm_sloppy_assv,
- 0);
- }
- #undef FUNC_NAME
- static int
- assv_predicate (SCM k, SCM v, void *closure)
- {
- return scm_is_true (scm_eqv_p (k, SCM_PACK_POINTER (closure)));
- }
- SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0,
- (SCM table, SCM key, SCM dflt),
- "Look up @var{key} in the hash table @var{table}, and return the\n"
- "value (if any) associated with it. If @var{key} is not found,\n"
- "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
- "is supplied). Uses @code{eqv?} for equality testing.")
- #define FUNC_NAME s_scm_hashv_ref
- {
- if (SCM_UNBNDP (dflt))
- dflt = SCM_BOOL_F;
- if (SCM_WEAK_TABLE_P (table))
- return scm_c_weak_table_ref (table, scm_ihashv (key, -1),
- assv_predicate,
- (void *) SCM_UNPACK (key), dflt);
- return scm_hash_fn_ref (table, key, dflt,
- (scm_t_hash_fn) scm_ihashv,
- (scm_t_assoc_fn) scm_sloppy_assv,
- 0);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0,
- (SCM table, SCM key, SCM val),
- "Find the entry in @var{table} associated with @var{key}, and\n"
- "store @var{value} there. Uses @code{eqv?} for equality testing.")
- #define FUNC_NAME s_scm_hashv_set_x
- {
- if (SCM_WEAK_TABLE_P (table))
- {
- scm_c_weak_table_put_x (table, scm_ihashv (key, -1),
- assv_predicate, (void *) SCM_UNPACK (key),
- key, val);
- return val;
- }
- return scm_hash_fn_set_x (table, key, val,
- (scm_t_hash_fn) scm_ihashv,
- (scm_t_assoc_fn) scm_sloppy_assv,
- 0);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0,
- (SCM table, SCM key),
- "Remove @var{key} (and any value associated with it) from\n"
- "@var{table}. Uses @code{eqv?} for equality tests.")
- #define FUNC_NAME s_scm_hashv_remove_x
- {
- if (SCM_WEAK_TABLE_P (table))
- {
- scm_c_weak_table_remove_x (table, scm_ihashv (key, -1),
- assv_predicate, (void *) SCM_UNPACK (key));
- /* See note in hashq-remove!. */
- return SCM_BOOL_F;
- }
- return scm_hash_fn_remove_x (table, key,
- (scm_t_hash_fn) scm_ihashv,
- (scm_t_assoc_fn) scm_sloppy_assv,
- 0);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0,
- (SCM table, SCM key),
- "This procedure returns the @code{(key . value)} pair from the\n"
- "hash table @var{table}. If @var{table} does not hold an\n"
- "associated value for @var{key}, @code{#f} is returned.\n"
- "Uses @code{equal?} for equality testing.")
- #define FUNC_NAME s_scm_hash_get_handle
- {
- return scm_hash_fn_get_handle (table, key,
- (scm_t_hash_fn) scm_ihash,
- (scm_t_assoc_fn) scm_sloppy_assoc,
- 0);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0,
- (SCM table, SCM key, SCM init),
- "This function looks up @var{key} in @var{table} and returns its handle.\n"
- "If @var{key} is not already present, a new handle is created which\n"
- "associates @var{key} with @var{init}.")
- #define FUNC_NAME s_scm_hash_create_handle_x
- {
- return scm_hash_fn_create_handle_x (table, key, init,
- (scm_t_hash_fn) scm_ihash,
- (scm_t_assoc_fn) scm_sloppy_assoc,
- 0);
- }
- #undef FUNC_NAME
- static int
- assoc_predicate (SCM k, SCM v, void *closure)
- {
- return scm_is_true (scm_equal_p (k, SCM_PACK_POINTER (closure)));
- }
- SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0,
- (SCM table, SCM key, SCM dflt),
- "Look up @var{key} in the hash table @var{table}, and return the\n"
- "value (if any) associated with it. If @var{key} is not found,\n"
- "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
- "is supplied). Uses @code{equal?} for equality testing.")
- #define FUNC_NAME s_scm_hash_ref
- {
- if (SCM_UNBNDP (dflt))
- dflt = SCM_BOOL_F;
- if (SCM_WEAK_TABLE_P (table))
- return scm_c_weak_table_ref (table, scm_ihash (key, -1),
- assoc_predicate,
- (void *) SCM_UNPACK (key), dflt);
- return scm_hash_fn_ref (table, key, dflt,
- (scm_t_hash_fn) scm_ihash,
- (scm_t_assoc_fn) scm_sloppy_assoc,
- 0);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0,
- (SCM table, SCM key, SCM val),
- "Find the entry in @var{table} associated with @var{key}, and\n"
- "store @var{val} there. Uses @code{equal?} for equality\n"
- "testing.")
- #define FUNC_NAME s_scm_hash_set_x
- {
- if (SCM_WEAK_TABLE_P (table))
- {
- scm_c_weak_table_put_x (table, scm_ihash (key, -1),
- assoc_predicate, (void *) SCM_UNPACK (key),
- key, val);
- return val;
- }
- return scm_hash_fn_set_x (table, key, val,
- (scm_t_hash_fn) scm_ihash,
- (scm_t_assoc_fn) scm_sloppy_assoc,
- 0);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0,
- (SCM table, SCM key),
- "Remove @var{key} (and any value associated with it) from\n"
- "@var{table}. Uses @code{equal?} for equality tests.")
- #define FUNC_NAME s_scm_hash_remove_x
- {
- if (SCM_WEAK_TABLE_P (table))
- {
- scm_c_weak_table_remove_x (table, scm_ihash (key, -1),
- assoc_predicate, (void *) SCM_UNPACK (key));
- /* See note in hashq-remove!. */
- return SCM_BOOL_F;
- }
- return scm_hash_fn_remove_x (table, key,
- (scm_t_hash_fn) scm_ihash,
- (scm_t_assoc_fn) scm_sloppy_assoc,
- 0);
- }
- #undef FUNC_NAME
- typedef struct scm_t_ihashx_closure
- {
- SCM hash;
- SCM assoc;
- SCM key;
- } scm_t_ihashx_closure;
- static unsigned long
- scm_ihashx (SCM obj, unsigned long n, void *arg)
- {
- SCM answer;
- scm_t_ihashx_closure *closure = (scm_t_ihashx_closure *) arg;
- answer = scm_call_2 (closure->hash, obj, scm_from_ulong (n));
- return scm_to_ulong (answer);
- }
- static SCM
- scm_sloppy_assx (SCM obj, SCM alist, void *arg)
- {
- scm_t_ihashx_closure *closure = (scm_t_ihashx_closure *) arg;
- return scm_call_2 (closure->assoc, obj, alist);
- }
- static int
- assx_predicate (SCM k, SCM v, void *closure)
- {
- scm_t_ihashx_closure *c = (scm_t_ihashx_closure *) closure;
- /* FIXME: The hashx interface is crazy. Hash tables have nothing to
- do with alists in principle. Instead of getting an assoc proc,
- hashx functions should use an equality predicate. Perhaps we can
- change this before 2.2, but until then, add a terrible, terrible
- hack. */
- return scm_is_true (scm_call_2 (c->assoc, c->key, scm_acons (k, v, SCM_EOL)));
- }
- SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0,
- (SCM hash, SCM assoc, SCM table, SCM key),
- "This behaves the same way as the corresponding\n"
- "@code{-get-handle} function, but uses @var{hash} as a hash\n"
- "function and @var{assoc} to compare keys. @code{hash} must be\n"
- "a function that takes two arguments, a key to be hashed and a\n"
- "table size. @code{assoc} must be an associator function, like\n"
- "@code{assoc}, @code{assq} or @code{assv}.")
- #define FUNC_NAME s_scm_hashx_get_handle
- {
- scm_t_ihashx_closure closure;
- closure.hash = hash;
- closure.assoc = assoc;
- closure.key = key;
- return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx,
- (void *) &closure);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0,
- (SCM hash, SCM assoc, SCM table, SCM key, SCM init),
- "This behaves the same way as the corresponding\n"
- "@code{-create-handle} function, but uses @var{hash} as a hash\n"
- "function and @var{assoc} to compare keys. @code{hash} must be\n"
- "a function that takes two arguments, a key to be hashed and a\n"
- "table size. @code{assoc} must be an associator function, like\n"
- "@code{assoc}, @code{assq} or @code{assv}.")
- #define FUNC_NAME s_scm_hashx_create_handle_x
- {
- scm_t_ihashx_closure closure;
- closure.hash = hash;
- closure.assoc = assoc;
- closure.key = key;
- return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx,
- scm_sloppy_assx, (void *)&closure);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0,
- (SCM hash, SCM assoc, SCM table, SCM key, SCM dflt),
- "This behaves the same way as the corresponding @code{ref}\n"
- "function, but uses @var{hash} as a hash function and\n"
- "@var{assoc} to compare keys. @code{hash} must be a function\n"
- "that takes two arguments, a key to be hashed and a table size.\n"
- "@code{assoc} must be an associator function, like @code{assoc},\n"
- "@code{assq} or @code{assv}.\n"
- "\n"
- "By way of illustration, @code{hashq-ref table key} is\n"
- "equivalent to @code{hashx-ref hashq assq table key}.")
- #define FUNC_NAME s_scm_hashx_ref
- {
- scm_t_ihashx_closure closure;
- if (SCM_UNBNDP (dflt))
- dflt = SCM_BOOL_F;
- closure.hash = hash;
- closure.assoc = assoc;
- closure.key = key;
- if (SCM_WEAK_TABLE_P (table))
- {
- unsigned long h = scm_to_ulong (scm_call_2 (hash, key,
- scm_from_ulong (-1)));
- return scm_c_weak_table_ref (table, h, assx_predicate, &closure, dflt);
- }
- return scm_hash_fn_ref (table, key, dflt, scm_ihashx, scm_sloppy_assx,
- (void *)&closure);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0,
- (SCM hash, SCM assoc, SCM table, SCM key, SCM val),
- "This behaves the same way as the corresponding @code{set!}\n"
- "function, but uses @var{hash} as a hash function and\n"
- "@var{assoc} to compare keys. @code{hash} must be a function\n"
- "that takes two arguments, a key to be hashed and a table size.\n"
- "@code{assoc} must be an associator function, like @code{assoc},\n"
- "@code{assq} or @code{assv}.\n"
- "\n"
- " By way of illustration, @code{hashq-set! table key} is\n"
- "equivalent to @code{hashx-set! hashq assq table key}.")
- #define FUNC_NAME s_scm_hashx_set_x
- {
- scm_t_ihashx_closure closure;
- closure.hash = hash;
- closure.assoc = assoc;
- closure.key = key;
- if (SCM_WEAK_TABLE_P (table))
- {
- unsigned long h = scm_to_ulong (scm_call_2 (hash, key,
- scm_from_ulong (-1)));
- scm_c_weak_table_put_x (table, h, assx_predicate, &closure, key, val);
- return val;
- }
- return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx,
- (void *)&closure);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hashx_remove_x, "hashx-remove!", 4, 0, 0,
- (SCM hash, SCM assoc, SCM table, SCM obj),
- "This behaves the same way as the corresponding @code{remove!}\n"
- "function, but uses @var{hash} as a hash function and\n"
- "@var{assoc} to compare keys. @code{hash} must be a function\n"
- "that takes two arguments, a key to be hashed and a table size.\n"
- "@code{assoc} must be an associator function, like @code{assoc},\n"
- "@code{assq} or @code{assv}.\n"
- "\n"
- " By way of illustration, @code{hashq-remove! table key} is\n"
- "equivalent to @code{hashx-remove! hashq assq #f table key}.")
- #define FUNC_NAME s_scm_hashx_remove_x
- {
- scm_t_ihashx_closure closure;
- closure.hash = hash;
- closure.assoc = assoc;
- closure.key = obj;
- if (SCM_WEAK_TABLE_P (table))
- {
- unsigned long h = scm_to_ulong (scm_call_2 (hash, obj,
- scm_from_ulong (-1)));
- scm_c_weak_table_remove_x (table, h, assx_predicate, &closure);
- /* See note in hashq-remove!. */
- return SCM_BOOL_F;
- }
- return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx,
- (void *) &closure);
- }
- #undef FUNC_NAME
- /* Hash table iterators */
- SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0,
- (SCM proc, SCM init, SCM table),
- "An iterator over hash-table elements.\n"
- "Accumulates and returns a result by applying PROC successively.\n"
- "The arguments to PROC are \"(key value prior-result)\" where key\n"
- "and value are successive pairs from the hash table TABLE, and\n"
- "prior-result is either INIT (for the first application of PROC)\n"
- "or the return value of the previous application of PROC.\n"
- "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
- "table into an a-list of key-value pairs.")
- #define FUNC_NAME s_scm_hash_fold
- {
- SCM_VALIDATE_PROC (1, proc);
- if (SCM_WEAK_TABLE_P (table))
- return scm_weak_table_fold (proc, init, table);
- SCM_VALIDATE_HASHTABLE (3, table);
- return scm_internal_hash_fold ((scm_t_hash_fold_fn) scm_call_3,
- (void *) SCM_UNPACK (proc), init, table);
- }
- #undef FUNC_NAME
- static SCM
- for_each_proc (void *proc, SCM handle)
- {
- return scm_call_2 (SCM_PACK (proc), SCM_CAR (handle), SCM_CDR (handle));
- }
- SCM_DEFINE (scm_hash_for_each, "hash-for-each", 2, 0, 0,
- (SCM proc, SCM table),
- "An iterator over hash-table elements.\n"
- "Applies PROC successively on all hash table items.\n"
- "The arguments to PROC are \"(key value)\" where key\n"
- "and value are successive pairs from the hash table TABLE.")
- #define FUNC_NAME s_scm_hash_for_each
- {
- SCM_VALIDATE_PROC (1, proc);
- if (SCM_WEAK_TABLE_P (table))
- {
- scm_weak_table_for_each (proc, table);
- return SCM_UNSPECIFIED;
- }
- SCM_VALIDATE_HASHTABLE (2, table);
-
- scm_internal_hash_for_each_handle (for_each_proc,
- (void *) SCM_UNPACK (proc),
- table);
- return SCM_UNSPECIFIED;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_hash_for_each_handle, "hash-for-each-handle", 2, 0, 0,
- (SCM proc, SCM table),
- "An iterator over hash-table elements.\n"
- "Applies PROC successively on all hash table handles.")
- #define FUNC_NAME s_scm_hash_for_each_handle
- {
- SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, 1, FUNC_NAME);
- SCM_VALIDATE_HASHTABLE (2, table);
-
- scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn) scm_call_1,
- (void *) SCM_UNPACK (proc),
- table);
- return SCM_UNSPECIFIED;
- }
- #undef FUNC_NAME
- static SCM
- map_proc (void *proc, SCM key, SCM data, SCM value)
- {
- return scm_cons (scm_call_2 (SCM_PACK (proc), key, data), value);
- }
- SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0,
- (SCM proc, SCM table),
- "An iterator over hash-table elements.\n"
- "Accumulates and returns as a list the results of applying PROC successively.\n"
- "The arguments to PROC are \"(key value)\" where key\n"
- "and value are successive pairs from the hash table TABLE.")
- #define FUNC_NAME s_scm_hash_map_to_list
- {
- SCM_VALIDATE_PROC (1, proc);
- if (SCM_WEAK_TABLE_P (table))
- return scm_weak_table_map_to_list (proc, table);
- SCM_VALIDATE_HASHTABLE (2, table);
- return scm_internal_hash_fold (map_proc,
- (void *) SCM_UNPACK (proc),
- SCM_EOL,
- table);
- }
- #undef FUNC_NAME
- static SCM
- count_proc (void *pred, SCM key, SCM data, SCM value)
- {
- if (scm_is_false (scm_call_2 (SCM_PACK (pred), key, data)))
- return value;
- else
- return scm_oneplus(value);
- }
- SCM_DEFINE (scm_hash_count, "hash-count", 2, 0, 0,
- (SCM pred, SCM table),
- "Return the number of elements in the given hash TABLE that\n"
- "cause `(PRED KEY VALUE)' to return true. To quickly determine\n"
- "the total number of elements, use `(const #t)' for PRED.")
- #define FUNC_NAME s_scm_hash_count
- {
- SCM init;
- SCM_VALIDATE_PROC (1, pred);
- SCM_VALIDATE_HASHTABLE (2, table);
- init = scm_from_int (0);
- return scm_internal_hash_fold ((scm_t_hash_fold_fn) count_proc,
- (void *) SCM_UNPACK (pred), init, table);
- }
- #undef FUNC_NAME
- SCM
- scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure,
- SCM init, SCM table)
- #define FUNC_NAME s_scm_hash_fold
- {
- long i, n;
- SCM buckets, result = init;
-
- if (SCM_WEAK_TABLE_P (table))
- return scm_c_weak_table_fold (fn, closure, init, table);
- SCM_VALIDATE_HASHTABLE (0, table);
- buckets = SCM_HASHTABLE_VECTOR (table);
-
- n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
- for (i = 0; i < n; ++i)
- {
- SCM ls, handle;
- for (ls = SCM_SIMPLE_VECTOR_REF (buckets, i); !scm_is_null (ls);
- ls = SCM_CDR (ls))
- {
- handle = SCM_CAR (ls);
- result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
- }
- }
- return result;
- }
- #undef FUNC_NAME
- /* The following redundant code is here in order to be able to support
- hash-for-each-handle. An alternative would have been to replace
- this code and scm_internal_hash_fold above with a single
- scm_internal_hash_fold_handles, but we don't want to promote such
- an API. */
- void
- scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn, void *closure,
- SCM table)
- #define FUNC_NAME s_scm_hash_for_each
- {
- long i, n;
- SCM buckets;
-
- SCM_VALIDATE_HASHTABLE (0, table);
- buckets = SCM_HASHTABLE_VECTOR (table);
- n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
- for (i = 0; i < n; ++i)
- {
- SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle;
- while (!scm_is_null (ls))
- {
- if (!scm_is_pair (ls))
- SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets);
- handle = SCM_CAR (ls);
- if (!scm_is_pair (handle))
- SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets);
- fn (closure, handle);
- ls = SCM_CDR (ls);
- }
- }
- }
- #undef FUNC_NAME
- void
- scm_init_hashtab ()
- {
- #include "hashtab.x"
- }
|