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