libguile/arrays.c

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