Make negative indexing work like python.

This would break a lot of code :|

CHANGELOG.md

@@ -1,6 +1,15 @@
 # Changelog
 All notable changes to this project will be documented in this file.
 
+## Unreleased - ???
+- Add new string escape sequences `\\a`, `\\b`, `\\?`, and `\\'`.
+- Fix bug with marshalling channels
+- Add `div` for floored division
+- Make `div` and `mod` variadic
+- Support `bnot` for integer types.
+- Define `(mod x 0)` as `x`
+- Add `ffi/pointer-cfunction` to convert pointers to cfunctions
+
 ## 1.29.1 - 2023-06-19
 - Add support for passing booleans to PEGs for "always" and "never" matching.
 - Allow dictionary types for `take` and `drop`

src/boot/boot.janet

@@ -700,7 +700,7 @@
     4 (let [[f g h i] functions] (fn [& x] (f (g (h (i ;x))))))
     (let [[f g h i] functions]
       (comp (fn [x] (f (g (h (i x)))))
-            ;(tuple/slice functions 4 -1)))))
+            ;(tuple/slice functions 4)))))
 
 (defn identity
   "A function that returns its argument."
@@ -1208,7 +1208,7 @@
   (assert (symbol? alias) "alias must be a symbol")
   (assert (and (> (length alias) 2) (= 42 (first alias) (last alias))) "name must have leading and trailing '*' characters")
   (def prefix (dyn :defdyn-prefix))
-  (def kw (keyword prefix (slice alias 1 -2)))
+  (def kw (keyword prefix (slice alias 1 -1)))
   ~(def ,alias :dyn ,;more ,kw))
 
 (defn has-key?
@@ -1821,7 +1821,7 @@
   # Partition body into sections.
   (def oddlen (odd? (length cases)))
   (def else (if oddlen (last cases)))
-  (def patterns (partition 2 (if oddlen (slice cases 0 -2) cases)))
+  (def patterns (partition 2 (if oddlen (slice cases 0 -1) cases)))
 
   # Keep an array for accumulating the compilation output
   (def x-sym (if (idempotent? x) x (gensym)))
@@ -2052,7 +2052,7 @@
     (tuple/slice
       (array/concat
         @[(in t 0) (expand-bindings bound)]
-        (tuple/slice t 2 -2)
+        (tuple/slice t 2 -1)
         @[(recur last)])))
 
   (defn expandall [t]
@@ -2227,7 +2227,7 @@
   [name & body]
   (def expansion (apply defn name body))
   (def fbody (last expansion))
-  (def modifiers (tuple/slice expansion 2 -2))
+  (def modifiers (tuple/slice expansion 2 -1))
   (def metadata @{})
   (each m modifiers
     (cond
@@ -2917,7 +2917,7 @@
     (def buf @"")
     (with-dyns [*err* buf *err-color* false]
       (bad-parse x y))
-    (set exit-error (string/slice buf 0 -2)))
+    (set exit-error (string/slice buf 0 -1)))
   (defn bc [&opt x y z a b]
     (when exit
       (bad-compile x y z a b)
@@ -2926,7 +2926,7 @@
     (def buf @"")
     (with-dyns [*err* buf *err-color* false]
       (bad-compile x nil z a b))
-    (set exit-error (string/slice buf 0 -2))
+    (set exit-error (string/slice buf 0 -1))
     (set exit-fiber y))
   (unless f
     (error (string "could not find file " path)))
@@ -3520,6 +3520,24 @@
     (when-let [constants (dasm :constants)]
       (eprintf "  constants:  %.4q" constants))
     (eprintf "  slots:      %.4q\n" (frame :slots))
+    (when-let [src-path (in dasm :source)]
+      (when (and (fexists src-path)
+                 sourcemap)
+        (defn dump
+          [src cur]
+          (def offset 5)
+          (def beg (max 1 (- cur offset)))
+          (def lines (array/concat @[""] (string/split "\n" src)))
+          (def end (min (+ cur offset) (length lines)))
+          (def digits (inc (math/floor (math/log10 end))))
+          (def fmt-str (string "%" digits "d: %s"))
+          (for i beg end
+            (eprin " ") # breakpoint someday?
+            (eprin (if (= i cur) "> " "  "))
+            (eprintf fmt-str i (get lines i))))
+        (let [[sl _] (sourcemap pc)]
+          (dump (slurp src-path) sl)
+          (eprint))))
     (def padding (string/repeat " " 20))
     (loop [i :range [0 (length bytecode)]
            :let [instr (bytecode i)]]
@@ -3771,7 +3789,7 @@
     "Generate bindings for native functions in a convenient manner."
     [name ret-type & body]
     (def real-ret-type (eval ret-type))
-    (def meta (slice body 0 -2))
+    (def meta (slice body 0 -1))
     (def arg-pairs (partition 2 (last body)))
     (def formal-args (map 0 arg-pairs))
     (def type-args (map 1 arg-pairs))

src/core/array.c

@@ -297,7 +297,7 @@ JANET_CORE_FN(cfun_array_remove,
     int32_t at = janet_getinteger(argv, 1);
     int32_t n = 1;
     if (at < 0) {
-        at = array->count + at + 1;
+        at = array->count + at;
     }
     if (at < 0 || at > array->count)
         janet_panicf("removal index %d out of range [0,%d]", at, array->count);

src/core/asm.c

@@ -138,6 +138,7 @@ static const JanetInstructionDef janet_ops[] = {
     {"sru", JOP_SHIFT_RIGHT_UNSIGNED},
     {"sruim", JOP_SHIFT_RIGHT_UNSIGNED_IMMEDIATE},
     {"sub", JOP_SUBTRACT},
+    {"subim", JOP_SUBTRACT_IMMEDIATE},
     {"tcall", JOP_TAILCALL},
     {"tchck", JOP_TYPECHECK}
 };

src/core/bytecode.c

@@ -37,6 +37,7 @@ enum JanetInstructionType janet_instructions[JOP_INSTRUCTION_COUNT] = {
     JINT_0, /* JOP_RETURN_NIL, */
     JINT_SSI, /* JOP_ADD_IMMEDIATE, */
     JINT_SSS, /* JOP_ADD, */
+    JINT_SSI, /* JOP_SUBTRACT_IMMEDIATE, */
     JINT_SSS, /* JOP_SUBTRACT, */
     JINT_SSI, /* JOP_MULTIPLY_IMMEDIATE, */
     JINT_SSS, /* JOP_MULTIPLY, */
@@ -251,6 +252,7 @@ void janet_bytecode_movopt(JanetFuncDef *def) {
                 case JOP_SIGNAL:
                 /* Write A, Read B */
                 case JOP_ADD_IMMEDIATE:
+                case JOP_SUBTRACT_IMMEDIATE:
                 case JOP_MULTIPLY_IMMEDIATE:
                 case JOP_DIVIDE_IMMEDIATE:
                 case JOP_SHIFT_LEFT_IMMEDIATE:

src/core/capi.c

@@ -334,20 +334,11 @@ size_t janet_getsize(const Janet *argv, int32_t n) {
 }
 
 int32_t janet_gethalfrange(const Janet *argv, int32_t n, int32_t length, const char *which) {
-    int32_t raw = janet_getinteger(argv, n);
-    int32_t not_raw = raw;
-    if (not_raw < 0) not_raw += length + 1;
-    if (not_raw < 0 || not_raw > length)
-        janet_panicf("%s index %d out of range [%d,%d]", which, raw, -length - 1, length);
-    return not_raw;
-}
-
-int32_t janet_getargindex(const Janet *argv, int32_t n, int32_t length, const char *which) {
     int32_t raw = janet_getinteger(argv, n);
     int32_t not_raw = raw;
     if (not_raw < 0) not_raw += length;
     if (not_raw < 0 || not_raw > length)
-        janet_panicf("%s index %d out of range [%d,%d)", which, raw, -length, length);
+        janet_panicf("%s index %d out of range [%d,%d]", which, raw, -length, length);
     return not_raw;
 }
 

src/core/cfuns.c

@@ -99,7 +99,7 @@ static JanetSlot opfunction(
 static int can_be_imm(Janet x, int8_t *out) {
     if (!janet_checkint(x)) return 0;
     int32_t integer = janet_unwrap_integer(x);
-    if (integer > 127 || integer < -127) return 0;
+    if (integer > INT8_MAX || integer < INT8_MIN) return 0;
     *out = (int8_t) integer;
     return 1;
 }
@@ -121,8 +121,6 @@ static JanetSlot opreduce(
     JanetCompiler *c = opts.compiler;
     int32_t i, len;
     int8_t imm = 0;
-    int neg = opim < 0;
-    if (opim < 0) opim = -opim;
     len = janet_v_count(args);
     JanetSlot t;
     if (len == 0) {
@@ -139,13 +137,13 @@ static JanetSlot opreduce(
     }
     t = janetc_gettarget(opts);
     if (opim && can_slot_be_imm(args[1], &imm)) {
-        janetc_emit_ssi(c, opim, t, args[0], neg ? -imm : imm, 1);
+        janetc_emit_ssi(c, opim, t, args[0], imm, 1);
     } else {
         janetc_emit_sss(c, op, t, args[0], args[1], 1);
     }
     for (i = 2; i < len; i++) {
         if (opim && can_slot_be_imm(args[i], &imm)) {
-            janetc_emit_ssi(c, opim, t, t, neg ? -imm : imm, 1);
+            janetc_emit_ssi(c, opim, t, t, imm, 1);
         } else {
             janetc_emit_sss(c, op, t, t, args[i], 1);
         }
@@ -260,7 +258,7 @@ static JanetSlot do_add(JanetFopts opts, JanetSlot *args) {
     return opreduce(opts, args, JOP_ADD, JOP_ADD_IMMEDIATE, janet_wrap_integer(0), janet_wrap_integer(0));
 }
 static JanetSlot do_sub(JanetFopts opts, JanetSlot *args) {
-    return opreduce(opts, args, JOP_SUBTRACT, -JOP_ADD_IMMEDIATE, janet_wrap_integer(0), janet_wrap_integer(0));
+    return opreduce(opts, args, JOP_SUBTRACT, JOP_SUBTRACT_IMMEDIATE, janet_wrap_integer(0), janet_wrap_integer(0));
 }
 static JanetSlot do_mul(JanetFopts opts, JanetSlot *args) {
     return opreduce(opts, args, JOP_MULTIPLY, JOP_MULTIPLY_IMMEDIATE, janet_wrap_integer(1), janet_wrap_integer(1));

src/core/corelib.c

@@ -1174,11 +1174,11 @@ JanetTable *janet_core_env(JanetTable *replacements) {
                           "values."));
     templatize_varop(env, JANET_FUN_MODULO, "mod", 0, 1, JOP_MODULO,
                      JDOC("(mod & xs)\n\n"
-                         "Returns the result of applying the modulo operator on the first value of xs with each remaining value. "
-                         "`(mod x 0)` is defined to be `x`."));
+                          "Returns the result of applying the modulo operator on the first value of xs with each remaining value. "
+                          "`(mod x 0)` is defined to be `x`."));
     templatize_varop(env, JANET_FUN_REMAINDER, "%", 0, 1, JOP_REMAINDER,
                      JDOC("(% & xs)\n\n"
-                         "Returns the remainder of dividing the first value of xs by each remaining value."));
+                          "Returns the remainder of dividing the first value of xs by each remaining value."));
     templatize_varop(env, JANET_FUN_BAND, "band", -1, -1, JOP_BAND,
                      JDOC("(band & xs)\n\n"
                           "Returns the bit-wise and of all values in xs. Each x in xs must be an integer."));

src/core/inttypes.c

@@ -118,10 +118,9 @@ int64_t janet_unwrap_s64(Janet x) {
         default:
             break;
         case JANET_NUMBER : {
-            double dbl = janet_unwrap_number(x);
-            if (fabs(dbl) <=  MAX_INT_IN_DBL)
-                return (int64_t)dbl;
-            break;
+            double d = janet_unwrap_number(x);
+            if (!janet_checkint64range(d)) break;
+            return (int64_t) d;
         }
         case JANET_STRING: {
             int64_t value;
@@ -147,12 +146,9 @@ uint64_t janet_unwrap_u64(Janet x) {
         default:
             break;
         case JANET_NUMBER : {
-            double dbl = janet_unwrap_number(x);
-            /* Allow negative values to be cast to "wrap around".
-             * This let's addition and subtraction work as expected. */
-            if (fabs(dbl) <=  MAX_INT_IN_DBL)
-                return (uint64_t)dbl;
-            break;
+            double d = janet_unwrap_number(x);
+            if (!janet_checkuint64range(d)) break;
+            return (uint64_t) d;
         }
         case JANET_STRING: {
             uint64_t value;
@@ -307,8 +303,8 @@ static int compare_double_double(double x, double y) {
 
 static int 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))) {
+        return 0;
+    } else if ((y > JANET_INTMIN_DOUBLE) && (y < JANET_INTMAX_DOUBLE)) {
         double dx = (double) x;
         return compare_double_double(dx, y);
     } else if (y > ((double) INT64_MAX)) {
@@ -323,10 +319,10 @@ static int compare_int64_double(int64_t x, double y) {
 
 static int compare_uint64_double(uint64_t x, double y) {
     if (isnan(y)) {
-        return 0; // clojure and python do this
+        return 0;
     } else if (y < 0) {
         return 1;
-    } else if ((y >= 0) && (y < ((double) MAX_INT_IN_DBL))) {
+    } else if ((y >= 0) && (y < JANET_INTMAX_DOUBLE)) {
         double dx = (double) x;
         return compare_double_double(dx, y);
     } else if (y > ((double) UINT64_MAX)) {
@@ -339,8 +335,9 @@ static int compare_uint64_double(uint64_t x, double y) {
 
 static Janet cfun_it_s64_compare(int32_t argc, Janet *argv) {
     janet_fixarity(argc, 2);
-    if (janet_is_int(argv[0]) != JANET_INT_S64)
+    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:
@@ -355,7 +352,6 @@ static Janet cfun_it_s64_compare(int32_t argc, Janet *argv) {
                 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);
@@ -374,8 +370,9 @@ static Janet cfun_it_s64_compare(int32_t argc, Janet *argv) {
 
 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?
+    if (janet_is_int(argv[0]) != JANET_INT_U64) {
         janet_panic("compare method requires int/u64 as first argument");
+    }
     uint64_t x = janet_unwrap_u64(argv[0]);
     switch (janet_type(argv[1])) {
         default:
@@ -390,7 +387,6 @@ static Janet cfun_it_u64_compare(int32_t argc, Janet *argv) {
                 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);

src/core/vm.c

@@ -347,6 +347,7 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) {
         &&label_JOP_RETURN_NIL,
         &&label_JOP_ADD_IMMEDIATE,
         &&label_JOP_ADD,
+        &&label_JOP_SUBTRACT_IMMEDIATE,
         &&label_JOP_SUBTRACT,
         &&label_JOP_MULTIPLY_IMMEDIATE,
         &&label_JOP_MULTIPLY,
@@ -593,7 +594,6 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) {
         &&label_unknown_op,
         &&label_unknown_op,
         &&label_unknown_op,
-        &&label_unknown_op,
         &&label_unknown_op
     };
 #endif
@@ -683,6 +683,9 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) {
     VM_OP(JOP_ADD)
     vm_binop(+);
 
+    VM_OP(JOP_SUBTRACT_IMMEDIATE)
+    vm_binop_immediate(-);
+
     VM_OP(JOP_SUBTRACT)
     vm_binop(-);
 
@@ -720,10 +723,10 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) {
             double x1 = janet_unwrap_number(op1);
             double x2 = janet_unwrap_number(op2);
             if (x2 == 0) {
-              stack[A] = janet_wrap_number(x1);
+                stack[A] = janet_wrap_number(x1);
             } else {
-              double intres = x2 * floor(x1 / x2);
-              stack[A] = janet_wrap_number(x1 - intres);
+                double intres = x2 * floor(x1 / x2);
+                stack[A] = janet_wrap_number(x1 - intres);
             }
             vm_pcnext();
         } else {

src/include/janet.h

@@ -1262,6 +1262,7 @@ enum JanetOpCode {
     JOP_RETURN_NIL,
     JOP_ADD_IMMEDIATE,
     JOP_ADD,
+    JOP_SUBTRACT_IMMEDIATE,
     JOP_SUBTRACT,
     JOP_MULTIPLY_IMMEDIATE,
     JOP_MULTIPLY,
@@ -1996,7 +1997,6 @@ JANET_API JanetDictView janet_getdictionary(const Janet *argv, int32_t n);
 JANET_API void *janet_getabstract(const Janet *argv, int32_t n, const JanetAbstractType *at);
 JANET_API JanetRange janet_getslice(int32_t argc, const Janet *argv);
 JANET_API int32_t janet_gethalfrange(const Janet *argv, int32_t n, int32_t length, const char *which);
-JANET_API int32_t janet_getargindex(const Janet *argv, int32_t n, int32_t length, const char *which);
 JANET_API uint64_t janet_getflags(const Janet *argv, int32_t n, const char *flags);
 
 /* Optionals */

test/helper.janet

@@ -44,7 +44,7 @@
          (number? x) (string x)
          (string? x) (string/slice x
                                    (length "test/suite-")
-                                   (- (inc (length ".janet"))))
+                                   (- (length ".janet")))
          (string x)))
   (set start-time (os/clock))
   (eprint "Starting suite " suite-name "..."))

test/suite-array.janet

@@ -37,14 +37,14 @@
 (assert (array= @[:one :two :three :four :five]
                 @[:one :two :three :four :five]) "array comparison 3")
 (assert (array= (array/slice @[1 2 3] 0 2) @[1 2]) "array/slice 1")
-(assert (array= (array/slice @[0 7 3 9 1 4] 2 -2) @[3 9 1]) "array/slice 2")
+(assert (array= (array/slice @[0 7 3 9 1 4] 2 -1) @[3 9 1]) "array/slice 2")
 
 # Array remove
 # 687a3c9
 (assert (deep= (array/remove @[1 2 3 4 5] 2) @[1 2 4 5]) "array/remove 1")
 (assert (deep= (array/remove @[1 2 3 4 5] 2 2) @[1 2 5]) "array/remove 2")
 (assert (deep= (array/remove @[1 2 3 4 5] 2 200) @[1 2]) "array/remove 3")
-(assert (deep= (array/remove @[1 2 3 4 5] -3 200) @[1 2 3]) "array/remove 4")
+(assert (deep= (array/remove @[1 2 3 4 5] -2 200) @[1 2 3]) "array/remove 4")
 
 
 # array/peek

test/suite-buffer.janet

@@ -96,13 +96,13 @@
 # Regression #301
 # a3d4ecddb
 (def b (buffer/new-filled 128 0x78))
-(assert (= 38 (length (buffer/blit @"" b -1 90))) "buffer/blit 1")
+(assert (= 38 (length (buffer/blit @"" b 0 90))) "buffer/blit 1")
 
 (def a @"abcdefghijklm")
-(assert (deep= @"abcde" (buffer/blit @"" a -1 0 5)) "buffer/blit 2")
-(assert (deep= @"bcde" (buffer/blit @"" a -1 1 5)) "buffer/blit 3")
-(assert (deep= @"cde" (buffer/blit @"" a -1 2 5)) "buffer/blit 4")
-(assert (deep= @"de" (buffer/blit @"" a -1 3 5)) "buffer/blit 5")
+(assert (deep= @"abcde" (buffer/blit @"" a 0 0 5)) "buffer/blit 2")
+(assert (deep= @"bcde" (buffer/blit @"" a 0 1 5)) "buffer/blit 3")
+(assert (deep= @"cde" (buffer/blit @"" a 0 2 5)) "buffer/blit 4")
+(assert (deep= @"de" (buffer/blit @"" a 0 3 5)) "buffer/blit 5")
 
 # buffer/push-at
 # c55d93512

test/suite-inttypes.janet

@@ -196,7 +196,8 @@
     (assert-error "division by zero" (op (int 7) (int 0)))))
 
 (each int [int/s64 int/u64]
-  (loop [x :in [-5 -3 0 3 5]]
+  (loop [x :in [-5 -3 0 3 5] :when (or (pos? x) (= int int/s64))]
+    # skip check when comparing negative values with unsigned integers.
     (assert (= (int x) (mod (int x) 0)) (string int " mod 0"))
     (assert (= (int x) (mod x (int 0))) (string int " mod 0"))
     (assert (= (int x) (mod (int x) (int 0))) (string int " mod 0"))))
@@ -267,12 +268,12 @@
 # compare u64/i64
 (assert (= (compare (u64 1) (i64 2)) -1) "compare 7")
 (assert (= (compare (u64 1) (i64 -1)) +1) "compare 8")
-(assert (= (compare (u64 -1) (i64 -1)) +1) "compare 9")
+(assert (= (compare (u64 0) (i64 -1)) +1) "compare 9")
 
 # compare i64/u64
 (assert (= (compare (i64 1) (u64 2)) -1) "compare 10")
 (assert (= (compare (i64 -1) (u64 1)) -1) "compare 11")
-(assert (= (compare (i64 -1) (u64 -1)) -1) "compare 12")
+(assert (= (compare (i64 -1) (u64 0)) -1) "compare 12")
 
 # off by 1 error in inttypes
 # a3e812b86
@@ -281,4 +282,7 @@
 (assert (= (int/s64 "0x7FFF_FFFF_FFFF_FFFF")
            (- (int/s64 "-0x8000_0000_0000_0000") 1)) "int types wrap around")
 
+# Issue #1217
+(assert (= (- (int/u64 "0xFFFFFFFF") 1) (int/u64 "0xFFFFFFFE")) "u64 subtract")
+
 (end-suite)

test/suite-parse.janet

@@ -69,7 +69,7 @@
 
   (def first-nl (= (chr "\n") (first str)))
   (def last-nl (= (chr "\n") (last str)))
-  (string/slice str (if first-nl 1 0) (if last-nl -2)))
+  (string/slice str (if first-nl 1 0) (if last-nl -1)))
 
 (defn reindent-reference
   "Same as reindent but use parser functionality. Useful for

test/suite-peg.janet

@@ -367,7 +367,7 @@
                  (set "!$%&*+-./:<?=>@^_|"))
     :token (some :symchars)
     :hex (range "09" "af" "AF")
-    :escape (* "\\" (+ (set "ntrvzf0e\"\\")
+    :escape (* "\\" (+ (set `"'0?\abefnrtvz`)
                        (* "x" :hex :hex)
                        (error (constant "bad hex escape"))))
     :comment (/ '(* "#" (any (if-not (+ "\n" -1) 1))) (constant :comment))

test/suite-pp.janet

@@ -32,10 +32,10 @@
 # Buffer self blitting, check for use after free
 # bbcfaf128
 (def buf1 @"1234567890")
-(buffer/blit buf1 buf1 -1)
-(buffer/blit buf1 buf1 -1)
-(buffer/blit buf1 buf1 -1)
-(buffer/blit buf1 buf1 -1)
+(buffer/blit buf1 buf1 (length buf1))
+(buffer/blit buf1 buf1 (length buf1))
+(buffer/blit buf1 buf1 (length buf1))
+(buffer/blit buf1 buf1 (length buf1))
 (assert (= (string buf1) (string/repeat "1234567890" 16))
         "buffer blit against self")