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