Commit | Line | Data |
---|---|---|
69d2000d | 1 | /* srfi-4.c --- Uniform numeric vector datatypes. |
f8579182 | 2 | * |
a2689737 | 3 | * Copyright (C) 2001, 2004, 2006, 2009, 2010 Free Software Foundation, Inc. |
f8579182 MV |
4 | * |
5 | * This library is free software; you can redistribute it and/or | |
53befeb7 NJ |
6 | * modify it under the terms of the GNU Lesser General Public License |
7 | * as published by the Free Software Foundation; either version 3 of | |
8 | * the License, or (at your option) any later version. | |
f8579182 | 9 | * |
53befeb7 NJ |
10 | * This library is distributed in the hope that it will be useful, but |
11 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
f8579182 MV |
12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | * Lesser General Public License for more details. | |
14 | * | |
15 | * You should have received a copy of the GNU Lesser General Public | |
16 | * License along with this library; if not, write to the Free Software | |
53befeb7 NJ |
17 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
18 | * 02110-1301 USA | |
f8579182 MV |
19 | */ |
20 | ||
dbb605f5 | 21 | #ifdef HAVE_CONFIG_H |
69730f92 MV |
22 | # include <config.h> |
23 | #endif | |
24 | ||
69730f92 MV |
25 | #include "libguile/_scm.h" |
26 | #include "libguile/__scm.h" | |
1c44468d | 27 | #include "libguile/bdw-gc.h" |
f8579182 | 28 | #include "libguile/srfi-4.h" |
438974d0 | 29 | #include "libguile/bytevectors.h" |
f8579182 | 30 | #include "libguile/error.h" |
ac8ed3db | 31 | #include "libguile/eval.h" |
a2689737 AW |
32 | #include "libguile/extensions.h" |
33 | #include "libguile/uniform.h" | |
34 | #include "libguile/generalized-vectors.h" | |
35 | #include "libguile/validate.h" | |
69730f92 | 36 | |
f8579182 | 37 | |
a2689737 AW |
38 | #define DEFINE_SCHEME_PROXY100(cname, modname, scmname) \ |
39 | SCM cname (SCM arg1) \ | |
40 | { \ | |
41 | static SCM var = SCM_BOOL_F; \ | |
42 | if (scm_is_false (var)) \ | |
43 | var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \ | |
44 | return scm_call_1 (SCM_VARIABLE_REF (var), arg1); \ | |
f8579182 MV |
45 | } |
46 | ||
a2689737 AW |
47 | #define DEFINE_SCHEME_PROXY001(cname, modname, scmname) \ |
48 | SCM cname (SCM args) \ | |
49 | { \ | |
50 | static SCM var = SCM_BOOL_F; \ | |
51 | if (scm_is_false (var)) \ | |
52 | var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \ | |
53 | return scm_apply_0 (SCM_VARIABLE_REF (var), args); \ | |
54 | } | |
f8579182 | 55 | |
a2689737 AW |
56 | #define DEFINE_SCHEME_PROXY110(cname, modname, scmname) \ |
57 | SCM cname (SCM arg1, SCM opt1) \ | |
58 | { \ | |
59 | static SCM var = SCM_BOOL_F; \ | |
60 | if (scm_is_false (var)) \ | |
61 | var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \ | |
62 | if (SCM_UNBNDP (opt1)) \ | |
63 | return scm_call_1 (SCM_VARIABLE_REF (var), arg1); \ | |
64 | else \ | |
65 | return scm_call_2 (SCM_VARIABLE_REF (var), arg1, opt1); \ | |
66 | } | |
f8579182 | 67 | |
a2689737 AW |
68 | #define DEFINE_SCHEME_PROXY200(cname, modname, scmname) \ |
69 | SCM cname (SCM arg1, SCM arg2) \ | |
70 | { \ | |
71 | static SCM var = SCM_BOOL_F; \ | |
72 | if (scm_is_false (var)) \ | |
73 | var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \ | |
74 | return scm_call_2 (SCM_VARIABLE_REF (var), arg1, arg2); \ | |
75 | } | |
f8579182 | 76 | |
a2689737 AW |
77 | #define DEFINE_SCHEME_PROXY300(cname, modname, scmname) \ |
78 | SCM cname (SCM arg1, SCM arg2, SCM arg3) \ | |
79 | { \ | |
80 | static SCM var = SCM_BOOL_F; \ | |
81 | if (scm_is_false (var)) \ | |
82 | var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \ | |
83 | return scm_call_3 (SCM_VARIABLE_REF (var), arg1, arg2, arg3); \ | |
84 | } | |
d7e7a02a | 85 | |
a2689737 AW |
86 | #define DEFPROXY100(cname, scmname) \ |
87 | DEFINE_SCHEME_PROXY100 (cname, MOD, scmname) | |
88 | #define DEFPROXY110(cname, scmname) \ | |
89 | DEFINE_SCHEME_PROXY110 (cname, MOD, scmname) | |
90 | #define DEFPROXY001(cname, scmname) \ | |
91 | DEFINE_SCHEME_PROXY001 (cname, MOD, scmname) | |
92 | #define DEFPROXY200(cname, scmname) \ | |
93 | DEFINE_SCHEME_PROXY200 (cname, MOD, scmname) | |
94 | #define DEFPROXY300(cname, scmname) \ | |
95 | DEFINE_SCHEME_PROXY300 (cname, MOD, scmname) | |
96 | ||
97 | #define DEFVECT(sym, str, func)\ | |
98 | ||
99 | #define DEFINE_SRFI_4_PROXIES(tag) \ | |
100 | DEFPROXY100 (scm_##tag##vector_p, #tag "vector?"); \ | |
101 | DEFPROXY110 (scm_make_##tag##vector, "make-" #tag "vector"); \ | |
102 | DEFPROXY001 (scm_##tag##vector, #tag "vector"); \ | |
103 | DEFPROXY100 (scm_##tag##vector_length, #tag "vector-length"); \ | |
104 | DEFPROXY200 (scm_##tag##vector_ref, #tag "vector-ref"); \ | |
105 | DEFPROXY300 (scm_##tag##vector_set_x, #tag "vector-set!"); \ | |
106 | DEFPROXY100 (scm_list_to_##tag##vector, "list->"#tag "vector"); \ | |
107 | DEFPROXY100 (scm_##tag##vector_to_list, #tag "vector->list"); \ | |
faa00365 | 108 | |
a2689737 AW |
109 | |
110 | #define ETYPE(TAG) \ | |
111 | SCM_ARRAY_ELEMENT_TYPE_##TAG | |
69730f92 | 112 | |
0d782201 | 113 | #define DEFINE_SRFI_4_C_FUNCS(TAG, tag, ctype, width) \ |
a2689737 AW |
114 | SCM scm_take_##tag##vector (ctype *data, size_t n) \ |
115 | { \ | |
116 | return scm_c_take_typed_bytevector ((scm_t_int8*)data, n, ETYPE (TAG)); \ | |
117 | } \ | |
118 | const ctype* scm_array_handle_##tag##_elements (scm_t_array_handle *h) \ | |
119 | { \ | |
120 | if (h->element_type != ETYPE (TAG)) \ | |
121 | scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \ | |
0d782201 | 122 | return ((const ctype*) h->elements) + h->base*width; \ |
a2689737 AW |
123 | } \ |
124 | ctype* scm_array_handle_##tag##_writable_elements (scm_t_array_handle *h) \ | |
125 | { \ | |
126 | if (h->element_type != ETYPE (TAG)) \ | |
127 | scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \ | |
0d782201 | 128 | return ((ctype*) h->writable_elements) + h->base*width; \ |
a2689737 AW |
129 | } \ |
130 | const ctype *scm_##tag##vector_elements (SCM uvec, \ | |
131 | scm_t_array_handle *h, \ | |
132 | size_t *lenp, ssize_t *incp) \ | |
133 | { \ | |
134 | return scm_##tag##vector_writable_elements (uvec, h, lenp, incp); \ | |
135 | } \ | |
136 | ctype *scm_##tag##vector_writable_elements (SCM uvec, \ | |
137 | scm_t_array_handle *h, \ | |
138 | size_t *lenp, ssize_t *incp) \ | |
139 | { \ | |
140 | scm_uniform_vector_elements (uvec, h, lenp, incp); \ | |
141 | if (h->element_type == ETYPE (TAG)) \ | |
0d782201 | 142 | return ((ctype*)h->writable_elements) + h->base*width; \ |
a2689737 AW |
143 | /* otherwise... */ \ |
144 | else \ | |
145 | { \ | |
146 | size_t sfrom, sto, lfrom, lto; \ | |
147 | if (h->dims != &h->dim0) \ | |
148 | { \ | |
149 | h->dim0 = h->dims[0]; \ | |
150 | h->dims = &h->dim0; \ | |
151 | } \ | |
152 | sfrom = scm_i_array_element_type_sizes [h->element_type]; \ | |
153 | sto = scm_i_array_element_type_sizes [ETYPE (TAG)]; \ | |
154 | lfrom = h->dim0.ubnd - h->dim0.lbnd + 1; \ | |
155 | lto = lfrom * sfrom / sto; \ | |
156 | if (lto * sto != lfrom * sfrom) \ | |
157 | { \ | |
158 | scm_array_handle_release (h); \ | |
159 | scm_wrong_type_arg (#tag"vector-elements", SCM_ARG1, uvec); \ | |
160 | } \ | |
161 | h->dim0.ubnd = h->dim0.lbnd + lto; \ | |
162 | h->base = h->base * sto / sfrom; \ | |
163 | h->element_type = ETYPE (TAG); \ | |
0d782201 | 164 | return ((ctype*)h->writable_elements) + h->base*width; \ |
a2689737 AW |
165 | } \ |
166 | } | |
69730f92 | 167 | |
fea99690 | 168 | |
a2689737 | 169 | #define MOD "srfi srfi-4" |
69730f92 | 170 | |
a2689737 | 171 | DEFINE_SRFI_4_PROXIES (u8); |
0d782201 | 172 | DEFINE_SRFI_4_C_FUNCS (U8, u8, scm_t_uint8, 1); |
69730f92 | 173 | |
a2689737 | 174 | DEFINE_SRFI_4_PROXIES (s8); |
0d782201 | 175 | DEFINE_SRFI_4_C_FUNCS (S8, s8, scm_t_int8, 1); |
69730f92 | 176 | |
a2689737 | 177 | DEFINE_SRFI_4_PROXIES (u16); |
0d782201 | 178 | DEFINE_SRFI_4_C_FUNCS (U16, u16, scm_t_uint16, 1); |
69730f92 | 179 | |
a2689737 | 180 | DEFINE_SRFI_4_PROXIES (s16); |
0d782201 | 181 | DEFINE_SRFI_4_C_FUNCS (S16, s16, scm_t_int16, 1); |
69730f92 | 182 | |
a2689737 | 183 | DEFINE_SRFI_4_PROXIES (u32); |
0d782201 | 184 | DEFINE_SRFI_4_C_FUNCS (U32, u32, scm_t_uint32, 1); |
fea99690 | 185 | |
a2689737 | 186 | DEFINE_SRFI_4_PROXIES (s32); |
0d782201 | 187 | DEFINE_SRFI_4_C_FUNCS (S32, s32, scm_t_int32, 1); |
69730f92 | 188 | |
a2689737 | 189 | DEFINE_SRFI_4_PROXIES (u64); |
0d782201 | 190 | DEFINE_SRFI_4_C_FUNCS (U64, u64, scm_t_uint64, 1); |
f8579182 | 191 | |
a2689737 | 192 | DEFINE_SRFI_4_PROXIES (s64); |
0d782201 | 193 | DEFINE_SRFI_4_C_FUNCS (S64, s64, scm_t_int64, 1); |
f8579182 | 194 | |
a2689737 | 195 | DEFINE_SRFI_4_PROXIES (f32); |
0d782201 | 196 | DEFINE_SRFI_4_C_FUNCS (F32, f32, float, 1); |
f8579182 | 197 | |
a2689737 | 198 | DEFINE_SRFI_4_PROXIES (f64); |
0d782201 | 199 | DEFINE_SRFI_4_C_FUNCS (F64, f64, double, 1); |
cbdc8379 | 200 | |
a2689737 AW |
201 | #undef MOD |
202 | #define MOD "srfi srfi-4 gnu" | |
cbdc8379 | 203 | |
a2689737 | 204 | DEFINE_SRFI_4_PROXIES (c32); |
0d782201 | 205 | DEFINE_SRFI_4_C_FUNCS (C32, c32, float, 2); |
ac8ed3db | 206 | |
a2689737 | 207 | DEFINE_SRFI_4_PROXIES (c64); |
0d782201 | 208 | DEFINE_SRFI_4_C_FUNCS (C64, c64, double, 2); |
ac8ed3db AW |
209 | |
210 | #define DEFINE_SRFI_4_GNU_PROXIES(tag) \ | |
211 | DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector") | |
212 | ||
a2689737 | 213 | #undef MOD |
ac8ed3db AW |
214 | #define MOD "srfi srfi-4 gnu" |
215 | DEFINE_SRFI_4_GNU_PROXIES (u8); | |
216 | DEFINE_SRFI_4_GNU_PROXIES (s8); | |
217 | DEFINE_SRFI_4_GNU_PROXIES (u16); | |
218 | DEFINE_SRFI_4_GNU_PROXIES (s16); | |
219 | DEFINE_SRFI_4_GNU_PROXIES (u32); | |
220 | DEFINE_SRFI_4_GNU_PROXIES (s32); | |
221 | DEFINE_SRFI_4_GNU_PROXIES (u64); | |
222 | DEFINE_SRFI_4_GNU_PROXIES (s64); | |
223 | DEFINE_SRFI_4_GNU_PROXIES (f32); | |
224 | DEFINE_SRFI_4_GNU_PROXIES (f64); | |
225 | DEFINE_SRFI_4_GNU_PROXIES (c32); | |
226 | DEFINE_SRFI_4_GNU_PROXIES (c64); | |
227 | ||
228 | ||
a2689737 AW |
229 | SCM_DEFINE (scm_make_srfi_4_vector, "make-srfi-4-vector", 2, 1, 0, |
230 | (SCM type, SCM len, SCM fill), | |
231 | "Make a srfi-4 vector") | |
232 | #define FUNC_NAME s_scm_make_srfi_4_vector | |
4ea4bc4c | 233 | { |
a2689737 AW |
234 | int i; |
235 | for (i = 0; i <= SCM_ARRAY_ELEMENT_TYPE_LAST; i++) | |
236 | if (scm_is_eq (type, scm_i_array_element_types[i])) | |
237 | break; | |
238 | if (i > SCM_ARRAY_ELEMENT_TYPE_LAST) | |
239 | scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "vector type"); | |
240 | switch (i) | |
241 | { | |
242 | case SCM_ARRAY_ELEMENT_TYPE_U8: | |
243 | case SCM_ARRAY_ELEMENT_TYPE_S8: | |
244 | case SCM_ARRAY_ELEMENT_TYPE_U16: | |
245 | case SCM_ARRAY_ELEMENT_TYPE_S16: | |
246 | case SCM_ARRAY_ELEMENT_TYPE_U32: | |
247 | case SCM_ARRAY_ELEMENT_TYPE_S32: | |
248 | case SCM_ARRAY_ELEMENT_TYPE_U64: | |
249 | case SCM_ARRAY_ELEMENT_TYPE_S64: | |
250 | case SCM_ARRAY_ELEMENT_TYPE_F32: | |
251 | case SCM_ARRAY_ELEMENT_TYPE_F64: | |
252 | case SCM_ARRAY_ELEMENT_TYPE_C32: | |
253 | case SCM_ARRAY_ELEMENT_TYPE_C64: | |
254 | { | |
255 | SCM ret = scm_i_make_typed_bytevector (scm_to_size_t (len), i); | |
dc327575 LC |
256 | |
257 | if (SCM_UNBNDP (fill) || scm_is_eq (len, SCM_INUM0)) | |
a2689737 AW |
258 | ; /* pass */ |
259 | else if (scm_is_true (scm_zero_p (fill))) | |
260 | memset (SCM_BYTEVECTOR_CONTENTS (ret), 0, | |
261 | SCM_BYTEVECTOR_LENGTH (ret)); | |
262 | else | |
263 | { | |
264 | scm_t_array_handle h; | |
265 | size_t len; | |
266 | ssize_t pos, inc; | |
d900a855 | 267 | |
a2689737 | 268 | scm_uniform_vector_writable_elements (ret, &h, &len, &inc); |
d900a855 | 269 | |
a2689737 AW |
270 | for (pos = 0; pos != h.dims[0].ubnd; pos += inc) |
271 | scm_array_handle_set (&h, pos, fill); | |
d900a855 LC |
272 | |
273 | /* Initialize the last element. */ | |
274 | scm_array_handle_set (&h, pos, fill); | |
275 | ||
a2689737 AW |
276 | scm_array_handle_release (&h); |
277 | } | |
278 | return ret; | |
279 | } | |
280 | default: | |
281 | scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "uniform vector type"); | |
282 | return SCM_BOOL_F; /* not reached */ | |
283 | } | |
4ea4bc4c | 284 | } |
a2689737 | 285 | #undef FUNC_NAME |
2a610be5 | 286 | |
f8579182 MV |
287 | void |
288 | scm_init_srfi_4 (void) | |
289 | { | |
f45eccff AW |
290 | #define REGISTER(tag, TAG) \ |
291 | scm_i_register_vector_constructor \ | |
292 | (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG], \ | |
293 | scm_make_##tag##vector) | |
294 | ||
295 | REGISTER (u8, U8); | |
296 | REGISTER (s8, S8); | |
297 | REGISTER (u16, U16); | |
298 | REGISTER (s16, S16); | |
299 | REGISTER (u32, U32); | |
300 | REGISTER (s32, S32); | |
301 | REGISTER (u64, U64); | |
302 | REGISTER (s64, S64); | |
303 | REGISTER (f32, F32); | |
304 | REGISTER (f64, F64); | |
305 | REGISTER (c32, C32); | |
306 | REGISTER (c64, C64); | |
307 | ||
f8579182 MV |
308 | #include "libguile/srfi-4.x" |
309 | } | |
310 | ||
311 | /* End of srfi-4.c. */ |