libguile/array-handle.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005,
   2  * 2006, 2009, 2011, 2013 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->impl = impl;
  70   h->base = 0;
  71   h->ndims = 0;
  72   h->dims = NULL;
  73   h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM; /* have to default to
  74                                                    something... */
  75   h->elements = NULL;
  76   h->writable_elements = NULL;
  77   h->impl->get_handle (array, h);
  78 }
  79
  80 ssize_t
  81 scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
  82 {
  83   scm_t_array_dim *s = scm_array_handle_dims (h);
  84   ssize_t pos = 0, i;
  85   size_t k = scm_array_handle_rank (h);
  86
  87   while (k > 0 && scm_is_pair (indices))
  88     {
  89       i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd);
  90       pos += (i - s->lbnd) * s->inc;
  91       k--;
  92       s++;
  93       indices = SCM_CDR (indices);
  94     }
  95   if (k > 0 || !scm_is_null (indices))
  96     scm_misc_error (NULL, "wrong number of indices, expecting ~a",
  97                     scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
  98   return pos;
  99 }
 100
 101 static void
 102 check_array_index_bounds (scm_t_array_dim *dim, ssize_t idx)
 103 {
 104   if (idx < dim->lbnd || idx > dim->ubnd)
 105     scm_error (scm_out_of_range_key, NULL, "Value out of range ~S to ~S: ~S",
 106                scm_list_3 (scm_from_ssize_t (dim->lbnd),
 107                            scm_from_ssize_t (dim->ubnd),
 108                            scm_from_ssize_t (idx)),
 109                scm_list_1 (scm_from_ssize_t (idx)));
 110 }
 111
 112 ssize_t
 113 scm_array_handle_pos_1 (scm_t_array_handle *h, ssize_t idx0)
 114 {
 115   scm_t_array_dim *dim = scm_array_handle_dims (h);
 116
 117   if (scm_array_handle_rank (h) != 1)
 118     scm_misc_error (NULL, "wrong number of indices, expecting ~A",
 119                     scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
 120
 121   check_array_index_bounds (&dim[0], idx0);
 122
 123   return (idx0 - dim[0].lbnd) * dim[0].inc;
 124 }
 125
 126 ssize_t
 127 scm_array_handle_pos_2 (scm_t_array_handle *h, ssize_t idx0, ssize_t idx1)
 128 {
 129   scm_t_array_dim *dim = scm_array_handle_dims (h);
 130
 131   if (scm_array_handle_rank (h) != 2)
 132     scm_misc_error (NULL, "wrong number of indices, expecting ~A",
 133                     scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
 134
 135   check_array_index_bounds (&dim[0], idx0);
 136   check_array_index_bounds (&dim[1], idx1);
 137
 138   return ((idx0 - dim[0].lbnd) * dim[0].inc
 139           + (idx1 - dim[1].lbnd) * dim[1].inc);
 140 }
 141
 142 SCM
 143 scm_array_handle_element_type (scm_t_array_handle *h)
 144 {
 145   if (h->element_type < 0 || h->element_type > SCM_ARRAY_ELEMENT_TYPE_LAST)
 146     abort (); /* guile programming error */
 147   return scm_i_array_element_types[h->element_type];
 148 }
 149
 150 void
 151 scm_array_handle_release (scm_t_array_handle *h)
 152 {
 153   /* Nothing to do here until arrays need to be reserved for real.
 154    */
 155 }
 156
 157 const SCM *
 158 scm_array_handle_elements (scm_t_array_handle *h)
 159 {
 160   if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
 161     scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
 162   return ((const SCM*)h->elements) + h->base;
 163 }
 164
 165 SCM *
 166 scm_array_handle_writable_elements (scm_t_array_handle *h)
 167 {
 168   if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
 169     scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
 170   return ((SCM*)h->elements) + h->base;
 171 }
 172
 173 void
 174 scm_init_array_handle (void)
 175 {
 176 #define DEFINE_ARRAY_TYPE(tag, TAG)                             \
 177   scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] = scm_from_utf8_symbol (#tag)
 178
 179   scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T;
 180   DEFINE_ARRAY_TYPE (a, CHAR);
 181   DEFINE_ARRAY_TYPE (b, BIT);
 182   DEFINE_ARRAY_TYPE (vu8, VU8);
 183   DEFINE_ARRAY_TYPE (u8, U8);
 184   DEFINE_ARRAY_TYPE (s8, S8);
 185   DEFINE_ARRAY_TYPE (u16, U16);
 186   DEFINE_ARRAY_TYPE (s16, S16);
 187   DEFINE_ARRAY_TYPE (u32, U32);
 188   DEFINE_ARRAY_TYPE (s32, S32);
 189   DEFINE_ARRAY_TYPE (u64, U64);
 190   DEFINE_ARRAY_TYPE (s64, S64);
 191   DEFINE_ARRAY_TYPE (f32, F32);
 192   DEFINE_ARRAY_TYPE (f64, F64);
 193   DEFINE_ARRAY_TYPE (c32, C32);
 194   DEFINE_ARRAY_TYPE (c64, C64);
 195
 196 #include "libguile/array-handle.x"
 197 }
 198
 199 /*
 200   Local Variables:
 201   c-file-style: "gnu"
 202   End:
 203 */