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