Commit | Line | Data |
---|---|---|
78a0461a | 1 | /* Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc. |
0f2d19dd JB |
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 | |
82892bed JB |
15 | * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
16 | * Boston, MA 02111-1307 USA | |
0f2d19dd JB |
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. | |
82892bed | 40 | * If you do not wish that, delete this exception notice. */ |
1bbd0b84 GB |
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 | ||
0f2d19dd JB |
45 | \f |
46 | ||
47 | #include <stdio.h> | |
48 | #include "_scm.h" | |
20e6290e JB |
49 | #include "alist.h" |
50 | #include "hash.h" | |
51 | #include "eval.h" | |
0f2d19dd | 52 | |
1bbd0b84 | 53 | #include "scm_validate.h" |
20e6290e | 54 | #include "hashtab.h" |
0f2d19dd JB |
55 | \f |
56 | ||
1cc91f1b | 57 | |
0f2d19dd | 58 | SCM |
1bbd0b84 | 59 | scm_hash_fn_get_handle (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn)(),void * closure) |
0f2d19dd | 60 | { |
a085c2b4 | 61 | unsigned int k; |
0f2d19dd JB |
62 | SCM h; |
63 | ||
0c95b57d | 64 | SCM_ASSERT (SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_get_handle"); |
0f2d19dd JB |
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)), | |
a085c2b4 | 69 | scm_ulong2num (k), |
0f2d19dd JB |
70 | SCM_OUTOFRANGE, |
71 | "hash_fn_get_handle"); | |
72 | h = assoc_fn (obj, SCM_VELTS (table)[k], closure); | |
73 | return h; | |
74 | } | |
75 | ||
76 | ||
1cc91f1b | 77 | |
0f2d19dd | 78 | SCM |
1bbd0b84 GB |
79 | scm_hash_fn_create_handle_x (SCM table,SCM obj,SCM init,unsigned int (*hash_fn)(), |
80 | SCM (*assoc_fn)(),void * closure) | |
0f2d19dd | 81 | { |
a085c2b4 | 82 | unsigned int k; |
0f2d19dd JB |
83 | SCM it; |
84 | ||
0c95b57d | 85 | SCM_ASSERT (SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_create_handle_x"); |
0f2d19dd JB |
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)), | |
a085c2b4 | 90 | scm_ulong2num (k), |
0f2d19dd JB |
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 | ||
1cc91f1b | 112 | |
0f2d19dd | 113 | SCM |
1bbd0b84 GB |
114 | scm_hash_fn_ref (SCM table,SCM obj,SCM dflt,unsigned int (*hash_fn)(), |
115 | SCM (*assoc_fn)(),void * closure) | |
0f2d19dd JB |
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 | ||
1cc91f1b | 128 | |
0f2d19dd | 129 | SCM |
1bbd0b84 GB |
130 | scm_hash_fn_set_x (SCM table,SCM obj,SCM val,unsigned int (*hash_fn)(), |
131 | SCM (*assoc_fn)(),void * closure) | |
0f2d19dd JB |
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 | ||
1cc91f1b | 143 | |
0f2d19dd | 144 | SCM |
1bbd0b84 GB |
145 | scm_hash_fn_remove_x (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn)(), |
146 | SCM (*delete_fn)(),void * closure) | |
0f2d19dd | 147 | { |
a085c2b4 | 148 | unsigned int k; |
0f2d19dd JB |
149 | SCM h; |
150 | ||
0c95b57d | 151 | SCM_ASSERT (SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_remove_x"); |
0f2d19dd JB |
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)), | |
a085c2b4 | 156 | scm_ulong2num (k), |
0f2d19dd JB |
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 | ||
a1ec6916 | 167 | SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0, |
1bbd0b84 | 168 | (SCM table, SCM obj), |
4079f87e GB |
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)}.") | |
1bbd0b84 | 178 | #define FUNC_NAME s_scm_hashq_get_handle |
0f2d19dd JB |
179 | { |
180 | return scm_hash_fn_get_handle (table, obj, scm_ihashq, scm_sloppy_assq, 0); | |
181 | } | |
1bbd0b84 | 182 | #undef FUNC_NAME |
0f2d19dd JB |
183 | |
184 | ||
a1ec6916 | 185 | SCM_DEFINE (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0, |
1bbd0b84 | 186 | (SCM table, SCM obj, SCM init), |
4079f87e GB |
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}.") | |
1bbd0b84 | 193 | #define FUNC_NAME s_scm_hashq_create_handle_x |
0f2d19dd JB |
194 | { |
195 | return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashq, scm_sloppy_assq, 0); | |
196 | } | |
1bbd0b84 | 197 | #undef FUNC_NAME |
0f2d19dd JB |
198 | |
199 | ||
a1ec6916 | 200 | SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0, |
1bbd0b84 | 201 | (SCM table, SCM obj, SCM dflt), |
4079f87e GB |
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).") | |
1bbd0b84 | 208 | #define FUNC_NAME s_scm_hashq_ref |
0f2d19dd JB |
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 | } | |
1bbd0b84 | 214 | #undef FUNC_NAME |
0f2d19dd JB |
215 | |
216 | ||
217 | ||
a1ec6916 | 218 | SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0, |
1bbd0b84 | 219 | (SCM table, SCM obj, SCM val), |
4079f87e GB |
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.") | |
1bbd0b84 | 224 | #define FUNC_NAME s_scm_hashq_set_x |
0f2d19dd JB |
225 | { |
226 | return scm_hash_fn_set_x (table, obj, val, scm_ihashq, scm_sloppy_assq, 0); | |
227 | } | |
1bbd0b84 | 228 | #undef FUNC_NAME |
0f2d19dd JB |
229 | |
230 | ||
231 | ||
a1ec6916 | 232 | SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0, |
1bbd0b84 | 233 | (SCM table, SCM obj), |
4079f87e GB |
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}.") | |
1bbd0b84 | 237 | #define FUNC_NAME s_scm_hashq_remove_x |
0f2d19dd JB |
238 | { |
239 | return scm_hash_fn_remove_x (table, obj, scm_ihashq, scm_sloppy_assq, scm_delq_x, 0); | |
240 | } | |
1bbd0b84 | 241 | #undef FUNC_NAME |
0f2d19dd JB |
242 | |
243 | ||
244 | \f | |
245 | ||
a1ec6916 | 246 | SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0, |
1bbd0b84 GB |
247 | (SCM table, SCM obj), |
248 | "") | |
249 | #define FUNC_NAME s_scm_hashv_get_handle | |
0f2d19dd JB |
250 | { |
251 | return scm_hash_fn_get_handle (table, obj, scm_ihashv, scm_sloppy_assv, 0); | |
252 | } | |
1bbd0b84 | 253 | #undef FUNC_NAME |
0f2d19dd JB |
254 | |
255 | ||
a1ec6916 | 256 | SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, |
1bbd0b84 GB |
257 | (SCM table, SCM obj, SCM init), |
258 | "") | |
259 | #define FUNC_NAME s_scm_hashv_create_handle_x | |
0f2d19dd JB |
260 | { |
261 | return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashv, scm_sloppy_assv, 0); | |
262 | } | |
1bbd0b84 | 263 | #undef FUNC_NAME |
0f2d19dd JB |
264 | |
265 | ||
a1ec6916 | 266 | SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0, |
1bbd0b84 GB |
267 | (SCM table, SCM obj, SCM dflt), |
268 | "") | |
269 | #define FUNC_NAME s_scm_hashv_ref | |
0f2d19dd JB |
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 | } | |
1bbd0b84 | 275 | #undef FUNC_NAME |
0f2d19dd JB |
276 | |
277 | ||
278 | ||
a1ec6916 | 279 | SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0, |
1bbd0b84 GB |
280 | (SCM table, SCM obj, SCM val), |
281 | "") | |
282 | #define FUNC_NAME s_scm_hashv_set_x | |
0f2d19dd JB |
283 | { |
284 | return scm_hash_fn_set_x (table, obj, val, scm_ihashv, scm_sloppy_assv, 0); | |
285 | } | |
1bbd0b84 | 286 | #undef FUNC_NAME |
0f2d19dd JB |
287 | |
288 | ||
a1ec6916 | 289 | SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0, |
1bbd0b84 GB |
290 | (SCM table, SCM obj), |
291 | "") | |
292 | #define FUNC_NAME s_scm_hashv_remove_x | |
0f2d19dd JB |
293 | { |
294 | return scm_hash_fn_remove_x (table, obj, scm_ihashv, scm_sloppy_assv, scm_delv_x, 0); | |
295 | } | |
1bbd0b84 | 296 | #undef FUNC_NAME |
0f2d19dd JB |
297 | |
298 | \f | |
299 | ||
a1ec6916 | 300 | SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0, |
1bbd0b84 GB |
301 | (SCM table, SCM obj), |
302 | "") | |
303 | #define FUNC_NAME s_scm_hash_get_handle | |
0f2d19dd JB |
304 | { |
305 | return scm_hash_fn_get_handle (table, obj, scm_ihash, scm_sloppy_assoc, 0); | |
306 | } | |
1bbd0b84 | 307 | #undef FUNC_NAME |
0f2d19dd JB |
308 | |
309 | ||
a1ec6916 | 310 | SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, |
1bbd0b84 GB |
311 | (SCM table, SCM obj, SCM init), |
312 | "") | |
313 | #define FUNC_NAME s_scm_hash_create_handle_x | |
0f2d19dd JB |
314 | { |
315 | return scm_hash_fn_create_handle_x (table, obj, init, scm_ihash, scm_sloppy_assoc, 0); | |
316 | } | |
1bbd0b84 | 317 | #undef FUNC_NAME |
0f2d19dd JB |
318 | |
319 | ||
a1ec6916 | 320 | SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0, |
1bbd0b84 GB |
321 | (SCM table, SCM obj, SCM dflt), |
322 | "") | |
323 | #define FUNC_NAME s_scm_hash_ref | |
0f2d19dd JB |
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 | } | |
1bbd0b84 | 329 | #undef FUNC_NAME |
0f2d19dd JB |
330 | |
331 | ||
332 | ||
a1ec6916 | 333 | SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0, |
1bbd0b84 GB |
334 | (SCM table, SCM obj, SCM val), |
335 | "") | |
336 | #define FUNC_NAME s_scm_hash_set_x | |
0f2d19dd JB |
337 | { |
338 | return scm_hash_fn_set_x (table, obj, val, scm_ihash, scm_sloppy_assoc, 0); | |
339 | } | |
1bbd0b84 | 340 | #undef FUNC_NAME |
0f2d19dd JB |
341 | |
342 | ||
343 | ||
a1ec6916 | 344 | SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0, |
1bbd0b84 GB |
345 | (SCM table, SCM obj), |
346 | "") | |
347 | #define FUNC_NAME s_scm_hash_remove_x | |
0f2d19dd JB |
348 | { |
349 | return scm_hash_fn_remove_x (table, obj, scm_ihash, scm_sloppy_assoc, scm_delete_x, 0); | |
350 | } | |
1bbd0b84 | 351 | #undef FUNC_NAME |
0f2d19dd JB |
352 | |
353 | \f | |
354 | ||
355 | ||
356 | struct scm_ihashx_closure | |
357 | { | |
358 | SCM hash; | |
359 | SCM assoc; | |
360 | SCM delete; | |
361 | }; | |
362 | ||
363 | ||
1cc91f1b | 364 | |
0f2d19dd | 365 | static unsigned int |
1bbd0b84 | 366 | scm_ihashx (SCM obj,unsigned int n,struct scm_ihashx_closure * closure) |
0f2d19dd JB |
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 | ||
1cc91f1b | 378 | |
0f2d19dd | 379 | static SCM |
1bbd0b84 | 380 | scm_sloppy_assx (SCM obj,SCM alist,struct scm_ihashx_closure * closure) |
0f2d19dd JB |
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 | ||
1cc91f1b | 393 | |
0f2d19dd | 394 | static SCM |
1bbd0b84 | 395 | scm_delx_x (SCM obj,SCM alist,struct scm_ihashx_closure * closure) |
0f2d19dd JB |
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 | ||
a1ec6916 | 408 | SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0, |
1bbd0b84 GB |
409 | (SCM hash, SCM assoc, SCM table, SCM obj), |
410 | "") | |
411 | #define FUNC_NAME s_scm_hashx_get_handle | |
0f2d19dd JB |
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 | } | |
1bbd0b84 | 418 | #undef FUNC_NAME |
0f2d19dd JB |
419 | |
420 | ||
a1ec6916 | 421 | SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, |
1bbd0b84 GB |
422 | (SCM hash,SCM assoc,SCM table,SCM obj,SCM init), |
423 | "") | |
424 | #define FUNC_NAME s_scm_hashx_create_handle_x | |
0f2d19dd JB |
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 | } | |
1bbd0b84 | 431 | #undef FUNC_NAME |
0f2d19dd JB |
432 | |
433 | ||
434 | ||
a1ec6916 | 435 | SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0, |
1bbd0b84 | 436 | (SCM hash,SCM assoc,SCM table,SCM obj,SCM dflt), |
4079f87e GB |
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}.") | |
1bbd0b84 | 448 | #define FUNC_NAME s_scm_hashx_ref |
0f2d19dd JB |
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 | } | |
1bbd0b84 | 457 | #undef FUNC_NAME |
0f2d19dd JB |
458 | |
459 | ||
460 | ||
461 | ||
a1ec6916 | 462 | SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0, |
1bbd0b84 GB |
463 | (SCM hash, SCM assoc, SCM table, SCM obj, SCM val), |
464 | "") | |
465 | #define FUNC_NAME s_scm_hashx_set_x | |
0f2d19dd JB |
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 | } | |
1bbd0b84 | 472 | #undef FUNC_NAME |
0f2d19dd JB |
473 | |
474 | ||
1cc91f1b | 475 | |
0f2d19dd | 476 | SCM |
1bbd0b84 | 477 | scm_hashx_remove_x (SCM hash,SCM assoc,SCM delete,SCM table,SCM obj) |
0f2d19dd JB |
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 | ||
b94903c2 MD |
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 | ||
a1ec6916 | 492 | SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0, |
1bbd0b84 GB |
493 | (SCM proc, SCM init, SCM table), |
494 | "") | |
495 | #define FUNC_NAME s_scm_hash_fold | |
b94903c2 | 496 | { |
3b3b36dd GB |
497 | SCM_VALIDATE_PROC (1,proc); |
498 | SCM_VALIDATE_VECTOR (3,table); | |
b94903c2 MD |
499 | return scm_internal_hash_fold (fold_proc, (void *) proc, init, table); |
500 | } | |
1bbd0b84 | 501 | #undef FUNC_NAME |
c7df61cd MD |
502 | |
503 | SCM | |
8cd5191b | 504 | scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) |
c7df61cd MD |
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 | { | |
0c95b57d | 513 | SCM_ASSERT (SCM_CONSP (ls), |
1bbd0b84 | 514 | table, SCM_ARG1, s_scm_hash_fold); |
c7df61cd | 515 | handle = SCM_CAR (ls); |
0c95b57d | 516 | SCM_ASSERT (SCM_CONSP (handle), |
1bbd0b84 | 517 | table, SCM_ARG1, s_scm_hash_fold); |
c7df61cd MD |
518 | result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); |
519 | ls = SCM_CDR (ls); | |
520 | } | |
521 | } | |
522 | return result; | |
523 | } | |
524 | ||
0f2d19dd JB |
525 | \f |
526 | ||
1cc91f1b | 527 | |
0f2d19dd JB |
528 | void |
529 | scm_init_hashtab () | |
0f2d19dd JB |
530 | { |
531 | #include "hashtab.x" | |
532 | } |