vectors.c 13 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484
  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. #ifdef HAVE_CONFIG_H
  20. # include <config.h>
  21. #endif
  22. #include "libguile/_scm.h"
  23. #include "libguile/eq.h"
  24. #include "libguile/root.h"
  25. #include "libguile/strings.h"
  26. #include "libguile/validate.h"
  27. #include "libguile/vectors.h"
  28. #include "libguile/arrays.h" /* Hit me with the ugly stick */
  29. #include "libguile/generalized-vectors.h"
  30. #include "libguile/strings.h"
  31. #include "libguile/srfi-13.h"
  32. #include "libguile/dynwind.h"
  33. #include "libguile/deprecation.h"
  34. #include "libguile/bdw-gc.h"
  35. #include <assert.h>
  36. #define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
  37. int
  38. scm_is_vector (SCM obj)
  39. {
  40. return SCM_I_IS_VECTOR (obj);
  41. }
  42. int
  43. scm_is_simple_vector (SCM obj)
  44. {
  45. return SCM_I_IS_VECTOR (obj);
  46. }
  47. SCM *
  48. scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
  49. size_t *lenp, ssize_t *incp)
  50. {
  51. if (SCM_I_WVECTP (vec))
  52. scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
  53. if (!scm_is_array (vec) || 1 != scm_c_array_rank (vec))
  54. scm_wrong_type_arg_msg (NULL, 0, vec, "rank 1 array");
  55. scm_array_get_handle (vec, h);
  56. if (lenp)
  57. {
  58. scm_t_array_dim *dim = scm_array_handle_dims (h);
  59. *lenp = dim->ubnd - dim->lbnd + 1;
  60. *incp = dim->inc;
  61. }
  62. return scm_array_handle_writable_elements (h);
  63. }
  64. const SCM *
  65. scm_vector_elements (SCM vec, scm_t_array_handle *h,
  66. size_t *lenp, ssize_t *incp)
  67. {
  68. return scm_vector_writable_elements (vec, h, lenp, incp);
  69. }
  70. SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0,
  71. (SCM obj),
  72. "Return @code{#t} if @var{obj} is a vector, otherwise return\n"
  73. "@code{#f}.")
  74. #define FUNC_NAME s_scm_vector_p
  75. {
  76. return scm_from_bool (scm_is_vector (obj));
  77. }
  78. #undef FUNC_NAME
  79. size_t
  80. scm_c_vector_length (SCM v)
  81. {
  82. if (SCM_I_IS_VECTOR (v))
  83. return SCM_I_VECTOR_LENGTH (v);
  84. else
  85. scm_wrong_type_arg_msg (NULL, 0, v, "vector");
  86. }
  87. SCM_DEFINE (scm_vector_length, "vector-length", 1, 0, 0,
  88. (SCM v),
  89. "Return the number of elements in vector @var{v} as an exact\n"
  90. "integer.\n"
  91. "\n"
  92. "@lisp\n"
  93. "(vector-length #(a b c)) @result{} 3\n"
  94. "@end lisp")
  95. #define FUNC_NAME s_scm_vector_length
  96. {
  97. return scm_from_size_t (scm_c_vector_length (v));
  98. }
  99. #undef FUNC_NAME
  100. SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector);
  101. /*
  102. "Return a newly created vector initialized to the elements of"
  103. "the list @var{list}.\n\n"
  104. "@lisp\n"
  105. "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
  106. "(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
  107. "@end lisp")
  108. */
  109. SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
  110. (SCM l),
  111. "@deffnx {Scheme Procedure} list->vector l\n"
  112. "Return a newly allocated vector composed of the\n"
  113. "given arguments. Analogous to @code{list}.\n"
  114. "\n"
  115. "@lisp\n"
  116. "(vector 'a 'b 'c) @result{} #(a b c)\n"
  117. "@end lisp")
  118. #define FUNC_NAME s_scm_vector
  119. {
  120. SCM res;
  121. SCM *data;
  122. long i, len;
  123. scm_t_array_handle handle;
  124. SCM_VALIDATE_LIST_COPYLEN (1, l, len);
  125. res = scm_c_make_vector (len, SCM_UNSPECIFIED);
  126. data = scm_vector_writable_elements (res, &handle, NULL, NULL);
  127. i = 0;
  128. while (scm_is_pair (l) && i < len)
  129. {
  130. data[i] = SCM_CAR (l);
  131. l = SCM_CDR (l);
  132. i += 1;
  133. }
  134. scm_array_handle_release (&handle);
  135. return res;
  136. }
  137. #undef FUNC_NAME
  138. SCM
  139. scm_c_vector_ref (SCM v, size_t k)
  140. {
  141. if (SCM_I_IS_NONWEAK_VECTOR (v))
  142. {
  143. if (k >= SCM_I_VECTOR_LENGTH (v))
  144. scm_out_of_range (NULL, scm_from_size_t (k));
  145. return SCM_SIMPLE_VECTOR_REF (v, k);
  146. }
  147. else if (SCM_I_WVECTP (v))
  148. return scm_c_weak_vector_ref (v, k);
  149. else
  150. scm_wrong_type_arg_msg (NULL, 0, v, "vector");
  151. }
  152. SCM_DEFINE (scm_vector_ref, "vector-ref", 2, 0, 0,
  153. (SCM v, SCM k),
  154. "@var{k} must be a valid index of @var{vector}.\n"
  155. "@samp{vector-ref} returns the contents of element @var{k} of\n"
  156. "@var{vector}.\n\n"
  157. "@lisp\n"
  158. "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n"
  159. "(vector-ref '#(1 1 2 3 5 8 13 21)\n"
  160. " (let ((i (round (* 2 (acos -1)))))\n"
  161. " (if (inexact? i)\n"
  162. " (inexact->exact i)\n"
  163. " i))) @result{} 13\n"
  164. "@end lisp")
  165. #define FUNC_NAME s_scm_vector_ref
  166. {
  167. return scm_c_vector_ref (v, scm_to_size_t (k));
  168. }
  169. #undef FUNC_NAME
  170. void
  171. scm_c_vector_set_x (SCM v, size_t k, SCM obj)
  172. {
  173. if (SCM_I_IS_NONWEAK_VECTOR (v))
  174. {
  175. if (k >= SCM_I_VECTOR_LENGTH (v))
  176. scm_out_of_range (NULL, scm_from_size_t (k));
  177. SCM_SIMPLE_VECTOR_SET (v, k, obj);
  178. }
  179. else if (SCM_I_WVECTP (v))
  180. scm_c_weak_vector_set_x (v, k, obj);
  181. else
  182. scm_wrong_type_arg_msg (NULL, 0, v, "vector");
  183. }
  184. SCM_DEFINE (scm_vector_set_x, "vector-set!", 3, 0, 0,
  185. (SCM v, SCM k, SCM obj),
  186. "@var{k} must be a valid index of @var{vector}.\n"
  187. "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n"
  188. "The value returned by @samp{vector-set!} is unspecified.\n"
  189. "@lisp\n"
  190. "(let ((vec (vector 0 '(2 2 2 2) \"Anna\")))\n"
  191. " (vector-set! vec 1 '(\"Sue\" \"Sue\"))\n"
  192. " vec) @result{} #(0 (\"Sue\" \"Sue\") \"Anna\")\n"
  193. "(vector-set! '#(0 1 2) 1 \"doe\") @result{} @emph{error} ; constant vector\n"
  194. "@end lisp")
  195. #define FUNC_NAME s_scm_vector_set_x
  196. {
  197. scm_c_vector_set_x (v, scm_to_size_t (k), obj);
  198. return SCM_UNSPECIFIED;
  199. }
  200. #undef FUNC_NAME
  201. SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0,
  202. (SCM k, SCM fill),
  203. "Return a newly allocated vector of @var{k} elements. If a\n"
  204. "second argument is given, then each position is initialized to\n"
  205. "@var{fill}. Otherwise the initial contents of each position is\n"
  206. "unspecified.")
  207. #define FUNC_NAME s_scm_make_vector
  208. {
  209. size_t l = scm_to_unsigned_integer (k, 0, VECTOR_MAX_LENGTH);
  210. if (SCM_UNBNDP (fill))
  211. fill = SCM_UNSPECIFIED;
  212. return scm_c_make_vector (l, fill);
  213. }
  214. #undef FUNC_NAME
  215. SCM
  216. scm_c_make_vector (size_t k, SCM fill)
  217. #define FUNC_NAME s_scm_make_vector
  218. {
  219. SCM vector;
  220. unsigned long int j;
  221. SCM_ASSERT_RANGE (1, scm_from_size_t (k), k <= VECTOR_MAX_LENGTH);
  222. vector = scm_words ((k << 8) | scm_tc7_vector, k + 1);
  223. for (j = 0; j < k; ++j)
  224. SCM_SIMPLE_VECTOR_SET (vector, j, fill);
  225. return vector;
  226. }
  227. #undef FUNC_NAME
  228. SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0,
  229. (SCM vec),
  230. "Return a copy of @var{vec}.")
  231. #define FUNC_NAME s_scm_vector_copy
  232. {
  233. scm_t_array_handle handle;
  234. size_t i, len;
  235. ssize_t inc;
  236. const SCM *src;
  237. SCM result, *dst;
  238. src = scm_vector_elements (vec, &handle, &len, &inc);
  239. result = scm_c_make_vector (len, SCM_UNDEFINED);
  240. dst = SCM_I_VECTOR_WELTS (result);
  241. for (i = 0; i < len; i++, src += inc)
  242. dst[i] = *src;
  243. scm_array_handle_release (&handle);
  244. return result;
  245. }
  246. #undef FUNC_NAME
  247. SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0,
  248. (SCM v),
  249. "Return a newly allocated list composed of the elements of @var{v}.\n"
  250. "\n"
  251. "@lisp\n"
  252. "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
  253. "(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
  254. "@end lisp")
  255. #define FUNC_NAME s_scm_vector_to_list
  256. {
  257. SCM res = SCM_EOL;
  258. const SCM *data;
  259. scm_t_array_handle handle;
  260. size_t i, count, len;
  261. ssize_t inc;
  262. data = scm_vector_elements (v, &handle, &len, &inc);
  263. for (i = (len - 1) * inc, count = 0;
  264. count < len;
  265. i -= inc, count++)
  266. res = scm_cons (data[i], res);
  267. scm_array_handle_release (&handle);
  268. return res;
  269. }
  270. #undef FUNC_NAME
  271. SCM_DEFINE (scm_vector_fill_x, "vector-fill!", 2, 0, 0,
  272. (SCM v, SCM fill),
  273. "Store @var{fill} in every position of @var{vector}. The value\n"
  274. "returned by @code{vector-fill!} is unspecified.")
  275. #define FUNC_NAME s_scm_vector_fill_x
  276. {
  277. scm_t_array_handle handle;
  278. SCM *data;
  279. size_t i, len;
  280. ssize_t inc;
  281. data = scm_vector_writable_elements (v, &handle, &len, &inc);
  282. for (i = 0; i < len; i += inc)
  283. data[i] = fill;
  284. scm_array_handle_release (&handle);
  285. return SCM_UNSPECIFIED;
  286. }
  287. #undef FUNC_NAME
  288. SCM
  289. scm_i_vector_equal_p (SCM x, SCM y)
  290. {
  291. long i;
  292. for (i = SCM_I_VECTOR_LENGTH (x) - 1; i >= 0; i--)
  293. if (scm_is_false (scm_equal_p (SCM_I_VECTOR_ELTS (x)[i],
  294. SCM_I_VECTOR_ELTS (y)[i])))
  295. return SCM_BOOL_F;
  296. return SCM_BOOL_T;
  297. }
  298. SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0,
  299. (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
  300. "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
  301. "to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
  302. "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
  303. "@code{vector-move-left!} copies elements in leftmost order.\n"
  304. "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
  305. "same vector, @code{vector-move-left!} is usually appropriate when\n"
  306. "@var{start1} is greater than @var{start2}.")
  307. #define FUNC_NAME s_scm_vector_move_left_x
  308. {
  309. scm_t_array_handle handle1, handle2;
  310. const SCM *elts1;
  311. SCM *elts2;
  312. size_t len1, len2;
  313. ssize_t inc1, inc2;
  314. size_t i, j, e;
  315. elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
  316. elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);
  317. i = scm_to_unsigned_integer (start1, 0, len1);
  318. e = scm_to_unsigned_integer (end1, i, len1);
  319. SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) <= len2);
  320. j = scm_to_unsigned_integer (start2, 0, len2);
  321. SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i));
  322. i *= inc1;
  323. e *= inc1;
  324. j *= inc2;
  325. for (; i < e; i += inc1, j += inc2)
  326. elts2[j] = elts1[i];
  327. scm_array_handle_release (&handle2);
  328. scm_array_handle_release (&handle1);
  329. return SCM_UNSPECIFIED;
  330. }
  331. #undef FUNC_NAME
  332. SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
  333. (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
  334. "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
  335. "to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
  336. "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
  337. "@code{vector-move-right!} copies elements in rightmost order.\n"
  338. "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
  339. "same vector, @code{vector-move-right!} is usually appropriate when\n"
  340. "@var{start1} is less than @var{start2}.")
  341. #define FUNC_NAME s_scm_vector_move_right_x
  342. {
  343. scm_t_array_handle handle1, handle2;
  344. const SCM *elts1;
  345. SCM *elts2;
  346. size_t len1, len2;
  347. ssize_t inc1, inc2;
  348. size_t i, j, e;
  349. elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
  350. elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);
  351. i = scm_to_unsigned_integer (start1, 0, len1);
  352. e = scm_to_unsigned_integer (end1, i, len1);
  353. SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) <= len2);
  354. j = scm_to_unsigned_integer (start2, 0, len2);
  355. SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i));
  356. j += (e - i);
  357. i *= inc1;
  358. e *= inc1;
  359. j *= inc2;
  360. while (i < e)
  361. {
  362. e -= inc1;
  363. j -= inc2;
  364. elts2[j] = elts1[e];
  365. }
  366. scm_array_handle_release (&handle2);
  367. scm_array_handle_release (&handle1);
  368. return SCM_UNSPECIFIED;
  369. }
  370. #undef FUNC_NAME
  371. static SCM
  372. vector_handle_ref (SCM vector, size_t idx)
  373. {
  374. assert (idx < SCM_I_VECTOR_LENGTH (vector));
  375. return SCM_I_VECTOR_WELTS(vector)[idx];
  376. }
  377. static void
  378. vector_handle_set (SCM vector, size_t idx, SCM val)
  379. {
  380. assert (idx < SCM_I_VECTOR_LENGTH (vector));
  381. SCM_I_VECTOR_WELTS(vector)[idx] = val;
  382. }
  383. static void
  384. vector_get_handle (SCM v, scm_t_array_handle *h)
  385. {
  386. h->base = 0;
  387. h->root = v;
  388. h->ndims = 1;
  389. h->dims = &h->dim0;
  390. h->dim0.lbnd = 0;
  391. h->dim0.ubnd = SCM_I_VECTOR_LENGTH (v) - 1;
  392. h->dim0.inc = 1;
  393. h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM;
  394. h->elements = h->writable_elements = SCM_I_VECTOR_WELTS (v);
  395. }
  396. /* the & ~2 allows catching scm_tc7_wvect as well. needs changing if you change
  397. tags.h. */
  398. SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector, 0x7f & ~2,
  399. vector_handle_ref, vector_handle_set,
  400. vector_get_handle)
  401. SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_SCM, scm_make_vector)
  402. void
  403. scm_init_vectors ()
  404. {
  405. #include "libguile/vectors.x"
  406. }
  407. /*
  408. Local Variables:
  409. c-file-style: "gnu"
  410. End:
  411. */