1 /* Copyright (C) 1995,1996,1998,2000,2001 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., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 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. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
46 #include "libguile/_scm.h"
47 #include "libguile/vectors.h"
49 #include "libguile/validate.h"
50 #include "libguile/weaks.h"
58 SCM_DEFINE (scm_make_weak_vector
, "make-weak-vector", 1, 1, 0,
60 "Return a weak vector with @var{size} elements. If the optional\n"
61 "argument @var{fill} is given, all entries in the vector will be\n"
62 "set to @var{fill}. The default value for @var{fill} is the\n"
64 #define FUNC_NAME s_scm_make_weak_vector
66 /* Dirk:FIXME:: We should probably rather use a double cell for weak vectors. */
68 v
= scm_make_vector (scm_sum (size
, SCM_MAKINUM (2)), fill
);
70 SCM_SET_VECTOR_LENGTH (v
, SCM_INUM (size
), scm_tc7_wvect
);
71 SCM_SETVELTS(v
, SCM_VELTS(v
) + 2);
72 SCM_VELTS(v
)[-2] = SCM_EOL
;
73 SCM_UNPACK (SCM_VELTS (v
)[-1]) = 0;
80 SCM_REGISTER_PROC(s_list_to_weak_vector
, "list->weak-vector", 1, 0, 0, scm_weak_vector
);
82 SCM_DEFINE (scm_weak_vector
, "weak-vector", 0, 0, 1,
84 "@deffnx primitive list->weak-vector l\n"
85 "Construct a weak vector from a list: @code{weak-vector} uses\n"
86 "the list of its arguments while @code{list->weak-vector} uses\n"
87 "its only argument @var{l} (a list) to construct a weak vector\n"
88 "the same way @code{list->vector} would.")
89 #define FUNC_NAME s_scm_weak_vector
95 /* Dirk:FIXME:: In case of multiple threads, the list might get corrupted
96 while the vector is being created. */
98 SCM_ASSERT (i
>= 0, l
, SCM_ARG1
, FUNC_NAME
);
99 res
= scm_make_weak_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
);
100 data
= SCM_VELTS (res
);
102 while (!SCM_NULLP (l
))
104 *data
++ = SCM_CAR (l
);
113 SCM_DEFINE (scm_weak_vector_p
, "weak-vector?", 1, 0, 0,
115 "Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
116 "weak hashes are also weak vectors.")
117 #define FUNC_NAME s_scm_weak_vector_p
119 return SCM_BOOL(SCM_WVECTP (obj
) && !SCM_IS_WHVEC (obj
));
129 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 1, 0, 0,
131 "@deffnx primitive make-weak-value-hash-table size\n"
132 "@deffnx primitive make-doubly-weak-hash-table size\n"
133 "Return a weak hash table with @var{size} buckets. As with any\n"
134 "hash table, choosing a good size for the table requires some\n"
137 "You can modify weak hash tables in exactly the same way you\n"
138 "would modify regular hash tables. (@pxref{Hash Tables})")
139 #define FUNC_NAME s_scm_make_weak_key_hash_table
142 SCM_VALIDATE_INUM (1, size
);
143 v
= scm_make_weak_vector (size
, SCM_EOL
);
145 SCM_UNPACK (SCM_VELTS (v
)[-1]) = 1;
152 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 1, 0, 0,
154 "Return a hash table with weak values with @var{size} buckets.\n"
155 "(@pxref{Hash Tables})")
156 #define FUNC_NAME s_scm_make_weak_value_hash_table
159 SCM_VALIDATE_INUM (1, size
);
160 v
= scm_make_weak_vector (size
, SCM_EOL
);
162 SCM_UNPACK (SCM_VELTS (v
)[-1]) = 2;
170 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
172 "Return a hash table with weak keys and values with @var{size}\n"
173 "buckets. (@pxref{Hash Tables})")
174 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
177 SCM_VALIDATE_INUM (1, size
);
178 v
= scm_make_weak_vector (size
, SCM_EOL
);
180 SCM_UNPACK (SCM_VELTS (v
)[-1]) = 3;
186 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
188 "@deffnx primitive weak-value-hash-table? obj\n"
189 "@deffnx primitive doubly-weak-hash-table? obj\n"
190 "Return @code{#t} if @var{obj} is the specified weak hash\n"
191 "table. Note that a doubly weak hash table is neither a weak key\n"
192 "nor a weak value hash table.")
193 #define FUNC_NAME s_scm_weak_key_hash_table_p
195 return SCM_BOOL(SCM_WVECTP (obj
) && SCM_IS_WHVEC(obj
));
200 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
202 "Return @code{#t} if @var{obj} is a weak value hash table.")
203 #define FUNC_NAME s_scm_weak_value_hash_table_p
205 return SCM_BOOL(SCM_WVECTP (obj
) && SCM_IS_WHVEC_V(obj
));
210 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
212 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
213 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
215 return SCM_BOOL(SCM_WVECTP (obj
) && SCM_IS_WHVEC_B (obj
));
220 scm_weak_vector_gc_init (void *dummy1
, void *dummy2
, void *dummy3
)
222 scm_weak_vectors
= SCM_EOL
;
228 scm_mark_weak_vector_spines (void *dummy1
, void *dummy2
, void *dummy3
)
232 for (w
= scm_weak_vectors
; !SCM_NULLP (w
); w
= SCM_WVECT_GC_CHAIN (w
))
234 if (SCM_IS_WHVEC_ANY (w
))
243 n
= SCM_VECTOR_LENGTH (w
);
244 for (j
= 0; j
< n
; ++j
)
249 while ( SCM_CONSP (alist
)
250 && !SCM_GCMARKP (alist
)
251 && SCM_CONSP (SCM_CAR (alist
)))
253 SCM_SETGCMARK (alist
);
254 SCM_SETGCMARK (SCM_CAR (alist
));
255 alist
= SCM_CDR (alist
);
265 scm_scan_weak_vectors (void *dummy1
, void *dummy2
, void *dummy3
)
268 for (w
= scm_weak_vectors
; !SCM_NULLP (w
); w
= SCM_WVECT_GC_CHAIN (w
))
270 if (!SCM_IS_WHVEC_ANY (w
))
275 n
= SCM_VECTOR_LENGTH (w
);
276 for (j
= 0; j
< n
; ++j
)
277 if (SCM_FREE_CELL_P (ptr
[j
]))
280 else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
283 register long n
= SCM_VECTOR_LENGTH (w
);
285 int weak_keys
= SCM_IS_WHVEC (obj
) || SCM_IS_WHVEC_B (obj
);
286 int weak_values
= SCM_IS_WHVEC_V (obj
) || SCM_IS_WHVEC_B (obj
);
290 for (j
= 0; j
< n
; ++j
)
298 while ( SCM_CONSP (alist
)
299 && SCM_CONSP (SCM_CAR (alist
)))
304 key
= SCM_CAAR (alist
);
305 value
= SCM_CDAR (alist
);
306 if ( (weak_keys
&& SCM_FREE_CELL_P (key
))
307 || (weak_values
&& SCM_FREE_CELL_P (value
)))
309 *fixup
= SCM_CDR (alist
);
312 fixup
= SCM_CDRLOC (alist
);
313 alist
= SCM_CDR (alist
);
327 scm_weaks_prehistory ()
329 scm_c_hook_add (&scm_before_mark_c_hook
, scm_weak_vector_gc_init
, 0, 0);
330 scm_c_hook_add (&scm_before_sweep_c_hook
, scm_mark_weak_vector_spines
, 0, 0);
331 scm_c_hook_add (&scm_after_sweep_c_hook
, scm_scan_weak_vectors
, 0, 0);
337 #ifndef SCM_MAGIC_SNARFER
338 #include "libguile/weaks.x"