Update peg to allow functions over captures. Update C API

to make janet function calls easier and faster from C (still
needs an object pool for fibers, though). Fix bug in scan-number
and add many more peg tests.

src/core/capi.c

@@ -118,6 +118,14 @@ int32_t janet_gethalfrange(const Janet *argv, int32_t n, int32_t length, const c
     return raw;
 }
 
+int32_t janet_getargindex(const Janet *argv, int32_t n, int32_t length, const char *which) {
+    int32_t raw = janet_getinteger(argv, n);
+    if (raw < 0) raw += length;
+    if (raw < 0 || raw > length)
+        janet_panicf("%s index %d out of range [0,%d)", which, raw, length);
+    return raw;
+}
+
 JanetView janet_getindexed(const Janet *argv, int32_t n) {
     Janet x = argv[n];
     JanetView view;

src/core/compile.c

@@ -485,7 +485,7 @@ static int macroexpand1(
     JanetFiber *fiberp;
     JanetFunction *macro = janet_unwrap_function(macroval);
     int lock = janet_gclock();
-    JanetSignal status = janet_call(
+    JanetSignal status = janet_pcall(
             macro,
             janet_tuple_length(form) - 1,
             form + 1,

src/core/core.janet

@@ -1367,6 +1367,11 @@ value, one key will be ignored."
     (set current (macex1 current)))
   current)
 
+(defn pp
+  "Pretty print to stdout."
+  [x]
+  (print (string/pretty x)))
+
 ###
 ###
 ### Evaluation and Compilation

src/core/corelib.c

@@ -152,7 +152,7 @@ static Janet janet_core_is_abstract(int32_t argc, Janet *argv) {
 static Janet janet_core_scannumber(int32_t argc, Janet *argv) {
     double number;
     janet_fixarity(argc, 1);
-    JanetByteView view = janet_getbytes(argv, 1);
+    JanetByteView view = janet_getbytes(argv, 0);
     if (janet_scan_number(view.bytes, view.len, &number))
         return janet_wrap_nil();
     return janet_wrap_number(number);

src/core/fiber.c

@@ -26,7 +26,17 @@
 #include "gc.h"
 #include "util.h"
 
-static JanetFiber *make_fiber(int32_t capacity) {
+static void fiber_reset(JanetFiber *fiber) {
+    fiber->maxstack = JANET_STACK_MAX;
+    fiber->frame = 0;
+    fiber->stackstart = JANET_FRAME_SIZE;
+    fiber->stacktop = JANET_FRAME_SIZE;
+    fiber->child = NULL;
+    fiber->flags = JANET_FIBER_MASK_YIELD;
+    janet_fiber_set_status(fiber, JANET_STATUS_NEW);
+}
+
+static JanetFiber *fiber_alloc(int32_t capacity) {
     Janet *data;
     JanetFiber *fiber = janet_gcalloc(JANET_MEMORY_FIBER, sizeof(JanetFiber));
     if (capacity < 32) {
@@ -38,37 +48,30 @@ static JanetFiber *make_fiber(int32_t capacity) {
         JANET_OUT_OF_MEMORY;
     }
     fiber->data = data;
-    fiber->maxstack = JANET_STACK_MAX;
-    fiber->frame = 0;
-    fiber->stackstart = JANET_FRAME_SIZE;
-    fiber->stacktop = JANET_FRAME_SIZE;
-    fiber->child = NULL;
-    fiber->flags = JANET_FIBER_MASK_YIELD;
-    janet_fiber_set_status(fiber, JANET_STATUS_NEW);
     return fiber;
 }
 
-/* Initialize a new fiber */
+/* Create a new fiber with argn values on the stack by reusing a fiber. */
-JanetFiber *janet_fiber(JanetFunction *callee, int32_t capacity) {
+JanetFiber *janet_fiber_reset(JanetFiber *fiber, JanetFunction *callee, int32_t argc, const Janet *argv) {
-    JanetFiber *fiber = make_fiber(capacity);
-    if (janet_fiber_funcframe(fiber, callee)) return NULL;
-    return fiber;
-}
-
-/* Clear a fiber (reset it) with argn values on the stack. */
-JanetFiber *janet_fiber_n(JanetFunction *callee, int32_t capacity, const Janet *argv, int32_t argn) {
     int32_t newstacktop;
-    JanetFiber *fiber = make_fiber(capacity);
+    fiber_reset(fiber);
-    newstacktop = fiber->stacktop + argn;
+    if (argc) {
+        newstacktop = fiber->stacktop + argc;
         if (newstacktop >= fiber->capacity) {
             janet_fiber_setcapacity(fiber, 2 * newstacktop);
         }
-    memcpy(fiber->data + fiber->stacktop, argv, argn * sizeof(Janet));
+        memcpy(fiber->data + fiber->stacktop, argv, argc * sizeof(Janet));
         fiber->stacktop = newstacktop;
+    }
     if (janet_fiber_funcframe(fiber, callee)) return NULL;
     return fiber;
 }
 
+/* Create a new fiber with argn values on the stack. */
+JanetFiber *janet_fiber(JanetFunction *callee, int32_t capacity, int32_t argc, const Janet *argv) {
+    return janet_fiber_reset(fiber_alloc(capacity), callee, argc, argv);
+}
+
 /* Ensure that the fiber has enough extra capacity */
 void janet_fiber_setcapacity(JanetFiber *fiber, int32_t n) {
     Janet *newData = realloc(fiber->data, sizeof(Janet) * n);
@@ -302,7 +305,7 @@ static Janet cfun_new(int32_t argc, Janet *argv) {
             janet_panic("expected nullary function in fiber constructor");
         }
     }
-    fiber = janet_fiber(func, 64);
+    fiber = janet_fiber(func, 64, 0, NULL);
     if (argc == 2) {
         int32_t i;
         JanetByteView view = janet_getbytes(argv, 1);

src/core/peg.c

@@ -35,7 +35,6 @@
 
 /* Hold captured patterns and match state */
 typedef struct {
-    int32_t depth;
     const uint8_t *text_start;
     const uint8_t *text_end;
     const uint8_t *subst_end;
@@ -44,12 +43,14 @@ typedef struct {
     JanetBuffer *scratch;
     const Janet *extrav;
     int32_t extrac;
-    int flags;
+    int32_t depth;
+    enum {
+        PEG_NORMAL,
+        PEG_SUBSTITUTE,
+        PEG_NOCAPTURE
+    } mode;
 } State;
 
-/* Check if we are inside a substitution capture */
-#define PEG_SUBSTITUTE 1
-
 /* Forward declaration */
 static int32_t match(State *s, Janet peg, const uint8_t *text);
 
@@ -202,13 +203,13 @@ static int32_t match_between(State *s, int32_t argc, const Janet *argv, const ui
  */
 
 static void push_capture(State *s, Janet capture, const uint8_t *text, int32_t nbytes) {
-    if (s->flags & PEG_SUBSTITUTE) {
+    if (s->mode == PEG_SUBSTITUTE) {
         /* Substitution mode, append as string to scratch buffer */
         /* But first append in-between text */
         janet_buffer_push_bytes(s->scratch, s->subst_end, text - s->subst_end);
         janet_to_string_b(s->scratch, capture);
         s->subst_end = text + nbytes;
-    } else {
+    } else if (s->mode == PEG_NORMAL) {
         /* Normal mode, append to captures */
         janet_array_push(s->captures, capture);
     }
@@ -217,7 +218,12 @@ static void push_capture(State *s, Janet capture, const uint8_t *text, int32_t n
 /* Capture a value */
 static int32_t match_capture(State *s, int32_t argc, const Janet *argv, const uint8_t *text) {
     janet_fixarity(argc, 1);
+    int oldmode = s->mode;
+    /* We can't have overlapping captures during substitution, so we can
+     * turn off the child captures if subsituting */
+    if (s->mode == PEG_SUBSTITUTE) s->mode = PEG_NOCAPTURE;
     int32_t result = match(s, argv[0], text);
+    s->mode = oldmode;
     if (result < 0) return -1;
     push_capture(s, janet_stringv(text, result), text, result);
     return result;
@@ -235,12 +241,14 @@ static int32_t match_position(State *s, int32_t argc, const Janet *argv, const u
 static int32_t match_group(State *s, int32_t argc, const Janet *argv, const uint8_t *text) {
     janet_fixarity(argc, 1);
     int32_t old_count = s->captures->count;
-    int32_t old_flags = s->flags;
+
-    s->flags &= ~PEG_SUBSTITUTE; /* Turn off substitution mode */
+    int oldmode = s->mode;
+    if (oldmode != PEG_NOCAPTURE) s->mode = PEG_NORMAL;
     int32_t result = match(s, argv[0], text);
-    s->flags = old_flags;
+    s->mode = oldmode;
     if (result < 0) return -1;
 
+    if (oldmode != PEG_NOCAPTURE) {
         /* Collect sub-captures into an array by popping new values off of the capture stack,
          * and then putting them in a new array. Then, push the new array back onto the capture stack. */
         int32_t num_sub_captures = s->captures->count - old_count;
@@ -248,8 +256,9 @@ static int32_t match_group(State *s, int32_t argc, const Janet *argv, const uint
         memcpy(sub_captures->data, s->captures->data + old_count, sizeof(Janet) * num_sub_captures);
         sub_captures->count = num_sub_captures;
         s->captures->count = old_count;
-
         push_capture(s, janet_wrap_array(sub_captures), text, result);
+    }
+
     return result;
 }
 
@@ -263,7 +272,7 @@ static int32_t match_capture_constant(State *s, int32_t argc, const Janet *argv,
 /* Capture nth extra argument to peg/match */
 static int32_t match_capture_arg(State *s, int32_t argc, const Janet *argv, const uint8_t *text) {
     janet_fixarity(argc, 1);
-    int32_t n = janet_gethalfrange(argv, 0, s->extrac, "n");
+    int32_t n = janet_getargindex(argv, 0, s->extrac, "n");
     push_capture(s, s->extrav[n], text, 0);
     return 0;
 }
@@ -271,8 +280,16 @@ static int32_t match_capture_arg(State *s, int32_t argc, const Janet *argv, cons
 /* Capture replace */
 static int32_t match_replace(State *s, int32_t argc, const Janet *argv, const uint8_t *text) {
     janet_fixarity(argc, 2);
+
+    int oldmode = s->mode;
+    int32_t old_count = s->captures->count;
+    if (oldmode == PEG_SUBSTITUTE) s->mode = PEG_NORMAL;
     int32_t result = match(s, argv[0], text);
+    s->mode = oldmode;
+
     if (result < 0) return -1;
+    if (oldmode == PEG_NOCAPTURE) return result;
+
     Janet capture;
     switch (janet_type(argv[1])) {
         default:
@@ -284,8 +301,28 @@ static int32_t match_replace(State *s, int32_t argc, const Janet *argv, const ui
         case JANET_TABLE:
             capture = janet_table_get(janet_unwrap_table(argv[1]), janet_stringv(text, result));
             break;
-        /* TODO - add functions, c functions, numbers */
+        case JANET_CFUNCTION:
+            {
+                janet_array_push(s->captures, janet_stringv(text, result));
+                JanetCFunction cfunc = janet_unwrap_cfunction(argv[1]);
+                capture = cfunc(s->captures->count - old_count, s->captures->data + old_count);
+                break;
             }
+        case JANET_FUNCTION:
+            {
+                janet_array_push(s->captures, janet_stringv(text, result));
+                capture = janet_call(janet_unwrap_function(argv[1]),
+                        s->captures->count - old_count, s->captures->data + old_count);
+                break;
+            }
+        case JANET_NUMBER:
+            {
+                int32_t index = janet_getargindex(argv, 1, s->captures->count, "capture");
+                capture = s->captures->data[index];
+                break;
+            }
+    }
+    s->captures->count = old_count;
     push_capture(s, capture, text, result);
     return result;
 }
@@ -294,25 +331,31 @@ static int32_t match_replace(State *s, int32_t argc, const Janet *argv, const ui
 static int32_t match_substitute(State *s, int32_t argc, const Janet *argv, const uint8_t *text) {
     janet_fixarity(argc, 1);
 
-    /* If we were originally in substitution mode, simply pass
+    /* Save old scratch state */
-     * argv[0] right through */
+    int32_t old_count = s->scratch->count;
-    if (s->flags & PEG_SUBSTITUTE)
+    const uint8_t *old_subst_end = s->subst_end;
-        return match(s, argv[0], text);
 
-    /* Set up scratch */
+    /* Prepare for collecting in scratch */
-    s->scratch->count = 0;
     s->subst_end = text;
 
-    s->flags |= PEG_SUBSTITUTE;
+    int oldmode = s->mode;
+    if (oldmode != PEG_NOCAPTURE) s->mode = PEG_SUBSTITUTE;
     int32_t result = match(s, argv[0], text);
-    s->flags &= ~PEG_SUBSTITUTE;
+    s->mode = oldmode;
 
     if (result < 0) return -1;
 
-    /* Pop scratch to captures */
+    if (oldmode != PEG_NOCAPTURE) {
+        /* Push remaining text to scratch buffer */
         janet_buffer_push_bytes(s->scratch, s->subst_end, text - s->subst_end + result);
-    janet_array_push(s->captures, janet_stringv(s->scratch->data, s->scratch->count));
+        /* Pop last section of scratch buffer and push a string capture */
-    s->scratch->count = 0;
+        janet_array_push(s->captures,
+                janet_stringv(s->scratch->data + old_count, s->scratch->count - old_count));
+    }
+
+    /* Reset scratch buffer and subst_end */
+    s->scratch->count = old_count;
+    s->subst_end = old_subst_end;
 
     return result;
 }
@@ -391,7 +434,6 @@ static int32_t match(State *s, Janet peg, const uint8_t *text) {
                 int32_t old_capture_count = s->captures->count;
                 int32_t old_scratch_count = s->scratch->count;
                 const uint8_t *old_subst_end = s->subst_end;
-
                 int32_t result =  mp->matcher(s, len - 1, items + 1, text);
 
                 /* Reset old state on failure */
@@ -438,7 +480,7 @@ static Janet cfun_match(int32_t argc, Janet *argv) {
         s.extrac = 0;
         s.extrav = NULL;
     }
-    s.flags = 0;
+    s.mode = PEG_NORMAL;
     s.text_start = bytes.bytes;
     s.text_end = bytes.bytes + bytes.len;
     s.depth = JANET_RECURSION_GUARD;

src/core/run.c

@@ -99,7 +99,7 @@ int janet_dobytes(JanetTable *env, const uint8_t *bytes, int32_t len, const char
             JanetCompileResult cres = janet_compile(form, env, where);
             if (cres.status == JANET_COMPILE_OK) {
                 JanetFunction *f = janet_thunk(cres.funcdef);
-                JanetFiber *fiber = janet_fiber(f, 64);
+                JanetFiber *fiber = janet_fiber(f, 64, 0, NULL);
                 JanetSignal status = janet_continue(fiber, janet_wrap_nil(), &ret);
                 if (status != JANET_SIGNAL_OK) {
                     janet_stacktrace(fiber, "runtime", ret);

src/core/vm.c

@@ -752,6 +752,24 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in, JanetFiberStatus status)
     VM_END()
 }
 
+Janet janet_call(JanetFunction *fun, int32_t argc, const Janet *argv) {
+    if (janet_vm_stackn >= JANET_RECURSION_GUARD)
+        janet_panic("C stack recursed too deeply");
+    JanetFiber *fiber = janet_fiber(fun, 64, argc, argv);
+    if (!fiber)
+        janet_panic("arity mismatch");
+    int handle = janet_gclock();
+
+    JanetFiber *old_fiber = janet_vm_fiber;
+    janet_vm_fiber = fiber;
+    memcpy(fiber->buf, janet_vm_fiber->buf,  sizeof(jmp_buf));
+    run_vm(fiber, janet_wrap_nil(), JANET_STATUS_NEW);
+    janet_vm_fiber = old_fiber;
+
+    janet_gcunlock(handle);
+    return fiber->data[fiber->stacktop - 1];
+}
+
 /* Enter the main vm loop */
 JanetSignal janet_continue(JanetFiber *fiber, Janet in, Janet *out) {
 
@@ -782,11 +800,14 @@ JanetSignal janet_continue(JanetFiber *fiber, Janet in, Janet *out) {
         fiber->child = NULL;
     }
 
-    /* Prepare state */
+    /* Save global state */
-    janet_vm_stackn++;
+    int32_t oldn = janet_vm_stackn++;
-    janet_gcroot(janet_wrap_fiber(fiber));
+    int handle = janet_vm_gc_suspend;
     JanetFiber *old_vm_fiber = janet_vm_fiber;
+
+    /* Setup fiber */
     janet_vm_fiber = fiber;
+    janet_gcroot(janet_wrap_fiber(fiber));
     janet_fiber_set_status(fiber, JANET_STATUS_ALIVE);
 
     /* Run loop */
@@ -797,25 +818,28 @@ JanetSignal janet_continue(JanetFiber *fiber, Janet in, Janet *out) {
         signal = run_vm(fiber, in, old_status);
     }
 
-    /* Tear down */
+    /* Tear down fiber */
     janet_fiber_set_status(fiber, signal);
-    janet_vm_fiber = old_vm_fiber;
-    janet_vm_stackn--;
     janet_gcunroot(janet_wrap_fiber(fiber));
 
+    /* Restore global state */
+    janet_vm_gc_suspend = handle; 
+    janet_vm_fiber = old_vm_fiber;
+    janet_vm_stackn = oldn;
+
     /* Pop error or return value from fiber stack */
     *out = fiber->data[--fiber->stacktop];
 
     return signal;
 }
 
-JanetSignal janet_call(
+JanetSignal janet_pcall(
         JanetFunction *fun,
-        int32_t argn,
+        int32_t argc,
         const Janet *argv,
         Janet *out,
         JanetFiber **f) {
-    JanetFiber *fiber = janet_fiber_n(fun, 64, argv, argn);
+    JanetFiber *fiber = janet_fiber(fun, 64, argc, argv);
     if (f) *f = fiber;
     if (!fiber) {
         *out = janet_cstringv("arity mismatch");

src/include/janet/janet.h

@@ -1042,8 +1042,8 @@ JANET_API void janet_table_merge_struct(JanetTable *table, const JanetKV *other)
 JANET_API JanetKV *janet_table_find(JanetTable *t, Janet key);
 
 /* Fiber */
-JANET_API JanetFiber *janet_fiber(JanetFunction *callee, int32_t capacity);
+JANET_API JanetFiber *janet_fiber(JanetFunction *callee, int32_t capacity, int32_t argc, const Janet *argv);
-JANET_API JanetFiber *janet_fiber_n(JanetFunction *callee, int32_t capacity, const Janet *argv, int32_t argn);
+JANET_API JanetFiber *janet_fiber_reset(JanetFiber *fiber, JanetFunction *callee, int32_t argc, const Janet *argv);
 #define janet_fiber_status(f) (((f)->flags & JANET_FIBER_STATUS_MASK) >> JANET_FIBER_STATUS_OFFSET)
 
 /* Treat similar types through uniform interfaces for iteration */
@@ -1112,7 +1112,8 @@ JANET_API void janet_inspect(Janet x);
 JANET_API int janet_init(void);
 JANET_API void janet_deinit(void);
 JANET_API JanetSignal janet_continue(JanetFiber *fiber, Janet in, Janet *out);
-JANET_API JanetSignal janet_call(JanetFunction *fun, int32_t argn, const Janet *argv, Janet *out, JanetFiber **f);
+JANET_API JanetSignal janet_pcall(JanetFunction *fun, int32_t argn, const Janet *argv, Janet *out, JanetFiber **f);
+JANET_API Janet janet_call(JanetFunction *fun, int32_t argc, const Janet *argv);
 JANET_API void janet_stacktrace(JanetFiber *fiber, const char *errtype, Janet err);
 
 /* C Library helpers */
@@ -1163,6 +1164,7 @@ 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);
 
 /***** END SECTION MAIN *****/
 

test/suite3.janet

@@ -53,6 +53,12 @@
 
 (assert (= var-b "hello") "regression 1")
 
+# Scan number 
+
+(assert (= 1 (scan-number "1")) "scan-number 1")
+(assert (= -1 (scan-number "-1")) "scan-number -1")
+(assert (= 1.3e4 (scan-number "1.3e4")) "scan-number 1.3e4")
+
 # Some macros
 
 (assert (= 2 (if-not 1 3 2)) "if-not 1")
@@ -160,6 +166,11 @@
   (def result (peg/match pat text))
   (assert (= (not should-match) (not result)) text))
 
+(defn check-deep
+  [pat text what]
+  (def result (peg/match pat text))
+  (assert (deep= result what) text))
+
 # Just numbers
 
 (check-match '(* 4 -1) "abcd" true)
@@ -193,11 +204,42 @@
   (assert (= (string/replace-all "dog" "purple panda" text) (0 (peg/match grammar text))) text))
 
 (try-grammar "i have a dog called doug the dog. he is good.")
-(try-grammar "i have a dog called doug the dog. he is good boy.")
+(try-grammar "i have a dog called doug the dog. he is a good boy.")
 (try-grammar "i have a dog called doug the do")
 (try-grammar "i have a dog called doug the dog")
 (try-grammar "i have a dog called doug the dogg")
 (try-grammar "i have a dog called doug the doggg")
 (try-grammar "i have a dog called doug the dogggg")
 
+# Peg CSV test
+(def csv
+  '{:field (+
+            (* `"` (<-s (at-least 0 (+ (- 1 `"`) (/ `""` `"`)))) `"`)
+            (<- (at-least 0 (- 1 (set ",\n")))))
+    :main (* :field (at-least 0 (* "," :field)) (+ "\n" -1))})
+
+(defn check-csv
+  [str res]
+  (check-deep csv str res))
+
+(check-csv "1,2,3" @["1" "2" "3"])
+(check-csv "1,\"2\",3" @["1" "2" "3"])
+(check-csv ``1,"1""",3`` @["1" "1\"" "3"])
+
+# Nested Captures
+
+(def grmr '(<- (* (<- "a") (<- 1) (<- "c"))))
+(check-deep grmr "abc" @["a" "b" "c" "abc"])
+(check-deep grmr "acc" @["a" "c" "c" "acc"])
+
+# Functions in grammar
+
+(def grmr-triple ~(<-s (at-least 0 (/ 1 ,(fn [x] (string x x x))))))
+(check-deep grmr-triple "abc" @["aaabbbccc"])
+(check-deep grmr-triple "" @[""])
+(check-deep grmr-triple " " @["   "])
+
+(def counter ~(/ (<-g (at-least 0 (<- 1))) ,length))
+(check-deep counter "abcdefg" @[7])
+
 (end-suite)