arrays.c 36 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239
  1. /* Copyright 1995-1998,2000-2006,2009-2015,2018, 2021
  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 <stdio.h>
  19. #include <errno.h>
  20. #include <string.h>
  21. #include "array-map.h"
  22. #include "bitvectors.h"
  23. #include "boolean.h"
  24. #include "bytevectors.h"
  25. #include "chars.h"
  26. #include "dynwind.h"
  27. #include "eq.h"
  28. #include "error.h"
  29. #include "eval.h"
  30. #include "feature.h"
  31. #include "fports.h"
  32. #include "generalized-vectors.h"
  33. #include "gsubr.h"
  34. #include "list.h"
  35. #include "modules.h"
  36. #include "numbers.h"
  37. #include "pairs.h"
  38. #include "procs.h"
  39. #include "read.h"
  40. #include "srfi-13.h"
  41. #include "srfi-4.h"
  42. #include "strings.h"
  43. #include "uniform.h"
  44. #include "vectors.h"
  45. #include "arrays.h"
  46. SCM_INTERNAL SCM scm_i_array_ref (SCM v,
  47. SCM idx0, SCM idx1, SCM idxN);
  48. SCM_INTERNAL SCM scm_i_array_set_x (SCM v, SCM obj,
  49. SCM idx0, SCM idx1, SCM idxN);
  50. int
  51. scm_is_array (SCM obj)
  52. {
  53. if (!SCM_HEAP_OBJECT_P (obj))
  54. return 0;
  55. switch (SCM_TYP7 (obj))
  56. {
  57. case scm_tc7_string:
  58. case scm_tc7_vector:
  59. case scm_tc7_bitvector:
  60. case scm_tc7_bytevector:
  61. case scm_tc7_array:
  62. return 1;
  63. default:
  64. return 0;
  65. }
  66. }
  67. SCM_DEFINE (scm_array_p_2, "array?", 1, 0, 0,
  68. (SCM obj),
  69. "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
  70. "not.")
  71. #define FUNC_NAME s_scm_array_p_2
  72. {
  73. return scm_from_bool (scm_is_array (obj));
  74. }
  75. #undef FUNC_NAME
  76. /* The array type predicate, with an extra argument kept for backward
  77. compatibility. Note that we can't use `SCM_DEFINE' directly because there
  78. would be an argument count mismatch that would be caught by
  79. `snarf-check-and-output-texi.scm'. */
  80. SCM
  81. scm_array_p (SCM obj, SCM unused)
  82. {
  83. return scm_array_p_2 (obj);
  84. }
  85. int
  86. scm_is_typed_array (SCM obj, SCM type)
  87. {
  88. int ret = 0;
  89. if (scm_is_array (obj))
  90. {
  91. scm_t_array_handle h;
  92. scm_array_get_handle (obj, &h);
  93. ret = scm_is_eq (scm_array_handle_element_type (&h), type);
  94. scm_array_handle_release (&h);
  95. }
  96. return ret;
  97. }
  98. SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
  99. (SCM obj, SCM type),
  100. "Return @code{#t} if the @var{obj} is an array of type\n"
  101. "@var{type}, and @code{#f} if not.")
  102. #define FUNC_NAME s_scm_typed_array_p
  103. {
  104. return scm_from_bool (scm_is_typed_array (obj, type));
  105. }
  106. #undef FUNC_NAME
  107. size_t
  108. scm_c_array_length (SCM array)
  109. {
  110. scm_t_array_handle handle;
  111. size_t res;
  112. scm_array_get_handle (array, &handle);
  113. if (scm_array_handle_rank (&handle) < 1)
  114. {
  115. scm_array_handle_release (&handle);
  116. scm_wrong_type_arg_msg (NULL, 0, array, "array of nonzero rank");
  117. }
  118. res = handle.dims[0].ubnd - handle.dims[0].lbnd + 1;
  119. scm_array_handle_release (&handle);
  120. return res;
  121. }
  122. SCM_DEFINE (scm_array_length, "array-length", 1, 0, 0,
  123. (SCM array),
  124. "Return the length of an array: its first dimension.\n"
  125. "It is an error to ask for the length of an array of rank 0.")
  126. #define FUNC_NAME s_scm_array_length
  127. {
  128. return scm_from_size_t (scm_c_array_length (array));
  129. }
  130. #undef FUNC_NAME
  131. SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
  132. (SCM ra),
  133. "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
  134. "elements with a @code{0} minimum with one greater than the maximum. So:\n"
  135. "@lisp\n"
  136. "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
  137. "@end lisp")
  138. #define FUNC_NAME s_scm_array_dimensions
  139. {
  140. scm_t_array_handle handle;
  141. scm_t_array_dim *s;
  142. SCM res = SCM_EOL;
  143. size_t k;
  144. scm_array_get_handle (ra, &handle);
  145. s = scm_array_handle_dims (&handle);
  146. k = scm_array_handle_rank (&handle);
  147. while (k--)
  148. res = scm_cons (s[k].lbnd
  149. ? scm_cons2 (scm_from_ssize_t (s[k].lbnd),
  150. scm_from_ssize_t (s[k].ubnd),
  151. SCM_EOL)
  152. : scm_from_ssize_t (1 + s[k].ubnd),
  153. res);
  154. scm_array_handle_release (&handle);
  155. return res;
  156. }
  157. #undef FUNC_NAME
  158. SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
  159. (SCM ra),
  160. "")
  161. #define FUNC_NAME s_scm_array_type
  162. {
  163. scm_t_array_handle h;
  164. SCM type;
  165. scm_array_get_handle (ra, &h);
  166. type = scm_array_handle_element_type (&h);
  167. scm_array_handle_release (&h);
  168. return type;
  169. }
  170. #undef FUNC_NAME
  171. SCM_DEFINE (scm_array_type_code,
  172. "array-type-code", 1, 0, 0,
  173. (SCM array),
  174. "Return the type of the elements in @var{array},\n"
  175. "as an integer code.")
  176. #define FUNC_NAME s_scm_array_type_code
  177. {
  178. scm_t_array_handle h;
  179. scm_t_array_element_type element_type;
  180. scm_array_get_handle (array, &h);
  181. element_type = h.element_type;
  182. scm_array_handle_release (&h);
  183. return scm_from_uint16 (element_type);
  184. }
  185. #undef FUNC_NAME
  186. SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
  187. (SCM ra, SCM args),
  188. "Return @code{#t} if its arguments would be acceptable to\n"
  189. "@code{array-ref}.")
  190. #define FUNC_NAME s_scm_array_in_bounds_p
  191. {
  192. SCM res = SCM_BOOL_T;
  193. size_t k, ndim;
  194. scm_t_array_dim *s;
  195. scm_t_array_handle handle;
  196. SCM_VALIDATE_REST_ARGUMENT (args);
  197. scm_array_get_handle (ra, &handle);
  198. s = scm_array_handle_dims (&handle);
  199. ndim = scm_array_handle_rank (&handle);
  200. for (k = 0; k < ndim; k++)
  201. {
  202. long ind;
  203. if (!scm_is_pair (args))
  204. SCM_WRONG_NUM_ARGS ();
  205. ind = scm_to_long (SCM_CAR (args));
  206. args = SCM_CDR (args);
  207. if (ind < s[k].lbnd || ind > s[k].ubnd)
  208. {
  209. res = SCM_BOOL_F;
  210. /* We do not stop the checking after finding a violation
  211. since we want to validate the type-correctness and
  212. number of arguments in any case.
  213. */
  214. }
  215. }
  216. scm_array_handle_release (&handle);
  217. return res;
  218. }
  219. #undef FUNC_NAME
  220. SCM
  221. scm_c_array_ref_1 (SCM array, ssize_t idx0)
  222. {
  223. scm_t_array_handle handle;
  224. SCM res;
  225. scm_array_get_handle (array, &handle);
  226. res = scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, idx0));
  227. scm_array_handle_release (&handle);
  228. return res;
  229. }
  230. SCM
  231. scm_c_array_ref_2 (SCM array, ssize_t idx0, ssize_t idx1)
  232. {
  233. scm_t_array_handle handle;
  234. SCM res;
  235. scm_array_get_handle (array, &handle);
  236. res = scm_array_handle_ref (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1));
  237. scm_array_handle_release (&handle);
  238. return res;
  239. }
  240. SCM
  241. scm_array_ref (SCM v, SCM args)
  242. {
  243. scm_t_array_handle handle;
  244. SCM res;
  245. scm_array_get_handle (v, &handle);
  246. res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args));
  247. scm_array_handle_release (&handle);
  248. return res;
  249. }
  250. void
  251. scm_c_array_set_1_x (SCM array, SCM obj, ssize_t idx0)
  252. {
  253. scm_t_array_handle handle;
  254. scm_array_get_handle (array, &handle);
  255. scm_array_handle_set (&handle, scm_array_handle_pos_1 (&handle, idx0),
  256. obj);
  257. scm_array_handle_release (&handle);
  258. }
  259. void
  260. scm_c_array_set_2_x (SCM array, SCM obj, ssize_t idx0, ssize_t idx1)
  261. {
  262. scm_t_array_handle handle;
  263. scm_array_get_handle (array, &handle);
  264. scm_array_handle_set (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1),
  265. obj);
  266. scm_array_handle_release (&handle);
  267. }
  268. SCM
  269. scm_array_set_x (SCM v, SCM obj, SCM args)
  270. {
  271. scm_t_array_handle handle;
  272. scm_array_get_handle (v, &handle);
  273. scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj);
  274. scm_array_handle_release (&handle);
  275. return SCM_UNSPECIFIED;
  276. }
  277. SCM_DEFINE (scm_i_array_ref, "array-ref", 1, 2, 1,
  278. (SCM v, SCM idx0, SCM idx1, SCM idxN),
  279. "Return the element at the @code{(idx0, idx1, idxN...)}\n"
  280. "position in array @var{v}.")
  281. #define FUNC_NAME s_scm_i_array_ref
  282. {
  283. if (SCM_UNBNDP (idx0))
  284. return scm_array_ref (v, SCM_EOL);
  285. else if (SCM_UNBNDP (idx1))
  286. return scm_c_array_ref_1 (v, scm_to_ssize_t (idx0));
  287. else if (scm_is_null (idxN))
  288. return scm_c_array_ref_2 (v, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1));
  289. else
  290. return scm_array_ref (v, scm_cons (idx0, scm_cons (idx1, idxN)));
  291. }
  292. #undef FUNC_NAME
  293. SCM_DEFINE (scm_i_array_set_x, "array-set!", 2, 2, 1,
  294. (SCM v, SCM obj, SCM idx0, SCM idx1, SCM idxN),
  295. "Set the element at the @code{(idx0, idx1, idxN...)} position\n"
  296. "in the array @var{v} to @var{obj}. The value returned by\n"
  297. "@code{array-set!} is unspecified.")
  298. #define FUNC_NAME s_scm_i_array_set_x
  299. {
  300. if (SCM_UNBNDP (idx0))
  301. scm_array_set_x (v, obj, SCM_EOL);
  302. else if (SCM_UNBNDP (idx1))
  303. scm_c_array_set_1_x (v, obj, scm_to_ssize_t (idx0));
  304. else if (scm_is_null (idxN))
  305. scm_c_array_set_2_x (v, obj, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1));
  306. else
  307. scm_array_set_x (v, obj, scm_cons (idx0, scm_cons (idx1, idxN)));
  308. return SCM_UNSPECIFIED;
  309. }
  310. #undef FUNC_NAME
  311. static SCM
  312. array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos)
  313. {
  314. if (dim == scm_array_handle_rank (h))
  315. return scm_array_handle_ref (h, pos);
  316. else
  317. {
  318. SCM res = SCM_EOL;
  319. long inc;
  320. size_t i;
  321. i = h->dims[dim].ubnd - h->dims[dim].lbnd + 1;
  322. inc = h->dims[dim].inc;
  323. pos += (i - 1) * inc;
  324. for (; i > 0; i--, pos -= inc)
  325. res = scm_cons (array_to_list (h, dim + 1, pos), res);
  326. return res;
  327. }
  328. }
  329. SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
  330. (SCM array),
  331. "Return a list representation of @var{array}.\n\n"
  332. "It is easiest to specify the behavior of this function by\n"
  333. "example:\n"
  334. "@example\n"
  335. "(array->list #0(a)) @result{} 1\n"
  336. "(array->list #1(a b)) @result{} (a b)\n"
  337. "(array->list #2((aa ab) (ba bb)) @result{} ((aa ab) (ba bb))\n"
  338. "@end example\n")
  339. #define FUNC_NAME s_scm_array_to_list
  340. {
  341. scm_t_array_handle h;
  342. SCM res;
  343. scm_array_get_handle (array, &h);
  344. res = array_to_list (&h, 0, 0);
  345. scm_array_handle_release (&h);
  346. return res;
  347. }
  348. #undef FUNC_NAME
  349. size_t
  350. scm_c_array_rank (SCM array)
  351. {
  352. if (SCM_I_ARRAYP (array))
  353. return SCM_I_ARRAY_NDIM (array);
  354. else if (scm_is_array (array))
  355. return 1;
  356. else
  357. scm_wrong_type_arg_msg ("array-rank", SCM_ARG1, array, "array");
  358. }
  359. SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
  360. (SCM array),
  361. "Return the number of dimensions of the array @var{array.}\n")
  362. #define FUNC_NAME s_scm_array_rank
  363. {
  364. return scm_from_size_t (scm_c_array_rank (array));
  365. }
  366. #undef FUNC_NAME
  367. SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
  368. (SCM ra),
  369. "Return the root vector of a shared array.")
  370. #define FUNC_NAME s_scm_shared_array_root
  371. {
  372. if (SCM_I_ARRAYP (ra))
  373. return SCM_I_ARRAY_V (ra);
  374. else if (scm_is_array (ra))
  375. return ra;
  376. else
  377. scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
  378. }
  379. #undef FUNC_NAME
  380. SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
  381. (SCM ra),
  382. "Return the root vector index of the first element in the array.")
  383. #define FUNC_NAME s_scm_shared_array_offset
  384. {
  385. if (SCM_I_ARRAYP (ra))
  386. return scm_from_size_t (SCM_I_ARRAY_BASE (ra));
  387. else if (scm_is_array (ra))
  388. return scm_from_size_t (0);
  389. else
  390. scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
  391. }
  392. #undef FUNC_NAME
  393. SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
  394. (SCM ra),
  395. "For each dimension, return the distance between elements in the root vector.")
  396. #define FUNC_NAME s_scm_shared_array_increments
  397. {
  398. if (SCM_I_ARRAYP (ra))
  399. {
  400. size_t k = SCM_I_ARRAY_NDIM (ra);
  401. SCM res = SCM_EOL;
  402. scm_t_array_dim *dims = SCM_I_ARRAY_DIMS (ra);
  403. while (k--)
  404. res = scm_cons (scm_from_ssize_t (dims[k].inc), res);
  405. return res;
  406. }
  407. else if (scm_is_array (ra))
  408. return scm_list_1 (scm_from_ssize_t (1));
  409. else
  410. scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
  411. }
  412. #undef FUNC_NAME
  413. SCM
  414. scm_i_make_array (int ndim)
  415. {
  416. SCM ra = scm_i_raw_array (ndim);
  417. SCM_I_ARRAY_SET_V (ra, SCM_BOOL_F);
  418. SCM_I_ARRAY_SET_BASE (ra, 0);
  419. /* dimensions are unset */
  420. return ra;
  421. }
  422. static char s_bad_spec[] = "Bad scm_array dimension";
  423. /* Increments will still need to be set. */
  424. SCM
  425. scm_i_shap2ra (SCM args)
  426. {
  427. scm_t_array_dim *s;
  428. SCM ra, spec;
  429. int ndim = scm_ilength (args);
  430. if (ndim < 0)
  431. scm_misc_error (NULL, s_bad_spec, SCM_EOL);
  432. ra = scm_i_make_array (ndim);
  433. SCM_I_ARRAY_SET_BASE (ra, 0);
  434. s = SCM_I_ARRAY_DIMS (ra);
  435. for (; !scm_is_null (args); s++, args = SCM_CDR (args))
  436. {
  437. spec = SCM_CAR (args);
  438. if (scm_is_integer (spec))
  439. {
  440. s->lbnd = 0;
  441. s->ubnd = scm_to_ssize_t (spec);
  442. if (s->ubnd < 0)
  443. scm_misc_error (NULL, s_bad_spec, SCM_EOL);
  444. --s->ubnd;
  445. }
  446. else
  447. {
  448. if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec)))
  449. scm_misc_error (NULL, s_bad_spec, SCM_EOL);
  450. s->lbnd = scm_to_ssize_t (SCM_CAR (spec));
  451. spec = SCM_CDR (spec);
  452. if (!scm_is_pair (spec)
  453. || !scm_is_integer (SCM_CAR (spec))
  454. || !scm_is_null (SCM_CDR (spec)))
  455. scm_misc_error (NULL, s_bad_spec, SCM_EOL);
  456. s->ubnd = scm_to_ssize_t (SCM_CAR (spec));
  457. if (s->ubnd - s->lbnd < -1)
  458. scm_misc_error (NULL, s_bad_spec, SCM_EOL);
  459. }
  460. s->inc = 1;
  461. }
  462. return ra;
  463. }
  464. SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
  465. (SCM type, SCM fill, SCM bounds),
  466. "Create and return an array of type @var{type}.")
  467. #define FUNC_NAME s_scm_make_typed_array
  468. {
  469. size_t k, rlen = 1;
  470. scm_t_array_dim *s;
  471. SCM ra;
  472. ra = scm_i_shap2ra (bounds);
  473. s = SCM_I_ARRAY_DIMS (ra);
  474. k = SCM_I_ARRAY_NDIM (ra);
  475. while (k--)
  476. {
  477. s[k].inc = rlen;
  478. SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
  479. rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
  480. }
  481. if (scm_is_eq (fill, SCM_UNSPECIFIED))
  482. fill = SCM_UNDEFINED;
  483. SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (type, scm_from_size_t (rlen), fill));
  484. if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
  485. if (0 == s->lbnd)
  486. return SCM_I_ARRAY_V (ra);
  487. return ra;
  488. }
  489. #undef FUNC_NAME
  490. SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
  491. (SCM fill, SCM bounds),
  492. "Create and return an array.")
  493. #define FUNC_NAME s_scm_make_array
  494. {
  495. return scm_make_typed_array (SCM_BOOL_T, fill, bounds);
  496. }
  497. #undef FUNC_NAME
  498. SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
  499. (SCM oldra, SCM mapfunc, SCM dims),
  500. "@code{make-shared-array} can be used to create shared subarrays\n"
  501. "of other arrays. The @var{mapfunc} is a function that\n"
  502. "translates coordinates in the new array into coordinates in the\n"
  503. "old array. A @var{mapfunc} must be linear, and its range must\n"
  504. "stay within the bounds of the old array, but it can be\n"
  505. "otherwise arbitrary. A simple example:\n"
  506. "@lisp\n"
  507. "(define fred (make-array #f 8 8))\n"
  508. "(define freds-diagonal\n"
  509. " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
  510. "(array-set! freds-diagonal 'foo 3)\n"
  511. "(array-ref fred 3 3) @result{} foo\n"
  512. "(define freds-center\n"
  513. " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
  514. "(array-ref freds-center 0 0) @result{} foo\n"
  515. "@end lisp")
  516. #define FUNC_NAME s_scm_make_shared_array
  517. {
  518. scm_t_array_handle old_handle;
  519. SCM ra;
  520. SCM inds, indptr;
  521. SCM imap;
  522. size_t k;
  523. ssize_t i;
  524. long old_base, old_min, new_min, old_max, new_max;
  525. scm_t_array_dim *s;
  526. SCM_VALIDATE_REST_ARGUMENT (dims);
  527. SCM_VALIDATE_PROC (2, mapfunc);
  528. ra = scm_i_shap2ra (dims);
  529. scm_array_get_handle (oldra, &old_handle);
  530. if (SCM_I_ARRAYP (oldra))
  531. {
  532. SCM_I_ARRAY_SET_V (ra, SCM_I_ARRAY_V (oldra));
  533. old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra);
  534. s = scm_array_handle_dims (&old_handle);
  535. k = scm_array_handle_rank (&old_handle);
  536. while (k--)
  537. {
  538. if (s[k].inc > 0)
  539. old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
  540. else
  541. old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
  542. }
  543. }
  544. else
  545. {
  546. SCM_I_ARRAY_SET_V (ra, oldra);
  547. old_base = old_min = 0;
  548. old_max = scm_c_array_length (oldra) - 1;
  549. }
  550. inds = SCM_EOL;
  551. s = SCM_I_ARRAY_DIMS (ra);
  552. for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
  553. {
  554. inds = scm_cons (scm_from_ssize_t (s[k].lbnd), inds);
  555. if (s[k].ubnd < s[k].lbnd)
  556. {
  557. if (1 == SCM_I_ARRAY_NDIM (ra))
  558. ra = scm_make_generalized_vector (scm_array_type (ra),
  559. SCM_INUM0, SCM_UNDEFINED);
  560. else
  561. SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (scm_array_type (ra),
  562. SCM_INUM0, SCM_UNDEFINED));
  563. scm_array_handle_release (&old_handle);
  564. return ra;
  565. }
  566. }
  567. imap = scm_apply_0 (mapfunc, scm_reverse (inds));
  568. i = scm_array_handle_pos (&old_handle, imap);
  569. new_min = new_max = i + old_base;
  570. SCM_I_ARRAY_SET_BASE (ra, new_min);
  571. indptr = inds;
  572. k = SCM_I_ARRAY_NDIM (ra);
  573. while (k--)
  574. {
  575. if (s[k].ubnd > s[k].lbnd)
  576. {
  577. SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1)));
  578. imap = scm_apply_0 (mapfunc, scm_reverse (inds));
  579. s[k].inc = scm_array_handle_pos (&old_handle, imap) - i;
  580. i += s[k].inc;
  581. if (s[k].inc > 0)
  582. new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
  583. else
  584. new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
  585. }
  586. else
  587. s[k].inc = new_max - new_min + 1; /* contiguous by default */
  588. indptr = SCM_CDR (indptr);
  589. }
  590. scm_array_handle_release (&old_handle);
  591. if (old_min > new_min || old_max < new_max)
  592. SCM_MISC_ERROR ("mapping out of range", SCM_EOL);
  593. if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
  594. {
  595. SCM v = SCM_I_ARRAY_V (ra);
  596. size_t length = scm_c_array_length (v);
  597. if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
  598. return v;
  599. if (s->ubnd < s->lbnd)
  600. return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0,
  601. SCM_UNDEFINED);
  602. }
  603. return ra;
  604. }
  605. #undef FUNC_NAME
  606. static void
  607. array_from_pos (scm_t_array_handle *handle, size_t *ndim, size_t *k, SCM *i, ssize_t *pos,
  608. scm_t_array_dim **s, char const * FUNC_NAME, SCM error_args)
  609. {
  610. *s = scm_array_handle_dims (handle);
  611. *k = *ndim = scm_array_handle_rank (handle);
  612. for (; *k>0 && scm_is_pair (*i); --*k, ++*s, *i=scm_cdr (*i))
  613. {
  614. ssize_t ik = scm_to_ssize_t (scm_car (*i));
  615. if (ik<(*s)->lbnd || ik>(*s)->ubnd)
  616. {
  617. scm_array_handle_release (handle);
  618. scm_misc_error (FUNC_NAME, "indices out of range", error_args);
  619. }
  620. *pos += (ik-(*s)->lbnd) * (*s)->inc;
  621. }
  622. }
  623. static void
  624. array_from_get_o (scm_t_array_handle *handle, size_t k, scm_t_array_dim *s, ssize_t pos,
  625. SCM *o)
  626. {
  627. scm_t_array_dim * os;
  628. *o = scm_i_make_array (k);
  629. SCM_I_ARRAY_SET_V (*o, handle->vector);
  630. SCM_I_ARRAY_SET_BASE (*o, pos + handle->base);
  631. os = SCM_I_ARRAY_DIMS (*o);
  632. for (; k>0; --k, ++s, ++os)
  633. {
  634. os->ubnd = s->ubnd;
  635. os->lbnd = s->lbnd;
  636. os->inc = s->inc;
  637. }
  638. }
  639. SCM_DEFINE (scm_array_slice, "array-slice", 1, 0, 1,
  640. (SCM ra, SCM indices),
  641. "Return the array slice @var{ra}[@var{indices} ..., ...]\n"
  642. "The rank of @var{ra} must equal to the number of indices or larger.\n\n"
  643. "See also @code{array-ref}, @code{array-cell-ref}, @code{array-cell-set!}.\n\n"
  644. "@code{array-slice} may return a rank-0 array. For example:\n"
  645. "@lisp\n"
  646. "(array-slice #2((1 2 3) (4 5 6)) 1 1) @result{} #0(5)\n"
  647. "(array-slice #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n"
  648. "(array-slice #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n"
  649. "(array-slice #0(5) @result{} #0(5).\n"
  650. "@end lisp")
  651. #define FUNC_NAME s_scm_array_slice
  652. {
  653. SCM o, i = indices;
  654. size_t ndim, k;
  655. ssize_t pos = 0;
  656. scm_t_array_handle handle;
  657. scm_t_array_dim *s;
  658. scm_array_get_handle (ra, &handle);
  659. array_from_pos (&handle, &ndim, &k, &i, &pos, &s, FUNC_NAME, scm_list_2 (ra, indices));
  660. if (k==ndim)
  661. o = ra;
  662. else if (scm_is_null (i))
  663. {
  664. array_from_get_o(&handle, k, s, pos, &o);
  665. }
  666. else
  667. {
  668. scm_array_handle_release (&handle);
  669. scm_misc_error(FUNC_NAME, "too many indices", scm_list_2 (ra, indices));
  670. }
  671. scm_array_handle_release (&handle);
  672. return o;
  673. }
  674. #undef FUNC_NAME
  675. SCM_DEFINE (scm_array_cell_ref, "array-cell-ref", 1, 0, 1,
  676. (SCM ra, SCM indices),
  677. "Return the element at the @code{(@var{indices} ...)} position\n"
  678. "in array @var{ra}, or the array slice @var{ra}[@var{indices} ..., ...]\n"
  679. "if the rank of @var{ra} is larger than the number of indices.\n\n"
  680. "See also @code{array-ref}, @code{array-slice}, @code{array-cell-set!}.\n\n"
  681. "@code{array-cell-ref} never returns a rank 0 array. For example:\n"
  682. "@lisp\n"
  683. "(array-cell-ref #2((1 2 3) (4 5 6)) 1 1) @result{} 5\n"
  684. "(array-cell-ref #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n"
  685. "(array-cell-ref #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n"
  686. "(array-cell-ref #0(5) @result{} 5.\n"
  687. "@end lisp")
  688. #define FUNC_NAME s_scm_array_cell_ref
  689. {
  690. SCM o, i = indices;
  691. size_t ndim, k;
  692. ssize_t pos = 0;
  693. scm_t_array_handle handle;
  694. scm_t_array_dim *s;
  695. scm_array_get_handle (ra, &handle);
  696. array_from_pos (&handle, &ndim, &k, &i, &pos, &s, FUNC_NAME, scm_list_2 (ra, indices));
  697. if (k>0)
  698. {
  699. if (k==ndim)
  700. o = ra;
  701. else
  702. array_from_get_o(&handle, k, s, pos, &o);
  703. }
  704. else if (scm_is_null(i))
  705. o = scm_array_handle_ref (&handle, pos);
  706. else
  707. {
  708. scm_array_handle_release (&handle);
  709. scm_misc_error(FUNC_NAME, "too many indices", scm_list_2 (ra, indices));
  710. }
  711. scm_array_handle_release (&handle);
  712. return o;
  713. }
  714. #undef FUNC_NAME
  715. SCM_DEFINE (scm_array_cell_set_x, "array-cell-set!", 2, 0, 1,
  716. (SCM ra, SCM b, SCM indices),
  717. "Set the array slice @var{ra}[@var{indices} ..., ...] to @var{b}\n."
  718. "Equivalent to @code{(array-copy! @var{b} (apply array-cell-ref @var{ra} @var{indices}))}\n"
  719. "if the number of indices is smaller than the rank of @var{ra}; otherwise\n"
  720. "equivalent to @code{(apply array-set! @var{ra} @var{b} @var{indices})}.\n"
  721. "This function returns the modified array @var{ra}.\n\n"
  722. "See also @code{array-ref}, @code{array-cell-ref}, @code{array-slice}.\n\n"
  723. "For example:\n"
  724. "@lisp\n"
  725. "(define A (list->array 2 '((1 2 3) (4 5 6))))\n"
  726. "(array-cell-set! A #0(99) 1 1) @result{} #2((1 2 3) (4 #0(99) 6))\n"
  727. "(array-cell-set! A 99 1 1) @result{} #2((1 2 3) (4 99 6))\n"
  728. "(array-cell-set! A #(a b c) 0) @result{} #2((a b c) (4 99 6))\n"
  729. "(array-cell-set! A #2((x y z) (9 8 7))) @result{} #2((x y z) (9 8 7))\n\n"
  730. "(define B (make-array 0))\n"
  731. "(array-cell-set! B 15) @result{} #0(15)\n"
  732. "@end lisp")
  733. #define FUNC_NAME s_scm_array_cell_set_x
  734. {
  735. SCM o, i = indices;
  736. size_t ndim, k;
  737. ssize_t pos = 0;
  738. scm_t_array_handle handle;
  739. scm_t_array_dim *s;
  740. scm_array_get_handle (ra, &handle);
  741. array_from_pos (&handle, &ndim, &k, &i, &pos, &s, FUNC_NAME, scm_list_3 (ra, b, indices));
  742. if (k>0)
  743. {
  744. if (k==ndim)
  745. o = ra;
  746. else
  747. array_from_get_o(&handle, k, s, pos, &o);
  748. scm_array_handle_release(&handle);
  749. /* an error is still possible here if o and b don't match. */
  750. /* FIXME copying like this wastes the handle, and the bounds matching
  751. behavior of array-copy! is not strict. */
  752. scm_array_copy_x(b, o);
  753. }
  754. else if (scm_is_null(i))
  755. {
  756. scm_array_handle_set (&handle, pos, b); /* ra may be non-ARRAYP */
  757. scm_array_handle_release (&handle);
  758. }
  759. else
  760. {
  761. scm_array_handle_release (&handle);
  762. scm_misc_error(FUNC_NAME, "too many indices", scm_list_3 (ra, b, indices));
  763. }
  764. return ra;
  765. }
  766. #undef FUNC_NAME
  767. #undef ARRAY_FROM_GET_O
  768. /* args are RA . DIMS */
  769. SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
  770. (SCM ra, SCM args),
  771. "Return an array sharing contents with @var{ra}, but with\n"
  772. "dimensions arranged in a different order. There must be one\n"
  773. "@var{dim} argument for each dimension of @var{ra}.\n"
  774. "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
  775. "and the rank of the array to be returned. Each integer in that\n"
  776. "range must appear at least once in the argument list.\n"
  777. "\n"
  778. "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
  779. "dimensions in the array to be returned, their positions in the\n"
  780. "argument list to dimensions of @var{ra}. Several @var{dim}s\n"
  781. "may have the same value, in which case the returned array will\n"
  782. "have smaller rank than @var{ra}.\n"
  783. "\n"
  784. "@lisp\n"
  785. "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
  786. "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
  787. "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
  788. " #2((a 4) (b 5) (c 6))\n"
  789. "@end lisp")
  790. #define FUNC_NAME s_scm_transpose_array
  791. {
  792. SCM res, vargs;
  793. scm_t_array_dim *s, *r;
  794. int ndim, i, k;
  795. SCM_VALIDATE_REST_ARGUMENT (args);
  796. SCM_ASSERT (SCM_HEAP_OBJECT_P (ra), ra, SCM_ARG1, FUNC_NAME);
  797. switch (scm_c_array_rank (ra))
  798. {
  799. case 0:
  800. if (!scm_is_null (args))
  801. SCM_WRONG_NUM_ARGS ();
  802. return ra;
  803. case 1:
  804. /* Make sure that we are called with a single zero as
  805. arguments.
  806. */
  807. if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
  808. SCM_WRONG_NUM_ARGS ();
  809. SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
  810. SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
  811. return ra;
  812. default:
  813. vargs = scm_vector (args);
  814. if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
  815. SCM_WRONG_NUM_ARGS ();
  816. ndim = 0;
  817. for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
  818. {
  819. i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k),
  820. 0, SCM_I_ARRAY_NDIM(ra));
  821. if (ndim < i)
  822. ndim = i;
  823. }
  824. ndim++;
  825. res = scm_i_make_array (ndim);
  826. SCM_I_ARRAY_SET_V (res, SCM_I_ARRAY_V (ra));
  827. SCM_I_ARRAY_SET_BASE (res, SCM_I_ARRAY_BASE (ra));
  828. for (k = ndim; k--;)
  829. {
  830. SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
  831. SCM_I_ARRAY_DIMS (res)[k].ubnd = -1;
  832. }
  833. for (k = SCM_I_ARRAY_NDIM (ra); k--;)
  834. {
  835. i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k));
  836. s = &(SCM_I_ARRAY_DIMS (ra)[k]);
  837. r = &(SCM_I_ARRAY_DIMS (res)[i]);
  838. if (r->ubnd < r->lbnd)
  839. {
  840. r->lbnd = s->lbnd;
  841. r->ubnd = s->ubnd;
  842. r->inc = s->inc;
  843. ndim--;
  844. }
  845. else
  846. {
  847. if (r->ubnd > s->ubnd)
  848. r->ubnd = s->ubnd;
  849. if (r->lbnd < s->lbnd)
  850. {
  851. SCM_I_ARRAY_SET_BASE (res, SCM_I_ARRAY_BASE (res) + (s->lbnd - r->lbnd) * r->inc);
  852. r->lbnd = s->lbnd;
  853. }
  854. r->inc += s->inc;
  855. }
  856. }
  857. if (ndim > 0)
  858. SCM_MISC_ERROR ("bad argument list", SCM_EOL);
  859. return res;
  860. }
  861. }
  862. #undef FUNC_NAME
  863. /* attempts to unroll an array into a one-dimensional array.
  864. returns the unrolled array or #f if it can't be done. */
  865. /* if strict is true, return #f if returned array
  866. wouldn't have contiguous elements. */
  867. SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
  868. (SCM ra, SCM strict),
  869. "If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n"
  870. "array without changing their order (last subscript changing\n"
  871. "fastest), then @code{array-contents} returns that shared array,\n"
  872. "otherwise it returns @code{#f}. All arrays made by\n"
  873. "@code{make-array} and @code{make-uniform-array} may be unrolled,\n"
  874. "some arrays made by @code{make-shared-array} may not be. If\n"
  875. "the optional argument @var{strict} is provided, a shared array\n"
  876. "will be returned only if its elements are stored contiguously\n"
  877. "in memory.")
  878. #define FUNC_NAME s_scm_array_contents
  879. {
  880. if (SCM_I_ARRAYP (ra))
  881. {
  882. SCM v;
  883. size_t ndim = SCM_I_ARRAY_NDIM (ra);
  884. scm_t_array_dim *s = SCM_I_ARRAY_DIMS (ra);
  885. size_t k = ndim;
  886. size_t len = 1;
  887. if (k)
  888. {
  889. ssize_t last_inc = s[k - 1].inc;
  890. while (k--)
  891. {
  892. if (len*last_inc != s[k].inc)
  893. return SCM_BOOL_F;
  894. len *= (s[k].ubnd - s[k].lbnd + 1);
  895. }
  896. }
  897. if (!SCM_UNBNDP (strict) && scm_is_true (strict))
  898. {
  899. if (ndim && (1 != s[ndim - 1].inc))
  900. return SCM_BOOL_F;
  901. if (scm_is_bitvector (SCM_I_ARRAY_V (ra))
  902. && (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
  903. SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
  904. len % SCM_LONG_BIT))
  905. return SCM_BOOL_F;
  906. }
  907. v = SCM_I_ARRAY_V (ra);
  908. if ((len == scm_c_array_length (v)) && (0 == SCM_I_ARRAY_BASE (ra)))
  909. return v;
  910. else
  911. {
  912. SCM sra = scm_i_make_array (1);
  913. SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
  914. SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
  915. SCM_I_ARRAY_SET_V (sra, v);
  916. SCM_I_ARRAY_SET_BASE (sra, SCM_I_ARRAY_BASE (ra));
  917. SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
  918. return sra;
  919. }
  920. }
  921. else if (scm_is_array (ra))
  922. return ra;
  923. else
  924. scm_wrong_type_arg_msg (NULL, 0, ra, "array");
  925. }
  926. #undef FUNC_NAME
  927. static void
  928. list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
  929. {
  930. if (k == scm_array_handle_rank (handle))
  931. scm_array_handle_set (handle, pos, lst);
  932. else
  933. {
  934. scm_t_array_dim *dim = scm_array_handle_dims (handle) + k;
  935. ssize_t inc = dim->inc;
  936. size_t len = 1 + dim->ubnd - dim->lbnd, n;
  937. char *errmsg = NULL;
  938. n = len;
  939. while (n > 0 && scm_is_pair (lst))
  940. {
  941. list_to_array (SCM_CAR (lst), handle, pos, k + 1);
  942. pos += inc;
  943. lst = SCM_CDR (lst);
  944. n -= 1;
  945. }
  946. if (n != 0)
  947. errmsg = "too few elements for array dimension ~a, need ~a";
  948. if (!scm_is_null (lst))
  949. errmsg = "too many elements for array dimension ~a, want ~a";
  950. if (errmsg)
  951. scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_size_t (k),
  952. scm_from_size_t (len)));
  953. }
  954. }
  955. SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
  956. (SCM type, SCM shape, SCM lst),
  957. "Return an array of the type @var{type}\n"
  958. "with elements the same as those of @var{lst}.\n"
  959. "\n"
  960. "The argument @var{shape} determines the number of dimensions\n"
  961. "of the array and their shape. It is either an exact integer,\n"
  962. "giving the\n"
  963. "number of dimensions directly, or a list whose length\n"
  964. "specifies the number of dimensions and each element specified\n"
  965. "the lower and optionally the upper bound of the corresponding\n"
  966. "dimension.\n"
  967. "When the element is list of two elements, these elements\n"
  968. "give the lower and upper bounds. When it is an exact\n"
  969. "integer, it gives only the lower bound.")
  970. #define FUNC_NAME s_scm_list_to_typed_array
  971. {
  972. SCM row;
  973. SCM ra;
  974. scm_t_array_handle handle;
  975. row = lst;
  976. if (scm_is_integer (shape))
  977. {
  978. size_t k = scm_to_size_t (shape);
  979. shape = SCM_EOL;
  980. while (k-- > 0)
  981. {
  982. shape = scm_cons (scm_length (row), shape);
  983. if (k > 0 && !scm_is_null (row))
  984. row = scm_car (row);
  985. }
  986. }
  987. else
  988. {
  989. SCM shape_spec = shape;
  990. shape = SCM_EOL;
  991. while (1)
  992. {
  993. SCM spec = scm_car (shape_spec);
  994. if (scm_is_pair (spec))
  995. shape = scm_cons (spec, shape);
  996. else
  997. shape = scm_cons (scm_list_2 (spec,
  998. scm_sum (scm_sum (spec,
  999. scm_length (row)),
  1000. scm_from_int (-1))),
  1001. shape);
  1002. shape_spec = scm_cdr (shape_spec);
  1003. if (scm_is_pair (shape_spec))
  1004. {
  1005. if (!scm_is_null (row))
  1006. row = scm_car (row);
  1007. }
  1008. else
  1009. break;
  1010. }
  1011. }
  1012. ra = scm_make_typed_array (type, SCM_UNSPECIFIED,
  1013. scm_reverse_x (shape, SCM_EOL));
  1014. scm_array_get_handle (ra, &handle);
  1015. list_to_array (lst, &handle, 0, 0);
  1016. scm_array_handle_release (&handle);
  1017. return ra;
  1018. }
  1019. #undef FUNC_NAME
  1020. SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0,
  1021. (SCM ndim, SCM lst),
  1022. "Return an array with elements the same as those of @var{lst}.")
  1023. #define FUNC_NAME s_scm_list_to_array
  1024. {
  1025. return scm_list_to_typed_array (SCM_BOOL_T, ndim, lst);
  1026. }
  1027. #undef FUNC_NAME
  1028. /* Print dimension DIM of ARRAY.
  1029. */
  1030. static int
  1031. scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos,
  1032. SCM port, scm_print_state *pstate)
  1033. {
  1034. if (dim == h->ndims)
  1035. scm_iprin1 (scm_array_handle_ref (h, pos), port, pstate);
  1036. else
  1037. {
  1038. ssize_t i;
  1039. scm_putc ('(', port);
  1040. for (i = h->dims[dim].lbnd; i <= h->dims[dim].ubnd;
  1041. i++, pos += h->dims[dim].inc)
  1042. {
  1043. scm_i_print_array_dimension (h, dim+1, pos, port, pstate);
  1044. if (i < h->dims[dim].ubnd)
  1045. scm_putc (' ', port);
  1046. }
  1047. scm_putc (')', port);
  1048. }
  1049. return 1;
  1050. }
  1051. int
  1052. scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
  1053. {
  1054. scm_t_array_handle h;
  1055. int d;
  1056. scm_call_2 (scm_c_private_ref ("ice-9 arrays", "array-print-prefix"),
  1057. array, port);
  1058. scm_array_get_handle (array, &h);
  1059. if (h.ndims == 0)
  1060. {
  1061. /* Rank zero arrays, which are really just scalars, are printed
  1062. specially. The consequent way would be to print them as
  1063. #0 OBJ
  1064. where OBJ is the printed representation of the scalar, but we
  1065. print them instead as
  1066. #0(OBJ)
  1067. to make them look less strange.
  1068. Just printing them as
  1069. OBJ
  1070. would be correct in a way as well, but zero rank arrays are
  1071. not really the same as Scheme values since they are boxed and
  1072. can be modified with array-set!, say.
  1073. */
  1074. scm_putc ('(', port);
  1075. scm_i_print_array_dimension (&h, 0, 0, port, pstate);
  1076. scm_putc (')', port);
  1077. d = 1;
  1078. }
  1079. else
  1080. d = scm_i_print_array_dimension (&h, 0, 0, port, pstate);
  1081. scm_array_handle_release (&h);
  1082. return d;
  1083. }
  1084. void
  1085. scm_init_arrays ()
  1086. {
  1087. scm_add_feature ("array");
  1088. #include "arrays.x"
  1089. }