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