libguile/vectors.c

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