libguile/srfi-4.c

   1 /* srfi-4.c --- Uniform numeric vector datatypes.
   2  *
   3  *      Copyright (C) 2001, 2004, 2006, 2009, 2010, 2011 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/generalized-vectors.h"
  35 #include "libguile/validate.h"
  36
  37
  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);                   \
  45   }
  46
  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   }
  55
  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   }
  67
  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   }
  76
  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   }
  85
  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");         \
 108
 109
 110 #define ETYPE(TAG) \
 111   SCM_ARRAY_ELEMENT_TYPE_##TAG
 112
 113 #define DEFINE_SRFI_4_C_FUNCS(TAG, tag, ctype, width)                   \
 114   SCM scm_take_##tag##vector (ctype *data, size_t n)                    \
 115   {                                                                     \
 116     return scm_c_take_typed_bytevector ((scm_t_int8*)data, n, ETYPE (TAG), \
 117                                         SCM_BOOL_F);                    \
 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");        \
 123     return ((const ctype*) h->elements) + h->base*width;                \
 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");        \
 129     return ((ctype*) h->writable_elements) + h->base*width;             \
 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))                                 \
 143       return ((ctype*)h->writable_elements) + h->base*width;            \
 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);                                  \
 165         return ((ctype*)h->writable_elements) + h->base*width;          \
 166       }                                                                 \
 167   }
 168
 169
 170 #define MOD "srfi srfi-4"
 171
 172 DEFINE_SRFI_4_PROXIES (u8);
 173 DEFINE_SRFI_4_C_FUNCS (U8, u8, scm_t_uint8, 1);
 174
 175 DEFINE_SRFI_4_PROXIES (s8);
 176 DEFINE_SRFI_4_C_FUNCS (S8, s8, scm_t_int8, 1);
 177
 178 DEFINE_SRFI_4_PROXIES (u16);
 179 DEFINE_SRFI_4_C_FUNCS (U16, u16, scm_t_uint16, 1);
 180
 181 DEFINE_SRFI_4_PROXIES (s16);
 182 DEFINE_SRFI_4_C_FUNCS (S16, s16, scm_t_int16, 1);
 183
 184 DEFINE_SRFI_4_PROXIES (u32);
 185 DEFINE_SRFI_4_C_FUNCS (U32, u32, scm_t_uint32, 1);
 186
 187 DEFINE_SRFI_4_PROXIES (s32);
 188 DEFINE_SRFI_4_C_FUNCS (S32, s32, scm_t_int32, 1);
 189
 190 DEFINE_SRFI_4_PROXIES (u64);
 191 DEFINE_SRFI_4_C_FUNCS (U64, u64, scm_t_uint64, 1);
 192
 193 DEFINE_SRFI_4_PROXIES (s64);
 194 DEFINE_SRFI_4_C_FUNCS (S64, s64, scm_t_int64, 1);
 195
 196 DEFINE_SRFI_4_PROXIES (f32);
 197 DEFINE_SRFI_4_C_FUNCS (F32, f32, float, 1);
 198
 199 DEFINE_SRFI_4_PROXIES (f64);
 200 DEFINE_SRFI_4_C_FUNCS (F64, f64, double, 1);
 201
 202 #undef MOD
 203 #define MOD "srfi srfi-4 gnu"
 204
 205 DEFINE_SRFI_4_PROXIES (c32);
 206 DEFINE_SRFI_4_C_FUNCS (C32, c32, float, 2);
 207
 208 DEFINE_SRFI_4_PROXIES (c64);
 209 DEFINE_SRFI_4_C_FUNCS (C64, c64, double, 2);
 210
 211 #define DEFINE_SRFI_4_GNU_PROXIES(tag)                              \
 212   DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector")
 213
 214 #undef MOD
 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);
 228
 229
 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
 234 {
 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);
 257
 258         if (SCM_UNBNDP (fill) || scm_is_eq (len, SCM_INUM0))
 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;
 268
 269             scm_uniform_vector_writable_elements (ret, &h, &len, &inc);
 270
 271             for (pos = 0; pos != h.dims[0].ubnd; pos += inc)
 272               scm_array_handle_set (&h, pos, fill);
 273
 274             /* Initialize the last element.  */
 275             scm_array_handle_set (&h, pos, fill);
 276
 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     }
 285 }
 286 #undef FUNC_NAME
 287
 288 void
 289 scm_init_srfi_4 (void)
 290 {
 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
 309 #include "libguile/srfi-4.x"
 310 }
 311
 312 /* End of srfi-4.c.  */