libguile/generalized-arrays.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 <stdio.h>
  27 #include <errno.h>
  28 #include <string.h>
  29
  30 #include "libguile/_scm.h"
  31 #include "libguile/__scm.h"
  32 #include "libguile/array-handle.h"
  33 #include "libguile/generalized-arrays.h"
  34
  35
  36 int
  37 scm_is_array (SCM obj)
  38 {
  39   return scm_i_array_implementation_for_obj (obj) ? 1 : 0;
  40 }
  41
  42 SCM_DEFINE (scm_array_p, "array?", 1, 0, 0,
  43            (SCM obj),
  44             "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
  45             "not.")
  46 #define FUNC_NAME s_scm_array_p
  47 {
  48   return scm_from_bool (scm_is_array (obj));
  49 }
  50 #undef FUNC_NAME
  51
  52 int
  53 scm_is_typed_array (SCM obj, SCM type)
  54 {
  55   int ret = 0;
  56   if (scm_i_array_implementation_for_obj (obj))
  57     {
  58       scm_t_array_handle h;
  59
  60       scm_array_get_handle (obj, &h);
  61       ret = scm_is_eq (scm_array_handle_element_type (&h), type);
  62       scm_array_handle_release (&h);
  63     }
  64
  65   return ret;
  66 }
  67
  68 SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
  69            (SCM obj, SCM type),
  70             "Return @code{#t} if the @var{obj} is an array of type\n"
  71             "@var{type}, and @code{#f} if not.")
  72 #define FUNC_NAME s_scm_typed_array_p
  73 {
  74   return scm_from_bool (scm_is_typed_array (obj, type));
  75 }
  76 #undef FUNC_NAME
  77
  78 size_t
  79 scm_c_array_rank (SCM array)
  80 {
  81   scm_t_array_handle handle;
  82   size_t res;
  83
  84   scm_array_get_handle (array, &handle);
  85   res = scm_array_handle_rank (&handle);
  86   scm_array_handle_release (&handle);
  87   return res;
  88 }
  89
  90 SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
  91            (SCM array),
  92             "Return the number of dimensions of the array @var{array.}\n")
  93 #define FUNC_NAME s_scm_array_rank
  94 {
  95   return scm_from_size_t (scm_c_array_rank (array));
  96 }
  97 #undef FUNC_NAME
  98
  99
 100 SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
 101            (SCM ra),
 102             "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
 103             "elements with a @code{0} minimum with one greater than the maximum. So:\n"
 104             "@lisp\n"
 105             "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
 106             "@end lisp")
 107 #define FUNC_NAME s_scm_array_dimensions
 108 {
 109   scm_t_array_handle handle;
 110   scm_t_array_dim *s;
 111   SCM res = SCM_EOL;
 112   size_t k;
 113
 114   scm_array_get_handle (ra, &handle);
 115   s = scm_array_handle_dims (&handle);
 116   k = scm_array_handle_rank (&handle);
 117
 118   while (k--)
 119     res = scm_cons (s[k].lbnd
 120                     ? scm_cons2 (scm_from_ssize_t (s[k].lbnd),
 121                                  scm_from_ssize_t (s[k].ubnd),
 122                                  SCM_EOL)
 123                     : scm_from_ssize_t (1 + s[k].ubnd),
 124                     res);
 125
 126   scm_array_handle_release (&handle);
 127   return res;
 128 }
 129 #undef FUNC_NAME
 130
 131 /* HACK*/
 132 #include "libguile/bytevectors.h"
 133
 134 SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
 135            (SCM ra),
 136             "")
 137 #define FUNC_NAME s_scm_array_type
 138 {
 139   scm_t_array_handle h;
 140   SCM type;
 141
 142   /* a hack, until srfi-4 and bytevectors are reunited */
 143   if (scm_is_bytevector (ra))
 144     return scm_from_locale_symbol ("vu8");
 145
 146   scm_array_get_handle (ra, &h);
 147   type = scm_array_handle_element_type (&h);
 148   scm_array_handle_release (&h);
 149
 150   return type;
 151 }
 152 #undef FUNC_NAME
 153
 154 SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
 155            (SCM ra, SCM args),
 156             "Return @code{#t} if its arguments would be acceptable to\n"
 157             "@code{array-ref}.")
 158 #define FUNC_NAME s_scm_array_in_bounds_p
 159 {
 160   SCM res = SCM_BOOL_T;
 161   size_t k, ndim;
 162   scm_t_array_dim *s;
 163   scm_t_array_handle handle;
 164
 165   SCM_VALIDATE_REST_ARGUMENT (args);
 166
 167   scm_array_get_handle (ra, &handle);
 168   s = scm_array_handle_dims (&handle);
 169   ndim = scm_array_handle_rank (&handle);
 170
 171   for (k = 0; k < ndim; k++)
 172     {
 173       long ind;
 174
 175       if (!scm_is_pair (args))
 176         SCM_WRONG_NUM_ARGS ();
 177       ind = scm_to_long (SCM_CAR (args));
 178       args = SCM_CDR (args);
 179
 180       if (ind < s[k].lbnd || ind > s[k].ubnd)
 181         {
 182           res = SCM_BOOL_F;
 183           /* We do not stop the checking after finding a violation
 184              since we want to validate the type-correctness and
 185              number of arguments in any case.
 186           */
 187         }
 188     }
 189
 190   scm_array_handle_release (&handle);
 191   return res;
 192 }
 193 #undef FUNC_NAME
 194
 195 SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
 196            (SCM v, SCM args),
 197             "Return the element at the @code{(index1, index2)} element in\n"
 198             "@var{array}.")
 199 #define FUNC_NAME s_scm_array_ref
 200 {
 201   scm_t_array_handle handle;
 202   SCM res;
 203
 204   scm_array_get_handle (v, &handle);
 205   res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args));
 206   scm_array_handle_release (&handle);
 207   return res;
 208 }
 209 #undef FUNC_NAME
 210
 211
 212 SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
 213            (SCM v, SCM obj, SCM args),
 214             "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
 215             "@var{new-value}.  The value returned by array-set! is unspecified.")
 216 #define FUNC_NAME s_scm_array_set_x
 217 {
 218   scm_t_array_handle handle;
 219
 220   scm_array_get_handle (v, &handle);
 221   scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj);
 222   scm_array_handle_release (&handle);
 223   return SCM_UNSPECIFIED;
 224 }
 225 #undef FUNC_NAME
 226
 227 static SCM
 228 array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos)
 229 {
 230   if (dim == scm_array_handle_rank (h))
 231     return scm_array_handle_ref (h, pos);
 232   else
 233     {
 234       SCM res = SCM_EOL;
 235       long inc;
 236       size_t i, lbnd;
 237
 238       i = h->dims[dim].ubnd;
 239       lbnd = h->dims[dim].lbnd;
 240       inc = h->dims[dim].inc;
 241       pos += (i - h->dims[dim].ubnd) * inc;
 242
 243       for (; i >= lbnd; i--, pos -= inc)
 244         res = scm_cons (array_to_list (h, dim + 1, pos), res);
 245       return res;
 246     }
 247 }
 248
 249 SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
 250             (SCM array),
 251             "FIXME description a list consisting of all the elements, in order, of\n"
 252             "@var{array}.")
 253 #define FUNC_NAME s_scm_array_to_list
 254 {
 255   scm_t_array_handle h;
 256   SCM res;
 257
 258   scm_array_get_handle (array, &h);
 259   res = array_to_list (&h, 0, 0);
 260   scm_array_handle_release (&h);
 261
 262   return res;
 263 }
 264 #undef FUNC_NAME
 265
 266 void
 267 scm_init_generalized_arrays ()
 268 {
 269 #include "libguile/generalized-arrays.x"
 270 }
 271
 272 /*
 273   Local Variables:
 274   c-file-style: "gnu"
 275   End:
 276 */