libguile/uniform.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010 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   if (!scm_is_uniform_vector (uvec))
 103     scm_wrong_type_arg_msg ("uniform-vector-length", 1, uvec,
 104                             "uniform vector");
 105
 106   return scm_c_generalized_vector_length (uvec);
 107 }
 108
 109 SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
 110             (SCM obj),
 111             "Return @code{#t} if @var{obj} is a uniform vector.")
 112 #define FUNC_NAME s_scm_uniform_vector_p
 113 {
 114   return scm_from_bool (scm_is_uniform_vector (obj));
 115 }
 116 #undef FUNC_NAME
 117
 118 SCM_DEFINE (scm_uniform_vector_element_type, "uniform-vector-element-type", 1, 0, 0,
 119             (SCM v),
 120             "Return the type of the elements in the uniform vector, @var{v}.")
 121 #define FUNC_NAME s_scm_uniform_vector_element_type
 122 {
 123   scm_t_array_handle h;
 124   SCM ret;
 125
 126   if (!scm_is_uniform_vector (v))
 127     scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, v, "uniform vector");
 128   scm_array_get_handle (v, &h);
 129   ret = scm_array_handle_element_type (&h);
 130   scm_array_handle_release (&h);
 131   return ret;
 132 }
 133 #undef FUNC_NAME
 134
 135 SCM_DEFINE (scm_uniform_vector_element_size, "uniform-vector-element-size", 1, 0, 0,
 136             (SCM v),
 137             "Return the number of bytes allocated to each element in the\n"
 138             "uniform vector, @var{v}.")
 139 #define FUNC_NAME s_scm_uniform_vector_element_size
 140 {
 141   scm_t_array_handle h;
 142   size_t len;
 143   ssize_t inc;
 144   SCM ret;
 145   scm_uniform_vector_elements (v, &h, &len, &inc);
 146   ret = scm_from_size_t (scm_array_handle_uniform_element_size (&h));
 147   scm_array_handle_release (&h);
 148   return ret;
 149 }
 150 #undef FUNC_NAME
 151
 152 SCM
 153 scm_c_uniform_vector_ref (SCM v, size_t idx)
 154 {
 155   if (!scm_is_uniform_vector (v))
 156     scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
 157   return scm_c_generalized_vector_ref (v, idx);
 158 }
 159
 160 SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
 161             (SCM v, SCM idx),
 162             "Return the element at index @var{idx} of the\n"
 163             "homogeneous numeric vector @var{v}.")
 164 #define FUNC_NAME s_scm_uniform_vector_ref
 165 {
 166   return scm_c_uniform_vector_ref (v, scm_to_size_t (idx));
 167 }
 168 #undef FUNC_NAME
 169
 170 void
 171 scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
 172 {
 173   if (!scm_is_uniform_vector (v))
 174     scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
 175   scm_c_generalized_vector_set_x (v, idx, val);
 176 }
 177
 178 SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0,
 179             (SCM v, SCM idx, SCM val),
 180             "Set the element at index @var{idx} of the\n"
 181             "homogeneous numeric vector @var{v} to @var{val}.")
 182 #define FUNC_NAME s_scm_uniform_vector_set_x
 183 {
 184   scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val);
 185   return SCM_UNSPECIFIED;
 186 }
 187 #undef FUNC_NAME
 188
 189 SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
 190             (SCM uvec),
 191             "Convert the uniform numeric vector @var{uvec} to a list.")
 192 #define FUNC_NAME s_scm_uniform_vector_to_list
 193 {
 194   if (!scm_is_uniform_vector (uvec))
 195     scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, uvec, "uniform vector");
 196   return scm_generalized_vector_to_list (uvec);
 197 }
 198 #undef FUNC_NAME
 199
 200 const void *
 201 scm_uniform_vector_elements (SCM uvec,
 202                              scm_t_array_handle *h,
 203                              size_t *lenp, ssize_t *incp)
 204 {
 205   return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
 206 }
 207
 208 void *
 209 scm_uniform_vector_writable_elements (SCM uvec,
 210                                       scm_t_array_handle *h,
 211                                       size_t *lenp, ssize_t *incp)
 212 {
 213   void *ret;
 214   scm_generalized_vector_get_handle (uvec, h);
 215   /* FIXME nonlocal exit */
 216   ret = scm_array_handle_uniform_writable_elements (h);
 217   if (lenp)
 218     {
 219       scm_t_array_dim *dim = scm_array_handle_dims (h);
 220       *lenp = dim->ubnd - dim->lbnd + 1;
 221       *incp = dim->inc;
 222     }
 223   return ret;
 224 }
 225
 226 SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
 227             (SCM v),
 228             "Return the number of elements in the uniform vector @var{v}.")
 229 #define FUNC_NAME s_scm_uniform_vector_length
 230 {
 231   return scm_from_size_t (scm_c_uniform_vector_length (v));
 232 }
 233 #undef FUNC_NAME
 234
 235
 236 void
 237 scm_init_uniform (void)
 238 {
 239 #include "libguile/uniform.x"
 240 }
 241
 242 /*
 243   Local Variables:
 244   c-file-style: "gnu"
 245   End:
 246 */