libguile/arrays.c

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