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     scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
  72
  73   scm_generalized_vector_get_handle (vec, h);
  74   if (lenp)
  75     {
  76       scm_t_array_dim *dim = scm_array_handle_dims (h);
  77       *lenp = dim->ubnd - dim->lbnd + 1;
  78       *incp = dim->inc;
  79     }
  80   return scm_array_handle_elements (h);
  81 }
  82
  83 SCM *
  84 scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
  85                               size_t *lenp, ssize_t *incp)
  86 {
  87   if (SCM_I_WVECTP (vec))
  88     scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
  89
  90   scm_generalized_vector_get_handle (vec, h);
  91   if (lenp)
  92     {
  93       scm_t_array_dim *dim = scm_array_handle_dims (h);
  94       *lenp = dim->ubnd - dim->lbnd + 1;
  95       *incp = dim->inc;
  96     }
  97   return scm_array_handle_writable_elements (h);
  98 }
  99
 100 SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0,
 101             (SCM obj),
 102             "Return @code{#t} if @var{obj} is a vector, otherwise return\n"
 103             "@code{#f}.")
 104 #define FUNC_NAME s_scm_vector_p
 105 {
 106   return scm_from_bool (scm_is_vector (obj));
 107 }
 108 #undef FUNC_NAME
 109
 110 SCM_GPROC (s_vector_length, "vector-length", 1, 0, 0, scm_vector_length, g_vector_length);
 111 /* Returns the number of elements in @var{vector} as an exact integer.  */
 112 SCM
 113 scm_vector_length (SCM v)
 114 {
 115   if (SCM_I_IS_VECTOR (v))
 116     return scm_from_size_t (SCM_I_VECTOR_LENGTH (v));
 117   else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
 118     {
 119       scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
 120       return scm_from_size_t (dim->ubnd - dim->lbnd + 1);
 121     }
 122   else
 123     return scm_wta_dispatch_1 (g_vector_length, v, 1, "vector-length");
 124 }
 125
 126 size_t
 127 scm_c_vector_length (SCM v)
 128 {
 129   if (SCM_I_IS_VECTOR (v))
 130     return SCM_I_VECTOR_LENGTH (v);
 131   else
 132     return scm_to_size_t (scm_vector_length (v));
 133 }
 134
 135 SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector);
 136 /*
 137             "Return a newly created vector initialized to the elements of"
 138             "the list @var{list}.\n\n"
 139             "@lisp\n"
 140             "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
 141             "(list->vector '(dididit dah)) @result{}   #(dididit dah)\n"
 142             "@end lisp")
 143 */
 144 SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
 145             (SCM l),
 146             "@deffnx {Scheme Procedure} list->vector l\n"
 147             "Return a newly allocated vector composed of the\n"
 148             "given arguments.  Analogous to @code{list}.\n"
 149             "\n"
 150             "@lisp\n"
 151             "(vector 'a 'b 'c) @result{} #(a b c)\n"
 152             "@end lisp")
 153 #define FUNC_NAME s_scm_vector
 154 {
 155   SCM res;
 156   SCM *data;
 157   long i, len;
 158   scm_t_array_handle handle;
 159
 160   SCM_VALIDATE_LIST_COPYLEN (1, l, len);
 161
 162   res = scm_c_make_vector (len, SCM_UNSPECIFIED);
 163   data = scm_vector_writable_elements (res, &handle, NULL, NULL);
 164   i = 0;
 165   while (scm_is_pair (l) && i < len)
 166     {
 167       data[i] = SCM_CAR (l);
 168       l = SCM_CDR (l);
 169       i += 1;
 170     }
 171
 172   scm_array_handle_release (&handle);
 173
 174   return res;
 175 }
 176 #undef FUNC_NAME
 177
 178 SCM_GPROC (s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref, g_vector_ref);
 179
 180 /*
 181            "@var{k} must be a valid index of @var{vector}.\n"
 182            "@samp{Vector-ref} returns the contents of element @var{k} of\n"
 183            "@var{vector}.\n\n"
 184            "@lisp\n"
 185            "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n"
 186            "(vector-ref '#(1 1 2 3 5 8 13 21)\n"
 187            "    (let ((i (round (* 2 (acos -1)))))\n"
 188            "      (if (inexact? i)\n"
 189            "        (inexact->exact i)\n"
 190            "           i))) @result{} 13\n"
 191            "@end lisp"
 192 */
 193
 194 SCM
 195 scm_vector_ref (SCM v, SCM k)
 196 #define FUNC_NAME s_vector_ref
 197 {
 198   return scm_c_vector_ref (v, scm_to_size_t (k));
 199 }
 200 #undef FUNC_NAME
 201
 202 SCM
 203 scm_c_vector_ref (SCM v, size_t k)
 204 {
 205   if (SCM_I_IS_NONWEAK_VECTOR (v))
 206     {
 207       if (k >= SCM_I_VECTOR_LENGTH (v))
 208         scm_out_of_range (NULL, scm_from_size_t (k));
 209       return SCM_SIMPLE_VECTOR_REF (v, k);
 210     }
 211   else if (SCM_I_WVECTP (v))
 212     return scm_c_weak_vector_ref (v, k);
 213   else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
 214     {
 215       scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
 216       SCM vv = SCM_I_ARRAY_V (v);
 217
 218       k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
 219       if (k >= dim->ubnd - dim->lbnd + 1)
 220         scm_out_of_range (NULL, scm_from_size_t (k));
 221
 222       if (SCM_I_IS_NONWEAK_VECTOR (vv))
 223         return SCM_SIMPLE_VECTOR_REF (vv, k);
 224       else if (SCM_I_WVECTP (vv))
 225         return scm_c_weak_vector_ref (vv, k);
 226       else
 227         scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
 228     }
 229   else
 230     return scm_wta_dispatch_2 (g_vector_ref, v, scm_from_size_t (k), 2,
 231                                "vector-ref");
 232 }
 233
 234 SCM_GPROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x, g_vector_set_x);
 235
 236 /* "@var{k} must be a valid index of @var{vector}.\n"
 237    "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n"
 238    "The value returned by @samp{vector-set!} is unspecified.\n"
 239    "@lisp\n"
 240    "(let ((vec (vector 0 '(2 2 2 2) "Anna")))\n"
 241    "  (vector-set! vec 1 '("Sue" "Sue"))\n"
 242    "  vec) @result{}  #(0 ("Sue" "Sue") "Anna")\n"
 243    "(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector\n"
 244    "@end lisp"
 245 */
 246
 247 SCM
 248 scm_vector_set_x (SCM v, SCM k, SCM obj)
 249 #define FUNC_NAME s_vector_set_x
 250 {
 251   scm_c_vector_set_x (v, scm_to_size_t (k), obj);
 252   return SCM_UNSPECIFIED;
 253 }
 254 #undef FUNC_NAME
 255
 256 void
 257 scm_c_vector_set_x (SCM v, size_t k, SCM obj)
 258 {
 259   if (SCM_I_IS_NONWEAK_VECTOR (v))
 260     {
 261       if (k >= SCM_I_VECTOR_LENGTH (v))
 262         scm_out_of_range (NULL, scm_from_size_t (k));
 263       SCM_SIMPLE_VECTOR_SET (v, k, obj);
 264     }
 265   else if (SCM_I_WVECTP (v))
 266     scm_c_weak_vector_set_x (v, k, obj);
 267   else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
 268     {
 269       scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
 270       SCM vv = SCM_I_ARRAY_V (v);
 271
 272       k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
 273       if (k >= dim->ubnd - dim->lbnd + 1)
 274         scm_out_of_range (NULL, scm_from_size_t (k));
 275
 276       if (SCM_I_IS_NONWEAK_VECTOR (vv))
 277         SCM_SIMPLE_VECTOR_SET (vv, k, obj);
 278       else if (SCM_I_WVECTP (vv))
 279         scm_c_weak_vector_set_x (vv, k, obj);
 280       else
 281         scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
 282     }
 283   else
 284     {
 285       if (SCM_UNPACK (g_vector_set_x))
 286         scm_wta_dispatch_n (g_vector_set_x,
 287                             scm_list_3 (v, scm_from_size_t (k), obj),
 288                             0,
 289                             "vector-set!");
 290       else
 291         scm_wrong_type_arg_msg (NULL, 0, v, "vector");
 292     }
 293 }
 294
 295 SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0,
 296             (SCM k, SCM fill),
 297             "Return a newly allocated vector of @var{k} elements.  If a\n"
 298             "second argument is given, then each position is initialized to\n"
 299             "@var{fill}.  Otherwise the initial contents of each position is\n"
 300             "unspecified.")
 301 #define FUNC_NAME s_scm_make_vector
 302 {
 303   size_t l = scm_to_unsigned_integer (k, 0, VECTOR_MAX_LENGTH);
 304
 305   if (SCM_UNBNDP (fill))
 306     fill = SCM_UNSPECIFIED;
 307
 308   return scm_c_make_vector (l, fill);
 309 }
 310 #undef FUNC_NAME
 311
 312
 313 SCM
 314 scm_c_make_vector (size_t k, SCM fill)
 315 #define FUNC_NAME s_scm_make_vector
 316 {
 317   SCM vector;
 318   unsigned long int j;
 319
 320   SCM_ASSERT_RANGE (1, scm_from_size_t (k), k <= VECTOR_MAX_LENGTH);
 321
 322   vector = scm_words ((k << 8) | scm_tc7_vector, k + 1);
 323
 324   for (j = 0; j < k; ++j)
 325     SCM_SIMPLE_VECTOR_SET (vector, j, fill);
 326
 327   return vector;
 328 }
 329 #undef FUNC_NAME
 330
 331 SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0,
 332             (SCM vec),
 333             "Return a copy of @var{vec}.")
 334 #define FUNC_NAME s_scm_vector_copy
 335 {
 336   scm_t_array_handle handle;
 337   size_t i, len;
 338   ssize_t inc;
 339   const SCM *src;
 340   SCM result, *dst;
 341
 342   src = scm_vector_elements (vec, &handle, &len, &inc);
 343
 344   result = scm_c_make_vector (len, SCM_UNDEFINED);
 345   dst = SCM_I_VECTOR_WELTS (result);
 346   for (i = 0; i < len; i++, src += inc)
 347     dst[i] = *src;
 348
 349   scm_array_handle_release (&handle);
 350
 351   return result;
 352 }
 353 #undef FUNC_NAME
 354
 355 \f
 356 SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0,
 357             (SCM v),
 358             "Return a newly allocated list composed of the elements of @var{v}.\n"
 359             "\n"
 360             "@lisp\n"
 361             "(vector->list '#(dah dah didah)) @result{}  (dah dah didah)\n"
 362             "(list->vector '(dididit dah)) @result{}  #(dididit dah)\n"
 363             "@end lisp")
 364 #define FUNC_NAME s_scm_vector_to_list
 365 {
 366   SCM res = SCM_EOL;
 367   const SCM *data;
 368   scm_t_array_handle handle;
 369   size_t i, count, len;
 370   ssize_t inc;
 371
 372   data = scm_vector_elements (v, &handle, &len, &inc);
 373   for (i = (len - 1) * inc, count = 0;
 374        count < len;
 375        i -= inc, count++)
 376     res = scm_cons (data[i], res);
 377
 378   scm_array_handle_release (&handle);
 379   return res;
 380 }
 381 #undef FUNC_NAME
 382
 383
 384 SCM_DEFINE (scm_vector_fill_x, "vector-fill!", 2, 0, 0,
 385             (SCM v, SCM fill),
 386             "Store @var{fill} in every position of @var{vector}.  The value\n"
 387             "returned by @code{vector-fill!} is unspecified.")
 388 #define FUNC_NAME s_scm_vector_fill_x
 389 {
 390   scm_t_array_handle handle;
 391   SCM *data;
 392   size_t i, len;
 393   ssize_t inc;
 394
 395   data = scm_vector_writable_elements (v, &handle, &len, &inc);
 396   for (i = 0; i < len; i += inc)
 397     data[i] = fill;
 398   scm_array_handle_release (&handle);
 399   return SCM_UNSPECIFIED;
 400 }
 401 #undef FUNC_NAME
 402
 403
 404 SCM
 405 scm_i_vector_equal_p (SCM x, SCM y)
 406 {
 407   long i;
 408   for (i = SCM_I_VECTOR_LENGTH (x) - 1; i >= 0; i--)
 409     if (scm_is_false (scm_equal_p (SCM_I_VECTOR_ELTS (x)[i],
 410                                    SCM_I_VECTOR_ELTS (y)[i])))
 411       return SCM_BOOL_F;
 412   return SCM_BOOL_T;
 413 }
 414
 415
 416 SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0,
 417             (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
 418             "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
 419             "to @var{vec2} starting at position @var{start2}.  @var{start1} and\n"
 420             "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
 421             "@code{vector-move-left!} copies elements in leftmost order.\n"
 422             "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
 423             "same vector, @code{vector-move-left!} is usually appropriate when\n"
 424             "@var{start1} is greater than @var{start2}.")
 425 #define FUNC_NAME s_scm_vector_move_left_x
 426 {
 427   scm_t_array_handle handle1, handle2;
 428   const SCM *elts1;
 429   SCM *elts2;
 430   size_t len1, len2;
 431   ssize_t inc1, inc2;
 432   size_t i, j, e;
 433
 434   elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
 435   elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);
 436
 437   i = scm_to_unsigned_integer (start1, 0, len1);
 438   e = scm_to_unsigned_integer (end1, i, len1);
 439   SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) <= len2);
 440   j = scm_to_unsigned_integer (start2, 0, len2);
 441   SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i));
 442
 443   i *= inc1;
 444   e *= inc1;
 445   j *= inc2;
 446   for (; i < e; i += inc1, j += inc2)
 447     elts2[j] = elts1[i];
 448
 449   scm_array_handle_release (&handle2);
 450   scm_array_handle_release (&handle1);
 451
 452   return SCM_UNSPECIFIED;
 453 }
 454 #undef FUNC_NAME
 455
 456 SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
 457             (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
 458             "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
 459             "to @var{vec2} starting at position @var{start2}.  @var{start1} and\n"
 460             "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
 461             "@code{vector-move-right!} copies elements in rightmost order.\n"
 462             "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
 463             "same vector, @code{vector-move-right!} is usually appropriate when\n"
 464             "@var{start1} is less than @var{start2}.")
 465 #define FUNC_NAME s_scm_vector_move_right_x
 466 {
 467   scm_t_array_handle handle1, handle2;
 468   const SCM *elts1;
 469   SCM *elts2;
 470   size_t len1, len2;
 471   ssize_t inc1, inc2;
 472   size_t i, j, e;
 473
 474   elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
 475   elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);
 476
 477   i = scm_to_unsigned_integer (start1, 0, len1);
 478   e = scm_to_unsigned_integer (end1, i, len1);
 479   SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) <= len2);
 480   j = scm_to_unsigned_integer (start2, 0, len2);
 481   SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i));
 482
 483   j += (e - i);
 484
 485   i *= inc1;
 486   e *= inc1;
 487   j *= inc2;
 488   while (i < e)
 489     {
 490       e -= inc1;
 491       j -= inc2;
 492       elts2[j] = elts1[e];
 493     }
 494
 495   scm_array_handle_release (&handle2);
 496   scm_array_handle_release (&handle1);
 497
 498   return SCM_UNSPECIFIED;
 499 }
 500 #undef FUNC_NAME
 501
 502 \f
 503 static SCM
 504 vector_handle_ref (scm_t_array_handle *h, size_t idx)
 505 {
 506   if (idx > h->dims[0].ubnd)
 507     scm_out_of_range ("vector-handle-ref", scm_from_size_t (idx));
 508   return ((SCM*)h->elements)[idx];
 509 }
 510
 511 static void
 512 vector_handle_set (scm_t_array_handle *h, size_t idx, SCM val)
 513 {
 514   if (idx > h->dims[0].ubnd)
 515     scm_out_of_range ("vector-handle-set!", scm_from_size_t (idx));
 516   ((SCM*)h->writable_elements)[idx] = val;
 517 }
 518
 519 static void
 520 vector_get_handle (SCM v, scm_t_array_handle *h)
 521 {
 522   h->array = v;
 523   h->ndims = 1;
 524   h->dims = &h->dim0;
 525   h->dim0.lbnd = 0;
 526   h->dim0.ubnd = SCM_I_VECTOR_LENGTH (v) - 1;
 527   h->dim0.inc = 1;
 528   h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM;
 529   h->elements = h->writable_elements = SCM_I_VECTOR_WELTS (v);
 530 }
 531
 532 /* the & ~2 allows catching scm_tc7_wvect as well. needs changing if you change
 533    tags.h. */
 534 SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector, 0x7f & ~2,
 535                           vector_handle_ref, vector_handle_set,
 536                           vector_get_handle)
 537 SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_SCM, scm_make_vector)
 538
 539
 540 void
 541 scm_init_vectors ()
 542 {
 543 #include "libguile/vectors.x"
 544 }
 545
 546
 547 /*
 548   Local Variables:
 549   c-file-style: "gnu"
 550   End:
 551 */