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