libguile/generalized-arrays.c

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