diff --git a/CMakeLists.txt b/CMakeLists.txt index f24bd853..20109bf3 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -79,6 +79,8 @@ add_compile_options($<$:-Wno-char-subscripts>) add_compile_options($<$:-Wno-string-plus-int>) add_compile_options($<$:-Wno-missing-braces>) add_compile_options($<$:-Wno-unknown-pragmas>) +add_compile_options($<$:-Wno-bool-compare>) + add_subdirectory(jsrc) add_subdirectory(base64) diff --git a/jsrc/CMakeLists.txt b/jsrc/CMakeLists.txt index 7c91ae9f..01260abc 100644 --- a/jsrc/CMakeLists.txt +++ b/jsrc/CMakeLists.txt @@ -91,7 +91,7 @@ target_sources(j PRIVATE io.c j.c jdlllic.c - k.c + conversions.cpp m.c parsing/p.c parsing/pv.c diff --git a/jsrc/array.hpp b/jsrc/array.hpp index 7499a49d..f7e5d46d 100644 --- a/jsrc/array.hpp +++ b/jsrc/array.hpp @@ -35,9 +35,10 @@ num(int64_t n) { return reinterpret_cast(Bnum[n - NUMMIN]); } +template [[nodiscard]] inline auto -pointer_to_values(array x) -> int64_t* { - return reinterpret_cast(reinterpret_cast(x) + x->kchain.k); +pointer_to_values(array x) -> Value* { + return reinterpret_cast(reinterpret_cast(x) + x->kchain.k); } [[nodiscard]] constexpr auto @@ -49,7 +50,7 @@ is_sparse(array x) noexcept -> bool { template auto set_value_at(array x, int32_t index, T const& value) -> void { - pointer_to_values(x)[index] = value; + pointer_to_values(x)[index] = value; } // TODO: remove eventually, temporary while c_types exist diff --git a/jsrc/conversions.cpp b/jsrc/conversions.cpp new file mode 100644 index 00000000..990f0933 --- /dev/null +++ b/jsrc/conversions.cpp @@ -0,0 +1,636 @@ +/* Copyright 1990-2010, Jsoftware Inc. All rights reserved. */ +/* Licensed use only. Any other use is in violation of copyright. */ +/* */ +/* Conversions Amongst Internal Types */ + +#include +#include +#include +#include +#include + +#include "array.hpp" +extern "C" { +#include "verbs/vcomp.h" +} + +#define CVCASE(a, b) (((a) << 3) + (b)) // The main cases fit in low 8 bits of mask + +// fuzzy_equal() is used in bcvt, where FUZZ may be set to 0 to ensure only exact values are demoted to lower precision +// used when v is known to be exact integer. It's close enough, maybe ULP too small on the high end +[[nodiscard]] static auto +fuzzy_equal(double u, double v, double fuzz) -> bool { + return std::abs(u - v) <= fuzz * std::abs(v); +} + +template +[[nodiscard]] constexpr auto +in_range(V value) -> bool { + return std::numeric_limits::lowest() <= value && value <= std::numeric_limits::max(); +} + +template +[[nodiscard]] constexpr auto +in_range() -> bool { + return in_range(std::numeric_limits::lowest()) && in_range(std::numeric_limits::max()); +} + +template +struct is_optional : std::false_type {}; + +template +struct is_optional> : std::true_type {}; + +template +[[nodiscard]] auto +value_if(bool cond, T value) -> std::optional { + return cond ? std::optional(value) : std::nullopt; +} + +template +[[nodiscard]] auto +convert(J jt, array w, void *yv, Transform t) -> bool { + auto *v = pointer_to_values(w); + auto *result = static_cast(yv); + if constexpr (is_optional::value) { + for (int64_t i = 0; i < AN(w); ++i) { + auto opt = t(v[i]); + if (!opt) return false; + result[i] = opt.value(); + } + } else { + std::transform(v, v + AN(w), result, t); + } + return true; +} + +template +[[nodiscard]] auto +convert(J jt, array w, void *yv) -> bool { + if constexpr (std::is_same_v) { + return convert(jt, w, yv, [](auto v) { return To{.re = static_cast(v), .im = {}}; }); + } else if constexpr (!in_range()) { + return convert(jt, w, yv, [](auto v) { return value_if(in_range(v), v); }); + } else { + (void)jt; + auto *v = pointer_to_values(w); + std::copy(v, v + AN(w), static_cast(yv)); + return true; + } +} + +template <> +[[nodiscard]] auto +convert(J jt, array w, void *yv, double fuzz) -> bool { + auto const infinity = [](auto p) { return p < -2 || 2 < p; }; + return convert( + jt, w, yv, [&](auto p) { return value_if(!infinity(p) && (p == 0.0 || fuzzy_equal(p, 1.0, fuzz)), p != 0.0); }); +} + +template <> +[[nodiscard]] auto +convert(J jt, array w, void *yv, double fuzz) -> bool { + return convert(jt, w, yv, [&](auto p) -> std::optional { + auto const q = jround(p); + if (!(p == q || fuzzy_equal(p, q, fuzz))) { + return std::nullopt; // must equal int, possibly out of range + } + // out-of-range values don't convert, handle separately + if (p < static_cast(IMIN)) { + return value_if(p >= IMIN * (1 + fuzz), IMIN); + } // if tolerantly < IMIN, error; else take IMIN + else if (p >= FLIMAX) { + return value_if(p <= -static_cast(IMIN) * (1 + fuzz), IMAX); + } // if tolerantly > IMAX, error; else take IMAX + return q; + }); +} + +template <> +[[nodiscard]] auto +convert(J jt, array w, void *yv, double fuzz) -> bool { + if (fuzz != 0.0) { + return convert(jt, w, yv, [&](auto const &v) { + auto const d = std::abs(v.im); + return value_if(d != inf && d <= fuzz * std::abs(v.re), v.re); + }); + } + return convert(jt, w, yv, [](auto v) { return value_if(!v.im, v.re); }); +} + +template <> +[[nodiscard]] auto +convert(J jt, array w, void *yv) -> bool { + auto const convert_one = [=](auto v) { + int64_t u[] = {v}; + return jtvec(jt, INT, 1L, u); + }; + return convert(jt, w, yv, convert_one) && !jt->jerr; +} + +template +static auto +inplace_negate(T *u, int64_t n) { + std::transform(u, u + n, u, std::negate{}); +} + +template <> +[[nodiscard]] auto +convert(J jt, array w, void *yv) -> bool { + int64_t u[XIDIG]; + auto const convert_one = [&](auto c) { + bool const b = c == IMIN; + int64_t d = b ? -(1 + c) : std::abs(c); + int64_t length = 0; + for (int64_t i = 0; i < XIDIG; ++i) { + auto const [q, r] = std::div(d, int64_t{XBASE}); + u[i] = r; + d = q; + if (r) length = i; + } + ++length; + *u += b; + if (0 > c) { inplace_negate(u, XIDIG); } + return jtvec(jt, INT, length, u); + }; + return convert(jt, w, yv, convert_one) && !jt->jerr; +} + +static auto +jtxd1(J jt, double p, int64_t mode) -> X { + PROLOG(0052); + double e = jttfloor(jt, p); + switch (mode) { + case XMFLR: p = e; break; + case XMCEIL: p = ceil(p); break; + case XMEXACT: + ASSERT(TEQ(p, e), EVDOMAIN); + p = e; + break; + case XMEXMT: + if (!TEQ(p, e)) { return jtvec(jt, INT, 0L, &iotavec[-IOTAVECBEGIN]); } + } + if (p == inf) { return jtvci(jt, XPINF); } + if (p == -inf) { return jtvci(jt, XNINF); } + array t = make_array(jt, 30, 1); + if (!t) return 0; + auto *u = pointer_to_values(t); + int64_t m = 0; + int64_t d = std::abs(p); + while (0 < d) { + auto const [q, r] = std::div(d, int64_t{XBASE}); + u[m++] = r; + d = q; + if (m == AN(t)) { + RZ(t = jtext(jt, 0, t)); + u = pointer_to_values(t); + } + } + if (m == 0) { + u[0] = 0; + ++m; + } else if (0 > p) { + inplace_negate(u, m); + } + array z = jtxstd(jt, jtvec(jt, INT, m, u)); + EPILOG(z); +} + +template <> +[[nodiscard]] auto +convert(J jt, array w, void *yv, int64_t mode) -> bool { + return convert(jt, w, yv, [=](auto v) { return jtxd1(jt, v, mode); }) && !jt->jerr; +} + +template <> +[[nodiscard]] auto +convert(J jt, array w, void *yv) -> bool { + return convert(jt, w, yv, [](auto q) { + auto const e = pointer_to_values(q)[0]; + return value_if(!((AN(q) ^ 1) | (e & -2)), e); + }); +} + +template +[[nodiscard]] static auto +value_from_X(X p) -> T { + auto const n = AN(p); + auto const v = std::reverse_iterator(pointer_to_values(p) + n); + return std::accumulate(v, v + n, T{}, [](auto d, auto v) { return v + d * XBASE; }); +} + +template <> +[[nodiscard]] auto +convert(J jt, array w, void *yv) -> bool { + X p = jtxc(jt, IMAX); + if (!p) return false; + X q = jtxminus(jt, jtnegate(jt, p), jtxc(jt, 1L)); + if (!q) return false; + return convert(jt, w, yv, [&](auto c) -> std::optional { + if (!(1 != jtxcompare(jt, q, c) && 1 != jtxcompare(jt, c, p))) return std::nullopt; + return value_from_X(c); + }); +} + +template <> +[[nodiscard]] auto +convert(J jt, array w, void *yv) -> bool { + return convert(jt, w, yv, [](auto p) { + auto const c = pointer_to_values(p)[AN(p) - 1]; + if (c == XPINF) { return inf; } + if (c == XNINF) { return infm; } + return value_from_X(p); + }); +} + +template <> +[[nodiscard]] auto +convert(J jt, array w, void *yv) -> bool { + return convert(jt, w, yv, [](auto v) -> Q { return {v, iv1}; }); +} + +template <> +[[nodiscard]] auto +convert(J jt, array w, void *yv, int64_t mode) -> bool { + if ((w) == nullptr) return false; + auto const n = AN(w); + auto *const wv = pointer_to_values(w); + auto *x = static_cast(yv); + double t = NAN; + auto *tv = 3 + reinterpret_cast(&t); + Q q; + for (int64_t i = 0; i < n; ++i) { + t = wv[i]; + ASSERT(!_isnan(t), EVNAN); + bool const neg = 0 > t; + if (neg) { t = -t; } + q.d = iv1; + if (t == inf) { + q.n = jtvci(jt, XPINF); + } else if (t == 0.0) { + q.n = iv0; + } else if (1.1102230246251565e-16 < t && t < 9.007199254740992e15) { + auto const d = jround(1 / jtdgcd(jt, 1.0, t)); + auto const c = jround(d * t); + q = jtqstd(jt, + { + .n = jtxd1(jt, c, mode), + .d = jtxd1(jt, d, mode), + }); + } else { + bool const recip = 1 > t; + if (recip) { t = 1.0 / t; } + auto e = static_cast(0xfff0 & *tv); + e >>= 4; + e -= 1023; + if (recip) { + q.d = jtxtymes(jt, jtxd1(jt, t / pow(2.0, e - 53.0), mode), jtxpow(jt, jtxc(jt, 2L), jtxc(jt, e - 53))); + q.n = jtca(jt, iv1); + } else { + q.n = jtxtymes(jt, jtxd1(jt, t / pow(2.0, e - 53.0), mode), jtxpow(jt, jtxc(jt, 2L), jtxc(jt, e - 53))); + q.d = jtca(jt, iv1); + } + } + if (neg) { inplace_negate(pointer_to_values(q.n), AN(q.n)); } + *x++ = q; + } + return !jt->jerr; +} + +template <> +[[nodiscard]] auto +convert(J jt, array w, void *yv) -> bool { + auto const xb = static_cast(XBASE); + auto const nn = 308 / XBASEN; + + // TODO: figure out nice algorithm for this + auto const add_digits = [&](auto n, auto v) { + auto f = 1.0; + auto d = 0.0; + std::for_each(v, v + n, [&](auto i) { + d += f * i; + f *= xb; + }); + return d; + }; + + X x2 = nullptr; + return convert(jt, w, yv, [&](auto nd) -> std::optional { + auto *const p = nd.n; + auto const pn = AN(p); + auto const kk = 1 == pn ? pointer_to_values(p)[0] : 0; + if (kk == XPINF) return inf; + if (kk == XNINF) return infm; + auto *const q = nd.d; + auto const qn = AN(q); + if (pn <= nn && qn <= nn) { + auto const n = add_digits(pn, pointer_to_values(p)); + auto const d = add_digits(qn, pointer_to_values(q)); + return n / d; + } + if (!x2 && !(x2 = jtxc(jt, 2L))) return std::nullopt; + auto const k = 5 + qn; + auto *c = jtxdiv(jt, jttake(jt, jtsc(jt, -(k + pn)), p), q, XMFLR); + if (!c) return std::nullopt; + auto const cn = AN(c); + auto const m = MIN(cn, 5); + auto const r = cn - (m + k); + auto const n = add_digits(m, pointer_to_values(c) + cn - m); + auto d = std::pow(xb, std::abs(r)); + return 0 > r ? n / d : n * d; + }); +} + +template <> +[[nodiscard]] auto +convert(J jt, array w, void *yv) -> bool { + return convert(jt, w, yv, [&](auto v) { return value_if(jtequ(jt, iv1, v.d), v.n); }) && !jt->jerr; +} + +// Convert the data in w to the type t. w and t must be noun types. A new buffer is always created (with a +// copy of the data if w is already of the right type), and returned in *y. Result is +// 0 if error, 1 if success. If the conversion loses precision, error is returned +// Calls through bcvt are tagged with a flag in jt, indicating to set fuzz=0 +auto +jtccvt(J jt, int64_t tflagged, array w, array *y) -> bool { + FPREFIP; + int64_t const t = tflagged & NOUN; + if (w == nullptr) return false; + auto const r = AR(w); + auto *const s = AS(w); + if (((t | AT(w)) & SPARSE) != 0) { + // Handle sparse + RANK2T oqr = jt->ranks; + RESETRANK; + switch (((t & SPARSE) != 0 ? 2 : 0) + (AT(w) & SPARSE ? 1 : 0)) { + case 1: RZ(w = jtdenseit(jt, w)); break; // sparse to dense + case 2: + RZ(*y = jtsparseit(jt, jtcvt(jt, DTYPE(t), w), IX(r), jtcvt(jt, DTYPE(t), jfalse))); + jt->ranks = oqr; + return true; // dense to sparse; convert type first (even if same dtype) + case 3: // sparse to sparse + int64_t t1 = DTYPE(t); + GASPARSE(*y, t, 1, r, s); + P *yp = pointer_to_values

(*y); + P *wp = pointer_to_values

(w); + SPB(yp, a, jtca(jt, SPA(wp, a))); + SPB(yp, i, jtca(jt, SPA(wp, i))); + SPB(yp, e, jtcvt(jt, t1, SPA(wp, e))); + SPB(yp, x, jtcvt(jt, t1, SPA(wp, x))); + jt->ranks = oqr; + return true; + } + jt->ranks = oqr; + } + // Now known to be non-sparse + auto const wt = AT(w); + // If type is already correct, return a clone - used to force a copy. Should get rid of this kludge + if (TYPESEQ(t, wt)) { + *y = jtca(jt, w); + return *y != nullptr; + } + // Kludge on behalf of result assembly: we want to be able to stop converting after the valid cells. If + // NOUNCVTVALIDCT is set in the type, we use the input *y as as override on the # cells to convert. We use it to + // replace n (for use here) and yv, and AK(w) and AN(w) for the subroutines. If NOUNCVTVALIDCT is set, w is + // modified: the caller must restore AN(w) and AK(w) if it needs it + // TODO: same-length conversion could be done in place + auto n = AN(w); + array d = jtga(jt, t, n, r, s); + if (!d) return false; + auto *yv = pointer_to_values(d); // allocate the same # atoms, even if we will convert fewer + if ((tflagged & NOUNCVTVALIDCT) != 0) { + int64_t inputn = *reinterpret_cast(y); // fetch input, in case it is called for + if (inputn > 0) { // if converting the leading values, just update the counts + n = inputn; // set the counts for local use, and in the block to be converted + } else { // if converting trailing values... + AK(w) += (n + inputn) << bplg(wt); + yv = reinterpret_cast( + static_cast(yv) + ((n + inputn) << bplg(t))); // advance input and output pointers to new area + n = -inputn; // get positive # atoms to convert + } + AN(w) = n; // change atomct of w to # atoms to convert + } + // If n and AN have been modified, it doesn't matter for rank-1 arguments whether the shape of the result is listed + // as n or s[0] since only n atoms will be used. For higher ranks, we need the shape from s. So it's just as well + // that we take the shape from s now + *y = d; + if ((t & CMPX) != 0) { + jtfillv(jt, t, n, static_cast(yv)); // why?? just fill in imaginary parts as we need to + } + if (n == 0) return true; + // Perform the conversion based on data types + // For branch-table efficiency, we split the C2T and C4T and BIT conversions into one block, and + // the rest in another + if (((t | wt) & (C2T + C4T + BIT + SBT)) != 0) { + // there are no SBT conversions, but we have to show domain error we + // must account for all NOUN types. Low 8 bits have most of them, and + // we know type can't be sparse. This picks up the others + ASSERT(!((t | wt) & SBT), EVDOMAIN); // No conversions for these types + switch (CVCASE(CTTZ(t), CTTZ(wt))) { + case CVCASE(LITX, C2TX): return convert(jt, w, yv); + case CVCASE(LITX, C4TX): return convert(jt, w, yv); + case CVCASE(C2TX, LITX): return convert(jt, w, yv); + case CVCASE(C2TX, C4TX): return convert(jt, w, yv); + case CVCASE(C4TX, LITX): return convert(jt, w, yv); + case CVCASE(C4TX, C2TX): return convert(jt, w, yv); + default: ASSERT(0, EVDOMAIN); + } + } + switch (CVCASE(CTTZ(t), CTTZ(wt))) { + case CVCASE(INTX, B01X): return convert(jt, w, yv); + case CVCASE(XNUMX, B01X): return convert(jt, w, yv); + case CVCASE(RATX, B01X): + GATV(d, XNUM, n, r, s); + return convert(jt, w, pointer_to_values(d)) && convert(jt, d, yv); + case CVCASE(FLX, B01X): return convert(jt, w, yv); + case CVCASE(CMPXX, B01X): return convert(jt, w, yv); + case CVCASE(B01X, INTX): return convert(jt, w, yv); + case CVCASE(XNUMX, INTX): return convert(jt, w, yv); + case CVCASE(RATX, INTX): + GATV(d, XNUM, n, r, s); + return convert(jt, w, pointer_to_values(d)) && convert(jt, d, yv); + case CVCASE(FLX, INTX): return convert(jt, w, yv); + case CVCASE(CMPXX, INTX): return convert(jt, w, yv); + case CVCASE(B01X, FLX): + return convert(jt, w, yv, ((int64_t)jtinplace & JTNOFUZZ) != 0 ? 0.0 : FUZZ); + case CVCASE(INTX, FLX): + return convert(jt, w, yv, ((int64_t)jtinplace & JTNOFUZZ) != 0 ? 0.0 : FUZZ); + case CVCASE(XNUMX, FLX): + return convert( + jt, w, yv, int64_t{(jt->xmode & REPSGN(SGNIFNOT(tflagged, XCVTXNUMORIDEX))) | (tflagged >> XCVTXNUMCVX)}); + case CVCASE(RATX, FLX): + return convert( + jt, w, yv, int64_t{(jt->xmode & REPSGN(SGNIFNOT(tflagged, XCVTXNUMORIDEX))) | (tflagged >> XCVTXNUMCVX)}); + case CVCASE(CMPXX, FLX): return convert(jt, w, yv); + case CVCASE(B01X, CMPXX): + GATV(d, FL, n, r, s); + return convert( + jt, w, pointer_to_values(d), ((int64_t)jtinplace & JTNOFUZZ) != 0 ? 0.0 : FUZZ) && + convert(jt, d, yv, ((int64_t)jtinplace & JTNOFUZZ) != 0 ? 0.0 : FUZZ); + case CVCASE(INTX, CMPXX): + GATV(d, FL, n, r, s); + return convert( + jt, w, pointer_to_values(d), ((int64_t)jtinplace & JTNOFUZZ) != 0 ? 0.0 : FUZZ) && + convert(jt, d, yv, ((int64_t)jtinplace & JTNOFUZZ) != 0 ? 0.0 : FUZZ); + case CVCASE(XNUMX, CMPXX): + GATV(d, FL, n, r, s); + return convert( + jt, w, pointer_to_values(d), ((int64_t)jtinplace & JTNOFUZZ) != 0 ? 0.0 : FUZZ) && + convert( + jt, d, yv, int64_t{(jt->xmode & REPSGN(SGNIFNOT(tflagged, XCVTXNUMORIDEX))) | (tflagged >> XCVTXNUMCVX)}); + case CVCASE(RATX, CMPXX): + GATV(d, FL, n, r, s); + return convert( + jt, w, pointer_to_values(d), ((int64_t)jtinplace & JTNOFUZZ) != 0 ? 0.0 : FUZZ) && + convert( + jt, d, yv, int64_t{(jt->xmode & REPSGN(SGNIFNOT(tflagged, XCVTXNUMORIDEX))) | (tflagged >> XCVTXNUMCVX)}); + case CVCASE(FLX, CMPXX): + return convert(jt, w, yv, ((int64_t)jtinplace & JTNOFUZZ) != 0 ? 0.0 : FUZZ); + case CVCASE(B01X, XNUMX): return convert(jt, w, yv); + case CVCASE(INTX, XNUMX): return convert(jt, w, yv); + case CVCASE(RATX, XNUMX): return convert(jt, w, yv); + case CVCASE(FLX, XNUMX): return convert(jt, w, yv); + case CVCASE(CMPXX, XNUMX): + GATV(d, FL, n, r, s); + return convert(jt, w, pointer_to_values(d)) && convert(jt, d, yv); + case CVCASE(B01X, RATX): + GATV(d, XNUM, n, r, s); + return convert(jt, w, pointer_to_values(d)) && convert(jt, d, yv); + case CVCASE(INTX, RATX): + GATV(d, XNUM, n, r, s); + return convert(jt, w, pointer_to_values(d)) && convert(jt, d, yv); + case CVCASE(XNUMX, RATX): return convert(jt, w, yv); + case CVCASE(FLX, RATX): return convert(jt, w, yv); + case CVCASE(CMPXX, RATX): + GATV(d, FL, n, r, s); + return convert(jt, w, pointer_to_values(d)) && convert(jt, d, yv); + default: ASSERT(0, EVDOMAIN); + } +} + +// clear rank before calling ccvt - needed for sparse arrays only but returns the block as the result +auto +jtcvt(J jt, int64_t t, array w) -> array { + array y = nullptr; + bool const b = jtccvt(jt, t, w, &y); + ASSERT(b, EVDOMAIN); + return y; +} + +// Convert numeric type to lowest precision that fits. Push fuzz/rank onto a stack, +// and use 'exact' and 'no rank' for them. If mode=0, do not promote XNUM/RAT to fixed-length types. +// If mode bit 1 is set, minimum precision is INT; if mode bit 2 is set, minimum precision is FL; if mode bit 3 is set, +// minimum precision is CMPX Result is a new buffer, always +auto +jtbcvt(J jt, C mode, array w) -> array { + FPREFIP; + if (w == nullptr) { return nullptr; } + + auto const as_integer = [](auto const &v) { return *(int64_t *)&v; }; + auto const isflag = [&](auto const &z) { return as_integer(z.im) == NANFLAG; }; + + // there may be values (especially b types) that were nominally CMPX but might actually be integers. Those were + // stored with the real part being the actual integer value and the imaginary part as the special 'flag' value. We + // handle those here. If all the imaginary parts were flags, we accept all the integer parts and change the type + // to integer. If none of the imaginary parts were flags, we leave the input unchanged. If some were flags, we + // convert the flagged values to float and keep the result as complex + array result = w; + if ((((AN(w) - 1) | ((AT(w) & CMPX) - 1))) >= 0) { // not empty AND complex + Z *wv = pointer_to_values(w); + // FIXME: get proper c++17 support + // auto flags = std::transform_reduce(wv, wv + AN(w), int64_t{}, std::plus{}, isflag); + auto flags = std::accumulate(wv, wv + AN(w), int64_t{}, [&](auto sum, auto v) { return sum + isflag(v); }); + if (flags != 0) { + int64_t ipok = SGNIF(jtinplace, JTINPLACEWX) & AC(w); // both sign bits set (<0) if inplaceable + if (flags == AN(w)) { + if (ipok >= 0) GATV(result, INT, AN(w), AR(w), AS(w)); + std::transform( + wv, wv + AN(w), pointer_to_values(result), [&](auto const &z) { return as_integer(z.re); }); + } else { + if (ipok >= 0) GATV(result, CMPX, AN(w), AR(w), AS(w)); + std::transform(wv, wv + AN(w), pointer_to_values(result), [&](auto const &z) -> Z { + if (isflag(z)) { return {.re = (double)as_integer(z.re), .im = 0.0}; }; + return z; // copy floats, and converts any integers back to float + }); + } + w = result; // this result is now eligible for further demotion + } + } + // for all numerics, try Boolean/int/float in order, stopping when we find one that holds the data + if (((mode & 1) != 0) || ((AT(w) & (XNUM + RAT)) == 0)) { // if we are not stopping at XNUM/RAT + // To avoid a needless copy, suppress conversion to B01 if type is B01, to INT if type is INT, etc + // set the NOFUZZ flag in jt to insist on an exact match so we won't lose precision + array y = nullptr; + jtinplace = (J)((int64_t)jt + JTNOFUZZ); // demand exact match + result = ((mode & 14) == 0) && jtccvt(jtinplace, B01, w, &y) ? y + : (y = w, AT(w) & INT || (((mode & 12) == 0) && jtccvt(jtinplace, INT, w, &y))) ? y + : (y = w, AT(w) & FL || (((mode & 8) == 0) && jtccvt(jtinplace, FL, w, &y))) + ? y + : w; // convert to enabled modes one by one, stopping when one works + } + RNE(result); +} /* convert to lowest type. 0=mode: don't convert XNUM/RAT to other types */ + +auto +jticvt(J jt, array w) -> array { + array z = nullptr; + GATV(z, INT, AN(w), AR(w), AS(w)); + return convert( + jt, w, pointer_to_values(z), [](auto x) { return value_if(IMIN <= x && x < FLIMAX, x); }) + ? z + : w; // if conversion will fail, skip it +} + +auto +jtpcvt(J jt, int64_t t, array w) -> array { + RANK2T oqr = jt->ranks; + RESETRANK; + array y = nullptr; + bool const b = jtccvt(jt, t, w, &y); + jt->ranks = oqr; + return b ? y : w; +} /* convert w to type t, if possible, otherwise just return w */ + +auto +jtcvt0(J jt, array w) -> array { + auto const t = AT(w); + auto const n = (t & CMPX) != 0 ? 2 * AN(w) : AN(w); + if ((n != 0) && ((t & (FL + CMPX)) != 0)) { + auto *u = pointer_to_values(w); + std::transform(u, u + n, u, [](auto v) { return v == 0.0 ? 0.0 : v; }); + } + return w; +} /* convert -0 to 0 in place */ + +auto +jtxco1(J jt, array w) -> array { + ASSERT(AT(w) & DENSE, EVNONCE); + return jtcvt(jt, AT(w) & (B01 + INT + XNUM) ? XNUM : RAT, w); +} + +auto +jtxco2(J jt, array a, array w) -> array { + ASSERT(AT(w) & DENSE, EVNONCE); + int64_t j = jti0(jt, a); + if (jt->jerr != 0) return nullptr; + switch (j) { + case -2: return jtaslash1(jt, CDIV, w); + case -1: return jtbcvt(jt, 1, w); + case 1: return jtxco1(jt, w); + case 2: + if ((AT(w) & RAT) == 0) { + w = jtcvt(jt, RAT, w); + if (!w) return nullptr; + } + { + auto const n = AN(w); + auto const r = AR(w); + array z = nullptr; + GATV(z, XNUM, 2 * n, r + 1, AS(w)); + AS(z)[r] = 2; + memcpy(pointer_to_values(z), pointer_to_values(w), 2 * n * SZI); + return z; + } + default: ASSERT(0, EVDOMAIN); + } +} diff --git a/jsrc/j.h b/jsrc/j.h index 7a3a6dfa..95244680 100644 --- a/jsrc/j.h +++ b/jsrc/j.h @@ -3,6 +3,12 @@ /* */ /* Global Definitions */ +#ifdef __cplusplus +extern "C" { +#else +#include +#endif + #if defined(__clang_major__) && !defined(__clang__) #error need workaround by define __clang__ in preprocessor macro #endif @@ -1135,3 +1141,7 @@ _clearfp(void) { // Create (x&y) where x and y are signed, so we can test for overflow. #define XANDY(x, y) ((I)((UI)(x) & (UI)(y))) + +#ifdef __cplusplus +} +#endif diff --git a/jsrc/je.h b/jsrc/je.h index 080705df..daac60a3 100644 --- a/jsrc/je.h +++ b/jsrc/je.h @@ -550,8 +550,8 @@ extern I jtcountnl(J); extern A jtcreatecycliciterator(J, A, A); extern A jtcrelocalsyms(J, A, A, I, I, I); extern A jtcstr(J, C*); -extern A jtcvt(J, I, A); -extern B jtccvt(J, I, A, A*); +extern A jtcvt(J, int64_t, A); +extern bool jtccvt(J, int64_t, A, A*); extern A jtcvz(J, I, A); extern A jtdaxis(J, I, A); extern A jtddtokens(J, A, I); @@ -640,7 +640,7 @@ extern A jtparsea(J, A*, I); extern B jtparseinit(J); extern A jtparsex(J, A*, I, CW*, DC); extern A jtpaxis(J, I, A); -extern A jtpcvt(J, I, A); +extern A jtpcvt(J, int64_t, A); extern A jtpee(J, A*, CW*, I, I, DC); extern A jtpfill(J, I, A); extern A jtpind(J, I, A); diff --git a/jsrc/k.c b/jsrc/k.c deleted file mode 100644 index 72f90692..00000000 --- a/jsrc/k.c +++ /dev/null @@ -1,733 +0,0 @@ -/* Copyright 1990-2010, Jsoftware Inc. All rights reserved. */ -/* Licensed use only. Any other use is in violation of copyright. */ -/* */ -/* Conversions Amongst Internal Types */ - -#include "j.h" -#include "verbs/vcomp.h" - -#define CVCASE(a, b) (((a) << 3) + (b)) // The main cases fit in low 8 bits of mask - -// FIEQ are used in bcvt, where FUZZ may be set to 0 to ensure only exact values are demoted to lower precision -#define FIEQ(u, v, fuzz) \ - (ABS((u) - (v)) <= \ - fuzz * \ - ABS(v)) // used when v is known to be exact integer. It's close enough, maybe ULP too small on the high end - -static B -jtC1fromC2(J jt, A w, void *yv) { - UC *x; - US c, *v; - v = USAV(w); - x = (C *)yv; - DQ(AN(w), c = *v++; if (!(256 > c)) return 0; *x++ = (UC)c;); - return 1; -} - -static B -jtC2fromC1(J jt, A w, void *yv) { - UC *v; - US *x; - v = UAV(w); - x = (US *)yv; - DQ(AN(w), *x++ = *v++;); - return 1; -} - -static B -jtC1fromC4(J jt, A w, void *yv) { - UC *x; - C4 c, *v; - v = C4AV(w); - x = (C *)yv; - DQ(AN(w), c = *v++; if (!(256 > c)) return 0; *x++ = (UC)c;); - return 1; -} - -static B -jtC2fromC4(J jt, A w, void *yv) { - US *x; - C4 c, *v; - v = C4AV(w); - x = (US *)yv; - DQ(AN(w), c = *v++; if (!(65536 > c)) return 0; *x++ = (US)c;); - return 1; -} - -static B -jtC4fromC1(J jt, A w, void *yv) { - UC *v; - C4 *x; - v = UAV(w); - x = (C4 *)yv; - DQ(AN(w), *x++ = *v++;); - return 1; -} - -static B -jtC4fromC2(J jt, A w, void *yv) { - US *v; - C4 *x; - v = USAV(w); - x = (C4 *)yv; - DQ(AN(w), *x++ = *v++;); - return 1; -} - -static B -jtBfromI(J jt, A w, void *yv) { - B *x; - I n, p, *v; - n = AN(w); - v = AV(w); - x = (B *)yv; - DQ(n, p = *v++; *x++ = (B)p; if (p & -2) return 0;); - return 1; -} - -static B -jtBfromD(J jt, A w, void *yv, D fuzz) { - B *x; - D p, *v; - I n; - n = AN(w); - v = DAV(w); - x = (B *)yv; - DQ(n, p = *v++; if (p < -2 || 2 < p) return 0; // handle infinities - I val = 2; - val = (p == 0) ? 0 : val; - val = FIEQ(p, 1.0, fuzz) ? 1 : val; - if (val == 2) return 0; - *x++ = (B)val;) - return 1; -} - -static B -jtIfromD(J jt, A w, void *yv, D fuzz) { - D p, q, *v; - I i, k = 0, n, *x; - n = AN(w); - v = DAV(w); - x = (I *)yv; - for (i = 0; i < n; ++i) { - p = v[i]; - q = jround(p); - I rq = (I)q; - if (!(p == q || FIEQ(p, q, fuzz))) return 0; // must equal int, possibly out of range - // out-of-range values don't convert, handle separately - if (p < (D)IMIN) { - if (!(p >= IMIN * (1 + fuzz))) return 0; - rq = IMIN; - } // if tolerantly < IMIN, error; else take IMIN - else if (p >= FLIMAX) { - if (!(p <= -(D)IMIN * (1 + fuzz))) return 0; - rq = IMAX; - } // if tolerantly > IMAX, error; else take IMAX - *x++ = rq; - } - return 1; -} - -static B -jtDfromZ(J jt, A w, void *yv, D fuzz) { - D d, *x; - I n; - Z *v; - n = AN(w); - v = ZAV(w); - x = (D *)yv; - if (fuzz) - DQ( - n, d = ABS(v->im); if (d != inf && d <= fuzz * ABS(v->re)) { - *x++ = v->re; - v++; - } else return 0;) - else - DQ( - n, d = v->im; if (!d) { - *x++ = v->re; - v++; - } else return 0;); - return 1; -} - -static B -jtXfromB(J jt, A w, void *yv) { - B *v; - I n, u[1]; - X *x; - n = AN(w); - v = BAV(w); - x = (X *)yv; - DO(n, *u = v[i]; x[i] = jtvec(jt, INT, 1L, u);); - return !jt->jerr; -} - -static B -jtXfromI(J jt, A w, void *yv) { - B b; - I c, d, i, j, n, r, u[XIDIG], *v; - X *x; - n = AN(w); - v = AV(w); - x = (X *)yv; - for (i = 0; i < n; ++i) { - c = v[i]; - b = c == IMIN; - d = b ? -(1 + c) : ABS(c); - j = 0; - DO(XIDIG, u[i] = r = d % XBASE; d = d / XBASE; if (r) j = i;); - ++j; - *u += b; - if (0 > c) DO(XIDIG, u[i] = -u[i];); - x[i] = jtvec(jt, INT, j, u); - } - return !jt->jerr; -} - -static X -jtxd1(J jt, D p, I mode) { - PROLOG(0052); - A t; - D d, e = jttfloor(jt, p), q, r; - I m, *u; - switch (mode) { - case XMFLR: p = e; break; - case XMCEIL: p = ceil(p); break; - case XMEXACT: - ASSERT(TEQ(p, e), EVDOMAIN); - p = e; - break; - case XMEXMT: - if (!TEQ(p, e)) return jtvec(jt, INT, 0L, &iotavec[-IOTAVECBEGIN]); - } - if (p == inf) return jtvci(jt, XPINF); - if (p == -inf) return jtvci(jt, XNINF); - GAT0(t, INT, 30, 1); - u = AV(t); - m = 0; - d = ABS(p); - while (0 < d) { - q = floor(d / XBASE); - r = d - q * XBASE; - u[m++] = (I)r; - d = q; - if (m == AN(t)) { - RZ(t = jtext(jt, 0, t)); - u = AV(t); - } - } - if (!m) { - u[0] = 0; - ++m; - } else if (0 > p) - DO(m, u[i] = -u[i];); - A z = jtxstd(jt, jtvec(jt, INT, m, u)); - EPILOG(z); -} - -static B -jtXfromD(J jt, A w, void *yv, I mode) { - D *v = DAV(w); - X *x = (X *)yv; - DO(AN(w), x[i] = jtxd1(jt, v[i], mode);); - return !jt->jerr; -} - -static B -jtBfromX(J jt, A w, void *yv) { - A q; - B *x; - I e; - X *v; - v = XAV(w); - x = (B *)yv; - DO(AN(w), q = v[i]; e = AV(q)[0]; if ((AN(q) ^ 1) | (e & -2)) return 0; x[i] = (B)e;); - return 1; -} - -static B -jtIfromX(J jt, A w, void *yv) { - I a, i, m, n, *u, *x; - X c, p, q, *v; - v = XAV(w); - x = (I *)yv; - n = AN(w); - if (!(p = jtxc(jt, IMAX))) return 0; - if (!(q = jtxminus(jt, jtnegate(jt, p), jtxc(jt, 1L)))) return 0; - for (i = 0; i < n; ++i) { - c = v[i]; - if (!(1 != jtxcompare(jt, q, c) && 1 != jtxcompare(jt, c, p))) return 0; - m = AN(c); - u = AV(c) + m - 1; - a = 0; - DO(m, a = *u-- + a * XBASE;); - x[i] = a; - } - return 1; -} - -static B -jtDfromX(J jt, A w, void *yv) { - D d, *x = (D *)yv /*,dm,dp*/; - I c, i, n, *v, wn; - X p, *wv; - // dp=1.7976931348623157e308; dm=-dp; - wn = AN(w); - wv = XAV(w); - for (i = 0; i < wn; ++i) { - p = wv[i]; - n = AN(p); - v = AV(p) + n - 1; - c = *v; - if (c == XPINF) - d = inf; - else if (c == XNINF) - d = infm; - else { - d = 0.0; - DQ(n, d = *v-- + d * XBASE;); - } - x[i] = d; - } - return 1; -} - -static B -jtQfromX(J jt, A w, void *yv) { - X *v = XAV(w), *x = (X *)yv; - DQ(AN(w), *x++ = *v++; *x++ = iv1;); - return 1; -} - -static B -jtQfromD(J jt, A w, void *yv, I mode) { - B neg, recip; - D c, d, t, *wv; - I e, i, n, *v; - Q q, *x; - S *tv; - if (!(w)) return 0; - n = AN(w); - wv = DAV(w); - x = (Q *)yv; - tv = 3 + (S *)&t; - for (i = 0; i < n; ++i) { - t = wv[i]; - ASSERT(!_isnan(t), EVNAN); - if (neg = 0 > t) t = -t; - q.d = iv1; - if (t == inf) - q.n = jtvci(jt, XPINF); - else if (t == 0.0) - q.n = iv0; - else if (1.1102230246251565e-16 < t && t < 9.007199254740992e15) { - d = jround(1 / jtdgcd(jt, 1.0, t)); - c = jround(d * t); - q.n = jtxd1(jt, c, mode); - q.d = jtxd1(jt, d, mode); - q = jtqstd(jt, q); - } else { - if (recip = 1 > t) t = 1.0 / t; - e = (I)(0xfff0 & *tv); - e >>= 4; - e -= 1023; - if (recip) { - q.d = jtxtymes(jt, jtxd1(jt, t / pow(2.0, e - 53.0), mode), jtxpow(jt, jtxc(jt, 2L), jtxc(jt, e - 53))); - q.n = jtca(jt, iv1); - } else { - q.n = jtxtymes(jt, jtxd1(jt, t / pow(2.0, e - 53.0), mode), jtxpow(jt, jtxc(jt, 2L), jtxc(jt, e - 53))); - q.d = jtca(jt, iv1); - } - } - if (neg) { - v = AV(q.n); - DQ(AN(q.n), *v = -*v; ++v;); - } - *x++ = q; - } - return !jt->jerr; -} - -static B -jtDfromQ(J jt, A w, void *yv) { - D d, f, n, *x, xb = (D)XBASE; - I cn, i, k, m, nn, pn, qn, r, *v, wn; - Q *wv; - X c, p, q, x2 = 0; - wn = AN(w); - wv = QAV(w); - x = (D *)yv; - nn = 308 / XBASEN; - for (i = 0; i < wn; ++i) { - p = wv[i].n; - pn = AN(p); - k = 1 == pn ? AV(p)[0] : 0; - q = wv[i].d; - qn = AN(q); - if (k == XPINF) - x[i] = inf; - else if (k == XNINF) - x[i] = infm; - else if (pn <= nn && qn <= nn) { - n = 0.0; - f = 1.0; - v = AV(p); - DO(pn, n += f * v[i]; f *= xb;); - d = 0.0; - f = 1.0; - v = AV(q); - DO(qn, d += f * v[i]; f *= xb;); - x[i] = n / d; - } else { - k = 5 + qn; - if (!x2) - if (!(x2 = jtxc(jt, 2L))) return 0; - if (!(c = jtxdiv(jt, jttake(jt, jtsc(jt, -(k + pn)), p), q, XMFLR))) return 0; - cn = AN(c); - m = MIN(cn, 5); - r = cn - (m + k); - v = AV(c) + cn - m; - n = 0.0; - f = 1.0; - DO(m, n += f * v[i]; f *= xb;); - d = 1.0; - DQ(ABS(r), d *= xb;); - x[i] = 0 > r ? n / d : n * d; - } - } - return 1; -} - -static B -jtXfromQ(J jt, A w, void *yv) { - Q *v; - X *x; - v = QAV(w); - x = (X *)yv; - DQ(AN(w), if (!(jtequ(jt, iv1, v->d))) return 0; *x++ = v->n; ++v;); - return !jt->jerr; -} - -// Imaginary parts have already been cleared -static B -jtZfromD(J jt, A w, void *yv) { - D *wv = DAV(w); - Z *zv = yv; - DQ(AN(w), zv++->re = *wv++;) return 1; -} - -// Convert the data in w to the type t. w and t must be noun types. A new buffer is always created (with a -// copy of the data if w is already of the right type), and returned in *y. Result is -// 0 if error, 1 if success. If the conversion loses precision, error is returned -// Calls through bcvt are tagged with a flag in jt, indicating to set fuzz=0 -B -jtccvt(J jt, I tflagged, A w, A *y) { - FPREFIP; - A d; - I n, r, *s, wt; - void *wv, *yv; - I t = tflagged & NOUN; - if (!w) return 0; - r = AR(w); - s = AS(w); - if (((t | AT(w)) & SPARSE) != 0) { - // Handle sparse - RANK2T oqr = jt->ranks; - RESETRANK; - switch ((t & SPARSE ? 2 : 0) + (AT(w) & SPARSE ? 1 : 0)) { - I t1; - P *wp, *yp; - case 1: RZ(w = jtdenseit(jt, w)); break; // sparse to dense - case 2: - RZ(*y = jtsparseit(jt, jtcvt(jt, DTYPE(t), w), IX(r), jtcvt(jt, DTYPE(t), jfalse))); - jt->ranks = oqr; - return 1; // dense to sparse; convert type first (even if same dtype) - case 3: // sparse to sparse - t1 = DTYPE(t); - GASPARSE(*y, t, 1, r, s); - yp = PAV(*y); - wp = PAV(w); - SPB(yp, a, jtca(jt, SPA(wp, a))); - SPB(yp, i, jtca(jt, SPA(wp, i))); - SPB(yp, e, jtcvt(jt, t1, SPA(wp, e))); - SPB(yp, x, jtcvt(jt, t1, SPA(wp, x))); - jt->ranks = oqr; - return 1; - } - jt->ranks = oqr; - } - // Now known to be non-sparse - n = AN(w); - wt = AT(w); - // If type is already correct, return a clone - used to force a copy. Should get rid of this kludge - if (TYPESEQ(t, wt)) { - RZ(*y = jtca(jt, w)); - return 1; - } - // else if(n&&t&JCHAR){ASSERT(HOMO(t,wt),EVDOMAIN); RZ(*y=jtuco1(jt,w)); return 1;} - // Kludge on behalf of result assembly: we want to be able to stop converting after the valid cells. If - // NOUNCVTVALIDCT is set in the type, we use the input *y as as override on the # cells to convert. We use it to - // replace n (for use here) and yv, and AK(w) and AN(w) for the subroutines. If NOUNCVTVALIDCT is set, w is - // modified: the caller must restore AN(w) and AK(w) if it needs it - // TODO: same-length conversion could be done in place - GA(d, t, n, r, s); - yv = voidAV(d); // allocate the same # atoms, even if we will convert fewer - if (tflagged & NOUNCVTVALIDCT) { - I inputn = *(I *)y; // fetch input, in case it is called for - if (inputn > 0) { // if converting the leading values, just update the counts - n = inputn; // set the counts for local use, and in the block to be converted - } else { // if converting trailing values... - I offset = (n + inputn) << bplg(t); // byte offset to start of data - AK(w) += (n + inputn) << bplg(wt); - yv = (I *)((C *)yv + ((n + inputn) << bplg(t))); // advance input and output pointers to new area - n = -inputn; // get positive # atoms to convert - } - AN(w) = n; // change atomct of w to # atoms to convert - } - // If n and AN have been modified, it doesn't matter for rank-1 arguments whether the shape of the result is listed - // as n or s[0] since only n atoms will be used. For higher ranks, we need the shape from s. So it's just as well - // that we take the shape from s now - *y = d; - wv = voidAV(w); // return the address of the new block - if (t & CMPX) jtfillv(jt, t, n, (C *)yv); // why?? just fill in imaginary parts as we need to - if (!n) return 1; - // Perform the conversion based on data types - // For branch-table efficiency, we split the C2T and C4T and BIT conversions into one block, and - // the rest in another - if ((t | wt) & - (C2T + C4T + BIT + SBT)) { // there are no SBT conversions, but we have to show domain error - // we must account for all NOUN types. Low 8 bits have most of them, and we know type can't be sparse. This - // picks up the others - ASSERT(!((t | wt) & SBT), EVDOMAIN); // No conversions for these types - switch (CVCASE(CTTZ(t), CTTZ(wt))) { - case CVCASE(LITX, C2TX): return jtC1fromC2(jt, w, yv); - case CVCASE(LITX, C4TX): return jtC1fromC4(jt, w, yv); - case CVCASE(C2TX, LITX): return jtC2fromC1(jt, w, yv); - case CVCASE(C2TX, C4TX): return jtC2fromC4(jt, w, yv); - case CVCASE(C4TX, LITX): return jtC4fromC1(jt, w, yv); - case CVCASE(C4TX, C2TX): return jtC4fromC2(jt, w, yv); - default: ASSERT(0, EVDOMAIN); - } - } - switch (CVCASE(CTTZ(t), CTTZ(wt))) { - case CVCASE(INTX, B01X): { - I *x = yv; - B *v = (B *)wv; - DQ(n, *x++ = *v++;); - } - return 1; - case CVCASE(XNUMX, B01X): return jtXfromB(jt, w, yv); - case CVCASE(RATX, B01X): GATV(d, XNUM, n, r, s); return jtXfromB(jt, w, AV(d)) && jtQfromX(jt, d, yv); - case CVCASE(FLX, B01X): { - D *x = (D *)yv; - B *v = (B *)wv; - DQ(n, *x++ = *v++;); - } - return 1; - case CVCASE(CMPXX, B01X): { - Z *x = (Z *)yv; - B *v = (B *)wv; - DQ(n, x++->re = *v++;); - } - return 1; - case CVCASE(B01X, INTX): return jtBfromI(jt, w, yv); - case CVCASE(XNUMX, INTX): return jtXfromI(jt, w, yv); - case CVCASE(RATX, INTX): GATV(d, XNUM, n, r, s); return jtXfromI(jt, w, AV(d)) && jtQfromX(jt, d, yv); - case CVCASE(FLX, INTX): { - D *x = (D *)yv; - I *v = wv; - DQ(n, *x++ = (D)*v++;); - } - return 1; - case CVCASE(CMPXX, INTX): { - Z *x = (Z *)yv; - I *v = wv; - DQ(n, x++->re = (D)*v++;); - } - return 1; - case CVCASE(B01X, FLX): return jtBfromD(jt, w, yv, (I)jtinplace & JTNOFUZZ ? 0.0 : FUZZ); - case CVCASE(INTX, FLX): return jtIfromD(jt, w, yv, (I)jtinplace & JTNOFUZZ ? 0.0 : FUZZ); - case CVCASE(XNUMX, FLX): - return jtXfromD(jt, w, yv, (jt->xmode & REPSGN(SGNIFNOT(tflagged, XCVTXNUMORIDEX))) | (tflagged >> XCVTXNUMCVX)); - case CVCASE(RATX, FLX): - return jtQfromD(jt, w, yv, (jt->xmode & REPSGN(SGNIFNOT(tflagged, XCVTXNUMORIDEX))) | (tflagged >> XCVTXNUMCVX)); - case CVCASE(CMPXX, FLX): return jtZfromD(jt, w, yv); - case CVCASE(B01X, CMPXX): - GATV(d, FL, n, r, s); - if (!(jtDfromZ(jt, w, AV(d), (I)jtinplace & JTNOFUZZ ? 0.0 : FUZZ))) return 0; - return jtBfromD(jt, d, yv, (I)jtinplace & JTNOFUZZ ? 0.0 : FUZZ); - case CVCASE(INTX, CMPXX): - GATV(d, FL, n, r, s); - if (!(jtDfromZ(jt, w, AV(d), (I)jtinplace & JTNOFUZZ ? 0.0 : FUZZ))) return 0; - return jtIfromD(jt, d, yv, (I)jtinplace & JTNOFUZZ ? 0.0 : FUZZ); - case CVCASE(XNUMX, CMPXX): - GATV(d, FL, n, r, s); - if (!(jtDfromZ(jt, w, AV(d), (I)jtinplace & JTNOFUZZ ? 0.0 : FUZZ))) return 0; - return jtXfromD(jt, d, yv, (jt->xmode & REPSGN(SGNIFNOT(tflagged, XCVTXNUMORIDEX))) | (tflagged >> XCVTXNUMCVX)); - case CVCASE(RATX, CMPXX): - GATV(d, FL, n, r, s); - if (!(jtDfromZ(jt, w, AV(d), (I)jtinplace & JTNOFUZZ ? 0.0 : FUZZ))) return 0; - return jtQfromD(jt, d, yv, (jt->xmode & REPSGN(SGNIFNOT(tflagged, XCVTXNUMORIDEX))) | (tflagged >> XCVTXNUMCVX)); - case CVCASE(FLX, CMPXX): return jtDfromZ(jt, w, yv, (I)jtinplace & JTNOFUZZ ? 0.0 : FUZZ); - case CVCASE(B01X, XNUMX): return jtBfromX(jt, w, yv); - case CVCASE(INTX, XNUMX): return jtIfromX(jt, w, yv); - case CVCASE(RATX, XNUMX): return jtQfromX(jt, w, yv); - case CVCASE(FLX, XNUMX): return jtDfromX(jt, w, yv); - case CVCASE(CMPXX, XNUMX): - GATV(d, FL, n, r, s); - if (!(jtDfromX(jt, w, AV(d)))) return 0; - return jtZfromD(jt, d, yv); - case CVCASE(B01X, RATX): - GATV(d, XNUM, n, r, s); - if (!(jtXfromQ(jt, w, AV(d)))) return 0; - return jtBfromX(jt, d, yv); - case CVCASE(INTX, RATX): - GATV(d, XNUM, n, r, s); - if (!(jtXfromQ(jt, w, AV(d)))) return 0; - return jtIfromX(jt, d, yv); - case CVCASE(XNUMX, RATX): return jtXfromQ(jt, w, yv); - case CVCASE(FLX, RATX): return jtDfromQ(jt, w, yv); - case CVCASE(CMPXX, RATX): - GATV(d, FL, n, r, s); - if (!(jtDfromQ(jt, w, AV(d)))) return 0; - return jtZfromD(jt, d, yv); - default: ASSERT(0, EVDOMAIN); - } -} - -// clear rank before calling ccvt - needed for sparse arrays only but returns the block as the result -A -jtcvt(J jt, I t, A w) { - A y; - B b; - b = jtccvt(jt, t, w, &y); - ASSERT(b != 0, EVDOMAIN); - return y; -} - -// Convert numeric type to lowest precision that fits. Push fuzz/rank onto a stack, -// and use 'exact' and 'no rank' for them. If mode=0, do not promote XNUM/RAT to fixed-length types. -// If mode bit 1 is set, minimum precision is INT; if mode bit 2 is set, minimum precision is FL; if mode bit 3 is set, -// minimum precision is CMPX Result is a new buffer, always -A -jtbcvt(J jt, C mode, A w) { - FPREFIP; - A y, z = w; - if (!w) return 0; -#ifdef NANFLAG - // there may be values (especially b types) that were nominally CMPX but might actually be integers. Those were - // stored with the real part being the actual integer value and the imaginary part as the special 'flag' value. We - // handle those here. If all the imaginary parts were flags, we accept all the integer parts and change the type - // to integer. If none of the imaginary parts were flags, we leave the input unchanged. If some were flags, we - // convert the flagged values to float and keep the result as complex - if ((((AN(w) - 1) | (AT(w) & CMPX) - 1)) >= 0) { // not empty AND complex - I allflag = 1, anyflag = 0; - Z *wv = ZAV(w); - DO(AN(w), I isflag = *(I *)&wv[i].im == NANFLAG; allflag &= isflag; anyflag |= isflag;) - if (anyflag) { - I ipok = SGNIF(jtinplace, JTINPLACEWX) & AC(w); // both sign bits set (<0) if inplaceable - if (allflag) { - if (ipok >= 0) GATV(z, INT, AN(w), AR(w), AS(w)); - I *zv = IAV(z); // output area - DO(AN(w), zv[i] = *(I *)&wv[i].re;) // copy the results as integers - } else { - if (ipok >= 0) GATV(z, CMPX, AN(w), AR(w), AS(w)); - Z *zv = ZAV(z); // output area - DO( - AN(w), - if (*(I *)&wv[i].im == NANFLAG) { - zv[i].re = (D) * (I *)&wv[i].re; - zv[i].im = 0.0; - } else { zv[i] = wv[i]; }) // copy floats, and converts any integers back to float - } - w = z; // this result is now eligible for further demotion - } - } -#endif - // for all numerics, try Boolean/int/float in order, stopping when we find one that holds the data - if (mode & 1 || !(AT(w) & XNUM + RAT)) { // if we are not stopping at XNUM/RAT - // To avoid a needless copy, suppress conversion to B01 if type is B01, to INT if type is INT, etc - // set the NOFUZZ flag in jt to insist on an exact match so we won't lose precision - jtinplace = (J)((I)jt + JTNOFUZZ); // demand exact match - z = !(mode & 14) && jtccvt(jtinplace, B01, w, &y) ? y - : (y = w, AT(w) & INT || (!(mode & 12) && jtccvt(jtinplace, INT, w, &y))) ? y - : (y = w, AT(w) & FL || (!(mode & 8) && jtccvt(jtinplace, FL, w, &y))) - ? y - : w; // convert to enabled modes one by one, stopping when one works - } - RNE(z); -} /* convert to lowest type. 0=mode: don't convert XNUM/RAT to other types */ - -A -jticvt(J jt, A w) { - A z; - D *v, x; - I i, n, *u; - n = AN(w); - v = DAV(w); - GATV(z, INT, n, AR(w), AS(w)); - u = AV(z); - for (i = 0; i < n; ++i) { - x = *v++; - if (x < IMIN || FLIMAX <= x) return w; // if conversion will fail, skip it - *u++ = (I)x; - } - return z; -} - -A -jtpcvt(J jt, I t, A w) { - A y; - B b; - RANK2T oqr = jt->ranks; - RESETRANK; - b = jtccvt(jt, t, w, &y); - jt->ranks = oqr; - return b ? y : w; -} /* convert w to type t, if possible, otherwise just return w */ - -A -jtcvt0(J jt, A w) { - I n, t; - D *u; - t = AT(w); - n = AN(w); - if (n && t & FL + CMPX) { - if (t & CMPX) n += n; - u = DAV(w); - DQ(n, if (*u == 0.0) *u = 0.0; ++u;); - } - return w; -} /* convert -0 to 0 in place */ - -A -jtxco1(J jt, A w) { - ASSERT(AT(w) & DENSE, EVNONCE); - return jtcvt(jt, AT(w) & B01 + INT + XNUM ? XNUM : RAT, w); -} - -A -jtxco2(J jt, A a, A w) { - A z; - B b; - I j, n, r, *s, t, *wv, *zu, *zv; - n = AN(w); - r = AR(w); - t = AT(w); - ASSERT(t & DENSE, EVNONCE); - RE(j = jti0(jt, a)); - switch (j) { - case -2: return jtaslash1(jt, CDIV, w); - case -1: return jtbcvt(jt, 1, w); - case 1: return jtxco1(jt, w); - case 2: - if (!(t & RAT)) RZ(w = jtcvt(jt, RAT, w)); - GATV(z, XNUM, 2 * n, r + 1, AS(w)); - AS(z)[r] = 2; - memcpy(AV(z), AV(w), 2 * n * SZI); - return z; - default: - ASSERT(0, EVDOMAIN); - } -}