HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Merge remote-tracking branch 'origin/stable-2.0'
[bpt/guile.git] / libguile / srfi-4.c
CommitLineData
69d2000d 1/* srfi-4.c --- Uniform numeric vector datatypes.
f8579182 2 *
059a588f 3 * Copyright (C) 2001, 2004, 2006, 2009, 2010, 2011 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 { \
059a588f
AW		 116 return scm_c_take_typed_bytevector ((scm_t_int8*)data, n, ETYPE (TAG), \
117 SCM_BOOL_F); \
a2689737
AW		 118 } \
119 const ctype* scm_array_handle_##tag##_elements (scm_t_array_handle *h) \
120 { \
121 if (h->element_type != ETYPE (TAG)) \
122 scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \
0d782201 123 return ((const ctype*) h->elements) + h->base*width; \
a2689737
AW		 124 } \
125 ctype* scm_array_handle_##tag##_writable_elements (scm_t_array_handle *h) \
126 { \
127 if (h->element_type != ETYPE (TAG)) \
128 scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \
0d782201 129 return ((ctype*) h->writable_elements) + h->base*width; \
a2689737
AW		 130 } \
131 const ctype *scm_##tag##vector_elements (SCM uvec, \
132 scm_t_array_handle *h, \
133 size_t *lenp, ssize_t *incp) \
134 { \
135 return scm_##tag##vector_writable_elements (uvec, h, lenp, incp); \
136 } \
137 ctype *scm_##tag##vector_writable_elements (SCM uvec, \
138 scm_t_array_handle *h, \
139 size_t *lenp, ssize_t *incp) \
140 { \
141 scm_uniform_vector_elements (uvec, h, lenp, incp); \
142 if (h->element_type == ETYPE (TAG)) \
0d782201 143 return ((ctype*)h->writable_elements) + h->base*width; \
a2689737
AW		 144 /* otherwise... */ \
145 else \
146 { \
147 size_t sfrom, sto, lfrom, lto; \
148 if (h->dims != &h->dim0) \
149 { \
150 h->dim0 = h->dims[0]; \
151 h->dims = &h->dim0; \
152 } \
153 sfrom = scm_i_array_element_type_sizes [h->element_type]; \
154 sto = scm_i_array_element_type_sizes [ETYPE (TAG)]; \
155 lfrom = h->dim0.ubnd - h->dim0.lbnd + 1; \
156 lto = lfrom * sfrom / sto; \
157 if (lto * sto != lfrom * sfrom) \
158 { \
159 scm_array_handle_release (h); \
160 scm_wrong_type_arg (#tag"vector-elements", SCM_ARG1, uvec); \
161 } \
162 h->dim0.ubnd = h->dim0.lbnd + lto; \
163 h->base = h->base * sto / sfrom; \
164 h->element_type = ETYPE (TAG); \
0d782201 165 return ((ctype*)h->writable_elements) + h->base*width; \
a2689737
AW		 166 } \
167 }
69730f92 168
fea99690 169
a2689737 170#define MOD "srfi srfi-4"
69730f92 171
a2689737 172DEFINE_SRFI_4_PROXIES (u8);
0d782201 173DEFINE_SRFI_4_C_FUNCS (U8, u8, scm_t_uint8, 1);
69730f92 174
a2689737 175DEFINE_SRFI_4_PROXIES (s8);
0d782201 176DEFINE_SRFI_4_C_FUNCS (S8, s8, scm_t_int8, 1);
69730f92 177
a2689737 178DEFINE_SRFI_4_PROXIES (u16);
0d782201 179DEFINE_SRFI_4_C_FUNCS (U16, u16, scm_t_uint16, 1);
69730f92 180
a2689737 181DEFINE_SRFI_4_PROXIES (s16);
0d782201 182DEFINE_SRFI_4_C_FUNCS (S16, s16, scm_t_int16, 1);
69730f92 183
a2689737 184DEFINE_SRFI_4_PROXIES (u32);
0d782201 185DEFINE_SRFI_4_C_FUNCS (U32, u32, scm_t_uint32, 1);
fea99690 186
a2689737 187DEFINE_SRFI_4_PROXIES (s32);
0d782201 188DEFINE_SRFI_4_C_FUNCS (S32, s32, scm_t_int32, 1);
69730f92 189
a2689737 190DEFINE_SRFI_4_PROXIES (u64);
0d782201 191DEFINE_SRFI_4_C_FUNCS (U64, u64, scm_t_uint64, 1);
f8579182 192
a2689737 193DEFINE_SRFI_4_PROXIES (s64);
0d782201 194DEFINE_SRFI_4_C_FUNCS (S64, s64, scm_t_int64, 1);
f8579182 195
a2689737 196DEFINE_SRFI_4_PROXIES (f32);
0d782201 197DEFINE_SRFI_4_C_FUNCS (F32, f32, float, 1);
f8579182 198
a2689737 199DEFINE_SRFI_4_PROXIES (f64);
0d782201 200DEFINE_SRFI_4_C_FUNCS (F64, f64, double, 1);
cbdc8379 201
a2689737
AW		 202#undef MOD
203#define MOD "srfi srfi-4 gnu"
cbdc8379 204
a2689737 205DEFINE_SRFI_4_PROXIES (c32);
0d782201 206DEFINE_SRFI_4_C_FUNCS (C32, c32, float, 2);
ac8ed3db 207
a2689737 208DEFINE_SRFI_4_PROXIES (c64);
0d782201 209DEFINE_SRFI_4_C_FUNCS (C64, c64, double, 2);
ac8ed3db
AW		 210
211#define DEFINE_SRFI_4_GNU_PROXIES(tag) \
212 DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector")
213
a2689737 214#undef MOD
ac8ed3db
AW		 215#define MOD "srfi srfi-4 gnu"
216DEFINE_SRFI_4_GNU_PROXIES (u8);
217DEFINE_SRFI_4_GNU_PROXIES (s8);
218DEFINE_SRFI_4_GNU_PROXIES (u16);
219DEFINE_SRFI_4_GNU_PROXIES (s16);
220DEFINE_SRFI_4_GNU_PROXIES (u32);
221DEFINE_SRFI_4_GNU_PROXIES (s32);
222DEFINE_SRFI_4_GNU_PROXIES (u64);
223DEFINE_SRFI_4_GNU_PROXIES (s64);
224DEFINE_SRFI_4_GNU_PROXIES (f32);
225DEFINE_SRFI_4_GNU_PROXIES (f64);
226DEFINE_SRFI_4_GNU_PROXIES (c32);
227DEFINE_SRFI_4_GNU_PROXIES (c64);
228
229
a2689737
AW		 230SCM_DEFINE (scm_make_srfi_4_vector, "make-srfi-4-vector", 2, 1, 0,
231 (SCM type, SCM len, SCM fill),
232 "Make a srfi-4 vector")
233#define FUNC_NAME s_scm_make_srfi_4_vector
4ea4bc4c 234{
a2689737
AW		 235 int i;
236 for (i = 0; i <= SCM_ARRAY_ELEMENT_TYPE_LAST; i++)
237 if (scm_is_eq (type, scm_i_array_element_types[i]))
238 break;
239 if (i > SCM_ARRAY_ELEMENT_TYPE_LAST)
240 scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "vector type");
241 switch (i)
242 {
243 case SCM_ARRAY_ELEMENT_TYPE_U8:
244 case SCM_ARRAY_ELEMENT_TYPE_S8:
245 case SCM_ARRAY_ELEMENT_TYPE_U16:
246 case SCM_ARRAY_ELEMENT_TYPE_S16:
247 case SCM_ARRAY_ELEMENT_TYPE_U32:
248 case SCM_ARRAY_ELEMENT_TYPE_S32:
249 case SCM_ARRAY_ELEMENT_TYPE_U64:
250 case SCM_ARRAY_ELEMENT_TYPE_S64:
251 case SCM_ARRAY_ELEMENT_TYPE_F32:
252 case SCM_ARRAY_ELEMENT_TYPE_F64:
253 case SCM_ARRAY_ELEMENT_TYPE_C32:
254 case SCM_ARRAY_ELEMENT_TYPE_C64:
255 {
256 SCM ret = scm_i_make_typed_bytevector (scm_to_size_t (len), i);
dc327575
LC		 257
258 if (SCM_UNBNDP (fill) || scm_is_eq (len, SCM_INUM0))
a2689737
AW		 259 ; /* pass */
260 else if (scm_is_true (scm_zero_p (fill)))
261 memset (SCM_BYTEVECTOR_CONTENTS (ret), 0,
262 SCM_BYTEVECTOR_LENGTH (ret));
263 else
264 {
265 scm_t_array_handle h;
266 size_t len;
267 ssize_t pos, inc;
d900a855 268
a2689737 269 scm_uniform_vector_writable_elements (ret, &h, &len, &inc);
d900a855 270
a2689737
AW		 271 for (pos = 0; pos != h.dims[0].ubnd; pos += inc)
272 scm_array_handle_set (&h, pos, fill);
d900a855
LC		 273
274 /* Initialize the last element. */
275 scm_array_handle_set (&h, pos, fill);
276
a2689737
AW		 277 scm_array_handle_release (&h);
278 }
279 return ret;
280 }
281 default:
282 scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "uniform vector type");
283 return SCM_BOOL_F; /* not reached */
284 }
4ea4bc4c 285}
a2689737 286#undef FUNC_NAME
2a610be5 287
f8579182
MV		 288void
289scm_init_srfi_4 (void)
290{
f45eccff
AW		 291#define REGISTER(tag, TAG) \
292 scm_i_register_vector_constructor \
293 (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG], \
294 scm_make_##tag##vector)
295
296 REGISTER (u8, U8);
297 REGISTER (s8, S8);
298 REGISTER (u16, U16);
299 REGISTER (s16, S16);
300 REGISTER (u32, U32);
301 REGISTER (s32, S32);
302 REGISTER (u64, U64);
303 REGISTER (s64, S64);
304 REGISTER (f32, F32);
305 REGISTER (f64, F64);
306 REGISTER (c32, C32);
307 REGISTER (c64, C64);
308
f8579182
MV		 309#include "libguile/srfi-4.x"
310}
311
312/* End of srfi-4.c. */
Unnamed repository; edit this file 'description' to name the repository.