1 /* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
27 #include "libguile/_scm.h"
28 #include "libguile/vectors.h"
30 #include "libguile/validate.h"
37 #define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
40 make_weak_vector (size_t len
, SCM fill
)
41 #define FUNC_NAME "make-weak-vector"
46 SCM_ASSERT_RANGE (1, scm_from_size_t (len
), len
<= VECTOR_MAX_LENGTH
);
48 if (SCM_UNBNDP (fill
))
49 fill
= SCM_UNSPECIFIED
;
51 wv
= SCM_PACK_POINTER (scm_gc_malloc_pointerless ((len
+ 1) * sizeof (SCM
),
54 SCM_SET_CELL_WORD_0 (wv
, (len
<< 8) | scm_tc7_wvect
);
56 if (SCM_HEAP_OBJECT_P (fill
))
58 memset (SCM_I_VECTOR_WELTS (wv
), 0, len
* sizeof (SCM
));
59 for (j
= 0; j
< len
; j
++)
60 scm_c_weak_vector_set_x (wv
, j
, fill
);
63 for (j
= 0; j
< len
; j
++)
64 SCM_SIMPLE_VECTOR_SET (wv
, j
, fill
);
70 SCM_DEFINE (scm_make_weak_vector
, "make-weak-vector", 1, 1, 0,
72 "Return a weak vector with @var{size} elements. If the optional\n"
73 "argument @var{fill} is given, all entries in the vector will be\n"
74 "set to @var{fill}. The default value for @var{fill} is the\n"
76 #define FUNC_NAME s_scm_make_weak_vector
78 return make_weak_vector (scm_to_size_t (size
), fill
);
83 SCM_REGISTER_PROC(s_list_to_weak_vector
, "list->weak-vector", 1, 0, 0, scm_weak_vector
);
85 SCM_DEFINE (scm_weak_vector
, "weak-vector", 0, 0, 1,
87 "@deffnx {Scheme Procedure} list->weak-vector lst\n"
88 "Construct a weak vector from a list: @code{weak-vector} uses\n"
89 "the list of its arguments while @code{list->weak-vector} uses\n"
90 "its only argument @var{l} (a list) to construct a weak vector\n"
91 "the same way @code{list->vector} would.")
92 #define FUNC_NAME s_scm_weak_vector
98 SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1
, lst
, c_size
);
100 wv
= make_weak_vector ((size_t) c_size
, SCM_BOOL_F
);
102 for (i
= 0; scm_is_pair (lst
); lst
= SCM_CDR (lst
), i
++)
103 scm_c_weak_vector_set_x (wv
, i
, SCM_CAR (lst
));
110 SCM_DEFINE (scm_weak_vector_p
, "weak-vector?", 1, 0, 0,
112 "Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
113 "weak hashes are also weak vectors.")
114 #define FUNC_NAME s_scm_weak_vector_p
116 return scm_from_bool (SCM_I_WVECTP (obj
));
121 struct weak_vector_ref_data
128 weak_vector_ref (void *data
)
130 struct weak_vector_ref_data
*d
= data
;
132 return SCM_SIMPLE_VECTOR_REF (d
->wv
, d
->k
);
136 scm_c_weak_vector_ref (SCM wv
, size_t k
)
138 struct weak_vector_ref_data d
;
144 if (k
>= SCM_I_VECTOR_LENGTH (wv
))
145 scm_out_of_range (NULL
, scm_from_size_t (k
));
147 ret
= GC_call_with_alloc_lock (weak_vector_ref
, &d
);
150 return SCM_PACK_POINTER (ret
);
157 scm_c_weak_vector_set_x (SCM wv
, size_t k
, SCM x
)
160 struct weak_vector_ref_data d
;
166 if (k
>= SCM_I_VECTOR_LENGTH (wv
))
167 scm_out_of_range (NULL
, scm_from_size_t (k
));
169 prev
= GC_call_with_alloc_lock (weak_vector_ref
, &d
);
171 elts
= SCM_I_VECTOR_WELTS (wv
);
173 if (prev
&& SCM_HEAP_OBJECT_P (SCM_PACK_POINTER (prev
)))
174 GC_unregister_disappearing_link ((GC_PTR
) &elts
[k
]);
178 if (SCM_HEAP_OBJECT_P (x
))
179 SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR
) &elts
[k
],
180 (GC_PTR
) SCM_HEAP_OBJECT_BASE (x
));
186 scm_init_weak_vector_builtins (void)
188 #ifndef SCM_MAGIC_SNARFER
189 #include "libguile/weak-vector.x"
194 scm_init_weak_vectors ()
196 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
197 "scm_init_weak_vector_builtins",
198 (scm_t_extension_init_func
)scm_init_weak_vector_builtins
,