libguile/array-handle.c

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