array-handle.c 12 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396
  1. /* Copyright 1995-1998,2000-2006,2009,2011,2013-2014,2018
  2. Free Software Foundation, Inc.
  3. This file is part of Guile.
  4. Guile is free software: you can redistribute it and/or modify it
  5. under the terms of the GNU Lesser General Public License as published
  6. by the Free Software Foundation, either version 3 of the License, or
  7. (at your option) any later version.
  8. Guile is distributed in the hope that it will be useful, but WITHOUT
  9. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  10. FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
  11. License for more details.
  12. You should have received a copy of the GNU Lesser General Public
  13. License along with Guile. If not, see
  14. <https://www.gnu.org/licenses/>. */
  15. #ifdef HAVE_CONFIG_H
  16. # include <config.h>
  17. #endif
  18. #include <string.h>
  19. #include "arrays.h"
  20. #include "boolean.h"
  21. #include "bitvectors.h"
  22. #include "bytevectors.h"
  23. #include "list.h"
  24. #include "numbers.h"
  25. #include "pairs.h"
  26. #include "strings.h"
  27. #include "symbols.h"
  28. #include "vectors.h"
  29. #include "array-handle.h"
  30. SCM scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_LAST + 1];
  31. /* Bytevectors as generalized vectors & arrays. */
  32. #define DEFINE_BYTEVECTOR_ACCESSORS(type, tag, infix) \
  33. static SCM \
  34. bytevector_##tag##_ref (SCM bv, size_t pos) \
  35. { \
  36. SCM idx = scm_from_size_t (pos * sizeof (type)); \
  37. return scm_bytevector_##infix##_ref (bv, idx); \
  38. } \
  39. static void \
  40. bytevector_##tag##_set (SCM bv, size_t pos, SCM val) \
  41. { \
  42. SCM idx = scm_from_size_t (pos * sizeof (type)); \
  43. scm_bytevector_##infix##_set_x (bv, idx, val); \
  44. }
  45. DEFINE_BYTEVECTOR_ACCESSORS (uint8_t, u8, u8);
  46. DEFINE_BYTEVECTOR_ACCESSORS (int8_t, s8, s8);
  47. DEFINE_BYTEVECTOR_ACCESSORS (uint16_t, u16, u16_native);
  48. DEFINE_BYTEVECTOR_ACCESSORS (int16_t, s16, s16_native);
  49. DEFINE_BYTEVECTOR_ACCESSORS (uint32_t, u32, u32_native);
  50. DEFINE_BYTEVECTOR_ACCESSORS (int32_t, s32, s32_native);
  51. DEFINE_BYTEVECTOR_ACCESSORS (uint64_t, u64, u64_native);
  52. DEFINE_BYTEVECTOR_ACCESSORS (int64_t, s64, s64_native);
  53. DEFINE_BYTEVECTOR_ACCESSORS (float, f32, ieee_single_native);
  54. DEFINE_BYTEVECTOR_ACCESSORS (double, f64, ieee_double_native);
  55. /* Since these functions are only called by Guile's C code, we can abort
  56. instead of throwing if there is an error. */
  57. static SCM
  58. bytevector_c32_ref (SCM bv, size_t pos)
  59. {
  60. char *c_bv;
  61. float real, imag;
  62. if (!SCM_BYTEVECTOR_P (bv))
  63. abort ();
  64. c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
  65. pos *= 2 * sizeof (float);
  66. if (pos + 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
  67. abort ();
  68. memcpy (&real, &c_bv[pos], sizeof (float));
  69. memcpy (&imag, &c_bv[pos + sizeof (float)], sizeof (float));
  70. return scm_c_make_rectangular (real, imag);
  71. }
  72. static SCM
  73. bytevector_c64_ref (SCM bv, size_t pos)
  74. {
  75. char *c_bv;
  76. double real, imag;
  77. if (!SCM_BYTEVECTOR_P (bv))
  78. abort ();
  79. c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
  80. pos *= 2 * sizeof (double);
  81. if (pos + 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
  82. abort ();
  83. memcpy (&real, &c_bv[pos], sizeof (double));
  84. memcpy (&imag, &c_bv[pos + sizeof (double)], sizeof (double));
  85. return scm_c_make_rectangular (real, imag);
  86. }
  87. static void
  88. bytevector_c32_set (SCM bv, size_t pos, SCM val)
  89. {
  90. char *c_bv;
  91. float real, imag;
  92. if (!SCM_BYTEVECTOR_P (bv))
  93. abort ();
  94. c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
  95. pos *= 2 * sizeof (float);
  96. if (pos + 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
  97. abort ();
  98. real = scm_c_real_part (val);
  99. imag = scm_c_imag_part (val);
  100. memcpy (&c_bv[pos], &real, sizeof (float));
  101. memcpy (&c_bv[pos + sizeof (float)], &imag, sizeof (float));
  102. }
  103. static void
  104. bytevector_c64_set (SCM bv, size_t pos, SCM val)
  105. {
  106. char *c_bv;
  107. double real, imag;
  108. if (!SCM_BYTEVECTOR_P (bv))
  109. abort ();
  110. c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
  111. pos *= 2 * sizeof (double);
  112. if (pos + 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
  113. abort ();
  114. real = scm_c_real_part (val);
  115. imag = scm_c_imag_part (val);
  116. memcpy (&c_bv[pos], &real, sizeof (double));
  117. memcpy (&c_bv[pos + sizeof (double)], &imag, sizeof (double));
  118. }
  119. static void
  120. initialize_vector_handle (scm_t_array_handle *h, size_t len,
  121. scm_t_array_element_type element_type,
  122. scm_t_vector_ref vref, scm_t_vector_set vset,
  123. const void *elements, int mutable_p)
  124. {
  125. h->base = 0;
  126. h->ndims = 1;
  127. h->dims = &h->dim0;
  128. h->dim0.lbnd = 0;
  129. h->dim0.ubnd = (ssize_t) (len - 1U);
  130. h->dim0.inc = 1;
  131. h->element_type = element_type;
  132. /* elements != writable_elements is used to check mutability later on.
  133. Ignore it if the array is empty. */
  134. h->elements = len==0 ? NULL : elements;
  135. h->writable_elements = mutable_p ? ((void *) h->elements) : NULL;
  136. h->vector = h->array;
  137. h->vref = vref;
  138. h->vset = vset;
  139. }
  140. static SCM
  141. bitvector_ref (SCM bv, size_t idx)
  142. {
  143. return scm_from_bool (scm_c_bitvector_bit_is_set (bv, idx));
  144. }
  145. static void
  146. bitvector_set_x (SCM bv, size_t idx, SCM val)
  147. {
  148. if (scm_is_true (val))
  149. scm_c_bitvector_set_bit_x (bv, idx);
  150. else
  151. scm_c_bitvector_clear_bit_x (bv, idx);
  152. }
  153. void
  154. scm_array_get_handle (SCM array, scm_t_array_handle *h)
  155. {
  156. if (!SCM_HEAP_OBJECT_P (array))
  157. scm_wrong_type_arg_msg (NULL, 0, array, "array");
  158. h->array = array;
  159. switch (SCM_TYP7 (array))
  160. {
  161. case scm_tc7_string:
  162. initialize_vector_handle (h, scm_c_string_length (array),
  163. SCM_ARRAY_ELEMENT_TYPE_CHAR,
  164. scm_c_string_ref, scm_c_string_set_x,
  165. NULL,
  166. scm_i_string_is_mutable (array));
  167. break;
  168. case scm_tc7_vector:
  169. initialize_vector_handle (h, scm_c_vector_length (array),
  170. SCM_ARRAY_ELEMENT_TYPE_SCM,
  171. scm_c_vector_ref, scm_c_vector_set_x,
  172. SCM_I_VECTOR_WELTS (array),
  173. SCM_I_IS_MUTABLE_VECTOR (array));
  174. break;
  175. case scm_tc7_bitvector:
  176. initialize_vector_handle (h, scm_c_bitvector_length (array),
  177. SCM_ARRAY_ELEMENT_TYPE_BIT,
  178. bitvector_ref,
  179. bitvector_set_x,
  180. scm_i_bitvector_bits (array),
  181. scm_i_is_mutable_bitvector (array));
  182. break;
  183. case scm_tc7_bytevector:
  184. {
  185. size_t length;
  186. scm_t_array_element_type element_type;
  187. scm_t_vector_ref vref;
  188. scm_t_vector_set vset;
  189. element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (array);
  190. length = SCM_BYTEVECTOR_TYPED_LENGTH (array);
  191. switch (element_type)
  192. {
  193. #define ACCESSOR_CASE(tag, TAG) \
  194. case SCM_ARRAY_ELEMENT_TYPE_##TAG: \
  195. vref = bytevector_##tag##_ref; \
  196. vset = bytevector_##tag##_set; \
  197. break
  198. case SCM_ARRAY_ELEMENT_TYPE_VU8:
  199. ACCESSOR_CASE(u8, U8);
  200. ACCESSOR_CASE(s8, S8);
  201. ACCESSOR_CASE(u16, U16);
  202. ACCESSOR_CASE(s16, S16);
  203. ACCESSOR_CASE(u32, U32);
  204. ACCESSOR_CASE(s32, S32);
  205. ACCESSOR_CASE(u64, U64);
  206. ACCESSOR_CASE(s64, S64);
  207. ACCESSOR_CASE(f32, F32);
  208. ACCESSOR_CASE(f64, F64);
  209. ACCESSOR_CASE(c32, C32);
  210. ACCESSOR_CASE(c64, C64);
  211. case SCM_ARRAY_ELEMENT_TYPE_SCM:
  212. case SCM_ARRAY_ELEMENT_TYPE_BIT:
  213. case SCM_ARRAY_ELEMENT_TYPE_CHAR:
  214. default:
  215. abort ();
  216. #undef ACCESSOR_CASE
  217. }
  218. initialize_vector_handle (h, length, element_type, vref, vset,
  219. SCM_BYTEVECTOR_CONTENTS (array),
  220. SCM_MUTABLE_BYTEVECTOR_P (array));
  221. }
  222. break;
  223. case scm_tc7_array:
  224. scm_array_get_handle (SCM_I_ARRAY_V (array), h);
  225. h->array = array;
  226. h->base = SCM_I_ARRAY_BASE (array);
  227. h->ndims = SCM_I_ARRAY_NDIM (array);
  228. h->dims = SCM_I_ARRAY_DIMS (array);
  229. break;
  230. default:
  231. scm_wrong_type_arg_msg (NULL, 0, array, "array");
  232. }
  233. }
  234. ssize_t
  235. scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
  236. {
  237. scm_t_array_dim *s = scm_array_handle_dims (h);
  238. ssize_t pos = 0, i;
  239. size_t k = scm_array_handle_rank (h);
  240. while (k > 0 && scm_is_pair (indices))
  241. {
  242. i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd);
  243. pos += (i - s->lbnd) * s->inc;
  244. k--;
  245. s++;
  246. indices = SCM_CDR (indices);
  247. }
  248. if (k > 0 || !scm_is_null (indices))
  249. scm_misc_error (NULL, "wrong number of indices, expecting ~a",
  250. scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
  251. return pos;
  252. }
  253. static void
  254. check_array_index_bounds (scm_t_array_dim *dim, ssize_t idx)
  255. {
  256. if (idx < dim->lbnd || idx > dim->ubnd)
  257. scm_error (scm_out_of_range_key, NULL, "Value out of range ~S to ~S: ~S",
  258. scm_list_3 (scm_from_ssize_t (dim->lbnd),
  259. scm_from_ssize_t (dim->ubnd),
  260. scm_from_ssize_t (idx)),
  261. scm_list_1 (scm_from_ssize_t (idx)));
  262. }
  263. ssize_t
  264. scm_array_handle_pos_1 (scm_t_array_handle *h, ssize_t idx0)
  265. {
  266. scm_t_array_dim *dim = scm_array_handle_dims (h);
  267. if (scm_array_handle_rank (h) != 1)
  268. scm_misc_error (NULL, "wrong number of indices, expecting ~A",
  269. scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
  270. check_array_index_bounds (&dim[0], idx0);
  271. return (idx0 - dim[0].lbnd) * dim[0].inc;
  272. }
  273. ssize_t
  274. scm_array_handle_pos_2 (scm_t_array_handle *h, ssize_t idx0, ssize_t idx1)
  275. {
  276. scm_t_array_dim *dim = scm_array_handle_dims (h);
  277. if (scm_array_handle_rank (h) != 2)
  278. scm_misc_error (NULL, "wrong number of indices, expecting ~A",
  279. scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
  280. check_array_index_bounds (&dim[0], idx0);
  281. check_array_index_bounds (&dim[1], idx1);
  282. return ((idx0 - dim[0].lbnd) * dim[0].inc
  283. + (idx1 - dim[1].lbnd) * dim[1].inc);
  284. }
  285. SCM
  286. scm_array_handle_element_type (scm_t_array_handle *h)
  287. {
  288. if (h->element_type < 0 || h->element_type > SCM_ARRAY_ELEMENT_TYPE_LAST)
  289. abort (); /* guile programming error */
  290. return scm_i_array_element_types[h->element_type];
  291. }
  292. void
  293. scm_array_handle_release (scm_t_array_handle *h)
  294. {
  295. /* Nothing to do here until arrays need to be reserved for real.
  296. */
  297. }
  298. const SCM *
  299. scm_array_handle_elements (scm_t_array_handle *h)
  300. {
  301. if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
  302. scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
  303. return ((const SCM *) h->elements) + h->base;
  304. }
  305. SCM *
  306. scm_array_handle_writable_elements (scm_t_array_handle *h)
  307. {
  308. if (h->writable_elements != h->elements)
  309. scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable array");
  310. return (SCM *) scm_array_handle_elements (h);
  311. }
  312. void
  313. scm_init_array_handle (void)
  314. {
  315. #define DEFINE_ARRAY_TYPE(tag, TAG) \
  316. scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] = scm_from_utf8_symbol (#tag)
  317. scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T;
  318. DEFINE_ARRAY_TYPE (a, CHAR);
  319. DEFINE_ARRAY_TYPE (b, BIT);
  320. DEFINE_ARRAY_TYPE (vu8, VU8);
  321. DEFINE_ARRAY_TYPE (u8, U8);
  322. DEFINE_ARRAY_TYPE (s8, S8);
  323. DEFINE_ARRAY_TYPE (u16, U16);
  324. DEFINE_ARRAY_TYPE (s16, S16);
  325. DEFINE_ARRAY_TYPE (u32, U32);
  326. DEFINE_ARRAY_TYPE (s32, S32);
  327. DEFINE_ARRAY_TYPE (u64, U64);
  328. DEFINE_ARRAY_TYPE (s64, S64);
  329. DEFINE_ARRAY_TYPE (f32, F32);
  330. DEFINE_ARRAY_TYPE (f64, F64);
  331. DEFINE_ARRAY_TYPE (c32, C32);
  332. DEFINE_ARRAY_TYPE (c64, C64);
  333. #include "array-handle.x"
  334. }