libguile/vectors.c

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