1 /* srfi-4.c --- Uniform numeric vector datatypes.
3 * Copyright (C) 2001, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
5 * This library is free software; you can redistribute it and/or
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.
10 * This library is distributed in the hope that it will be useful, but
11 * WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Lesser General Public License for more details.
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
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
25 #include "libguile/_scm.h"
26 #include "libguile/__scm.h"
27 #include "libguile/bdw-gc.h"
28 #include "libguile/srfi-4.h"
29 #include "libguile/bytevectors.h"
30 #include "libguile/error.h"
31 #include "libguile/eval.h"
32 #include "libguile/extensions.h"
33 #include "libguile/uniform.h"
34 #include "libguile/generalized-vectors.h"
35 #include "libguile/validate.h"
38 #define DEFINE_SCHEME_PROXY100(cname, modname, scmname) \
39 SCM cname (SCM arg1) \
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); \
47 #define DEFINE_SCHEME_PROXY001(cname, modname, scmname) \
48 SCM cname (SCM args) \
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); \
56 #define DEFINE_SCHEME_PROXY110(cname, modname, scmname) \
57 SCM cname (SCM arg1, SCM opt1) \
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); \
65 return scm_call_2 (SCM_VARIABLE_REF (var), arg1, opt1); \
68 #define DEFINE_SCHEME_PROXY200(cname, modname, scmname) \
69 SCM cname (SCM arg1, SCM arg2) \
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); \
77 #define DEFINE_SCHEME_PROXY300(cname, modname, scmname) \
78 SCM cname (SCM arg1, SCM arg2, SCM arg3) \
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); \
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)
97 #define DEFVECT(sym, str, func)\
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"); \
111 SCM_ARRAY_ELEMENT_TYPE_##TAG
113 #define DEFINE_SRFI_4_C_FUNCS(TAG, tag, ctype, width) \
114 SCM scm_take_##tag##vector (ctype *data, size_t n) \
116 return scm_c_take_typed_bytevector ((scm_t_int8*)data, n, ETYPE (TAG), \
119 const ctype* scm_array_handle_##tag##_elements (scm_t_array_handle *h) \
121 if (h->element_type != ETYPE (TAG)) \
122 scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \
123 return ((const ctype*) h->elements) + h->base*width; \
125 ctype* scm_array_handle_##tag##_writable_elements (scm_t_array_handle *h) \
127 if (h->element_type != ETYPE (TAG)) \
128 scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \
129 return ((ctype*) h->writable_elements) + h->base*width; \
131 const ctype *scm_##tag##vector_elements (SCM uvec, \
132 scm_t_array_handle *h, \
133 size_t *lenp, ssize_t *incp) \
135 return scm_##tag##vector_writable_elements (uvec, h, lenp, incp); \
137 ctype *scm_##tag##vector_writable_elements (SCM uvec, \
138 scm_t_array_handle *h, \
139 size_t *lenp, ssize_t *incp) \
141 scm_uniform_vector_elements (uvec, h, lenp, incp); \
142 if (h->element_type == ETYPE (TAG)) \
143 return ((ctype*)h->writable_elements) + h->base*width; \
147 size_t sfrom, sto, lfrom, lto; \
148 if (h->dims != &h->dim0) \
150 h->dim0 = h->dims[0]; \
151 h->dims = &h->dim0; \
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) \
159 scm_array_handle_release (h); \
160 scm_wrong_type_arg (#tag"vector-elements", SCM_ARG1, uvec); \
162 h->dim0.ubnd = h->dim0.lbnd + lto; \
163 h->base = h->base * sto / sfrom; \
164 h->element_type = ETYPE (TAG); \
165 return ((ctype*)h->writable_elements) + h->base*width; \
170 #define MOD "srfi srfi-4"
172 DEFINE_SRFI_4_PROXIES (u8
);
173 DEFINE_SRFI_4_C_FUNCS (U8
, u8
, scm_t_uint8
, 1);
175 DEFINE_SRFI_4_PROXIES (s8
);
176 DEFINE_SRFI_4_C_FUNCS (S8
, s8
, scm_t_int8
, 1);
178 DEFINE_SRFI_4_PROXIES (u16
);
179 DEFINE_SRFI_4_C_FUNCS (U16
, u16
, scm_t_uint16
, 1);
181 DEFINE_SRFI_4_PROXIES (s16
);
182 DEFINE_SRFI_4_C_FUNCS (S16
, s16
, scm_t_int16
, 1);
184 DEFINE_SRFI_4_PROXIES (u32
);
185 DEFINE_SRFI_4_C_FUNCS (U32
, u32
, scm_t_uint32
, 1);
187 DEFINE_SRFI_4_PROXIES (s32
);
188 DEFINE_SRFI_4_C_FUNCS (S32
, s32
, scm_t_int32
, 1);
190 DEFINE_SRFI_4_PROXIES (u64
);
191 DEFINE_SRFI_4_C_FUNCS (U64
, u64
, scm_t_uint64
, 1);
193 DEFINE_SRFI_4_PROXIES (s64
);
194 DEFINE_SRFI_4_C_FUNCS (S64
, s64
, scm_t_int64
, 1);
196 DEFINE_SRFI_4_PROXIES (f32
);
197 DEFINE_SRFI_4_C_FUNCS (F32
, f32
, float, 1);
199 DEFINE_SRFI_4_PROXIES (f64
);
200 DEFINE_SRFI_4_C_FUNCS (F64
, f64
, double, 1);
203 #define MOD "srfi srfi-4 gnu"
205 DEFINE_SRFI_4_PROXIES (c32
);
206 DEFINE_SRFI_4_C_FUNCS (C32
, c32
, float, 2);
208 DEFINE_SRFI_4_PROXIES (c64
);
209 DEFINE_SRFI_4_C_FUNCS (C64
, c64
, double, 2);
211 #define DEFINE_SRFI_4_GNU_PROXIES(tag) \
212 DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector")
215 #define MOD "srfi srfi-4 gnu"
216 DEFINE_SRFI_4_GNU_PROXIES (u8
);
217 DEFINE_SRFI_4_GNU_PROXIES (s8
);
218 DEFINE_SRFI_4_GNU_PROXIES (u16
);
219 DEFINE_SRFI_4_GNU_PROXIES (s16
);
220 DEFINE_SRFI_4_GNU_PROXIES (u32
);
221 DEFINE_SRFI_4_GNU_PROXIES (s32
);
222 DEFINE_SRFI_4_GNU_PROXIES (u64
);
223 DEFINE_SRFI_4_GNU_PROXIES (s64
);
224 DEFINE_SRFI_4_GNU_PROXIES (f32
);
225 DEFINE_SRFI_4_GNU_PROXIES (f64
);
226 DEFINE_SRFI_4_GNU_PROXIES (c32
);
227 DEFINE_SRFI_4_GNU_PROXIES (c64
);
230 SCM_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
236 for (i
= 0; i
<= SCM_ARRAY_ELEMENT_TYPE_LAST
; i
++)
237 if (scm_is_eq (type
, scm_i_array_element_types
[i
]))
239 if (i
> SCM_ARRAY_ELEMENT_TYPE_LAST
)
240 scm_wrong_type_arg_msg (FUNC_NAME
, SCM_ARG1
, type
, "vector type");
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
:
256 SCM ret
= scm_i_make_typed_bytevector (scm_to_size_t (len
), i
);
258 if (SCM_UNBNDP (fill
) || scm_is_eq (len
, SCM_INUM0
))
260 else if (scm_is_true (scm_zero_p (fill
)))
261 memset (SCM_BYTEVECTOR_CONTENTS (ret
), 0,
262 SCM_BYTEVECTOR_LENGTH (ret
));
265 scm_t_array_handle h
;
269 scm_uniform_vector_writable_elements (ret
, &h
, &len
, &inc
);
271 for (pos
= 0; pos
!= h
.dims
[0].ubnd
; pos
+= inc
)
272 scm_array_handle_set (&h
, pos
, fill
);
274 /* Initialize the last element. */
275 scm_array_handle_set (&h
, pos
, fill
);
277 scm_array_handle_release (&h
);
282 scm_wrong_type_arg_msg (FUNC_NAME
, SCM_ARG1
, type
, "uniform vector type");
283 return SCM_BOOL_F
; /* not reached */
289 scm_init_srfi_4 (void)
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)
309 #include "libguile/srfi-4.x"
312 /* End of srfi-4.c. */