libguile/vectors.c

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