1 /* Copyright 1995-1996,1998,2000-2001,2003,2006,2008-2014,2018
2 Free Software Foundation, Inc.
3
4 This file is part of Guile.
5
6 Guile is free software: you can redistribute it and/or modify it
7 under the terms of the GNU Lesser General Public License as published
8 by the Free Software Foundation, either version 3 of the License, or
9 (at your option) any later version.
10
11 Guile is distributed in the hope that it will be useful, but WITHOUT
12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13 FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
14 License for more details.
15
16 You should have received a copy of the GNU Lesser General Public
17 License along with Guile. If not, see
18 <https://www.gnu.org/licenses/>. */
19
20
21
22 #ifdef HAVE_CONFIG_H
23 # include <config.h>
24 #endif
25
26 #include <stdio.h>
27 #include <string.h>
28
29 #include "boolean.h"
30 #include "extensions.h"
31 #include "gsubr.h"
32 #include "list.h"
33 #include "pairs.h"
34 #include "vectors.h"
35 #include "version.h"
36
37 #include "weak-vector.h"
38
39
40
41
42 /* {Weak Vectors}
43 */
44
45 #define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
46
47 SCM
scm_c_make_weak_vector(size_t len,SCM fill)48 scm_c_make_weak_vector (size_t len, SCM fill)
49 #define FUNC_NAME "make-weak-vector"
50 {
51 SCM wv;
52 size_t j;
53
54 SCM_ASSERT_RANGE (1, scm_from_size_t (len), len <= VECTOR_MAX_LENGTH);
55
56 if (SCM_UNBNDP (fill))
57 fill = SCM_UNSPECIFIED;
58
59 wv = SCM_PACK_POINTER (scm_gc_malloc_pointerless ((len + 1) * sizeof (SCM),
60 "weak vector"));
61
62 SCM_SET_CELL_WORD_0 (wv, (len << 8) | scm_tc7_wvect);
63
64 if (SCM_HEAP_OBJECT_P (fill))
65 {
66 memset (SCM_I_VECTOR_WELTS (wv), 0, len * sizeof (SCM));
67 for (j = 0; j < len; j++)
68 scm_c_weak_vector_set_x (wv, j, fill);
69 }
70 else
71 for (j = 0; j < len; j++)
72 SCM_SIMPLE_VECTOR_SET (wv, j, fill);
73
74 return wv;
75 }
76 #undef FUNC_NAME
77
78 SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
79 (SCM size, SCM fill),
80 "Return a weak vector with @var{size} elements. If the optional\n"
81 "argument @var{fill} is given, all entries in the vector will be\n"
82 "set to @var{fill}. The default value for @var{fill} is the\n"
83 "empty list.")
84 #define FUNC_NAME s_scm_make_weak_vector
85 {
86 return scm_c_make_weak_vector (scm_to_size_t (size), fill);
87 }
88 #undef FUNC_NAME
89
90
91 SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
92
93 SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1,
94 (SCM lst),
95 "@deffnx {Scheme Procedure} list->weak-vector lst\n"
96 "Construct a weak vector from a list: @code{weak-vector} uses\n"
97 "the list of its arguments while @code{list->weak-vector} uses\n"
98 "its only argument @var{l} (a list) to construct a weak vector\n"
99 "the same way @code{list->vector} would.")
100 #define FUNC_NAME s_scm_weak_vector
101 {
102 SCM wv;
103 size_t i;
104 long c_size;
105
106 SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, lst, c_size);
107
108 wv = scm_c_make_weak_vector ((size_t) c_size, SCM_BOOL_F);
109
110 for (i = 0; scm_is_pair (lst); lst = SCM_CDR (lst), i++)
111 scm_c_weak_vector_set_x (wv, i, SCM_CAR (lst));
112
113 return wv;
114 }
115 #undef FUNC_NAME
116
117
118 SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
119 (SCM obj),
120 "Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
121 "weak hashes are also weak vectors.")
122 #define FUNC_NAME s_scm_weak_vector_p
123 {
124 return scm_from_bool (scm_is_weak_vector (obj));
125 }
126 #undef FUNC_NAME
127
128
129 int
scm_is_weak_vector(SCM obj)130 scm_is_weak_vector (SCM obj)
131 #define FUNC_NAME s_scm_weak_vector_p
132 {
133 return SCM_I_WVECTP (obj);
134 }
135 #undef FUNC_NAME
136
137
138 #define SCM_VALIDATE_WEAK_VECTOR(pos, var) \
139 SCM_I_MAKE_VALIDATE_MSG2 (pos, var, SCM_I_WVECTP, "weak vector")
140
141
142 SCM_DEFINE (scm_weak_vector_length, "weak-vector-length", 1, 0, 0,
143 (SCM wvect),
144 "Like @code{vector-length}, but for weak vectors.")
145 #define FUNC_NAME s_scm_weak_vector_length
146 {
147 return scm_from_size_t (scm_c_weak_vector_length (wvect));
148 }
149 #undef FUNC_NAME
150
151
152 size_t
scm_c_weak_vector_length(SCM wvect)153 scm_c_weak_vector_length (SCM wvect)
154 #define FUNC_NAME s_scm_weak_vector_length
155 {
156 SCM_VALIDATE_WEAK_VECTOR (1, wvect);
157 return SCM_I_VECTOR_LENGTH (wvect);
158 }
159 #undef FUNC_NAME
160
161
162 SCM_DEFINE (scm_weak_vector_ref, "weak-vector-ref", 2, 0, 0,
163 (SCM wvect, SCM k),
164 "Like @code{vector-ref}, but for weak vectors.")
165 #define FUNC_NAME s_scm_weak_vector_ref
166 {
167 return scm_c_weak_vector_ref (wvect, scm_to_size_t (k));
168 }
169 #undef FUNC_NAME
170
171
172 struct weak_vector_ref_data
173 {
174 SCM wv;
175 size_t k;
176 };
177
178 static void*
weak_vector_ref(void * data)179 weak_vector_ref (void *data)
180 {
181 struct weak_vector_ref_data *d = data;
182
183 return (void *) SCM_UNPACK (SCM_SIMPLE_VECTOR_REF (d->wv, d->k));
184 }
185
186 SCM
scm_c_weak_vector_ref(SCM wv,size_t k)187 scm_c_weak_vector_ref (SCM wv, size_t k)
188 #define FUNC_NAME s_scm_weak_vector_ref
189 {
190 struct weak_vector_ref_data d;
191 void *ret;
192
193 SCM_VALIDATE_WEAK_VECTOR (1, wv);
194
195 d.wv = wv;
196 d.k = k;
197
198 if (k >= SCM_I_VECTOR_LENGTH (wv))
199 scm_out_of_range ("weak-vector-ref", scm_from_size_t (k));
200
201 ret = GC_call_with_alloc_lock (weak_vector_ref, &d);
202
203 if (ret)
204 return SCM_PACK_POINTER (ret);
205 else
206 return SCM_BOOL_F;
207 }
208 #undef FUNC_NAME
209
210
211 SCM_DEFINE (scm_weak_vector_set_x, "weak-vector-set!", 3, 0, 0,
212 (SCM wvect, SCM k, SCM obj),
213 "Like @code{vector-set!}, but for weak vectors.")
214 #define FUNC_NAME s_scm_weak_vector_set_x
215 {
216 scm_c_weak_vector_set_x (wvect, scm_to_size_t (k), obj);
217
218 return SCM_UNSPECIFIED;
219 }
220 #undef FUNC_NAME
221
222
223 void
scm_c_weak_vector_set_x(SCM wv,size_t k,SCM x)224 scm_c_weak_vector_set_x (SCM wv, size_t k, SCM x)
225 #define FUNC_NAME s_scm_weak_vector_set_x
226 {
227 SCM *elts;
228 struct weak_vector_ref_data d;
229 void *prev;
230
231 SCM_VALIDATE_WEAK_VECTOR (1, wv);
232
233 d.wv = wv;
234 d.k = k;
235
236 if (k >= SCM_I_VECTOR_LENGTH (wv))
237 scm_out_of_range ("weak-vector-set!", scm_from_size_t (k));
238
239 prev = GC_call_with_alloc_lock (weak_vector_ref, &d);
240
241 elts = SCM_I_VECTOR_WELTS (wv);
242
243 if (prev && SCM_HEAP_OBJECT_P (SCM_PACK_POINTER (prev)))
244 GC_unregister_disappearing_link ((void **) &elts[k]);
245
246 elts[k] = x;
247
248 if (SCM_HEAP_OBJECT_P (x))
249 SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &elts[k],
250 SCM2PTR (x));
251 }
252 #undef FUNC_NAME
253
254
255
256 static void
scm_init_weak_vector_builtins(void)257 scm_init_weak_vector_builtins (void)
258 {
259 #ifndef SCM_MAGIC_SNARFER
260 #include "weak-vector.x"
261 #endif
262 }
263
264 void
scm_init_weak_vectors()265 scm_init_weak_vectors ()
266 {
267 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
268 "scm_init_weak_vector_builtins",
269 (scm_t_extension_init_func)scm_init_weak_vector_builtins,
270 NULL);
271 }
272
273