libguile/array-handle.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/array-handle.h"
  30 #include "libguile/unif.h"
  31 #include "libguile/strings.h"
  32 #include "libguile/vectors.h"
  33 #include "libguile/srfi-4.h"
  34 #include "libguile/bitvectors.h"
  35 #include "libguile/bytevectors.h"
  36
  37
  38 static SCM
  39 enclosed_ref (scm_t_array_handle *h, ssize_t pos)
  40 {
  41   return scm_i_cvref (SCM_I_ARRAY_V (h->array), pos + h->base, 1);
  42 }
  43
  44 static SCM
  45 vector_ref (scm_t_array_handle *h, ssize_t pos)
  46 {
  47   return ((const SCM *)h->elements)[pos];
  48 }
  49
  50 static SCM
  51 string_ref (scm_t_array_handle *h, ssize_t pos)
  52 {
  53   pos += h->base;
  54   if (SCM_I_ARRAYP (h->array))
  55     return scm_c_string_ref (SCM_I_ARRAY_V (h->array), pos);
  56   else
  57     return scm_c_string_ref (h->array, pos);
  58 }
  59
  60 static SCM
  61 bitvector_ref (scm_t_array_handle *h, ssize_t pos)
  62 {
  63   pos += scm_array_handle_bit_elements_offset (h);
  64   return
  65     scm_from_bool (((scm_t_uint32 *)h->elements)[pos/32] & (1l << (pos % 32)));
  66 }
  67
  68 static SCM
  69 bytevector_ref (scm_t_array_handle *h, ssize_t pos)
  70 {
  71   return scm_from_uint8 (((scm_t_uint8 *) h->elements)[pos]);
  72 }
  73
  74 static SCM
  75 memoize_ref (scm_t_array_handle *h, ssize_t pos)
  76 {
  77   SCM v = h->array;
  78
  79   if (SCM_I_ENCLOSED_ARRAYP (v))
  80     {
  81       h->ref = enclosed_ref;
  82       return enclosed_ref (h, pos);
  83     }
  84
  85   if (SCM_I_ARRAYP (v))
  86     v = SCM_I_ARRAY_V (v);
  87
  88   if (scm_is_vector (v))
  89     {
  90       h->elements = scm_array_handle_elements (h);
  91       h->ref = vector_ref;
  92     }
  93   else if (scm_is_uniform_vector (v))
  94     {
  95       h->elements = scm_array_handle_uniform_elements (h);
  96       h->ref = scm_i_uniform_vector_ref_proc (v);
  97     }
  98   else if (scm_is_string (v))
  99     {
 100       h->ref = string_ref;
 101     }
 102   else if (scm_is_bitvector (v))
 103     {
 104       h->elements = scm_array_handle_bit_elements (h);
 105       h->ref = bitvector_ref;
 106     }
 107   else if (scm_is_bytevector (v))
 108     {
 109       h->elements = scm_array_handle_uniform_elements (h);
 110       h->ref = bytevector_ref;
 111     }
 112   else
 113     scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
 114
 115   return h->ref (h, pos);
 116 }
 117
 118 static void
 119 enclosed_set (scm_t_array_handle *h, ssize_t pos, SCM val)
 120 {
 121   scm_wrong_type_arg_msg (NULL, 0, h->array, "non-enclosed array");
 122 }
 123
 124 static void
 125 vector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
 126 {
 127   ((SCM *)h->writable_elements)[pos] = val;
 128 }
 129
 130 static void
 131 string_set (scm_t_array_handle *h, ssize_t pos, SCM val)
 132 {
 133   pos += h->base;
 134   if (SCM_I_ARRAYP (h->array))
 135     scm_c_string_set_x (SCM_I_ARRAY_V (h->array), pos, val);
 136   else
 137     scm_c_string_set_x (h->array, pos, val);
 138 }
 139
 140 static void
 141 bitvector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
 142 {
 143   scm_t_uint32 mask;
 144   pos += scm_array_handle_bit_elements_offset (h);
 145   mask = 1l << (pos % 32);
 146   if (scm_to_bool (val))
 147     ((scm_t_uint32 *)h->writable_elements)[pos/32] |= mask;
 148   else
 149     ((scm_t_uint32 *)h->writable_elements)[pos/32] &= ~mask;
 150 }
 151
 152 static void
 153 bytevector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
 154 {
 155   scm_t_uint8 c_value;
 156   scm_t_uint8 *elements;
 157
 158   c_value = scm_to_uint8 (val);
 159   elements = (scm_t_uint8 *) h->elements;
 160   elements[pos] = (scm_t_uint8) c_value;
 161 }
 162
 163 static void
 164 memoize_set (scm_t_array_handle *h, ssize_t pos, SCM val)
 165 {
 166   SCM v = h->array;
 167
 168   if (SCM_I_ENCLOSED_ARRAYP (v))
 169     {
 170       h->set = enclosed_set;
 171       enclosed_set (h, pos, val);
 172       return;
 173     }
 174
 175   if (SCM_I_ARRAYP (v))
 176     v = SCM_I_ARRAY_V (v);
 177
 178   if (scm_is_vector (v))
 179     {
 180       h->writable_elements = scm_array_handle_writable_elements (h);
 181       h->set = vector_set;
 182     }
 183   else if (scm_is_uniform_vector (v))
 184     {
 185       h->writable_elements = scm_array_handle_uniform_writable_elements (h);
 186       h->set = scm_i_uniform_vector_set_proc (v);
 187     }
 188   else if (scm_is_string (v))
 189     {
 190       h->set = string_set;
 191     }
 192   else if (scm_is_bitvector (v))
 193     {
 194       h->writable_elements = scm_array_handle_bit_writable_elements (h);
 195       h->set = bitvector_set;
 196     }
 197   else if (scm_is_bytevector (v))
 198     {
 199       h->elements = scm_array_handle_uniform_writable_elements (h);
 200       h->set = bytevector_set;
 201     }
 202   else
 203     scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
 204
 205   h->set (h, pos, val);
 206 }
 207
 208 void
 209 scm_array_get_handle (SCM array, scm_t_array_handle *h)
 210 {
 211   h->array = array;
 212   h->ref = memoize_ref;
 213   h->set = memoize_set;
 214
 215   if (SCM_I_ARRAYP (array) || SCM_I_ENCLOSED_ARRAYP (array))
 216     {
 217       h->dims = SCM_I_ARRAY_DIMS (array);
 218       h->base = SCM_I_ARRAY_BASE (array);
 219     }
 220   else if (scm_is_generalized_vector (array))
 221     {
 222       h->dim0.lbnd = 0;
 223       h->dim0.ubnd = scm_c_generalized_vector_length (array) - 1;
 224       h->dim0.inc = 1;
 225       h->dims = &h->dim0;
 226       h->base = 0;
 227     }
 228   else
 229     scm_wrong_type_arg_msg (NULL, 0, array, "array");
 230 }
 231
 232 void
 233 scm_array_handle_release (scm_t_array_handle *h)
 234 {
 235   /* Nothing to do here until arrays need to be reserved for real.
 236    */
 237 }
 238
 239 size_t
 240 scm_array_handle_rank (scm_t_array_handle *h)
 241 {
 242   if (SCM_I_ARRAYP (h->array) || SCM_I_ENCLOSED_ARRAYP (h->array))
 243     return SCM_I_ARRAY_NDIM (h->array);
 244   else
 245     return 1;
 246 }
 247
 248 scm_t_array_dim *
 249 scm_array_handle_dims (scm_t_array_handle *h)
 250 {
 251   return h->dims;
 252 }
 253
 254 const SCM *
 255 scm_array_handle_elements (scm_t_array_handle *h)
 256 {
 257   SCM vec = h->array;
 258   if (SCM_I_ARRAYP (vec))
 259     vec = SCM_I_ARRAY_V (vec);
 260   if (SCM_I_IS_VECTOR (vec))
 261     return SCM_I_VECTOR_ELTS (vec) + h->base;
 262   scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
 263 }
 264
 265 SCM *
 266 scm_array_handle_writable_elements (scm_t_array_handle *h)
 267 {
 268   SCM vec = h->array;
 269   if (SCM_I_ARRAYP (vec))
 270     vec = SCM_I_ARRAY_V (vec);
 271   if (SCM_I_IS_VECTOR (vec))
 272     return SCM_I_VECTOR_WELTS (vec) + h->base;
 273   scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
 274 }
 275
 276
 277 void
 278 scm_init_array_handle (void)
 279 {
 280 #include "libguile/array-handle.x"
 281 }
 282
 283 /*
 284   Local Variables:
 285   c-file-style: "gnu"
 286   End:
 287 */