libguile/vectors.c

   1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009, 2010,
   2  *   2011, 2012, 2014 Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20
  21 \f
  22 #ifdef HAVE_CONFIG_H
  23 # include <config.h>
  24 #endif
  25
  26 #include "libguile/_scm.h"
  27 #include "libguile/eq.h"
  28 #include "libguile/root.h"
  29 #include "libguile/strings.h"
  30
  31 #include "libguile/validate.h"
  32 #include "libguile/vectors.h"
  33 #include "libguile/arrays.h" /* Hit me with the ugly stick */
  34 #include "libguile/generalized-vectors.h"
  35 #include "libguile/strings.h"
  36 #include "libguile/srfi-13.h"
  37 #include "libguile/dynwind.h"
  38 #include "libguile/deprecation.h"
  39
  40 #include "libguile/bdw-gc.h"
  41
  42
  43 \f
  44
  45 #define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
  46
  47 int
  48 scm_is_vector (SCM obj)
  49 {
  50   if (SCM_I_IS_NONWEAK_VECTOR (obj))
  51     return 1;
  52   if (SCM_I_WVECTP (obj))
  53     {
  54       scm_c_issue_deprecation_warning
  55         ("Expecting vector? to be true for weak vectors is deprecated.  "
  56          "Use weak-vector? instead.");
  57       return 1;
  58     }
  59   if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
  60     {
  61       SCM v = SCM_I_ARRAY_V (obj);
  62       if (SCM_I_IS_VECTOR (v))
  63         {
  64           scm_c_issue_deprecation_warning
  65             ("Expecting vector? to be true for rank-1 arrays is deprecated.  "
  66              "Use array?, array-rank, and array-type instead.");
  67           return 1;
  68         }
  69       return 0;
  70     }
  71   return 0;
  72 }
  73
  74 int
  75 scm_is_simple_vector (SCM obj)
  76 {
  77   if (SCM_I_IS_NONWEAK_VECTOR (obj))
  78     return 1;
  79   if (SCM_I_WVECTP (obj))
  80     {
  81       scm_c_issue_deprecation_warning
  82         ("Expecting scm_is_simple_vector to be true for weak vectors is "
  83          "deprecated.  Use scm_is_weak_vector instead.");
  84       return 1;
  85     }
  86   return 0;
  87 }
  88
  89 const SCM *
  90 scm_vector_elements (SCM vec, scm_t_array_handle *h,
  91                      size_t *lenp, ssize_t *incp)
  92 {
  93   if (SCM_I_WVECTP (vec))
  94     /* FIXME: We should check each (weak) element of the vector for NULL and
  95        convert it to SCM_BOOL_F.  */
  96     abort ();
  97
  98   scm_generalized_vector_get_handle (vec, h);
  99   if (lenp)
 100     {
 101       scm_t_array_dim *dim = scm_array_handle_dims (h);
 102       *lenp = dim->ubnd - dim->lbnd + 1;
 103       *incp = dim->inc;
 104     }
 105   return scm_array_handle_elements (h);
 106 }
 107
 108 SCM *
 109 scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
 110                               size_t *lenp, ssize_t *incp)
 111 {
 112   if (SCM_I_WVECTP (vec))
 113     /* FIXME: We should check each (weak) element of the vector for NULL and
 114        convert it to SCM_BOOL_F.  */
 115     abort ();
 116
 117   scm_generalized_vector_get_handle (vec, h);
 118   if (lenp)
 119     {
 120       scm_t_array_dim *dim = scm_array_handle_dims (h);
 121       *lenp = dim->ubnd - dim->lbnd + 1;
 122       *incp = dim->inc;
 123     }
 124   return scm_array_handle_writable_elements (h);
 125 }
 126
 127 SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0,
 128             (SCM obj),
 129             "Return @code{#t} if @var{obj} is a vector, otherwise return\n"
 130             "@code{#f}.")
 131 #define FUNC_NAME s_scm_vector_p
 132 {
 133   return scm_from_bool (scm_is_vector (obj));
 134 }
 135 #undef FUNC_NAME
 136
 137 SCM_GPROC (s_vector_length, "vector-length", 1, 0, 0, scm_vector_length, g_vector_length);
 138 /* Returns the number of elements in @var{vector} as an exact integer.  */
 139 SCM
 140 scm_vector_length (SCM v)
 141 {
 142   if (SCM_I_IS_VECTOR (v))
 143     {
 144       if (SCM_I_WVECTP (v))
 145         scm_c_issue_deprecation_warning
 146           ("Using vector-length on weak vectors is deprecated.  "
 147            "Use weak-vector-length from (ice-9 weak-vectors) instead.");
 148       return scm_from_size_t (SCM_I_VECTOR_LENGTH (v));
 149     }
 150   else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
 151     {
 152       scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
 153       scm_c_issue_deprecation_warning
 154         ("Using vector-length on arrays is deprecated.  "
 155          "Use array-length instead.");
 156       return scm_from_size_t (dim->ubnd - dim->lbnd + 1);
 157     }
 158   else if (SCM_UNPACK (g_vector_length))
 159     {
 160       scm_c_issue_deprecation_warning
 161         ("Using vector-length as a primitive-generic is deprecated.");
 162       return scm_call_generic_1 (g_vector_length, v);
 163     }
 164   else
 165     {
 166       scm_wrong_type_arg_msg ("vector-length", 1, v, "vector");
 167       return SCM_UNDEFINED;  /* not reached */
 168     }
 169 }
 170
 171 size_t
 172 scm_c_vector_length (SCM v)
 173 {
 174   if (SCM_I_IS_NONWEAK_VECTOR (v))
 175     return SCM_I_VECTOR_LENGTH (v);
 176   else
 177     return scm_to_size_t (scm_vector_length (v));
 178 }
 179
 180 SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector);
 181 /*
 182             "Return a newly created vector initialized to the elements of"
 183             "the list @var{list}.\n\n"
 184             "@lisp\n"
 185             "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
 186             "(list->vector '(dididit dah)) @result{}   #(dididit dah)\n"
 187             "@end lisp")
 188 */
 189 SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
 190             (SCM l),
 191             "@deffnx {Scheme Procedure} list->vector l\n"
 192             "Return a newly allocated vector composed of the\n"
 193             "given arguments.  Analogous to @code{list}.\n"
 194             "\n"
 195             "@lisp\n"
 196             "(vector 'a 'b 'c) @result{} #(a b c)\n"
 197             "@end lisp")
 198 #define FUNC_NAME s_scm_vector
 199 {
 200   SCM res;
 201   SCM *data;
 202   long i, len;
 203   scm_t_array_handle handle;
 204
 205   SCM_VALIDATE_LIST_COPYLEN (1, l, len);
 206
 207   res = scm_c_make_vector (len, SCM_UNSPECIFIED);
 208   data = scm_vector_writable_elements (res, &handle, NULL, NULL);
 209   i = 0;
 210   while (scm_is_pair (l) && i < len)
 211     {
 212       data[i] = SCM_CAR (l);
 213       l = SCM_CDR (l);
 214       i += 1;
 215     }
 216
 217   scm_array_handle_release (&handle);
 218
 219   return res;
 220 }
 221 #undef FUNC_NAME
 222
 223 SCM_GPROC (s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref, g_vector_ref);
 224
 225 /*
 226            "@var{k} must be a valid index of @var{vector}.\n"
 227            "@samp{Vector-ref} returns the contents of element @var{k} of\n"
 228            "@var{vector}.\n\n"
 229            "@lisp\n"
 230            "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n"
 231            "(vector-ref '#(1 1 2 3 5 8 13 21)\n"
 232            "    (let ((i (round (* 2 (acos -1)))))\n"
 233            "      (if (inexact? i)\n"
 234            "        (inexact->exact i)\n"
 235            "           i))) @result{} 13\n"
 236            "@end lisp"
 237 */
 238
 239 SCM
 240 scm_vector_ref (SCM v, SCM k)
 241 #define FUNC_NAME s_vector_ref
 242 {
 243   return scm_c_vector_ref (v, scm_to_size_t (k));
 244 }
 245 #undef FUNC_NAME
 246
 247 SCM
 248 scm_c_vector_ref (SCM v, size_t k)
 249 {
 250   if (SCM_I_IS_NONWEAK_VECTOR (v))
 251     {
 252       register SCM elt;
 253
 254       if (k >= SCM_I_VECTOR_LENGTH (v))
 255         scm_out_of_range (NULL, scm_from_size_t (k));
 256       elt = (SCM_I_VECTOR_ELTS(v))[k];
 257
 258       return elt;
 259     }
 260   else if (SCM_I_WVECTP (v))
 261     {
 262       scm_c_issue_deprecation_warning
 263         ("Using vector-ref on weak vectors is deprecated.  "
 264          "Instead, use weak-vector-ref from (ice-9 weak-vectors).");
 265       return scm_c_weak_vector_ref (v, k);
 266     }
 267   else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
 268     {
 269       scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
 270       SCM vv = SCM_I_ARRAY_V (v);
 271       if (SCM_I_IS_VECTOR (vv))
 272         {
 273           register SCM elt;
 274
 275           scm_c_issue_deprecation_warning
 276             ("Using vector-ref on arrays is deprecated.  "
 277              "Use array-ref instead.");
 278
 279           if (k >= dim->ubnd - dim->lbnd + 1)
 280             scm_out_of_range (NULL, scm_from_size_t (k));
 281           k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
 282           elt = (SCM_I_VECTOR_ELTS (vv))[k];
 283
 284           if (SCM_UNPACK (elt) == 0 && (SCM_I_WVECTP (vv)))
 285             {
 286               scm_c_issue_deprecation_warning
 287                 ("Weak arrays are deprecated.  Use weak vectors instead.");
 288               /* ELT was a weak pointer and got nullified by the GC.  */
 289               return SCM_BOOL_F;
 290             }
 291
 292           return elt;
 293         }
 294       scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
 295     }
 296   else if (SCM_UNPACK (g_vector_ref))
 297     {
 298       scm_c_issue_deprecation_warning
 299         ("Using vector-ref as a primitive-generic is deprecated.");
 300       return scm_call_generic_2 (g_vector_ref, v, scm_from_size_t (k));
 301     }
 302   else
 303     {
 304       scm_wrong_type_arg_msg ("vector-ref", 1, v, "vector");
 305       return SCM_UNDEFINED;  /* not reached */
 306     }
 307 }
 308
 309 SCM_GPROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x, g_vector_set_x);
 310
 311 /* "@var{k} must be a valid index of @var{vector}.\n"
 312    "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n"
 313    "The value returned by @samp{vector-set!} is unspecified.\n"
 314    "@lisp\n"
 315    "(let ((vec (vector 0 '(2 2 2 2) "Anna")))\n"
 316    "  (vector-set! vec 1 '("Sue" "Sue"))\n"
 317    "  vec) @result{}  #(0 ("Sue" "Sue") "Anna")\n"
 318    "(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector\n"
 319    "@end lisp"
 320 */
 321
 322 SCM
 323 scm_vector_set_x (SCM v, SCM k, SCM obj)
 324 #define FUNC_NAME s_vector_set_x
 325 {
 326   scm_c_vector_set_x (v, scm_to_size_t (k), obj);
 327   return SCM_UNSPECIFIED;
 328 }
 329 #undef FUNC_NAME
 330
 331 void
 332 scm_c_vector_set_x (SCM v, size_t k, SCM obj)
 333 {
 334   if (SCM_I_IS_NONWEAK_VECTOR (v))
 335     {
 336       if (k >= SCM_I_VECTOR_LENGTH (v))
 337         scm_out_of_range (NULL, scm_from_size_t (k));
 338       (SCM_I_VECTOR_WELTS(v))[k] = obj;
 339     }
 340   else if (SCM_I_WVECTP (v))
 341     {
 342       scm_c_issue_deprecation_warning
 343         ("Using vector-set! on weak vectors is deprecated.  "
 344          "Instead, use weak-vector-set! from (ice-9 weak-vectors).");
 345       scm_c_weak_vector_set_x (v, k, obj);
 346     }
 347   else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
 348     {
 349       scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
 350       SCM vv = SCM_I_ARRAY_V (v);
 351       if (SCM_I_IS_VECTOR (vv))
 352         {
 353           scm_c_issue_deprecation_warning
 354             ("Using vector-set! on arrays is deprecated.  "
 355              "Use array-set! instead, but note the change in argument order.");
 356
 357           if (k >= dim->ubnd - dim->lbnd + 1)
 358             scm_out_of_range (NULL, scm_from_size_t (k));
 359           k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
 360           (SCM_I_VECTOR_WELTS (vv))[k] = obj;
 361
 362           if (SCM_I_WVECTP (vv))
 363             {
 364               /* Make it a weak pointer.  */
 365               SCM *link = & SCM_I_VECTOR_WELTS (vv)[k];
 366               SCM_I_REGISTER_DISAPPEARING_LINK ((void **) link, SCM2PTR (obj));
 367               scm_c_issue_deprecation_warning
 368                 ("Weak arrays are deprecated.  Use weak vectors instead.");
 369             }
 370         }
 371       else
 372         scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
 373     }
 374   else if (SCM_UNPACK (g_vector_set_x))
 375     {
 376       scm_c_issue_deprecation_warning
 377         ("Using vector-set! as a primitive-generic is deprecated.");
 378       scm_call_3 (g_vector_set_x, v, scm_from_size_t (k), obj);
 379     }
 380   else
 381     scm_wrong_type_arg_msg ("vector-set!", 1, v, "vector");
 382 }
 383
 384 SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0,
 385             (SCM k, SCM fill),
 386             "Return a newly allocated vector of @var{k} elements.  If a\n"
 387             "second argument is given, then each position is initialized to\n"
 388             "@var{fill}.  Otherwise the initial contents of each position is\n"
 389             "unspecified.")
 390 #define FUNC_NAME s_scm_make_vector
 391 {
 392   size_t l = scm_to_unsigned_integer (k, 0, VECTOR_MAX_LENGTH);
 393
 394   if (SCM_UNBNDP (fill))
 395     fill = SCM_UNSPECIFIED;
 396
 397   return scm_c_make_vector (l, fill);
 398 }
 399 #undef FUNC_NAME
 400
 401
 402 SCM
 403 scm_c_make_vector (size_t k, SCM fill)
 404 #define FUNC_NAME s_scm_make_vector
 405 {
 406   SCM *vector;
 407
 408   vector = (SCM *)
 409     scm_gc_malloc ((k + SCM_I_VECTOR_HEADER_SIZE) * sizeof (SCM),
 410                    "vector");
 411
 412   if (k > 0)
 413     {
 414       SCM *base;
 415       unsigned long int j;
 416
 417       SCM_ASSERT_RANGE (1, scm_from_ulong (k), k <= VECTOR_MAX_LENGTH);
 418
 419       base = vector + SCM_I_VECTOR_HEADER_SIZE;
 420       for (j = 0; j != k; ++j)
 421         base[j] = fill;
 422     }
 423
 424   ((scm_t_bits *) vector)[0] = (k << 8) | scm_tc7_vector;
 425   ((scm_t_bits *) vector)[1] = 0;
 426
 427   return PTR2SCM (vector);
 428 }
 429 #undef FUNC_NAME
 430
 431 SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0,
 432             (SCM vec),
 433             "Return a copy of @var{vec}.")
 434 #define FUNC_NAME s_scm_vector_copy
 435 {
 436   scm_t_array_handle handle;
 437   size_t i, len;
 438   ssize_t inc;
 439   const SCM *src;
 440   SCM result, *dst;
 441
 442   src = scm_vector_elements (vec, &handle, &len, &inc);
 443
 444   result = scm_c_make_vector (len, SCM_UNDEFINED);
 445   dst = SCM_I_VECTOR_WELTS (result);
 446   for (i = 0; i < len; i++, src += inc)
 447     dst[i] = *src;
 448
 449   scm_array_handle_release (&handle);
 450
 451   return result;
 452 }
 453 #undef FUNC_NAME
 454
 455 \f
 456 /* Weak vectors.  */
 457
 458 /* Allocate memory for the elements of a weak vector on behalf of the
 459    caller.  */
 460 static SCM
 461 make_weak_vector (scm_t_bits type, size_t c_size)
 462 {
 463   SCM *vector;
 464   size_t total_size;
 465
 466   total_size = (c_size + SCM_I_VECTOR_HEADER_SIZE) * sizeof (SCM);
 467   vector = (SCM *) scm_gc_malloc_pointerless (total_size, "weak vector");
 468
 469   ((scm_t_bits *) vector)[0] = (c_size << 8) | scm_tc7_wvect;
 470   ((scm_t_bits *) vector)[1] = type;
 471
 472   return PTR2SCM (vector);
 473 }
 474
 475 /* Return a new weak vector.  The allocated vector will be of the given weak
 476    vector subtype.  It will contain SIZE elements which are initialized with
 477    the FILL object, or, if FILL is undefined, with an unspecified object.  */
 478 SCM
 479 scm_i_make_weak_vector (scm_t_bits type, SCM size, SCM fill)
 480 {
 481   SCM wv, *base;
 482   size_t c_size, j;
 483
 484   if (SCM_UNBNDP (fill))
 485     fill = SCM_UNSPECIFIED;
 486
 487   c_size = scm_to_unsigned_integer (size, 0, VECTOR_MAX_LENGTH);
 488   wv = make_weak_vector (type, c_size);
 489   base = SCM_I_WVECT_GC_WVELTS (wv);
 490
 491   for (j = 0; j != c_size; ++j)
 492     base[j] = fill;
 493
 494   return wv;
 495 }
 496
 497 /* Return a new weak vector with type TYPE and whose content are taken from
 498    list LST.  */
 499 SCM
 500 scm_i_make_weak_vector_from_list (scm_t_bits type, SCM lst)
 501 {
 502   SCM wv, *elt;
 503   long c_size;
 504
 505   c_size = scm_ilength (lst);
 506   SCM_ASSERT (c_size >= 0, lst, SCM_ARG2, "scm_i_make_weak_vector_from_list");
 507
 508   wv = make_weak_vector(type, (size_t) c_size);
 509
 510   for (elt = SCM_I_WVECT_GC_WVELTS (wv);
 511        scm_is_pair (lst);
 512        lst = SCM_CDR (lst), elt++)
 513     {
 514       *elt = SCM_CAR (lst);
 515     }
 516
 517   return wv;
 518 }
 519
 520
 521 \f
 522 SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0,
 523             (SCM v),
 524             "Return a newly allocated list composed of the elements of @var{v}.\n"
 525             "\n"
 526             "@lisp\n"
 527             "(vector->list '#(dah dah didah)) @result{}  (dah dah didah)\n"
 528             "(list->vector '(dididit dah)) @result{}  #(dididit dah)\n"
 529             "@end lisp")
 530 #define FUNC_NAME s_scm_vector_to_list
 531 {
 532   SCM res = SCM_EOL;
 533   const SCM *data;
 534   scm_t_array_handle handle;
 535   size_t i, count, len;
 536   ssize_t inc;
 537
 538   data = scm_vector_elements (v, &handle, &len, &inc);
 539   for (i = (len - 1) * inc, count = 0;
 540        count < len;
 541        i -= inc, count++)
 542     res = scm_cons (data[i], res);
 543
 544   scm_array_handle_release (&handle);
 545   return res;
 546 }
 547 #undef FUNC_NAME
 548
 549
 550 SCM_DEFINE (scm_vector_fill_x, "vector-fill!", 2, 0, 0,
 551             (SCM v, SCM fill),
 552             "Store @var{fill} in every position of @var{vector}.  The value\n"
 553             "returned by @code{vector-fill!} is unspecified.")
 554 #define FUNC_NAME s_scm_vector_fill_x
 555 {
 556   scm_t_array_handle handle;
 557   SCM *data;
 558   size_t i, len;
 559   ssize_t inc;
 560
 561   data = scm_vector_writable_elements (v, &handle, &len, &inc);
 562   for (i = 0; i < len; i += inc)
 563     data[i] = fill;
 564   scm_array_handle_release (&handle);
 565   return SCM_UNSPECIFIED;
 566 }
 567 #undef FUNC_NAME
 568
 569
 570 SCM
 571 scm_i_vector_equal_p (SCM x, SCM y)
 572 {
 573   long i;
 574   for (i = SCM_I_VECTOR_LENGTH (x) - 1; i >= 0; i--)
 575     if (scm_is_false (scm_equal_p (SCM_I_VECTOR_ELTS (x)[i],
 576                                    SCM_I_VECTOR_ELTS (y)[i])))
 577       return SCM_BOOL_F;
 578   return SCM_BOOL_T;
 579 }
 580
 581
 582 SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0,
 583             (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
 584             "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
 585             "to @var{vec2} starting at position @var{start2}.  @var{start1} and\n"
 586             "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
 587             "@code{vector-move-left!} copies elements in leftmost order.\n"
 588             "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
 589             "same vector, @code{vector-move-left!} is usually appropriate when\n"
 590             "@var{start1} is greater than @var{start2}.")
 591 #define FUNC_NAME s_scm_vector_move_left_x
 592 {
 593   scm_t_array_handle handle1, handle2;
 594   const SCM *elts1;
 595   SCM *elts2;
 596   size_t len1, len2;
 597   ssize_t inc1, inc2;
 598   size_t i, j, e;
 599
 600   elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
 601   elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);
 602
 603   i = scm_to_unsigned_integer (start1, 0, len1);
 604   e = scm_to_unsigned_integer (end1, i, len1);
 605   SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) <= len2);
 606   j = scm_to_unsigned_integer (start2, 0, len2);
 607   SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i));
 608
 609   i *= inc1;
 610   e *= inc1;
 611   j *= inc2;
 612   for (; i < e; i += inc1, j += inc2)
 613     elts2[j] = elts1[i];
 614
 615   scm_array_handle_release (&handle2);
 616   scm_array_handle_release (&handle1);
 617
 618   return SCM_UNSPECIFIED;
 619 }
 620 #undef FUNC_NAME
 621
 622 SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
 623             (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
 624             "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
 625             "to @var{vec2} starting at position @var{start2}.  @var{start1} and\n"
 626             "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
 627             "@code{vector-move-right!} copies elements in rightmost order.\n"
 628             "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
 629             "same vector, @code{vector-move-right!} is usually appropriate when\n"
 630             "@var{start1} is less than @var{start2}.")
 631 #define FUNC_NAME s_scm_vector_move_right_x
 632 {
 633   scm_t_array_handle handle1, handle2;
 634   const SCM *elts1;
 635   SCM *elts2;
 636   size_t len1, len2;
 637   ssize_t inc1, inc2;
 638   size_t i, j, e;
 639
 640   elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
 641   elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);
 642
 643   i = scm_to_unsigned_integer (start1, 0, len1);
 644   e = scm_to_unsigned_integer (end1, i, len1);
 645   SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) <= len2);
 646   j = scm_to_unsigned_integer (start2, 0, len2);
 647   SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i));
 648
 649   j += (e - i);
 650
 651   i *= inc1;
 652   e *= inc1;
 653   j *= inc2;
 654   while (i < e)
 655     {
 656       e -= inc1;
 657       j -= inc2;
 658       elts2[j] = elts1[e];
 659     }
 660
 661   scm_array_handle_release (&handle2);
 662   scm_array_handle_release (&handle1);
 663
 664   return SCM_UNSPECIFIED;
 665 }
 666 #undef FUNC_NAME
 667
 668 \f
 669 static SCM
 670 vector_handle_ref (scm_t_array_handle *h, size_t idx)
 671 {
 672   if (idx > h->dims[0].ubnd)
 673     scm_out_of_range ("vector-handle-ref", scm_from_size_t (idx));
 674   return ((SCM*)h->elements)[idx];
 675 }
 676
 677 static void
 678 vector_handle_set (scm_t_array_handle *h, size_t idx, SCM val)
 679 {
 680   if (idx > h->dims[0].ubnd)
 681     scm_out_of_range ("vector-handle-set!", scm_from_size_t (idx));
 682   ((SCM*)h->writable_elements)[idx] = val;
 683 }
 684
 685 static void
 686 vector_get_handle (SCM v, scm_t_array_handle *h)
 687 {
 688   h->array = v;
 689   h->ndims = 1;
 690   h->dims = &h->dim0;
 691   h->dim0.lbnd = 0;
 692   h->dim0.ubnd = SCM_I_VECTOR_LENGTH (v) - 1;
 693   h->dim0.inc = 1;
 694   h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM;
 695   h->elements = h->writable_elements = SCM_I_VECTOR_WELTS (v);
 696 }
 697
 698 /* the & ~2 allows catching scm_tc7_wvect as well. needs changing if you change
 699    tags.h. */
 700 SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector, 0x7f & ~2,
 701                           vector_handle_ref, vector_handle_set,
 702                           vector_get_handle)
 703 SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_SCM, scm_make_vector)
 704
 705
 706 void
 707 scm_init_vectors ()
 708 {
 709 #include "libguile/vectors.x"
 710 }
 711
 712
 713 /*
 714   Local Variables:
 715   c-file-style: "gnu"
 716   End:
 717 */