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 "libguile/_scm.h"
  27 #include "libguile/__scm.h"
  28
  29 #include "libguile/uniform.h"
  30
  31
  32 const size_t scm_i_array_element_type_sizes[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = {
  33   0,
  34   0,
  35   1,
  36   8,
  37   8, 8,
  38   16, 16,
  39   32, 32,
  40   64, 64,
  41   32, 64,
  42   64, 128
  43 };
  44
  45 size_t
  46 scm_array_handle_uniform_element_size (scm_t_array_handle *h)
  47 {
  48   size_t ret = scm_i_array_element_type_sizes[h->element_type];
  49   if (ret && ret % 8 == 0)
  50     return ret / 8;
  51   else if (ret)
  52     scm_wrong_type_arg_msg (NULL, 0, h->array, "byte-aligned uniform array");
  53   else
  54     scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
  55 }
  56
  57 size_t
  58 scm_array_handle_uniform_element_bit_size (scm_t_array_handle *h)
  59 {
  60   size_t ret = scm_i_array_element_type_sizes[h->element_type];
  61   if (ret)
  62     return ret;
  63   else
  64     scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
  65 }
  66
  67 const void *
  68 scm_array_handle_uniform_elements (scm_t_array_handle *h)
  69 {
  70   return scm_array_handle_uniform_writable_elements (h);
  71 }
  72
  73 void *
  74 scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
  75 {
  76   size_t esize;
  77   scm_t_uint8 *ret;
  78
  79   esize = scm_array_handle_uniform_element_size (h);
  80   ret = ((scm_t_uint8*) h->writable_elements) + h->base * esize;
  81   return ret;
  82 }
  83
  84 int
  85 scm_is_uniform_vector (SCM obj)
  86 {
  87   scm_t_array_handle h;
  88   int ret = 0;
  89
  90   if (scm_is_generalized_vector (obj))
  91     {
  92       scm_generalized_vector_get_handle (obj, &h);
  93       ret = SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED (h.element_type);
  94       scm_array_handle_release (&h);
  95     }
  96   return ret;
  97 }
  98
  99 size_t
 100 scm_c_uniform_vector_length (SCM uvec)
 101 {
 102   scm_t_array_handle h;
 103   size_t len;
 104   ssize_t inc;
 105
 106   scm_uniform_vector_elements (uvec, &h, &len, &inc);
 107   scm_array_handle_release (&h);
 108   return len;
 109 }
 110
 111 SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
 112             (SCM obj),
 113             "Return @code{#t} if @var{obj} is a uniform vector.")
 114 #define FUNC_NAME s_scm_uniform_vector_p
 115 {
 116   return scm_from_bool (scm_is_uniform_vector (obj));
 117 }
 118 #undef FUNC_NAME
 119
 120 SCM_DEFINE (scm_uniform_vector_element_type, "uniform-vector-element-type", 1, 0, 0,
 121             (SCM v),
 122             "Return the type of the elements in the uniform vector, @var{v}.")
 123 #define FUNC_NAME s_scm_uniform_vector_element_type
 124 {
 125   scm_t_array_handle h;
 126   SCM ret;
 127
 128   if (!scm_is_uniform_vector (v))
 129     scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, v, "uniform vector");
 130   scm_array_get_handle (v, &h);
 131   ret = scm_array_handle_element_type (&h);
 132   scm_array_handle_release (&h);
 133   return ret;
 134 }
 135 #undef FUNC_NAME
 136
 137 SCM_DEFINE (scm_uniform_vector_element_size, "uniform-vector-element-size", 1, 0, 0,
 138             (SCM v),
 139             "Return the number of bytes allocated to each element in the\n"
 140             "uniform vector, @var{v}.")
 141 #define FUNC_NAME s_scm_uniform_vector_element_size
 142 {
 143   scm_t_array_handle h;
 144   size_t len;
 145   ssize_t inc;
 146   SCM ret;
 147   scm_uniform_vector_elements (v, &h, &len, &inc);
 148   ret = scm_from_size_t (scm_array_handle_uniform_element_size (&h));
 149   scm_array_handle_release (&h);
 150   return ret;
 151 }
 152 #undef FUNC_NAME
 153
 154 SCM
 155 scm_c_uniform_vector_ref (SCM v, size_t idx)
 156 {
 157   if (!scm_is_uniform_vector (v))
 158     scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
 159   return scm_c_generalized_vector_ref (v, idx);
 160 }
 161
 162 SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
 163             (SCM v, SCM idx),
 164             "Return the element at index @var{idx} of the\n"
 165             "homogenous numeric vector @var{v}.")
 166 #define FUNC_NAME s_scm_uniform_vector_ref
 167 {
 168   return scm_c_uniform_vector_ref (v, scm_to_size_t (idx));
 169 }
 170 #undef FUNC_NAME
 171
 172 void
 173 scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
 174 {
 175   if (!scm_is_uniform_vector (v))
 176     scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
 177   scm_c_generalized_vector_set_x (v, idx, val);
 178 }
 179
 180 SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0,
 181             (SCM v, SCM idx, SCM val),
 182             "Set the element at index @var{idx} of the\n"
 183             "homogenous numeric vector @var{v} to @var{val}.")
 184 #define FUNC_NAME s_scm_uniform_vector_set_x
 185 {
 186   scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val);
 187   return SCM_UNSPECIFIED;
 188 }
 189 #undef FUNC_NAME
 190
 191 SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
 192             (SCM uvec),
 193             "Convert the uniform numeric vector @var{uvec} to a list.")
 194 #define FUNC_NAME s_scm_uniform_vector_to_list
 195 {
 196   if (!scm_is_uniform_vector (uvec))
 197     scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, uvec, "uniform vector");
 198   return scm_generalized_vector_to_list (uvec);
 199 }
 200 #undef FUNC_NAME
 201
 202 const void *
 203 scm_uniform_vector_elements (SCM uvec,
 204                              scm_t_array_handle *h,
 205                              size_t *lenp, ssize_t *incp)
 206 {
 207   return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
 208 }
 209
 210 void *
 211 scm_uniform_vector_writable_elements (SCM uvec,
 212                                       scm_t_array_handle *h,
 213                                       size_t *lenp, ssize_t *incp)
 214 {
 215   void *ret;
 216   scm_generalized_vector_get_handle (uvec, h);
 217   /* FIXME nonlocal exit */
 218   ret = scm_array_handle_uniform_writable_elements (h);
 219   if (lenp)
 220     {
 221       scm_t_array_dim *dim = scm_array_handle_dims (h);
 222       *lenp = dim->ubnd - dim->lbnd + 1;
 223       *incp = dim->inc;
 224     }
 225   return ret;
 226 }
 227
 228 SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
 229             (SCM v),
 230             "Return the number of elements in the uniform vector @var{v}.")
 231 #define FUNC_NAME s_scm_uniform_vector_length
 232 {
 233   return scm_from_size_t (scm_c_uniform_vector_length (v));
 234 }
 235 #undef FUNC_NAME
 236
 237
 238 void
 239 scm_init_uniform (void)
 240 {
 241 #include "libguile/uniform.x"
 242 }
 243
 244 /*
 245   Local Variables:
 246   c-file-style: "gnu"
 247   End:
 248 */