diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 80cba0a7..12883523 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -667,6 +667,68 @@ [xs] (get xs (- (length xs) 1))) +## Polymorphic comparisons + +(defn compare-primitive + "Compare x and y using primitive operators. + Returns -1,0,1 for x < y, x = y, x > y respectively. + Present mostly for constructing 'compare' methods in prototypes." + [x y] + (cond + (= x y) 0 + (< x y) -1 + (> x y) 1)) + +(defn compare + "Polymorphic compare. Returns -1,0,1 for x < y, x = y, x > y respectively. + Differs from the primitive comparators in that it first checks to + see whether either x or y implement a 'compare' method which can + compare x and y. If so it uses that compare method. If not, it + delegates to the primitive comparators." + [x y] + (or + (when-let [f (get x :compare)] (f x y)) + (when-let [f (get y :compare) + fyx (f y x)] (- fyx)) + (compare-primitive x y))) + +(defn- compare-reduce [op xs] + (var r true) + (loop [i :range [0 (- (length xs) 1)] + :let [c (compare (xs i) (xs (+ i 1))) + ok (op c 0)] + :when (not ok)] + (set r false) + (break)) + r) + +(defn compare= + "Equivalent of '=' but using compare function instead of primitive comparator" + [& xs] + (compare-reduce = xs)) + +(defn compare< + "Equivalent of '<' but using compare function instead of primitive comparator" + [& xs] + (compare-reduce < xs)) + +(defn compare<= + "Equivalent of '<=' but using compare function instead of primitive comparator" + [& xs] + (compare-reduce <= xs)) + +(defn compare> + "Equivalent of '>' but using compare function instead of primitive comparator" + [& xs] + (compare-reduce > xs)) + +(defn compare>= + "Equivalent of '>=' but using compare function instead of primitive comparator" + [& xs] + (compare-reduce >= xs)) + +(put _env 'compare-reduce nil) + ### ### ### Indexed Combinators diff --git a/src/core/inttypes.c b/src/core/inttypes.c index 4afd6ba0..73e66118 100644 --- a/src/core/inttypes.c +++ b/src/core/inttypes.c @@ -197,6 +197,122 @@ static Janet cfun_it_u64_new(int32_t argc, Janet *argv) { return janet_wrap_u64(janet_unwrap_u64(argv[0])); } +// Code to support polymorphic comparison. +// +// int/u64 and int/s64 support a "compare" method that allows +// comparison to each other, and to Janet numbers, using the +// "compare" "compare<" ... functions. +// +// In the following code explicit casts are sometimes used to help +// make it clear when int/float conversions are happening. +// +static int64_t compare_double_double(double x, double y) { + return (x < y) ? -1 : ((x > y) ? 1 : 0); +} + +static int64_t compare_int64_double(int64_t x, double y) { + if (isnan(y)) { + return 0; // clojure and python do this + } else if ((y > ((double) - MAX_INT_IN_DBL)) && (y < ((double) MAX_INT_IN_DBL))) { + double dx = (double) x; + return compare_double_double(dx, y); + } else if (y > ((double) INT64_MAX)) { + return -1; + } else if (y < ((double) INT64_MIN)) { + return 1; + } else { + int64_t yi = (int64_t) y; + return (x < yi) ? -1 : ((x > yi) ? 1 : 0); + } +} + +static int64_t compare_uint64_double(uint64_t x, double y) { + if (isnan(y)) { + return 0; // clojure and python do this + } else if (y < 0) { + return 1; + } else if ((y >= 0) && (y < ((double) MAX_INT_IN_DBL))) { + double dx = (double) x; + return compare_double_double(dx, y); + } else if (y > ((double) UINT64_MAX)) { + return -1; + } else { + uint64_t yi = (uint64_t) y; + return (x < yi) ? -1 : ((x > yi) ? 1 : 0); + } +} + + +static Janet cfun_it_s64_compare(int32_t argc, Janet *argv) { + janet_fixarity(argc, 2); + if (janet_is_int(argv[0]) != JANET_INT_S64) + janet_panic("compare method requires int/s64 as first argument"); + int64_t x = janet_unwrap_s64(argv[0]); + switch (janet_type(argv[1])) { + default: + break; + case JANET_NUMBER : { + double y = janet_unwrap_number(argv[1]); + return janet_wrap_number(compare_int64_double(x, y)); + } + case JANET_ABSTRACT: { + void *abst = janet_unwrap_abstract(argv[1]); + if (janet_abstract_type(abst) == &janet_s64_type) { + int64_t y = *(int64_t *)abst; + return janet_wrap_number((x < y) ? -1 : (x > y ? 1 : 0)); + } else if (janet_abstract_type(abst) == &janet_u64_type) { + // comparing signed to unsigned -- be careful! + uint64_t y = *(uint64_t *)abst; + if (x < 0) { + return janet_wrap_number(-1); + } else if (y > INT64_MAX) { + return janet_wrap_number(-1); + } else { + int64_t y2 = (int64_t) y; + return janet_wrap_number((x < y2) ? -1 : (x > y2 ? 1 : 0)); + } + } + break; + } + } + return janet_wrap_nil(); +} + +static Janet cfun_it_u64_compare(int32_t argc, Janet *argv) { + janet_fixarity(argc, 2); + if (janet_is_int(argv[0]) != JANET_INT_U64) // is this needed? + janet_panic("compare method requires int/u64 as first argument"); + uint64_t x = janet_unwrap_u64(argv[0]); + switch (janet_type(argv[1])) { + default: + break; + case JANET_NUMBER : { + double y = janet_unwrap_number(argv[1]); + return janet_wrap_number(compare_uint64_double(x, y)); + } + case JANET_ABSTRACT: { + void *abst = janet_unwrap_abstract(argv[1]); + if (janet_abstract_type(abst) == &janet_u64_type) { + uint64_t y = *(uint64_t *)abst; + return janet_wrap_number((x < y) ? -1 : (x > y ? 1 : 0)); + } else if (janet_abstract_type(abst) == &janet_s64_type) { + // comparing unsigned to signed -- be careful! + int64_t y = *(int64_t *)abst; + if (y < 0) { + return janet_wrap_number(1); + } else if (x > INT64_MAX) { + return janet_wrap_number(1); + } else { + int64_t x2 = (int64_t) x; + return janet_wrap_number((x2 < y) ? -1 : (x2 > y ? 1 : 0)); + } + } + break; + } + } + return janet_wrap_nil(); +} + #define OPMETHOD(T, type, name, oper) \ static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ janet_arity(argc, 2, -1); \ @@ -266,14 +382,6 @@ static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ return janet_wrap_abstract(box); \ } \ -#define COMPMETHOD(T, type, name, oper) \ -static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ - janet_fixarity(argc, 2); \ - T v1 = janet_unwrap_##type(argv[0]); \ - T v2 = janet_unwrap_##type(argv[1]); \ - return janet_wrap_boolean(v1 oper v2); \ -} - static Janet cfun_it_s64_mod(int32_t argc, Janet *argv) { janet_arity(argc, 2, -1); int64_t *box = janet_abstract(&janet_s64_type, sizeof(int64_t)); @@ -316,13 +424,6 @@ OPMETHOD(int64_t, s64, or, |) OPMETHOD(int64_t, s64, xor, ^) OPMETHOD(int64_t, s64, lshift, <<) OPMETHOD(int64_t, s64, rshift, >>) -COMPMETHOD(int64_t, s64, lt, <) -COMPMETHOD(int64_t, s64, gt, >) -COMPMETHOD(int64_t, s64, le, <=) -COMPMETHOD(int64_t, s64, ge, >=) -COMPMETHOD(int64_t, s64, eq, ==) -COMPMETHOD(int64_t, s64, ne, !=) - OPMETHOD(uint64_t, u64, add, +) OPMETHOD(uint64_t, u64, sub, -) OPMETHODINVERT(uint64_t, u64, subi, -) @@ -336,18 +437,13 @@ OPMETHOD(uint64_t, u64, or, |) OPMETHOD(uint64_t, u64, xor, ^) OPMETHOD(uint64_t, u64, lshift, <<) OPMETHOD(uint64_t, u64, rshift, >>) -COMPMETHOD(uint64_t, u64, lt, <) -COMPMETHOD(uint64_t, u64, gt, >) -COMPMETHOD(uint64_t, u64, le, <=) -COMPMETHOD(uint64_t, u64, ge, >=) -COMPMETHOD(uint64_t, u64, eq, ==) -COMPMETHOD(uint64_t, u64, ne, !=) #undef OPMETHOD #undef DIVMETHOD #undef DIVMETHOD_SIGNED #undef COMPMETHOD + static JanetMethod it_s64_methods[] = { {"+", cfun_it_s64_add}, {"r+", cfun_it_s64_add}, @@ -361,12 +457,6 @@ static JanetMethod it_s64_methods[] = { {"rmod", cfun_it_s64_modi}, {"%", cfun_it_s64_rem}, {"r%", cfun_it_s64_remi}, - {"<", cfun_it_s64_lt}, - {">", cfun_it_s64_gt}, - {"<=", cfun_it_s64_le}, - {">=", cfun_it_s64_ge}, - {"=", cfun_it_s64_eq}, - {"!=", cfun_it_s64_ne}, {"&", cfun_it_s64_and}, {"r&", cfun_it_s64_and}, {"|", cfun_it_s64_or}, @@ -375,6 +465,7 @@ static JanetMethod it_s64_methods[] = { {"r^", cfun_it_s64_xor}, {"<<", cfun_it_s64_lshift}, {">>", cfun_it_s64_rshift}, + {"compare", cfun_it_s64_compare}, {NULL, NULL} }; @@ -392,12 +483,6 @@ static JanetMethod it_u64_methods[] = { {"rmod", cfun_it_u64_modi}, {"%", cfun_it_u64_mod}, {"r%", cfun_it_u64_modi}, - {"<", cfun_it_u64_lt}, - {">", cfun_it_u64_gt}, - {"<=", cfun_it_u64_le}, - {">=", cfun_it_u64_ge}, - {"=", cfun_it_u64_eq}, - {"!=", cfun_it_u64_ne}, {"&", cfun_it_u64_and}, {"r&", cfun_it_u64_and}, {"|", cfun_it_u64_or}, @@ -406,6 +491,7 @@ static JanetMethod it_u64_methods[] = { {"r^", cfun_it_u64_xor}, {"<<", cfun_it_u64_lshift}, {">>", cfun_it_u64_rshift}, + {"compare", cfun_it_u64_compare}, {NULL, NULL} }; diff --git a/src/core/os.c b/src/core/os.c index 471e6fd6..5b060b4a 100644 --- a/src/core/os.c +++ b/src/core/os.c @@ -1224,17 +1224,16 @@ static Janet os_rename(int32_t argc, Janet *argv) { static Janet os_realpath(int32_t argc, Janet *argv) { janet_fixarity(argc, 1); -#ifdef JANET_NO_REALPATH - (void) argv; - janet_panic("os/realpath not supported on this platform"); -#else const char *src = janet_getcstring(argv, 0); +#ifdef JANET_WINDOWS + char *dest = _fullpath(NULL, src, _MAX_PATH); +#else char *dest = realpath(src, NULL); +#endif if (NULL == dest) janet_panicf("%s: %s", strerror(errno), src); Janet ret = janet_cstringv(dest); free(dest); return ret; -#endif } static Janet os_permission_string(int32_t argc, Janet *argv) { diff --git a/src/core/peg.c b/src/core/peg.c index e05511fb..877338b6 100644 --- a/src/core/peg.c +++ b/src/core/peg.c @@ -206,6 +206,29 @@ tail: return (result) ? NULL : text; } + case RULE_THRU: + case RULE_TO: { + const uint32_t *rule_a = s->bytecode + rule[1]; + const uint8_t *next_text; + CapState cs = cap_save(s); + down1(s); + while (text < s->text_end) { + CapState cs2 = cap_save(s); + next_text = peg_rule(s, rule_a, text); + if (next_text) { + if (rule[0] == RULE_TO) cap_load(s, cs2); + break; + } + text++; + } + up1(s); + if (text >= s->text_end) { + cap_load(s, cs); + return NULL; + } + return rule[0] == RULE_TO ? text : next_text; + } + case RULE_BETWEEN: { uint32_t lo = rule[1]; uint32_t hi = rule[2]; @@ -765,6 +788,12 @@ static void spec_error(Builder *b, int32_t argc, const Janet *argv) { static void spec_drop(Builder *b, int32_t argc, const Janet *argv) { spec_onerule(b, argc, argv, RULE_DROP); } +static void spec_to(Builder *b, int32_t argc, const Janet *argv) { + spec_onerule(b, argc, argv, RULE_TO); +} +static void spec_thru(Builder *b, int32_t argc, const Janet *argv) { + spec_onerule(b, argc, argv, RULE_THRU); +} /* Rule of the form [rule, tag] */ static void spec_cap1(Builder *b, int32_t argc, const Janet *argv, uint32_t op) { @@ -895,6 +924,8 @@ static const SpecialPair peg_specials[] = { {"sequence", spec_sequence}, {"set", spec_set}, {"some", spec_some}, + {"thru", spec_thru}, + {"to", spec_to}, }; /* Compile a janet value into a rule and return the rule index. */ @@ -997,6 +1028,14 @@ static uint32_t peg_compile1(Builder *b, Janet peg) { const Janet *tup = janet_unwrap_tuple(peg); int32_t len = janet_tuple_length(tup); if (len == 0) peg_panic(b, "tuple in grammar must have non-zero length"); + if (janet_checkint(tup[0])) { + int32_t n = janet_unwrap_integer(tup[0]); + if (n < 0) { + peg_panicf(b, "expected non-negative integer, got %d", n); + } + spec_repeat(b, len, tup); + break; + } if (!janet_checktype(tup[0], JANET_SYMBOL)) peg_panicf(b, "expected grammar command, found %v", tup[0]); const uint8_t *sym = janet_unwrap_symbol(tup[0]); @@ -1180,6 +1219,8 @@ static void *peg_unmarshal(JanetMarshalContext *ctx) { case RULE_ERROR: case RULE_DROP: case RULE_NOT: + case RULE_TO: + case RULE_THRU: /* [rule] */ if (rule[1] >= blen) goto bad; op_flags[rule[1]] |= 0x01; diff --git a/src/include/janet.h b/src/include/janet.h index 38073228..a69cc6a3 100644 --- a/src/include/janet.h +++ b/src/include/janet.h @@ -138,11 +138,6 @@ extern "C" { #define JANET_NO_UTC_MKTIME #endif -/* Add some windows flags */ -#ifdef JANET_WINDOWS -#define JANET_NO_REALPATH -#endif - /* Define how global janet state is declared */ #ifdef JANET_SINGLE_THREADED #define JANET_THREAD_LOCAL @@ -1658,6 +1653,8 @@ typedef enum { RULE_ERROR, /* [rule] */ RULE_DROP, /* [rule] */ RULE_BACKMATCH, /* [tag] */ + RULE_TO, /* [rule] */ + RULE_THRU, /* [rule] */ RULE_LENPREFIX, /* [rule_a, rule_b (repeat rule_b rule_a times)] */ } JanetPegOpcode; diff --git a/test/suite0.janet b/test/suite0.janet index 606e2fb5..f5fa2a8b 100644 --- a/test/suite0.janet +++ b/test/suite0.janet @@ -334,5 +334,86 @@ (assert (deep= @{:a 3 :b 2} @{:a 1 :b 2 :a 3}) "table literal duplicate keys") (assert (deep= @{:a 3 :b 2} (table :a 1 :b 2 :a 3)) "table constructor duplicate keys") +## Polymorphic comparison -- Issue #272 + +# confirm polymorphic comparison delegation to primitive comparators: +(assert (= 0 (compare-primitive 3 3)) "compare-primitive integers (1)") +(assert (= -1 (compare-primitive 3 5)) "compare-primitive integers (2)") +(assert (= 1 (compare-primitive "foo" "bar")) "compare-primitive strings") +(assert (= 0 (compare 1 1)) "compare integers (1)") +(assert (= -1 (compare 1 2)) "compare integers (2)") +(assert (= 1 (compare "foo" "bar")) "compare strings (1)") + +(assert (compare< 1 2 3 4 5 6) "compare less than integers") +(assert (not (compare> 1 2 3 4 5 6)) "compare not greater than integers") +(assert (compare< 1.0 2.0 3.0 4.0 5.0 6.0) "compare less than reals") +(assert (compare> 6 5 4 3 2 1) "compare greater than integers") +(assert (compare> 6.0 5.0 4.0 3.0 2.0 1.0) "compare greater than reals") +(assert (not (compare< 6.0 5.0 4.0 3.0 2.0 1.0)) "compare less than reals") +(assert (compare<= 1 2 3 3 4 5 6) "compare less than or equal to integers") +(assert (compare<= 1.0 2.0 3.0 3.0 4.0 5.0 6.0) "compare less than or equal to reals") +(assert (compare>= 6 5 4 4 3 2 1) "compare greater than or equal to integers") +(assert (compare>= 6.0 5.0 4.0 4.0 3.0 2.0 1.0) "compare greater than or equal to reals") +(assert (compare< 1.0 nil false true + (fiber/new (fn [] 1)) + "hi" + (quote hello) + :hello + (array 1 2 3) + (tuple 1 2 3) + (table "a" "b" "c" "d") + (struct 1 2 3 4) + (buffer "hi") + (fn [x] (+ x x)) + print) "compare type ordering") + +# test polymorphic compare with 'objects' (table/setproto) +(def mynum + @{:type :mynum :v 0 :compare + (fn [self other] + (case (type other) + :number (compare-primitive (self :v) other) + :table (when (= (get other :type) :mynum) + (compare-primitive (self :v) (other :v)))))}) + +(let [n3 (table/setproto @{:v 3} mynum)] + (assert (= 0 (compare 3 n3)) "compare num to object (1)") + (assert (= -1 (compare n3 4)) "compare object to num (2)") + (assert (= 1 (compare (table/setproto @{:v 4} mynum) n3)) "compare object to object") + (assert (compare< 2 n3 4) "compare< poly") + (assert (compare> 4 n3 2) "compare> poly") + (assert (compare<= 2 3 n3 4) "compare<= poly") + (assert (compare= 3 n3 (table/setproto @{:v 3} mynum)) "compare= poly") + (assert (deep= (sorted @[4 5 n3 2] compare<) @[2 n3 4 5]) "polymorphic sort")) + +(let [ + MAX_INT_64_STRING "9223372036854775807" + MAX_UINT_64_STRING "18446744073709551615" + MAX_INT_IN_DBL_STRING "9007199254740991" + NAN (math/log -1) + INF (/ 1 0) + MINUS_INF (/ -1 0) + + compare-poly-tests + [ + [(int/s64 3) (int/u64 3) 0] + [(int/s64 -3) (int/u64 3) -1] + [(int/s64 3) (int/u64 2) 1] + [(int/s64 3) 3 0] [(int/s64 3) 4 -1] [(int/s64 3) -9 1] + [(int/u64 3) 3 0] [(int/u64 3) 4 -1] [(int/u64 3) -9 1] + [3 (int/s64 3) 0] [3 (int/s64 4) -1] [3 (int/s64 -5) 1] + [3 (int/u64 3) 0] [3 (int/u64 4) -1] [3 (int/u64 2) 1] + [(int/s64 MAX_INT_64_STRING) (int/u64 MAX_UINT_64_STRING) -1] + [(int/s64 MAX_INT_IN_DBL_STRING) (scan-number MAX_INT_IN_DBL_STRING) 0] + [(int/u64 MAX_INT_IN_DBL_STRING) (scan-number MAX_INT_IN_DBL_STRING) 0] + [(+ 1 (int/u64 MAX_INT_IN_DBL_STRING)) (scan-number MAX_INT_IN_DBL_STRING) 1] + [(int/s64 0) INF -1] [(int/u64 0) INF -1] + [MINUS_INF (int/u64 0) -1] [MINUS_INF (int/s64 0) -1] + [(int/s64 1) NAN 0] [NAN (int/u64 1) 0] + ]] + (each [x y c] compare-poly-tests + (assert (= c (compare x y)) (string/format "compare polymorphic %q %q %d" x y c))) + ) + (end-suite) diff --git a/test/suite8.janet b/test/suite8.janet index 7090c04e..71f1b0ff 100644 --- a/test/suite8.janet +++ b/test/suite8.janet @@ -288,4 +288,23 @@ neldb\0\0\0\xD8\x05printG\x01\0\xDE\xDE\xDE'\x03\0marshal_tes/\x02 # Issue #412 (assert (peg/match '(* "a" (> -1 "a") "b") "abc") "lookhead does not move cursor") +(def peg3 + ~{:main (* "(" (thru ")"))}) + +(def peg4 (peg/compile ~(* (thru "(") '(to ")")))) + +(assert (peg/match peg3 "(12345)") "peg thru 1") +(assert (not (peg/match peg3 " (12345)")) "peg thru 2") +(assert (not (peg/match peg3 "(12345")) "peg thru 3") + +(assert (= "abc" (0 (peg/match peg4 "123(abc)"))) "peg thru/to 1") +(assert (= "abc" (0 (peg/match peg4 "(abc)"))) "peg thru/to 2") +(assert (not (peg/match peg4 "123(abc")) "peg thru/to 3") + +(def peg5 (peg/compile [3 "abc"])) + +(assert (:match peg5 "abcabcabc") "repeat alias 1") +(assert (:match peg5 "abcabcabcac") "repeat alias 2") +(assert (not (:match peg5 "abcabc")) "repeat alias 3") + (end-suite)