Commit | Line | Data |
---|---|---|
69d2000d | 1 | /* srfi-4.c --- Uniform numeric vector datatypes. |
f8579182 | 2 | * |
dc65b88d | 3 | * Copyright (C) 2001, 2004, 2006, 2009, 2010, 2014 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 | { \ | |
2be7131e | 140 | size_t byte_width = width * sizeof (ctype); \ |
dc65b88d | 141 | if (!scm_is_bytevector (uvec) \ |
2be7131e | 142 | || (scm_c_bytevector_length (uvec) % byte_width)) \ |
dc65b88d AW |
143 | scm_wrong_type_arg_msg (NULL, 0, uvec, #tag "vector"); \ |
144 | scm_array_get_handle (uvec, h); \ | |
145 | if (lenp) \ | |
2be7131e | 146 | *lenp = scm_c_bytevector_length (uvec) / byte_width; \ |
dc65b88d AW |
147 | if (incp) \ |
148 | *incp = 1; \ | |
149 | return ((ctype *)h->writable_elements); \ | |
a2689737 | 150 | } |
69730f92 | 151 | |
fea99690 | 152 | |
a2689737 | 153 | #define MOD "srfi srfi-4" |
69730f92 | 154 | |
a2689737 | 155 | DEFINE_SRFI_4_PROXIES (u8); |
0d782201 | 156 | DEFINE_SRFI_4_C_FUNCS (U8, u8, scm_t_uint8, 1); |
69730f92 | 157 | |
a2689737 | 158 | DEFINE_SRFI_4_PROXIES (s8); |
0d782201 | 159 | DEFINE_SRFI_4_C_FUNCS (S8, s8, scm_t_int8, 1); |
69730f92 | 160 | |
a2689737 | 161 | DEFINE_SRFI_4_PROXIES (u16); |
0d782201 | 162 | DEFINE_SRFI_4_C_FUNCS (U16, u16, scm_t_uint16, 1); |
69730f92 | 163 | |
a2689737 | 164 | DEFINE_SRFI_4_PROXIES (s16); |
0d782201 | 165 | DEFINE_SRFI_4_C_FUNCS (S16, s16, scm_t_int16, 1); |
69730f92 | 166 | |
a2689737 | 167 | DEFINE_SRFI_4_PROXIES (u32); |
0d782201 | 168 | DEFINE_SRFI_4_C_FUNCS (U32, u32, scm_t_uint32, 1); |
fea99690 | 169 | |
a2689737 | 170 | DEFINE_SRFI_4_PROXIES (s32); |
0d782201 | 171 | DEFINE_SRFI_4_C_FUNCS (S32, s32, scm_t_int32, 1); |
69730f92 | 172 | |
a2689737 | 173 | DEFINE_SRFI_4_PROXIES (u64); |
0d782201 | 174 | DEFINE_SRFI_4_C_FUNCS (U64, u64, scm_t_uint64, 1); |
f8579182 | 175 | |
a2689737 | 176 | DEFINE_SRFI_4_PROXIES (s64); |
0d782201 | 177 | DEFINE_SRFI_4_C_FUNCS (S64, s64, scm_t_int64, 1); |
f8579182 | 178 | |
a2689737 | 179 | DEFINE_SRFI_4_PROXIES (f32); |
0d782201 | 180 | DEFINE_SRFI_4_C_FUNCS (F32, f32, float, 1); |
f8579182 | 181 | |
a2689737 | 182 | DEFINE_SRFI_4_PROXIES (f64); |
0d782201 | 183 | DEFINE_SRFI_4_C_FUNCS (F64, f64, double, 1); |
cbdc8379 | 184 | |
a2689737 AW |
185 | #undef MOD |
186 | #define MOD "srfi srfi-4 gnu" | |
cbdc8379 | 187 | |
a2689737 | 188 | DEFINE_SRFI_4_PROXIES (c32); |
0d782201 | 189 | DEFINE_SRFI_4_C_FUNCS (C32, c32, float, 2); |
ac8ed3db | 190 | |
a2689737 | 191 | DEFINE_SRFI_4_PROXIES (c64); |
0d782201 | 192 | DEFINE_SRFI_4_C_FUNCS (C64, c64, double, 2); |
ac8ed3db AW |
193 | |
194 | #define DEFINE_SRFI_4_GNU_PROXIES(tag) \ | |
195 | DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector") | |
196 | ||
a2689737 | 197 | #undef MOD |
ac8ed3db AW |
198 | #define MOD "srfi srfi-4 gnu" |
199 | DEFINE_SRFI_4_GNU_PROXIES (u8); | |
200 | DEFINE_SRFI_4_GNU_PROXIES (s8); | |
201 | DEFINE_SRFI_4_GNU_PROXIES (u16); | |
202 | DEFINE_SRFI_4_GNU_PROXIES (s16); | |
203 | DEFINE_SRFI_4_GNU_PROXIES (u32); | |
204 | DEFINE_SRFI_4_GNU_PROXIES (s32); | |
205 | DEFINE_SRFI_4_GNU_PROXIES (u64); | |
206 | DEFINE_SRFI_4_GNU_PROXIES (s64); | |
207 | DEFINE_SRFI_4_GNU_PROXIES (f32); | |
208 | DEFINE_SRFI_4_GNU_PROXIES (f64); | |
209 | DEFINE_SRFI_4_GNU_PROXIES (c32); | |
210 | DEFINE_SRFI_4_GNU_PROXIES (c64); | |
211 | ||
212 | ||
a2689737 AW |
213 | SCM_DEFINE (scm_make_srfi_4_vector, "make-srfi-4-vector", 2, 1, 0, |
214 | (SCM type, SCM len, SCM fill), | |
215 | "Make a srfi-4 vector") | |
216 | #define FUNC_NAME s_scm_make_srfi_4_vector | |
4ea4bc4c | 217 | { |
dc65b88d AW |
218 | int c_type; |
219 | size_t c_len; | |
220 | ||
221 | for (c_type = 0; c_type <= SCM_ARRAY_ELEMENT_TYPE_LAST; c_type++) | |
222 | if (scm_is_eq (type, scm_i_array_element_types[c_type])) | |
a2689737 | 223 | break; |
dc65b88d | 224 | if (c_type > SCM_ARRAY_ELEMENT_TYPE_LAST) |
a2689737 | 225 | scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "vector type"); |
dc65b88d | 226 | switch (c_type) |
a2689737 AW |
227 | { |
228 | case SCM_ARRAY_ELEMENT_TYPE_U8: | |
229 | case SCM_ARRAY_ELEMENT_TYPE_S8: | |
230 | case SCM_ARRAY_ELEMENT_TYPE_U16: | |
231 | case SCM_ARRAY_ELEMENT_TYPE_S16: | |
232 | case SCM_ARRAY_ELEMENT_TYPE_U32: | |
233 | case SCM_ARRAY_ELEMENT_TYPE_S32: | |
234 | case SCM_ARRAY_ELEMENT_TYPE_U64: | |
235 | case SCM_ARRAY_ELEMENT_TYPE_S64: | |
236 | case SCM_ARRAY_ELEMENT_TYPE_F32: | |
237 | case SCM_ARRAY_ELEMENT_TYPE_F64: | |
238 | case SCM_ARRAY_ELEMENT_TYPE_C32: | |
239 | case SCM_ARRAY_ELEMENT_TYPE_C64: | |
240 | { | |
dc65b88d AW |
241 | SCM ret; |
242 | ||
243 | c_len = scm_to_size_t (len); | |
244 | ret = scm_i_make_typed_bytevector (c_len, c_type); | |
dc327575 LC |
245 | |
246 | if (SCM_UNBNDP (fill) || scm_is_eq (len, SCM_INUM0)) | |
a2689737 AW |
247 | ; /* pass */ |
248 | else if (scm_is_true (scm_zero_p (fill))) | |
249 | memset (SCM_BYTEVECTOR_CONTENTS (ret), 0, | |
250 | SCM_BYTEVECTOR_LENGTH (ret)); | |
251 | else | |
252 | { | |
253 | scm_t_array_handle h; | |
dc65b88d | 254 | size_t i; |
d900a855 | 255 | |
dc65b88d AW |
256 | scm_array_get_handle (ret, &h); |
257 | for (i = 0; i < c_len; i++) | |
258 | scm_array_handle_set (&h, i, fill); | |
a2689737 AW |
259 | scm_array_handle_release (&h); |
260 | } | |
261 | return ret; | |
262 | } | |
263 | default: | |
264 | scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "uniform vector type"); | |
265 | return SCM_BOOL_F; /* not reached */ | |
266 | } | |
4ea4bc4c | 267 | } |
a2689737 | 268 | #undef FUNC_NAME |
2a610be5 | 269 | |
f8579182 MV |
270 | void |
271 | scm_init_srfi_4 (void) | |
272 | { | |
f45eccff AW |
273 | #define REGISTER(tag, TAG) \ |
274 | scm_i_register_vector_constructor \ | |
275 | (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG], \ | |
276 | scm_make_##tag##vector) | |
277 | ||
278 | REGISTER (u8, U8); | |
279 | REGISTER (s8, S8); | |
280 | REGISTER (u16, U16); | |
281 | REGISTER (s16, S16); | |
282 | REGISTER (u32, U32); | |
283 | REGISTER (s32, S32); | |
284 | REGISTER (u64, U64); | |
285 | REGISTER (s64, S64); | |
286 | REGISTER (f32, F32); | |
287 | REGISTER (f64, F64); | |
288 | REGISTER (c32, C32); | |
289 | REGISTER (c64, C64); | |
290 | ||
f8579182 MV |
291 | #include "libguile/srfi-4.x" |
292 | } | |
293 | ||
294 | /* End of srfi-4.c. */ |