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     return scm_wta_dispatch_1 (g_vector_length, v, 1, "vector-length");
 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     return scm_wta_dispatch_2 (g_vector_ref, v, scm_from_size_t (k), 2,
 245                                "vector-ref");
 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           GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (v))[k]);
 282           SCM_I_REGISTER_DISAPPEARING_LINK (link,
 283                                             (GC_PTR) SCM2PTR (obj));
 284         }
 285     }
 286   else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
 287     {
 288       scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
 289       SCM vv = SCM_I_ARRAY_V (v);
 290       if (SCM_I_IS_VECTOR (vv))
 291         {
 292           if (k >= dim->ubnd - dim->lbnd + 1)
 293             scm_out_of_range (NULL, scm_from_size_t (k));
 294           k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
 295           (SCM_I_VECTOR_WELTS (vv))[k] = obj;
 296
 297           if (SCM_I_WVECTP (vv))
 298             {
 299               /* Make it a weak pointer.  */
 300               GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (vv))[k]);
 301               SCM_I_REGISTER_DISAPPEARING_LINK (link,
 302                                                 (GC_PTR) SCM2PTR (obj));
 303             }
 304         }
 305       else
 306         scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
 307     }
 308   else
 309     {
 310       if (SCM_UNPACK (g_vector_set_x))
 311         scm_wta_dispatch_n (g_vector_set_x,
 312                             scm_list_3 (v, scm_from_size_t (k), obj),
 313                             0,
 314                             "vector-set!");
 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   SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) <= len2);
 542   j = scm_to_unsigned_integer (start2, 0, len2);
 543   SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i));
 544
 545   i *= inc1;
 546   e *= inc1;
 547   j *= inc2;
 548   for (; i < e; i += inc1, j += inc2)
 549     elts2[j] = elts1[i];
 550
 551   scm_array_handle_release (&handle2);
 552   scm_array_handle_release (&handle1);
 553
 554   return SCM_UNSPECIFIED;
 555 }
 556 #undef FUNC_NAME
 557
 558 SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
 559             (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
 560             "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
 561             "to @var{vec2} starting at position @var{start2}.  @var{start1} and\n"
 562             "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
 563             "@code{vector-move-right!} copies elements in rightmost order.\n"
 564             "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
 565             "same vector, @code{vector-move-right!} is usually appropriate when\n"
 566             "@var{start1} is less than @var{start2}.")
 567 #define FUNC_NAME s_scm_vector_move_right_x
 568 {
 569   scm_t_array_handle handle1, handle2;
 570   const SCM *elts1;
 571   SCM *elts2;
 572   size_t len1, len2;
 573   ssize_t inc1, inc2;
 574   size_t i, j, e;
 575
 576   elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
 577   elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);
 578
 579   i = scm_to_unsigned_integer (start1, 0, len1);
 580   e = scm_to_unsigned_integer (end1, i, len1);
 581   SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) <= len2);
 582   j = scm_to_unsigned_integer (start2, 0, len2);
 583   SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i));
 584
 585   j += (e - i);
 586
 587   i *= inc1;
 588   e *= inc1;
 589   j *= inc2;
 590   while (i < e)
 591     {
 592       e -= inc1;
 593       j -= inc2;
 594       elts2[j] = elts1[e];
 595     }
 596
 597   scm_array_handle_release (&handle2);
 598   scm_array_handle_release (&handle1);
 599
 600   return SCM_UNSPECIFIED;
 601 }
 602 #undef FUNC_NAME
 603
 604 \f
 605 static SCM
 606 vector_handle_ref (scm_t_array_handle *h, size_t idx)
 607 {
 608   if (idx > h->dims[0].ubnd)
 609     scm_out_of_range ("vector-handle-ref", scm_from_size_t (idx));
 610   return ((SCM*)h->elements)[idx];
 611 }
 612
 613 static void
 614 vector_handle_set (scm_t_array_handle *h, size_t idx, SCM val)
 615 {
 616   if (idx > h->dims[0].ubnd)
 617     scm_out_of_range ("vector-handle-set!", scm_from_size_t (idx));
 618   ((SCM*)h->writable_elements)[idx] = val;
 619 }
 620
 621 static void
 622 vector_get_handle (SCM v, scm_t_array_handle *h)
 623 {
 624   h->array = v;
 625   h->ndims = 1;
 626   h->dims = &h->dim0;
 627   h->dim0.lbnd = 0;
 628   h->dim0.ubnd = SCM_I_VECTOR_LENGTH (v) - 1;
 629   h->dim0.inc = 1;
 630   h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM;
 631   h->elements = h->writable_elements = SCM_I_VECTOR_WELTS (v);
 632 }
 633
 634 /* the & ~2 allows catching scm_tc7_wvect as well. needs changing if you change
 635    tags.h. */
 636 SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector, 0x7f & ~2,
 637                           vector_handle_ref, vector_handle_set,
 638                           vector_get_handle)
 639 SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_SCM, scm_make_vector)
 640
 641
 642 void
 643 scm_init_vectors ()
 644 {
 645 #include "libguile/vectors.x"
 646 }
 647
 648
 649 /*
 650   Local Variables:
 651   c-file-style: "gnu"
 652   End:
 653 */