Fix nasty bugs with longjmp() looping for uw_set_input(); and bad variable indexes for nested JavaScript in jscomp

7 files changed, 170 insertions, 74 deletions

diff --git a/include/urweb.h b/include/urweb.h
index 80d2b255..974d3c01 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -43,8 +43,8 @@ void uw_memstats(uw_context);
 
 int uw_send(uw_context, int sock);
 
-void uw_set_input(uw_context, const char *name, char *value);
-void uw_set_file_input(uw_context, char *name, uw_Basis_file);
+int uw_set_input(uw_context, const char *name, char *value);
+int uw_set_file_input(uw_context, char *name, uw_Basis_file);
 
 char *uw_get_input(uw_context, int name);
 char *uw_get_optional_input(uw_context, int name);
diff --git a/lib/ur/listPair.ur b/lib/ur/listPair.ur
new file mode 100644
index 00000000..9a56f75a
--- /dev/null
+++ b/lib/ur/listPair.ur
@@ -0,0 +1,10 @@
+fun mapX (a ::: Type) (b ::: Type) (ctx ::: {Unit}) f =
+    let
+        fun mapX' ls1 ls2 =
+            case (ls1, ls2) of
+                ([], []) => <xml/>
+              | (x1 :: ls1, x2 :: ls2) => <xml>{f x1 x2}{mapX' ls1 ls2}</xml>
+              | _ => error <xml>ListPair.mapX: Unequal list lengths</xml>
+    in
+        mapX'
+    end
diff --git a/lib/ur/listPair.urs b/lib/ur/listPair.urs
new file mode 100644
index 00000000..55a34b3a
--- /dev/null
+++ b/lib/ur/listPair.urs
@@ -0,0 +1,2 @@
+val mapX : a ::: Type -> b ::: Type -> ctx ::: {Unit}
+           -> (a -> b -> xml ctx [] []) -> list a -> list b -> xml ctx [] []
diff --git a/src/c/driver.c b/src/c/driver.c
index af3e73a3..2140cb2c 100644
--- a/src/c/driver.c
+++ b/src/c/driver.c
@@ -403,9 +403,14 @@ static void *worker(void *data) {
             if (filename) {
               uw_Basis_file f = {filename, type, {part_len, after_sub_headers}};
 
-              uw_set_file_input(ctx, name, f);
-            } else
-              uw_set_input(ctx, name, after_sub_headers);
+              if (uw_set_file_input(ctx, name, f)) {
+                puts(uw_error_message(ctx));
+                goto done;
+              }
+            } else if (uw_set_input(ctx, name, after_sub_headers)) {
+              puts(uw_error_message(ctx));
+              goto done;
+            }
           }
         }
         else {
@@ -426,10 +431,15 @@ static void *worker(void *data) {
 
               if (value = strchr(name, '=')) {
                 *value++ = 0;
-                uw_set_input(ctx, name, value);
+                if (uw_set_input(ctx, name, value)) {
+                  puts(uw_error_message(ctx));
+                  goto done;
+                }
+              }
+              else if (uw_set_input(ctx, name, "")) {
+                puts(uw_error_message(ctx));
+                goto done;
               }
-              else
-                uw_set_input(ctx, name, "");
             }
           }
         }
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 2ddc273a..a75ccf56 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -482,6 +482,13 @@ void uw_headers_moved(uw_context ctx, char *headers) {
 
 int uw_db_begin(uw_context);
 
+static void uw_set_error(uw_context ctx, const char *fmt, ...) {
+  va_list ap;
+  va_start(ap, fmt);
+
+  vsnprintf(ctx->error_message, ERROR_BUF_LEN, fmt, ap);
+}
+
 __attribute__((noreturn)) void uw_error(uw_context ctx, failure_kind fk, const char *fmt, ...) {
   cleanup *cl;
 
@@ -658,16 +665,20 @@ static input *check_input_space(uw_context ctx, size_t len) {
   return r;
 }
 
-void uw_set_input(uw_context ctx, const char *name, char *value) {
+int uw_set_input(uw_context ctx, const char *name, char *value) {
   if (!strcasecmp(name, ".b")) {
     int n = uw_input_num(value);
     input *inps;
 
-    if (n < 0)
-      uw_error(ctx, FATAL, "Bad subform name %s", value);
+    if (n < 0) {
+      uw_set_error(ctx, "Bad subform name %s", value);
+      return -1;
+    }
 
-    if (n >= uw_inputs_len)
-      uw_error(ctx, FATAL, "For subform name %s, index %d is out of range", value, n);
+    if (n >= uw_inputs_len) {
+      uw_set_error(ctx, "For subform name %s, index %d is out of range", value, n);
+      return -1;
+    }
 
     inps = check_input_space(ctx, uw_inputs_len);
 
@@ -678,8 +689,10 @@ void uw_set_input(uw_context ctx, const char *name, char *value) {
   } else if (!strcasecmp(name, ".e")) {
     input *tmp;
 
-    if (ctx->cur_container == NULL)
-      uw_error(ctx, FATAL, "Unmatched subform closer");
+    if (ctx->cur_container == NULL) {
+      uw_set_error(ctx, "Unmatched subform closer");
+      return -1;
+    }
 
     tmp = ctx->cur_container;
     switch (tmp->kind) {
@@ -695,16 +708,21 @@ void uw_set_input(uw_context ctx, const char *name, char *value) {
       ctx->cur_container = tmp->data.entry.parent;
       break;
     default:
-      uw_error(ctx, FATAL, "uw_set_input: Wrong kind");
+      uw_set_error(ctx, "uw_set_input: Wrong kind");
+      return -1;
     }
   } else if (!strcasecmp(name, ".s")) {
     int n = uw_input_num(value);
 
-    if (n < 0)
-      uw_error(ctx, FATAL, "Bad subforms name %s", value);
+    if (n < 0) {
+      uw_set_error(ctx, "Bad subforms name %s", value);
+      return -1;
+    }
 
-    if (n >= uw_inputs_len)
-      uw_error(ctx, FATAL, "For subforms name %s, index %d is out of range", value, n);
+    if (n >= uw_inputs_len) {
+      uw_set_error(ctx, "For subforms name %s, index %d is out of range", value, n);
+      return -1;
+    }
 
     INP(ctx)[n].kind = SUBFORMS;
     INP(ctx)[n].data.subforms.parent = ctx->cur_container;
@@ -713,11 +731,15 @@ void uw_set_input(uw_context ctx, const char *name, char *value) {
   } else if (!strcasecmp(name, ".i")) {
     input *inps;
 
-    if (!ctx->cur_container)
-      uw_error(ctx, FATAL, "New entry without container");
+    if (!ctx->cur_container) {
+      uw_set_error(ctx, "New entry without container");
+      return -1;
+    }
 
-    if (ctx->cur_container->kind != SUBFORMS)
-      uw_error(ctx, FATAL, "Bad kind for entry parent");
+    if (ctx->cur_container->kind != SUBFORMS) {
+      uw_set_error(ctx, "Bad kind for entry parent");
+      return -1;
+    }
 
     inps = check_input_space(ctx, uw_inputs_len + 1);
 
@@ -731,15 +753,21 @@ void uw_set_input(uw_context ctx, const char *name, char *value) {
   } else {
     int n = uw_input_num(name);
 
-    if (n < 0)
-      uw_error(ctx, FATAL, "Bad input name %s", name);
+    if (n < 0) {
+      uw_set_error(ctx, "Bad input name %s", name);
+      return -1;
+    }
 
-    if (n >= uw_inputs_len)
-      uw_error(ctx, FATAL, "For input name %s, index %d is out of range", name, n);
+    if (n >= uw_inputs_len) {
+      uw_set_error(ctx, "For input name %s, index %d is out of range", name, n);
+      return -1;
+    }
 
     INP(ctx)[n].kind = NORMAL;
     INP(ctx)[n].data.normal = value;
   }
+
+  return 0;
 }
 
 char *uw_get_input(uw_context ctx, int n) {
@@ -790,17 +818,23 @@ char *uw_get_optional_input(uw_context ctx, int n) {
   }
 }
 
-void uw_set_file_input(uw_context ctx, const char *name, uw_Basis_file f) {
+int uw_set_file_input(uw_context ctx, const char *name, uw_Basis_file f) {
   int n = uw_input_num(name);
 
-  if (n < 0)
-    uw_error(ctx, FATAL, "Bad file input name %s", name);
+  if (n < 0) {
+    uw_set_error(ctx, "Bad file input name %s", name);
+    return -1;
+  }
 
-  if (n >= uw_inputs_len)
-    uw_error(ctx, FATAL, "For file input name %s, index %d is out of range", name, n);
+  if (n >= uw_inputs_len) {
+    uw_set_error(ctx, "For file input name %s, index %d is out of range", name, n);
+    return -1;
+  }
 
   ctx->inputs[n].kind = FIL;
   ctx->inputs[n].data.file = f;
+
+  return 0;
 }
 
 void *uw_malloc(uw_context ctx, size_t len);
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 3e8e939e..e0954ba0 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -143,6 +143,32 @@ fun strcat loc es =
       | [x] => x
       | x :: es' => (EStrcat (x, strcat loc es'), loc)
 
+fun patDepth (p, _) =
+    case p of
+        PWild => 0
+      | PVar _ => 0
+      | PPrim _ => 0
+      | PCon (_, _, NONE) => 0
+      | PCon (_, _, SOME p) => 1 + patDepth p
+      | PRecord xpts => foldl Int.max 0 (map (fn (_, p, _) => 1 + patDepth p) xpts)
+      | PNone _ => 0
+      | PSome (_, p) => 1 + patDepth p
+
+val compact =
+    U.Exp.mapB {typ = fn t => t,
+                exp = fn inner => fn e =>
+                                     case e of
+                                         ERel n =>
+                                         if n >= inner then
+                                             ERel (n - inner)
+                                         else
+                                             e
+                                       | _ => e,
+                bind = fn (inner, b) =>
+                          case b of
+                              U.Exp.RelE _ => inner+1
+                            | _ => inner}
+    
 fun process file =
     let
         val (someTs, nameds) =
@@ -254,7 +280,7 @@ fun process file =
                                    maxName = n' + 1}
 
                          val s = (TFfi ("Basis", "string"), loc)
-                         val (e', st) = quoteExp loc t ((EField ((ERel 0, loc), "1"), loc), st)
+                         val (e', st) = quoteExp loc t' ((EField ((ERel 0, loc), "1"), loc), st)
 
                          val body = (ECase ((ERel 0, loc),
                                             [((PNone rt, loc),
@@ -620,7 +646,8 @@ fun process file =
 
                         val quoteExp = quoteExp loc
                     in
-                        (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e)];*)
+                        (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e),
+                                              ("inner", Print.PD.string (Int.toString inner))];*)
 
                         case #1 e of
                             EPrim p => (jsPrim p, st)
@@ -629,6 +656,12 @@ fun process file =
                                 (str ("_" ^ var n), st)
                             else
                                 let
+                                    (*val () = Print.prefaces "ERel"
+                                             [("n", Print.PD.string (Int.toString n)),
+                                              ("inner", Print.PD.string (Int.toString inner)),
+                                              ("eq", MonoPrint.p_exp MonoEnv.empty
+                                                                     (#1 (quoteExp (List.nth (outer, n - inner))
+                                                                                   ((ERel (n - inner), loc), st))))]*)
                                     val n = n - inner
                                 in
                                     quoteExp (List.nth (outer, n)) ((ERel n, loc), st)
@@ -652,11 +685,15 @@ fun process file =
                                                           decoders = #decoders st,
                                                           maxName = #maxName st}
 
+                                                val old = e
                                                 val (e, st) = jsExp mode [] 0 (e, st)
+                                                val new = e
                                                 val e = deStrcat 0 e
                                                 
                                                 val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n"
                                             in
+                                                (*Print.prefaces "jsify'" [("old", MonoPrint.p_exp MonoEnv.empty old),
+                                                                         ("new", MonoPrint.p_exp MonoEnv.empty new)];*)
                                                 {decls = #decls st,
                                                  script = sc :: #script st,
                                                  included = #included st,
@@ -851,43 +888,42 @@ fun process file =
                             end
 
                           | ECase (e', pes, {result, ...}) =>
-                            (*if closedUpto inner e andalso List.all (fn (_, e) => closedUpto inner e) pes then
-                                let
-                                    val (e', st) = quoteExp result ((ERel 0, loc), st)
-                                in
-                                    ((ELet ("js", result, e, e'), loc),
-                                     st)
-                                end
-                            else*)
-                                let
-                                    val plen = length pes
-
-                                    val (cases, st) = ListUtil.foldliMap
-                                                          (fn (i, (p, e), st) =>
-                                                              let
-                                                                  val (e, st) = jsE (inner + E.patBindsN p) (e, st)
-                                                                  val fail =
-                                                                      if i = plen - 1 then
-                                                                          str "pf()"
-                                                                      else
-                                                                          str ("c" ^ Int.toString (i+1) ^ "()")
-                                                                  val c = jsPat 0 inner p e fail
-                                                              in
-                                                                  (strcat [str ("c" ^ Int.toString i ^ "=function(){return "),
-                                                                           c,
-                                                                           str "},"],
-                                                                   st)
-                                                              end)
-                                                          st pes
-
-                                    val (e, st) = jsE inner (e', st)
-                                in
-                                    (strcat (str "(d0="
-                                             :: e
-                                             :: str ","
-                                             :: List.revAppend (cases,
-                                                                [str "c0())"])), st)
-                                end
+                            let
+                                val plen = length pes
+
+                                val (cases, st) = ListUtil.foldliMap
+                                                      (fn (i, (p, e), st) =>
+                                                          let
+                                                              val (e, st) = jsE (inner + E.patBindsN p) (e, st)
+                                                              val fail =
+                                                                  if i = plen - 1 then
+                                                                      str "pf()"
+                                                                  else
+                                                                      str ("c" ^ Int.toString (i+1) ^ "()")
+                                                              val c = jsPat 0 inner p e fail
+                                                          in
+                                                              (strcat [str ("c" ^ Int.toString i ^ "=function(){return "),
+                                                                       c,
+                                                                       str "},"],
+                                                               st)
+                                                          end)
+                                                      st pes
+
+                                val depth = foldl Int.max 0 (map (fn (p, _) => 1 + patDepth p) pes)
+                                val normalDepth = foldl Int.max 0 (map (fn (_, e) => 1 + varDepth e) pes)
+                                val (e, st) = jsE inner (e', st)
+
+                                val len = inner + len
+                                val normalVars = List.tabulate (normalDepth, fn n => "_" ^ Int.toString (n + len))
+                                val patVars = List.tabulate (depth, fn n => "d" ^ Int.toString n)
+                            in
+                                (strcat (str "(function (){ var "
+                                         :: str (String.concatWith "," (normalVars @ patVars) ^ ";d0=")
+                                         :: e
+                                         :: str ";\nreturn ("
+                                         :: List.revAppend (cases,
+                                                            [str "c0()) } ())"])), st)
+                            end
 
                           | EStrcat (e1, e2) =>
                             let
@@ -939,7 +975,7 @@ fun process file =
                           | EJavaScript (_, _, SOME e) =>
                             (foundJavaScript := true;
                              (strcat [str "cs(function(){return ",
-                                      e,
+                                      compact inner e,
                                       str "})"],
                               st))
 
@@ -1054,8 +1090,11 @@ fun process file =
                                                   val locals = List.tabulate
                                                                    (varDepth e,
                                                                  fn i => str ("var _" ^ Int.toString (len + i) ^ ";"))
+                                                  val old = e
                                                   val (e, st) = jsExp m env 0 (e, st)
                                               in
+                                                  (*Print.prefaces "jsify" [("old", MonoPrint.p_exp MonoEnv.empty old),
+                                                                          ("new", MonoPrint.p_exp MonoEnv.empty e)];*)
                                                   (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st)
                                               end
                                       in
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 5a2aca85..94c57bac 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -536,7 +536,8 @@ fun reduce file =
 
         and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env
 
-        fun decl env d = d
+        fun decl env d = ((*Print.preface ("d", MonoPrint.p_decl env (d, ErrorMsg.dummySpan));*)
+                          d)
     in
         U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file
     end