libguile/arrays.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011 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/eq.h"
  33 #include "libguile/chars.h"
  34 #include "libguile/eval.h"
  35 #include "libguile/fports.h"
  36 #include "libguile/feature.h"
  37 #include "libguile/root.h"
  38 #include "libguile/strings.h"
  39 #include "libguile/srfi-13.h"
  40 #include "libguile/srfi-4.h"
  41 #include "libguile/vectors.h"
  42 #include "libguile/bitvectors.h"
  43 #include "libguile/bytevectors.h"
  44 #include "libguile/list.h"
  45 #include "libguile/dynwind.h"
  46 #include "libguile/read.h"
  47
  48 #include "libguile/validate.h"
  49 #include "libguile/arrays.h"
  50 #include "libguile/array-map.h"
  51 #include "libguile/generalized-vectors.h"
  52 #include "libguile/generalized-arrays.h"
  53 #include "libguile/uniform.h"
  54
  55
  56 #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
  57   (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
  58 #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
  59   (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
  60
  61
  62 SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
  63            (SCM ra),
  64             "Return the root vector of a shared array.")
  65 #define FUNC_NAME s_scm_shared_array_root
  66 {
  67   if (SCM_I_ARRAYP (ra))
  68     return SCM_I_ARRAY_V (ra);
  69   else if (scm_is_generalized_vector (ra))
  70     return ra;
  71   scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
  72 }
  73 #undef FUNC_NAME
  74
  75
  76 SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
  77            (SCM ra),
  78             "Return the root vector index of the first element in the array.")
  79 #define FUNC_NAME s_scm_shared_array_offset
  80 {
  81   scm_t_array_handle handle;
  82   SCM res;
  83
  84   scm_array_get_handle (ra, &handle);
  85   res = scm_from_size_t (handle.base);
  86   scm_array_handle_release (&handle);
  87   return res;
  88 }
  89 #undef FUNC_NAME
  90
  91
  92 SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
  93            (SCM ra),
  94             "For each dimension, return the distance between elements in the root vector.")
  95 #define FUNC_NAME s_scm_shared_array_increments
  96 {
  97   scm_t_array_handle handle;
  98   SCM res = SCM_EOL;
  99   size_t k;
 100   scm_t_array_dim *s;
 101
 102   scm_array_get_handle (ra, &handle);
 103   k = scm_array_handle_rank (&handle);
 104   s = scm_array_handle_dims (&handle);
 105   while (k--)
 106     res = scm_cons (scm_from_ssize_t (s[k].inc), res);
 107   scm_array_handle_release (&handle);
 108   return res;
 109 }
 110 #undef FUNC_NAME
 111
 112 SCM
 113 scm_i_make_array (int ndim)
 114 {
 115   SCM ra;
 116   ra = scm_cell (((scm_t_bits) ndim << 17) + scm_tc7_array,
 117                  (scm_t_bits) scm_gc_malloc (sizeof (scm_i_t_array) +
 118                                              ndim * sizeof (scm_t_array_dim),
 119                                              "array"));
 120   SCM_I_ARRAY_V (ra) = SCM_BOOL_F;
 121   return ra;
 122 }
 123
 124 static char s_bad_spec[] = "Bad scm_array dimension";
 125
 126
 127 /* Increments will still need to be set. */
 128
 129 static SCM
 130 scm_i_shap2ra (SCM args)
 131 {
 132   scm_t_array_dim *s;
 133   SCM ra, spec, sp;
 134   int ndim = scm_ilength (args);
 135   if (ndim < 0)
 136     scm_misc_error (NULL, s_bad_spec, SCM_EOL);
 137
 138   ra = scm_i_make_array (ndim);
 139   SCM_I_ARRAY_BASE (ra) = 0;
 140   s = SCM_I_ARRAY_DIMS (ra);
 141   for (; !scm_is_null (args); s++, args = SCM_CDR (args))
 142     {
 143       spec = SCM_CAR (args);
 144       if (scm_is_integer (spec))
 145         {
 146           if (scm_to_long (spec) < 0)
 147             scm_misc_error (NULL, s_bad_spec, SCM_EOL);
 148           s->lbnd = 0;
 149           s->ubnd = scm_to_long (spec) - 1;
 150           s->inc = 1;
 151         }
 152       else
 153         {
 154           if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec)))
 155             scm_misc_error (NULL, s_bad_spec, SCM_EOL);
 156           s->lbnd = scm_to_long (SCM_CAR (spec));
 157           sp = SCM_CDR (spec);
 158           if (!scm_is_pair (sp)
 159               || !scm_is_integer (SCM_CAR (sp))
 160               || !scm_is_null (SCM_CDR (sp)))
 161             scm_misc_error (NULL, s_bad_spec, SCM_EOL);
 162           s->ubnd = scm_to_long (SCM_CAR (sp));
 163           s->inc = 1;
 164         }
 165     }
 166   return ra;
 167 }
 168
 169 SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
 170             (SCM type, SCM fill, SCM bounds),
 171             "Create and return an array of type @var{type}.")
 172 #define FUNC_NAME s_scm_make_typed_array
 173 {
 174   size_t k, rlen = 1;
 175   scm_t_array_dim *s;
 176   SCM ra;
 177
 178   ra = scm_i_shap2ra (bounds);
 179   SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
 180   s = SCM_I_ARRAY_DIMS (ra);
 181   k = SCM_I_ARRAY_NDIM (ra);
 182
 183   while (k--)
 184     {
 185       s[k].inc = rlen;
 186       SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
 187       rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
 188     }
 189
 190   if (scm_is_eq (fill, SCM_UNSPECIFIED))
 191     fill = SCM_UNDEFINED;
 192
 193   SCM_I_ARRAY_V (ra) =
 194     scm_make_generalized_vector (type, scm_from_size_t (rlen), fill);
 195
 196   if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
 197     if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
 198       return SCM_I_ARRAY_V (ra);
 199   return ra;
 200 }
 201 #undef FUNC_NAME
 202
 203 SCM
 204 scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
 205                                  size_t byte_len)
 206 #define FUNC_NAME "scm_from_contiguous_typed_array"
 207 {
 208   size_t k, rlen = 1;
 209   scm_t_array_dim *s;
 210   SCM ra;
 211   scm_t_array_handle h;
 212   void *elts;
 213   size_t sz;
 214
 215   ra = scm_i_shap2ra (bounds);
 216   SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
 217   s = SCM_I_ARRAY_DIMS (ra);
 218   k = SCM_I_ARRAY_NDIM (ra);
 219
 220   while (k--)
 221     {
 222       s[k].inc = rlen;
 223       SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
 224       rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
 225     }
 226   SCM_I_ARRAY_V (ra) =
 227     scm_make_generalized_vector (type, scm_from_size_t (rlen), SCM_UNDEFINED);
 228
 229
 230   scm_array_get_handle (ra, &h);
 231   elts = h.writable_elements;
 232   sz = scm_array_handle_uniform_element_bit_size (&h);
 233   scm_array_handle_release (&h);
 234
 235   if (sz >= 8 && ((sz % 8) == 0))
 236     {
 237       if (byte_len % (sz / 8))
 238         SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL);
 239       if (byte_len / (sz / 8) != rlen)
 240         SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
 241     }
 242   else if (sz < 8)
 243     {
 244       /* byte_len ?= ceil (rlen * sz / 8) */
 245       if (byte_len != (rlen * sz + 7) / 8)
 246         SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
 247     }
 248   else
 249     /* an internal guile error, really */
 250     SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL);
 251
 252   memcpy (elts, bytes, byte_len);
 253
 254   if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
 255     if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
 256       return SCM_I_ARRAY_V (ra);
 257   return ra;
 258 }
 259 #undef FUNC_NAME
 260
 261 SCM
 262 scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len)
 263 #define FUNC_NAME "scm_from_contiguous_array"
 264 {
 265   size_t k, rlen = 1;
 266   scm_t_array_dim *s;
 267   SCM ra;
 268   scm_t_array_handle h;
 269
 270   ra = scm_i_shap2ra (bounds);
 271   SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
 272   s = SCM_I_ARRAY_DIMS (ra);
 273   k = SCM_I_ARRAY_NDIM (ra);
 274
 275   while (k--)
 276     {
 277       s[k].inc = rlen;
 278       SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
 279       rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
 280     }
 281   if (rlen != len)
 282     SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL);
 283
 284   SCM_I_ARRAY_V (ra) = scm_c_make_vector (rlen, SCM_UNDEFINED);
 285   scm_array_get_handle (ra, &h);
 286   memcpy (h.writable_elements, elts, rlen * sizeof(SCM));
 287   scm_array_handle_release (&h);
 288
 289   if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
 290     if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
 291       return SCM_I_ARRAY_V (ra);
 292   return ra;
 293 }
 294 #undef FUNC_NAME
 295
 296 SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
 297             (SCM fill, SCM bounds),
 298             "Create and return an array.")
 299 #define FUNC_NAME s_scm_make_array
 300 {
 301   return scm_make_typed_array (SCM_BOOL_T, fill, bounds);
 302 }
 303 #undef FUNC_NAME
 304
 305 static void
 306 scm_i_ra_set_contp (SCM ra)
 307 {
 308   size_t k = SCM_I_ARRAY_NDIM (ra);
 309   if (k)
 310     {
 311       long inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc;
 312       while (k--)
 313         {
 314           if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc)
 315             {
 316               SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
 317               return;
 318             }
 319           inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
 320                   - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
 321         }
 322     }
 323   SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
 324 }
 325
 326
 327 SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
 328            (SCM oldra, SCM mapfunc, SCM dims),
 329             "@code{make-shared-array} can be used to create shared subarrays of other\n"
 330             "arrays.  The @var{mapper} is a function that translates coordinates in\n"
 331             "the new array into coordinates in the old array.  A @var{mapper} must be\n"
 332             "linear, and its range must stay within the bounds of the old array, but\n"
 333             "it can be otherwise arbitrary.  A simple example:\n"
 334             "@lisp\n"
 335             "(define fred (make-array #f 8 8))\n"
 336             "(define freds-diagonal\n"
 337             "  (make-shared-array fred (lambda (i) (list i i)) 8))\n"
 338             "(array-set! freds-diagonal 'foo 3)\n"
 339             "(array-ref fred 3 3) @result{} foo\n"
 340             "(define freds-center\n"
 341             "  (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
 342             "(array-ref freds-center 0 0) @result{} foo\n"
 343             "@end lisp")
 344 #define FUNC_NAME s_scm_make_shared_array
 345 {
 346   scm_t_array_handle old_handle;
 347   SCM ra;
 348   SCM inds, indptr;
 349   SCM imap;
 350   size_t k;
 351   ssize_t i;
 352   long old_base, old_min, new_min, old_max, new_max;
 353   scm_t_array_dim *s;
 354
 355   SCM_VALIDATE_REST_ARGUMENT (dims);
 356   SCM_VALIDATE_PROC (2, mapfunc);
 357   ra = scm_i_shap2ra (dims);
 358
 359   scm_array_get_handle (oldra, &old_handle);
 360
 361   if (SCM_I_ARRAYP (oldra))
 362     {
 363       SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra);
 364       old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra);
 365       s = scm_array_handle_dims (&old_handle);
 366       k = scm_array_handle_rank (&old_handle);
 367       while (k--)
 368         {
 369           if (s[k].inc > 0)
 370             old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
 371           else
 372             old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
 373         }
 374     }
 375   else
 376     {
 377       SCM_I_ARRAY_V (ra) = oldra;
 378       old_base = old_min = 0;
 379       old_max = scm_c_generalized_vector_length (oldra) - 1;
 380     }
 381
 382   inds = SCM_EOL;
 383   s = SCM_I_ARRAY_DIMS (ra);
 384   for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
 385     {
 386       inds = scm_cons (scm_from_long (s[k].lbnd), inds);
 387       if (s[k].ubnd < s[k].lbnd)
 388         {
 389           if (1 == SCM_I_ARRAY_NDIM (ra))
 390             ra = scm_make_generalized_vector (scm_array_type (ra),
 391                                               SCM_INUM0, SCM_UNDEFINED);
 392           else
 393             SCM_I_ARRAY_V (ra) =
 394               scm_make_generalized_vector (scm_array_type (ra),
 395                                            SCM_INUM0, SCM_UNDEFINED);
 396           scm_array_handle_release (&old_handle);
 397           return ra;
 398         }
 399     }
 400
 401   imap = scm_apply_0 (mapfunc, scm_reverse (inds));
 402   i = scm_array_handle_pos (&old_handle, imap);
 403   SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base;
 404   indptr = inds;
 405   k = SCM_I_ARRAY_NDIM (ra);
 406   while (k--)
 407     {
 408       if (s[k].ubnd > s[k].lbnd)
 409         {
 410           SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1)));
 411           imap = scm_apply_0 (mapfunc, scm_reverse (inds));
 412           s[k].inc = scm_array_handle_pos (&old_handle, imap) - i;
 413           i += s[k].inc;
 414           if (s[k].inc > 0)
 415             new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
 416           else
 417             new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
 418         }
 419       else
 420         s[k].inc = new_max - new_min + 1;       /* contiguous by default */
 421       indptr = SCM_CDR (indptr);
 422     }
 423
 424   scm_array_handle_release (&old_handle);
 425
 426   if (old_min > new_min || old_max < new_max)
 427     SCM_MISC_ERROR ("mapping out of range", SCM_EOL);
 428   if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
 429     {
 430       SCM v = SCM_I_ARRAY_V (ra);
 431       size_t length = scm_c_generalized_vector_length (v);
 432       if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
 433         return v;
 434       if (s->ubnd < s->lbnd)
 435         return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0,
 436                                             SCM_UNDEFINED);
 437     }
 438   scm_i_ra_set_contp (ra);
 439   return ra;
 440 }
 441 #undef FUNC_NAME
 442
 443
 444 /* args are RA . DIMS */
 445 SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
 446            (SCM ra, SCM args),
 447             "Return an array sharing contents with @var{array}, but with\n"
 448             "dimensions arranged in a different order.  There must be one\n"
 449             "@var{dim} argument for each dimension of @var{array}.\n"
 450             "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
 451             "and the rank of the array to be returned.  Each integer in that\n"
 452             "range must appear at least once in the argument list.\n"
 453             "\n"
 454             "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
 455             "dimensions in the array to be returned, their positions in the\n"
 456             "argument list to dimensions of @var{array}.  Several @var{dim}s\n"
 457             "may have the same value, in which case the returned array will\n"
 458             "have smaller rank than @var{array}.\n"
 459             "\n"
 460             "@lisp\n"
 461             "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
 462             "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
 463             "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
 464             "                #2((a 4) (b 5) (c 6))\n"
 465             "@end lisp")
 466 #define FUNC_NAME s_scm_transpose_array
 467 {
 468   SCM res, vargs;
 469   scm_t_array_dim *s, *r;
 470   int ndim, i, k;
 471
 472   SCM_VALIDATE_REST_ARGUMENT (args);
 473   SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME);
 474
 475   if (scm_is_generalized_vector (ra))
 476     {
 477       /* Make sure that we are called with a single zero as
 478          arguments.
 479       */
 480       if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
 481         SCM_WRONG_NUM_ARGS ();
 482       SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
 483       SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
 484       return ra;
 485     }
 486
 487   if (SCM_I_ARRAYP (ra))
 488     {
 489       vargs = scm_vector (args);
 490       if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
 491         SCM_WRONG_NUM_ARGS ();
 492       ndim = 0;
 493       for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
 494         {
 495           i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k),
 496                                      0, SCM_I_ARRAY_NDIM(ra));
 497           if (ndim < i)
 498             ndim = i;
 499         }
 500       ndim++;
 501       res = scm_i_make_array (ndim);
 502       SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra);
 503       SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra);
 504       for (k = ndim; k--;)
 505         {
 506           SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
 507           SCM_I_ARRAY_DIMS (res)[k].ubnd = -1;
 508         }
 509       for (k = SCM_I_ARRAY_NDIM (ra); k--;)
 510         {
 511           i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k));
 512           s = &(SCM_I_ARRAY_DIMS (ra)[k]);
 513           r = &(SCM_I_ARRAY_DIMS (res)[i]);
 514           if (r->ubnd < r->lbnd)
 515             {
 516               r->lbnd = s->lbnd;
 517               r->ubnd = s->ubnd;
 518               r->inc = s->inc;
 519               ndim--;
 520             }
 521           else
 522             {
 523               if (r->ubnd > s->ubnd)
 524                 r->ubnd = s->ubnd;
 525               if (r->lbnd < s->lbnd)
 526                 {
 527                   SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
 528                   r->lbnd = s->lbnd;
 529                 }
 530               r->inc += s->inc;
 531             }
 532         }
 533       if (ndim > 0)
 534         SCM_MISC_ERROR ("bad argument list", SCM_EOL);
 535       scm_i_ra_set_contp (res);
 536       return res;
 537     }
 538
 539   scm_wrong_type_arg_msg (NULL, 0, ra, "array");
 540 }
 541 #undef FUNC_NAME
 542
 543 /* attempts to unroll an array into a one-dimensional array.
 544    returns the unrolled array or #f if it can't be done.  */
 545   /* if strict is not SCM_UNDEFINED, return #f if returned array
 546                      wouldn't have contiguous elements.  */
 547 SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
 548            (SCM ra, SCM strict),
 549             "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
 550             "without changing their order (last subscript changing fastest), then\n"
 551             "@code{array-contents} returns that shared array, otherwise it returns\n"
 552             "@code{#f}.  All arrays made by @var{make-array} and\n"
 553             "@var{make-uniform-array} may be unrolled, some arrays made by\n"
 554             "@var{make-shared-array} may not be.\n\n"
 555             "If the optional argument @var{strict} is provided, a shared array will\n"
 556             "be returned only if its elements are stored internally contiguous in\n"
 557             "memory.")
 558 #define FUNC_NAME s_scm_array_contents
 559 {
 560   SCM sra;
 561
 562   if (scm_is_generalized_vector (ra))
 563     return ra;
 564
 565   if (SCM_I_ARRAYP (ra))
 566     {
 567       size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
 568       if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra))
 569         return SCM_BOOL_F;
 570       for (k = 0; k < ndim; k++)
 571         len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
 572       if (!SCM_UNBNDP (strict) && scm_is_true (strict))
 573         {
 574           if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc))
 575             return SCM_BOOL_F;
 576           if (scm_is_bitvector (SCM_I_ARRAY_V (ra)))
 577             {
 578               if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
 579                   SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
 580                   len % SCM_LONG_BIT)
 581                 return SCM_BOOL_F;
 582             }
 583         }
 584
 585       {
 586         SCM v = SCM_I_ARRAY_V (ra);
 587         size_t length = scm_c_generalized_vector_length (v);
 588         if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc)
 589           return v;
 590       }
 591
 592       sra = scm_i_make_array (1);
 593       SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
 594       SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
 595       SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra);
 596       SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra);
 597       SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
 598       return sra;
 599     }
 600   else
 601     scm_wrong_type_arg_msg (NULL, 0, ra, "array");
 602 }
 603 #undef FUNC_NAME
 604
 605
 606 static void
 607 list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
 608 {
 609   if (k == scm_array_handle_rank (handle))
 610     scm_array_handle_set (handle, pos, lst);
 611   else
 612     {
 613       scm_t_array_dim *dim = scm_array_handle_dims (handle) + k;
 614       ssize_t inc = dim->inc;
 615       size_t len = 1 + dim->ubnd - dim->lbnd, n;
 616       char *errmsg = NULL;
 617
 618       n = len;
 619       while (n > 0 && scm_is_pair (lst))
 620         {
 621           list_to_array (SCM_CAR (lst), handle, pos, k + 1);
 622           pos += inc;
 623           lst = SCM_CDR (lst);
 624           n -= 1;
 625         }
 626       if (n != 0)
 627         errmsg = "too few elements for array dimension ~a, need ~a";
 628       if (!scm_is_null (lst))
 629         errmsg = "too many elements for array dimension ~a, want ~a";
 630       if (errmsg)
 631         scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k),
 632                                                   scm_from_size_t (len)));
 633     }
 634 }
 635
 636
 637 SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
 638            (SCM type, SCM shape, SCM lst),
 639             "Return an array of the type @var{type}\n"
 640             "with elements the same as those of @var{lst}.\n"
 641             "\n"
 642             "The argument @var{shape} determines the number of dimensions\n"
 643             "of the array and their shape.  It is either an exact integer,\n"
 644             "giving the\n"
 645             "number of dimensions directly, or a list whose length\n"
 646             "specifies the number of dimensions and each element specified\n"
 647             "the lower and optionally the upper bound of the corresponding\n"
 648             "dimension.\n"
 649             "When the element is list of two elements, these elements\n"
 650             "give the lower and upper bounds.  When it is an exact\n"
 651             "integer, it gives only the lower bound.")
 652 #define FUNC_NAME s_scm_list_to_typed_array
 653 {
 654   SCM row;
 655   SCM ra;
 656   scm_t_array_handle handle;
 657
 658   row = lst;
 659   if (scm_is_integer (shape))
 660     {
 661       size_t k = scm_to_size_t (shape);
 662       shape = SCM_EOL;
 663       while (k-- > 0)
 664         {
 665           shape = scm_cons (scm_length (row), shape);
 666           if (k > 0 && !scm_is_null (row))
 667             row = scm_car (row);
 668         }
 669     }
 670   else
 671     {
 672       SCM shape_spec = shape;
 673       shape = SCM_EOL;
 674       while (1)
 675         {
 676           SCM spec = scm_car (shape_spec);
 677           if (scm_is_pair (spec))
 678             shape = scm_cons (spec, shape);
 679           else
 680             shape = scm_cons (scm_list_2 (spec,
 681                                           scm_sum (scm_sum (spec,
 682                                                             scm_length (row)),
 683                                                    scm_from_int (-1))),
 684                               shape);
 685           shape_spec = scm_cdr (shape_spec);
 686           if (scm_is_pair (shape_spec))
 687             {
 688               if (!scm_is_null (row))
 689                 row = scm_car (row);
 690             }
 691           else
 692             break;
 693         }
 694     }
 695
 696   ra = scm_make_typed_array (type, SCM_UNSPECIFIED,
 697                              scm_reverse_x (shape, SCM_EOL));
 698
 699   scm_array_get_handle (ra, &handle);
 700   list_to_array (lst, &handle, 0, 0);
 701   scm_array_handle_release (&handle);
 702
 703   return ra;
 704 }
 705 #undef FUNC_NAME
 706
 707 SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0,
 708            (SCM ndim, SCM lst),
 709             "Return an array with elements the same as those of @var{lst}.")
 710 #define FUNC_NAME s_scm_list_to_array
 711 {
 712   return scm_list_to_typed_array (SCM_BOOL_T, ndim, lst);
 713 }
 714 #undef FUNC_NAME
 715
 716 /* Print dimension DIM of ARRAY.
 717  */
 718
 719 static int
 720 scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos,
 721                              SCM port, scm_print_state *pstate)
 722 {
 723   if (dim == h->ndims)
 724     scm_iprin1 (scm_array_handle_ref (h, pos), port, pstate);
 725   else
 726     {
 727       ssize_t i;
 728       scm_putc ('(', port);
 729       for (i = h->dims[dim].lbnd; i <= h->dims[dim].ubnd;
 730            i++, pos += h->dims[dim].inc)
 731         {
 732           scm_i_print_array_dimension (h, dim+1, pos, port, pstate);
 733           if (i < h->dims[dim].ubnd)
 734             scm_putc (' ', port);
 735         }
 736       scm_putc (')', port);
 737     }
 738   return 1;
 739 }
 740
 741 /* Print an array.
 742 */
 743
 744 int
 745 scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
 746 {
 747   scm_t_array_handle h;
 748   long i;
 749   int print_lbnds = 0, zero_size = 0, print_lens = 0;
 750
 751   scm_array_get_handle (array, &h);
 752
 753   scm_putc ('#', port);
 754   if (h.ndims != 1 || h.dims[0].lbnd != 0)
 755     scm_intprint (h.ndims, 10, port);
 756   if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
 757     scm_write (scm_array_handle_element_type (&h), port);
 758
 759   for (i = 0; i < h.ndims; i++)
 760     {
 761       if (h.dims[i].lbnd != 0)
 762         print_lbnds = 1;
 763       if (h.dims[i].ubnd - h.dims[i].lbnd + 1 == 0)
 764         zero_size = 1;
 765       else if (zero_size)
 766         print_lens = 1;
 767     }
 768
 769   if (print_lbnds || print_lens)
 770     for (i = 0; i < h.ndims; i++)
 771       {
 772         if (print_lbnds)
 773           {
 774             scm_putc ('@', port);
 775             scm_intprint (h.dims[i].lbnd, 10, port);
 776           }
 777         if (print_lens)
 778           {
 779             scm_putc (':', port);
 780             scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1,
 781                           10, port);
 782           }
 783       }
 784
 785   if (h.ndims == 0)
 786     {
 787       /* Rank zero arrays, which are really just scalars, are printed
 788          specially.  The consequent way would be to print them as
 789
 790             #0 OBJ
 791
 792          where OBJ is the printed representation of the scalar, but we
 793          print them instead as
 794
 795             #0(OBJ)
 796
 797          to make them look less strange.
 798
 799          Just printing them as
 800
 801             OBJ
 802
 803          would be correct in a way as well, but zero rank arrays are
 804          not really the same as Scheme values since they are boxed and
 805          can be modified with array-set!, say.
 806       */
 807       scm_putc ('(', port);
 808       scm_i_print_array_dimension (&h, 0, 0, port, pstate);
 809       scm_putc (')', port);
 810       return 1;
 811     }
 812   else
 813     return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
 814 }
 815
 816 /* Read an array.  This function can also read vectors and uniform
 817    vectors.  Also, the conflict between '#f' and '#f32' and '#f64' is
 818    handled here.
 819
 820    C is the first character read after the '#'.
 821 */
 822
 823 static int
 824 read_decimal_integer (SCM port, int c, ssize_t *resp)
 825 {
 826   ssize_t sign = 1;
 827   ssize_t res = 0;
 828   int got_it = 0;
 829
 830   if (c == '-')
 831     {
 832       sign = -1;
 833       c = scm_getc (port);
 834     }
 835
 836   while ('0' <= c && c <= '9')
 837     {
 838       res = 10*res + c-'0';
 839       got_it = 1;
 840       c = scm_getc (port);
 841     }
 842
 843   if (got_it)
 844     *resp = sign * res;
 845   return c;
 846 }
 847
 848 SCM
 849 scm_i_read_array (SCM port, int c)
 850 {
 851   ssize_t rank;
 852   scm_t_wchar tag_buf[8];
 853   int tag_len;
 854
 855   SCM tag, shape = SCM_BOOL_F, elements;
 856
 857   /* XXX - shortcut for ordinary vectors.  Shouldn't be necessary but
 858      the array code can not deal with zero-length dimensions yet, and
 859      we want to allow zero-length vectors, of course.
 860   */
 861   if (c == '(')
 862     {
 863       scm_ungetc (c, port);
 864       return scm_vector (scm_read (port));
 865     }
 866
 867   /* Disambiguate between '#f' and uniform floating point vectors.
 868    */
 869   if (c == 'f')
 870     {
 871       c = scm_getc (port);
 872       if (c != '3' && c != '6')
 873         {
 874           if (c != EOF)
 875             scm_ungetc (c, port);
 876           return SCM_BOOL_F;
 877         }
 878       rank = 1;
 879       tag_buf[0] = 'f';
 880       tag_len = 1;
 881       goto continue_reading_tag;
 882     }
 883
 884   /* Read rank.
 885    */
 886   rank = 1;
 887   c = read_decimal_integer (port, c, &rank);
 888   if (rank < 0)
 889     scm_i_input_error (NULL, port, "array rank must be non-negative",
 890                        SCM_EOL);
 891
 892   /* Read tag.
 893    */
 894   tag_len = 0;
 895  continue_reading_tag:
 896   while (c != EOF && c != '(' && c != '@' && c != ':'
 897          && tag_len < sizeof tag_buf / sizeof tag_buf[0])
 898     {
 899       tag_buf[tag_len++] = c;
 900       c = scm_getc (port);
 901     }
 902   if (tag_len == 0)
 903     tag = SCM_BOOL_T;
 904   else
 905     {
 906       tag = scm_string_to_symbol (scm_from_utf32_stringn (tag_buf, tag_len));
 907       if (tag_len == sizeof tag_buf / sizeof tag_buf[0])
 908         scm_i_input_error (NULL, port, "invalid array tag, starting with: ~a",
 909                            scm_list_1 (tag));
 910     }
 911
 912   /* Read shape.
 913    */
 914   if (c == '@' || c == ':')
 915     {
 916       shape = SCM_EOL;
 917
 918       do
 919         {
 920           ssize_t lbnd = 0, len = 0;
 921           SCM s;
 922
 923           if (c == '@')
 924             {
 925               c = scm_getc (port);
 926               c = read_decimal_integer (port, c, &lbnd);
 927             }
 928
 929           s = scm_from_ssize_t (lbnd);
 930
 931           if (c == ':')
 932             {
 933               c = scm_getc (port);
 934               c = read_decimal_integer (port, c, &len);
 935               if (len < 0)
 936                 scm_i_input_error (NULL, port,
 937                                    "array length must be non-negative",
 938                                    SCM_EOL);
 939
 940               s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1));
 941             }
 942
 943           shape = scm_cons (s, shape);
 944         } while (c == '@' || c == ':');
 945
 946       shape = scm_reverse_x (shape, SCM_EOL);
 947     }
 948
 949   /* Read nested lists of elements.
 950    */
 951   if (c != '(')
 952     scm_i_input_error (NULL, port,
 953                        "missing '(' in vector or array literal",
 954                        SCM_EOL);
 955   scm_ungetc (c, port);
 956   elements = scm_read (port);
 957
 958   if (scm_is_false (shape))
 959     shape = scm_from_ssize_t (rank);
 960   else if (scm_ilength (shape) != rank)
 961     scm_i_input_error
 962       (NULL, port,
 963        "the number of shape specifications must match the array rank",
 964        SCM_EOL);
 965
 966   /* Handle special print syntax of rank zero arrays; see
 967      scm_i_print_array for a rationale.
 968   */
 969   if (rank == 0)
 970     {
 971       if (!scm_is_pair (elements))
 972         scm_i_input_error (NULL, port,
 973                            "too few elements in array literal, need 1",
 974                            SCM_EOL);
 975       if (!scm_is_null (SCM_CDR (elements)))
 976         scm_i_input_error (NULL, port,
 977                            "too many elements in array literal, want 1",
 978                            SCM_EOL);
 979       elements = SCM_CAR (elements);
 980     }
 981
 982   /* Construct array.
 983    */
 984   return scm_list_to_typed_array (tag, shape, elements);
 985 }
 986
 987
 988 static SCM
 989 array_handle_ref (scm_t_array_handle *h, size_t pos)
 990 {
 991   return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h->array), pos);
 992 }
 993
 994 static void
 995 array_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
 996 {
 997   scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h->array), pos, val);
 998 }
 999
1000 /* FIXME: should be handle for vect? maybe not, because of dims */
1001 static void
1002 array_get_handle (SCM array, scm_t_array_handle *h)
1003 {
1004   scm_t_array_handle vh;
1005   scm_array_get_handle (SCM_I_ARRAY_V (array), &vh);
1006   h->element_type = vh.element_type;
1007   h->elements = vh.elements;
1008   h->writable_elements = vh.writable_elements;
1009   scm_array_handle_release (&vh);
1010
1011   h->dims = SCM_I_ARRAY_DIMS (array);
1012   h->ndims = SCM_I_ARRAY_NDIM (array);
1013   h->base = SCM_I_ARRAY_BASE (array);
1014 }
1015
1016 SCM_ARRAY_IMPLEMENTATION (scm_tc7_array,
1017                           0x7f,
1018                           array_handle_ref, array_handle_set,
1019                           array_get_handle)
1020
1021 void
1022 scm_init_arrays ()
1023 {
1024   scm_add_feature ("array");
1025
1026 #include "libguile/arrays.x"
1027
1028 }
1029
1030 /*
1031   Local Variables:
1032   c-file-style: "gnu"
1033   End:
1034 */