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/boehm-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           GC_GENERAL_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               GC_GENERAL_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 v;
 343   SCM *base;
 344
 345   if (k > 0)
 346     {
 347       unsigned long int j;
 348
 349       SCM_ASSERT_RANGE (1, scm_from_ulong (k), k <= VECTOR_MAX_LENGTH);
 350
 351       base = scm_gc_malloc (k * sizeof (SCM), "vector");
 352       for (j = 0; j != k; ++j)
 353         base[j] = fill;
 354     }
 355   else
 356     base = NULL;
 357
 358   v = scm_immutable_cell ((k << 8) | scm_tc7_vector, (scm_t_bits) base);
 359   scm_remember_upto_here_1 (fill);
 360
 361   return v;
 362 }
 363 #undef FUNC_NAME
 364
 365 SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0,
 366             (SCM vec),
 367             "Return a copy of @var{vec}.")
 368 #define FUNC_NAME s_scm_vector_copy
 369 {
 370   scm_t_array_handle handle;
 371   size_t i, len;
 372   ssize_t inc;
 373   const SCM *src;
 374   SCM *dst;
 375
 376   src = scm_vector_elements (vec, &handle, &len, &inc);
 377   dst = scm_gc_malloc (len * sizeof (SCM), "vector");
 378   for (i = 0; i < len; i++, src += inc)
 379     dst[i] = *src;
 380   scm_array_handle_release (&handle);
 381
 382   return scm_cell ((len << 8) | scm_tc7_vector, (scm_t_bits) dst);
 383 }
 384 #undef FUNC_NAME
 385
 386 void
 387 scm_i_vector_free (SCM vec)
 388 {
 389   scm_gc_free (SCM_I_VECTOR_WELTS (vec),
 390                SCM_I_VECTOR_LENGTH (vec) * sizeof(SCM),
 391                "vector");
 392 }
 393
 394 \f
 395 /* Weak vectors.  */
 396
 397
 398 /* Initialize RET as a weak vector of type TYPE of SIZE elements pointed to
 399    by BASE.  */
 400 #define MAKE_WEAK_VECTOR(_ret, _type, _size, _base)             \
 401   (_ret) = scm_double_cell ((_size << 8) | scm_tc7_wvect,       \
 402                             (scm_t_bits) (_base),               \
 403                             (_type),                            \
 404                             SCM_UNPACK (SCM_EOL));
 405
 406
 407 /* Allocate memory for the elements of a weak vector on behalf of the
 408    caller.  */
 409 static SCM *
 410 allocate_weak_vector (scm_t_bits type, size_t c_size)
 411 {
 412   SCM *base;
 413
 414   if (c_size > 0)
 415     /* The base itself should not be scanned for pointers otherwise those
 416        pointers will always be reachable.  */
 417     base = scm_gc_malloc_pointerless (c_size * sizeof (SCM), "weak vector");
 418   else
 419     base = NULL;
 420
 421   return base;
 422 }
 423
 424 /* Return a new weak vector.  The allocated vector will be of the given weak
 425    vector subtype.  It will contain SIZE elements which are initialized with
 426    the FILL object, or, if FILL is undefined, with an unspecified object.  */
 427 SCM
 428 scm_i_make_weak_vector (scm_t_bits type, SCM size, SCM fill)
 429 {
 430   SCM wv, *base;
 431   size_t c_size, j;
 432
 433   if (SCM_UNBNDP (fill))
 434     fill = SCM_UNSPECIFIED;
 435
 436   c_size = scm_to_unsigned_integer (size, 0, VECTOR_MAX_LENGTH);
 437   base = allocate_weak_vector (type, c_size);
 438
 439   for (j = 0; j != c_size; ++j)
 440     base[j] = fill;
 441
 442   MAKE_WEAK_VECTOR (wv, type, c_size, base);
 443
 444   return wv;
 445 }
 446
 447 /* Return a new weak vector with type TYPE and whose content are taken from
 448    list LST.  */
 449 SCM
 450 scm_i_make_weak_vector_from_list (scm_t_bits type, SCM lst)
 451 {
 452   SCM wv, *base, *elt;
 453   long c_size;
 454
 455   c_size = scm_ilength (lst);
 456   SCM_ASSERT (c_size >= 0, lst, SCM_ARG2, "scm_i_make_weak_vector_from_list");
 457
 458   base = allocate_weak_vector (type, (size_t)c_size);
 459   for (elt = base;
 460        scm_is_pair (lst);
 461        lst = SCM_CDR (lst), elt++)
 462     {
 463       *elt = SCM_CAR (lst);
 464     }
 465
 466   MAKE_WEAK_VECTOR (wv, type, (size_t)c_size, base);
 467
 468   return wv;
 469 }
 470
 471
 472 \f
 473 SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0,
 474             (SCM v),
 475             "Return a newly allocated list composed of the elements of @var{v}.\n"
 476             "\n"
 477             "@lisp\n"
 478             "(vector->list '#(dah dah didah)) @result{}  (dah dah didah)\n"
 479             "(list->vector '(dididit dah)) @result{}  #(dididit dah)\n"
 480             "@end lisp")
 481 #define FUNC_NAME s_scm_vector_to_list
 482 {
 483   SCM res = SCM_EOL;
 484   const SCM *data;
 485   scm_t_array_handle handle;
 486   size_t i, count, len;
 487   ssize_t inc;
 488
 489   data = scm_vector_elements (v, &handle, &len, &inc);
 490   for (i = (len - 1) * inc, count = 0;
 491        count < len;
 492        i -= inc, count++)
 493     res = scm_cons (data[i], res);
 494
 495   scm_array_handle_release (&handle);
 496   return res;
 497 }
 498 #undef FUNC_NAME
 499
 500
 501 SCM_DEFINE (scm_vector_fill_x, "vector-fill!", 2, 0, 0,
 502             (SCM v, SCM fill),
 503             "Store @var{fill} in every position of @var{vector}.  The value\n"
 504             "returned by @code{vector-fill!} is unspecified.")
 505 #define FUNC_NAME s_scm_vector_fill_x
 506 {
 507   scm_t_array_handle handle;
 508   SCM *data;
 509   size_t i, len;
 510   ssize_t inc;
 511
 512   data = scm_vector_writable_elements (v, &handle, &len, &inc);
 513   for (i = 0; i < len; i += inc)
 514     data[i] = fill;
 515   scm_array_handle_release (&handle);
 516   return SCM_UNSPECIFIED;
 517 }
 518 #undef FUNC_NAME
 519
 520
 521 SCM
 522 scm_i_vector_equal_p (SCM x, SCM y)
 523 {
 524   long i;
 525   for (i = SCM_I_VECTOR_LENGTH (x) - 1; i >= 0; i--)
 526     if (scm_is_false (scm_equal_p (SCM_I_VECTOR_ELTS (x)[i],
 527                                    SCM_I_VECTOR_ELTS (y)[i])))
 528       return SCM_BOOL_F;
 529   return SCM_BOOL_T;
 530 }
 531
 532
 533 SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0,
 534             (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
 535             "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
 536             "to @var{vec2} starting at position @var{start2}.  @var{start1} and\n"
 537             "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
 538             "@code{vector-move-left!} copies elements in leftmost order.\n"
 539             "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
 540             "same vector, @code{vector-move-left!} is usually appropriate when\n"
 541             "@var{start1} is greater than @var{start2}.")
 542 #define FUNC_NAME s_scm_vector_move_left_x
 543 {
 544   scm_t_array_handle handle1, handle2;
 545   const SCM *elts1;
 546   SCM *elts2;
 547   size_t len1, len2;
 548   ssize_t inc1, inc2;
 549   size_t i, j, e;
 550
 551   elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
 552   elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);
 553
 554   i = scm_to_unsigned_integer (start1, 0, len1);
 555   e = scm_to_unsigned_integer (end1, i, len1);
 556   j = scm_to_unsigned_integer (start2, 0, len2 - (i-e));
 557
 558   i *= inc1;
 559   e *= inc1;
 560   j *= inc2;
 561   for (; i < e; i += inc1, j += inc2)
 562     elts2[j] = elts1[i];
 563
 564   scm_array_handle_release (&handle2);
 565   scm_array_handle_release (&handle1);
 566
 567   return SCM_UNSPECIFIED;
 568 }
 569 #undef FUNC_NAME
 570
 571 SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
 572             (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
 573             "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
 574             "to @var{vec2} starting at position @var{start2}.  @var{start1} and\n"
 575             "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
 576             "@code{vector-move-right!} copies elements in rightmost order.\n"
 577             "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
 578             "same vector, @code{vector-move-right!} is usually appropriate when\n"
 579             "@var{start1} is less than @var{start2}.")
 580 #define FUNC_NAME s_scm_vector_move_right_x
 581 {
 582   scm_t_array_handle handle1, handle2;
 583   const SCM *elts1;
 584   SCM *elts2;
 585   size_t len1, len2;
 586   ssize_t inc1, inc2;
 587   size_t i, j, e;
 588
 589   elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
 590   elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);
 591
 592   i = scm_to_unsigned_integer (start1, 0, len1);
 593   e = scm_to_unsigned_integer (end1, i, len1);
 594   j = scm_to_unsigned_integer (start2, 0, len2 - (i-e));
 595
 596   i *= inc1;
 597   e *= inc1;
 598   j *= inc2;
 599   while (i < e)
 600     {
 601       e -= inc1;
 602       j -= inc2;
 603       elts2[j] = elts1[e];
 604     }
 605
 606   scm_array_handle_release (&handle2);
 607   scm_array_handle_release (&handle1);
 608
 609   return SCM_UNSPECIFIED;
 610 }
 611 #undef FUNC_NAME
 612
 613 \f
 614 static SCM
 615 vector_handle_ref (scm_t_array_handle *h, size_t idx)
 616 {
 617   if (idx > h->dims[0].ubnd)
 618     scm_out_of_range ("vector-handle-ref", scm_from_size_t (idx));
 619   return ((SCM*)h->elements)[idx];
 620 }
 621
 622 static void
 623 vector_handle_set (scm_t_array_handle *h, size_t idx, SCM val)
 624 {
 625   if (idx > h->dims[0].ubnd)
 626     scm_out_of_range ("vector-handle-set!", scm_from_size_t (idx));
 627   ((SCM*)h->writable_elements)[idx] = val;
 628 }
 629
 630 static void
 631 vector_get_handle (SCM v, scm_t_array_handle *h)
 632 {
 633   h->array = v;
 634   h->ndims = 1;
 635   h->dims = &h->dim0;
 636   h->dim0.lbnd = 0;
 637   h->dim0.ubnd = SCM_I_VECTOR_LENGTH (v) - 1;
 638   h->dim0.inc = 1;
 639   h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM;
 640   h->elements = h->writable_elements = SCM_I_VECTOR_WELTS (v);
 641 }
 642
 643 SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector, 0x7f & ~2,
 644                           vector_handle_ref, vector_handle_set,
 645                           vector_get_handle);
 646 SCM_ARRAY_IMPLEMENTATION (scm_tc7_wvect, 0x7f & ~2,
 647                           vector_handle_ref, vector_handle_set,
 648                           vector_get_handle);
 649 SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_SCM, scm_make_vector);
 650
 651
 652 void
 653 scm_init_vectors ()
 654 {
 655   scm_nullvect = scm_c_make_vector (0, SCM_UNDEFINED);
 656
 657 #include "libguile/vectors.x"
 658 }
 659
 660
 661 /*
 662   Local Variables:
 663   c-file-style: "gnu"
 664   End:
 665 */