libguile/srfi-4.c

   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.  */