array-handle.c 12 KB

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