libguile/array-handle.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005,
   2  * 2006, 2009, 2011, 2013, 2014 Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20
  21 \f
  22
  23 #ifdef HAVE_CONFIG_H
  24 #  include <config.h>
  25 #endif
  26
  27 #include "libguile/_scm.h"
  28 #include "libguile/__scm.h"
  29
  30 #include "libguile/array-handle.h"
  31
  32
  33 SCM scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_LAST + 1];
  34
  35
  36 #define ARRAY_IMPLS_N_STATIC_ALLOC 7
  37 static scm_t_array_implementation array_impls[ARRAY_IMPLS_N_STATIC_ALLOC];
  38 static int num_array_impls_registered = 0;
  39
  40
  41 void
  42 scm_i_register_array_implementation (scm_t_array_implementation *impl)
  43 {
  44   if (num_array_impls_registered >= ARRAY_IMPLS_N_STATIC_ALLOC)
  45     /* need to increase ARRAY_IMPLS_N_STATIC_ALLOC, buster */
  46     abort ();
  47   else
  48     array_impls[num_array_impls_registered++] = *impl;
  49 }
  50
  51 scm_t_array_implementation*
  52 scm_i_array_implementation_for_obj (SCM obj)
  53 {
  54   int i;
  55   for (i = 0; i < num_array_impls_registered; i++)
  56     if (SCM_NIMP (obj)
  57         && (SCM_CELL_TYPE (obj) & array_impls[i].mask) == array_impls[i].tag)
  58       return &array_impls[i];
  59   return NULL;
  60 }
  61
  62 void
  63 scm_array_get_handle (SCM array, scm_t_array_handle *h)
  64 {
  65   scm_t_array_implementation *impl = scm_i_array_implementation_for_obj (array);
  66   if (!impl)
  67     scm_wrong_type_arg_msg (NULL, 0, array, "array");
  68   h->array = array;
  69   h->base = 0;
  70   h->ndims = 0;
  71   h->dims = NULL;
  72   h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM; /* have to default to
  73                                                    something... */
  74   h->elements = NULL;
  75   h->writable_elements = NULL;
  76   h->vref = impl->vref;
  77   h->vset = impl->vset;
  78   h->vector = SCM_I_ARRAYP (array) ? SCM_I_ARRAY_V (array) : array;
  79   impl->get_handle (array, h);
  80 }
  81
  82 ssize_t
  83 scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
  84 {
  85   scm_t_array_dim *s = scm_array_handle_dims (h);
  86   ssize_t pos = 0, i;
  87   size_t k = scm_array_handle_rank (h);
  88
  89   while (k > 0 && scm_is_pair (indices))
  90     {
  91       i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd);
  92       pos += (i - s->lbnd) * s->inc;
  93       k--;
  94       s++;
  95       indices = SCM_CDR (indices);
  96     }
  97   if (k > 0 || !scm_is_null (indices))
  98     scm_misc_error (NULL, "wrong number of indices, expecting ~a",
  99                     scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
 100   return pos;
 101 }
 102
 103 static void
 104 check_array_index_bounds (scm_t_array_dim *dim, ssize_t idx)
 105 {
 106   if (idx < dim->lbnd || idx > dim->ubnd)
 107     scm_error (scm_out_of_range_key, NULL, "Value out of range ~S to ~S: ~S",
 108                scm_list_3 (scm_from_ssize_t (dim->lbnd),
 109                            scm_from_ssize_t (dim->ubnd),
 110                            scm_from_ssize_t (idx)),
 111                scm_list_1 (scm_from_ssize_t (idx)));
 112 }
 113
 114 ssize_t
 115 scm_array_handle_pos_1 (scm_t_array_handle *h, ssize_t idx0)
 116 {
 117   scm_t_array_dim *dim = scm_array_handle_dims (h);
 118
 119   if (scm_array_handle_rank (h) != 1)
 120     scm_misc_error (NULL, "wrong number of indices, expecting ~A",
 121                     scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
 122
 123   check_array_index_bounds (&dim[0], idx0);
 124
 125   return (idx0 - dim[0].lbnd) * dim[0].inc;
 126 }
 127
 128 ssize_t
 129 scm_array_handle_pos_2 (scm_t_array_handle *h, ssize_t idx0, ssize_t idx1)
 130 {
 131   scm_t_array_dim *dim = scm_array_handle_dims (h);
 132
 133   if (scm_array_handle_rank (h) != 2)
 134     scm_misc_error (NULL, "wrong number of indices, expecting ~A",
 135                     scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
 136
 137   check_array_index_bounds (&dim[0], idx0);
 138   check_array_index_bounds (&dim[1], idx1);
 139
 140   return ((idx0 - dim[0].lbnd) * dim[0].inc
 141           + (idx1 - dim[1].lbnd) * dim[1].inc);
 142 }
 143
 144 SCM
 145 scm_array_handle_element_type (scm_t_array_handle *h)
 146 {
 147   if (h->element_type < 0 || h->element_type > SCM_ARRAY_ELEMENT_TYPE_LAST)
 148     abort (); /* guile programming error */
 149   return scm_i_array_element_types[h->element_type];
 150 }
 151
 152 void
 153 scm_array_handle_release (scm_t_array_handle *h)
 154 {
 155   /* Nothing to do here until arrays need to be reserved for real.
 156    */
 157 }
 158
 159 const SCM *
 160 scm_array_handle_elements (scm_t_array_handle *h)
 161 {
 162   if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
 163     scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
 164   return ((const SCM*)h->elements) + h->base;
 165 }
 166
 167 SCM *
 168 scm_array_handle_writable_elements (scm_t_array_handle *h)
 169 {
 170   if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
 171     scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
 172   return ((SCM*)h->elements) + h->base;
 173 }
 174
 175 void
 176 scm_init_array_handle (void)
 177 {
 178 #define DEFINE_ARRAY_TYPE(tag, TAG)                             \
 179   scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] = scm_from_utf8_symbol (#tag)
 180
 181   scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T;
 182   DEFINE_ARRAY_TYPE (a, CHAR);
 183   DEFINE_ARRAY_TYPE (b, BIT);
 184   DEFINE_ARRAY_TYPE (vu8, VU8);
 185   DEFINE_ARRAY_TYPE (u8, U8);
 186   DEFINE_ARRAY_TYPE (s8, S8);
 187   DEFINE_ARRAY_TYPE (u16, U16);
 188   DEFINE_ARRAY_TYPE (s16, S16);
 189   DEFINE_ARRAY_TYPE (u32, U32);
 190   DEFINE_ARRAY_TYPE (s32, S32);
 191   DEFINE_ARRAY_TYPE (u64, U64);
 192   DEFINE_ARRAY_TYPE (s64, S64);
 193   DEFINE_ARRAY_TYPE (f32, F32);
 194   DEFINE_ARRAY_TYPE (f64, F64);
 195   DEFINE_ARRAY_TYPE (c32, C32);
 196   DEFINE_ARRAY_TYPE (c64, C64);
 197
 198 #include "libguile/array-handle.x"
 199 }
 200
 201 /*
 202   Local Variables:
 203   c-file-style: "gnu"
 204   End:
 205 */