Add matchcap combinator to pegs.

This allows running rules on captures of pegs. This is flexible, but
loses some guarantees about rules only operating on the source string.
This means that line and column information will be incorrect inside the
matchcap combinator.

jpm

@@ -23,12 +23,12 @@
 
 # Overriden on some installs.
 # To configure this script, replace the code between
-# the START and END comments and define a function 
+# the START and END comments and define a function
 # (install-paths) that gives the the default paths
 # to use. Trailing directory separator not expected.
 #
 # Example.
-# 
+#
 #   (defn- install-paths []
 #     {:headerpath "/usr/local/include/janet"
 #      :libpath "/usr/local/lib/janet"
@@ -169,9 +169,7 @@
   [& args]
   (if (dyn :verbose)
     (print ;(interpose " " args)))
-  (def res (os/execute args :p))
-  (unless (zero? res)
-    (error (string "command exited with status " res))))
+  (os/execute args :px))
 
 (defn copy
   "Copy a file or directory recursively from one location to another."
@@ -1424,26 +1422,30 @@ Flags are:
    "load-lockfile" load-lockfile
    "quickbin" quickbin})
 
-(def- args (tuple/slice (dyn :args) 1))
-(def- len (length args))
-(var i :private 0)
+(defn- main
+  "Script entry."
+  [& argv]
 
-# Get flags
-(while (< i len)
-  (if-let [m (peg/match argpeg (args i))]
-    (if (= 2 (length m))
-      (let [[key value] m]
-        (setdyn (keyword key) value))
-      (setdyn (keyword (m 0)) true))
-    (break))
-  (++ i))
+  (def- args (tuple/slice argv 1))
+  (def- len (length args))
+  (var i :private 0)
 
-# Run subcommand
-(if (= i len)
-  (help)
-  (do
-    (if-let [com (subcommands (args i))]
-      (com ;(tuple/slice args (+ i 1)))
-      (do
-        (print "invalid command " (args i))
-        (help)))))
+  # Get flags
+  (while (< i len)
+    (if-let [m (peg/match argpeg (args i))]
+      (if (= 2 (length m))
+        (let [[key value] m]
+          (setdyn (keyword key) value))
+        (setdyn (keyword (m 0)) true))
+      (break))
+    (++ i))
+
+  # Run subcommand
+  (if (= i len)
+    (help)
+    (do
+      (if-let [com (subcommands (args i))]
+        (com ;(tuple/slice args (+ i 1)))
+        (do
+          (print "invalid command " (args i))
+          (help))))))

src/boot/boot.janet

@@ -277,7 +277,7 @@
   [& forms]
   (def len (length forms))
   (var i (- len 1))
