| 1 | /* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009, |
| 2 | * 2010, 2011, 2012, 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 | |
| 20 | |
| 21 | \f |
| 22 | |
| 23 | |
| 24 | \f |
| 25 | #ifdef HAVE_CONFIG_H |
| 26 | # include <config.h> |
| 27 | #endif |
| 28 | |
| 29 | #include "libguile/_scm.h" |
| 30 | #include "libguile/strings.h" |
| 31 | #include "libguile/arrays.h" |
| 32 | #include "libguile/smob.h" |
| 33 | #include "libguile/chars.h" |
| 34 | #include "libguile/eq.h" |
| 35 | #include "libguile/eval.h" |
| 36 | #include "libguile/feature.h" |
| 37 | #include "libguile/root.h" |
| 38 | #include "libguile/vectors.h" |
| 39 | #include "libguile/bitvectors.h" |
| 40 | #include "libguile/srfi-4.h" |
| 41 | #include "libguile/generalized-arrays.h" |
| 42 | |
| 43 | #include "libguile/validate.h" |
| 44 | #include "libguile/array-map.h" |
| 45 | \f |
| 46 | |
| 47 | /* The WHAT argument for `scm_gc_malloc ()' et al. */ |
| 48 | static const char vi_gc_hint[] = "array-indices"; |
| 49 | |
| 50 | static SCM |
| 51 | AREF (SCM v, size_t pos) |
| 52 | { |
| 53 | return scm_c_array_ref_1 (v, pos); |
| 54 | } |
| 55 | |
| 56 | static void |
| 57 | ASET (SCM v, size_t pos, SCM val) |
| 58 | { |
| 59 | scm_c_array_set_1_x (v, val, pos); |
| 60 | } |
| 61 | |
| 62 | static SCM |
| 63 | make1array (SCM v, ssize_t inc) |
| 64 | { |
| 65 | SCM a = scm_i_make_array (1); |
| 66 | SCM_I_ARRAY_SET_BASE (a, 0); |
| 67 | SCM_I_ARRAY_DIMS (a)->lbnd = 0; |
| 68 | SCM_I_ARRAY_DIMS (a)->ubnd = scm_c_array_length (v) - 1; |
| 69 | SCM_I_ARRAY_DIMS (a)->inc = inc; |
| 70 | SCM_I_ARRAY_SET_V (a, v); |
| 71 | return a; |
| 72 | } |
| 73 | |
| 74 | /* Linear index of not-unrolled index set. */ |
| 75 | static size_t |
| 76 | cindk (SCM ra, ssize_t *ve, int kend) |
| 77 | { |
| 78 | if (SCM_I_ARRAYP (ra)) |
| 79 | { |
| 80 | int k; |
| 81 | size_t i = SCM_I_ARRAY_BASE (ra); |
| 82 | for (k = 0; k < kend; ++k) |
| 83 | i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS (ra)[k].inc; |
| 84 | return i; |
| 85 | } |
| 86 | else |
| 87 | return 0; /* this is BASE */ |
| 88 | } |
| 89 | |
| 90 | /* array mapper: apply cproc to each dimension of the given arrays?. |
| 91 | int (*cproc) (); procedure to call on unrolled arrays? |
| 92 | cproc (dest, source list) or |
| 93 | cproc (dest, data, source list). |
| 94 | SCM data; data to give to cproc or unbound. |
| 95 | SCM ra0; destination array. |
| 96 | SCM lra; list of source arrays. |
| 97 | const char *what; caller, for error reporting. */ |
| 98 | |
| 99 | #define LBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].lbnd |
| 100 | #define UBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].ubnd |
| 101 | |
| 102 | int |
| 103 | scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what) |
| 104 | { |
| 105 | int (*cproc) () = cproc_ptr; |
| 106 | SCM z, va0, lva, *plva; |
| 107 | int k, kmax, kroll; |
| 108 | ssize_t *vi, inc; |
| 109 | size_t len; |
| 110 | |
| 111 | /* Prepare reference argument. */ |
| 112 | if (SCM_I_ARRAYP (ra0)) |
| 113 | { |
| 114 | kmax = SCM_I_ARRAY_NDIM (ra0)-1; |
| 115 | inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra0)[kmax].inc; |
| 116 | va0 = make1array (SCM_I_ARRAY_V (ra0), inc); |
| 117 | |
| 118 | /* Find unroll depth */ |
| 119 | for (kroll = max(0, kmax); kroll > 0; --kroll) |
| 120 | { |
| 121 | inc *= (UBND (ra0, kroll) - LBND (ra0, kroll) + 1); |
| 122 | if (inc != SCM_I_ARRAY_DIMS (ra0)[kroll-1].inc) |
| 123 | break; |
| 124 | } |
| 125 | } |
| 126 | else |
| 127 | { |
| 128 | kroll = kmax = 0; |
| 129 | va0 = ra0 = make1array (ra0, 1); |
| 130 | } |
| 131 | |
| 132 | /* Prepare rest arguments. */ |
| 133 | lva = SCM_EOL; |
| 134 | plva = &lva; |
| 135 | for (z = lra; !scm_is_null (z); z = SCM_CDR (z)) |
| 136 | { |
| 137 | SCM va1, ra1 = SCM_CAR (z); |
| 138 | if (SCM_I_ARRAYP (ra1)) |
| 139 | { |
| 140 | if (kmax != SCM_I_ARRAY_NDIM (ra1) - 1) |
| 141 | scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0)); |
| 142 | inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra1)[kmax].inc; |
| 143 | va1 = make1array (SCM_I_ARRAY_V (ra1), inc); |
| 144 | |
| 145 | /* Check unroll depth. */ |
| 146 | for (k = kmax; k > kroll; --k) |
| 147 | { |
| 148 | ssize_t l0 = LBND (ra0, k), u0 = UBND (ra0, k); |
| 149 | if (l0 < LBND (ra1, k) || u0 > UBND (ra1, k)) |
| 150 | scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0)); |
| 151 | inc *= (u0 - l0 + 1); |
| 152 | if (inc != SCM_I_ARRAY_DIMS (ra1)[k-1].inc) |
| 153 | { |
| 154 | kroll = k; |
| 155 | break; |
| 156 | } |
| 157 | } |
| 158 | |
| 159 | /* Check matching of not-unrolled axes. */ |
| 160 | for (; k>=0; --k) |
| 161 | if (LBND (ra0, k) < LBND (ra1, k) || UBND (ra0, k) > UBND (ra1, k)) |
| 162 | scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0)); |
| 163 | } |
| 164 | else |
| 165 | { |
| 166 | if (kmax != 0) |
| 167 | scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0)); |
| 168 | va1 = make1array (ra1, 1); |
| 169 | |
| 170 | if (LBND (ra0, 0) < LBND (va1, 0) || UBND (ra0, 0) > UBND (va1, 0)) |
| 171 | scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0)); |
| 172 | } |
| 173 | *plva = scm_cons (va1, SCM_EOL); |
| 174 | plva = SCM_CDRLOC (*plva); |
| 175 | } |
| 176 | |
| 177 | /* Check emptiness of not-unrolled axes. */ |
| 178 | for (k = 0; k < kroll; ++k) |
| 179 | if (0 == (UBND (ra0, k) - LBND (ra0, k) + 1)) |
| 180 | return 1; |
| 181 | |
| 182 | /* Set unrolled size. */ |
| 183 | for (len = 1; k <= kmax; ++k) |
| 184 | len *= (UBND (ra0, k) - LBND (ra0, k) + 1); |
| 185 | UBND (va0, 0) = len - 1; |
| 186 | for (z = lva; !scm_is_null (z); z = SCM_CDR (z)) |
| 187 | UBND (SCM_CAR (z), 0) = len - 1; |
| 188 | |
| 189 | /* Set starting indices and go. */ |
| 190 | vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * kroll, vi_gc_hint); |
| 191 | for (k = 0; k < kroll; ++k) |
| 192 | vi[k] = LBND (ra0, k); |
| 193 | do |
| 194 | { |
| 195 | if (k == kroll) |
| 196 | { |
| 197 | SCM y = lra; |
| 198 | SCM_I_ARRAY_SET_BASE (va0, cindk (ra0, vi, kroll)); |
| 199 | for (z = lva; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y)) |
| 200 | SCM_I_ARRAY_SET_BASE (SCM_CAR (z), cindk (SCM_CAR (y), vi, kroll)); |
| 201 | if (! (SCM_UNBNDP (data) ? cproc (va0, lva) : cproc (va0, data, lva))) |
| 202 | return 0; |
| 203 | --k; |
| 204 | } |
| 205 | else if (vi[k] < UBND (ra0, k)) |
| 206 | { |
| 207 | ++vi[k]; |
| 208 | ++k; |
| 209 | } |
| 210 | else |
| 211 | { |
| 212 | vi[k] = LBND (ra0, k) - 1; |
| 213 | --k; |
| 214 | } |
| 215 | } |
| 216 | while (k >= 0); |
| 217 | |
| 218 | return 1; |
| 219 | } |
| 220 | |
| 221 | #undef UBND |
| 222 | #undef LBND |
| 223 | |
| 224 | static int |
| 225 | rafill (SCM dst, SCM fill) |
| 226 | { |
| 227 | scm_t_array_handle h; |
| 228 | size_t n, i; |
| 229 | ssize_t inc; |
| 230 | scm_array_get_handle (SCM_I_ARRAY_V (dst), &h); |
| 231 | i = SCM_I_ARRAY_BASE (dst); |
| 232 | inc = SCM_I_ARRAY_DIMS (dst)->inc; |
| 233 | n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1); |
| 234 | dst = SCM_I_ARRAY_V (dst); |
| 235 | |
| 236 | for (; n-- > 0; i += inc) |
| 237 | h.vset (h.vector, i, fill); |
| 238 | |
| 239 | scm_array_handle_release (&h); |
| 240 | return 1; |
| 241 | } |
| 242 | |
| 243 | SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0, |
| 244 | (SCM ra, SCM fill), |
| 245 | "Store @var{fill} in every element of array @var{ra}. The value\n" |
| 246 | "returned is unspecified.") |
| 247 | #define FUNC_NAME s_scm_array_fill_x |
| 248 | { |
| 249 | scm_ramapc (rafill, fill, ra, SCM_EOL, FUNC_NAME); |
| 250 | return SCM_UNSPECIFIED; |
| 251 | } |
| 252 | #undef FUNC_NAME |
| 253 | |
| 254 | |
| 255 | static int |
| 256 | racp (SCM src, SCM dst) |
| 257 | { |
| 258 | scm_t_array_handle h_s, h_d; |
| 259 | size_t n, i_s, i_d; |
| 260 | ssize_t inc_s, inc_d; |
| 261 | |
| 262 | dst = SCM_CAR (dst); |
| 263 | i_s = SCM_I_ARRAY_BASE (src); |
| 264 | i_d = SCM_I_ARRAY_BASE (dst); |
| 265 | inc_s = SCM_I_ARRAY_DIMS (src)->inc; |
| 266 | inc_d = SCM_I_ARRAY_DIMS (dst)->inc; |
| 267 | n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1); |
| 268 | src = SCM_I_ARRAY_V (src); |
| 269 | dst = SCM_I_ARRAY_V (dst); |
| 270 | |
| 271 | scm_array_get_handle (src, &h_s); |
| 272 | scm_array_get_handle (dst, &h_d); |
| 273 | |
| 274 | if (h_s.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM |
| 275 | && h_d.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM) |
| 276 | { |
| 277 | SCM const * el_s = h_s.elements; |
| 278 | SCM * el_d = h_d.writable_elements; |
| 279 | for (; n-- > 0; i_s += inc_s, i_d += inc_d) |
| 280 | el_d[i_d] = el_s[i_s]; |
| 281 | } |
| 282 | else |
| 283 | for (; n-- > 0; i_s += inc_s, i_d += inc_d) |
| 284 | h_d.vset (h_d.vector, i_d, h_s.vref (h_s.vector, i_s)); |
| 285 | |
| 286 | scm_array_handle_release (&h_d); |
| 287 | scm_array_handle_release (&h_s); |
| 288 | |
| 289 | return 1; |
| 290 | } |
| 291 | |
| 292 | SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x); |
| 293 | |
| 294 | |
| 295 | SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0, |
| 296 | (SCM src, SCM dst), |
| 297 | "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n" |
| 298 | "Copy every element from vector or array @var{src} to the\n" |
| 299 | "corresponding element of @var{dst}. @var{dst} must have the\n" |
| 300 | "same rank as @var{src}, and be at least as large in each\n" |
| 301 | "dimension. The order is unspecified.") |
| 302 | #define FUNC_NAME s_scm_array_copy_x |
| 303 | { |
| 304 | scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), FUNC_NAME); |
| 305 | return SCM_UNSPECIFIED; |
| 306 | } |
| 307 | #undef FUNC_NAME |
| 308 | |
| 309 | |
| 310 | #if SCM_ENABLE_DEPRECATED == 1 |
| 311 | |
| 312 | /* to be used as cproc in scm_ramapc to fill an array dimension with |
| 313 | "fill". */ |
| 314 | int |
| 315 | scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED) |
| 316 | { |
| 317 | unsigned long i; |
| 318 | unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1; |
| 319 | long inc = SCM_I_ARRAY_DIMS (ra)->inc; |
| 320 | unsigned long base = SCM_I_ARRAY_BASE (ra); |
| 321 | |
| 322 | ra = SCM_I_ARRAY_V (ra); |
| 323 | |
| 324 | for (i = base; n--; i += inc) |
| 325 | ASET (ra, i, fill); |
| 326 | |
| 327 | return 1; |
| 328 | } |
| 329 | |
| 330 | /* Functions callable by ARRAY-MAP! */ |
| 331 | |
| 332 | int |
| 333 | scm_ra_eqp (SCM ra0, SCM ras) |
| 334 | { |
| 335 | SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras)); |
| 336 | scm_t_array_handle ra0_handle; |
| 337 | scm_t_array_dim *ra0_dims; |
| 338 | size_t n; |
| 339 | ssize_t inc0; |
| 340 | size_t i0 = 0; |
| 341 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2); |
| 342 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; |
| 343 | long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc; |
| 344 | ra1 = SCM_I_ARRAY_V (ra1); |
| 345 | ra2 = SCM_I_ARRAY_V (ra2); |
| 346 | |
| 347 | scm_array_get_handle (ra0, &ra0_handle); |
| 348 | ra0_dims = scm_array_handle_dims (&ra0_handle); |
| 349 | n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1; |
| 350 | inc0 = ra0_dims[0].inc; |
| 351 | |
| 352 | { |
| 353 | for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) |
| 354 | if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0))) |
| 355 | if (!scm_is_eq (AREF (ra1, i1), AREF (ra2, i2))) |
| 356 | scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F); |
| 357 | } |
| 358 | |
| 359 | scm_array_handle_release (&ra0_handle); |
| 360 | return 1; |
| 361 | } |
| 362 | |
| 363 | /* opt 0 means <, nonzero means >= */ |
| 364 | |
| 365 | static int |
| 366 | ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt) |
| 367 | { |
| 368 | scm_t_array_handle ra0_handle; |
| 369 | scm_t_array_dim *ra0_dims; |
| 370 | size_t n; |
| 371 | ssize_t inc0; |
| 372 | size_t i0 = 0; |
| 373 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2); |
| 374 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; |
| 375 | long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc; |
| 376 | ra1 = SCM_I_ARRAY_V (ra1); |
| 377 | ra2 = SCM_I_ARRAY_V (ra2); |
| 378 | |
| 379 | scm_array_get_handle (ra0, &ra0_handle); |
| 380 | ra0_dims = scm_array_handle_dims (&ra0_handle); |
| 381 | n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1; |
| 382 | inc0 = ra0_dims[0].inc; |
| 383 | |
| 384 | { |
| 385 | for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) |
| 386 | if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0))) |
| 387 | if (opt ? |
| 388 | scm_is_true (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))) : |
| 389 | scm_is_false (scm_less_p (AREF (ra1, i1), AREF (ra2, i2)))) |
| 390 | scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F); |
| 391 | } |
| 392 | |
| 393 | scm_array_handle_release (&ra0_handle); |
| 394 | return 1; |
| 395 | } |
| 396 | |
| 397 | |
| 398 | |
| 399 | int |
| 400 | scm_ra_lessp (SCM ra0, SCM ras) |
| 401 | { |
| 402 | return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0); |
| 403 | } |
| 404 | |
| 405 | |
| 406 | int |
| 407 | scm_ra_leqp (SCM ra0, SCM ras) |
| 408 | { |
| 409 | return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1); |
| 410 | } |
| 411 | |
| 412 | |
| 413 | int |
| 414 | scm_ra_grp (SCM ra0, SCM ras) |
| 415 | { |
| 416 | return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0); |
| 417 | } |
| 418 | |
| 419 | |
| 420 | int |
| 421 | scm_ra_greqp (SCM ra0, SCM ras) |
| 422 | { |
| 423 | return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1); |
| 424 | } |
| 425 | |
| 426 | |
| 427 | int |
| 428 | scm_ra_sum (SCM ra0, SCM ras) |
| 429 | { |
| 430 | long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; |
| 431 | unsigned long i0 = SCM_I_ARRAY_BASE (ra0); |
| 432 | long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; |
| 433 | ra0 = SCM_I_ARRAY_V (ra0); |
| 434 | if (!scm_is_null(ras)) |
| 435 | { |
| 436 | SCM ra1 = SCM_CAR (ras); |
| 437 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1); |
| 438 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; |
| 439 | ra1 = SCM_I_ARRAY_V (ra1); |
| 440 | switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) |
| 441 | { |
| 442 | default: |
| 443 | { |
| 444 | for (; n-- > 0; i0 += inc0, i1 += inc1) |
| 445 | ASET (ra0, i0, scm_sum (AREF(ra0, i0), AREF(ra1, i1))); |
| 446 | break; |
| 447 | } |
| 448 | } |
| 449 | } |
| 450 | return 1; |
| 451 | } |
| 452 | |
| 453 | |
| 454 | |
| 455 | int |
| 456 | scm_ra_difference (SCM ra0, SCM ras) |
| 457 | { |
| 458 | long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; |
| 459 | unsigned long i0 = SCM_I_ARRAY_BASE (ra0); |
| 460 | long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; |
| 461 | ra0 = SCM_I_ARRAY_V (ra0); |
| 462 | if (scm_is_null (ras)) |
| 463 | { |
| 464 | switch (SCM_TYP7 (ra0)) |
| 465 | { |
| 466 | default: |
| 467 | { |
| 468 | for (; n-- > 0; i0 += inc0) |
| 469 | ASET (ra0, i0, scm_difference (AREF(ra0, i0), SCM_UNDEFINED)); |
| 470 | break; |
| 471 | } |
| 472 | } |
| 473 | } |
| 474 | else |
| 475 | { |
| 476 | SCM ra1 = SCM_CAR (ras); |
| 477 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1); |
| 478 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; |
| 479 | ra1 = SCM_I_ARRAY_V (ra1); |
| 480 | switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) |
| 481 | { |
| 482 | default: |
| 483 | { |
| 484 | for (; n-- > 0; i0 += inc0, i1 += inc1) |
| 485 | ASET (ra0, i0, scm_difference (AREF (ra0, i0), AREF (ra1, i1))); |
| 486 | break; |
| 487 | } |
| 488 | } |
| 489 | } |
| 490 | return 1; |
| 491 | } |
| 492 | |
| 493 | |
| 494 | |
| 495 | int |
| 496 | scm_ra_product (SCM ra0, SCM ras) |
| 497 | { |
| 498 | long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; |
| 499 | unsigned long i0 = SCM_I_ARRAY_BASE (ra0); |
| 500 | long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; |
| 501 | ra0 = SCM_I_ARRAY_V (ra0); |
| 502 | if (!scm_is_null (ras)) |
| 503 | { |
| 504 | SCM ra1 = SCM_CAR (ras); |
| 505 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1); |
| 506 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; |
| 507 | ra1 = SCM_I_ARRAY_V (ra1); |
| 508 | switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) |
| 509 | { |
| 510 | default: |
| 511 | { |
| 512 | for (; n-- > 0; i0 += inc0, i1 += inc1) |
| 513 | ASET (ra0, i0, scm_product (AREF (ra0, i0), AREF (ra1, i1))); |
| 514 | } |
| 515 | } |
| 516 | } |
| 517 | return 1; |
| 518 | } |
| 519 | |
| 520 | |
| 521 | int |
| 522 | scm_ra_divide (SCM ra0, SCM ras) |
| 523 | { |
| 524 | long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; |
| 525 | unsigned long i0 = SCM_I_ARRAY_BASE (ra0); |
| 526 | long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; |
| 527 | ra0 = SCM_I_ARRAY_V (ra0); |
| 528 | if (scm_is_null (ras)) |
| 529 | { |
| 530 | switch (SCM_TYP7 (ra0)) |
| 531 | { |
| 532 | default: |
| 533 | { |
| 534 | for (; n-- > 0; i0 += inc0) |
| 535 | ASET (ra0, i0, scm_divide (AREF (ra0, i0), SCM_UNDEFINED)); |
| 536 | break; |
| 537 | } |
| 538 | } |
| 539 | } |
| 540 | else |
| 541 | { |
| 542 | SCM ra1 = SCM_CAR (ras); |
| 543 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1); |
| 544 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; |
| 545 | ra1 = SCM_I_ARRAY_V (ra1); |
| 546 | switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) |
| 547 | { |
| 548 | default: |
| 549 | { |
| 550 | for (; n-- > 0; i0 += inc0, i1 += inc1) |
| 551 | { |
| 552 | SCM res = scm_divide (AREF (ra0, i0), AREF (ra1, i1)); |
| 553 | ASET (ra0, i0, res); |
| 554 | } |
| 555 | break; |
| 556 | } |
| 557 | } |
| 558 | } |
| 559 | return 1; |
| 560 | } |
| 561 | |
| 562 | |
| 563 | int |
| 564 | scm_array_identity (SCM dst, SCM src) |
| 565 | { |
| 566 | return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL)); |
| 567 | } |
| 568 | |
| 569 | #endif /* SCM_ENABLE_DEPRECATED */ |
| 570 | |
| 571 | static int |
| 572 | ramap (SCM ra0, SCM proc, SCM ras) |
| 573 | { |
| 574 | scm_t_array_handle h0; |
| 575 | size_t n, i0; |
| 576 | ssize_t i, inc0; |
| 577 | i0 = SCM_I_ARRAY_BASE (ra0); |
| 578 | inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; |
| 579 | i = SCM_I_ARRAY_DIMS (ra0)->lbnd; |
| 580 | n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1; |
| 581 | ra0 = SCM_I_ARRAY_V (ra0); |
| 582 | scm_array_get_handle (ra0, &h0); |
| 583 | if (scm_is_null (ras)) |
| 584 | for (; n--; i0 += inc0) |
| 585 | h0.vset (h0.vector, i0, scm_call_0 (proc)); |
| 586 | else |
| 587 | { |
| 588 | SCM ra1 = SCM_CAR (ras); |
| 589 | scm_t_array_handle h1; |
| 590 | size_t i1; |
| 591 | ssize_t inc1; |
| 592 | i1 = SCM_I_ARRAY_BASE (ra1); |
| 593 | inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; |
| 594 | ras = SCM_CDR (ras); |
| 595 | ra1 = SCM_I_ARRAY_V (ra1); |
| 596 | scm_array_get_handle (ra1, &h1); |
| 597 | if (scm_is_null (ras)) |
| 598 | for (; n--; i0 += inc0, i1 += inc1) |
| 599 | h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1))); |
| 600 | else |
| 601 | { |
| 602 | ras = scm_vector (ras); |
| 603 | for (; n--; i0 += inc0, i1 += inc1, ++i) |
| 604 | { |
| 605 | SCM args = SCM_EOL; |
| 606 | unsigned long k; |
| 607 | for (k = scm_c_vector_length (ras); k--;) |
| 608 | args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args); |
| 609 | h0.vset (h0.vector, i0, |
| 610 | scm_apply_1 (proc, h1.vref (h1.vector, i1), args)); |
| 611 | } |
| 612 | } |
| 613 | scm_array_handle_release (&h1); |
| 614 | } |
| 615 | scm_array_handle_release (&h0); |
| 616 | return 1; |
| 617 | } |
| 618 | |
| 619 | |
| 620 | SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x); |
| 621 | |
| 622 | SCM_SYMBOL (sym_b, "b"); |
| 623 | |
| 624 | SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, |
| 625 | (SCM ra0, SCM proc, SCM lra), |
| 626 | "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n" |
| 627 | "@var{array1}, @dots{} must have the same number of dimensions\n" |
| 628 | "as @var{ra0} and have a range for each index which includes the\n" |
| 629 | "range for the corresponding index in @var{ra0}. @var{proc} is\n" |
| 630 | "applied to each tuple of elements of @var{array1}, @dots{} and\n" |
| 631 | "the result is stored as the corresponding element in @var{ra0}.\n" |
| 632 | "The value returned is unspecified. The order of application is\n" |
| 633 | "unspecified.") |
| 634 | #define FUNC_NAME s_scm_array_map_x |
| 635 | { |
| 636 | SCM_VALIDATE_PROC (2, proc); |
| 637 | SCM_VALIDATE_REST_ARGUMENT (lra); |
| 638 | |
| 639 | scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME); |
| 640 | return SCM_UNSPECIFIED; |
| 641 | } |
| 642 | #undef FUNC_NAME |
| 643 | |
| 644 | |
| 645 | static int |
| 646 | rafe (SCM ra0, SCM proc, SCM ras) |
| 647 | { |
| 648 | ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd; |
| 649 | size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1; |
| 650 | |
| 651 | scm_t_array_handle h0; |
| 652 | size_t i0; |
| 653 | ssize_t inc0; |
| 654 | i0 = SCM_I_ARRAY_BASE (ra0); |
| 655 | inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; |
| 656 | ra0 = SCM_I_ARRAY_V (ra0); |
| 657 | scm_array_get_handle (ra0, &h0); |
| 658 | if (scm_is_null (ras)) |
| 659 | for (; n--; i0 += inc0) |
| 660 | scm_call_1 (proc, h0.vref (h0.vector, i0)); |
| 661 | else |
| 662 | { |
| 663 | ras = scm_vector (ras); |
| 664 | for (; n--; i0 += inc0, ++i) |
| 665 | { |
| 666 | SCM args = SCM_EOL; |
| 667 | unsigned long k; |
| 668 | for (k = scm_c_vector_length (ras); k--;) |
| 669 | args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args); |
| 670 | scm_apply_1 (proc, h0.vref (h0.vector, i0), args); |
| 671 | } |
| 672 | } |
| 673 | scm_array_handle_release (&h0); |
| 674 | return 1; |
| 675 | } |
| 676 | |
| 677 | SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1, |
| 678 | (SCM proc, SCM ra0, SCM lra), |
| 679 | "Apply @var{proc} to each tuple of elements of @var{ra0} @dots{}\n" |
| 680 | "in row-major order. The value returned is unspecified.") |
| 681 | #define FUNC_NAME s_scm_array_for_each |
| 682 | { |
| 683 | SCM_VALIDATE_PROC (1, proc); |
| 684 | SCM_VALIDATE_REST_ARGUMENT (lra); |
| 685 | scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME); |
| 686 | return SCM_UNSPECIFIED; |
| 687 | } |
| 688 | #undef FUNC_NAME |
| 689 | |
| 690 | static void |
| 691 | array_index_map_1 (SCM ra, SCM proc) |
| 692 | { |
| 693 | scm_t_array_handle h; |
| 694 | ssize_t i, inc; |
| 695 | size_t p; |
| 696 | scm_array_get_handle (ra, &h); |
| 697 | inc = h.dims[0].inc; |
| 698 | for (i = h.dims[0].lbnd, p = h.base; i <= h.dims[0].ubnd; ++i, p += inc) |
| 699 | h.vset (h.vector, p, scm_call_1 (proc, scm_from_ssize_t (i))); |
| 700 | scm_array_handle_release (&h); |
| 701 | } |
| 702 | |
| 703 | /* Here we assume that the array is a scm_tc7_array, as that is the only |
| 704 | kind of array in Guile that supports rank > 1. */ |
| 705 | static void |
| 706 | array_index_map_n (SCM ra, SCM proc) |
| 707 | { |
| 708 | scm_t_array_handle h; |
| 709 | size_t i; |
| 710 | int k, kmax = SCM_I_ARRAY_NDIM (ra) - 1; |
| 711 | ssize_t *vi; |
| 712 | SCM **si; |
| 713 | SCM args = SCM_EOL; |
| 714 | SCM *p = &args; |
| 715 | |
| 716 | vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * (kmax + 1), vi_gc_hint); |
| 717 | si = scm_gc_malloc_pointerless (sizeof(SCM *) * (kmax + 1), vi_gc_hint); |
| 718 | |
| 719 | for (k = 0; k <= kmax; k++) |
| 720 | { |
| 721 | vi[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd; |
| 722 | if (vi[k] > SCM_I_ARRAY_DIMS (ra)[k].ubnd) |
| 723 | return; |
| 724 | *p = scm_cons (scm_from_ssize_t (vi[k]), SCM_EOL); |
| 725 | si[k] = SCM_CARLOC (*p); |
| 726 | p = SCM_CDRLOC (*p); |
| 727 | } |
| 728 | |
| 729 | scm_array_get_handle (ra, &h); |
| 730 | k = kmax; |
| 731 | do |
| 732 | { |
| 733 | if (k == kmax) |
| 734 | { |
| 735 | vi[kmax] = SCM_I_ARRAY_DIMS (ra)[kmax].lbnd; |
| 736 | i = cindk (ra, vi, kmax+1); |
| 737 | for (; vi[kmax] <= SCM_I_ARRAY_DIMS (ra)[kmax].ubnd; ++vi[kmax]) |
| 738 | { |
| 739 | *(si[kmax]) = scm_from_ssize_t (vi[kmax]); |
| 740 | h.vset (h.vector, i, scm_apply_0 (proc, args)); |
| 741 | i += SCM_I_ARRAY_DIMS (ra)[kmax].inc; |
| 742 | } |
| 743 | k--; |
| 744 | } |
| 745 | else if (vi[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd) |
| 746 | { |
| 747 | *(si[k]) = scm_from_ssize_t (++vi[k]); |
| 748 | k++; |
| 749 | } |
| 750 | else |
| 751 | { |
| 752 | vi[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1; |
| 753 | k--; |
| 754 | } |
| 755 | } |
| 756 | while (k >= 0); |
| 757 | scm_array_handle_release (&h); |
| 758 | } |
| 759 | |
| 760 | SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, |
| 761 | (SCM ra, SCM proc), |
| 762 | "Apply @var{proc} to the indices of each element of @var{ra} in\n" |
| 763 | "turn, storing the result in the corresponding element. The value\n" |
| 764 | "returned and the order of application are unspecified.\n\n" |
| 765 | "One can implement @var{array-indexes} as\n" |
| 766 | "@lisp\n" |
| 767 | "(define (array-indexes array)\n" |
| 768 | " (let ((ra (apply make-array #f (array-shape array))))\n" |
| 769 | " (array-index-map! ra (lambda x x))\n" |
| 770 | " ra))\n" |
| 771 | "@end lisp\n" |
| 772 | "Another example:\n" |
| 773 | "@lisp\n" |
| 774 | "(define (apl:index-generator n)\n" |
| 775 | " (let ((v (make-uniform-vector n 1)))\n" |
| 776 | " (array-index-map! v (lambda (i) i))\n" |
| 777 | " v))\n" |
| 778 | "@end lisp") |
| 779 | #define FUNC_NAME s_scm_array_index_map_x |
| 780 | { |
| 781 | SCM_VALIDATE_PROC (2, proc); |
| 782 | |
| 783 | switch (scm_c_array_rank (ra)) |
| 784 | { |
| 785 | case 0: |
| 786 | scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL); |
| 787 | break; |
| 788 | case 1: |
| 789 | array_index_map_1 (ra, proc); |
| 790 | break; |
| 791 | default: |
| 792 | array_index_map_n (ra, proc); |
| 793 | break; |
| 794 | } |
| 795 | |
| 796 | return SCM_UNSPECIFIED; |
| 797 | } |
| 798 | #undef FUNC_NAME |
| 799 | |
| 800 | |
| 801 | static int |
| 802 | array_compare (scm_t_array_handle *hx, scm_t_array_handle *hy, |
| 803 | size_t dim, unsigned long posx, unsigned long posy) |
| 804 | { |
| 805 | if (dim == scm_array_handle_rank (hx)) |
| 806 | return scm_is_true (scm_equal_p (scm_array_handle_ref (hx, posx), |
| 807 | scm_array_handle_ref (hy, posy))); |
| 808 | else |
| 809 | { |
| 810 | long incx, incy; |
| 811 | size_t i; |
| 812 | |
| 813 | if (hx->dims[dim].lbnd != hy->dims[dim].lbnd |
| 814 | || hx->dims[dim].ubnd != hy->dims[dim].ubnd) |
| 815 | return 0; |
| 816 | |
| 817 | i = hx->dims[dim].ubnd - hx->dims[dim].lbnd + 1; |
| 818 | |
| 819 | incx = hx->dims[dim].inc; |
| 820 | incy = hy->dims[dim].inc; |
| 821 | posx += (i - 1) * incx; |
| 822 | posy += (i - 1) * incy; |
| 823 | |
| 824 | for (; i > 0; i--, posx -= incx, posy -= incy) |
| 825 | if (!array_compare (hx, hy, dim + 1, posx, posy)) |
| 826 | return 0; |
| 827 | return 1; |
| 828 | } |
| 829 | } |
| 830 | |
| 831 | SCM |
| 832 | scm_array_equal_p (SCM x, SCM y) |
| 833 | { |
| 834 | scm_t_array_handle hx, hy; |
| 835 | SCM res; |
| 836 | |
| 837 | scm_array_get_handle (x, &hx); |
| 838 | scm_array_get_handle (y, &hy); |
| 839 | |
| 840 | res = scm_from_bool (hx.ndims == hy.ndims |
| 841 | && hx.element_type == hy.element_type); |
| 842 | |
| 843 | if (scm_is_true (res)) |
| 844 | res = scm_from_bool (array_compare (&hx, &hy, 0, 0, 0)); |
| 845 | |
| 846 | scm_array_handle_release (&hy); |
| 847 | scm_array_handle_release (&hx); |
| 848 | |
| 849 | return res; |
| 850 | } |
| 851 | |
| 852 | static SCM scm_i_array_equal_p (SCM, SCM, SCM); |
| 853 | SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1, |
| 854 | (SCM ra0, SCM ra1, SCM rest), |
| 855 | "Return @code{#t} iff all arguments are arrays with the same\n" |
| 856 | "shape, the same type, and have corresponding elements which are\n" |
| 857 | "either @code{equal?} or @code{array-equal?}. This function\n" |
| 858 | "differs from @code{equal?} in that all arguments must be arrays.") |
| 859 | #define FUNC_NAME s_scm_i_array_equal_p |
| 860 | { |
| 861 | if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1)) |
| 862 | return SCM_BOOL_T; |
| 863 | |
| 864 | while (!scm_is_null (rest)) |
| 865 | { if (scm_is_false (scm_array_equal_p (ra0, ra1))) |
| 866 | return SCM_BOOL_F; |
| 867 | ra0 = ra1; |
| 868 | ra1 = scm_car (rest); |
| 869 | rest = scm_cdr (rest); |
| 870 | } |
| 871 | return scm_array_equal_p (ra0, ra1); |
| 872 | } |
| 873 | #undef FUNC_NAME |
| 874 | |
| 875 | |
| 876 | void |
| 877 | scm_init_array_map (void) |
| 878 | { |
| 879 | #include "libguile/array-map.x" |
| 880 | scm_add_feature (s_scm_array_for_each); |
| 881 | } |
| 882 | |
| 883 | /* |
| 884 | Local Variables: |
| 885 | c-file-style: "gnu" |
| 886 | End: |
| 887 | */ |