libguile/generalized-arrays.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 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 <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 SCM_INTERNAL SCM scm_i_array_ref (SCM v,
  37                                   SCM idx0, SCM idx1, SCM idxN);
  38 SCM_INTERNAL SCM scm_i_array_set_x (SCM v, SCM obj,
  39                                     SCM idx0, SCM idx1, SCM idxN);
  40
  41
  42 int
  43 scm_is_array (SCM obj)
  44 {
  45   return scm_i_array_implementation_for_obj (obj) ? 1 : 0;
  46 }
  47
  48 SCM_DEFINE (scm_array_p_2, "array?", 1, 0, 0,
  49             (SCM obj),
  50             "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
  51             "not.")
  52 #define FUNC_NAME s_scm_array_p_2
  53 {
  54   return scm_from_bool (scm_is_array (obj));
  55 }
  56 #undef FUNC_NAME
  57
  58 /* The array type predicate, with an extra argument kept for backward
  59    compatibility.  Note that we can't use `SCM_DEFINE' directly because there
  60    would be an argument count mismatch that would be caught by
  61    `snarf-check-and-output-texi.scm'.  */
  62 SCM
  63 scm_array_p (SCM obj, SCM unused)
  64 {
  65   return scm_array_p_2 (obj);
  66 }
  67
  68 int
  69 scm_is_typed_array (SCM obj, SCM type)
  70 {
  71   int ret = 0;
  72   if (scm_i_array_implementation_for_obj (obj))
  73     {
  74       scm_t_array_handle h;
  75
  76       scm_array_get_handle (obj, &h);
  77       ret = scm_is_eq (scm_array_handle_element_type (&h), type);
  78       scm_array_handle_release (&h);
  79     }
  80
  81   return ret;
  82 }
  83
  84 SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
  85            (SCM obj, SCM type),
  86             "Return @code{#t} if the @var{obj} is an array of type\n"
  87             "@var{type}, and @code{#f} if not.")
  88 #define FUNC_NAME s_scm_typed_array_p
  89 {
  90   return scm_from_bool (scm_is_typed_array (obj, type));
  91 }
  92 #undef FUNC_NAME
  93
  94 size_t
  95 scm_c_array_rank (SCM array)
  96 {
  97   scm_t_array_handle handle;
  98   size_t res;
  99
 100   scm_array_get_handle (array, &handle);
 101   res = scm_array_handle_rank (&handle);
 102   scm_array_handle_release (&handle);
 103   return res;
 104 }
 105
 106 SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
 107            (SCM array),
 108             "Return the number of dimensions of the array @var{array.}\n")
 109 #define FUNC_NAME s_scm_array_rank
 110 {
 111   return scm_from_size_t (scm_c_array_rank (array));
 112 }
 113 #undef FUNC_NAME
 114
 115
 116 size_t
 117 scm_c_array_length (SCM array)
 118 {
 119   scm_t_array_handle handle;
 120   size_t res;
 121
 122   scm_array_get_handle (array, &handle);
 123   if (scm_array_handle_rank (&handle) < 1)
 124     {
 125       scm_array_handle_release (&handle);
 126       scm_wrong_type_arg_msg (NULL, 0, array, "array of nonzero rank");
 127     }
 128   res = handle.dims[0].ubnd - handle.dims[0].lbnd + 1;
 129   scm_array_handle_release (&handle);
 130
 131   return res;
 132 }
 133
 134 SCM_DEFINE (scm_array_length, "array-length", 1, 0, 0,
 135            (SCM array),
 136             "Return the length of an array: its first dimension.\n"
 137             "It is an error to ask for the length of an array of rank 0.")
 138 #define FUNC_NAME s_scm_array_length
 139 {
 140   return scm_from_size_t (scm_c_array_length (array));
 141 }
 142 #undef FUNC_NAME
 143
 144
 145 SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
 146            (SCM ra),
 147             "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
 148             "elements with a @code{0} minimum with one greater than the maximum. So:\n"
 149             "@lisp\n"
 150             "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
 151             "@end lisp")
 152 #define FUNC_NAME s_scm_array_dimensions
 153 {
 154   scm_t_array_handle handle;
 155   scm_t_array_dim *s;
 156   SCM res = SCM_EOL;
 157   size_t k;
 158
 159   scm_array_get_handle (ra, &handle);
 160   s = scm_array_handle_dims (&handle);
 161   k = scm_array_handle_rank (&handle);
 162
 163   while (k--)
 164     res = scm_cons (s[k].lbnd
 165                     ? scm_cons2 (scm_from_ssize_t (s[k].lbnd),
 166                                  scm_from_ssize_t (s[k].ubnd),
 167                                  SCM_EOL)
 168                     : scm_from_ssize_t (1 + s[k].ubnd),
 169                     res);
 170
 171   scm_array_handle_release (&handle);
 172   return res;
 173 }
 174 #undef FUNC_NAME
 175
 176 SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
 177            (SCM ra),
 178             "")
 179 #define FUNC_NAME s_scm_array_type
 180 {
 181   scm_t_array_handle h;
 182   SCM type;
 183
 184   scm_array_get_handle (ra, &h);
 185   type = scm_array_handle_element_type (&h);
 186   scm_array_handle_release (&h);
 187
 188   return type;
 189 }
 190 #undef FUNC_NAME
 191
 192 SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
 193            (SCM ra, SCM args),
 194             "Return @code{#t} if its arguments would be acceptable to\n"
 195             "@code{array-ref}.")
 196 #define FUNC_NAME s_scm_array_in_bounds_p
 197 {
 198   SCM res = SCM_BOOL_T;
 199   size_t k, ndim;
 200   scm_t_array_dim *s;
 201   scm_t_array_handle handle;
 202
 203   SCM_VALIDATE_REST_ARGUMENT (args);
 204
 205   scm_array_get_handle (ra, &handle);
 206   s = scm_array_handle_dims (&handle);
 207   ndim = scm_array_handle_rank (&handle);
 208
 209   for (k = 0; k < ndim; k++)
 210     {
 211       long ind;
 212
 213       if (!scm_is_pair (args))
 214         SCM_WRONG_NUM_ARGS ();
 215       ind = scm_to_long (SCM_CAR (args));
 216       args = SCM_CDR (args);
 217
 218       if (ind < s[k].lbnd || ind > s[k].ubnd)
 219         {
 220           res = SCM_BOOL_F;
 221           /* We do not stop the checking after finding a violation
 222              since we want to validate the type-correctness and
 223              number of arguments in any case.
 224           */
 225         }
 226     }
 227
 228   scm_array_handle_release (&handle);
 229   return res;
 230 }
 231 #undef FUNC_NAME
 232
 233
 234 SCM
 235 scm_c_array_ref_1 (SCM array, ssize_t idx0)
 236 {
 237   scm_t_array_handle handle;
 238   SCM res;
 239
 240   scm_array_get_handle (array, &handle);
 241   res = scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, idx0));
 242   scm_array_handle_release (&handle);
 243   return res;
 244 }
 245
 246
 247 SCM
 248 scm_c_array_ref_2 (SCM array, ssize_t idx0, ssize_t idx1)
 249 {
 250   scm_t_array_handle handle;
 251   SCM res;
 252
 253   scm_array_get_handle (array, &handle);
 254   res = scm_array_handle_ref (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1));
 255   scm_array_handle_release (&handle);
 256   return res;
 257 }
 258
 259
 260 SCM
 261 scm_array_ref (SCM v, SCM args)
 262 {
 263   scm_t_array_handle handle;
 264   SCM res;
 265
 266   scm_array_get_handle (v, &handle);
 267   res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args));
 268   scm_array_handle_release (&handle);
 269   return res;
 270 }
 271
 272
 273 void
 274 scm_c_array_set_1_x (SCM array, SCM obj, ssize_t idx0)
 275 {
 276   scm_t_array_handle handle;
 277
 278   scm_array_get_handle (array, &handle);
 279   scm_array_handle_set (&handle, scm_array_handle_pos_1 (&handle, idx0),
 280                         obj);
 281   scm_array_handle_release (&handle);
 282 }
 283
 284
 285 void
 286 scm_c_array_set_2_x (SCM array, SCM obj, ssize_t idx0, ssize_t idx1)
 287 {
 288   scm_t_array_handle handle;
 289
 290   scm_array_get_handle (array, &handle);
 291   scm_array_handle_set (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1),
 292                         obj);
 293   scm_array_handle_release (&handle);
 294 }
 295
 296
 297 SCM
 298 scm_array_set_x (SCM v, SCM obj, SCM args)
 299 {
 300   scm_t_array_handle handle;
 301
 302   scm_array_get_handle (v, &handle);
 303   scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj);
 304   scm_array_handle_release (&handle);
 305   return SCM_UNSPECIFIED;
 306 }
 307
 308
 309 SCM_DEFINE (scm_i_array_ref, "array-ref", 1, 2, 1,
 310             (SCM v, SCM idx0, SCM idx1, SCM idxN),
 311             "Return the element at the @code{(idx0, idx1, idxN...)}\n"
 312             "position in array @var{v}.")
 313 #define FUNC_NAME s_scm_i_array_ref
 314 {
 315   if (SCM_UNBNDP (idx0))
 316     return scm_array_ref (v, SCM_EOL);
 317   else if (SCM_UNBNDP (idx1))
 318     return scm_c_array_ref_1 (v, scm_to_ssize_t (idx0));
 319   else if (scm_is_null (idxN))
 320     return scm_c_array_ref_2 (v, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1));
 321   else
 322     return scm_array_ref (v, scm_cons (idx0, scm_cons (idx1, idxN)));
 323 }
 324 #undef FUNC_NAME
 325
 326
 327 SCM_DEFINE (scm_i_array_set_x, "array-set!", 2, 2, 1,
 328             (SCM v, SCM obj, SCM idx0, SCM idx1, SCM idxN),
 329             "Set the element at the @code{(idx0, idx1, idxN...)} position\n"
 330             "in the array @var{v} to @var{obj}.  The value returned by\n"
 331             "@code{array-set!} is unspecified.")
 332 #define FUNC_NAME s_scm_i_array_set_x
 333 {
 334   if (SCM_UNBNDP (idx0))
 335     scm_array_set_x (v, obj, SCM_EOL);
 336   else if (SCM_UNBNDP (idx1))
 337     scm_c_array_set_1_x (v, obj, scm_to_ssize_t (idx0));
 338   else if (scm_is_null (idxN))
 339     scm_c_array_set_2_x (v, obj, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1));
 340   else
 341     scm_array_set_x (v, obj, scm_cons (idx0, scm_cons (idx1, idxN)));
 342
 343   return SCM_UNSPECIFIED;
 344 }
 345 #undef FUNC_NAME
 346
 347
 348 static SCM
 349 array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos)
 350 {
 351   if (dim == scm_array_handle_rank (h))
 352     return scm_array_handle_ref (h, pos);
 353   else
 354     {
 355       SCM res = SCM_EOL;
 356       long inc;
 357       size_t i;
 358
 359       i = h->dims[dim].ubnd - h->dims[dim].lbnd + 1;
 360       inc = h->dims[dim].inc;
 361       pos += (i - 1) * inc;
 362
 363       for (; i > 0; i--, pos -= inc)
 364         res = scm_cons (array_to_list (h, dim + 1, pos), res);
 365       return res;
 366     }
 367 }
 368
 369 SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
 370             (SCM array),
 371             "Return a list representation of @var{array}.\n\n"
 372             "It is easiest to specify the behavior of this function by\n"
 373             "example:\n"
 374             "@example\n"
 375             "(array->list #0(a)) @result{} 1\n"
 376             "(array->list #1(a b)) @result{} (a b)\n"
 377             "(array->list #2((aa ab) (ba bb)) @result{} ((aa ab) (ba bb))\n"
 378             "@end example\n")
 379 #define FUNC_NAME s_scm_array_to_list
 380 {
 381   scm_t_array_handle h;
 382   SCM res;
 383
 384   scm_array_get_handle (array, &h);
 385   res = array_to_list (&h, 0, 0);
 386   scm_array_handle_release (&h);
 387
 388   return res;
 389 }
 390 #undef FUNC_NAME
 391
 392 void
 393 scm_init_generalized_arrays ()
 394 {
 395 #include "libguile/generalized-arrays.x"
 396 }
 397
 398 /*
 399   Local Variables:
 400   c-file-style: "gnu"
 401   End:
 402 */