Commit | Line | Data |
---|---|---|
69d2000d | 1 | /* srfi-4.c --- Uniform numeric vector datatypes. |
f8579182 | 2 | * |
54f17b7b | 3 | * Copyright (C) 2001, 2004, 2006, 2009, 2010, 2011, 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" | |
a2689737 | 34 | #include "libguile/validate.h" |
69730f92 | 35 | |
f8579182 | 36 | |
a2689737 AW |
37 | #define DEFINE_SCHEME_PROXY100(cname, modname, scmname) \ |
38 | SCM cname (SCM arg1) \ | |
39 | { \ | |
40 | static SCM var = SCM_BOOL_F; \ | |
41 | if (scm_is_false (var)) \ | |
42 | var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \ | |
43 | return scm_call_1 (SCM_VARIABLE_REF (var), arg1); \ | |
f8579182 MV |
44 | } |
45 | ||
a2689737 AW |
46 | #define DEFINE_SCHEME_PROXY001(cname, modname, scmname) \ |
47 | SCM cname (SCM args) \ | |
48 | { \ | |
49 | static SCM var = SCM_BOOL_F; \ | |
50 | if (scm_is_false (var)) \ | |
51 | var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \ | |
52 | return scm_apply_0 (SCM_VARIABLE_REF (var), args); \ | |
53 | } | |
f8579182 | 54 | |
a2689737 AW |
55 | #define DEFINE_SCHEME_PROXY110(cname, modname, scmname) \ |
56 | SCM cname (SCM arg1, SCM opt1) \ | |
57 | { \ | |
58 | static SCM var = SCM_BOOL_F; \ | |
59 | if (scm_is_false (var)) \ | |
60 | var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \ | |
61 | if (SCM_UNBNDP (opt1)) \ | |
62 | return scm_call_1 (SCM_VARIABLE_REF (var), arg1); \ | |
63 | else \ | |
64 | return scm_call_2 (SCM_VARIABLE_REF (var), arg1, opt1); \ | |
65 | } | |
f8579182 | 66 | |
a2689737 AW |
67 | #define DEFINE_SCHEME_PROXY200(cname, modname, scmname) \ |
68 | SCM cname (SCM arg1, SCM arg2) \ | |
69 | { \ | |
70 | static SCM var = SCM_BOOL_F; \ | |
71 | if (scm_is_false (var)) \ | |
72 | var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \ | |
73 | return scm_call_2 (SCM_VARIABLE_REF (var), arg1, arg2); \ | |
74 | } | |
f8579182 | 75 | |
a2689737 AW |
76 | #define DEFINE_SCHEME_PROXY300(cname, modname, scmname) \ |
77 | SCM cname (SCM arg1, SCM arg2, SCM arg3) \ | |
78 | { \ | |
79 | static SCM var = SCM_BOOL_F; \ | |
80 | if (scm_is_false (var)) \ | |
81 | var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \ | |
82 | return scm_call_3 (SCM_VARIABLE_REF (var), arg1, arg2, arg3); \ | |
83 | } | |
d7e7a02a | 84 | |
a2689737 AW |
85 | #define DEFPROXY100(cname, scmname) \ |
86 | DEFINE_SCHEME_PROXY100 (cname, MOD, scmname) | |
87 | #define DEFPROXY110(cname, scmname) \ | |
88 | DEFINE_SCHEME_PROXY110 (cname, MOD, scmname) | |
89 | #define DEFPROXY001(cname, scmname) \ | |
90 | DEFINE_SCHEME_PROXY001 (cname, MOD, scmname) | |
91 | #define DEFPROXY200(cname, scmname) \ | |
92 | DEFINE_SCHEME_PROXY200 (cname, MOD, scmname) | |
93 | #define DEFPROXY300(cname, scmname) \ | |
94 | DEFINE_SCHEME_PROXY300 (cname, MOD, scmname) | |
95 | ||
96 | #define DEFVECT(sym, str, func)\ | |
97 | ||
98 | #define DEFINE_SRFI_4_PROXIES(tag) \ | |
99 | DEFPROXY100 (scm_##tag##vector_p, #tag "vector?"); \ | |
100 | DEFPROXY110 (scm_make_##tag##vector, "make-" #tag "vector"); \ | |
101 | DEFPROXY001 (scm_##tag##vector, #tag "vector"); \ | |
102 | DEFPROXY100 (scm_##tag##vector_length, #tag "vector-length"); \ | |
103 | DEFPROXY200 (scm_##tag##vector_ref, #tag "vector-ref"); \ | |
104 | DEFPROXY300 (scm_##tag##vector_set_x, #tag "vector-set!"); \ | |
105 | DEFPROXY100 (scm_list_to_##tag##vector, "list->"#tag "vector"); \ | |
106 | DEFPROXY100 (scm_##tag##vector_to_list, #tag "vector->list"); \ | |
faa00365 | 107 | |
a2689737 AW |
108 | |
109 | #define ETYPE(TAG) \ | |
110 | SCM_ARRAY_ELEMENT_TYPE_##TAG | |
69730f92 | 111 | |
0d782201 | 112 | #define DEFINE_SRFI_4_C_FUNCS(TAG, tag, ctype, width) \ |
a2689737 AW |
113 | SCM scm_take_##tag##vector (ctype *data, size_t n) \ |
114 | { \ | |
059a588f AW |
115 | return scm_c_take_typed_bytevector ((scm_t_int8*)data, n, ETYPE (TAG), \ |
116 | SCM_BOOL_F); \ | |
a2689737 AW |
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. */ |