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\n"
 330             "of other arrays.  The @var{mapfunc} is a function that\n"
 331             "translates coordinates in the new array into coordinates in the\n"
 332             "old array.  A @var{mapfunc} must be linear, and its range must\n"
 333             "stay within the bounds of the old array, but it can be\n"
 334             "otherwise arbitrary.  A simple example:\n"
 335             "@lisp\n"
 336             "(define fred (make-array #f 8 8))\n"
 337             "(define freds-diagonal\n"
 338             "  (make-shared-array fred (lambda (i) (list i i)) 8))\n"
 339             "(array-set! freds-diagonal 'foo 3)\n"
 340             "(array-ref fred 3 3) @result{} foo\n"
 341             "(define freds-center\n"
 342             "  (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
 343             "(array-ref freds-center 0 0) @result{} foo\n"
 344             "@end lisp")
 345 #define FUNC_NAME s_scm_make_shared_array
 346 {
 347   scm_t_array_handle old_handle;
 348   SCM ra;
 349   SCM inds, indptr;
 350   SCM imap;
 351   size_t k;
 352   ssize_t i;
 353   long old_base, old_min, new_min, old_max, new_max;
 354   scm_t_array_dim *s;
 355
 356   SCM_VALIDATE_REST_ARGUMENT (dims);
 357   SCM_VALIDATE_PROC (2, mapfunc);
 358   ra = scm_i_shap2ra (dims);
 359
 360   scm_array_get_handle (oldra, &old_handle);
 361
 362   if (SCM_I_ARRAYP (oldra))
 363     {
 364       SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra);
 365       old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra);
 366       s = scm_array_handle_dims (&old_handle);
 367       k = scm_array_handle_rank (&old_handle);
 368       while (k--)
 369         {
 370           if (s[k].inc > 0)
 371             old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
 372           else
 373             old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
 374         }
 375     }
 376   else
 377     {
 378       SCM_I_ARRAY_V (ra) = oldra;
 379       old_base = old_min = 0;
 380       old_max = scm_c_generalized_vector_length (oldra) - 1;
 381     }
 382
 383   inds = SCM_EOL;
 384   s = SCM_I_ARRAY_DIMS (ra);
 385   for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
 386     {
 387       inds = scm_cons (scm_from_long (s[k].lbnd), inds);
 388       if (s[k].ubnd < s[k].lbnd)
 389         {
 390           if (1 == SCM_I_ARRAY_NDIM (ra))
 391             ra = scm_make_generalized_vector (scm_array_type (ra),
 392                                               SCM_INUM0, SCM_UNDEFINED);
 393           else
 394             SCM_I_ARRAY_V (ra) =
 395               scm_make_generalized_vector (scm_array_type (ra),
 396                                            SCM_INUM0, SCM_UNDEFINED);
 397           scm_array_handle_release (&old_handle);
 398           return ra;
 399         }
 400     }
 401
 402   imap = scm_apply_0 (mapfunc, scm_reverse (inds));
 403   i = scm_array_handle_pos (&old_handle, imap);
 404   SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base;
 405   indptr = inds;
 406   k = SCM_I_ARRAY_NDIM (ra);
 407   while (k--)
 408     {
 409       if (s[k].ubnd > s[k].lbnd)
 410         {
 411           SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1)));
 412           imap = scm_apply_0 (mapfunc, scm_reverse (inds));
 413           s[k].inc = scm_array_handle_pos (&old_handle, imap) - i;
 414           i += s[k].inc;
 415           if (s[k].inc > 0)
 416             new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
 417           else
 418             new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
 419         }
 420       else
 421         s[k].inc = new_max - new_min + 1;       /* contiguous by default */
 422       indptr = SCM_CDR (indptr);
 423     }
 424
 425   scm_array_handle_release (&old_handle);
 426
 427   if (old_min > new_min || old_max < new_max)
 428     SCM_MISC_ERROR ("mapping out of range", SCM_EOL);
 429   if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
 430     {
 431       SCM v = SCM_I_ARRAY_V (ra);
 432       size_t length = scm_c_generalized_vector_length (v);
 433       if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
 434         return v;
 435       if (s->ubnd < s->lbnd)
 436         return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0,
 437                                             SCM_UNDEFINED);
 438     }
 439   scm_i_ra_set_contp (ra);
 440   return ra;
 441 }
 442 #undef FUNC_NAME
 443
 444
 445 /* args are RA . DIMS */
 446 SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
 447            (SCM ra, SCM args),
 448             "Return an array sharing contents with @var{ra}, but with\n"
 449             "dimensions arranged in a different order.  There must be one\n"
 450             "@var{dim} argument for each dimension of @var{ra}.\n"
 451             "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
 452             "and the rank of the array to be returned.  Each integer in that\n"
 453             "range must appear at least once in the argument list.\n"
 454             "\n"
 455             "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
 456             "dimensions in the array to be returned, their positions in the\n"
 457             "argument list to dimensions of @var{ra}.  Several @var{dim}s\n"
 458             "may have the same value, in which case the returned array will\n"
 459             "have smaller rank than @var{ra}.\n"
 460             "\n"
 461             "@lisp\n"
 462             "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
 463             "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
 464             "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
 465             "                #2((a 4) (b 5) (c 6))\n"
 466             "@end lisp")
 467 #define FUNC_NAME s_scm_transpose_array
 468 {
 469   SCM res, vargs;
 470   scm_t_array_dim *s, *r;
 471   int ndim, i, k;
 472
 473   SCM_VALIDATE_REST_ARGUMENT (args);
 474   SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME);
 475
 476   if (scm_is_generalized_vector (ra))
 477     {
 478       /* Make sure that we are called with a single zero as
 479          arguments.
 480       */
 481       if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
 482         SCM_WRONG_NUM_ARGS ();
 483       SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
 484       SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
 485       return ra;
 486     }
 487
 488   if (SCM_I_ARRAYP (ra))
 489     {
 490       vargs = scm_vector (args);
 491       if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
 492         SCM_WRONG_NUM_ARGS ();
 493       ndim = 0;
 494       for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
 495         {
 496           i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k),
 497                                      0, SCM_I_ARRAY_NDIM(ra));
 498           if (ndim < i)
 499             ndim = i;
 500         }
 501       ndim++;
 502       res = scm_i_make_array (ndim);
 503       SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra);
 504       SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra);
 505       for (k = ndim; k--;)
 506         {
 507           SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
 508           SCM_I_ARRAY_DIMS (res)[k].ubnd = -1;
 509         }
 510       for (k = SCM_I_ARRAY_NDIM (ra); k--;)
 511         {
 512           i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k));
 513           s = &(SCM_I_ARRAY_DIMS (ra)[k]);
 514           r = &(SCM_I_ARRAY_DIMS (res)[i]);
 515           if (r->ubnd < r->lbnd)
 516             {
 517               r->lbnd = s->lbnd;
 518               r->ubnd = s->ubnd;
 519               r->inc = s->inc;
 520               ndim--;
 521             }
 522           else
 523             {
 524               if (r->ubnd > s->ubnd)
 525                 r->ubnd = s->ubnd;
 526               if (r->lbnd < s->lbnd)
 527                 {
 528                   SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
 529                   r->lbnd = s->lbnd;
 530                 }
 531               r->inc += s->inc;
 532             }
 533         }
 534       if (ndim > 0)
 535         SCM_MISC_ERROR ("bad argument list", SCM_EOL);
 536       scm_i_ra_set_contp (res);
 537       return res;
 538     }
 539
 540   scm_wrong_type_arg_msg (NULL, 0, ra, "array");
 541 }
 542 #undef FUNC_NAME
 543
 544 /* attempts to unroll an array into a one-dimensional array.
 545    returns the unrolled array or #f if it can't be done.  */
 546   /* if strict is not SCM_UNDEFINED, return #f if returned array
 547                      wouldn't have contiguous elements.  */
 548 SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
 549            (SCM ra, SCM strict),
 550             "If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n"
 551             "array without changing their order (last subscript changing\n"
 552             "fastest), then @code{array-contents} returns that shared array,\n"
 553             "otherwise it returns @code{#f}.  All arrays made by\n"
 554             "@code{make-array} and @code{make-uniform-array} may be unrolled,\n"
 555             "some arrays made by @code{make-shared-array} may not be.  If\n"
 556             "the optional argument @var{strict} is provided, a shared array\n"
 557             "will be returned only if its elements are stored internally\n"
 558             "contiguous in memory.")
 559 #define FUNC_NAME s_scm_array_contents
 560 {
 561   SCM sra;
 562
 563   if (scm_is_generalized_vector (ra))
 564     return ra;
 565
 566   if (SCM_I_ARRAYP (ra))
 567     {
 568       size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
 569       if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra))
 570         return SCM_BOOL_F;
 571       for (k = 0; k < ndim; k++)
 572         len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
 573       if (!SCM_UNBNDP (strict) && scm_is_true (strict))
 574         {
 575           if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc))
 576             return SCM_BOOL_F;
 577           if (scm_is_bitvector (SCM_I_ARRAY_V (ra)))
 578             {
 579               if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
 580                   SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
 581                   len % SCM_LONG_BIT)
 582                 return SCM_BOOL_F;
 583             }
 584         }
 585
 586       {
 587         SCM v = SCM_I_ARRAY_V (ra);
 588         size_t length = scm_c_generalized_vector_length (v);
 589         if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc)
 590           return v;
 591       }
 592
 593       sra = scm_i_make_array (1);
 594       SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
 595       SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
 596       SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra);
 597       SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra);
 598       SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
 599       return sra;
 600     }
 601   else
 602     scm_wrong_type_arg_msg (NULL, 0, ra, "array");
 603 }
 604 #undef FUNC_NAME
 605
 606
 607 static void
 608 list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
 609 {
 610   if (k == scm_array_handle_rank (handle))
 611     scm_array_handle_set (handle, pos, lst);
 612   else
 613     {
 614       scm_t_array_dim *dim = scm_array_handle_dims (handle) + k;
 615       ssize_t inc = dim->inc;
 616       size_t len = 1 + dim->ubnd - dim->lbnd, n;
 617       char *errmsg = NULL;
 618
 619       n = len;
 620       while (n > 0 && scm_is_pair (lst))
 621         {
 622           list_to_array (SCM_CAR (lst), handle, pos, k + 1);
 623           pos += inc;
 624           lst = SCM_CDR (lst);
 625           n -= 1;
 626         }
 627       if (n != 0)
 628         errmsg = "too few elements for array dimension ~a, need ~a";
 629       if (!scm_is_null (lst))
 630         errmsg = "too many elements for array dimension ~a, want ~a";
 631       if (errmsg)
 632         scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k),
 633                                                   scm_from_size_t (len)));
 634     }
 635 }
 636
 637
 638 SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
 639            (SCM type, SCM shape, SCM lst),
 640             "Return an array of the type @var{type}\n"
 641             "with elements the same as those of @var{lst}.\n"
 642             "\n"
 643             "The argument @var{shape} determines the number of dimensions\n"
 644             "of the array and their shape.  It is either an exact integer,\n"
 645             "giving the\n"
 646             "number of dimensions directly, or a list whose length\n"
 647             "specifies the number of dimensions and each element specified\n"
 648             "the lower and optionally the upper bound of the corresponding\n"
 649             "dimension.\n"
 650             "When the element is list of two elements, these elements\n"
 651             "give the lower and upper bounds.  When it is an exact\n"
 652             "integer, it gives only the lower bound.")
 653 #define FUNC_NAME s_scm_list_to_typed_array
 654 {
 655   SCM row;
 656   SCM ra;
 657   scm_t_array_handle handle;
 658
 659   row = lst;
 660   if (scm_is_integer (shape))
 661     {
 662       size_t k = scm_to_size_t (shape);
 663       shape = SCM_EOL;
 664       while (k-- > 0)
 665         {
 666           shape = scm_cons (scm_length (row), shape);
 667           if (k > 0 && !scm_is_null (row))
 668             row = scm_car (row);
 669         }
 670     }
 671   else
 672     {
 673       SCM shape_spec = shape;
 674       shape = SCM_EOL;
 675       while (1)
 676         {
 677           SCM spec = scm_car (shape_spec);
 678           if (scm_is_pair (spec))
 679             shape = scm_cons (spec, shape);
 680           else
 681             shape = scm_cons (scm_list_2 (spec,
 682                                           scm_sum (scm_sum (spec,
 683                                                             scm_length (row)),
 684                                                    scm_from_int (-1))),
 685                               shape);
 686           shape_spec = scm_cdr (shape_spec);
 687           if (scm_is_pair (shape_spec))
 688             {
 689               if (!scm_is_null (row))
 690                 row = scm_car (row);
 691             }
 692           else
 693             break;
 694         }
 695     }
 696
 697   ra = scm_make_typed_array (type, SCM_UNSPECIFIED,
 698                              scm_reverse_x (shape, SCM_EOL));
 699
 700   scm_array_get_handle (ra, &handle);
 701   list_to_array (lst, &handle, 0, 0);
 702   scm_array_handle_release (&handle);
 703
 704   return ra;
 705 }
 706 #undef FUNC_NAME
 707
 708 SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0,
 709            (SCM ndim, SCM lst),
 710             "Return an array with elements the same as those of @var{lst}.")
 711 #define FUNC_NAME s_scm_list_to_array
 712 {
 713   return scm_list_to_typed_array (SCM_BOOL_T, ndim, lst);
 714 }
 715 #undef FUNC_NAME
 716
 717 /* Print dimension DIM of ARRAY.
 718  */
 719
 720 static int
 721 scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos,
 722                              SCM port, scm_print_state *pstate)
 723 {
 724   if (dim == h->ndims)
 725     scm_iprin1 (scm_array_handle_ref (h, pos), port, pstate);
 726   else
 727     {
 728       ssize_t i;
 729       scm_putc ('(', port);
 730       for (i = h->dims[dim].lbnd; i <= h->dims[dim].ubnd;
 731            i++, pos += h->dims[dim].inc)
 732         {
 733           scm_i_print_array_dimension (h, dim+1, pos, port, pstate);
 734           if (i < h->dims[dim].ubnd)
 735             scm_putc (' ', port);
 736         }
 737       scm_putc (')', port);
 738     }
 739   return 1;
 740 }
 741
 742 /* Print an array.
 743 */
 744
 745 int
 746 scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
 747 {
 748   scm_t_array_handle h;
 749   long i;
 750   int print_lbnds = 0, zero_size = 0, print_lens = 0;
 751
 752   scm_array_get_handle (array, &h);
 753
 754   scm_putc ('#', port);
 755   if (h.ndims != 1 || h.dims[0].lbnd != 0)
 756     scm_intprint (h.ndims, 10, port);
 757   if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
 758     scm_write (scm_array_handle_element_type (&h), port);
 759
 760   for (i = 0; i < h.ndims; i++)
 761     {
 762       if (h.dims[i].lbnd != 0)
 763         print_lbnds = 1;
 764       if (h.dims[i].ubnd - h.dims[i].lbnd + 1 == 0)
 765         zero_size = 1;
 766       else if (zero_size)
 767         print_lens = 1;
 768     }
 769
 770   if (print_lbnds || print_lens)
 771     for (i = 0; i < h.ndims; i++)
 772       {
 773         if (print_lbnds)
 774           {
 775             scm_putc ('@', port);
 776             scm_intprint (h.dims[i].lbnd, 10, port);
 777           }
 778         if (print_lens)
 779           {
 780             scm_putc (':', port);
 781             scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1,
 782                           10, port);
 783           }
 784       }
 785
 786   if (h.ndims == 0)
 787     {
 788       /* Rank zero arrays, which are really just scalars, are printed
 789          specially.  The consequent way would be to print them as
 790
 791             #0 OBJ
 792
 793          where OBJ is the printed representation of the scalar, but we
 794          print them instead as
 795
 796             #0(OBJ)
 797
 798          to make them look less strange.
 799
 800          Just printing them as
 801
 802             OBJ
 803
 804          would be correct in a way as well, but zero rank arrays are
 805          not really the same as Scheme values since they are boxed and
 806          can be modified with array-set!, say.
 807       */
 808       scm_putc ('(', port);
 809       scm_i_print_array_dimension (&h, 0, 0, port, pstate);
 810       scm_putc (')', port);
 811       return 1;
 812     }
 813   else
 814     return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
 815 }
 816
 817 /* Read an array.  This function can also read vectors and uniform
 818    vectors.  Also, the conflict between '#f' and '#f32' and '#f64' is
 819    handled here.
 820
 821    C is the first character read after the '#'.
 822 */
 823
 824 static int
 825 read_decimal_integer (SCM port, int c, ssize_t *resp)
 826 {
 827   ssize_t sign = 1;
 828   ssize_t res = 0;
 829   int got_it = 0;
 830
 831   if (c == '-')
 832     {
 833       sign = -1;
 834       c = scm_getc (port);
 835     }
 836
 837   while ('0' <= c && c <= '9')
 838     {
 839       res = 10*res + c-'0';
 840       got_it = 1;
 841       c = scm_getc (port);
 842     }
 843
 844   if (got_it)
 845     *resp = sign * res;
 846   return c;
 847 }
 848
 849 SCM
 850 scm_i_read_array (SCM port, int c)
 851 {
 852   ssize_t rank;
 853   scm_t_wchar tag_buf[8];
 854   int tag_len;
 855
 856   SCM tag, shape = SCM_BOOL_F, elements;
 857
 858   /* XXX - shortcut for ordinary vectors.  Shouldn't be necessary but
 859      the array code can not deal with zero-length dimensions yet, and
 860      we want to allow zero-length vectors, of course.
 861   */
 862   if (c == '(')
 863     {
 864       scm_ungetc (c, port);
 865       return scm_vector (scm_read (port));
 866     }
 867
 868   /* Disambiguate between '#f' and uniform floating point vectors.
 869    */
 870   if (c == 'f')
 871     {
 872       c = scm_getc (port);
 873       if (c != '3' && c != '6')
 874         {
 875           if (c != EOF)
 876             scm_ungetc (c, port);
 877           return SCM_BOOL_F;
 878         }
 879       rank = 1;
 880       tag_buf[0] = 'f';
 881       tag_len = 1;
 882       goto continue_reading_tag;
 883     }
 884
 885   /* Read rank.
 886    */
 887   rank = 1;
 888   c = read_decimal_integer (port, c, &rank);
 889   if (rank < 0)
 890     scm_i_input_error (NULL, port, "array rank must be non-negative",
 891                        SCM_EOL);
 892
 893   /* Read tag.
 894    */
 895   tag_len = 0;
 896  continue_reading_tag:
 897   while (c != EOF && c != '(' && c != '@' && c != ':'
 898          && tag_len < sizeof tag_buf / sizeof tag_buf[0])
 899     {
 900       tag_buf[tag_len++] = c;
 901       c = scm_getc (port);
 902     }
 903   if (tag_len == 0)
 904     tag = SCM_BOOL_T;
 905   else
 906     {
 907       tag = scm_string_to_symbol (scm_from_utf32_stringn (tag_buf, tag_len));
 908       if (tag_len == sizeof tag_buf / sizeof tag_buf[0])
 909         scm_i_input_error (NULL, port, "invalid array tag, starting with: ~a",
 910                            scm_list_1 (tag));
 911     }
 912
 913   /* Read shape.
 914    */
 915   if (c == '@' || c == ':')
 916     {
 917       shape = SCM_EOL;
 918
 919       do
 920         {
 921           ssize_t lbnd = 0, len = 0;
 922           SCM s;
 923
 924           if (c == '@')
 925             {
 926               c = scm_getc (port);
 927               c = read_decimal_integer (port, c, &lbnd);
 928             }
 929
 930           s = scm_from_ssize_t (lbnd);
 931
 932           if (c == ':')
 933             {
 934               c = scm_getc (port);
 935               c = read_decimal_integer (port, c, &len);
 936               if (len < 0)
 937                 scm_i_input_error (NULL, port,
 938                                    "array length must be non-negative",
 939                                    SCM_EOL);
 940
 941               s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1));
 942             }
 943
 944           shape = scm_cons (s, shape);
 945         } while (c == '@' || c == ':');
 946
 947       shape = scm_reverse_x (shape, SCM_EOL);
 948     }
 949
 950   /* Read nested lists of elements.
 951    */
 952   if (c != '(')
 953     scm_i_input_error (NULL, port,
 954                        "missing '(' in vector or array literal",
 955                        SCM_EOL);
 956   scm_ungetc (c, port);
 957   elements = scm_read (port);
 958
 959   if (scm_is_false (shape))
 960     shape = scm_from_ssize_t (rank);
 961   else if (scm_ilength (shape) != rank)
 962     scm_i_input_error
 963       (NULL, port,
 964        "the number of shape specifications must match the array rank",
 965        SCM_EOL);
 966
 967   /* Handle special print syntax of rank zero arrays; see
 968      scm_i_print_array for a rationale.
 969   */
 970   if (rank == 0)
 971     {
 972       if (!scm_is_pair (elements))
 973         scm_i_input_error (NULL, port,
 974                            "too few elements in array literal, need 1",
 975                            SCM_EOL);
 976       if (!scm_is_null (SCM_CDR (elements)))
 977         scm_i_input_error (NULL, port,
 978                            "too many elements in array literal, want 1",
 979                            SCM_EOL);
 980       elements = SCM_CAR (elements);
 981     }
 982
 983   /* Construct array.
 984    */
 985   return scm_list_to_typed_array (tag, shape, elements);
 986 }
 987
 988
 989 static SCM
 990 array_handle_ref (scm_t_array_handle *h, size_t pos)
 991 {
 992   return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h->array), pos);
 993 }
 994
 995 static void
 996 array_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
 997 {
 998   scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h->array), pos, val);
 999 }
1000
1001 /* FIXME: should be handle for vect? maybe not, because of dims */
1002 static void
1003 array_get_handle (SCM array, scm_t_array_handle *h)
1004 {
1005   scm_t_array_handle vh;
1006   scm_array_get_handle (SCM_I_ARRAY_V (array), &vh);
1007   h->element_type = vh.element_type;
1008   h->elements = vh.elements;
1009   h->writable_elements = vh.writable_elements;
1010   scm_array_handle_release (&vh);
1011
1012   h->dims = SCM_I_ARRAY_DIMS (array);
1013   h->ndims = SCM_I_ARRAY_NDIM (array);
1014   h->base = SCM_I_ARRAY_BASE (array);
1015 }
1016
1017 SCM_ARRAY_IMPLEMENTATION (scm_tc7_array,
1018                           0x7f,
1019                           array_handle_ref, array_handle_set,
1020                           array_get_handle)
1021
1022 void
1023 scm_init_arrays ()
1024 {
1025   scm_add_feature ("array");
1026
1027 #include "libguile/arrays.x"
1028
1029 }
1030
1031 /*
1032   Local Variables:
1033   c-file-style: "gnu"
1034   End:
1035 */