guile18/libguile/unif.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  18
  19 /*
  20   This file has code for arrays in lots of variants (double, integer,
  21   unsigned etc. ). It suffers from hugely repetitive code because
  22   there is similar (but different) code for every variant included. (urg.)
  23
  24   --hwn
  25 */
  26 \f
  27
  28 #ifdef HAVE_CONFIG_H
  29 #  include <config.h>
  30 #endif
  31
  32 #include <stdio.h>
  33 #include <errno.h>
  34 #include <string.h>
  35
  36 #include "libguile/_scm.h"
  37 #include "libguile/__scm.h"
  38 #include "libguile/eq.h"
  39 #include "libguile/chars.h"
  40 #include "libguile/eval.h"
  41 #include "libguile/fports.h"
  42 #include "libguile/smob.h"
  43 #include "libguile/feature.h"
  44 #include "libguile/root.h"
  45 #include "libguile/strings.h"
  46 #include "libguile/srfi-13.h"
  47 #include "libguile/srfi-4.h"
  48 #include "libguile/vectors.h"
  49 #include "libguile/list.h"
  50 #include "libguile/deprecation.h"
  51 #include "libguile/dynwind.h"
  52
  53 #include "libguile/validate.h"
  54 #include "libguile/unif.h"
  55 #include "libguile/ramap.h"
  56 #include "libguile/print.h"
  57 #include "libguile/read.h"
  58
  59 #ifdef HAVE_UNISTD_H
  60 #include <unistd.h>
  61 #endif
  62
  63 #ifdef HAVE_IO_H
  64 #include <io.h>
  65 #endif
  66
  67 \f
  68 /* The set of uniform scm_vector types is:
  69  *  Vector of:           Called:   Replaced by:
  70  * unsigned char        string
  71  * char                 byvect     s8 or u8, depending on signedness of 'char'
  72  * boolean              bvect
  73  * signed long          ivect      s32
  74  * unsigned long        uvect      u32
  75  * float                fvect      f32
  76  * double               dvect      d32
  77  * complex double       cvect      c64
  78  * short                svect      s16
  79  * long long            llvect     s64
  80  */
  81
  82 scm_t_bits scm_i_tc16_array;
  83 scm_t_bits scm_i_tc16_enclosed_array;
  84
  85 #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
  86   (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
  87 #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
  88   (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
  89
  90 typedef SCM creator_proc (SCM len, SCM fill);
  91
  92 struct {
  93   char *type_name;
  94   SCM type;
  95   creator_proc *creator;
  96 } type_creator_table[] = {
  97   { "a", SCM_UNSPECIFIED, scm_make_string },
  98   { "b", SCM_UNSPECIFIED, scm_make_bitvector },
  99   { "u8", SCM_UNSPECIFIED, scm_make_u8vector },
 100   { "s8", SCM_UNSPECIFIED, scm_make_s8vector },
 101   { "u16", SCM_UNSPECIFIED, scm_make_u16vector },
 102   { "s16", SCM_UNSPECIFIED, scm_make_s16vector },
 103   { "u32", SCM_UNSPECIFIED, scm_make_u32vector },
 104   { "s32", SCM_UNSPECIFIED, scm_make_s32vector },
 105   { "u64", SCM_UNSPECIFIED, scm_make_u64vector },
 106   { "s64", SCM_UNSPECIFIED, scm_make_s64vector },
 107   { "f32", SCM_UNSPECIFIED, scm_make_f32vector },
 108   { "f64", SCM_UNSPECIFIED, scm_make_f64vector },
 109   { "c32", SCM_UNSPECIFIED, scm_make_c32vector },
 110   { "c64", SCM_UNSPECIFIED, scm_make_c64vector },
 111   { NULL }
 112 };
 113
 114 static void
 115 init_type_creator_table ()
 116 {
 117   int i;
 118   for (i = 0; type_creator_table[i].type_name; i++)
 119     {
 120       SCM sym = scm_from_locale_symbol (type_creator_table[i].type_name);
 121       type_creator_table[i].type = scm_permanent_object (sym);
 122     }
 123 }
 124
 125 static creator_proc *
 126 type_to_creator (SCM type)
 127 {
 128   int i;
 129
 130   if (scm_is_eq (type, SCM_BOOL_T))
 131     return scm_make_vector;
 132   for (i = 0; type_creator_table[i].type_name; i++)
 133     if (scm_is_eq (type, type_creator_table[i].type))
 134       return type_creator_table[i].creator;
 135
 136   scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (type));
 137 }
 138
 139 static SCM
 140 make_typed_vector (SCM type, size_t len)
 141 {
 142   creator_proc *creator = type_to_creator (type);
 143   return creator (scm_from_size_t (len), SCM_UNDEFINED);
 144 }
 145
 146 #if SCM_ENABLE_DEPRECATED
 147
 148 SCM_SYMBOL (scm_sym_s, "s");
 149 SCM_SYMBOL (scm_sym_l, "l");
 150
 151 static int
 152 singp (SCM obj)
 153 {
 154   if (!SCM_REALP (obj))
 155     return 0;
 156   else
 157     {
 158       double x = SCM_REAL_VALUE (obj);
 159       float fx = x;
 160       return (- SCM_FLTMAX < x) && (x < SCM_FLTMAX) && (fx == x);
 161     }
 162 }
 163
 164 SCM_API int scm_i_inump (SCM obj);
 165 SCM_API scm_t_signed_bits scm_i_inum (SCM obj);
 166
 167 static SCM
 168 prototype_to_type (SCM proto)
 169 {
 170   const char *type_name;
 171
 172   if (scm_is_eq (proto, SCM_BOOL_T))
 173     type_name = "b";
 174   else if (scm_is_eq (proto, SCM_MAKE_CHAR (0)))
 175     type_name = "s8";
 176   else if (SCM_CHARP (proto))
 177     type_name = "a";
 178   else if (scm_i_inump (proto))
 179     {
 180       if (scm_i_inum (proto) > 0)
 181         type_name = "u32";
 182       else
 183         type_name = "s32";
 184     }
 185   else if (scm_is_eq (proto, scm_sym_s))
 186     type_name = "s16";
 187   else if (scm_is_eq (proto, scm_sym_l))
 188     type_name = "s64";
 189   else if (SCM_REALP (proto)
 190            || scm_is_true (scm_eqv_p (proto,
 191                                       scm_divide (scm_from_int (1),
 192                                                   scm_from_int (3)))))
 193     {
 194       if (singp (proto))
 195         type_name = "f32";
 196       else
 197         type_name = "f64";
 198     }
 199   else if (SCM_COMPLEXP (proto))
 200     type_name = "c64";
 201   else if (scm_is_null (proto))
 202     type_name = NULL;
 203   else
 204     type_name = NULL;
 205
 206   if (type_name)
 207     return scm_from_locale_symbol (type_name);
 208   else
 209     return SCM_BOOL_T;
 210 }
 211
 212 static SCM
 213 scm_i_get_old_prototype (SCM uvec)
 214 {
 215   if (scm_is_bitvector (uvec))
 216     return SCM_BOOL_T;
 217   else if (scm_is_string (uvec))
 218     return SCM_MAKE_CHAR ('a');
 219   else if (scm_is_true (scm_s8vector_p (uvec)))
 220     return SCM_MAKE_CHAR ('\0');
 221   else if (scm_is_true (scm_s16vector_p (uvec)))
 222     return scm_sym_s;
 223   else if (scm_is_true (scm_u32vector_p (uvec)))
 224     return scm_from_int (1);
 225   else if (scm_is_true (scm_s32vector_p (uvec)))
 226     return scm_from_int (-1);
 227   else if (scm_is_true (scm_s64vector_p (uvec)))
 228     return scm_sym_l;
 229   else if (scm_is_true (scm_f32vector_p (uvec)))
 230     return scm_from_double (1.0);
 231   else if (scm_is_true (scm_f64vector_p (uvec)))
 232     return scm_divide (scm_from_int (1), scm_from_int (3));
 233   else if (scm_is_true (scm_c64vector_p (uvec)))
 234     return scm_c_make_rectangular (0, 1);
 235   else if (scm_is_vector (uvec))
 236     return SCM_EOL;
 237   else
 238     scm_misc_error (NULL, "~a has no prototype", scm_list_1 (uvec));
 239 }
 240
 241 SCM
 242 scm_make_uve (long k, SCM prot)
 243 #define FUNC_NAME "scm_make_uve"
 244 {
 245   scm_c_issue_deprecation_warning
 246     ("`scm_make_uve' is deprecated, see the manual for alternatives.");
 247
 248   return make_typed_vector (prototype_to_type (prot), k);
 249 }
 250 #undef FUNC_NAME
 251
 252 #endif
 253
 254 int
 255 scm_is_array (SCM obj)
 256 {
 257   return (SCM_I_ENCLOSED_ARRAYP (obj)
 258           || SCM_I_ARRAYP (obj)
 259           || scm_is_generalized_vector (obj));
 260 }
 261
 262 int
 263 scm_is_typed_array (SCM obj, SCM type)
 264 {
 265   if (SCM_I_ENCLOSED_ARRAYP (obj))
 266     {
 267       /* Enclosed arrays are arrays but are not of any type.
 268       */
 269       return 0;
 270     }
 271
 272   /* Get storage vector.
 273    */
 274   if (SCM_I_ARRAYP (obj))
 275     obj = SCM_I_ARRAY_V (obj);
 276
 277   /* It must be a generalized vector (which includes vectors, strings, etc).
 278    */
 279   if (!scm_is_generalized_vector (obj))
 280     return 0;
 281
 282   return scm_is_eq (type, scm_i_generalized_vector_type (obj));
 283 }
 284
 285 static SCM
 286 enclosed_ref (scm_t_array_handle *h, ssize_t pos)
 287 {
 288   return scm_i_cvref (SCM_I_ARRAY_V (h->array), pos + h->base, 1);
 289 }
 290
 291 static SCM
 292 vector_ref (scm_t_array_handle *h, ssize_t pos)
 293 {
 294   return ((const SCM *)h->elements)[pos];
 295 }
 296
 297 static SCM
 298 string_ref (scm_t_array_handle *h, ssize_t pos)
 299 {
 300   pos += h->base;
 301   if (SCM_I_ARRAYP (h->array))
 302     return scm_c_string_ref (SCM_I_ARRAY_V (h->array), pos);
 303   else
 304     return scm_c_string_ref (h->array, pos);
 305 }
 306
 307 static SCM
 308 bitvector_ref (scm_t_array_handle *h, ssize_t pos)
 309 {
 310   pos += scm_array_handle_bit_elements_offset (h);
 311   return
 312     scm_from_bool (((scm_t_uint32 *)h->elements)[pos/32] & (1l << (pos % 32)));
 313 }
 314
 315 static SCM
 316 memoize_ref (scm_t_array_handle *h, ssize_t pos)
 317 {
 318   SCM v = h->array;
 319
 320   if (SCM_I_ENCLOSED_ARRAYP (v))
 321     {
 322       h->ref = enclosed_ref;
 323       return enclosed_ref (h, pos);
 324     }
 325
 326   if (SCM_I_ARRAYP (v))
 327     v = SCM_I_ARRAY_V (v);
 328
 329   if (scm_is_vector (v))
 330     {
 331       h->elements = scm_array_handle_elements (h);
 332       h->ref = vector_ref;
 333     }
 334   else if (scm_is_uniform_vector (v))
 335     {
 336       h->elements = scm_array_handle_uniform_elements (h);
 337       h->ref = scm_i_uniform_vector_ref_proc (v);
 338     }
 339   else if (scm_is_string (v))
 340     {
 341       h->ref = string_ref;
 342     }
 343   else if (scm_is_bitvector (v))
 344     {
 345       h->elements = scm_array_handle_bit_elements (h);
 346       h->ref = bitvector_ref;
 347     }
 348   else
 349     scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
 350
 351   return h->ref (h, pos);
 352 }
 353
 354 static void
 355 enclosed_set (scm_t_array_handle *h, ssize_t pos, SCM val)
 356 {
 357   scm_wrong_type_arg_msg (NULL, 0, h->array, "non-enclosed array");
 358 }
 359
 360 static void
 361 vector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
 362 {
 363   ((SCM *)h->writable_elements)[pos] = val;
 364 }
 365
 366 static void
 367 string_set (scm_t_array_handle *h, ssize_t pos, SCM val)
 368 {
 369   pos += h->base;
 370   if (SCM_I_ARRAYP (h->array))
 371     scm_c_string_set_x (SCM_I_ARRAY_V (h->array), pos, val);
 372   else
 373     scm_c_string_set_x (h->array, pos, val);
 374 }
 375
 376 static void
 377 bitvector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
 378 {
 379   scm_t_uint32 mask;
 380   pos += scm_array_handle_bit_elements_offset (h);
 381   mask = 1l << (pos % 32);
 382   if (scm_to_bool (val))
 383     ((scm_t_uint32 *)h->writable_elements)[pos/32] |= mask;
 384   else
 385     ((scm_t_uint32 *)h->writable_elements)[pos/32] &= ~mask;
 386 }
 387
 388 static void
 389 memoize_set (scm_t_array_handle *h, ssize_t pos, SCM val)
 390 {
 391   SCM v = h->array;
 392
 393   if (SCM_I_ENCLOSED_ARRAYP (v))
 394     {
 395       h->set = enclosed_set;
 396       enclosed_set (h, pos, val);
 397       return;
 398     }
 399
 400   if (SCM_I_ARRAYP (v))
 401     v = SCM_I_ARRAY_V (v);
 402
 403   if (scm_is_vector (v))
 404     {
 405       h->writable_elements = scm_array_handle_writable_elements (h);
 406       h->set = vector_set;
 407     }
 408   else if (scm_is_uniform_vector (v))
 409     {
 410       h->writable_elements = scm_array_handle_uniform_writable_elements (h);
 411       h->set = scm_i_uniform_vector_set_proc (v);
 412     }
 413   else if (scm_is_string (v))
 414     {
 415       h->set = string_set;
 416     }
 417   else if (scm_is_bitvector (v))
 418     {
 419       h->writable_elements = scm_array_handle_bit_writable_elements (h);
 420       h->set = bitvector_set;
 421     }
 422   else
 423     scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
 424
 425   h->set (h, pos, val);
 426 }
 427
 428 void
 429 scm_array_get_handle (SCM array, scm_t_array_handle *h)
 430 {
 431   h->array = array;
 432   h->ref = memoize_ref;
 433   h->set = memoize_set;
 434
 435   if (SCM_I_ARRAYP (array) || SCM_I_ENCLOSED_ARRAYP (array))
 436     {
 437       h->dims = SCM_I_ARRAY_DIMS (array);
 438       h->base = SCM_I_ARRAY_BASE (array);
 439     }
 440   else if (scm_is_generalized_vector (array))
 441     {
 442       h->dim0.lbnd = 0;
 443       h->dim0.ubnd = scm_c_generalized_vector_length (array) - 1;
 444       h->dim0.inc = 1;
 445       h->dims = &h->dim0;
 446       h->base = 0;
 447     }
 448   else
 449     scm_wrong_type_arg_msg (NULL, 0, array, "array");
 450 }
 451
 452 void
 453 scm_array_handle_release (scm_t_array_handle *h)
 454 {
 455   /* Nothing to do here until arrays need to be reserved for real.
 456    */
 457 }
 458
 459 size_t
 460 scm_array_handle_rank (scm_t_array_handle *h)
 461 {
 462   if (SCM_I_ARRAYP (h->array) || SCM_I_ENCLOSED_ARRAYP (h->array))
 463     return SCM_I_ARRAY_NDIM (h->array);
 464   else
 465     return 1;
 466 }
 467
 468 scm_t_array_dim *
 469 scm_array_handle_dims (scm_t_array_handle *h)
 470 {
 471   return h->dims;
 472 }
 473
 474 const SCM *
 475 scm_array_handle_elements (scm_t_array_handle *h)
 476 {
 477   SCM vec = h->array;
 478   if (SCM_I_ARRAYP (vec))
 479     vec = SCM_I_ARRAY_V (vec);
 480   if (SCM_I_IS_VECTOR (vec))
 481     return SCM_I_VECTOR_ELTS (vec) + h->base;
 482   scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
 483 }
 484
 485 SCM *
 486 scm_array_handle_writable_elements (scm_t_array_handle *h)
 487 {
 488   SCM vec = h->array;
 489   if (SCM_I_ARRAYP (vec))
 490     vec = SCM_I_ARRAY_V (vec);
 491   if (SCM_I_IS_VECTOR (vec))
 492     return SCM_I_VECTOR_WELTS (vec) + h->base;
 493   scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
 494 }
 495
 496 #if SCM_ENABLE_DEPRECATED
 497
 498 SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
 499            (SCM obj, SCM prot),
 500             "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
 501             "not.")
 502 #define FUNC_NAME s_scm_array_p
 503 {
 504   if (!SCM_UNBNDP (prot))
 505     {
 506       scm_c_issue_deprecation_warning
 507         ("Using prototypes with `array?' is deprecated."
 508          "  Use `typed-array?' instead.");
 509
 510       return scm_typed_array_p (obj, prototype_to_type (prot));
 511     }
 512   else
 513     return scm_from_bool (scm_is_array (obj));
 514 }
 515 #undef FUNC_NAME
 516
 517 #else /* !SCM_ENABLE_DEPRECATED */
 518
 519 /* We keep the old 2-argument C prototype for a while although the old
 520    PROT argument is always ignored now.  C code should probably use
 521    scm_is_array or scm_is_typed_array anyway.
 522 */
 523
 524 static SCM scm_i_array_p (SCM obj);
 525
 526 SCM_DEFINE (scm_i_array_p, "array?", 1, 0, 0,
 527            (SCM obj),
 528             "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
 529             "not.")
 530 #define FUNC_NAME s_scm_i_array_p
 531 {
 532   return scm_from_bool (scm_is_array (obj));
 533 }
 534 #undef FUNC_NAME
 535
 536 SCM
 537 scm_array_p (SCM obj, SCM prot)
 538 {
 539   return scm_from_bool (scm_is_array (obj));
 540 }
 541
 542 #endif /* !SCM_ENABLE_DEPRECATED */
 543
 544
 545 SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
 546            (SCM obj, SCM type),
 547             "Return @code{#t} if the @var{obj} is an array of type\n"
 548             "@var{type}, and @code{#f} if not.")
 549 #define FUNC_NAME s_scm_typed_array_p
 550 {
 551   return scm_from_bool (scm_is_typed_array (obj, type));
 552 }
 553 #undef FUNC_NAME
 554
 555 size_t
 556 scm_c_array_rank (SCM array)
 557 {
 558   scm_t_array_handle handle;
 559   size_t res;
 560
 561   scm_array_get_handle (array, &handle);
 562   res = scm_array_handle_rank (&handle);
 563   scm_array_handle_release (&handle);
 564   return res;
 565 }
 566
 567 SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
 568            (SCM array),
 569             "Return the number of dimensions of the array @var{array.}\n")
 570 #define FUNC_NAME s_scm_array_rank
 571 {
 572   return scm_from_size_t (scm_c_array_rank (array));
 573 }
 574 #undef FUNC_NAME
 575
 576
 577 SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
 578            (SCM ra),
 579             "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
 580             "elements with a @code{0} minimum with one greater than the maximum. So:\n"
 581             "@lisp\n"
 582             "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
 583             "@end lisp")
 584 #define FUNC_NAME s_scm_array_dimensions
 585 {
 586   scm_t_array_handle handle;
 587   scm_t_array_dim *s;
 588   SCM res = SCM_EOL;
 589   size_t k;
 590
 591   scm_array_get_handle (ra, &handle);
 592   s = scm_array_handle_dims (&handle);
 593   k = scm_array_handle_rank (&handle);
 594
 595   while (k--)
 596     res = scm_cons (s[k].lbnd
 597                     ? scm_cons2 (scm_from_ssize_t (s[k].lbnd),
 598                                  scm_from_ssize_t (s[k].ubnd),
 599                                  SCM_EOL)
 600                     : scm_from_ssize_t (1 + s[k].ubnd),
 601                     res);
 602
 603   scm_array_handle_release (&handle);
 604   return res;
 605 }
 606 #undef FUNC_NAME
 607
 608
 609 SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
 610            (SCM ra),
 611             "Return the root vector of a shared array.")
 612 #define FUNC_NAME s_scm_shared_array_root
 613 {
 614   if (SCM_I_ARRAYP (ra) || SCM_I_ENCLOSED_ARRAYP (ra))
 615     return SCM_I_ARRAY_V (ra);
 616   else if (scm_is_generalized_vector (ra))
 617     return ra;
 618   scm_wrong_type_arg_msg (NULL, 0, ra, "array");
 619 }
 620 #undef FUNC_NAME
 621
 622
 623 SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
 624            (SCM ra),
 625             "Return the root vector index of the first element in the array.")
 626 #define FUNC_NAME s_scm_shared_array_offset
 627 {
 628   scm_t_array_handle handle;
 629   SCM res;
 630
 631   scm_array_get_handle (ra, &handle);
 632   res = scm_from_size_t (handle.base);
 633   scm_array_handle_release (&handle);
 634   return res;
 635 }
 636 #undef FUNC_NAME
 637
 638
 639 SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
 640            (SCM ra),
 641             "For each dimension, return the distance between elements in the root vector.")
 642 #define FUNC_NAME s_scm_shared_array_increments
 643 {
 644   scm_t_array_handle handle;
 645   SCM res = SCM_EOL;
 646   size_t k;
 647   scm_t_array_dim *s;
 648
 649   scm_array_get_handle (ra, &handle);
 650   k = scm_array_handle_rank (&handle);
 651   s = scm_array_handle_dims (&handle);
 652   while (k--)
 653     res = scm_cons (scm_from_ssize_t (s[k].inc), res);
 654   scm_array_handle_release (&handle);
 655   return res;
 656 }
 657 #undef FUNC_NAME
 658
 659 ssize_t
 660 scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
 661 {
 662   scm_t_array_dim *s = scm_array_handle_dims (h);
 663   ssize_t pos = 0, i;
 664   size_t k = scm_array_handle_rank (h);
 665
 666   while (k > 0 && scm_is_pair (indices))
 667     {
 668       i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd);
 669       pos += (i - s->lbnd) * s->inc;
 670       k--;
 671       s++;
 672       indices = SCM_CDR (indices);
 673     }
 674   if (k > 0 || !scm_is_null (indices))
 675     scm_misc_error (NULL, "wrong number of indices, expecting ~a",
 676                     scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
 677   return pos;
 678 }
 679
 680 SCM
 681 scm_i_make_ra (int ndim, int enclosed)
 682 {
 683   scm_t_bits tag = enclosed? scm_i_tc16_enclosed_array : scm_i_tc16_array;
 684   SCM ra;
 685   SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + tag,
 686               scm_gc_malloc ((sizeof (scm_i_t_array) +
 687                               ndim * sizeof (scm_t_array_dim)),
 688                              "array"));
 689   SCM_I_ARRAY_V (ra) = SCM_BOOL_F;
 690   return ra;
 691 }
 692
 693 static char s_bad_spec[] = "Bad scm_array dimension";
 694
 695
 696 /* Increments will still need to be set. */
 697
 698 static SCM
 699 scm_i_shap2ra (SCM args)
 700 {
 701   scm_t_array_dim *s;
 702   SCM ra, spec, sp;
 703   int ndim = scm_ilength (args);
 704   if (ndim < 0)
 705     scm_misc_error (NULL, s_bad_spec, SCM_EOL);
 706
 707   ra = scm_i_make_ra (ndim, 0);
 708   SCM_I_ARRAY_BASE (ra) = 0;
 709   s = SCM_I_ARRAY_DIMS (ra);
 710   for (; !scm_is_null (args); s++, args = SCM_CDR (args))
 711     {
 712       spec = SCM_CAR (args);
 713       if (scm_is_integer (spec))
 714         {
 715           if (scm_to_long (spec) < 0)
 716             scm_misc_error (NULL, s_bad_spec, SCM_EOL);
 717           s->lbnd = 0;
 718           s->ubnd = scm_to_long (spec) - 1;
 719           s->inc = 1;
 720         }
 721       else
 722         {
 723           if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec)))
 724             scm_misc_error (NULL, s_bad_spec, SCM_EOL);
 725           s->lbnd = scm_to_long (SCM_CAR (spec));
 726           sp = SCM_CDR (spec);
 727           if (!scm_is_pair (sp)
 728               || !scm_is_integer (SCM_CAR (sp))
 729               || !scm_is_null (SCM_CDR (sp)))
 730             scm_misc_error (NULL, s_bad_spec, SCM_EOL);
 731           s->ubnd = scm_to_long (SCM_CAR (sp));
 732           s->inc = 1;
 733         }
 734     }
 735   return ra;
 736 }
 737
 738 SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
 739             (SCM type, SCM fill, SCM bounds),
 740             "Create and return an array of type @var{type}.")
 741 #define FUNC_NAME s_scm_make_typed_array
 742 {
 743   size_t k, rlen = 1;
 744   scm_t_array_dim *s;
 745   creator_proc *creator;
 746   SCM ra;
 747
 748   creator = type_to_creator (type);
 749   ra = scm_i_shap2ra (bounds);
 750   SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
 751   s = SCM_I_ARRAY_DIMS (ra);
 752   k = SCM_I_ARRAY_NDIM (ra);
 753
 754   while (k--)
 755     {
 756       s[k].inc = rlen;
 757       SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
 758       rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
 759     }
 760
 761   if (scm_is_eq (fill, SCM_UNSPECIFIED))
 762     fill = SCM_UNDEFINED;
 763
 764   SCM_I_ARRAY_V (ra) = creator (scm_from_size_t (rlen), fill);
 765
 766   if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
 767     if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
 768       return SCM_I_ARRAY_V (ra);
 769   return ra;
 770 }
 771 #undef FUNC_NAME
 772
 773 SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
 774             (SCM fill, SCM bounds),
 775             "Create and return an array.")
 776 #define FUNC_NAME s_scm_make_array
 777 {
 778   return scm_make_typed_array (SCM_BOOL_T, fill, bounds);
 779 }
 780 #undef FUNC_NAME
 781
 782 #if SCM_ENABLE_DEPRECATED
 783
 784 SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0,
 785             (SCM dims, SCM prot, SCM fill),
 786             "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
 787             "Create and return a uniform array or vector of type\n"
 788             "corresponding to @var{prototype} with dimensions @var{dims} or\n"
 789             "length @var{length}.  If @var{fill} is supplied, it's used to\n"
 790             "fill the array, otherwise @var{prototype} is used.")
 791 #define FUNC_NAME s_scm_dimensions_to_uniform_array
 792 {
 793   scm_c_issue_deprecation_warning
 794     ("`dimensions->uniform-array' is deprecated.  "
 795      "Use `make-typed-array' instead.");
 796
 797   if (scm_is_integer (dims))
 798     dims = scm_list_1 (dims);
 799
 800   if (SCM_UNBNDP (fill))
 801     {
 802       /* Using #\nul as the prototype yields a s8 array, but numeric
 803          arrays can't store characters, so we have to special case this.
 804       */
 805       if (scm_is_eq (prot, SCM_MAKE_CHAR (0)))
 806         fill = scm_from_int (0);
 807       else
 808         fill = prot;
 809     }
 810
 811   return scm_make_typed_array (prototype_to_type (prot), fill, dims);
 812 }
 813 #undef FUNC_NAME
 814
 815 #endif
 816
 817 static void
 818 scm_i_ra_set_contp (SCM ra)
 819 {
 820   size_t k = SCM_I_ARRAY_NDIM (ra);
 821   if (k)
 822     {
 823       long inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc;
 824       while (k--)
 825         {
 826           if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc)
 827             {
 828               SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
 829               return;
 830             }
 831           inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
 832                   - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
 833         }
 834     }
 835   SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
 836 }
 837
 838
 839 SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
 840            (SCM oldra, SCM mapfunc, SCM dims),
 841             "@code{make-shared-array} can be used to create shared subarrays of other\n"
 842             "arrays.  The @var{mapper} is a function that translates coordinates in\n"
 843             "the new array into coordinates in the old array.  A @var{mapper} must be\n"
 844             "linear, and its range must stay within the bounds of the old array, but\n"
 845             "it can be otherwise arbitrary.  A simple example:\n"
 846             "@lisp\n"
 847             "(define fred (make-array #f 8 8))\n"
 848             "(define freds-diagonal\n"
 849             "  (make-shared-array fred (lambda (i) (list i i)) 8))\n"
 850             "(array-set! freds-diagonal 'foo 3)\n"
 851             "(array-ref fred 3 3) @result{} foo\n"
 852             "(define freds-center\n"
 853             "  (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
 854             "(array-ref freds-center 0 0) @result{} foo\n"
 855             "@end lisp")
 856 #define FUNC_NAME s_scm_make_shared_array
 857 {
 858   scm_t_array_handle old_handle;
 859   SCM ra;
 860   SCM inds, indptr;
 861   SCM imap;
 862   size_t k;
 863   ssize_t i;
 864   long old_base, old_min, new_min, old_max, new_max;
 865   scm_t_array_dim *s;
 866
 867   SCM_VALIDATE_REST_ARGUMENT (dims);
 868   SCM_VALIDATE_PROC (2, mapfunc);
 869   ra = scm_i_shap2ra (dims);
 870
 871   scm_array_get_handle (oldra, &old_handle);
 872
 873   if (SCM_I_ARRAYP (oldra))
 874     {
 875       SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra);
 876       old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra);
 877       s = scm_array_handle_dims (&old_handle);
 878       k = scm_array_handle_rank (&old_handle);
 879       while (k--)
 880         {
 881           if (s[k].inc > 0)
 882             old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
 883           else
 884             old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
 885         }
 886     }
 887   else
 888     {
 889       SCM_I_ARRAY_V (ra) = oldra;
 890       old_base = old_min = 0;
 891       old_max = scm_c_generalized_vector_length (oldra) - 1;
 892     }
 893
 894   inds = SCM_EOL;
 895   s = SCM_I_ARRAY_DIMS (ra);
 896   for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
 897     {
 898       inds = scm_cons (scm_from_long (s[k].lbnd), inds);
 899       if (s[k].ubnd < s[k].lbnd)
 900         {
 901           if (1 == SCM_I_ARRAY_NDIM (ra))
 902             ra = make_typed_vector (scm_array_type (ra), 0);
 903           else
 904             SCM_I_ARRAY_V (ra) = make_typed_vector (scm_array_type (ra), 0);
 905           scm_array_handle_release (&old_handle);
 906           return ra;
 907         }
 908     }
 909
 910   imap = scm_apply_0 (mapfunc, scm_reverse (inds));
 911   i = scm_array_handle_pos (&old_handle, imap);
 912   SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base;
 913   indptr = inds;
 914   k = SCM_I_ARRAY_NDIM (ra);
 915   while (k--)
 916     {
 917       if (s[k].ubnd > s[k].lbnd)
 918         {
 919           SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1)));
 920           imap = scm_apply_0 (mapfunc, scm_reverse (inds));
 921           s[k].inc = scm_array_handle_pos (&old_handle, imap) - i;
 922           i += s[k].inc;
 923           if (s[k].inc > 0)
 924             new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
 925           else
 926             new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
 927         }
 928       else
 929         s[k].inc = new_max - new_min + 1;       /* contiguous by default */
 930       indptr = SCM_CDR (indptr);
 931     }
 932
 933   scm_array_handle_release (&old_handle);
 934
 935   if (old_min > new_min || old_max < new_max)
 936     SCM_MISC_ERROR ("mapping out of range", SCM_EOL);
 937   if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
 938     {
 939       SCM v = SCM_I_ARRAY_V (ra);
 940       size_t length = scm_c_generalized_vector_length (v);
 941       if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
 942         return v;
 943       if (s->ubnd < s->lbnd)
 944         return make_typed_vector (scm_array_type (ra), 0);
 945     }
 946   scm_i_ra_set_contp (ra);
 947   return ra;
 948 }
 949 #undef FUNC_NAME
 950
 951
 952 /* args are RA . DIMS */
 953 SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
 954            (SCM ra, SCM args),
 955             "Return an array sharing contents with @var{array}, but with\n"
 956             "dimensions arranged in a different order.  There must be one\n"
 957             "@var{dim} argument for each dimension of @var{array}.\n"
 958             "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
 959             "and the rank of the array to be returned.  Each integer in that\n"
 960             "range must appear at least once in the argument list.\n"
 961             "\n"
 962             "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
 963             "dimensions in the array to be returned, their positions in the\n"
 964             "argument list to dimensions of @var{array}.  Several @var{dim}s\n"
 965             "may have the same value, in which case the returned array will\n"
 966             "have smaller rank than @var{array}.\n"
 967             "\n"
 968             "@lisp\n"
 969             "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
 970             "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
 971             "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
 972             "                #2((a 4) (b 5) (c 6))\n"
 973             "@end lisp")
 974 #define FUNC_NAME s_scm_transpose_array
 975 {
 976   SCM res, vargs;
 977   scm_t_array_dim *s, *r;
 978   int ndim, i, k;
 979
 980   SCM_VALIDATE_REST_ARGUMENT (args);
 981   SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME);
 982
 983   if (scm_is_generalized_vector (ra))
 984     {
 985       /* Make sure that we are called with a single zero as
 986          arguments.
 987       */
 988       if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
 989         SCM_WRONG_NUM_ARGS ();
 990       SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
 991       SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
 992       return ra;
 993     }
 994
 995   if (SCM_I_ARRAYP (ra) || SCM_I_ENCLOSED_ARRAYP (ra))
 996     {
 997       vargs = scm_vector (args);
 998       if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
 999         SCM_WRONG_NUM_ARGS ();
1000       ndim = 0;
1001       for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
1002         {
1003           i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k),
1004                                      0, SCM_I_ARRAY_NDIM(ra));
1005           if (ndim < i)
1006             ndim = i;
1007         }
1008       ndim++;
1009       res = scm_i_make_ra (ndim, 0);
1010       SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra);
1011       SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra);
1012       for (k = ndim; k--;)
1013         {
1014           SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
1015           SCM_I_ARRAY_DIMS (res)[k].ubnd = -1;
1016         }
1017       for (k = SCM_I_ARRAY_NDIM (ra); k--;)
1018         {
1019           i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k));
1020           s = &(SCM_I_ARRAY_DIMS (ra)[k]);
1021           r = &(SCM_I_ARRAY_DIMS (res)[i]);
1022           if (r->ubnd < r->lbnd)
1023             {
1024               r->lbnd = s->lbnd;
1025               r->ubnd = s->ubnd;
1026               r->inc = s->inc;
1027               ndim--;
1028             }
1029           else
1030             {
1031               if (r->ubnd > s->ubnd)
1032                 r->ubnd = s->ubnd;
1033               if (r->lbnd < s->lbnd)
1034                 {
1035                   SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
1036                   r->lbnd = s->lbnd;
1037                 }
1038               r->inc += s->inc;
1039             }
1040         }
1041       if (ndim > 0)
1042         SCM_MISC_ERROR ("bad argument list", SCM_EOL);
1043       scm_i_ra_set_contp (res);
1044       return res;
1045     }
1046
1047   scm_wrong_type_arg_msg (NULL, 0, ra, "array");
1048 }
1049 #undef FUNC_NAME
1050
1051 /* args are RA . AXES */
1052 SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1,
1053            (SCM ra, SCM axes),
1054             "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
1055             "the rank of @var{array}.  @var{enclose-array} returns an array\n"
1056             "resembling an array of shared arrays.  The dimensions of each shared\n"
1057             "array are the same as the @var{dim}th dimensions of the original array,\n"
1058             "the dimensions of the outer array are the same as those of the original\n"
1059             "array that did not match a @var{dim}.\n\n"
1060             "An enclosed array is not a general Scheme array.  Its elements may not\n"
1061             "be set using @code{array-set!}.  Two references to the same element of\n"
1062             "an enclosed array will be @code{equal?} but will not in general be\n"
1063             "@code{eq?}.  The value returned by @var{array-prototype} when given an\n"
1064             "enclosed array is unspecified.\n\n"
1065             "examples:\n"
1066             "@lisp\n"
1067             "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
1068             "   #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
1069             "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
1070             "   #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
1071             "@end lisp")
1072 #define FUNC_NAME s_scm_enclose_array
1073 {
1074   SCM axv, res, ra_inr;
1075   const char *c_axv;
1076   scm_t_array_dim vdim, *s = &vdim;
1077   int ndim, j, k, ninr, noutr;
1078
1079   SCM_VALIDATE_REST_ARGUMENT (axes);
1080   if (scm_is_null (axes))
1081     axes = scm_cons ((SCM_I_ARRAYP (ra) ? scm_from_size_t (SCM_I_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL);
1082   ninr = scm_ilength (axes);
1083   if (ninr < 0)
1084     SCM_WRONG_NUM_ARGS ();
1085   ra_inr = scm_i_make_ra (ninr, 0);
1086
1087   if (scm_is_generalized_vector (ra))
1088     {
1089       s->lbnd = 0;
1090       s->ubnd = scm_c_generalized_vector_length (ra) - 1;
1091       s->inc = 1;
1092       SCM_I_ARRAY_V (ra_inr) = ra;
1093       SCM_I_ARRAY_BASE (ra_inr) = 0;
1094       ndim = 1;
1095     }
1096   else if (SCM_I_ARRAYP (ra))
1097     {
1098       s = SCM_I_ARRAY_DIMS (ra);
1099       SCM_I_ARRAY_V (ra_inr) = SCM_I_ARRAY_V (ra);
1100       SCM_I_ARRAY_BASE (ra_inr) = SCM_I_ARRAY_BASE (ra);
1101       ndim = SCM_I_ARRAY_NDIM (ra);
1102     }
1103   else
1104     scm_wrong_type_arg_msg (NULL, 0, ra, "array");
1105
1106   noutr = ndim - ninr;
1107   if (noutr < 0)
1108     SCM_WRONG_NUM_ARGS ();
1109   axv = scm_make_string (scm_from_int (ndim), SCM_MAKE_CHAR (0));
1110   res = scm_i_make_ra (noutr, 1);
1111   SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra_inr);
1112   SCM_I_ARRAY_V (res) = ra_inr;
1113   for (k = 0; k < ninr; k++, axes = SCM_CDR (axes))
1114     {
1115       if (!scm_is_integer (SCM_CAR (axes)))
1116         SCM_MISC_ERROR ("bad axis", SCM_EOL);
1117       j = scm_to_int (SCM_CAR (axes));
1118       SCM_I_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd;
1119       SCM_I_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd;
1120       SCM_I_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc;
1121       scm_c_string_set_x (axv, j, SCM_MAKE_CHAR (1));
1122     }
1123   c_axv = scm_i_string_chars (axv);
1124   for (j = 0, k = 0; k < noutr; k++, j++)
1125     {
1126       while (c_axv[j])
1127         j++;
1128       SCM_I_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd;
1129       SCM_I_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd;
1130       SCM_I_ARRAY_DIMS (res)[k].inc = s[j].inc;
1131     }
1132   scm_remember_upto_here_1 (axv);
1133   scm_i_ra_set_contp (ra_inr);
1134   scm_i_ra_set_contp (res);
1135   return res;
1136 }
1137 #undef FUNC_NAME
1138
1139
1140
1141 SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
1142            (SCM v, SCM args),
1143             "Return @code{#t} if its arguments would be acceptable to\n"
1144             "@code{array-ref}.")
1145 #define FUNC_NAME s_scm_array_in_bounds_p
1146 {
1147   SCM res = SCM_BOOL_T;
1148
1149   SCM_VALIDATE_REST_ARGUMENT (args);
1150
1151   if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v))
1152     {
1153       size_t k, ndim = SCM_I_ARRAY_NDIM (v);
1154       scm_t_array_dim *s = SCM_I_ARRAY_DIMS (v);
1155
1156       for (k = 0; k < ndim; k++)
1157         {
1158           long ind;
1159
1160           if (!scm_is_pair (args))
1161             SCM_WRONG_NUM_ARGS ();
1162           ind = scm_to_long (SCM_CAR (args));
1163           args = SCM_CDR (args);
1164
1165           if (ind < s[k].lbnd || ind > s[k].ubnd)
1166             {
1167               res = SCM_BOOL_F;
1168               /* We do not stop the checking after finding a violation
1169                  since we want to validate the type-correctness and
1170                  number of arguments in any case.
1171               */
1172             }
1173         }
1174     }
1175   else if (scm_is_generalized_vector (v))
1176     {
1177       /* Since real arrays have been covered above, all generalized
1178          vectors are guaranteed to be zero-origin here.
1179       */
1180
1181       long ind;
1182
1183       if (!scm_is_pair (args))
1184         SCM_WRONG_NUM_ARGS ();
1185       ind = scm_to_long (SCM_CAR (args));
1186       args = SCM_CDR (args);
1187       res = scm_from_bool (ind >= 0
1188                            && ind < scm_c_generalized_vector_length (v));
1189     }
1190   else
1191     scm_wrong_type_arg_msg (NULL, 0, v, "array");
1192
1193   if (!scm_is_null (args))
1194     SCM_WRONG_NUM_ARGS ();
1195
1196   return res;
1197 }
1198 #undef FUNC_NAME
1199
1200 SCM
1201 scm_i_cvref (SCM v, size_t pos, int enclosed)
1202 {
1203   if (enclosed)
1204     {
1205       int k = SCM_I_ARRAY_NDIM (v);
1206       SCM res = scm_i_make_ra (k, 0);
1207       SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (v);
1208       SCM_I_ARRAY_BASE (res) = pos;
1209       while (k--)
1210         {
1211           SCM_I_ARRAY_DIMS (res)[k].ubnd = SCM_I_ARRAY_DIMS (v)[k].ubnd;
1212           SCM_I_ARRAY_DIMS (res)[k].lbnd = SCM_I_ARRAY_DIMS (v)[k].lbnd;
1213           SCM_I_ARRAY_DIMS (res)[k].inc = SCM_I_ARRAY_DIMS (v)[k].inc;
1214         }
1215       return res;
1216     }
1217   else
1218     return scm_c_generalized_vector_ref (v, pos);
1219 }
1220
1221 SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
1222            (SCM v, SCM args),
1223             "Return the element at the @code{(index1, index2)} element in\n"
1224             "@var{array}.")
1225 #define FUNC_NAME s_scm_array_ref
1226 {
1227   scm_t_array_handle handle;
1228   SCM res;
1229
1230   scm_array_get_handle (v, &handle);
1231   res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args));
1232   scm_array_handle_release (&handle);
1233   return res;
1234 }
1235 #undef FUNC_NAME
1236
1237
1238 SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
1239            (SCM v, SCM obj, SCM args),
1240             "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
1241             "@var{new-value}.  The value returned by array-set! is unspecified.")
1242 #define FUNC_NAME s_scm_array_set_x
1243 {
1244   scm_t_array_handle handle;
1245
1246   scm_array_get_handle (v, &handle);
1247   scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj);
1248   scm_array_handle_release (&handle);
1249   return SCM_UNSPECIFIED;
1250 }
1251 #undef FUNC_NAME
1252
1253 /* attempts to unroll an array into a one-dimensional array.
1254    returns the unrolled array or #f if it can't be done.  */
1255   /* if strict is not SCM_UNDEFINED, return #f if returned array
1256                      wouldn't have contiguous elements.  */
1257 SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
1258            (SCM ra, SCM strict),
1259             "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1260             "without changing their order (last subscript changing fastest), then\n"
1261             "@code{array-contents} returns that shared array, otherwise it returns\n"
1262             "@code{#f}.  All arrays made by @var{make-array} and\n"
1263             "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1264             "@var{make-shared-array} may not be.\n\n"
1265             "If the optional argument @var{strict} is provided, a shared array will\n"
1266             "be returned only if its elements are stored internally contiguous in\n"
1267             "memory.")
1268 #define FUNC_NAME s_scm_array_contents
1269 {
1270   SCM sra;
1271
1272   if (scm_is_generalized_vector (ra))
1273     return ra;
1274
1275   if (SCM_I_ARRAYP (ra))
1276     {
1277       size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
1278       if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra))
1279         return SCM_BOOL_F;
1280       for (k = 0; k < ndim; k++)
1281         len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
1282       if (!SCM_UNBNDP (strict))
1283         {
1284           if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc))
1285             return SCM_BOOL_F;
1286           if (scm_is_bitvector (SCM_I_ARRAY_V (ra)))
1287             {
1288               if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
1289                   SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
1290                   len % SCM_LONG_BIT)
1291                 return SCM_BOOL_F;
1292             }
1293         }
1294
1295       {
1296         SCM v = SCM_I_ARRAY_V (ra);
1297         size_t length = scm_c_generalized_vector_length (v);
1298         if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc)
1299           return v;
1300       }
1301
1302       sra = scm_i_make_ra (1, 0);
1303       SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
1304       SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
1305       SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra);
1306       SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra);
1307       SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
1308       return sra;
1309     }
1310   else if (SCM_I_ENCLOSED_ARRAYP (ra))
1311     scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array");
1312   else
1313     scm_wrong_type_arg_msg (NULL, 0, ra, "array");
1314 }
1315 #undef FUNC_NAME
1316
1317
1318 SCM
1319 scm_ra2contig (SCM ra, int copy)
1320 {
1321   SCM ret;
1322   long inc = 1;
1323   size_t k, len = 1;
1324   for (k = SCM_I_ARRAY_NDIM (ra); k--;)
1325     len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
1326   k = SCM_I_ARRAY_NDIM (ra);
1327   if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k - 1].inc)))
1328     {
1329       if (!scm_is_bitvector (SCM_I_ARRAY_V (ra)))
1330         return ra;
1331       if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) &&
1332            0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT &&
1333            0 == len % SCM_LONG_BIT))
1334         return ra;
1335     }
1336   ret = scm_i_make_ra (k, 0);
1337   SCM_I_ARRAY_BASE (ret) = 0;
1338   while (k--)
1339     {
1340       SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
1341       SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd;
1342       SCM_I_ARRAY_DIMS (ret)[k].inc = inc;
1343       inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
1344     }
1345   SCM_I_ARRAY_V (ret) = make_typed_vector (scm_array_type (ra), inc);
1346   if (copy)
1347     scm_array_copy_x (ra, ret);
1348   return ret;
1349 }
1350
1351
1352
1353 SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
1354            (SCM ura, SCM port_or_fd, SCM start, SCM end),
1355             "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1356             "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1357             "binary objects from @var{port-or-fdes}.\n"
1358             "If an end of file is encountered,\n"
1359             "the objects up to that point are put into @var{ura}\n"
1360             "(starting at the beginning) and the remainder of the array is\n"
1361             "unchanged.\n\n"
1362             "The optional arguments @var{start} and @var{end} allow\n"
1363             "a specified region of a vector (or linearized array) to be read,\n"
1364             "leaving the remainder of the vector unchanged.\n\n"
1365             "@code{uniform-array-read!} returns the number of objects read.\n"
1366             "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1367             "returned by @code{(current-input-port)}.")
1368 #define FUNC_NAME s_scm_uniform_array_read_x
1369 {
1370   if (SCM_UNBNDP (port_or_fd))
1371     port_or_fd = scm_current_input_port ();
1372
1373   if (scm_is_uniform_vector (ura))
1374     {
1375       return scm_uniform_vector_read_x (ura, port_or_fd, start, end);
1376     }
1377   else if (SCM_I_ARRAYP (ura))
1378     {
1379       size_t base, vlen, cstart, cend;
1380       SCM cra, ans;
1381
1382       cra = scm_ra2contig (ura, 0);
1383       base = SCM_I_ARRAY_BASE (cra);
1384       vlen = SCM_I_ARRAY_DIMS (cra)->inc *
1385         (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
1386
1387       cstart = 0;
1388       cend = vlen;
1389       if (!SCM_UNBNDP (start))
1390         {
1391           cstart = scm_to_unsigned_integer (start, 0, vlen);
1392           if (!SCM_UNBNDP (end))
1393             cend = scm_to_unsigned_integer (end, cstart, vlen);
1394         }
1395
1396       ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd,
1397                                        scm_from_size_t (base + cstart),
1398                                        scm_from_size_t (base + cend));
1399
1400       if (!scm_is_eq (cra, ura))
1401         scm_array_copy_x (cra, ura);
1402       return ans;
1403     }
1404   else if (SCM_I_ENCLOSED_ARRAYP (ura))
1405     scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array");
1406   else
1407     scm_wrong_type_arg_msg (NULL, 0, ura, "array");
1408 }
1409 #undef FUNC_NAME
1410
1411 SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
1412            (SCM ura, SCM port_or_fd, SCM start, SCM end),
1413             "Writes all elements of @var{ura} as binary objects to\n"
1414             "@var{port-or-fdes}.\n\n"
1415             "The optional arguments @var{start}\n"
1416             "and @var{end} allow\n"
1417             "a specified region of a vector (or linearized array) to be written.\n\n"
1418             "The number of objects actually written is returned.\n"
1419             "@var{port-or-fdes} may be\n"
1420             "omitted, in which case it defaults to the value returned by\n"
1421             "@code{(current-output-port)}.")
1422 #define FUNC_NAME s_scm_uniform_array_write
1423 {
1424   if (SCM_UNBNDP (port_or_fd))
1425     port_or_fd = scm_current_output_port ();
1426
1427   if (scm_is_uniform_vector (ura))
1428     {
1429       return scm_uniform_vector_write (ura, port_or_fd, start, end);
1430     }
1431   else if (SCM_I_ARRAYP (ura))
1432     {
1433       size_t base, vlen, cstart, cend;
1434       SCM cra, ans;
1435
1436       cra = scm_ra2contig (ura, 1);
1437       base = SCM_I_ARRAY_BASE (cra);
1438       vlen = SCM_I_ARRAY_DIMS (cra)->inc *
1439         (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
1440
1441       cstart = 0;
1442       cend = vlen;
1443       if (!SCM_UNBNDP (start))
1444         {
1445           cstart = scm_to_unsigned_integer (start, 0, vlen);
1446           if (!SCM_UNBNDP (end))
1447             cend = scm_to_unsigned_integer (end, cstart, vlen);
1448         }
1449
1450       ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd,
1451                                       scm_from_size_t (base + cstart),
1452                                       scm_from_size_t (base + cend));
1453
1454       return ans;
1455     }
1456   else if (SCM_I_ENCLOSED_ARRAYP (ura))
1457     scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array");
1458   else
1459     scm_wrong_type_arg_msg (NULL, 0, ura, "array");
1460 }
1461 #undef FUNC_NAME
1462
1463
1464 /** Bit vectors */
1465
1466 static scm_t_bits scm_tc16_bitvector;
1467
1468 #define IS_BITVECTOR(obj)       SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
1469 #define BITVECTOR_BITS(obj)     ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
1470 #define BITVECTOR_LENGTH(obj)   ((size_t)SCM_SMOB_DATA_2(obj))
1471
1472 static size_t
1473 bitvector_free (SCM vec)
1474 {
1475   scm_gc_free (BITVECTOR_BITS (vec),
1476                sizeof (scm_t_uint32) * ((BITVECTOR_LENGTH (vec)+31)/32),
1477                "bitvector");
1478   return 0;
1479 }
1480
1481 static int
1482 bitvector_print (SCM vec, SCM port, scm_print_state *pstate)
1483 {
1484   size_t bit_len = BITVECTOR_LENGTH (vec);
1485   size_t word_len = (bit_len+31)/32;
1486   scm_t_uint32 *bits = BITVECTOR_BITS (vec);
1487   size_t i, j;
1488
1489   scm_puts ("#*", port);
1490   for (i = 0; i < word_len; i++, bit_len -= 32)
1491     {
1492       scm_t_uint32 mask = 1;
1493       for (j = 0; j < 32 && j < bit_len; j++, mask <<= 1)
1494         scm_putc ((bits[i] & mask)? '1' : '0', port);
1495     }
1496
1497   return 1;
1498 }
1499
1500 static SCM
1501 bitvector_equalp (SCM vec1, SCM vec2)
1502 {
1503   size_t bit_len = BITVECTOR_LENGTH (vec1);
1504   size_t word_len = (bit_len + 31) / 32;
1505   scm_t_uint32 last_mask =  ((scm_t_uint32)-1) >> (32*word_len - bit_len);
1506   scm_t_uint32 *bits1 = BITVECTOR_BITS (vec1);
1507   scm_t_uint32 *bits2 = BITVECTOR_BITS (vec2);
1508
1509   /* compare lengths */
1510   if (BITVECTOR_LENGTH (vec2) != bit_len)
1511     return SCM_BOOL_F;
1512   /* avoid underflow in word_len-1 below. */
1513   if (bit_len == 0)
1514     return SCM_BOOL_T;
1515   /* compare full words */
1516   if (memcmp (bits1, bits2, sizeof (scm_t_uint32) * (word_len-1)))
1517     return SCM_BOOL_F;
1518   /* compare partial last words */
1519   if ((bits1[word_len-1] & last_mask) != (bits2[word_len-1] & last_mask))
1520     return SCM_BOOL_F;
1521   return SCM_BOOL_T;
1522 }
1523
1524 int
1525 scm_is_bitvector (SCM vec)
1526 {
1527   return IS_BITVECTOR (vec);
1528 }
1529
1530 SCM_DEFINE (scm_bitvector_p, "bitvector?", 1, 0, 0,
1531             (SCM obj),
1532             "Return @code{#t} when @var{obj} is a bitvector, else\n"
1533             "return @code{#f}.")
1534 #define FUNC_NAME s_scm_bitvector_p
1535 {
1536   return scm_from_bool (scm_is_bitvector (obj));
1537 }
1538 #undef FUNC_NAME
1539
1540 SCM
1541 scm_c_make_bitvector (size_t len, SCM fill)
1542 {
1543   size_t word_len = (len + 31) / 32;
1544   scm_t_uint32 *bits;
1545   SCM res;
1546
1547   bits = scm_gc_malloc (sizeof (scm_t_uint32) * word_len,
1548                         "bitvector");
1549   SCM_NEWSMOB2 (res, scm_tc16_bitvector, bits, len);
1550
1551   if (!SCM_UNBNDP (fill))
1552     scm_bitvector_fill_x (res, fill);
1553
1554   return res;
1555 }
1556
1557 SCM_DEFINE (scm_make_bitvector, "make-bitvector", 1, 1, 0,
1558             (SCM len, SCM fill),
1559             "Create a new bitvector of length @var{len} and\n"
1560             "optionally initialize all elements to @var{fill}.")
1561 #define FUNC_NAME s_scm_make_bitvector
1562 {
1563   return scm_c_make_bitvector (scm_to_size_t (len), fill);
1564 }
1565 #undef FUNC_NAME
1566
1567 SCM_DEFINE (scm_bitvector, "bitvector", 0, 0, 1,
1568             (SCM bits),
1569             "Create a new bitvector with the arguments as elements.")
1570 #define FUNC_NAME s_scm_bitvector
1571 {
1572   return scm_list_to_bitvector (bits);
1573 }
1574 #undef FUNC_NAME
1575
1576 size_t
1577 scm_c_bitvector_length (SCM vec)
1578 {
1579   scm_assert_smob_type (scm_tc16_bitvector, vec);
1580   return BITVECTOR_LENGTH (vec);
1581 }
1582
1583 SCM_DEFINE (scm_bitvector_length, "bitvector-length", 1, 0, 0,
1584             (SCM vec),
1585             "Return the length of the bitvector @var{vec}.")
1586 #define FUNC_NAME s_scm_bitvector_length
1587 {
1588   return scm_from_size_t (scm_c_bitvector_length (vec));
1589 }
1590 #undef FUNC_NAME
1591
1592 const scm_t_uint32 *
1593 scm_array_handle_bit_elements (scm_t_array_handle *h)
1594 {
1595   return scm_array_handle_bit_writable_elements (h);
1596 }
1597
1598 scm_t_uint32 *
1599 scm_array_handle_bit_writable_elements (scm_t_array_handle *h)
1600 {
1601   SCM vec = h->array;
1602   if (SCM_I_ARRAYP (vec))
1603     vec = SCM_I_ARRAY_V (vec);
1604   if (IS_BITVECTOR (vec))
1605     return BITVECTOR_BITS (vec) + h->base/32;
1606   scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array");
1607 }
1608
1609 size_t
1610 scm_array_handle_bit_elements_offset (scm_t_array_handle *h)
1611 {
1612   return h->base % 32;
1613 }
1614
1615 const scm_t_uint32 *
1616 scm_bitvector_elements (SCM vec,
1617                         scm_t_array_handle *h,
1618                         size_t *offp,
1619                         size_t *lenp,
1620                         ssize_t *incp)
1621 {
1622   return scm_bitvector_writable_elements (vec, h, offp, lenp, incp);
1623 }
1624
1625
1626 scm_t_uint32 *
1627 scm_bitvector_writable_elements (SCM vec,
1628                                  scm_t_array_handle *h,
1629                                  size_t *offp,
1630                                  size_t *lenp,
1631                                  ssize_t *incp)
1632 {
1633   scm_generalized_vector_get_handle (vec, h);
1634   if (offp)
1635     {
1636       scm_t_array_dim *dim = scm_array_handle_dims (h);
1637       *offp = scm_array_handle_bit_elements_offset (h);
1638       *lenp = dim->ubnd - dim->lbnd + 1;
1639       *incp = dim->inc;
1640     }
1641   return scm_array_handle_bit_writable_elements (h);
1642 }
1643
1644 SCM
1645 scm_c_bitvector_ref (SCM vec, size_t idx)
1646 {
1647   scm_t_array_handle handle;
1648   const scm_t_uint32 *bits;
1649
1650   if (IS_BITVECTOR (vec))
1651     {
1652       if (idx >= BITVECTOR_LENGTH (vec))
1653         scm_out_of_range (NULL, scm_from_size_t (idx));
1654       bits = BITVECTOR_BITS(vec);
1655       return scm_from_bool (bits[idx/32] & (1L << (idx%32)));
1656     }
1657   else
1658     {
1659       SCM res;
1660       size_t len, off;
1661       ssize_t inc;
1662
1663       bits = scm_bitvector_elements (vec, &handle, &off, &len, &inc);
1664       if (idx >= len)
1665         scm_out_of_range (NULL, scm_from_size_t (idx));
1666       idx = idx*inc + off;
1667       res = scm_from_bool (bits[idx/32] & (1L << (idx%32)));
1668       scm_array_handle_release (&handle);
1669       return res;
1670     }
1671 }
1672
1673 SCM_DEFINE (scm_bitvector_ref, "bitvector-ref", 2, 0, 0,
1674             (SCM vec, SCM idx),
1675             "Return the element at index @var{idx} of the bitvector\n"
1676             "@var{vec}.")
1677 #define FUNC_NAME s_scm_bitvector_ref
1678 {
1679   return scm_c_bitvector_ref (vec, scm_to_size_t (idx));
1680 }
1681 #undef FUNC_NAME
1682
1683 void
1684 scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val)
1685 {
1686   scm_t_array_handle handle;
1687   scm_t_uint32 *bits, mask;
1688
1689   if (IS_BITVECTOR (vec))
1690     {
1691       if (idx >= BITVECTOR_LENGTH (vec))
1692         scm_out_of_range (NULL, scm_from_size_t (idx));
1693       bits = BITVECTOR_BITS(vec);
1694     }
1695   else
1696     {
1697       size_t len, off;
1698       ssize_t inc;
1699
1700       bits = scm_bitvector_writable_elements (vec, &handle, &off, &len, &inc);
1701       if (idx >= len)
1702         scm_out_of_range (NULL, scm_from_size_t (idx));
1703       idx = idx*inc + off;
1704     }
1705
1706   mask = 1L << (idx%32);
1707   if (scm_is_true (val))
1708     bits[idx/32] |= mask;
1709   else
1710     bits[idx/32] &= ~mask;
1711
1712   if (!IS_BITVECTOR (vec))
1713       scm_array_handle_release (&handle);
1714 }
1715
1716 SCM_DEFINE (scm_bitvector_set_x, "bitvector-set!", 3, 0, 0,
1717             (SCM vec, SCM idx, SCM val),
1718             "Set the element at index @var{idx} of the bitvector\n"
1719             "@var{vec} when @var{val} is true, else clear it.")
1720 #define FUNC_NAME s_scm_bitvector_set_x
1721 {
1722   scm_c_bitvector_set_x (vec, scm_to_size_t (idx), val);
1723   return SCM_UNSPECIFIED;
1724 }
1725 #undef FUNC_NAME
1726
1727 SCM_DEFINE (scm_bitvector_fill_x, "bitvector-fill!", 2, 0, 0,
1728             (SCM vec, SCM val),
1729             "Set all elements of the bitvector\n"
1730             "@var{vec} when @var{val} is true, else clear them.")
1731 #define FUNC_NAME s_scm_bitvector_fill_x
1732 {
1733   scm_t_array_handle handle;
1734   size_t off, len;
1735   ssize_t inc;
1736   scm_t_uint32 *bits;
1737
1738   bits = scm_bitvector_writable_elements (vec, &handle,
1739                                           &off, &len, &inc);
1740
1741   if (off == 0 && inc == 1 && len > 0)
1742     {
1743       /* the usual case
1744        */
1745       size_t word_len = (len + 31) / 32;
1746       scm_t_uint32 last_mask =  ((scm_t_uint32)-1) >> (32*word_len - len);
1747
1748       if (scm_is_true (val))
1749         {
1750           memset (bits, 0xFF, sizeof(scm_t_uint32)*(word_len-1));
1751           bits[word_len-1] |= last_mask;
1752         }
1753       else
1754         {
1755           memset (bits, 0x00, sizeof(scm_t_uint32)*(word_len-1));
1756           bits[word_len-1] &= ~last_mask;
1757         }
1758     }
1759   else
1760     {
1761       size_t i;
1762       for (i = 0; i < len; i++)
1763         scm_array_handle_set (&handle, i*inc, val);
1764     }
1765
1766   scm_array_handle_release (&handle);
1767
1768   return SCM_UNSPECIFIED;
1769 }
1770 #undef FUNC_NAME
1771
1772 SCM_DEFINE (scm_list_to_bitvector, "list->bitvector", 1, 0, 0,
1773             (SCM list),
1774             "Return a new bitvector initialized with the elements\n"
1775             "of @var{list}.")
1776 #define FUNC_NAME s_scm_list_to_bitvector
1777 {
1778   size_t bit_len = scm_to_size_t (scm_length (list));
1779   SCM vec = scm_c_make_bitvector (bit_len, SCM_UNDEFINED);
1780   size_t word_len = (bit_len+31)/32;
1781   scm_t_array_handle handle;
1782   scm_t_uint32 *bits = scm_bitvector_writable_elements (vec, &handle,
1783                                                         NULL, NULL, NULL);
1784   size_t i, j;
1785
1786   for (i = 0; i < word_len && scm_is_pair (list); i++, bit_len -= 32)
1787     {
1788       scm_t_uint32 mask = 1;
1789       bits[i] = 0;
1790       for (j = 0; j < 32 && j < bit_len;
1791            j++, mask <<= 1, list = SCM_CDR (list))
1792         if (scm_is_true (SCM_CAR (list)))
1793           bits[i] |= mask;
1794     }
1795
1796   scm_array_handle_release (&handle);
1797
1798   return vec;
1799 }
1800 #undef FUNC_NAME
1801
1802 SCM_DEFINE (scm_bitvector_to_list, "bitvector->list", 1, 0, 0,
1803             (SCM vec),
1804             "Return a new list initialized with the elements\n"
1805             "of the bitvector @var{vec}.")
1806 #define FUNC_NAME s_scm_bitvector_to_list
1807 {
1808   scm_t_array_handle handle;
1809   size_t off, len;
1810   ssize_t inc;
1811   scm_t_uint32 *bits;
1812   SCM res = SCM_EOL;
1813
1814   bits = scm_bitvector_writable_elements (vec, &handle,
1815                                           &off, &len, &inc);
1816
1817   if (off == 0 && inc == 1)
1818     {
1819       /* the usual case
1820        */
1821       size_t word_len = (len + 31) / 32;
1822       size_t i, j;
1823
1824       for (i = 0; i < word_len; i++, len -= 32)
1825         {
1826           scm_t_uint32 mask = 1;
1827           for (j = 0; j < 32 && j < len; j++, mask <<= 1)
1828             res = scm_cons ((bits[i] & mask)? SCM_BOOL_T : SCM_BOOL_F, res);
1829         }
1830     }
1831   else
1832     {
1833       size_t i;
1834       for (i = 0; i < len; i++)
1835         res = scm_cons (scm_array_handle_ref (&handle, i*inc), res);
1836     }
1837
1838   scm_array_handle_release (&handle);
1839
1840   return scm_reverse_x (res, SCM_EOL);
1841 }
1842 #undef FUNC_NAME
1843
1844 /* From mmix-arith.w by Knuth.
1845
1846   Here's a fun way to count the number of bits in a tetrabyte.
1847
1848   [This classical trick is called the ``Gillies--Miller method for
1849   sideways addition'' in {\sl The Preparation of Programs for an
1850   Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
1851   edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
1852   the tricks used here were suggested by Balbir Singh, Peter
1853   Rossmanith, and Stefan Schwoon.]
1854 */
1855
1856 static size_t
1857 count_ones (scm_t_uint32 x)
1858 {
1859   x=x-((x>>1)&0x55555555);
1860   x=(x&0x33333333)+((x>>2)&0x33333333);
1861   x=(x+(x>>4))&0x0f0f0f0f;
1862   x=x+(x>>8);
1863   return (x+(x>>16)) & 0xff;
1864 }
1865
1866 SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
1867             (SCM b, SCM bitvector),
1868             "Return the number of occurrences of the boolean @var{b} in\n"
1869             "@var{bitvector}.")
1870 #define FUNC_NAME s_scm_bit_count
1871 {
1872   scm_t_array_handle handle;
1873   size_t off, len;
1874   ssize_t inc;
1875   scm_t_uint32 *bits;
1876   int bit = scm_to_bool (b);
1877   size_t count = 0;
1878
1879   bits = scm_bitvector_writable_elements (bitvector, &handle,
1880                                           &off, &len, &inc);
1881
1882   if (off == 0 && inc == 1 && len > 0)
1883     {
1884       /* the usual case
1885        */
1886       size_t word_len = (len + 31) / 32;
1887       scm_t_uint32 last_mask =  ((scm_t_uint32)-1) >> (32*word_len - len);
1888       size_t i;
1889
1890       for (i = 0; i < word_len-1; i++)
1891         count += count_ones (bits[i]);
1892       count += count_ones (bits[i] & last_mask);
1893     }
1894   else
1895     {
1896       size_t i;
1897       for (i = 0; i < len; i++)
1898         if (scm_is_true (scm_array_handle_ref (&handle, i*inc)))
1899           count++;
1900     }
1901
1902   scm_array_handle_release (&handle);
1903
1904   return scm_from_size_t (bit? count : len-count);
1905 }
1906 #undef FUNC_NAME
1907
1908 /* returns 32 for x == 0.
1909 */
1910 static size_t
1911 find_first_one (scm_t_uint32 x)
1912 {
1913   size_t pos = 0;
1914   /* do a binary search in x. */
1915   if ((x & 0xFFFF) == 0)
1916     x >>= 16, pos += 16;
1917   if ((x & 0xFF) == 0)
1918     x >>= 8, pos += 8;
1919   if ((x & 0xF) == 0)
1920     x >>= 4, pos += 4;
1921   if ((x & 0x3) == 0)
1922     x >>= 2, pos += 2;
1923   if ((x & 0x1) == 0)
1924     pos += 1;
1925   return pos;
1926 }
1927
1928 SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
1929            (SCM item, SCM v, SCM k),
1930             "Return the index of the first occurrance of @var{item} in bit\n"
1931             "vector @var{v}, starting from @var{k}.  If there is no\n"
1932             "@var{item} entry between @var{k} and the end of\n"
1933             "@var{bitvector}, then return @code{#f}.  For example,\n"
1934             "\n"
1935             "@example\n"
1936             "(bit-position #t #*000101 0)  @result{} 3\n"
1937             "(bit-position #f #*0001111 3) @result{} #f\n"
1938             "@end example")
1939 #define FUNC_NAME s_scm_bit_position
1940 {
1941   scm_t_array_handle handle;
1942   size_t off, len, first_bit;
1943   ssize_t inc;
1944   const scm_t_uint32 *bits;
1945   int bit = scm_to_bool (item);
1946   SCM res = SCM_BOOL_F;
1947
1948   bits = scm_bitvector_elements (v, &handle, &off, &len, &inc);
1949   first_bit = scm_to_unsigned_integer (k, 0, len);
1950
1951   if (off == 0 && inc == 1 && len > 0)
1952     {
1953       size_t i, word_len = (len + 31) / 32;
1954       scm_t_uint32 last_mask =  ((scm_t_uint32)-1) >> (32*word_len - len);
1955       size_t first_word = first_bit / 32;
1956       scm_t_uint32 first_mask =
1957         ((scm_t_uint32)-1) << (first_bit - 32*first_word);
1958       scm_t_uint32 w;
1959
1960       for (i = first_word; i < word_len; i++)
1961         {
1962           w = (bit? bits[i] : ~bits[i]);
1963           if (i == first_word)
1964             w &= first_mask;
1965           if (i == word_len-1)
1966             w &= last_mask;
1967           if (w)
1968             {
1969               res = scm_from_size_t (32*i + find_first_one (w));
1970               break;
1971             }
1972         }
1973     }
1974   else
1975     {
1976       size_t i;
1977       for (i = first_bit; i < len; i++)
1978         {
1979           SCM elt = scm_array_handle_ref (&handle, i*inc);
1980           if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
1981             {
1982               res = scm_from_size_t (i);
1983               break;
1984             }
1985         }
1986     }
1987
1988   scm_array_handle_release (&handle);
1989
1990   return res;
1991 }
1992 #undef FUNC_NAME
1993
1994 SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
1995             (SCM v, SCM kv, SCM obj),
1996             "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1997             "selecting the entries to change.  The return value is\n"
1998             "unspecified.\n"
1999             "\n"
2000             "If @var{kv} is a bit vector, then those entries where it has\n"
2001             "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
2002             "@var{kv} and @var{v} must be the same length.  When @var{obj}\n"
2003             "is @code{#t} it's like @var{kv} is OR'ed into @var{v}.  Or when\n"
2004             "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
2005             "\n"
2006             "@example\n"
2007             "(define bv #*01000010)\n"
2008             "(bit-set*! bv #*10010001 #t)\n"
2009             "bv\n"
2010             "@result{} #*11010011\n"
2011             "@end example\n"
2012             "\n"
2013             "If @var{kv} is a u32vector, then its elements are\n"
2014             "indices into @var{v} which are set to @var{obj}.\n"
2015             "\n"
2016             "@example\n"
2017             "(define bv #*01000010)\n"
2018             "(bit-set*! bv #u32(5 2 7) #t)\n"
2019             "bv\n"
2020             "@result{} #*01100111\n"
2021             "@end example")
2022 #define FUNC_NAME s_scm_bit_set_star_x
2023 {
2024   scm_t_array_handle v_handle;
2025   size_t v_off, v_len;
2026   ssize_t v_inc;
2027   scm_t_uint32 *v_bits;
2028   int bit;
2029
2030   /* Validate that OBJ is a boolean so this is done even if we don't
2031      need BIT.
2032   */
2033   bit = scm_to_bool (obj);
2034
2035   v_bits = scm_bitvector_writable_elements (v, &v_handle,
2036                                             &v_off, &v_len, &v_inc);
2037
2038   if (scm_is_bitvector (kv))
2039     {
2040       scm_t_array_handle kv_handle;
2041       size_t kv_off, kv_len;
2042       ssize_t kv_inc;
2043       const scm_t_uint32 *kv_bits;
2044
2045       kv_bits = scm_bitvector_elements (v, &kv_handle,
2046                                         &kv_off, &kv_len, &kv_inc);
2047
2048       if (v_len != kv_len)
2049         scm_misc_error (NULL,
2050                         "bit vectors must have equal length",
2051                         SCM_EOL);
2052
2053       if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
2054         {
2055           size_t word_len = (kv_len + 31) / 32;
2056           scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
2057           size_t i;
2058
2059           if (bit == 0)
2060             {
2061               for (i = 0; i < word_len-1; i++)
2062                 v_bits[i] &= ~kv_bits[i];
2063               v_bits[i] &= ~(kv_bits[i] & last_mask);
2064             }
2065           else
2066             {
2067               for (i = 0; i < word_len-1; i++)
2068                 v_bits[i] |= kv_bits[i];
2069               v_bits[i] |= kv_bits[i] & last_mask;
2070             }
2071         }
2072       else
2073         {
2074           size_t i;
2075           for (i = 0; i < kv_len; i++)
2076             if (scm_is_true (scm_array_handle_ref (&kv_handle, i*kv_inc)))
2077               scm_array_handle_set (&v_handle, i*v_inc, obj);
2078         }
2079
2080       scm_array_handle_release (&kv_handle);
2081
2082     }
2083   else if (scm_is_true (scm_u32vector_p (kv)))
2084     {
2085       scm_t_array_handle kv_handle;
2086       size_t i, kv_len;
2087       ssize_t kv_inc;
2088       const scm_t_uint32 *kv_elts;
2089
2090       kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
2091       for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
2092         scm_array_handle_set (&v_handle, (*kv_elts)*v_inc, obj);
2093
2094       scm_array_handle_release (&kv_handle);
2095     }
2096   else
2097     scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
2098
2099   scm_array_handle_release (&v_handle);
2100
2101   return SCM_UNSPECIFIED;
2102 }
2103 #undef FUNC_NAME
2104
2105
2106 SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
2107            (SCM v, SCM kv, SCM obj),
2108             "Return a count of how many entries in bit vector @var{v} are\n"
2109             "equal to @var{obj}, with @var{kv} selecting the entries to\n"
2110             "consider.\n"
2111             "\n"
2112             "If @var{kv} is a bit vector, then those entries where it has\n"
2113             "@code{#t} are the ones in @var{v} which are considered.\n"
2114             "@var{kv} and @var{v} must be the same length.\n"
2115             "\n"
2116             "If @var{kv} is a u32vector, then it contains\n"
2117             "the indexes in @var{v} to consider.\n"
2118             "\n"
2119             "For example,\n"
2120             "\n"
2121             "@example\n"
2122             "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
2123             "(bit-count* #*01110111 #u32(7 0 4) #f)  @result{} 2\n"
2124             "@end example")
2125 #define FUNC_NAME s_scm_bit_count_star
2126 {
2127   scm_t_array_handle v_handle;
2128   size_t v_off, v_len;
2129   ssize_t v_inc;
2130   const scm_t_uint32 *v_bits;
2131   size_t count = 0;
2132   int bit;
2133
2134   /* Validate that OBJ is a boolean so this is done even if we don't
2135      need BIT.
2136   */
2137   bit = scm_to_bool (obj);
2138
2139   v_bits = scm_bitvector_elements (v, &v_handle,
2140                                    &v_off, &v_len, &v_inc);
2141
2142   if (scm_is_bitvector (kv))
2143     {
2144       scm_t_array_handle kv_handle;
2145       size_t kv_off, kv_len;
2146       ssize_t kv_inc;
2147       const scm_t_uint32 *kv_bits;
2148
2149       kv_bits = scm_bitvector_elements (v, &kv_handle,
2150                                         &kv_off, &kv_len, &kv_inc);
2151
2152       if (v_len != kv_len)
2153         scm_misc_error (NULL,
2154                         "bit vectors must have equal length",
2155                         SCM_EOL);
2156
2157       if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
2158         {
2159           size_t i, word_len = (kv_len + 31) / 32;
2160           scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
2161           scm_t_uint32 xor_mask = bit? 0 : ((scm_t_uint32)-1);
2162
2163           for (i = 0; i < word_len-1; i++)
2164             count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i]);
2165           count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i] & last_mask);
2166         }
2167       else
2168         {
2169           size_t i;
2170           for (i = 0; i < kv_len; i++)
2171             if (scm_is_true (scm_array_handle_ref (&kv_handle, i)))
2172               {
2173                 SCM elt = scm_array_handle_ref (&v_handle, i*v_inc);
2174                 if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
2175                   count++;
2176               }
2177         }
2178
2179       scm_array_handle_release (&kv_handle);
2180
2181     }
2182   else if (scm_is_true (scm_u32vector_p (kv)))
2183     {
2184       scm_t_array_handle kv_handle;
2185       size_t i, kv_len;
2186       ssize_t kv_inc;
2187       const scm_t_uint32 *kv_elts;
2188
2189       kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
2190       for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
2191         {
2192           SCM elt = scm_array_handle_ref (&v_handle, (*kv_elts)*v_inc);
2193           if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
2194             count++;
2195         }
2196
2197       scm_array_handle_release (&kv_handle);
2198     }
2199   else
2200     scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
2201
2202   scm_array_handle_release (&v_handle);
2203
2204   return scm_from_size_t (count);
2205 }
2206 #undef FUNC_NAME
2207
2208 SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
2209            (SCM v),
2210             "Modify the bit vector @var{v} by replacing each element with\n"
2211             "its negation.")
2212 #define FUNC_NAME s_scm_bit_invert_x
2213 {
2214   scm_t_array_handle handle;
2215   size_t off, len;
2216   ssize_t inc;
2217   scm_t_uint32 *bits;
2218
2219   bits = scm_bitvector_writable_elements (v, &handle, &off, &len, &inc);
2220
2221   if (off == 0 && inc == 1 && len > 0)
2222     {
2223       size_t word_len = (len + 31) / 32;
2224       scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
2225       size_t i;
2226
2227       for (i = 0; i < word_len-1; i++)
2228         bits[i] = ~bits[i];
2229       bits[i] = bits[i] ^ last_mask;
2230     }
2231   else
2232     {
2233       size_t i;
2234       for (i = 0; i < len; i++)
2235         scm_array_handle_set (&handle, i*inc,
2236                               scm_not (scm_array_handle_ref (&handle, i*inc)));
2237     }
2238
2239   scm_array_handle_release (&handle);
2240
2241   return SCM_UNSPECIFIED;
2242 }
2243 #undef FUNC_NAME
2244
2245
2246 SCM
2247 scm_istr2bve (SCM str)
2248 {
2249   scm_t_array_handle handle;
2250   size_t len = scm_i_string_length (str);
2251   SCM vec = scm_c_make_bitvector (len, SCM_UNDEFINED);
2252   SCM res = vec;
2253
2254   scm_t_uint32 mask;
2255   size_t k, j;
2256   const char *c_str;
2257   scm_t_uint32 *data;
2258
2259   data = scm_bitvector_writable_elements (vec, &handle, NULL, NULL, NULL);
2260   c_str = scm_i_string_chars (str);
2261
2262   for (k = 0; k < (len + 31) / 32; k++)
2263     {
2264       data[k] = 0L;
2265       j = len - k * 32;
2266       if (j > 32)
2267         j = 32;
2268       for (mask = 1L; j--; mask <<= 1)
2269         switch (*c_str++)
2270           {
2271           case '0':
2272             break;
2273           case '1':
2274             data[k] |= mask;
2275             break;
2276           default:
2277             res = SCM_BOOL_F;
2278             goto exit;
2279           }
2280     }
2281
2282  exit:
2283   scm_array_handle_release (&handle);
2284   scm_remember_upto_here_1 (str);
2285   return res;
2286 }
2287
2288
2289
2290 static SCM
2291 ra2l (SCM ra, unsigned long base, unsigned long k)
2292 {
2293   SCM res = SCM_EOL;
2294   long inc;
2295   size_t i;
2296   int enclosed = SCM_I_ENCLOSED_ARRAYP (ra);
2297
2298   if (k == SCM_I_ARRAY_NDIM (ra))
2299     return scm_i_cvref (SCM_I_ARRAY_V (ra), base, enclosed);
2300
2301   inc = SCM_I_ARRAY_DIMS (ra)[k].inc;
2302   if (SCM_I_ARRAY_DIMS (ra)[k].ubnd < SCM_I_ARRAY_DIMS (ra)[k].lbnd)
2303     return SCM_EOL;
2304   i = base + (1 + SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * inc;
2305   do
2306     {
2307       i -= inc;
2308       res = scm_cons (ra2l (ra, i, k + 1), res);
2309     }
2310   while (i != base);
2311   return res;
2312 }
2313
2314
2315 SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
2316            (SCM v),
2317             "Return a list consisting of all the elements, in order, of\n"
2318             "@var{array}.")
2319 #define FUNC_NAME s_scm_array_to_list
2320 {
2321   if (scm_is_generalized_vector (v))
2322     return scm_generalized_vector_to_list (v);
2323   else if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v))
2324     return ra2l (v, SCM_I_ARRAY_BASE (v), 0);
2325
2326   scm_wrong_type_arg_msg (NULL, 0, v, "array");
2327 }
2328 #undef FUNC_NAME
2329
2330
2331 static void l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k);
2332
2333 SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
2334            (SCM type, SCM shape, SCM lst),
2335             "Return an array of the type @var{type}\n"
2336             "with elements the same as those of @var{lst}.\n"
2337             "\n"
2338             "The argument @var{shape} determines the number of dimensions\n"
2339             "of the array and their shape.  It is either an exact integer,\n"
2340             "giving the\n"
2341             "number of dimensions directly, or a list whose length\n"
2342             "specifies the number of dimensions and each element specified\n"
2343             "the lower and optionally the upper bound of the corresponding\n"
2344             "dimension.\n"
2345             "When the element is list of two elements, these elements\n"
2346             "give the lower and upper bounds.  When it is an exact\n"
2347             "integer, it gives only the lower bound.")
2348 #define FUNC_NAME s_scm_list_to_typed_array
2349 {
2350   SCM row;
2351   SCM ra;
2352   scm_t_array_handle handle;
2353
2354   row = lst;
2355   if (scm_is_integer (shape))
2356     {
2357       size_t k = scm_to_size_t (shape);
2358       shape = SCM_EOL;
2359       while (k-- > 0)
2360         {
2361           shape = scm_cons (scm_length (row), shape);
2362           if (k > 0 && !scm_is_null (row))
2363             row = scm_car (row);
2364         }
2365     }
2366   else
2367     {
2368       SCM shape_spec = shape;
2369       shape = SCM_EOL;
2370       while (1)
2371         {
2372           SCM spec = scm_car (shape_spec);
2373           if (scm_is_pair (spec))
2374             shape = scm_cons (spec, shape);
2375           else
2376             shape = scm_cons (scm_list_2 (spec,
2377                                           scm_sum (scm_sum (spec,
2378                                                             scm_length (row)),
2379                                                    scm_from_int (-1))),
2380                               shape);
2381           shape_spec = scm_cdr (shape_spec);
2382           if (scm_is_pair (shape_spec))
2383             {
2384               if (!scm_is_null (row))
2385                 row = scm_car (row);
2386             }
2387           else
2388             break;
2389         }
2390     }
2391
2392   ra = scm_make_typed_array (type, SCM_UNSPECIFIED,
2393                              scm_reverse_x (shape, SCM_EOL));
2394
2395   scm_array_get_handle (ra, &handle);
2396   l2ra (lst, &handle, 0, 0);
2397   scm_array_handle_release (&handle);
2398
2399   return ra;
2400 }
2401 #undef FUNC_NAME
2402
2403 SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0,
2404            (SCM ndim, SCM lst),
2405             "Return an array with elements the same as those of @var{lst}.")
2406 #define FUNC_NAME s_scm_list_to_array
2407 {
2408   return scm_list_to_typed_array (SCM_BOOL_T, ndim, lst);
2409 }
2410 #undef FUNC_NAME
2411
2412 static void
2413 l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
2414 {
2415   if (k == scm_array_handle_rank (handle))
2416     scm_array_handle_set (handle, pos, lst);
2417   else
2418     {
2419       scm_t_array_dim *dim = scm_array_handle_dims (handle) + k;
2420       ssize_t inc = dim->inc;
2421       size_t len = 1 + dim->ubnd - dim->lbnd, n;
2422       char *errmsg = NULL;
2423
2424       n = len;
2425       while (n > 0 && scm_is_pair (lst))
2426         {
2427           l2ra (SCM_CAR (lst), handle, pos, k + 1);
2428           pos += inc;
2429           lst = SCM_CDR (lst);
2430           n -= 1;
2431         }
2432       if (n != 0)
2433         errmsg = "too few elements for array dimension ~a, need ~a";
2434       if (!scm_is_null (lst))
2435         errmsg = "too many elements for array dimension ~a, want ~a";
2436       if (errmsg)
2437         scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k),
2438                                                   scm_from_size_t (len)));
2439     }
2440 }
2441
2442 #if SCM_ENABLE_DEPRECATED
2443
2444 SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0,
2445            (SCM ndim, SCM prot, SCM lst),
2446             "Return a uniform array of the type indicated by prototype\n"
2447             "@var{prot} with elements the same as those of @var{lst}.\n"
2448             "Elements must be of the appropriate type, no coercions are\n"
2449             "done.\n"
2450             "\n"
2451             "The argument @var{ndim} determines the number of dimensions\n"
2452             "of the array.  It is either an exact integer, giving the\n"
2453             "number directly, or a list of exact integers, whose length\n"
2454             "specifies the number of dimensions and each element is the\n"
2455             "lower index bound of its dimension.")
2456 #define FUNC_NAME s_scm_list_to_uniform_array
2457 {
2458   return scm_list_to_typed_array (prototype_to_type (prot), ndim, lst);
2459 }
2460 #undef FUNC_NAME
2461
2462 #endif
2463
2464 /* Print dimension DIM of ARRAY.
2465  */
2466
2467 static int
2468 scm_i_print_array_dimension (SCM array, int dim, int base, int enclosed,
2469                              SCM port, scm_print_state *pstate)
2470 {
2471   scm_t_array_dim *dim_spec = SCM_I_ARRAY_DIMS (array) + dim;
2472   long idx;
2473
2474   scm_putc ('(', port);
2475
2476   for (idx = dim_spec->lbnd; idx <= dim_spec->ubnd; idx++)
2477     {
2478       if (dim < SCM_I_ARRAY_NDIM(array)-1)
2479         scm_i_print_array_dimension (array, dim+1, base, enclosed,
2480                                      port, pstate);
2481       else
2482         scm_iprin1 (scm_i_cvref (SCM_I_ARRAY_V (array), base, enclosed),
2483                     port, pstate);
2484       if (idx < dim_spec->ubnd)
2485         scm_putc (' ', port);
2486       base += dim_spec->inc;
2487     }
2488
2489   scm_putc (')', port);
2490   return 1;
2491 }
2492
2493 /* Print an array.  (Only for strict arrays, not for generalized vectors.)
2494 */
2495
2496 static int
2497 scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
2498 {
2499   long ndim = SCM_I_ARRAY_NDIM (array);
2500   scm_t_array_dim *dim_specs = SCM_I_ARRAY_DIMS (array);
2501   SCM v = SCM_I_ARRAY_V (array);
2502   unsigned long base = SCM_I_ARRAY_BASE (array);
2503   long i;
2504   int print_lbnds = 0, zero_size = 0, print_lens = 0;
2505
2506   scm_putc ('#', port);
2507   if (ndim != 1 || dim_specs[0].lbnd != 0)
2508     scm_intprint (ndim, 10, port);
2509   if (scm_is_uniform_vector (v))
2510     scm_puts (scm_i_uniform_vector_tag (v), port);
2511   else if (scm_is_bitvector (v))
2512     scm_puts ("b", port);
2513   else if (scm_is_string (v))
2514     scm_puts ("a", port);
2515   else if (!scm_is_vector (v))
2516     scm_puts ("?", port);
2517
2518   for (i = 0; i < ndim; i++)
2519     {
2520       if (dim_specs[i].lbnd != 0)
2521         print_lbnds = 1;
2522       if (dim_specs[i].ubnd - dim_specs[i].lbnd + 1 == 0)
2523         zero_size = 1;
2524       else if (zero_size)
2525         print_lens = 1;
2526     }
2527
2528   if (print_lbnds || print_lens)
2529     for (i = 0; i < ndim; i++)
2530       {
2531         if (print_lbnds)
2532           {
2533             scm_putc ('@', port);
2534             scm_intprint (dim_specs[i].lbnd, 10, port);
2535           }
2536         if (print_lens)
2537           {
2538             scm_putc (':', port);
2539             scm_intprint (dim_specs[i].ubnd - dim_specs[i].lbnd + 1,
2540                           10, port);
2541           }
2542       }
2543
2544   if (ndim == 0)
2545     {
2546       /* Rank zero arrays, which are really just scalars, are printed
2547          specially.  The consequent way would be to print them as
2548
2549             #0 OBJ
2550
2551          where OBJ is the printed representation of the scalar, but we
2552          print them instead as
2553
2554             #0(OBJ)
2555
2556          to make them look less strange.
2557
2558          Just printing them as
2559
2560             OBJ
2561
2562          would be correct in a way as well, but zero rank arrays are
2563          not really the same as Scheme values since they are boxed and
2564          can be modified with array-set!, say.
2565       */
2566       scm_putc ('(', port);
2567       scm_iprin1 (scm_i_cvref (v, base, 0), port, pstate);
2568       scm_putc (')', port);
2569       return 1;
2570     }
2571   else
2572     return scm_i_print_array_dimension (array, 0, base, 0, port, pstate);
2573 }
2574
2575 static int
2576 scm_i_print_enclosed_array (SCM array, SCM port, scm_print_state *pstate)
2577 {
2578   size_t base;
2579
2580   scm_putc ('#', port);
2581   base = SCM_I_ARRAY_BASE (array);
2582   scm_puts ("<enclosed-array ", port);
2583   scm_i_print_array_dimension (array, 0, base, 1, port, pstate);
2584   scm_putc ('>', port);
2585   return 1;
2586 }
2587
2588 /* Read an array.  This function can also read vectors and uniform
2589    vectors.  Also, the conflict between '#f' and '#f32' and '#f64' is
2590    handled here.
2591
2592    C is the first character read after the '#'.
2593 */
2594
2595 static SCM
2596 tag_to_type (const char *tag, SCM port)
2597 {
2598 #if SCM_ENABLE_DEPRECATED
2599   {
2600     /* Recognize the old syntax.
2601      */
2602     const char *instead;
2603     switch (tag[0])
2604       {
2605       case 'u':
2606         instead = "u32";
2607         break;
2608       case 'e':
2609         instead = "s32";
2610         break;
2611       case 's':
2612         instead = "f32";
2613         break;
2614       case 'i':
2615         instead = "f64";
2616         break;
2617       case 'y':
2618         instead = "s8";
2619         break;
2620       case 'h':
2621         instead = "s16";
2622         break;
2623       case 'l':
2624         instead = "s64";
2625         break;
2626       case 'c':
2627         instead = "c64";
2628         break;
2629       default:
2630         instead = NULL;
2631         break;
2632       }
2633
2634     if (instead && tag[1] == '\0')
2635       {
2636         scm_c_issue_deprecation_warning_fmt
2637           ("The tag '%c' is deprecated for uniform vectors. "
2638            "Use '%s' instead.", tag[0], instead);
2639         return scm_from_locale_symbol (instead);
2640       }
2641   }
2642 #endif
2643
2644   if (*tag == '\0')
2645     return SCM_BOOL_T;
2646   else
2647     return scm_from_locale_symbol (tag);
2648 }
2649
2650 static int
2651 read_decimal_integer (SCM port, int c, ssize_t *resp)
2652 {
2653   ssize_t sign = 1;
2654   ssize_t res = 0;
2655   int got_it = 0;
2656
2657   if (c == '-')
2658     {
2659       sign = -1;
2660       c = scm_getc (port);
2661     }
2662
2663   while ('0' <= c && c <= '9')
2664     {
2665       res = 10*res + c-'0';
2666       got_it = 1;
2667       c = scm_getc (port);
2668     }
2669
2670   if (got_it)
2671     *resp = sign * res;
2672   return c;
2673 }
2674
2675 SCM
2676 scm_i_read_array (SCM port, int c)
2677 {
2678   ssize_t rank;
2679   int got_rank;
2680   char tag[80];
2681   int tag_len;
2682
2683   SCM shape = SCM_BOOL_F, elements;
2684
2685   /* XXX - shortcut for ordinary vectors.  Shouldn't be necessary but
2686      the array code can not deal with zero-length dimensions yet, and
2687      we want to allow zero-length vectors, of course.
2688   */
2689   if (c == '(')
2690     {
2691       scm_ungetc (c, port);
2692       return scm_vector (scm_read (port));
2693     }
2694
2695   /* Disambiguate between '#f' and uniform floating point vectors.
2696    */
2697   if (c == 'f')
2698     {
2699       c = scm_getc (port);
2700       if (c != '3' && c != '6')
2701         {
2702           if (c != EOF)
2703             scm_ungetc (c, port);
2704           return SCM_BOOL_F;
2705         }
2706       rank = 1;
2707       got_rank = 1;
2708       tag[0] = 'f';
2709       tag_len = 1;
2710       goto continue_reading_tag;
2711     }
2712
2713   /* Read rank.
2714    */
2715   rank = 1;
2716   c = read_decimal_integer (port, c, &rank);
2717   if (rank < 0)
2718     scm_i_input_error (NULL, port, "array rank must be non-negative",
2719                        SCM_EOL);
2720
2721   /* Read tag.
2722    */
2723   tag_len = 0;
2724  continue_reading_tag:
2725   while (c != EOF && c != '(' && c != '@' && c != ':' && tag_len < 80)
2726     {
2727       tag[tag_len++] = c;
2728       c = scm_getc (port);
2729     }
2730   tag[tag_len] = '\0';
2731
2732   /* Read shape.
2733    */
2734   if (c == '@' || c == ':')
2735     {
2736       shape = SCM_EOL;
2737
2738       do
2739         {
2740           ssize_t lbnd = 0, len = 0;
2741           SCM s;
2742
2743           if (c == '@')
2744             {
2745               c = scm_getc (port);
2746               c = read_decimal_integer (port, c, &lbnd);
2747             }
2748
2749           s = scm_from_ssize_t (lbnd);
2750
2751           if (c == ':')
2752             {
2753               c = scm_getc (port);
2754               c = read_decimal_integer (port, c, &len);
2755               if (len < 0)
2756                 scm_i_input_error (NULL, port,
2757                                    "array length must be non-negative",
2758                                    SCM_EOL);
2759
2760               s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1));
2761             }
2762
2763           shape = scm_cons (s, shape);
2764         } while (c == '@' || c == ':');
2765
2766       shape = scm_reverse_x (shape, SCM_EOL);
2767     }
2768
2769   /* Read nested lists of elements.
2770    */
2771   if (c != '(')
2772     scm_i_input_error (NULL, port,
2773                        "missing '(' in vector or array literal",
2774                        SCM_EOL);
2775   scm_ungetc (c, port);
2776   elements = scm_read (port);
2777
2778   if (scm_is_false (shape))
2779     shape = scm_from_ssize_t (rank);
2780   else if (scm_ilength (shape) != rank)
2781     scm_i_input_error
2782       (NULL, port,
2783        "the number of shape specifications must match the array rank",
2784        SCM_EOL);
2785
2786   /* Handle special print syntax of rank zero arrays; see
2787      scm_i_print_array for a rationale.
2788   */
2789   if (rank == 0)
2790     {
2791       if (!scm_is_pair (elements))
2792         scm_i_input_error (NULL, port,
2793                            "too few elements in array literal, need 1",
2794                            SCM_EOL);
2795       if (!scm_is_null (SCM_CDR (elements)))
2796         scm_i_input_error (NULL, port,
2797                            "too many elements in array literal, want 1",
2798                            SCM_EOL);
2799       elements = SCM_CAR (elements);
2800     }
2801
2802   /* Construct array.
2803    */
2804   return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements);
2805 }
2806
2807 SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
2808            (SCM ra),
2809             "")
2810 #define FUNC_NAME s_scm_array_type
2811 {
2812   if (SCM_I_ARRAYP (ra))
2813     return scm_i_generalized_vector_type (SCM_I_ARRAY_V (ra));
2814   else if (scm_is_generalized_vector (ra))
2815     return scm_i_generalized_vector_type (ra);
2816   else if (SCM_I_ENCLOSED_ARRAYP (ra))
2817     scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array");
2818   else
2819     scm_wrong_type_arg_msg (NULL, 0, ra, "array");
2820 }
2821 #undef FUNC_NAME
2822
2823 #if SCM_ENABLE_DEPRECATED
2824
2825 SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0,
2826            (SCM ra),
2827             "Return an object that would produce an array of the same type\n"
2828             "as @var{array}, if used as the @var{prototype} for\n"
2829             "@code{make-uniform-array}.")
2830 #define FUNC_NAME s_scm_array_prototype
2831 {
2832   if (SCM_I_ARRAYP (ra))
2833     return scm_i_get_old_prototype (SCM_I_ARRAY_V (ra));
2834   else if (scm_is_generalized_vector (ra))
2835     return scm_i_get_old_prototype (ra);
2836   else if (SCM_I_ENCLOSED_ARRAYP (ra))
2837     return SCM_UNSPECIFIED;
2838   else
2839     scm_wrong_type_arg_msg (NULL, 0, ra, "array");
2840 }
2841 #undef FUNC_NAME
2842
2843 #endif
2844
2845 static SCM
2846 array_mark (SCM ptr)
2847 {
2848   return SCM_I_ARRAY_V (ptr);
2849 }
2850
2851 static size_t
2852 array_free (SCM ptr)
2853 {
2854   scm_gc_free (SCM_I_ARRAY_MEM (ptr),
2855                (sizeof (scm_i_t_array)
2856                 + SCM_I_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)),
2857                "array");
2858   return 0;
2859 }
2860
2861 #if SCM_ENABLE_DEPRECATED
2862
2863 SCM
2864 scm_make_ra (int ndim)
2865 {
2866   scm_c_issue_deprecation_warning
2867     ("scm_make_ra is deprecated.  Use scm_make_array or similar instead.");
2868   return scm_i_make_ra (ndim, 0);
2869 }
2870
2871 SCM
2872 scm_shap2ra (SCM args, const char *what)
2873 {
2874   scm_c_issue_deprecation_warning
2875     ("scm_shap2ra is deprecated.  Use scm_make_array or similar instead.");
2876   return scm_i_shap2ra (args);
2877 }
2878
2879 SCM
2880 scm_cvref (SCM v, unsigned long pos, SCM last)
2881 {
2882   scm_c_issue_deprecation_warning
2883     ("scm_cvref is deprecated.  Use scm_c_generalized_vector_ref instead.");
2884   return scm_c_generalized_vector_ref (v, pos);
2885 }
2886
2887 void
2888 scm_ra_set_contp (SCM ra)
2889 {
2890   scm_c_issue_deprecation_warning
2891     ("scm_ra_set_contp is deprecated.  There should be no need for it.");
2892   scm_i_ra_set_contp (ra);
2893 }
2894
2895 long
2896 scm_aind (SCM ra, SCM args, const char *what)
2897 {
2898   scm_t_array_handle handle;
2899   ssize_t pos;
2900
2901   scm_c_issue_deprecation_warning
2902     ("scm_aind is deprecated.  Use scm_array_handle_pos instead.");
2903
2904   if (scm_is_integer (args))
2905     args = scm_list_1 (args);
2906
2907   scm_array_get_handle (ra, &handle);
2908   pos = scm_array_handle_pos (&handle, args) + SCM_I_ARRAY_BASE (ra);
2909   scm_array_handle_release (&handle);
2910   return pos;
2911 }
2912
2913 int
2914 scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
2915 {
2916   scm_c_issue_deprecation_warning
2917     ("scm_raprin1 is deprecated.  Use scm_display or scm_write instead.");
2918
2919   scm_iprin1 (exp, port, pstate);
2920   return 1;
2921 }
2922
2923 #endif
2924
2925 void
2926 scm_init_unif ()
2927 {
2928   scm_i_tc16_array = scm_make_smob_type ("array", 0);
2929   scm_set_smob_mark (scm_i_tc16_array, array_mark);
2930   scm_set_smob_free (scm_i_tc16_array, array_free);
2931   scm_set_smob_print (scm_i_tc16_array, scm_i_print_array);
2932   scm_set_smob_equalp (scm_i_tc16_array, scm_array_equal_p);
2933
2934   scm_i_tc16_enclosed_array = scm_make_smob_type ("enclosed-array", 0);
2935   scm_set_smob_mark (scm_i_tc16_enclosed_array, array_mark);
2936   scm_set_smob_free (scm_i_tc16_enclosed_array, array_free);
2937   scm_set_smob_print (scm_i_tc16_enclosed_array, scm_i_print_enclosed_array);
2938   scm_set_smob_equalp (scm_i_tc16_enclosed_array, scm_array_equal_p);
2939
2940   scm_add_feature ("array");
2941
2942   scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0);
2943   scm_set_smob_free (scm_tc16_bitvector, bitvector_free);
2944   scm_set_smob_print (scm_tc16_bitvector, bitvector_print);
2945   scm_set_smob_equalp (scm_tc16_bitvector, bitvector_equalp);
2946
2947   init_type_creator_table ();
2948
2949 #include "libguile/unif.x"
2950
2951 }
2952
2953 /*
2954   Local Variables:
2955   c-file-style: "gnu"
2956   End:
2957 */