array-map.c 27 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922
  1. /* Copyright 1996,1998,2000-2001,2004-2006,2008-2015,2018-2019
  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 <assert.h>
  19. #include <string.h>
  20. #include "arrays.h"
  21. #include "bitvectors.h"
  22. #include "boolean.h"
  23. #include "chars.h"
  24. #include "eq.h"
  25. #include "eval.h"
  26. #include "feature.h"
  27. #include "gsubr.h"
  28. #include "list.h"
  29. #include "numbers.h"
  30. #include "pairs.h"
  31. #include "procs.h"
  32. #include "smob.h"
  33. #include "srfi-4.h"
  34. #include "strings.h"
  35. #include "symbols.h"
  36. #include "vectors.h"
  37. #include "array-map.h"
  38. /* The WHAT argument for `scm_gc_malloc ()' et al. */
  39. static const char vi_gc_hint[] = "array-indices";
  40. static SCM
  41. make1array (SCM v, ssize_t inc)
  42. {
  43. SCM a = scm_i_make_array (1);
  44. SCM_I_ARRAY_SET_BASE (a, 0);
  45. SCM_I_ARRAY_DIMS (a)->lbnd = 0;
  46. SCM_I_ARRAY_DIMS (a)->ubnd = scm_c_array_length (v) - 1;
  47. SCM_I_ARRAY_DIMS (a)->inc = inc;
  48. SCM_I_ARRAY_SET_V (a, v);
  49. return a;
  50. }
  51. /* Linear index of not-unrolled index set. */
  52. static size_t
  53. cindk (SCM ra, ssize_t *ve, int kend)
  54. {
  55. if (SCM_I_ARRAYP (ra))
  56. {
  57. int k;
  58. size_t i = SCM_I_ARRAY_BASE (ra);
  59. for (k = 0; k < kend; ++k)
  60. i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS (ra)[k].inc;
  61. return i;
  62. }
  63. else
  64. return 0; /* this is BASE */
  65. }
  66. /* array mapper: apply cproc to each dimension of the given arrays?.
  67. int (*cproc) (); procedure to call on unrolled arrays?
  68. cproc (dest, source list) or
  69. cproc (dest, data, source list).
  70. SCM data; data to give to cproc or unbound.
  71. SCM ra0; destination array.
  72. SCM lra; list of source arrays.
  73. const char *what; caller, for error reporting. */
  74. #define LBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].lbnd
  75. #define UBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].ubnd
  76. #define MAX(A, B) ((A) >= (B) ? (A) : (B))
  77. /* scm_ramapc() always calls cproc with rank-1 arrays created by
  78. make1array. cproc (rafe, ramap, rafill, racp) can assume that the
  79. dims[0].lbnd of these arrays is always 0. */
  80. int
  81. scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
  82. {
  83. int (*cproc) () = cproc_ptr;
  84. SCM z, va0, lva, *plva;
  85. int k, kmax, kroll;
  86. ssize_t *vi, inc;
  87. size_t len;
  88. /* Prepare reference argument. */
  89. if (SCM_I_ARRAYP (ra0))
  90. {
  91. kmax = SCM_I_ARRAY_NDIM (ra0)-1;
  92. inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
  93. va0 = make1array (SCM_I_ARRAY_V (ra0), inc);
  94. /* Find unroll depth */
  95. for (kroll = MAX (0, kmax); kroll > 0; --kroll)
  96. {
  97. inc *= (UBND (ra0, kroll) - LBND (ra0, kroll) + 1);
  98. if (inc != SCM_I_ARRAY_DIMS (ra0)[kroll-1].inc)
  99. break;
  100. }
  101. }
  102. else
  103. {
  104. kroll = kmax = 0;
  105. va0 = ra0 = make1array (ra0, 1);
  106. }
  107. /* Prepare rest arguments. */
  108. lva = SCM_EOL;
  109. plva = &lva;
  110. for (z = lra; !scm_is_null (z); z = SCM_CDR (z))
  111. {
  112. SCM va1, ra1 = SCM_CAR (z);
  113. if (SCM_I_ARRAYP (ra1))
  114. {
  115. if (kmax != SCM_I_ARRAY_NDIM (ra1) - 1)
  116. scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
  117. inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
  118. va1 = make1array (SCM_I_ARRAY_V (ra1), inc);
  119. /* Check unroll depth. */
  120. for (k = kmax; k > kroll; --k)
  121. {
  122. ssize_t l0 = LBND (ra0, k), u0 = UBND (ra0, k);
  123. if (l0 < LBND (ra1, k) || u0 > UBND (ra1, k))
  124. scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
  125. inc *= (u0 - l0 + 1);
  126. if (inc != SCM_I_ARRAY_DIMS (ra1)[k-1].inc)
  127. {
  128. kroll = k;
  129. break;
  130. }
  131. }
  132. /* Check matching of not-unrolled axes. */
  133. for (; k>=0; --k)
  134. if (LBND (ra0, k) < LBND (ra1, k) || UBND (ra0, k) > UBND (ra1, k))
  135. scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
  136. }
  137. else
  138. {
  139. if (kmax != 0)
  140. scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
  141. va1 = make1array (ra1, 1);
  142. if (LBND (ra0, 0) < 0 /* LBND (va1, 0) */ || UBND (ra0, 0) > UBND (va1, 0))
  143. scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
  144. }
  145. *plva = scm_cons (va1, SCM_EOL);
  146. plva = SCM_CDRLOC (*plva);
  147. }
  148. /* Check emptiness of not-unrolled axes. */
  149. for (k = 0; k < kroll; ++k)
  150. if (0 == (UBND (ra0, k) - LBND (ra0, k) + 1))
  151. return 1;
  152. /* Set unrolled size. */
  153. for (len = 1; k <= kmax; ++k)
  154. len *= (UBND (ra0, k) - LBND (ra0, k) + 1);
  155. UBND (va0, 0) = len - 1;
  156. for (z = lva; !scm_is_null (z); z = SCM_CDR (z))
  157. UBND (SCM_CAR (z), 0) = len - 1;
  158. /* Set starting indices and go. */
  159. vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * kroll, vi_gc_hint);
  160. for (k = 0; k < kroll; ++k)
  161. vi[k] = LBND (ra0, k);
  162. do
  163. {
  164. if (k == kroll)
  165. {
  166. SCM y = lra;
  167. SCM_I_ARRAY_SET_BASE (va0, cindk (ra0, vi, kroll));
  168. for (z = lva; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y))
  169. SCM_I_ARRAY_SET_BASE (SCM_CAR (z), cindk (SCM_CAR (y), vi, kroll));
  170. if (! (SCM_UNBNDP (data) ? cproc (va0, lva) : cproc (va0, data, lva)))
  171. return 0;
  172. --k;
  173. }
  174. else if (vi[k] < UBND (ra0, k))
  175. {
  176. ++vi[k];
  177. ++k;
  178. }
  179. else
  180. {
  181. vi[k] = LBND (ra0, k) - 1;
  182. --k;
  183. }
  184. }
  185. while (k >= 0);
  186. return 1;
  187. }
  188. #undef UBND
  189. #undef LBND
  190. static int
  191. rafill (SCM dst, SCM fill)
  192. {
  193. size_t n = SCM_I_ARRAY_DIMS (dst)->ubnd + 1;
  194. size_t i = SCM_I_ARRAY_BASE (dst);
  195. ssize_t inc = SCM_I_ARRAY_DIMS (dst)->inc;
  196. scm_t_array_handle h;
  197. dst = SCM_I_ARRAY_V (dst);
  198. scm_array_get_handle (dst, &h);
  199. for (; n-- > 0; i += inc)
  200. h.vset (h.vector, i, fill);
  201. scm_array_handle_release (&h);
  202. return 1;
  203. }
  204. SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
  205. (SCM ra, SCM fill),
  206. "Store @var{fill} in every element of array @var{ra}. The value\n"
  207. "returned is unspecified.")
  208. #define FUNC_NAME s_scm_array_fill_x
  209. {
  210. scm_ramapc (rafill, fill, ra, SCM_EOL, FUNC_NAME);
  211. return SCM_UNSPECIFIED;
  212. }
  213. #undef FUNC_NAME
  214. static int
  215. racp (SCM src, SCM dst)
  216. {
  217. size_t i_s, i_d, n;
  218. ssize_t inc_s, inc_d;
  219. scm_t_array_handle h_s, h_d;
  220. dst = SCM_CAR (dst);
  221. i_s = SCM_I_ARRAY_BASE (src);
  222. i_d = SCM_I_ARRAY_BASE (dst);
  223. n = (SCM_I_ARRAY_DIMS (src)->ubnd + 1);
  224. inc_s = SCM_I_ARRAY_DIMS (src)->inc;
  225. inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
  226. src = SCM_I_ARRAY_V (src);
  227. dst = SCM_I_ARRAY_V (dst);
  228. scm_array_get_handle (src, &h_s);
  229. scm_array_get_handle (dst, &h_d);
  230. if (h_s.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM
  231. && h_d.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
  232. {
  233. SCM const * el_s = h_s.elements;
  234. SCM * el_d = h_d.writable_elements;
  235. if (!el_d && n>0)
  236. scm_wrong_type_arg_msg ("array-copy!", SCM_ARG2, dst, "mutable array");
  237. for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  238. el_d[i_d] = el_s[i_s];
  239. }
  240. else
  241. for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  242. h_d.vset (h_d.vector, i_d, h_s.vref (h_s.vector, i_s));
  243. scm_array_handle_release (&h_d);
  244. scm_array_handle_release (&h_s);
  245. return 1;
  246. }
  247. SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x);
  248. SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
  249. (SCM src, SCM dst),
  250. "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n"
  251. "Copy every element from vector or array @var{src} to the\n"
  252. "corresponding element of @var{dst}. @var{dst} must have the\n"
  253. "same rank as @var{src}, and be at least as large in each\n"
  254. "dimension. The order is unspecified.")
  255. #define FUNC_NAME s_scm_array_copy_x
  256. {
  257. scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), FUNC_NAME);
  258. return SCM_UNSPECIFIED;
  259. }
  260. #undef FUNC_NAME
  261. static int
  262. ramap (SCM ra0, SCM proc, SCM ras)
  263. {
  264. size_t i0 = SCM_I_ARRAY_BASE (ra0);
  265. ssize_t inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
  266. size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd + 1;
  267. scm_t_array_handle h0;
  268. ra0 = SCM_I_ARRAY_V (ra0);
  269. scm_array_get_handle (ra0, &h0);
  270. if (scm_is_null (ras))
  271. for (; n--; i0 += inc0)
  272. h0.vset (h0.vector, i0, scm_call_0 (proc));
  273. else
  274. {
  275. SCM ra1 = SCM_CAR (ras);
  276. size_t i1 = SCM_I_ARRAY_BASE (ra1);
  277. ssize_t inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
  278. scm_t_array_handle h1;
  279. ra1 = SCM_I_ARRAY_V (ra1);
  280. scm_array_get_handle (ra1, &h1);
  281. ras = SCM_CDR (ras);
  282. if (scm_is_null (ras))
  283. for (; n--; i0 += inc0, i1 += inc1)
  284. h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1)));
  285. else
  286. {
  287. SCM ra2 = SCM_CAR (ras);
  288. size_t i2 = SCM_I_ARRAY_BASE (ra2);
  289. ssize_t inc2 = SCM_I_ARRAY_DIMS (ra2)->inc;
  290. scm_t_array_handle h2;
  291. ra2 = SCM_I_ARRAY_V (ra2);
  292. scm_array_get_handle (ra2, &h2);
  293. ras = SCM_CDR (ras);
  294. if (scm_is_null (ras))
  295. for (; n--; i0 += inc0, i1 += inc1, i2 += inc2)
  296. h0.vset (h0.vector, i0, scm_call_2 (proc, h1.vref (h1.vector, i1), h2.vref (h2.vector, i2)));
  297. else
  298. {
  299. scm_t_array_handle *hs;
  300. size_t restn = scm_ilength (ras);
  301. SCM args = SCM_EOL;
  302. SCM *p = &args;
  303. SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint);
  304. size_t k;
  305. ssize_t i;
  306. for (k = 0; k < restn; ++k)
  307. {
  308. *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
  309. sa[k] = SCM_CARLOC (*p);
  310. p = SCM_CDRLOC (*p);
  311. }
  312. hs = scm_gc_malloc (sizeof(scm_t_array_handle) * restn, vi_gc_hint);
  313. for (k = 0; k < restn; ++k, ras = scm_cdr (ras))
  314. scm_array_get_handle (scm_car (ras), hs+k);
  315. for (i = 0; n--; i0 += inc0, i1 += inc1, i2 += inc2, ++i)
  316. {
  317. for (k = 0; k < restn; ++k)
  318. *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc);
  319. h0.vset (h0.vector, i0, scm_apply_2 (proc, h1.vref (h1.vector, i1), h2.vref (h2.vector, i2), args));
  320. }
  321. for (k = 0; k < restn; ++k)
  322. scm_array_handle_release (hs+k);
  323. }
  324. scm_array_handle_release (&h2);
  325. }
  326. scm_array_handle_release (&h1);
  327. }
  328. scm_array_handle_release (&h0);
  329. return 1;
  330. }
  331. SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);
  332. SCM_SYMBOL (sym_b, "b");
  333. SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
  334. (SCM ra0, SCM proc, SCM lra),
  335. "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n"
  336. "@var{array1}, @dots{} must have the same number of dimensions\n"
  337. "as @var{ra0} and have a range for each index which includes the\n"
  338. "range for the corresponding index in @var{ra0}. @var{proc} is\n"
  339. "applied to each tuple of elements of @var{array1}, @dots{} and\n"
  340. "the result is stored as the corresponding element in @var{ra0}.\n"
  341. "The value returned is unspecified. The order of application is\n"
  342. "unspecified.")
  343. #define FUNC_NAME s_scm_array_map_x
  344. {
  345. SCM_VALIDATE_PROC (2, proc);
  346. SCM_VALIDATE_REST_ARGUMENT (lra);
  347. scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
  348. return SCM_UNSPECIFIED;
  349. }
  350. #undef FUNC_NAME
  351. static int
  352. rafe (SCM ra0, SCM proc, SCM ras)
  353. {
  354. size_t i0 = SCM_I_ARRAY_BASE (ra0);
  355. ssize_t inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
  356. size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd + 1;
  357. scm_t_array_handle h0;
  358. ra0 = SCM_I_ARRAY_V (ra0);
  359. scm_array_get_handle (ra0, &h0);
  360. if (scm_is_null (ras))
  361. for (; n--; i0 += inc0)
  362. scm_call_1 (proc, h0.vref (h0.vector, i0));
  363. else
  364. {
  365. scm_t_array_handle *hs;
  366. size_t restn = scm_ilength (ras);
  367. SCM args = SCM_EOL;
  368. SCM *p = &args;
  369. SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint);
  370. for (size_t k = 0; k < restn; ++k)
  371. {
  372. *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
  373. sa[k] = SCM_CARLOC (*p);
  374. p = SCM_CDRLOC (*p);
  375. }
  376. hs = scm_gc_malloc (sizeof(scm_t_array_handle) * restn, vi_gc_hint);
  377. for (size_t k = 0; k < restn; ++k, ras = scm_cdr (ras))
  378. scm_array_get_handle (scm_car (ras), hs+k);
  379. for (ssize_t i = 0; n--; i0 += inc0, ++i)
  380. {
  381. for (size_t k = 0; k < restn; ++k)
  382. *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc);
  383. scm_apply_1 (proc, h0.vref (h0.vector, i0), args);
  384. }
  385. for (size_t k = 0; k < restn; ++k)
  386. scm_array_handle_release (hs+k);
  387. }
  388. scm_array_handle_release (&h0);
  389. return 1;
  390. }
  391. SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
  392. (SCM proc, SCM ra0, SCM lra),
  393. "Apply @var{proc} to each tuple of elements of @var{ra0} @dots{}\n"
  394. "in row-major order. The value returned is unspecified.")
  395. #define FUNC_NAME s_scm_array_for_each
  396. {
  397. SCM_VALIDATE_PROC (1, proc);
  398. SCM_VALIDATE_REST_ARGUMENT (lra);
  399. scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME);
  400. return SCM_UNSPECIFIED;
  401. }
  402. #undef FUNC_NAME
  403. static void
  404. array_index_map_1 (SCM ra, SCM proc)
  405. {
  406. scm_t_array_handle h;
  407. ssize_t i, inc;
  408. size_t p;
  409. scm_array_get_handle (ra, &h);
  410. inc = h.dims[0].inc;
  411. for (i = h.dims[0].lbnd, p = h.base; i <= h.dims[0].ubnd; ++i, p += inc)
  412. h.vset (h.vector, p, scm_call_1 (proc, scm_from_ssize_t (i)));
  413. scm_array_handle_release (&h);
  414. }
  415. /* Here we assume that the array is a scm_tc7_array, as that is the only
  416. kind of array in Guile that supports rank > 1. */
  417. static void
  418. array_index_map_n (SCM ra, SCM proc)
  419. {
  420. scm_t_array_handle h;
  421. int k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
  422. SCM args = SCM_EOL;
  423. SCM *p = &args;
  424. ssize_t *vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * (kmax + 1), vi_gc_hint);
  425. SCM **si = scm_gc_malloc_pointerless (sizeof(SCM *) * (kmax + 1), vi_gc_hint);
  426. for (k = 0; k <= kmax; k++)
  427. {
  428. vi[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
  429. if (vi[k] > SCM_I_ARRAY_DIMS (ra)[k].ubnd)
  430. return;
  431. *p = scm_cons (scm_from_ssize_t (vi[k]), SCM_EOL);
  432. si[k] = SCM_CARLOC (*p);
  433. p = SCM_CDRLOC (*p);
  434. }
  435. scm_array_get_handle (ra, &h);
  436. k = kmax;
  437. do
  438. {
  439. if (k == kmax)
  440. {
  441. size_t i;
  442. vi[kmax] = SCM_I_ARRAY_DIMS (ra)[kmax].lbnd;
  443. i = cindk (ra, vi, kmax+1);
  444. for (; vi[kmax] <= SCM_I_ARRAY_DIMS (ra)[kmax].ubnd; ++vi[kmax])
  445. {
  446. *(si[kmax]) = scm_from_ssize_t (vi[kmax]);
  447. h.vset (h.vector, i, scm_apply_0 (proc, args));
  448. i += SCM_I_ARRAY_DIMS (ra)[kmax].inc;
  449. }
  450. k--;
  451. }
  452. else if (vi[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
  453. {
  454. *(si[k]) = scm_from_ssize_t (++vi[k]);
  455. k++;
  456. }
  457. else
  458. {
  459. vi[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
  460. k--;
  461. }
  462. }
  463. while (k >= 0);
  464. scm_array_handle_release (&h);
  465. }
  466. SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
  467. (SCM ra, SCM proc),
  468. "Apply @var{proc} to the indices of each element of @var{ra} in\n"
  469. "turn, storing the result in the corresponding element. The value\n"
  470. "returned and the order of application are unspecified.\n\n"
  471. "One can implement @var{array-indexes} as\n"
  472. "@lisp\n"
  473. "(define (array-indexes array)\n"
  474. " (let ((ra (apply make-array #f (array-shape array))))\n"
  475. " (array-index-map! ra (lambda x x))\n"
  476. " ra))\n"
  477. "@end lisp\n"
  478. "Another example:\n"
  479. "@lisp\n"
  480. "(define (apl:index-generator n)\n"
  481. " (let ((v (make-uniform-vector n 1)))\n"
  482. " (array-index-map! v (lambda (i) i))\n"
  483. " v))\n"
  484. "@end lisp")
  485. #define FUNC_NAME s_scm_array_index_map_x
  486. {
  487. SCM_VALIDATE_PROC (2, proc);
  488. switch (scm_c_array_rank (ra))
  489. {
  490. case 0:
  491. scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
  492. break;
  493. case 1:
  494. array_index_map_1 (ra, proc);
  495. break;
  496. default:
  497. array_index_map_n (ra, proc);
  498. break;
  499. }
  500. return SCM_UNSPECIFIED;
  501. }
  502. #undef FUNC_NAME
  503. static int
  504. array_compare (scm_t_array_handle *hx, scm_t_array_handle *hy,
  505. size_t dim, unsigned long posx, unsigned long posy)
  506. {
  507. if (dim == scm_array_handle_rank (hx))
  508. return scm_is_true (scm_equal_p (scm_array_handle_ref (hx, posx),
  509. scm_array_handle_ref (hy, posy)));
  510. else
  511. {
  512. long incx, incy;
  513. size_t i;
  514. if (hx->dims[dim].lbnd != hy->dims[dim].lbnd
  515. || hx->dims[dim].ubnd != hy->dims[dim].ubnd)
  516. return 0;
  517. i = hx->dims[dim].ubnd - hx->dims[dim].lbnd + 1;
  518. incx = hx->dims[dim].inc;
  519. incy = hy->dims[dim].inc;
  520. posx += (i - 1) * incx;
  521. posy += (i - 1) * incy;
  522. for (; i > 0; i--, posx -= incx, posy -= incy)
  523. if (!array_compare (hx, hy, dim + 1, posx, posy))
  524. return 0;
  525. return 1;
  526. }
  527. }
  528. SCM
  529. scm_array_equal_p (SCM x, SCM y)
  530. {
  531. scm_t_array_handle hx, hy;
  532. SCM res;
  533. scm_array_get_handle (x, &hx);
  534. scm_array_get_handle (y, &hy);
  535. scm_t_array_element_type t1 = hx.element_type;
  536. scm_t_array_element_type t2 = hy.element_type;
  537. /* R6RS and Guile mostly use #vu8(...) as the literal syntax for
  538. bytevectors, but R7RS uses #u8. To allow R7RS users to re-use the
  539. various routines implemented on bytevectors which return vu8-tagged
  540. values and to also be able to do (equal? #u8(1 2 3) (bytevector 1 2
  541. 3)), we allow equality comparisons between vu8 and u8. */
  542. if (t1 == SCM_ARRAY_ELEMENT_TYPE_VU8)
  543. t1 = SCM_ARRAY_ELEMENT_TYPE_U8;
  544. if (t2 == SCM_ARRAY_ELEMENT_TYPE_VU8)
  545. t2 = SCM_ARRAY_ELEMENT_TYPE_U8;
  546. res = scm_from_bool (hx.ndims == hy.ndims && t1 == t2);
  547. if (scm_is_true (res))
  548. res = scm_from_bool (array_compare (&hx, &hy, 0, 0, 0));
  549. scm_array_handle_release (&hy);
  550. scm_array_handle_release (&hx);
  551. return res;
  552. }
  553. static SCM scm_i_array_equal_p (SCM, SCM, SCM);
  554. SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
  555. (SCM ra0, SCM ra1, SCM rest),
  556. "Return @code{#t} iff all arguments are arrays with the same\n"
  557. "shape, the same type, and have corresponding elements which are\n"
  558. "either @code{equal?} or @code{array-equal?}. This function\n"
  559. "differs from @code{equal?} in that all arguments must be arrays.")
  560. #define FUNC_NAME s_scm_i_array_equal_p
  561. {
  562. if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1))
  563. return SCM_BOOL_T;
  564. while (!scm_is_null (rest))
  565. {
  566. if (scm_is_false (scm_array_equal_p (ra0, ra1)))
  567. return SCM_BOOL_F;
  568. ra0 = ra1;
  569. ra1 = scm_car (rest);
  570. rest = scm_cdr (rest);
  571. }
  572. return scm_array_equal_p (ra0, ra1);
  573. }
  574. #undef FUNC_NAME
  575. /* Copy array descriptor with different base. */
  576. SCM
  577. scm_i_array_rebase (SCM a, size_t base)
  578. {
  579. size_t ndim = SCM_I_ARRAY_NDIM (a);
  580. SCM b = scm_i_raw_array (ndim);
  581. SCM_I_ARRAY_SET_V (b, SCM_I_ARRAY_V (a));
  582. /* FIXME do check base */
  583. SCM_I_ARRAY_SET_BASE (b, base);
  584. memcpy (SCM_I_ARRAY_DIMS (b), SCM_I_ARRAY_DIMS (a), sizeof (scm_t_array_dim)*ndim);
  585. return b;
  586. }
  587. static inline size_t padtoptr(size_t d) { return (d + (sizeof (void *) - 1)) & ~(sizeof (void *) - 1); }
  588. SCM_DEFINE (scm_array_slice_for_each, "array-slice-for-each", 2, 0, 1,
  589. (SCM frame_rank, SCM op, SCM args),
  590. "Apply @var{op} to each of the cells of rank rank(@var{arg})-@var{frame_rank}\n"
  591. "of the arrays @var{args}, in unspecified order. The first\n"
  592. "@var{frame_rank} dimensions of each @var{arg} must match.\n"
  593. "Rank-0 cells are passed as rank-0 arrays.\n\n"
  594. "The value returned is unspecified.\n\n"
  595. "For example:\n"
  596. "@lisp\n"
  597. ";; Sort the rows of rank-2 array A.\n\n"
  598. "(array-slice-for-each 1 (lambda (x) (sort! x <)) a)\n"
  599. "\n"
  600. ";; Compute the arguments of the (x y) vectors in the rows of rank-2\n"
  601. ";; array XYS and store them in rank-1 array ANGLES. Inside OP,\n"
  602. ";; XY is a rank-1 (2-1) array, and ANGLE is a rank-0 (1-1) array.\n\n"
  603. "(array-slice-for-each 1 \n"
  604. " (lambda (xy angle)\n"
  605. " (array-set! angle (atan (array-ref xy 1) (array-ref xy 0))))\n"
  606. " xys angles)\n"
  607. "@end lisp")
  608. #define FUNC_NAME s_scm_array_slice_for_each
  609. {
  610. SCM xargs = args;
  611. int const N = scm_ilength (args);
  612. int const frank = scm_to_int (frame_rank);
  613. int ocd;
  614. ssize_t step;
  615. SCM dargs_ = SCM_EOL;
  616. char const * msg;
  617. scm_t_array_dim * ais;
  618. int n, k;
  619. ssize_t z;
  620. /* to be allocated inside the pool */
  621. scm_t_array_handle * ah;
  622. SCM * args_;
  623. scm_t_array_dim ** as;
  624. int * rank;
  625. ssize_t * s;
  626. SCM * ai;
  627. SCM ** dargs;
  628. ssize_t * i;
  629. int * order;
  630. size_t * base;
  631. /* size the pool */
  632. char * pool;
  633. char * pool0;
  634. size_t pool_size = 0;
  635. pool_size += padtoptr(N*sizeof (scm_t_array_handle));
  636. pool_size += padtoptr(N*sizeof (SCM));
  637. pool_size += padtoptr(N*sizeof (scm_t_array_dim *));
  638. pool_size += padtoptr(N*sizeof (int));
  639. pool_size += padtoptr(frank*sizeof (ssize_t));
  640. pool_size += padtoptr(N*sizeof (SCM));
  641. pool_size += padtoptr(N*sizeof (SCM *));
  642. pool_size += padtoptr(frank*sizeof (ssize_t));
  643. pool_size += padtoptr(frank*sizeof (int));
  644. pool_size += padtoptr(N*sizeof (size_t));
  645. pool = scm_gc_malloc (pool_size, "pool");
  646. /* place the items in the pool */
  647. #define AFIC_ALLOC_ADVANCE(pool, count, type, name) \
  648. name = (void *)pool; \
  649. pool += padtoptr(count*sizeof (type));
  650. pool0 = pool;
  651. AFIC_ALLOC_ADVANCE (pool, N, scm_t_array_handle, ah);
  652. AFIC_ALLOC_ADVANCE (pool, N, SCM, args_);
  653. AFIC_ALLOC_ADVANCE (pool, N, scm_t_array_dim *, as);
  654. AFIC_ALLOC_ADVANCE (pool, N, int, rank);
  655. AFIC_ALLOC_ADVANCE (pool, frank, ssize_t, s);
  656. AFIC_ALLOC_ADVANCE (pool, N, SCM, ai);
  657. AFIC_ALLOC_ADVANCE (pool, N, SCM *, dargs);
  658. AFIC_ALLOC_ADVANCE (pool, frank, ssize_t, i);
  659. AFIC_ALLOC_ADVANCE (pool, frank, int, order);
  660. AFIC_ALLOC_ADVANCE (pool, N, size_t, base);
  661. assert((pool0+pool_size==pool) && "internal error");
  662. #undef AFIC_ALLOC_ADVANCE
  663. for (n=0, xargs=args; scm_is_pair(xargs); xargs=scm_cdr(xargs), ++n)
  664. {
  665. args_[n] = scm_car(xargs);
  666. scm_array_get_handle(args_[n], ah+n);
  667. as[n] = scm_array_handle_dims(ah+n);
  668. rank[n] = scm_array_handle_rank(ah+n);
  669. }
  670. /* checks */
  671. msg = NULL;
  672. if (frank<0)
  673. msg = "bad frame rank ~S, ~S";
  674. else
  675. {
  676. for (n=0; n!=N; ++n)
  677. {
  678. if (rank[n]<frank)
  679. {
  680. msg = "frame too large for arguments: ~S, ~S";
  681. goto check_msg;
  682. }
  683. for (k=0; k!=frank; ++k)
  684. {
  685. if (as[0][k].lbnd!=as[n][k].lbnd || as[0][k].ubnd!=as[n][k].ubnd)
  686. {
  687. msg = "mismatched frames: ~S, ~S";
  688. goto check_msg;
  689. }
  690. s[k] = as[n][k].ubnd - as[n][k].lbnd + 1;
  691. /* this check is needed if the array cannot be entirely */
  692. /* unrolled, because the unrolled subloop will be run before */
  693. /* checking the dimensions of the frame. */
  694. if (s[k]==0)
  695. goto end;
  696. }
  697. }
  698. }
  699. check_msg: ;
  700. if (msg!=NULL)
  701. {
  702. for (n=0; n!=N; ++n)
  703. scm_array_handle_release(ah+n);
  704. scm_misc_error("array-slice-for-each", msg, scm_cons(frame_rank, args));
  705. }
  706. /* prepare moving cells. */
  707. for (n=0; n!=N; ++n)
  708. {
  709. ai[n] = scm_i_make_array(rank[n]-frank);
  710. SCM_I_ARRAY_SET_V (ai[n], scm_shared_array_root(args_[n]));
  711. /* FIXME scm_array_handle_base (ah+n) should be in Guile */
  712. SCM_I_ARRAY_SET_BASE (ai[n], ah[n].base);
  713. ais = SCM_I_ARRAY_DIMS(ai[n]);
  714. for (k=frank; k!=rank[n]; ++k)
  715. {
  716. ais[k-frank] = as[n][k];
  717. }
  718. }
  719. /* prepare rest list for callee. */
  720. {
  721. SCM *p = &dargs_;
  722. for (n=0; n<N; ++n)
  723. {
  724. *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
  725. dargs[n] = SCM_CARLOC (*p);
  726. p = SCM_CDRLOC (*p);
  727. }
  728. }
  729. /* special case for rank 0. */
  730. if (frank==0)
  731. {
  732. for (n=0; n<N; ++n)
  733. *dargs[n] = ai[n];
  734. scm_apply_0(op, dargs_);
  735. for (n=0; n<N; ++n)
  736. scm_array_handle_release(ah+n);
  737. return SCM_UNSPECIFIED;
  738. }
  739. /* FIXME determine best looping order. */
  740. for (k=0; k!=frank; ++k)
  741. {
  742. i[k] = 0;
  743. order[k] = frank-1-k;
  744. }
  745. /* find outermost compact dim. */
  746. step = s[order[0]];
  747. ocd = 1;
  748. for (; ocd<frank; step *= s[order[ocd]], ++ocd)
  749. for (n=0; n!=N; ++n)
  750. if (step*as[n][order[0]].inc!=as[n][order[ocd]].inc)
  751. goto ocd_reached;
  752. ocd_reached: ;
  753. /* rank loop. */
  754. for (n=0; n!=N; ++n)
  755. base[n] = SCM_I_ARRAY_BASE(ai[n]);
  756. for (;;)
  757. {
  758. /* unrolled loop. */
  759. for (z=0; z!=step; ++z)
  760. {
  761. /* we are forced to create fresh array descriptors for each */
  762. /* call since we don't know whether the callee will keep them, */
  763. /* and Guile offers no way to copy the descriptor (since */
  764. /* descriptors are immutable). Yet another reason why this */
  765. /* should be in Scheme. */
  766. for (n=0; n<N; ++n)
  767. {
  768. *dargs[n] = scm_i_array_rebase(ai[n], base[n]);
  769. base[n] += as[n][order[0]].inc;
  770. }
  771. scm_apply_0(op, dargs_);
  772. }
  773. for (n=0; n<N; ++n)
  774. base[n] -= step*as[n][order[0]].inc;
  775. for (k=ocd; ; ++k)
  776. {
  777. if (k==frank)
  778. goto end;
  779. else if (i[order[k]]<s[order[k]]-1)
  780. {
  781. ++i[order[k]];
  782. for (n=0; n<N; ++n)
  783. base[n] += as[n][order[k]].inc;
  784. break;
  785. }
  786. else
  787. {
  788. i[order[k]] = 0;
  789. for (n=0; n<N; ++n)
  790. base[n] += as[n][order[k]].inc*(1-s[order[k]]);
  791. }
  792. }
  793. }
  794. end:;
  795. for (n=0; n<N; ++n)
  796. scm_array_handle_release(ah+n);
  797. return SCM_UNSPECIFIED;
  798. }
  799. #undef FUNC_NAME
  800. SCM_DEFINE (scm_array_slice_for_each_in_order, "array-slice-for-each-in-order", 2, 0, 1,
  801. (SCM frank, SCM op, SCM a),
  802. "Same as array-slice-for-each, but visit the cells sequentially\n"
  803. "and in row-major order.\n")
  804. #define FUNC_NAME s_scm_array_slice_for_each_in_order
  805. {
  806. return scm_array_slice_for_each (frank, op, a);
  807. }
  808. #undef FUNC_NAME
  809. void
  810. scm_init_array_map (void)
  811. {
  812. #include "array-map.x"
  813. scm_add_feature (s_scm_array_for_each);
  814. }