1 /* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2003, 2006, 2008, 2009,
2 * 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
28 #include "libguile/_scm.h"
29 #include "libguile/vectors.h"
31 #include "libguile/validate.h"
38 #define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
41 scm_c_make_weak_vector (size_t len
, SCM fill
)
42 #define FUNC_NAME "make-weak-vector"
47 SCM_ASSERT_RANGE (1, scm_from_size_t (len
), len
<= VECTOR_MAX_LENGTH
);
49 if (SCM_UNBNDP (fill
))
50 fill
= SCM_UNSPECIFIED
;
52 wv
= SCM_PACK_POINTER (scm_gc_malloc_pointerless ((len
+ 1) * sizeof (SCM
),
55 SCM_SET_CELL_WORD_0 (wv
, (len
<< 8) | scm_tc7_wvect
);
57 if (SCM_HEAP_OBJECT_P (fill
))
59 memset (SCM_I_VECTOR_WELTS (wv
), 0, len
* sizeof (SCM
));
60 for (j
= 0; j
< len
; j
++)
61 scm_c_weak_vector_set_x (wv
, j
, fill
);
64 for (j
= 0; j
< len
; j
++)
65 SCM_SIMPLE_VECTOR_SET (wv
, j
, fill
);
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_c_make_weak_vector (scm_to_size_t (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 lst\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
99 SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1
, lst
, c_size
);
101 wv
= scm_c_make_weak_vector ((size_t) c_size
, SCM_BOOL_F
);
103 for (i
= 0; scm_is_pair (lst
); lst
= SCM_CDR (lst
), i
++)
104 scm_c_weak_vector_set_x (wv
, i
, SCM_CAR (lst
));
111 SCM_DEFINE (scm_weak_vector_p
, "weak-vector?", 1, 0, 0,
113 "Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
114 "weak hashes are also weak vectors.")
115 #define FUNC_NAME s_scm_weak_vector_p
117 return scm_from_bool (scm_is_weak_vector (obj
));
123 scm_is_weak_vector (SCM obj
)
124 #define FUNC_NAME s_scm_weak_vector_p
126 return SCM_I_WVECTP (obj
);
131 #define SCM_VALIDATE_WEAK_VECTOR(pos, var) \
132 SCM_I_MAKE_VALIDATE_MSG2 (pos, var, SCM_I_WVECTP, "weak vector")
135 SCM_DEFINE (scm_weak_vector_length
, "weak-vector-length", 1, 0, 0,
137 "Like @code{vector-length}, but for weak vectors.")
138 #define FUNC_NAME s_scm_weak_vector_length
140 return scm_from_size_t (scm_c_weak_vector_length (wvect
));
146 scm_c_weak_vector_length (SCM wvect
)
147 #define FUNC_NAME s_scm_weak_vector_length
149 SCM_VALIDATE_WEAK_VECTOR (1, wvect
);
150 return SCM_I_VECTOR_LENGTH (wvect
);
155 SCM_DEFINE (scm_weak_vector_ref
, "weak-vector-ref", 2, 0, 0,
157 "Like @code{vector-ref}, but for weak vectors.")
158 #define FUNC_NAME s_scm_weak_vector_ref
160 return scm_c_weak_vector_ref (wvect
, scm_to_size_t (k
));
165 struct weak_vector_ref_data
172 weak_vector_ref (void *data
)
174 struct weak_vector_ref_data
*d
= data
;
176 return (void *) SCM_UNPACK (SCM_SIMPLE_VECTOR_REF (d
->wv
, d
->k
));
180 scm_c_weak_vector_ref (SCM wv
, size_t k
)
181 #define FUNC_NAME s_scm_weak_vector_ref
183 struct weak_vector_ref_data d
;
186 SCM_VALIDATE_WEAK_VECTOR (1, wv
);
191 if (k
>= SCM_I_VECTOR_LENGTH (wv
))
192 scm_out_of_range ("weak-vector-ref", scm_from_size_t (k
));
194 ret
= GC_call_with_alloc_lock (weak_vector_ref
, &d
);
197 return SCM_PACK_POINTER (ret
);
204 SCM_DEFINE (scm_weak_vector_set_x
, "weak-vector-set!", 3, 0, 0,
205 (SCM wvect
, SCM k
, SCM obj
),
206 "Like @code{vector-set!}, but for weak vectors.")
207 #define FUNC_NAME s_scm_weak_vector_set_x
209 scm_c_weak_vector_set_x (wvect
, scm_to_size_t (k
), obj
);
211 return SCM_UNSPECIFIED
;
217 scm_c_weak_vector_set_x (SCM wv
, size_t k
, SCM x
)
218 #define FUNC_NAME s_scm_weak_vector_set_x
221 struct weak_vector_ref_data d
;
224 SCM_VALIDATE_WEAK_VECTOR (1, wv
);
229 if (k
>= SCM_I_VECTOR_LENGTH (wv
))
230 scm_out_of_range ("weak-vector-set!", scm_from_size_t (k
));
232 prev
= GC_call_with_alloc_lock (weak_vector_ref
, &d
);
234 elts
= SCM_I_VECTOR_WELTS (wv
);
236 if (prev
&& SCM_HEAP_OBJECT_P (SCM_PACK_POINTER (prev
)))
237 GC_unregister_disappearing_link ((void **) &elts
[k
]);
241 if (SCM_HEAP_OBJECT_P (x
))
242 SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &elts
[k
],
250 scm_init_weak_vector_builtins (void)
252 #ifndef SCM_MAGIC_SNARFER
253 #include "libguile/weak-vector.x"
258 scm_init_weak_vectors ()
260 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
261 "scm_init_weak_vector_builtins",
262 (scm_t_extension_init_func
)scm_init_weak_vector_builtins
,