| 1 | /* srfi-4.c --- Uniform numeric vector datatypes. |
| 2 | * |
| 3 | * Copyright (C) 2001, 2004, 2006, 2009, 2010, 2011, 2014 Free Software Foundation, Inc. |
| 4 | * |
| 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. |
| 9 | * |
| 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. |
| 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 |
| 17 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
| 18 | * 02110-1301 USA |
| 19 | */ |
| 20 | |
| 21 | #ifdef HAVE_CONFIG_H |
| 22 | # include <config.h> |
| 23 | #endif |
| 24 | |
| 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/validate.h" |
| 35 | |
| 36 | |
| 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); \ |
| 44 | } |
| 45 | |
| 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 | } |
| 54 | |
| 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 | } |
| 66 | |
| 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 | } |
| 75 | |
| 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 | } |
| 84 | |
| 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"); \ |
| 107 | |
| 108 | |
| 109 | #define ETYPE(TAG) \ |
| 110 | SCM_ARRAY_ELEMENT_TYPE_##TAG |
| 111 | |
| 112 | #define DEFINE_SRFI_4_C_FUNCS(TAG, tag, ctype, width) \ |
| 113 | SCM scm_take_##tag##vector (ctype *data, size_t n) \ |
| 114 | { \ |
| 115 | return scm_c_take_typed_bytevector ((scm_t_int8*)data, n, ETYPE (TAG), \ |
| 116 | SCM_BOOL_F); \ |
| 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"); \ |
| 122 | return ((const ctype*) h->elements) + h->base*width; \ |
| 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"); \ |
| 128 | return ((ctype*) h->writable_elements) + h->base*width; \ |
| 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 | size_t byte_width = width * sizeof (ctype); \ |
| 141 | if (!scm_is_bytevector (uvec) \ |
| 142 | || (scm_c_bytevector_length (uvec) % byte_width)) \ |
| 143 | scm_wrong_type_arg_msg (NULL, 0, uvec, #tag "vector"); \ |
| 144 | scm_array_get_handle (uvec, h); \ |
| 145 | if (lenp) \ |
| 146 | *lenp = scm_c_bytevector_length (uvec) / byte_width; \ |
| 147 | if (incp) \ |
| 148 | *incp = 1; \ |
| 149 | return ((ctype *)h->writable_elements); \ |
| 150 | } |
| 151 | |
| 152 | |
| 153 | #define MOD "srfi srfi-4" |
| 154 | |
| 155 | DEFINE_SRFI_4_PROXIES (u8); |
| 156 | DEFINE_SRFI_4_C_FUNCS (U8, u8, scm_t_uint8, 1); |
| 157 | |
| 158 | DEFINE_SRFI_4_PROXIES (s8); |
| 159 | DEFINE_SRFI_4_C_FUNCS (S8, s8, scm_t_int8, 1); |
| 160 | |
| 161 | DEFINE_SRFI_4_PROXIES (u16); |
| 162 | DEFINE_SRFI_4_C_FUNCS (U16, u16, scm_t_uint16, 1); |
| 163 | |
| 164 | DEFINE_SRFI_4_PROXIES (s16); |
| 165 | DEFINE_SRFI_4_C_FUNCS (S16, s16, scm_t_int16, 1); |
| 166 | |
| 167 | DEFINE_SRFI_4_PROXIES (u32); |
| 168 | DEFINE_SRFI_4_C_FUNCS (U32, u32, scm_t_uint32, 1); |
| 169 | |
| 170 | DEFINE_SRFI_4_PROXIES (s32); |
| 171 | DEFINE_SRFI_4_C_FUNCS (S32, s32, scm_t_int32, 1); |
| 172 | |
| 173 | DEFINE_SRFI_4_PROXIES (u64); |
| 174 | DEFINE_SRFI_4_C_FUNCS (U64, u64, scm_t_uint64, 1); |
| 175 | |
| 176 | DEFINE_SRFI_4_PROXIES (s64); |
| 177 | DEFINE_SRFI_4_C_FUNCS (S64, s64, scm_t_int64, 1); |
| 178 | |
| 179 | DEFINE_SRFI_4_PROXIES (f32); |
| 180 | DEFINE_SRFI_4_C_FUNCS (F32, f32, float, 1); |
| 181 | |
| 182 | DEFINE_SRFI_4_PROXIES (f64); |
| 183 | DEFINE_SRFI_4_C_FUNCS (F64, f64, double, 1); |
| 184 | |
| 185 | #undef MOD |
| 186 | #define MOD "srfi srfi-4 gnu" |
| 187 | |
| 188 | DEFINE_SRFI_4_PROXIES (c32); |
| 189 | DEFINE_SRFI_4_C_FUNCS (C32, c32, float, 2); |
| 190 | |
| 191 | DEFINE_SRFI_4_PROXIES (c64); |
| 192 | DEFINE_SRFI_4_C_FUNCS (C64, c64, double, 2); |
| 193 | |
| 194 | #define DEFINE_SRFI_4_GNU_PROXIES(tag) \ |
| 195 | DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector") |
| 196 | |
| 197 | #undef MOD |
| 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 | |
| 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 |
| 217 | { |
| 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])) |
| 223 | break; |
| 224 | if (c_type > SCM_ARRAY_ELEMENT_TYPE_LAST) |
| 225 | scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "vector type"); |
| 226 | switch (c_type) |
| 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 | { |
| 241 | SCM ret; |
| 242 | |
| 243 | c_len = scm_to_size_t (len); |
| 244 | ret = scm_i_make_typed_bytevector (c_len, c_type); |
| 245 | |
| 246 | if (SCM_UNBNDP (fill) || scm_is_eq (len, SCM_INUM0)) |
| 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; |
| 254 | size_t i; |
| 255 | |
| 256 | scm_array_get_handle (ret, &h); |
| 257 | for (i = 0; i < c_len; i++) |
| 258 | scm_array_handle_set (&h, i, fill); |
| 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 | } |
| 267 | } |
| 268 | #undef FUNC_NAME |
| 269 | |
| 270 | void |
| 271 | scm_init_srfi_4 (void) |
| 272 | { |
| 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 | |
| 291 | #include "libguile/srfi-4.x" |
| 292 | } |
| 293 | |
| 294 | /* End of srfi-4.c. */ |