hashtab.c 31 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080
  1. /* Copyright 1995-1996,1998-2001,2003-2004,2006,2008-2013,2018
  2. Free Software Foundation, Inc.
  3. This file is part of Guile.
  4. Guile is free software: you can redistribute it and/or modify it
  5. under the terms of the GNU Lesser General Public License as published
  6. by the Free Software Foundation, either version 3 of the License, or
  7. (at your option) any later version.
  8. Guile is distributed in the hope that it will be useful, but WITHOUT
  9. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  10. FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
  11. License for more details.
  12. You should have received a copy of the GNU Lesser General Public
  13. License along with Guile. If not, see
  14. <https://www.gnu.org/licenses/>. */
  15. #ifdef HAVE_CONFIG_H
  16. # include <config.h>
  17. #endif
  18. #include <alloca.h>
  19. #include <assert.h>
  20. #include <stdio.h>
  21. #include "alist.h"
  22. #include "bdw-gc.h"
  23. #include "boolean.h"
  24. #include "eq.h"
  25. #include "eval.h"
  26. #include "gsubr.h"
  27. #include "hash.h"
  28. #include "list.h"
  29. #include "numbers.h"
  30. #include "pairs.h"
  31. #include "ports.h"
  32. #include "procs.h"
  33. #include "vectors.h"
  34. #include "weak-table.h"
  35. #include "hashtab.h"
  36. /* A hash table is a cell containing a vector of association lists.
  37. *
  38. * Growing or shrinking, with following rehashing, is triggered when
  39. * the load factor
  40. *
  41. * L = N / S (N: number of items in table, S: bucket vector length)
  42. *
  43. * passes an upper limit of 0.9 or a lower limit of 0.25.
  44. *
  45. * The implementation stores the upper and lower number of items which
  46. * trigger a resize in the hashtable object.
  47. *
  48. * Possible hash table sizes (primes) are stored in the array
  49. * hashtable_size.
  50. */
  51. static unsigned long hashtable_size[] = {
  52. 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
  53. 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
  54. #if SIZEOF_UINTPTR_T > 4
  55. /* vector lengths are stored in the first word of vectors, shifted by
  56. 8 bits for the tc8, so for 32-bit we only get 2^24-1 = 16777215
  57. elements. But we allow a few more sizes for 64-bit. */
  58. , 28762081, 57524111, 115048217, 230096423, 460192829
  59. #endif
  60. };
  61. #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
  62. static char *s_hashtable = "hashtable";
  63. static SCM
  64. make_hash_table (unsigned long k, const char *func_name)
  65. {
  66. SCM vector;
  67. scm_t_hashtable *t;
  68. int i = 0, n = k ? k : 31;
  69. while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i])
  70. ++i;
  71. n = hashtable_size[i];
  72. vector = scm_c_make_vector (n, SCM_EOL);
  73. t = scm_gc_malloc_pointerless (sizeof (*t), s_hashtable);
  74. t->min_size_index = t->size_index = i;
  75. t->n_items = 0;
  76. t->lower = 0;
  77. t->upper = 9 * n / 10;
  78. /* FIXME: we just need two words of storage, not three */
  79. return scm_double_cell (scm_tc7_hashtable, SCM_UNPACK (vector),
  80. (scm_t_bits)t, 0);
  81. }
  82. void
  83. scm_i_rehash (SCM table,
  84. scm_t_hash_fn hash_fn,
  85. void *closure,
  86. const char* func_name)
  87. {
  88. SCM buckets, new_buckets;
  89. int i;
  90. unsigned long old_size;
  91. unsigned long new_size;
  92. if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
  93. {
  94. /* rehashing is not triggered when i <= min_size */
  95. i = SCM_HASHTABLE (table)->size_index;
  96. do
  97. --i;
  98. while (i > SCM_HASHTABLE (table)->min_size_index
  99. && SCM_HASHTABLE_N_ITEMS (table) < hashtable_size[i] / 4);
  100. }
  101. else
  102. {
  103. i = SCM_HASHTABLE (table)->size_index + 1;
  104. if (i >= HASHTABLE_SIZE_N)
  105. /* don't rehash */
  106. return;
  107. }
  108. SCM_HASHTABLE (table)->size_index = i;
  109. new_size = hashtable_size[i];
  110. if (i <= SCM_HASHTABLE (table)->min_size_index)
  111. SCM_HASHTABLE (table)->lower = 0;
  112. else
  113. SCM_HASHTABLE (table)->lower = new_size / 4;
  114. SCM_HASHTABLE (table)->upper = 9 * new_size / 10;
  115. buckets = SCM_HASHTABLE_VECTOR (table);
  116. new_buckets = scm_c_make_vector (new_size, SCM_EOL);
  117. SCM_SET_HASHTABLE_VECTOR (table, new_buckets);
  118. SCM_SET_HASHTABLE_N_ITEMS (table, 0);
  119. old_size = SCM_SIMPLE_VECTOR_LENGTH (buckets);
  120. for (i = 0; i < old_size; ++i)
  121. {
  122. SCM ls, cell, handle;
  123. ls = SCM_SIMPLE_VECTOR_REF (buckets, i);
  124. SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_EOL);
  125. while (scm_is_pair (ls))
  126. {
  127. unsigned long h;
  128. cell = ls;
  129. handle = SCM_CAR (cell);
  130. ls = SCM_CDR (ls);
  131. h = hash_fn (SCM_CAR (handle), new_size, closure);
  132. if (h >= new_size)
  133. scm_out_of_range (func_name, scm_from_ulong (h));
  134. SCM_SETCDR (cell, SCM_SIMPLE_VECTOR_REF (new_buckets, h));
  135. SCM_SIMPLE_VECTOR_SET (new_buckets, h, cell);
  136. SCM_HASHTABLE_INCREMENT (table);
  137. }
  138. }
  139. }
  140. void
  141. scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
  142. {
  143. scm_puts ("#<hash-table ", port);
  144. scm_uintprint (SCM_UNPACK (exp), 16, port);
  145. scm_putc (' ', port);
  146. scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
  147. scm_putc ('/', port);
  148. scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
  149. 10, port);
  150. scm_puts (">", port);
  151. }
  152. SCM
  153. scm_c_make_hash_table (unsigned long k)
  154. {
  155. return make_hash_table (k, "scm_c_make_hash_table");
  156. }
  157. SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0,
  158. (SCM n),
  159. "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
  160. #define FUNC_NAME s_scm_make_hash_table
  161. {
  162. return make_hash_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), FUNC_NAME);
  163. }
  164. #undef FUNC_NAME
  165. #define SCM_WEAK_TABLE_P(x) (scm_is_true (scm_weak_table_p (x)))
  166. SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0,
  167. (SCM obj),
  168. "Return @code{#t} if @var{obj} is an abstract hash table object.")
  169. #define FUNC_NAME s_scm_hash_table_p
  170. {
  171. return scm_from_bool (SCM_HASHTABLE_P (obj) || SCM_WEAK_TABLE_P (obj));
  172. }
  173. #undef FUNC_NAME
  174. /* Accessing hash table entries. */
  175. SCM
  176. scm_hash_fn_get_handle (SCM table, SCM obj,
  177. scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
  178. void * closure)
  179. #define FUNC_NAME "scm_hash_fn_get_handle"
  180. {
  181. unsigned long k;
  182. SCM buckets, h;
  183. SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
  184. buckets = SCM_HASHTABLE_VECTOR (table);
  185. if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
  186. return SCM_BOOL_F;
  187. k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
  188. if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
  189. scm_out_of_range (FUNC_NAME, scm_from_ulong (k));
  190. h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
  191. return h;
  192. }
  193. #undef FUNC_NAME
  194. SCM
  195. scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init,
  196. scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
  197. void * closure)
  198. #define FUNC_NAME "scm_hash_fn_create_handle_x"
  199. {
  200. unsigned long k;
  201. SCM buckets, it;
  202. SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
  203. buckets = SCM_HASHTABLE_VECTOR (table);
  204. if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
  205. SCM_MISC_ERROR ("void hashtable", SCM_EOL);
  206. k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
  207. if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
  208. scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
  209. it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
  210. if (scm_is_pair (it))
  211. return it;
  212. else if (scm_is_true (it))
  213. scm_wrong_type_arg_msg (NULL, 0, it, "a pair");
  214. else
  215. {
  216. SCM handle, new_bucket;
  217. handle = scm_cons (obj, init);
  218. new_bucket = scm_cons (handle, SCM_EOL);
  219. if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets))
  220. {
  221. buckets = SCM_HASHTABLE_VECTOR (table);
  222. k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
  223. if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
  224. scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
  225. }
  226. SCM_SETCDR (new_bucket, SCM_SIMPLE_VECTOR_REF (buckets, k));
  227. SCM_SIMPLE_VECTOR_SET (buckets, k, new_bucket);
  228. SCM_HASHTABLE_INCREMENT (table);
  229. /* Maybe rehash the table. */
  230. if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table)
  231. || SCM_HASHTABLE_N_ITEMS (table) > SCM_HASHTABLE_UPPER (table))
  232. scm_i_rehash (table, hash_fn, closure, FUNC_NAME);
  233. return SCM_CAR (new_bucket);
  234. }
  235. }
  236. #undef FUNC_NAME
  237. SCM
  238. scm_hash_fn_ref (SCM table, SCM obj, SCM dflt,
  239. scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
  240. void *closure)
  241. {
  242. SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure);
  243. if (scm_is_pair (it))
  244. return SCM_CDR (it);
  245. else
  246. return dflt;
  247. }
  248. SCM
  249. scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
  250. scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
  251. void *closure)
  252. {
  253. SCM pair;
  254. pair = scm_hash_fn_create_handle_x (table, obj, val,
  255. hash_fn, assoc_fn, closure);
  256. if (!scm_is_eq (SCM_CDR (pair), val))
  257. SCM_SETCDR (pair, val);
  258. return val;
  259. }
  260. SCM
  261. scm_hash_fn_remove_x (SCM table, SCM obj,
  262. scm_t_hash_fn hash_fn,
  263. scm_t_assoc_fn assoc_fn,
  264. void *closure)
  265. #define FUNC_NAME "hash_fn_remove_x"
  266. {
  267. unsigned long k;
  268. SCM buckets, h;
  269. SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
  270. buckets = SCM_HASHTABLE_VECTOR (table);
  271. if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
  272. return SCM_EOL;
  273. k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
  274. if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
  275. scm_out_of_range (FUNC_NAME, scm_from_ulong (k));
  276. h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
  277. if (scm_is_true (h))
  278. {
  279. SCM_SIMPLE_VECTOR_SET
  280. (buckets, k, scm_delq_x (h, SCM_SIMPLE_VECTOR_REF (buckets, k)));
  281. SCM_HASHTABLE_DECREMENT (table);
  282. if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
  283. scm_i_rehash (table, hash_fn, closure, FUNC_NAME);
  284. }
  285. return h;
  286. }
  287. #undef FUNC_NAME
  288. SCM_DEFINE (scm_hash_clear_x, "hash-clear!", 1, 0, 0,
  289. (SCM table),
  290. "Remove all items from @var{table} (without triggering a resize).")
  291. #define FUNC_NAME s_scm_hash_clear_x
  292. {
  293. if (SCM_WEAK_TABLE_P (table))
  294. {
  295. scm_weak_table_clear_x (table);
  296. return SCM_UNSPECIFIED;
  297. }
  298. SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
  299. scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL);
  300. SCM_SET_HASHTABLE_N_ITEMS (table, 0);
  301. return SCM_UNSPECIFIED;
  302. }
  303. #undef FUNC_NAME
  304. SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0,
  305. (SCM table, SCM key),
  306. "This procedure returns the @code{(key . value)} pair from the\n"
  307. "hash table @var{table}. If @var{table} does not hold an\n"
  308. "associated value for @var{key}, @code{#f} is returned.\n"
  309. "Uses @code{eq?} for equality testing.")
  310. #define FUNC_NAME s_scm_hashq_get_handle
  311. {
  312. return scm_hash_fn_get_handle (table, key,
  313. (scm_t_hash_fn) scm_ihashq,
  314. (scm_t_assoc_fn) scm_sloppy_assq,
  315. 0);
  316. }
  317. #undef FUNC_NAME
  318. SCM_DEFINE (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0,
  319. (SCM table, SCM key, SCM init),
  320. "This function looks up @var{key} in @var{table} and returns its handle.\n"
  321. "If @var{key} is not already present, a new handle is created which\n"
  322. "associates @var{key} with @var{init}.")
  323. #define FUNC_NAME s_scm_hashq_create_handle_x
  324. {
  325. return scm_hash_fn_create_handle_x (table, key, init,
  326. (scm_t_hash_fn) scm_ihashq,
  327. (scm_t_assoc_fn) scm_sloppy_assq,
  328. 0);
  329. }
  330. #undef FUNC_NAME
  331. SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0,
  332. (SCM table, SCM key, SCM dflt),
  333. "Look up @var{key} in the hash table @var{table}, and return the\n"
  334. "value (if any) associated with it. If @var{key} is not found,\n"
  335. "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
  336. "is supplied). Uses @code{eq?} for equality testing.")
  337. #define FUNC_NAME s_scm_hashq_ref
  338. {
  339. if (SCM_UNBNDP (dflt))
  340. dflt = SCM_BOOL_F;
  341. if (SCM_WEAK_TABLE_P (table))
  342. return scm_weak_table_refq (table, key, dflt);
  343. return scm_hash_fn_ref (table, key, dflt,
  344. (scm_t_hash_fn) scm_ihashq,
  345. (scm_t_assoc_fn) scm_sloppy_assq,
  346. 0);
  347. }
  348. #undef FUNC_NAME
  349. SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0,
  350. (SCM table, SCM key, SCM val),
  351. "Find the entry in @var{table} associated with @var{key}, and\n"
  352. "store @var{val} there. Uses @code{eq?} for equality testing.")
  353. #define FUNC_NAME s_scm_hashq_set_x
  354. {
  355. if (SCM_WEAK_TABLE_P (table))
  356. {
  357. scm_weak_table_putq_x (table, key, val);
  358. return val;
  359. }
  360. return scm_hash_fn_set_x (table, key, val,
  361. (scm_t_hash_fn) scm_ihashq,
  362. (scm_t_assoc_fn) scm_sloppy_assq,
  363. 0);
  364. }
  365. #undef FUNC_NAME
  366. SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0,
  367. (SCM table, SCM key),
  368. "Remove @var{key} (and any value associated with it) from\n"
  369. "@var{table}. Uses @code{eq?} for equality tests.")
  370. #define FUNC_NAME s_scm_hashq_remove_x
  371. {
  372. if (SCM_WEAK_TABLE_P (table))
  373. {
  374. scm_weak_table_remq_x (table, key);
  375. /* This return value is for historical compatibility with
  376. hash-remove!, which returns either the "handle" corresponding
  377. to the entry, or #f. Since weak tables don't have handles, we
  378. have to return #f. */
  379. return SCM_BOOL_F;
  380. }
  381. return scm_hash_fn_remove_x (table, key,
  382. (scm_t_hash_fn) scm_ihashq,
  383. (scm_t_assoc_fn) scm_sloppy_assq,
  384. 0);
  385. }
  386. #undef FUNC_NAME
  387. SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0,
  388. (SCM table, SCM key),
  389. "This procedure returns the @code{(key . value)} pair from the\n"
  390. "hash table @var{table}. If @var{table} does not hold an\n"
  391. "associated value for @var{key}, @code{#f} is returned.\n"
  392. "Uses @code{eqv?} for equality testing.")
  393. #define FUNC_NAME s_scm_hashv_get_handle
  394. {
  395. return scm_hash_fn_get_handle (table, key,
  396. (scm_t_hash_fn) scm_ihashv,
  397. (scm_t_assoc_fn) scm_sloppy_assv,
  398. 0);
  399. }
  400. #undef FUNC_NAME
  401. SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0,
  402. (SCM table, SCM key, SCM init),
  403. "This function looks up @var{key} in @var{table} and returns its handle.\n"
  404. "If @var{key} is not already present, a new handle is created which\n"
  405. "associates @var{key} with @var{init}.")
  406. #define FUNC_NAME s_scm_hashv_create_handle_x
  407. {
  408. return scm_hash_fn_create_handle_x (table, key, init,
  409. (scm_t_hash_fn) scm_ihashv,
  410. (scm_t_assoc_fn) scm_sloppy_assv,
  411. 0);
  412. }
  413. #undef FUNC_NAME
  414. static int
  415. assv_predicate (SCM k, SCM v, void *closure)
  416. {
  417. return scm_is_true (scm_eqv_p (k, SCM_PACK_POINTER (closure)));
  418. }
  419. SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0,
  420. (SCM table, SCM key, SCM dflt),
  421. "Look up @var{key} in the hash table @var{table}, and return the\n"
  422. "value (if any) associated with it. If @var{key} is not found,\n"
  423. "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
  424. "is supplied). Uses @code{eqv?} for equality testing.")
  425. #define FUNC_NAME s_scm_hashv_ref
  426. {
  427. if (SCM_UNBNDP (dflt))
  428. dflt = SCM_BOOL_F;
  429. if (SCM_WEAK_TABLE_P (table))
  430. return scm_c_weak_table_ref (table, scm_ihashv (key, -1),
  431. assv_predicate,
  432. (void *) SCM_UNPACK (key), dflt);
  433. return scm_hash_fn_ref (table, key, dflt,
  434. (scm_t_hash_fn) scm_ihashv,
  435. (scm_t_assoc_fn) scm_sloppy_assv,
  436. 0);
  437. }
  438. #undef FUNC_NAME
  439. SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0,
  440. (SCM table, SCM key, SCM val),
  441. "Find the entry in @var{table} associated with @var{key}, and\n"
  442. "store @var{value} there. Uses @code{eqv?} for equality testing.")
  443. #define FUNC_NAME s_scm_hashv_set_x
  444. {
  445. if (SCM_WEAK_TABLE_P (table))
  446. {
  447. scm_c_weak_table_put_x (table, scm_ihashv (key, -1),
  448. assv_predicate, (void *) SCM_UNPACK (key),
  449. key, val);
  450. return val;
  451. }
  452. return scm_hash_fn_set_x (table, key, val,
  453. (scm_t_hash_fn) scm_ihashv,
  454. (scm_t_assoc_fn) scm_sloppy_assv,
  455. 0);
  456. }
  457. #undef FUNC_NAME
  458. SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0,
  459. (SCM table, SCM key),
  460. "Remove @var{key} (and any value associated with it) from\n"
  461. "@var{table}. Uses @code{eqv?} for equality tests.")
  462. #define FUNC_NAME s_scm_hashv_remove_x
  463. {
  464. if (SCM_WEAK_TABLE_P (table))
  465. {
  466. scm_c_weak_table_remove_x (table, scm_ihashv (key, -1),
  467. assv_predicate, (void *) SCM_UNPACK (key));
  468. /* See note in hashq-remove!. */
  469. return SCM_BOOL_F;
  470. }
  471. return scm_hash_fn_remove_x (table, key,
  472. (scm_t_hash_fn) scm_ihashv,
  473. (scm_t_assoc_fn) scm_sloppy_assv,
  474. 0);
  475. }
  476. #undef FUNC_NAME
  477. SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0,
  478. (SCM table, SCM key),
  479. "This procedure returns the @code{(key . value)} pair from the\n"
  480. "hash table @var{table}. If @var{table} does not hold an\n"
  481. "associated value for @var{key}, @code{#f} is returned.\n"
  482. "Uses @code{equal?} for equality testing.")
  483. #define FUNC_NAME s_scm_hash_get_handle
  484. {
  485. return scm_hash_fn_get_handle (table, key,
  486. (scm_t_hash_fn) scm_ihash,
  487. (scm_t_assoc_fn) scm_sloppy_assoc,
  488. 0);
  489. }
  490. #undef FUNC_NAME
  491. SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0,
  492. (SCM table, SCM key, SCM init),
  493. "This function looks up @var{key} in @var{table} and returns its handle.\n"
  494. "If @var{key} is not already present, a new handle is created which\n"
  495. "associates @var{key} with @var{init}.")
  496. #define FUNC_NAME s_scm_hash_create_handle_x
  497. {
  498. return scm_hash_fn_create_handle_x (table, key, init,
  499. (scm_t_hash_fn) scm_ihash,
  500. (scm_t_assoc_fn) scm_sloppy_assoc,
  501. 0);
  502. }
  503. #undef FUNC_NAME
  504. static int
  505. assoc_predicate (SCM k, SCM v, void *closure)
  506. {
  507. return scm_is_true (scm_equal_p (k, SCM_PACK_POINTER (closure)));
  508. }
  509. SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0,
  510. (SCM table, SCM key, SCM dflt),
  511. "Look up @var{key} in the hash table @var{table}, and return the\n"
  512. "value (if any) associated with it. If @var{key} is not found,\n"
  513. "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
  514. "is supplied). Uses @code{equal?} for equality testing.")
  515. #define FUNC_NAME s_scm_hash_ref
  516. {
  517. if (SCM_UNBNDP (dflt))
  518. dflt = SCM_BOOL_F;
  519. if (SCM_WEAK_TABLE_P (table))
  520. return scm_c_weak_table_ref (table, scm_ihash (key, -1),
  521. assoc_predicate,
  522. (void *) SCM_UNPACK (key), dflt);
  523. return scm_hash_fn_ref (table, key, dflt,
  524. (scm_t_hash_fn) scm_ihash,
  525. (scm_t_assoc_fn) scm_sloppy_assoc,
  526. 0);
  527. }
  528. #undef FUNC_NAME
  529. SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0,
  530. (SCM table, SCM key, SCM val),
  531. "Find the entry in @var{table} associated with @var{key}, and\n"
  532. "store @var{val} there. Uses @code{equal?} for equality\n"
  533. "testing.")
  534. #define FUNC_NAME s_scm_hash_set_x
  535. {
  536. if (SCM_WEAK_TABLE_P (table))
  537. {
  538. scm_c_weak_table_put_x (table, scm_ihash (key, -1),
  539. assoc_predicate, (void *) SCM_UNPACK (key),
  540. key, val);
  541. return val;
  542. }
  543. return scm_hash_fn_set_x (table, key, val,
  544. (scm_t_hash_fn) scm_ihash,
  545. (scm_t_assoc_fn) scm_sloppy_assoc,
  546. 0);
  547. }
  548. #undef FUNC_NAME
  549. SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0,
  550. (SCM table, SCM key),
  551. "Remove @var{key} (and any value associated with it) from\n"
  552. "@var{table}. Uses @code{equal?} for equality tests.")
  553. #define FUNC_NAME s_scm_hash_remove_x
  554. {
  555. if (SCM_WEAK_TABLE_P (table))
  556. {
  557. scm_c_weak_table_remove_x (table, scm_ihash (key, -1),
  558. assoc_predicate, (void *) SCM_UNPACK (key));
  559. /* See note in hashq-remove!. */
  560. return SCM_BOOL_F;
  561. }
  562. return scm_hash_fn_remove_x (table, key,
  563. (scm_t_hash_fn) scm_ihash,
  564. (scm_t_assoc_fn) scm_sloppy_assoc,
  565. 0);
  566. }
  567. #undef FUNC_NAME
  568. typedef struct scm_t_ihashx_closure
  569. {
  570. SCM hash;
  571. SCM assoc;
  572. SCM key;
  573. } scm_t_ihashx_closure;
  574. static unsigned long
  575. scm_ihashx (SCM obj, unsigned long n, void *arg)
  576. {
  577. SCM answer;
  578. scm_t_ihashx_closure *closure = (scm_t_ihashx_closure *) arg;
  579. answer = scm_call_2 (closure->hash, obj, scm_from_ulong (n));
  580. return scm_to_ulong (answer);
  581. }
  582. static SCM
  583. scm_sloppy_assx (SCM obj, SCM alist, void *arg)
  584. {
  585. scm_t_ihashx_closure *closure = (scm_t_ihashx_closure *) arg;
  586. return scm_call_2 (closure->assoc, obj, alist);
  587. }
  588. static int
  589. assx_predicate (SCM k, SCM v, void *closure)
  590. {
  591. scm_t_ihashx_closure *c = (scm_t_ihashx_closure *) closure;
  592. /* FIXME: The hashx interface is crazy. Hash tables have nothing to
  593. do with alists in principle. Instead of getting an assoc proc,
  594. hashx functions should use an equality predicate. Perhaps we can
  595. change this before 2.2, but until then, add a terrible, terrible
  596. hack. */
  597. return scm_is_true (scm_call_2 (c->assoc, c->key, scm_acons (k, v, SCM_EOL)));
  598. }
  599. SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0,
  600. (SCM hash, SCM assoc, SCM table, SCM key),
  601. "This behaves the same way as the corresponding\n"
  602. "@code{-get-handle} function, but uses @var{hash} as a hash\n"
  603. "function and @var{assoc} to compare keys. @code{hash} must be\n"
  604. "a function that takes two arguments, a key to be hashed and a\n"
  605. "table size. @code{assoc} must be an associator function, like\n"
  606. "@code{assoc}, @code{assq} or @code{assv}.")
  607. #define FUNC_NAME s_scm_hashx_get_handle
  608. {
  609. scm_t_ihashx_closure closure;
  610. closure.hash = hash;
  611. closure.assoc = assoc;
  612. closure.key = key;
  613. return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx,
  614. (void *) &closure);
  615. }
  616. #undef FUNC_NAME
  617. SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0,
  618. (SCM hash, SCM assoc, SCM table, SCM key, SCM init),
  619. "This behaves the same way as the corresponding\n"
  620. "@code{-create-handle} function, but uses @var{hash} as a hash\n"
  621. "function and @var{assoc} to compare keys. @code{hash} must be\n"
  622. "a function that takes two arguments, a key to be hashed and a\n"
  623. "table size. @code{assoc} must be an associator function, like\n"
  624. "@code{assoc}, @code{assq} or @code{assv}.")
  625. #define FUNC_NAME s_scm_hashx_create_handle_x
  626. {
  627. scm_t_ihashx_closure closure;
  628. closure.hash = hash;
  629. closure.assoc = assoc;
  630. closure.key = key;
  631. return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx,
  632. scm_sloppy_assx, (void *)&closure);
  633. }
  634. #undef FUNC_NAME
  635. SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0,
  636. (SCM hash, SCM assoc, SCM table, SCM key, SCM dflt),
  637. "This behaves the same way as the corresponding @code{ref}\n"
  638. "function, but uses @var{hash} as a hash function and\n"
  639. "@var{assoc} to compare keys. @code{hash} must be a function\n"
  640. "that takes two arguments, a key to be hashed and a table size.\n"
  641. "@code{assoc} must be an associator function, like @code{assoc},\n"
  642. "@code{assq} or @code{assv}.\n"
  643. "\n"
  644. "By way of illustration, @code{hashq-ref table key} is\n"
  645. "equivalent to @code{hashx-ref hashq assq table key}.")
  646. #define FUNC_NAME s_scm_hashx_ref
  647. {
  648. scm_t_ihashx_closure closure;
  649. if (SCM_UNBNDP (dflt))
  650. dflt = SCM_BOOL_F;
  651. closure.hash = hash;
  652. closure.assoc = assoc;
  653. closure.key = key;
  654. if (SCM_WEAK_TABLE_P (table))
  655. {
  656. unsigned long h = scm_to_ulong (scm_call_2 (hash, key,
  657. scm_from_ulong (-1)));
  658. return scm_c_weak_table_ref (table, h, assx_predicate, &closure, dflt);
  659. }
  660. return scm_hash_fn_ref (table, key, dflt, scm_ihashx, scm_sloppy_assx,
  661. (void *)&closure);
  662. }
  663. #undef FUNC_NAME
  664. SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0,
  665. (SCM hash, SCM assoc, SCM table, SCM key, SCM val),
  666. "This behaves the same way as the corresponding @code{set!}\n"
  667. "function, but uses @var{hash} as a hash function and\n"
  668. "@var{assoc} to compare keys. @code{hash} must be a function\n"
  669. "that takes two arguments, a key to be hashed and a table size.\n"
  670. "@code{assoc} must be an associator function, like @code{assoc},\n"
  671. "@code{assq} or @code{assv}.\n"
  672. "\n"
  673. " By way of illustration, @code{hashq-set! table key} is\n"
  674. "equivalent to @code{hashx-set! hashq assq table key}.")
  675. #define FUNC_NAME s_scm_hashx_set_x
  676. {
  677. scm_t_ihashx_closure closure;
  678. closure.hash = hash;
  679. closure.assoc = assoc;
  680. closure.key = key;
  681. if (SCM_WEAK_TABLE_P (table))
  682. {
  683. unsigned long h = scm_to_ulong (scm_call_2 (hash, key,
  684. scm_from_ulong (-1)));
  685. scm_c_weak_table_put_x (table, h, assx_predicate, &closure, key, val);
  686. return val;
  687. }
  688. return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx,
  689. (void *)&closure);
  690. }
  691. #undef FUNC_NAME
  692. SCM_DEFINE (scm_hashx_remove_x, "hashx-remove!", 4, 0, 0,
  693. (SCM hash, SCM assoc, SCM table, SCM obj),
  694. "This behaves the same way as the corresponding @code{remove!}\n"
  695. "function, but uses @var{hash} as a hash function and\n"
  696. "@var{assoc} to compare keys. @code{hash} must be a function\n"
  697. "that takes two arguments, a key to be hashed and a table size.\n"
  698. "@code{assoc} must be an associator function, like @code{assoc},\n"
  699. "@code{assq} or @code{assv}.\n"
  700. "\n"
  701. " By way of illustration, @code{hashq-remove! table key} is\n"
  702. "equivalent to @code{hashx-remove! hashq assq #f table key}.")
  703. #define FUNC_NAME s_scm_hashx_remove_x
  704. {
  705. scm_t_ihashx_closure closure;
  706. closure.hash = hash;
  707. closure.assoc = assoc;
  708. closure.key = obj;
  709. if (SCM_WEAK_TABLE_P (table))
  710. {
  711. unsigned long h = scm_to_ulong (scm_call_2 (hash, obj,
  712. scm_from_ulong (-1)));
  713. scm_c_weak_table_remove_x (table, h, assx_predicate, &closure);
  714. /* See note in hashq-remove!. */
  715. return SCM_BOOL_F;
  716. }
  717. return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx,
  718. (void *) &closure);
  719. }
  720. #undef FUNC_NAME
  721. /* Hash table iterators */
  722. SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0,
  723. (SCM proc, SCM init, SCM table),
  724. "An iterator over hash-table elements.\n"
  725. "Accumulates and returns a result by applying PROC successively.\n"
  726. "The arguments to PROC are \"(key value prior-result)\" where key\n"
  727. "and value are successive pairs from the hash table TABLE, and\n"
  728. "prior-result is either INIT (for the first application of PROC)\n"
  729. "or the return value of the previous application of PROC.\n"
  730. "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
  731. "table into an a-list of key-value pairs.")
  732. #define FUNC_NAME s_scm_hash_fold
  733. {
  734. SCM_VALIDATE_PROC (1, proc);
  735. if (SCM_WEAK_TABLE_P (table))
  736. return scm_weak_table_fold (proc, init, table);
  737. SCM_VALIDATE_HASHTABLE (3, table);
  738. return scm_internal_hash_fold ((scm_t_hash_fold_fn) scm_call_3,
  739. (void *) SCM_UNPACK (proc), init, table);
  740. }
  741. #undef FUNC_NAME
  742. static SCM
  743. for_each_proc (void *proc, SCM handle)
  744. {
  745. return scm_call_2 (SCM_PACK (proc), SCM_CAR (handle), SCM_CDR (handle));
  746. }
  747. SCM_DEFINE (scm_hash_for_each, "hash-for-each", 2, 0, 0,
  748. (SCM proc, SCM table),
  749. "An iterator over hash-table elements.\n"
  750. "Applies PROC successively on all hash table items.\n"
  751. "The arguments to PROC are \"(key value)\" where key\n"
  752. "and value are successive pairs from the hash table TABLE.")
  753. #define FUNC_NAME s_scm_hash_for_each
  754. {
  755. SCM_VALIDATE_PROC (1, proc);
  756. if (SCM_WEAK_TABLE_P (table))
  757. {
  758. scm_weak_table_for_each (proc, table);
  759. return SCM_UNSPECIFIED;
  760. }
  761. SCM_VALIDATE_HASHTABLE (2, table);
  762. scm_internal_hash_for_each_handle (for_each_proc,
  763. (void *) SCM_UNPACK (proc),
  764. table);
  765. return SCM_UNSPECIFIED;
  766. }
  767. #undef FUNC_NAME
  768. SCM_DEFINE (scm_hash_for_each_handle, "hash-for-each-handle", 2, 0, 0,
  769. (SCM proc, SCM table),
  770. "An iterator over hash-table elements.\n"
  771. "Applies PROC successively on all hash table handles.")
  772. #define FUNC_NAME s_scm_hash_for_each_handle
  773. {
  774. SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, 1, FUNC_NAME);
  775. SCM_VALIDATE_HASHTABLE (2, table);
  776. scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn) scm_call_1,
  777. (void *) SCM_UNPACK (proc),
  778. table);
  779. return SCM_UNSPECIFIED;
  780. }
  781. #undef FUNC_NAME
  782. static SCM
  783. map_proc (void *proc, SCM key, SCM data, SCM value)
  784. {
  785. return scm_cons (scm_call_2 (SCM_PACK (proc), key, data), value);
  786. }
  787. SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0,
  788. (SCM proc, SCM table),
  789. "An iterator over hash-table elements.\n"
  790. "Accumulates and returns as a list the results of applying PROC successively.\n"
  791. "The arguments to PROC are \"(key value)\" where key\n"
  792. "and value are successive pairs from the hash table TABLE.")
  793. #define FUNC_NAME s_scm_hash_map_to_list
  794. {
  795. SCM_VALIDATE_PROC (1, proc);
  796. if (SCM_WEAK_TABLE_P (table))
  797. return scm_weak_table_map_to_list (proc, table);
  798. SCM_VALIDATE_HASHTABLE (2, table);
  799. return scm_internal_hash_fold (map_proc,
  800. (void *) SCM_UNPACK (proc),
  801. SCM_EOL,
  802. table);
  803. }
  804. #undef FUNC_NAME
  805. static SCM
  806. count_proc (void *pred, SCM key, SCM data, SCM value)
  807. {
  808. if (scm_is_false (scm_call_2 (SCM_PACK (pred), key, data)))
  809. return value;
  810. else
  811. return scm_oneplus(value);
  812. }
  813. SCM_DEFINE (scm_hash_count, "hash-count", 2, 0, 0,
  814. (SCM pred, SCM table),
  815. "Return the number of elements in the given hash TABLE that\n"
  816. "cause `(PRED KEY VALUE)' to return true. To quickly determine\n"
  817. "the total number of elements, use `(const #t)' for PRED.")
  818. #define FUNC_NAME s_scm_hash_count
  819. {
  820. SCM init;
  821. SCM_VALIDATE_PROC (1, pred);
  822. SCM_VALIDATE_HASHTABLE (2, table);
  823. init = scm_from_int (0);
  824. return scm_internal_hash_fold ((scm_t_hash_fold_fn) count_proc,
  825. (void *) SCM_UNPACK (pred), init, table);
  826. }
  827. #undef FUNC_NAME
  828. SCM
  829. scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure,
  830. SCM init, SCM table)
  831. #define FUNC_NAME s_scm_hash_fold
  832. {
  833. long i, n;
  834. SCM buckets, result = init;
  835. if (SCM_WEAK_TABLE_P (table))
  836. return scm_c_weak_table_fold (fn, closure, init, table);
  837. SCM_VALIDATE_HASHTABLE (0, table);
  838. buckets = SCM_HASHTABLE_VECTOR (table);
  839. n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
  840. for (i = 0; i < n; ++i)
  841. {
  842. SCM ls, handle;
  843. for (ls = SCM_SIMPLE_VECTOR_REF (buckets, i); !scm_is_null (ls);
  844. ls = SCM_CDR (ls))
  845. {
  846. handle = SCM_CAR (ls);
  847. result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
  848. }
  849. }
  850. return result;
  851. }
  852. #undef FUNC_NAME
  853. /* The following redundant code is here in order to be able to support
  854. hash-for-each-handle. An alternative would have been to replace
  855. this code and scm_internal_hash_fold above with a single
  856. scm_internal_hash_fold_handles, but we don't want to promote such
  857. an API. */
  858. void
  859. scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn, void *closure,
  860. SCM table)
  861. #define FUNC_NAME s_scm_hash_for_each
  862. {
  863. long i, n;
  864. SCM buckets;
  865. SCM_VALIDATE_HASHTABLE (0, table);
  866. buckets = SCM_HASHTABLE_VECTOR (table);
  867. n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
  868. for (i = 0; i < n; ++i)
  869. {
  870. SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle;
  871. while (!scm_is_null (ls))
  872. {
  873. if (!scm_is_pair (ls))
  874. SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets);
  875. handle = SCM_CAR (ls);
  876. if (!scm_is_pair (handle))
  877. SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets);
  878. fn (closure, handle);
  879. ls = SCM_CDR (ls);
  880. }
  881. }
  882. }
  883. #undef FUNC_NAME
  884. void
  885. scm_init_hashtab ()
  886. {
  887. #include "hashtab.x"
  888. }