libguile/uniform.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19
  20 \f
  21
  22 #ifdef HAVE_CONFIG_H
  23 #  include <config.h>
  24 #endif
  25
  26 #include <assert.h>
  27
  28 #include "libguile/_scm.h"
  29 #include "libguile/__scm.h"
  30
  31 #include "libguile/uniform.h"
  32
  33
  34 const size_t scm_i_array_element_type_sizes[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = {
  35   0,
  36   0,
  37   1,
  38   8,
  39   8, 8,
  40   16, 16,
  41   32, 32,
  42   64, 64,
  43   32, 64,
  44   64, 128
  45 };
  46
  47 size_t
  48 scm_array_handle_uniform_element_size (scm_t_array_handle *h)
  49 {
  50   size_t ret = scm_i_array_element_type_sizes[h->element_type];
  51   if (ret && ret % 8 == 0)
  52     return ret / 8;
  53   else if (ret)
  54     scm_wrong_type_arg_msg (NULL, 0, h->array, "byte-aligned uniform array");
  55   else
  56     scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
  57 }
  58
  59 size_t
  60 scm_array_handle_uniform_element_bit_size (scm_t_array_handle *h)
  61 {
  62   size_t ret = scm_i_array_element_type_sizes[h->element_type];
  63   if (ret)
  64     return ret;
  65   else
  66     scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
  67 }
  68
  69 const void *
  70 scm_array_handle_uniform_elements (scm_t_array_handle *h)
  71 {
  72   return scm_array_handle_uniform_writable_elements (h);
  73 }
  74
  75 void *
  76 scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
  77 {
  78   size_t esize;
  79   scm_t_uint8 *ret;
  80
  81   esize = scm_array_handle_uniform_element_size (h);
  82   ret = ((scm_t_uint8*) h->writable_elements) + h->base * esize;
  83   return ret;
  84 }
  85
  86 int
  87 scm_is_uniform_vector (SCM obj)
  88 {
  89   scm_t_array_handle h;
  90   int ret = 0;
  91
  92   if (scm_is_generalized_vector (obj))
  93     {
  94       scm_generalized_vector_get_handle (obj, &h);
  95       ret = SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED (h.element_type);
  96       scm_array_handle_release (&h);
  97     }
  98   return ret;
  99 }
 100
 101 size_t
 102 scm_c_uniform_vector_length (SCM uvec)
 103 {
 104   scm_t_array_handle h;
 105   size_t len;
 106   ssize_t inc;
 107
 108   scm_uniform_vector_elements (uvec, &h, &len, &inc);
 109   scm_array_handle_release (&h);
 110   return len;
 111 }
 112
 113 SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
 114             (SCM obj),
 115             "Return @code{#t} if @var{obj} is a uniform vector.")
 116 #define FUNC_NAME s_scm_uniform_vector_p
 117 {
 118   return scm_from_bool (scm_is_uniform_vector (obj));
 119 }
 120 #undef FUNC_NAME
 121
 122 SCM_DEFINE (scm_uniform_vector_element_type, "uniform-vector-element-type", 1, 0, 0,
 123             (SCM v),
 124             "Return the type of the elements in the uniform vector, @var{v}.")
 125 #define FUNC_NAME s_scm_uniform_vector_element_type
 126 {
 127   scm_t_array_handle h;
 128   SCM ret;
 129
 130   if (!scm_is_uniform_vector (v))
 131     scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, v, "uniform vector");
 132   scm_array_get_handle (v, &h);
 133   ret = scm_array_handle_element_type (&h);
 134   scm_array_handle_release (&h);
 135   return ret;
 136 }
 137 #undef FUNC_NAME
 138
 139 SCM_DEFINE (scm_uniform_vector_element_size, "uniform-vector-element-size", 1, 0, 0,
 140             (SCM v),
 141             "Return the number of bytes allocated to each element in the\n"
 142             "uniform vector, @var{v}.")
 143 #define FUNC_NAME s_scm_uniform_vector_element_size
 144 {
 145   scm_t_array_handle h;
 146   size_t len;
 147   ssize_t inc;
 148   SCM ret;
 149   scm_uniform_vector_elements (v, &h, &len, &inc);
 150   ret = scm_from_size_t (scm_array_handle_uniform_element_size (&h));
 151   scm_array_handle_release (&h);
 152   return ret;
 153 }
 154 #undef FUNC_NAME
 155
 156 SCM
 157 scm_c_uniform_vector_ref (SCM v, size_t idx)
 158 {
 159   if (!scm_is_uniform_vector (v))
 160     scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
 161   return scm_c_generalized_vector_ref (v, idx);
 162 }
 163
 164 SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
 165             (SCM v, SCM idx),
 166             "Return the element at index @var{idx} of the\n"
 167             "homogenous numeric vector @var{v}.")
 168 #define FUNC_NAME s_scm_uniform_vector_ref
 169 {
 170   return scm_c_uniform_vector_ref (v, scm_to_size_t (idx));
 171 }
 172 #undef FUNC_NAME
 173
 174 void
 175 scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
 176 {
 177   if (!scm_is_uniform_vector (v))
 178     scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
 179   scm_c_generalized_vector_set_x (v, idx, val);
 180 }
 181
 182 SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0,
 183             (SCM v, SCM idx, SCM val),
 184             "Set the element at index @var{idx} of the\n"
 185             "homogenous numeric vector @var{v} to @var{val}.")
 186 #define FUNC_NAME s_scm_uniform_vector_set_x
 187 {
 188   scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val);
 189   return SCM_UNSPECIFIED;
 190 }
 191 #undef FUNC_NAME
 192
 193 SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
 194             (SCM uvec),
 195             "Convert the uniform numeric vector @var{uvec} to a list.")
 196 #define FUNC_NAME s_scm_uniform_vector_to_list
 197 {
 198   if (!scm_is_uniform_vector (uvec))
 199     scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, uvec, "uniform vector");
 200   return scm_generalized_vector_to_list (uvec);
 201 }
 202 #undef FUNC_NAME
 203
 204 const void *
 205 scm_uniform_vector_elements (SCM uvec,
 206                              scm_t_array_handle *h,
 207                              size_t *lenp, ssize_t *incp)
 208 {
 209   return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
 210 }
 211
 212 void *
 213 scm_uniform_vector_writable_elements (SCM uvec,
 214                                       scm_t_array_handle *h,
 215                                       size_t *lenp, ssize_t *incp)
 216 {
 217   void *ret;
 218   scm_generalized_vector_get_handle (uvec, h);
 219   /* FIXME nonlocal exit */
 220   ret = scm_array_handle_uniform_writable_elements (h);
 221   if (lenp)
 222     {
 223       scm_t_array_dim *dim = scm_array_handle_dims (h);
 224       *lenp = dim->ubnd - dim->lbnd + 1;
 225       *incp = dim->inc;
 226     }
 227   return ret;
 228 }
 229
 230 SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
 231             (SCM v),
 232             "Return the number of elements in the uniform vector @var{v}.")
 233 #define FUNC_NAME s_scm_uniform_vector_length
 234 {
 235   return scm_from_size_t (scm_c_uniform_vector_length (v));
 236 }
 237 #undef FUNC_NAME
 238
 239
 240 void
 241 scm_init_uniform (void)
 242 {
 243 #include "libguile/uniform.x"
 244 }
 245
 246 /*
 247   Local Variables:
 248   c-file-style: "gnu"
 249   End:
 250 */