1 /* Copyright (C) 1995,1996,1998, 2000 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 */
47 #include "libguile/_scm.h"
48 #include "libguile/vectors.h"
50 #include "libguile/validate.h"
51 #include "libguile/weaks.h"
59 SCM_DEFINE (scm_make_weak_vector
, "make-weak-vector", 1, 1, 0,
61 "Return a weak vector with @var{size} elements. If the optional\n"
62 "argument @var{fill} is given, all entries in the vector will be set to\n"
63 "@var{fill}. The default value for @var{fill} is the empty list.")
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 (k
, SCM_MAKINUM (2)), fill
);
70 SCM_SET_VECTOR_LENGTH (v
, SCM_INUM (k
), 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 the list of\n"
86 "its arguments while @code{list->weak-vector} uses its only argument\n"
87 "@var{l} (a list) to construct a weak vector the same way\n"
88 "@code{vector->list} would.")
89 #define FUNC_NAME s_scm_weak_vector
96 SCM_ASSERT (i
>= 0, l
, SCM_ARG1
, FUNC_NAME
);
97 res
= scm_make_weak_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
);
98 data
= SCM_VELTS (res
);
101 --i
, l
= SCM_CDR (l
))
102 *data
++ = SCM_CAR (l
);
108 SCM_DEFINE (scm_weak_vector_p
, "weak-vector?", 1, 0, 0,
110 "Return @var{#t} if @var{obj} is a weak vector. Note that all weak\n"
111 "hashes are also weak vectors.")
112 #define FUNC_NAME s_scm_weak_vector_p
114 return SCM_BOOL(SCM_WVECTP (x
) && !SCM_IS_WHVEC (x
));
124 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 1, 0, 0,
126 "@deffnx primitive make-weak-value-hash-table size\n"
127 "@deffnx primitive make-doubly-weak-hash-table size\n"
128 "Return a weak hash table with @var{size} buckets. As with any hash\n"
129 "table, choosing a good size for the table requires some caution.\n\n"
130 "You can modify weak hash tables in exactly the same way you would modify\n"
131 "regular hash tables. (@pxref{Hash Tables})")
132 #define FUNC_NAME s_scm_make_weak_key_hash_table
135 SCM_VALIDATE_INUM (1,k
);
136 v
= scm_make_weak_vector (k
, SCM_EOL
);
138 SCM_UNPACK (SCM_VELTS (v
)[-1]) = 1;
145 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 1, 0, 0,
148 #define FUNC_NAME s_scm_make_weak_value_hash_table
151 SCM_VALIDATE_INUM (1,k
);
152 v
= scm_make_weak_vector (k
, SCM_EOL
);
154 SCM_UNPACK (SCM_VELTS (v
)[-1]) = 2;
162 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
165 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
168 SCM_VALIDATE_INUM (1,k
);
169 v
= scm_make_weak_vector (k
, SCM_EOL
);
171 SCM_UNPACK (SCM_VELTS (v
)[-1]) = 3;
177 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
179 "@deffnx primitive weak-value-hash-table? obj\n"
180 "@deffnx primitive doubly-weak-hash-table? obj\n"
181 "Return @var{#t} if @var{obj} is the specified weak hash table. Note\n"
182 "that a doubly weak hash table is neither a weak key nor a weak value\n"
184 #define FUNC_NAME s_scm_weak_key_hash_table_p
186 return SCM_BOOL(SCM_WVECTP (x
) && SCM_IS_WHVEC(x
));
191 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
194 #define FUNC_NAME s_scm_weak_value_hash_table_p
196 return SCM_BOOL(SCM_WVECTP (x
) && SCM_IS_WHVEC_V(x
));
201 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
204 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
206 return SCM_BOOL(SCM_WVECTP (x
) && SCM_IS_WHVEC_B (x
));
211 scm_weak_vector_gc_init (void *dummy1
, void *dummy2
, void *dummy3
)
213 scm_weak_vectors
= SCM_EOL
;
219 scm_mark_weak_vector_spines (void *dummy1
, void *dummy2
, void *dummy3
)
223 for (w
= scm_weak_vectors
; !SCM_NULLP (w
); w
= SCM_WVECT_GC_CHAIN (w
))
225 if (SCM_IS_WHVEC_ANY (w
))
234 n
= SCM_VECTOR_LENGTH (w
);
235 for (j
= 0; j
< n
; ++j
)
240 while ( SCM_CONSP (alist
)
241 && !SCM_GCMARKP (alist
)
242 && SCM_CONSP (SCM_CAR (alist
)))
244 SCM_SETGCMARK (alist
);
245 SCM_SETGCMARK (SCM_CAR (alist
));
246 alist
= SCM_GCCDR (alist
);
256 scm_scan_weak_vectors (void *dummy1
, void *dummy2
, void *dummy3
)
259 for (w
= scm_weak_vectors
; !SCM_NULLP (w
); w
= SCM_WVECT_GC_CHAIN (w
))
261 if (!SCM_IS_WHVEC_ANY (w
))
266 n
= SCM_VECTOR_LENGTH (w
);
267 for (j
= 0; j
< n
; ++j
)
268 if (SCM_FREE_CELL_P (ptr
[j
]))
271 else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
274 register long n
= SCM_VECTOR_LENGTH (w
);
279 for (j
= 0; j
< n
; ++j
)
286 weak_keys
= SCM_IS_WHVEC (obj
) || SCM_IS_WHVEC_B (obj
);
287 weak_values
= SCM_IS_WHVEC_V (obj
) || SCM_IS_WHVEC_B (obj
);
292 while ( SCM_CONSP (alist
)
293 && SCM_CONSP (SCM_CAR (alist
)))
298 key
= SCM_CAAR (alist
);
299 value
= SCM_CDAR (alist
);
300 if ( (weak_keys
&& SCM_FREE_CELL_P (key
))
301 || (weak_values
&& SCM_FREE_CELL_P (value
)))
303 *fixup
= SCM_CDR (alist
);
306 fixup
= SCM_CDRLOC (alist
);
307 alist
= SCM_CDR (alist
);
321 scm_weaks_prehistory ()
323 scm_c_hook_add (&scm_before_mark_c_hook
, scm_weak_vector_gc_init
, 0, 0);
324 scm_c_hook_add (&scm_before_sweep_c_hook
, scm_mark_weak_vector_spines
, 0, 0);
325 scm_c_hook_add (&scm_after_sweep_c_hook
, scm_scan_weak_vectors
, 0, 0);
331 #ifndef SCM_MAGIC_SNARFER
332 #include "libguile/weaks.x"