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