libguile/arrays.c

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