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