-  (var ret (in forms i))
+  (var ret (get forms i))
   (while (> i 0)
     (-- i)
     (def fi (in forms i))

src/core/peg.c

@@ -286,7 +286,7 @@ tail:
             const uint8_t *next_text;
             CapState cs = cap_save(s);
             down1(s);
-            while (text < s->text_end) {
+            while (text <= s->text_end) {
                 CapState cs2 = cap_save(s);
                 next_text = peg_rule(s, rule_a, text);
                 if (next_text) {
@@ -296,7 +296,7 @@ tail:
                 text++;
             }
             up1(s);
-            if (text >= s->text_end) {
+            if (text > s->text_end) {
                 cap_load(s, cs);
                 return NULL;
             }
@@ -596,6 +596,67 @@ tail:
             return text + width;
         }
 
+        case RULE_MATCHCAP: {
+            const uint32_t *rule_a = s->bytecode + rule[1];
+            const uint32_t *rule_b = s->bytecode + rule[2];
+
+            int oldmode = s->mode;
+            CapState cs = cap_save(s);
+            s->mode = PEG_MODE_NORMAL;
+            int32_t old_cap = s->captures->count;
+            down1(s);
+            const uint8_t *b_result = peg_rule(s, rule_b, text);
+            up1(s);
+            s->mode = oldmode;
+            if (!b_result) return NULL;
+            int32_t new_cap = s->captures->count;
+
+            /* Check for bad captures */
+            for (int32_t i = old_cap; i < new_cap; i++) {
+                Janet capture = s->captures->data[i];
+                if (!janet_checktype(capture, JANET_STRING)) {
+                    return NULL;
+                }
+            }
+
+            /* Save captures to temporary buffer */
+            Janet *temp_mem = janet_smalloc(sizeof(Janet) * (new_cap - old_cap));
+            for (int32_t i = old_cap; i < new_cap; i++) {
+                temp_mem[i - old_cap] = s->captures->data[i];
+            }
+            cap_load(s, cs);
+
+            for (int32_t i = old_cap; i < new_cap; i++) {
+                Janet capture = temp_mem[i - old_cap];
+                const uint8_t *str = janet_unwrap_string(capture);
+                PegState subs;
+                subs.mode = PEG_MODE_NORMAL;
+                subs.text_start = str;
+                subs.text_end = str + janet_string_length(str);
+                subs.depth = s->depth - 1;
+                subs.captures = s->captures;
+                subs.tagged_captures = s->tagged_captures;
+                subs.scratch = janet_buffer(10);
+                subs.tags = s->tags;
+                subs.constants = s->constants;
+                subs.bytecode = s->bytecode;
+                subs.linemap = NULL;
+                subs.linemaplen = -1;
+                subs.has_backref = s->has_backref;
+                subs.extrac = s->extrac;
+                subs.extrav = s->extrav;
+
+                const uint8_t *a_result = peg_rule(&subs, rule_a, str);
+                if (NULL == a_result) {
+                    janet_sfree(temp_mem);
+                    return NULL;
+                }
+            }
+
+            janet_sfree(temp_mem);
+            return b_result;
+        }
+
     }
 }
 
@@ -844,6 +905,9 @@ static void spec_ifnot(Builder *b, int32_t argc, const Janet *argv) {
 static void spec_lenprefix(Builder *b, int32_t argc, const Janet *argv) {
     spec_branch(b, argc, argv, RULE_LENPREFIX);
 }
+static void spec_matchcap(Builder *b, int32_t argc, const Janet *argv) {
+    spec_branch(b, argc, argv, RULE_MATCHCAP);
+}
 
 static void spec_between(Builder *b, int32_t argc, const Janet *argv) {
     peg_fixarity(b, argc, 3);
@@ -1090,6 +1154,7 @@ static const SpecialPair peg_specials[] = {
     {"lenprefix", spec_lenprefix},
     {"line", spec_line},
     {"look", spec_look},
+    {"matchcap", spec_matchcap},
     {"not", spec_not},
     {"opt", spec_opt},
     {"position", spec_position},
@@ -1362,6 +1427,7 @@ static void *peg_unmarshal(JanetMarshalContext *ctx) {
             case RULE_IF:
             case RULE_IFNOT:
             case RULE_LENPREFIX:
+            case RULE_MATCHCAP:
                 /* [rule_a, rule_b (b if not a)] */
                 if (rule[1] >= blen) goto bad;
                 if (rule[2] >= blen) goto bad;

src/core/vm.c

@@ -1378,6 +1378,7 @@ static JanetSignal janet_continue_no_check(JanetFiber *fiber, Janet in, Janet *o
         if (janet_vm_root_fiber == fiber) janet_vm_root_fiber = NULL;
         if (sig != JANET_SIGNAL_OK && !(child->flags & (1 << sig))) {
             *out = in;
+            janet_fiber_set_status(fiber, sig);
             return sig;
         }
         /* Check if we need any special handling for certain opcodes */
@@ -1417,23 +1418,23 @@ static JanetSignal janet_continue_no_check(JanetFiber *fiber, Janet in, Janet *o
 
     /* Save global state */
     JanetTryState tstate;
-    JanetSignal signal = janet_try(&tstate);
-    if (!signal) {
+    JanetSignal sig = janet_try(&tstate);
+    if (!sig) {
         /* Normal setup */
         if (janet_vm_root_fiber == NULL) janet_vm_root_fiber = fiber;
         janet_vm_fiber = fiber;
         janet_fiber_set_status(fiber, JANET_STATUS_ALIVE);
-        signal = run_vm(fiber, in);
+        sig = run_vm(fiber, in);
     }
 
     /* Restore */
     if (janet_vm_root_fiber == fiber) janet_vm_root_fiber = NULL;
-    janet_fiber_set_status(fiber, signal);
+    janet_fiber_set_status(fiber, sig);
     janet_restore(&tstate);
     fiber->last_value = tstate.payload;
     *out = tstate.payload;
 
-    return signal;
+    return sig;
 }
 
 /* Enter the main vm loop */

src/include/janet.h

@@ -1841,7 +1841,8 @@ typedef enum {
     RULE_LENPREFIX,    /* [rule_a, rule_b (repeat rule_b rule_a times)] */
     RULE_READINT,      /* [(signedness << 4) | (endianess << 5) | bytewidth, tag] */
     RULE_LINE,         /* [tag] */
-    RULE_COLUMN        /* [tag] */
+    RULE_COLUMN,       /* [tag] */
+    RULE_MATCHCAP      /* [rule_a, rule_b] */
 } JanetPegOpcod;
 
 typedef struct {

test/suite0001.janet

@@ -294,4 +294,25 @@
           (sort (mapcat (fn [[x y z]] [z y x]) (partition 3 (range 99))))) "sort 5")
 (assert (<= ;(sort (map (fn [x] (math/random)) (range 1000)))) "sort 6")
 
+# And and or
+
+(assert (= (and true true) true) "and true true")
+(assert (= (and true false) false) "and true false")
+(assert (= (and false true) false) "and false true")
+(assert (= (and true true true) true) "and true true true")
+(assert (= (and 0 1 2) 2) "and 0 1 2")
+(assert (= (and 0 1 nil) nil) "and 0 1 nil")
+(assert (= (and 1) 1) "and 1")
+(assert (= (and) true) "and with no arguments")
+
+(assert (= (or true true) true) "or true true")
+(assert (= (or true false) true) "or true false")
+(assert (= (or false true) true) "or false true")
+(assert (= (or false false) false) "or false true")
+(assert (= (or true true false) true) "or true true false")
+(assert (= (or 0 1 2) 0) "or 0 1 2")
+(assert (= (or nil 1 2) 1) "or nil 1 2")
+(assert (= (or 1) 1) "or 1")
+(assert (= (or) nil) "or with no arguments")
+
 (end-suite)

test/suite0003.janet

@@ -473,4 +473,21 @@
 
 (check-deep '(* (int 2) -1) "123" nil)
 
+# to/thru bug
+(check-deep '(to -1) "aaaa" @[])
+(check-deep '(thru -1) "aaaa" @[])
+(check-deep ''(to -1) "aaaa" @["aaaa"])
+(check-deep ''(thru -1) "aaaa" @["aaaa"])
+(check-deep '(to "b") "aaaa" nil)
+(check-deep '(thru "b") "aaaa" nil)
+
+# matchcap
+(def matchcap-test
+  ~{:span (* "{" '(to "}") "}")
+    :parse-span (* '3 3)
+    :main (matchcap :parse-span (any :span ))})
+
+(check-deep matchcap-test "{bigrig}{fatman}{catdog}" @["big" "fat" "cat"])
+(check-deep matchcap-test "{bigrig}{fatman}{catdoggy}" @["big" "fat" "cat"])
+
 (end-suite)

test/suite0010.janet

@@ -146,4 +146,19 @@
 # os/execute with environment variables
 (assert (= 0 (os/execute [(dyn :executable) "-e" "(+ 1 2 3)"] :pe {"HELLO" "WORLD"})) "os/execute with env")
 
+# Regression #638
+(compwhen
+  (dyn 'ev/go)
+  (assert
+    (= [true :caught]
+       (protect
+         (try
+           (do
+             (ev/sleep 0)
+             (with-dyns []
+               (ev/sleep 0)
+               (error "oops")))
+           ([err] :caught))))
+    "regression #638"))
+
 (end-suite)