Add some fixes for serializing complex grammars.

5 files changed, 124 insertions, 17 deletions

diff --git a/src/boot/boot.janet b/src/boot/boot.janet
index 0645c1f0..b69e4934 100644
--- a/src/boot/boot.janet
+++ b/src/boot/boot.janet
@@ -1579,8 +1579,8 @@
   (unmarshal image (env-lookup _env)))
 
 (def- nati (if (= :windows (os/which)) ".dll" ".so"))
-(defn- check-. [x] (string/has-prefix? "." x))
-(defn- not-check-. [x] (not (string/has-prefix? "." x)))
+(defn- check-. [x] (if (string/has-prefix? "." x) x))
+(defn- not-check-. [x] (unless (string/has-prefix? "." x) x))
 
 (def module/paths
   "The list of paths to look for modules, templated for module/expand-path.
diff --git a/src/core/corelib.c b/src/core/corelib.c
index 9de58134..d8b5b7aa 100644
--- a/src/core/corelib.c
+++ b/src/core/corelib.c
@@ -119,24 +119,37 @@ static Janet janet_core_expand_path(int32_t argc, Janet *argv) {
     janet_fixarity(argc, 2);
     const char *input = janet_getcstring(argv, 0);
     const char *template = janet_getcstring(argv, 1);
-    const char *curfile = janet_dyncstring("current-file", "./.");
+    const char *curfile = janet_dyncstring("current-file", "");
     const char *syspath = janet_dyncstring("syspath", "");
     JanetBuffer *out = janet_buffer(0);
     size_t tlen = strlen(template);
 
     /* Calculate name */
-    const char *name = input + strlen(input) - 1;
+    const char *name = input + strlen(input);
     while (name > input) {
         if (is_path_sep(*(name - 1))) break;
         name--;
     }
 
     /* Calculate dirpath from current file */
-    const char *curname = curfile + strlen(curfile) - 1;
+    const char *curname = curfile + strlen(curfile);
     while (curname > curfile) {
         if (is_path_sep(*curname)) break;
         curname--;
     }
+    const char *curdir;
+    int32_t curlen;
+    if (curname == curfile) {
+        /* Current file has one or zero path segments, so
+         * we are in the . directory. */
+        curdir = ".";
+        curlen = 1;
+    } else {
+        /* Current file has 2 or more segments, so we
+         * can cut off the last segment. */
+        curdir = curfile;
+        curlen = (int32_t)(curname - curfile);
+    }
 
     for (size_t i = 0; i < tlen; i++) {
         if (template[i] == ':') {
@@ -144,12 +157,11 @@ static Janet janet_core_expand_path(int32_t argc, Janet *argv) {
                 janet_buffer_push_cstring(out, input);
                 i += 4;
             } else if (strncmp(template + i, ":cur:", 5) == 0) {
-                janet_buffer_push_bytes(out, (const uint8_t *) curfile,
-                        (int32_t)(curname - curfile));
+                janet_buffer_push_bytes(out, (const uint8_t *)curdir, curlen);
                 i += 4;
             } else if (strncmp(template + i, ":dir:", 5) == 0) {
-                janet_buffer_push_bytes(out, (const uint8_t *) input,
-                        (int32_t)(name - input));
+                janet_buffer_push_bytes(out, (const uint8_t *)input,
+                                        (int32_t)(name - input));
                 i += 4;
             } else if (strncmp(template + i, ":sys:", 5) == 0) {
                 janet_buffer_push_cstring(out, syspath);
diff --git a/src/core/marsh.c b/src/core/marsh.c
index 3da03d1b..8f5e0bba 100644
--- a/src/core/marsh.c
+++ b/src/core/marsh.c
@@ -328,11 +328,11 @@ static void marshal_one_abstract(MarshalState *st, Janet x, int flags) {
     void *abstract = janet_unwrap_abstract(x);
     const JanetAbstractType *at = janet_abstract_type(abstract);
     if (at->marshal) {
-        MARK_SEEN();
         JanetMarshalContext context = {st, NULL, flags, NULL};
         pushbyte(st, LB_ABSTRACT);
         marshal_one(st, janet_csymbolv(at->name), flags + 1);
         push64(st, (uint64_t) janet_abstract_size(abstract));
+        MARK_SEEN();
         at->marshal(abstract, &context);
     } else {
         janet_panicf("try to marshal unregistered abstract type, cannot marshal %p", x);
@@ -1008,10 +1008,11 @@ static const uint8_t *unmarshal_one_abstract(UnmarshalState *st, const uint8_t *
     if (at == NULL) return NULL;
     if (at->unmarshal) {
         void *p = janet_abstract(at, (size_t) read64(st, &data));
+        *out = janet_wrap_abstract(p);
         JanetMarshalContext context = {NULL, st, flags, data};
+        janet_v_push(st->lookup, *out);
         at->unmarshal(p, &context);
-        *out = janet_wrap_abstract(p);
-        return data;
+        return context.data;
     }
     return NULL;
 }
diff --git a/src/core/peg.c b/src/core/peg.c
index 17555866..85b907e3 100644
--- a/src/core/peg.c
+++ b/src/core/peg.c
@@ -952,8 +952,9 @@ typedef struct {
 static int peg_mark(void *p, size_t size) {
     (void) size;
     Peg *peg = (Peg *)p;
-    for (uint32_t i = 0; i < peg->num_constants; i++)
-        janet_mark(peg->constants[i]);
+    if (NULL != peg->constants)
+        for (uint32_t i = 0; i < peg->num_constants; i++)
+            janet_mark(peg->constants[i]);
     return 0;
 }
 
@@ -986,8 +987,8 @@ static void peg_unmarshal(void *p, JanetMarshalContext *ctx) {
     size_t constants_start = size_padded(bytecode_start + bytecode_size, sizeof(Janet));
     uint32_t *bytecode = (uint32_t *)(mem + bytecode_start);
     Janet *constants = (Janet *)(mem + constants_start);
-    peg->bytecode = bytecode;
-    peg->constants = constants;
+    peg->bytecode = NULL;
+    peg->constants = NULL;
 
     for (size_t i = 0; i < peg->bytecode_len; i++)
         bytecode[i] = (uint32_t) janet_unmarshal_int(ctx);
@@ -1087,7 +1088,7 @@ static void peg_unmarshal(void *p, JanetMarshalContext *ctx) {
                 if (rule[1] >= blen) goto bad;
                 if (rule[2] >= clen) goto bad;
                 op_flags[rule[1]] |= 0x01;
-                i += 2;
+                i += 4;
                 break;
             case RULE_ERROR:
             case RULE_DROP:
@@ -1111,6 +1112,8 @@ static void peg_unmarshal(void *p, JanetMarshalContext *ctx) {
         if (op_flags[i] == 0x01) goto bad;
 
     /* Good return */
+    peg->bytecode = bytecode;
+    peg->constants = constants;
     free(op_flags);
     return;
 
diff --git a/test/suite7.janet b/test/suite7.janet
new file mode 100644
index 00000000..1adefb0b
--- /dev/null
+++ b/test/suite7.janet
@@ -0,0 +1,91 @@
+# Copyright (c) 2019 Calvin Rose & contributors
+#
+# Permission is hereby granted, free of charge, to any person obtaining a copy
+# of this software and associated documentation files (the "Software"), to
+# deal in the Software without restriction, including without limitation the
+# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+# sell copies of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be included in
+# all copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+# IN THE SOFTWARE.
+
+(import ./helper :prefix "" :exit true)
+(start-suite 7)
+
+# Using a large test grammar
+
+(def- core-env (table/getproto (fiber/getenv (fiber/current))))
+(def- specials {'fn true
+               'var true
+               'do true
+               'while true
+               'def true
+               'splice true
+               'set true
+               'unquote true
+               'quasiquote true
+               'quote true
+               'if true})
+
+(defn- check-number [text] (and (scan-number text) text))
+
+(defn capture-sym
+  [text]
+  (def sym (symbol text))
+  [(if (or (core-env sym) (specials sym)) :coresym :symbol) text])
+
+(def grammar
+  ~{:ws (set " \v\t\r\f\n\0")
+    :readermac (set "';~,")
+    :symchars (+ (range "09" "AZ" "az" "\x80\xFF") (set "!$%&*+-./:<?=>@^_|"))
+    :token (some :symchars)
+    :hex (range "09" "af" "AF")
+    :escape (* "\\" (+ (set "ntrvzf0e\"\\")
+                       (* "x" :hex :hex)
+                       (error (constant "bad hex escape"))))
+    :comment (/ '(* "#" (any (if-not (+ "\n" -1) 1))) (constant :comment))
+    :symbol (/ ':token ,capture-sym)
+    :keyword (/ '(* ":" (any :symchars)) (constant :keyword))
+    :constant (/ '(+ "true" "false" "nil") (constant :constant))
+    :bytes (* "\"" (any (+ :escape (if-not "\"" 1))) "\"")
+    :string (/ ':bytes (constant :string))
+    :buffer (/ '(* "@" :bytes) (constant :string))
+    :long-bytes {:delim (some "`")
+                 :open (capture :delim :n)
+                 :close (cmt (* (not (> -1 "`")) (-> :n) ':delim) ,=)
+                 :main (drop (* :open (any (if-not :close 1)) :close))}
+    :long-string (/ ':long-bytes (constant :string))
+    :long-buffer (/ '(* "@" :long-bytes) (constant :string))
+    :number (/ (cmt ':token ,check-number) (constant :number))
+    :raw-value (+ :comment :constant :number :keyword
+                  :string :buffer :long-string :long-buffer
+                  :parray :barray :ptuple :btuple :struct :dict :symbol)
+    :value (* (? '(some (+ :ws :readermac))) :raw-value '(any :ws))
+    :root (any :value)
+    :root2 (any (* :value :value))
+    :ptuple (* '"(" :root (+ '")" (error "")))
+    :btuple (* '"[" :root (+ '"]" (error "")))
+    :struct (* '"{" :root2 (+ '"}" (error "")))
+    :parray (* '"@" :ptuple)
+    :barray (* '"@" :btuple)
+    :dict (* '"@"  :struct)
+    :main (+ :root (error ""))})
+
+(def p (peg/compile grammar))
+
+# Just make sure is valgrind clean.
+(-> p make-image load-image)
+
+(assert (peg/match p "abc") "complex peg grammar 1")
+(assert (peg/match p "[1 2 3 4]") "complex peg grammar 2")
+
+(end-suite)