libguile/arrays.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005,
   2  *   2006, 2009, 2010, 2011, 2012 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       /* byte_len ?= ceil (rlen * sz / 8) */
 246       if (byte_len != (rlen * sz + 7) / 8)
 247         SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
 248     }
 249   else
 250     /* an internal guile error, really */
 251     SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL);
 252
 253   memcpy (elts, bytes, byte_len);
 254
 255   if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
 256     if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
 257       return SCM_I_ARRAY_V (ra);
 258   return ra;
 259 }
 260 #undef FUNC_NAME
 261
 262 SCM
 263 scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len)
 264 #define FUNC_NAME "scm_from_contiguous_array"
 265 {
 266   size_t k, rlen = 1;
 267   scm_t_array_dim *s;
 268   SCM ra;
 269   scm_t_array_handle h;
 270
 271   ra = scm_i_shap2ra (bounds);
 272   SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
 273   s = SCM_I_ARRAY_DIMS (ra);
 274   k = SCM_I_ARRAY_NDIM (ra);
 275
 276   while (k--)
 277     {
 278       s[k].inc = rlen;
 279       SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
 280       rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
 281     }
 282   if (rlen != len)
 283     SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL);
 284
 285   SCM_I_ARRAY_V (ra) = scm_c_make_vector (rlen, SCM_UNDEFINED);
 286   scm_array_get_handle (ra, &h);
 287   memcpy (h.writable_elements, elts, rlen * sizeof(SCM));
 288   scm_array_handle_release (&h);
 289
 290   if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
 291     if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
 292       return SCM_I_ARRAY_V (ra);
 293   return ra;
 294 }
 295 #undef FUNC_NAME
 296
 297 SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
 298             (SCM fill, SCM bounds),
 299             "Create and return an array.")
 300 #define FUNC_NAME s_scm_make_array
 301 {
 302   return scm_make_typed_array (SCM_BOOL_T, fill, bounds);
 303 }
 304 #undef FUNC_NAME
 305
 306 static void
 307 scm_i_ra_set_contp (SCM ra)
 308 {
 309   size_t k = SCM_I_ARRAY_NDIM (ra);
 310   if (k)
 311     {
 312       long inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc;
 313       while (k--)
 314         {
 315           if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc)
 316             {
 317               SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
 318               return;
 319             }
 320           inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
 321                   - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
 322         }
 323     }
 324   SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
 325 }
 326
 327
 328 SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
 329            (SCM oldra, SCM mapfunc, SCM dims),
 330             "@code{make-shared-array} can be used to create shared subarrays\n"
 331             "of other arrays.  The @var{mapfunc} is a function that\n"
 332             "translates coordinates in the new array into coordinates in the\n"
 333             "old array.  A @var{mapfunc} must be linear, and its range must\n"
 334             "stay within the bounds of the old array, but it can be\n"
 335             "otherwise arbitrary.  A simple example:\n"
 336             "@lisp\n"
 337             "(define fred (make-array #f 8 8))\n"
 338             "(define freds-diagonal\n"
 339             "  (make-shared-array fred (lambda (i) (list i i)) 8))\n"
 340             "(array-set! freds-diagonal 'foo 3)\n"
 341             "(array-ref fred 3 3) @result{} foo\n"
 342             "(define freds-center\n"
 343             "  (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
 344             "(array-ref freds-center 0 0) @result{} foo\n"
 345             "@end lisp")
 346 #define FUNC_NAME s_scm_make_shared_array
 347 {
 348   scm_t_array_handle old_handle;
 349   SCM ra;
 350   SCM inds, indptr;
 351   SCM imap;
 352   size_t k;
 353   ssize_t i;
 354   long old_base, old_min, new_min, old_max, new_max;
 355   scm_t_array_dim *s;
 356
 357   SCM_VALIDATE_REST_ARGUMENT (dims);
 358   SCM_VALIDATE_PROC (2, mapfunc);
 359   ra = scm_i_shap2ra (dims);
 360
 361   scm_array_get_handle (oldra, &old_handle);
 362
 363   if (SCM_I_ARRAYP (oldra))
 364     {
 365       SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra);
 366       old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra);
 367       s = scm_array_handle_dims (&old_handle);
 368       k = scm_array_handle_rank (&old_handle);
 369       while (k--)
 370         {
 371           if (s[k].inc > 0)
 372             old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
 373           else
 374             old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
 375         }
 376     }
 377   else
 378     {
 379       SCM_I_ARRAY_V (ra) = oldra;
 380       old_base = old_min = 0;
 381       old_max = scm_c_generalized_vector_length (oldra) - 1;
 382     }
 383
 384   inds = SCM_EOL;
 385   s = SCM_I_ARRAY_DIMS (ra);
 386   for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
 387     {
 388       inds = scm_cons (scm_from_long (s[k].lbnd), inds);
 389       if (s[k].ubnd < s[k].lbnd)
 390         {
 391           if (1 == SCM_I_ARRAY_NDIM (ra))
 392             ra = scm_make_generalized_vector (scm_array_type (ra),
 393                                               SCM_INUM0, SCM_UNDEFINED);
 394           else
 395             SCM_I_ARRAY_V (ra) =
 396               scm_make_generalized_vector (scm_array_type (ra),
 397                                            SCM_INUM0, SCM_UNDEFINED);
 398           scm_array_handle_release (&old_handle);
 399           return ra;
 400         }
 401     }
 402
 403   imap = scm_apply_0 (mapfunc, scm_reverse (inds));
 404   i = scm_array_handle_pos (&old_handle, imap);
 405   SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base;
 406   indptr = inds;
 407   k = SCM_I_ARRAY_NDIM (ra);
 408   while (k--)
 409     {
 410       if (s[k].ubnd > s[k].lbnd)
 411         {
 412           SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1)));
 413           imap = scm_apply_0 (mapfunc, scm_reverse (inds));
 414           s[k].inc = scm_array_handle_pos (&old_handle, imap) - i;
 415           i += s[k].inc;
 416           if (s[k].inc > 0)
 417             new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
 418           else
 419             new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
 420         }
 421       else
 422         s[k].inc = new_max - new_min + 1;       /* contiguous by default */
 423       indptr = SCM_CDR (indptr);
 424     }
 425
 426   scm_array_handle_release (&old_handle);
 427
 428   if (old_min > new_min || old_max < new_max)
 429     SCM_MISC_ERROR ("mapping out of range", SCM_EOL);
 430   if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
 431     {
 432       SCM v = SCM_I_ARRAY_V (ra);
 433       size_t length = scm_c_generalized_vector_length (v);
 434       if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
 435         return v;
 436       if (s->ubnd < s->lbnd)
 437         return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0,
 438                                             SCM_UNDEFINED);
 439     }
 440   scm_i_ra_set_contp (ra);
 441   return ra;
 442 }
 443 #undef FUNC_NAME
 444
 445
 446 /* args are RA . DIMS */
 447 SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
 448            (SCM ra, SCM args),
 449             "Return an array sharing contents with @var{ra}, but with\n"
 450             "dimensions arranged in a different order.  There must be one\n"
 451             "@var{dim} argument for each dimension of @var{ra}.\n"
 452             "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
 453             "and the rank of the array to be returned.  Each integer in that\n"
 454             "range must appear at least once in the argument list.\n"
 455             "\n"
 456             "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
 457             "dimensions in the array to be returned, their positions in the\n"
 458             "argument list to dimensions of @var{ra}.  Several @var{dim}s\n"
 459             "may have the same value, in which case the returned array will\n"
 460             "have smaller rank than @var{ra}.\n"
 461             "\n"
 462             "@lisp\n"
 463             "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
 464             "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
 465             "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
 466             "                #2((a 4) (b 5) (c 6))\n"
 467             "@end lisp")
 468 #define FUNC_NAME s_scm_transpose_array
 469 {
 470   SCM res, vargs;
 471   scm_t_array_dim *s, *r;
 472   int ndim, i, k;
 473
 474   SCM_VALIDATE_REST_ARGUMENT (args);
 475   SCM_ASSERT (SCM_HEAP_OBJECT_P (ra), ra, SCM_ARG1, FUNC_NAME);
 476
 477   if (scm_is_generalized_vector (ra))
 478     {
 479       /* Make sure that we are called with a single zero as
 480          arguments.
 481       */
 482       if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
 483         SCM_WRONG_NUM_ARGS ();
 484       SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
 485       SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
 486       return ra;
 487     }
 488
 489   if (SCM_I_ARRAYP (ra))
 490     {
 491       vargs = scm_vector (args);
 492       if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
 493         SCM_WRONG_NUM_ARGS ();
 494       ndim = 0;
 495       for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
 496         {
 497           i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k),
 498                                      0, SCM_I_ARRAY_NDIM(ra));
 499           if (ndim < i)
 500             ndim = i;
 501         }
 502       ndim++;
 503       res = scm_i_make_array (ndim);
 504       SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra);
 505       SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra);
 506       for (k = ndim; k--;)
 507         {
 508           SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
 509           SCM_I_ARRAY_DIMS (res)[k].ubnd = -1;
 510         }
 511       for (k = SCM_I_ARRAY_NDIM (ra); k--;)
 512         {
 513           i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k));
 514           s = &(SCM_I_ARRAY_DIMS (ra)[k]);
 515           r = &(SCM_I_ARRAY_DIMS (res)[i]);
 516           if (r->ubnd < r->lbnd)
 517             {
 518               r->lbnd = s->lbnd;
 519               r->ubnd = s->ubnd;
 520               r->inc = s->inc;
 521               ndim--;
 522             }
 523           else
 524             {
 525               if (r->ubnd > s->ubnd)
 526                 r->ubnd = s->ubnd;
 527               if (r->lbnd < s->lbnd)
 528                 {
 529                   SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
 530                   r->lbnd = s->lbnd;
 531                 }
 532               r->inc += s->inc;
 533             }
 534         }
 535       if (ndim > 0)
 536         SCM_MISC_ERROR ("bad argument list", SCM_EOL);
 537       scm_i_ra_set_contp (res);
 538       return res;
 539     }
 540
 541   scm_wrong_type_arg_msg (NULL, 0, ra, "array");
 542 }
 543 #undef FUNC_NAME
 544
 545 /* attempts to unroll an array into a one-dimensional array.
 546    returns the unrolled array or #f if it can't be done.  */
 547   /* if strict is not SCM_UNDEFINED, return #f if returned array
 548                      wouldn't have contiguous elements.  */
 549 SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
 550            (SCM ra, SCM strict),
 551             "If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n"
 552             "array without changing their order (last subscript changing\n"
 553             "fastest), then @code{array-contents} returns that shared array,\n"
 554             "otherwise it returns @code{#f}.  All arrays made by\n"
 555             "@code{make-array} and @code{make-uniform-array} may be unrolled,\n"
 556             "some arrays made by @code{make-shared-array} may not be.  If\n"
 557             "the optional argument @var{strict} is provided, a shared array\n"
 558             "will be returned only if its elements are stored internally\n"
 559             "contiguous in memory.")
 560 #define FUNC_NAME s_scm_array_contents
 561 {
 562   SCM sra;
 563
 564   if (scm_is_generalized_vector (ra))
 565     return ra;
 566
 567   if (SCM_I_ARRAYP (ra))
 568     {
 569       size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
 570       if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra))
 571         return SCM_BOOL_F;
 572       for (k = 0; k < ndim; k++)
 573         len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
 574       if (!SCM_UNBNDP (strict) && scm_is_true (strict))
 575         {
 576           if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc))
 577             return SCM_BOOL_F;
 578           if (scm_is_bitvector (SCM_I_ARRAY_V (ra)))
 579             {
 580               if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
 581                   SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
 582                   len % SCM_LONG_BIT)
 583                 return SCM_BOOL_F;
 584             }
 585         }
 586
 587       {
 588         SCM v = SCM_I_ARRAY_V (ra);
 589         size_t length = scm_c_generalized_vector_length (v);
 590         if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc)
 591           return v;
 592       }
 593
 594       sra = scm_i_make_array (1);
 595       SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
 596       SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
 597       SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra);
 598       SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra);
 599       SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
 600       return sra;
 601     }
 602   else
 603     scm_wrong_type_arg_msg (NULL, 0, ra, "array");
 604 }
 605 #undef FUNC_NAME
 606
 607
 608 static void
 609 list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
 610 {
 611   if (k == scm_array_handle_rank (handle))
 612     scm_array_handle_set (handle, pos, lst);
 613   else
 614     {
 615       scm_t_array_dim *dim = scm_array_handle_dims (handle) + k;
 616       ssize_t inc = dim->inc;
 617       size_t len = 1 + dim->ubnd - dim->lbnd, n;
 618       char *errmsg = NULL;
 619
 620       n = len;
 621       while (n > 0 && scm_is_pair (lst))
 622         {
 623           list_to_array (SCM_CAR (lst), handle, pos, k + 1);
 624           pos += inc;
 625           lst = SCM_CDR (lst);
 626           n -= 1;
 627         }
 628       if (n != 0)
 629         errmsg = "too few elements for array dimension ~a, need ~a";
 630       if (!scm_is_null (lst))
 631         errmsg = "too many elements for array dimension ~a, want ~a";
 632       if (errmsg)
 633         scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k),
 634                                                   scm_from_size_t (len)));
 635     }
 636 }
 637
 638
 639 SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
 640            (SCM type, SCM shape, SCM lst),
 641             "Return an array of the type @var{type}\n"
 642             "with elements the same as those of @var{lst}.\n"
 643             "\n"
 644             "The argument @var{shape} determines the number of dimensions\n"
 645             "of the array and their shape.  It is either an exact integer,\n"
 646             "giving the\n"
 647             "number of dimensions directly, or a list whose length\n"
 648             "specifies the number of dimensions and each element specified\n"
 649             "the lower and optionally the upper bound of the corresponding\n"
 650             "dimension.\n"
 651             "When the element is list of two elements, these elements\n"
 652             "give the lower and upper bounds.  When it is an exact\n"
 653             "integer, it gives only the lower bound.")
 654 #define FUNC_NAME s_scm_list_to_typed_array
 655 {
 656   SCM row;
 657   SCM ra;
 658   scm_t_array_handle handle;
 659
 660   row = lst;
 661   if (scm_is_integer (shape))
 662     {
 663       size_t k = scm_to_size_t (shape);
 664       shape = SCM_EOL;
 665       while (k-- > 0)
 666         {
 667           shape = scm_cons (scm_length (row), shape);
 668           if (k > 0 && !scm_is_null (row))
 669             row = scm_car (row);
 670         }
 671     }
 672   else
 673     {
 674       SCM shape_spec = shape;
 675       shape = SCM_EOL;
 676       while (1)
 677         {
 678           SCM spec = scm_car (shape_spec);
 679           if (scm_is_pair (spec))
 680             shape = scm_cons (spec, shape);
 681           else
 682             shape = scm_cons (scm_list_2 (spec,
 683                                           scm_sum (scm_sum (spec,
 684                                                             scm_length (row)),
 685                                                    scm_from_int (-1))),
 686                               shape);
 687           shape_spec = scm_cdr (shape_spec);
 688           if (scm_is_pair (shape_spec))
 689             {
 690               if (!scm_is_null (row))
 691                 row = scm_car (row);
 692             }
 693           else
 694             break;
 695         }
 696     }
 697
 698   ra = scm_make_typed_array (type, SCM_UNSPECIFIED,
 699                              scm_reverse_x (shape, SCM_EOL));
 700
 701   scm_array_get_handle (ra, &handle);
 702   list_to_array (lst, &handle, 0, 0);
 703   scm_array_handle_release (&handle);
 704
 705   return ra;
 706 }
 707 #undef FUNC_NAME
 708
 709 SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0,
 710            (SCM ndim, SCM lst),
 711             "Return an array with elements the same as those of @var{lst}.")
 712 #define FUNC_NAME s_scm_list_to_array
 713 {
 714   return scm_list_to_typed_array (SCM_BOOL_T, ndim, lst);
 715 }
 716 #undef FUNC_NAME
 717
 718 /* Print dimension DIM of ARRAY.
 719  */
 720
 721 static int
 722 scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos,
 723                              SCM port, scm_print_state *pstate)
 724 {
 725   if (dim == h->ndims)
 726     scm_iprin1 (scm_array_handle_ref (h, pos), port, pstate);
 727   else
 728     {
 729       ssize_t i;
 730       scm_putc_unlocked ('(', port);
 731       for (i = h->dims[dim].lbnd; i <= h->dims[dim].ubnd;
 732            i++, pos += h->dims[dim].inc)
 733         {
 734           scm_i_print_array_dimension (h, dim+1, pos, port, pstate);
 735           if (i < h->dims[dim].ubnd)
 736             scm_putc_unlocked (' ', port);
 737         }
 738       scm_putc_unlocked (')', port);
 739     }
 740   return 1;
 741 }
 742
 743 /* Print an array.
 744 */
 745
 746 int
 747 scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
 748 {
 749   scm_t_array_handle h;
 750   long i;
 751   int print_lbnds = 0, zero_size = 0, print_lens = 0;
 752
 753   scm_array_get_handle (array, &h);
 754
 755   scm_putc_unlocked ('#', port);
 756   if (h.ndims != 1 || h.dims[0].lbnd != 0)
 757     scm_intprint (h.ndims, 10, port);
 758   if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
 759     scm_write (scm_array_handle_element_type (&h), port);
 760
 761   for (i = 0; i < h.ndims; i++)
 762     {
 763       if (h.dims[i].lbnd != 0)
 764         print_lbnds = 1;
 765       if (h.dims[i].ubnd - h.dims[i].lbnd + 1 == 0)
 766         zero_size = 1;
 767       else if (zero_size)
 768         print_lens = 1;
 769     }
 770
 771   if (print_lbnds || print_lens)
 772     for (i = 0; i < h.ndims; i++)
 773       {
 774         if (print_lbnds)
 775           {
 776             scm_putc_unlocked ('@', port);
 777             scm_intprint (h.dims[i].lbnd, 10, port);
 778           }
 779         if (print_lens)
 780           {
 781             scm_putc_unlocked (':', port);
 782             scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1,
 783                           10, port);
 784           }
 785       }
 786
 787   if (h.ndims == 0)
 788     {
 789       /* Rank zero arrays, which are really just scalars, are printed
 790          specially.  The consequent way would be to print them as
 791
 792             #0 OBJ
 793
 794          where OBJ is the printed representation of the scalar, but we
 795          print them instead as
 796
 797             #0(OBJ)
 798
 799          to make them look less strange.
 800
 801          Just printing them as
 802
 803             OBJ
 804
 805          would be correct in a way as well, but zero rank arrays are
 806          not really the same as Scheme values since they are boxed and
 807          can be modified with array-set!, say.
 808       */
 809       scm_putc_unlocked ('(', port);
 810       scm_i_print_array_dimension (&h, 0, 0, port, pstate);
 811       scm_putc_unlocked (')', port);
 812       return 1;
 813     }
 814   else
 815     return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
 816 }
 817
 818 static SCM
 819 array_handle_ref (scm_t_array_handle *h, size_t pos)
 820 {
 821   return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h->array), pos);
 822 }
 823
 824 static void
 825 array_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
 826 {
 827   scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h->array), pos, val);
 828 }
 829
 830 /* FIXME: should be handle for vect? maybe not, because of dims */
 831 static void
 832 array_get_handle (SCM array, scm_t_array_handle *h)
 833 {
 834   scm_t_array_handle vh;
 835   scm_array_get_handle (SCM_I_ARRAY_V (array), &vh);
 836   h->element_type = vh.element_type;
 837   h->elements = vh.elements;
 838   h->writable_elements = vh.writable_elements;
 839   scm_array_handle_release (&vh);
 840
 841   h->dims = SCM_I_ARRAY_DIMS (array);
 842   h->ndims = SCM_I_ARRAY_NDIM (array);
 843   h->base = SCM_I_ARRAY_BASE (array);
 844 }
 845
 846 SCM_ARRAY_IMPLEMENTATION (scm_tc7_array,
 847                           0x7f,
 848                           array_handle_ref, array_handle_set,
 849                           array_get_handle)
 850
 851 void
 852 scm_init_arrays ()
 853 {
 854   scm_add_feature ("array");
 855
 856 #include "libguile/arrays.x"
 857
 858 }
 859
 860 /*
 861   Local Variables:
 862   c-file-style: "gnu"
 863   End:
 864 */