1 /* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006 Free Software Foundation, Inc.
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)
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.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
16 * Boston, MA 02110-1301 USA
18 * As a special exception, Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of this library.
21 * The exception is that, if you link this 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 this library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by
31 * Free Software Foundation as part of this library. If you copy
32 * code from other releases distributed under the terms of the GPL into a copy of
33 * this library, 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 such code.
38 * If you write modifications of your own for this library, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
47 #include "libguile/_scm.h"
48 #include "libguile/vectors.h"
49 #include "libguile/lang.h"
50 #include "libguile/hashtab.h"
52 #include "libguile/validate.h"
53 #include "libguile/weaks.h"
57 /* 1. The current hash table implementation in hashtab.c uses weak alist
58 * vectors (formerly called weak hash tables) internally.
60 * 2. All hash table operations still work on alist vectors.
62 * 3. The weak vector and alist vector Scheme API is accessed through
63 * the module (ice-9 weak-vector).
71 SCM_DEFINE (scm_make_weak_vector
, "make-weak-vector", 1, 1, 0,
73 "Return a weak vector with @var{size} elements. If the optional\n"
74 "argument @var{fill} is given, all entries in the vector will be\n"
75 "set to @var{fill}. The default value for @var{fill} is the\n"
77 #define FUNC_NAME s_scm_make_weak_vector
79 return scm_i_allocate_weak_vector (0, size
, fill
);
84 SCM_REGISTER_PROC(s_list_to_weak_vector
, "list->weak-vector", 1, 0, 0, scm_weak_vector
);
86 SCM_DEFINE (scm_weak_vector
, "weak-vector", 0, 0, 1,
88 "@deffnx {Scheme Procedure} list->weak-vector l\n"
89 "Construct a weak vector from a list: @code{weak-vector} uses\n"
90 "the list of its arguments while @code{list->weak-vector} uses\n"
91 "its only argument @var{l} (a list) to construct a weak vector\n"
92 "the same way @code{list->vector} would.")
93 #define FUNC_NAME s_scm_weak_vector
95 scm_t_array_handle handle
;
100 SCM_ASSERT (i
>= 0, l
, SCM_ARG1
, FUNC_NAME
);
102 res
= scm_make_weak_vector (scm_from_int (i
), SCM_UNSPECIFIED
);
103 data
= scm_vector_writable_elements (res
, &handle
, NULL
, NULL
);
105 while (scm_is_pair (l
) && i
> 0)
107 *data
++ = SCM_CAR (l
);
112 scm_array_handle_release (&handle
);
119 SCM_DEFINE (scm_weak_vector_p
, "weak-vector?", 1, 0, 0,
121 "Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
122 "weak hashes are also weak vectors.")
123 #define FUNC_NAME s_scm_weak_vector_p
125 return scm_from_bool (SCM_I_WVECTP (obj
) && !SCM_IS_WHVEC (obj
));
131 SCM_DEFINE (scm_make_weak_key_alist_vector
, "make-weak-key-alist-vector", 0, 1, 0,
133 "@deffnx {Scheme Procedure} make-weak-value-alist-vector size\n"
134 "@deffnx {Scheme Procedure} make-doubly-weak-alist-vector size\n"
135 "Return a weak hash table with @var{size} buckets. As with any\n"
136 "hash table, choosing a good size for the table requires some\n"
139 "You can modify weak hash tables in exactly the same way you\n"
140 "would modify regular hash tables. (@pxref{Hash Tables})")
141 #define FUNC_NAME s_scm_make_weak_key_alist_vector
143 return scm_i_allocate_weak_vector
144 (1, SCM_UNBNDP (size
) ? scm_from_int (31) : size
, SCM_EOL
);
149 SCM_DEFINE (scm_make_weak_value_alist_vector
, "make-weak-value-alist-vector", 0, 1, 0,
151 "Return a hash table with weak values with @var{size} buckets.\n"
152 "(@pxref{Hash Tables})")
153 #define FUNC_NAME s_scm_make_weak_value_alist_vector
155 return scm_i_allocate_weak_vector
156 (2, SCM_UNBNDP (size
) ? scm_from_int (31) : size
, SCM_EOL
);
161 SCM_DEFINE (scm_make_doubly_weak_alist_vector
, "make-doubly-weak-alist-vector", 1, 0, 0,
163 "Return a hash table with weak keys and values with @var{size}\n"
164 "buckets. (@pxref{Hash Tables})")
165 #define FUNC_NAME s_scm_make_doubly_weak_alist_vector
167 return scm_i_allocate_weak_vector
168 (3, SCM_UNBNDP (size
) ? scm_from_int (31) : size
, SCM_EOL
);
173 SCM_DEFINE (scm_weak_key_alist_vector_p
, "weak-key-alist-vector?", 1, 0, 0,
175 "@deffnx {Scheme Procedure} weak-value-alist-vector? obj\n"
176 "@deffnx {Scheme Procedure} doubly-weak-alist-vector? obj\n"
177 "Return @code{#t} if @var{obj} is the specified weak hash\n"
178 "table. Note that a doubly weak hash table is neither a weak key\n"
179 "nor a weak value hash table.")
180 #define FUNC_NAME s_scm_weak_key_alist_vector_p
182 return scm_from_bool (SCM_I_WVECTP (obj
) && SCM_IS_WHVEC (obj
));
187 SCM_DEFINE (scm_weak_value_alist_vector_p
, "weak-value-alist-vector?", 1, 0, 0,
189 "Return @code{#t} if @var{obj} is a weak value hash table.")
190 #define FUNC_NAME s_scm_weak_value_alist_vector_p
192 return scm_from_bool (SCM_I_WVECTP (obj
) && SCM_IS_WHVEC_V (obj
));
197 SCM_DEFINE (scm_doubly_weak_alist_vector_p
, "doubly-weak-alist-vector?", 1, 0, 0,
199 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
200 #define FUNC_NAME s_scm_doubly_weak_alist_vector_p
202 return scm_from_bool (SCM_I_WVECTP (obj
) && SCM_IS_WHVEC_B (obj
));
206 #define UNMARKED_CELL_P(x) 1 /* (SCM_NIMP(x) && !SCM_GC_MARK_P (x)) *//*
209 static SCM weak_vectors
;
212 scm_i_init_weak_vectors_for_gc ()
214 weak_vectors
= SCM_EOL
;
218 scm_i_mark_weak_vector (SCM w
)
220 SCM_I_SET_WVECT_GC_CHAIN (w
, weak_vectors
);
225 scm_i_mark_weak_vector_non_weaks (SCM w
)
229 if (SCM_IS_WHVEC_ANY (w
))
232 long n
= SCM_I_WVECT_LENGTH (w
);
234 int weak_keys
= SCM_IS_WHVEC (w
) || SCM_IS_WHVEC_B (w
);
235 int weak_values
= SCM_IS_WHVEC_V (w
) || SCM_IS_WHVEC_B (w
);
237 ptr
= SCM_I_WVECT_GC_WVELTS (w
);
239 for (j
= 0; j
< n
; ++j
)
241 SCM alist
, slow_alist
;
244 /* We do not set the mark bits of the alist spine cells here
245 since we do not want to ever create the situation where a
246 marked cell references an unmarked cell (except in
247 scm_gc_mark, where the referenced cells will be marked
248 immediately). Thus, we can not use mark bits to stop us
249 from looping indefinitely over a cyclic alist. Instead,
250 we use the standard tortoise and hare trick to catch
251 cycles. The fast walker does the work, and stops when it
252 catches the slow walker to ensure that the whole cycle
256 alist
= slow_alist
= ptr
[j
];
258 while (scm_is_pair (alist
))
260 SCM elt
= SCM_CAR (alist
);
262 if (UNMARKED_CELL_P (elt
))
264 if (scm_is_pair (elt
))
266 SCM key
= SCM_CAR (elt
);
267 SCM value
= SCM_CDR (elt
);
269 if (!((weak_keys
&& UNMARKED_CELL_P (key
))
270 || (weak_values
&& UNMARKED_CELL_P (value
))))
272 /* The item should be kept. We need to mark it
281 /* A non-pair cell element. This should not
282 appear in a real alist, but when it does, we
290 alist
= SCM_CDR (alist
);
292 if (slow_toggle
&& scm_is_pair (slow_alist
))
294 slow_alist
= SCM_CDR (slow_alist
);
295 slow_toggle
= !slow_toggle
;
296 if (scm_is_eq (slow_alist
, alist
))
300 if (!scm_is_pair (alist
))
309 scm_i_mark_weak_vectors_non_weaks ()
312 SCM w
= weak_vectors
;
313 while (!scm_is_null (w
))
315 if (scm_i_mark_weak_vector_non_weaks (w
))
317 w
= SCM_I_WVECT_GC_CHAIN (w
);
323 scm_i_remove_weaks (SCM w
)
327 SCM
*ptr
= SCM_I_WVECT_GC_WVELTS (w
);
328 size_t n
= SCM_I_WVECT_LENGTH (w
);
331 if (!SCM_IS_WHVEC_ANY (w
))
333 for (i
= 0; i
< n
; ++i
)
334 if (UNMARKED_CELL_P (ptr
[i
]))
341 for (i
= 0; i
< n
; ++i
)
347 while (scm_is_pair (alist
) && !SCM_GC_MARK_P (alist
))
349 if (UNMARKED_CELL_P (SCM_CAR (alist
)))
351 *fixup
= SCM_CDR (alist
);
356 SCM_SET_GC_MARK (alist
);
357 fixup
= SCM_CDRLOC (alist
);
364 fprintf (stderr
, "vector %p, delta %d\n", w
, delta
);
366 SCM_I_SET_WVECT_DELTA (w
, delta
);
372 scm_i_remove_weaks_from_weak_vectors ()
374 SCM w
= weak_vectors
;
375 while (!scm_is_null (w
))
377 scm_i_remove_weaks (w
);
378 w
= SCM_I_WVECT_GC_CHAIN (w
);
385 scm_init_weaks_builtins ()
387 #include "libguile/weaks.x"
388 return SCM_UNSPECIFIED
;
394 scm_c_define_gsubr ("%init-weaks-builtins", 0, 0, 0,
395 scm_init_weaks_builtins
);