libguile/vectors.c

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