libguile/generalized-arrays.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010 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_2
  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 SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
 142            (SCM ra),
 143             "")
 144 #define FUNC_NAME s_scm_array_type
 145 {
 146   scm_t_array_handle h;
 147   SCM type;
 148
 149   scm_array_get_handle (ra, &h);
 150   type = scm_array_handle_element_type (&h);
 151   scm_array_handle_release (&h);
 152
 153   return type;
 154 }
 155 #undef FUNC_NAME
 156
 157 SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
 158            (SCM ra, SCM args),
 159             "Return @code{#t} if its arguments would be acceptable to\n"
 160             "@code{array-ref}.")
 161 #define FUNC_NAME s_scm_array_in_bounds_p
 162 {
 163   SCM res = SCM_BOOL_T;
 164   size_t k, ndim;
 165   scm_t_array_dim *s;
 166   scm_t_array_handle handle;
 167
 168   SCM_VALIDATE_REST_ARGUMENT (args);
 169
 170   scm_array_get_handle (ra, &handle);
 171   s = scm_array_handle_dims (&handle);
 172   ndim = scm_array_handle_rank (&handle);
 173
 174   for (k = 0; k < ndim; k++)
 175     {
 176       long ind;
 177
 178       if (!scm_is_pair (args))
 179         SCM_WRONG_NUM_ARGS ();
 180       ind = scm_to_long (SCM_CAR (args));
 181       args = SCM_CDR (args);
 182
 183       if (ind < s[k].lbnd || ind > s[k].ubnd)
 184         {
 185           res = SCM_BOOL_F;
 186           /* We do not stop the checking after finding a violation
 187              since we want to validate the type-correctness and
 188              number of arguments in any case.
 189           */
 190         }
 191     }
 192
 193   scm_array_handle_release (&handle);
 194   return res;
 195 }
 196 #undef FUNC_NAME
 197
 198 SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
 199            (SCM v, SCM args),
 200             "Return the element at the @code{(index1, index2)} element in\n"
 201             "array @var{v}.")
 202 #define FUNC_NAME s_scm_array_ref
 203 {
 204   scm_t_array_handle handle;
 205   SCM res;
 206
 207   scm_array_get_handle (v, &handle);
 208   res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args));
 209   scm_array_handle_release (&handle);
 210   return res;
 211 }
 212 #undef FUNC_NAME
 213
 214
 215 SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
 216            (SCM v, SCM obj, SCM args),
 217             "Set the element at the @code{(index1, index2)} element in array\n"
 218             "@var{v} to @var{obj}.  The value returned by @code{array-set!}\n"
 219             "is unspecified.")
 220 #define FUNC_NAME s_scm_array_set_x
 221 {
 222   scm_t_array_handle handle;
 223
 224   scm_array_get_handle (v, &handle);
 225   scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj);
 226   scm_array_handle_release (&handle);
 227   return SCM_UNSPECIFIED;
 228 }
 229 #undef FUNC_NAME
 230
 231 static SCM
 232 array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos)
 233 {
 234   if (dim == scm_array_handle_rank (h))
 235     return scm_array_handle_ref (h, pos);
 236   else
 237     {
 238       SCM res = SCM_EOL;
 239       long inc;
 240       size_t i;
 241
 242       i = h->dims[dim].ubnd - h->dims[dim].lbnd + 1;
 243       inc = h->dims[dim].inc;
 244       pos += (i - 1) * inc;
 245
 246       for (; i > 0; i--, pos -= inc)
 247         res = scm_cons (array_to_list (h, dim + 1, pos), res);
 248       return res;
 249     }
 250 }
 251
 252 SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
 253             (SCM array),
 254             "Return a list representation of @var{array}.\n\n"
 255             "It is easiest to specify the behavior of this function by\n"
 256             "example:\n"
 257             "@example\n"
 258             "(array->list #0(a)) @result{} 1\n"
 259             "(array->list #1(a b)) @result{} (a b)\n"
 260             "(array->list #2((aa ab) (ba bb)) @result{} ((aa ab) (ba bb))\n"
 261             "@end example\n")
 262 #define FUNC_NAME s_scm_array_to_list
 263 {
 264   scm_t_array_handle h;
 265   SCM res;
 266
 267   scm_array_get_handle (array, &h);
 268   res = array_to_list (&h, 0, 0);
 269   scm_array_handle_release (&h);
 270
 271   return res;
 272 }
 273 #undef FUNC_NAME
 274
 275 void
 276 scm_init_generalized_arrays ()
 277 {
 278 #include "libguile/generalized-arrays.x"
 279 }
 280
 281 /*
 282   Local Variables:
 283   c-file-style: "gnu"
 284   End:
 285 */