From 79655b086c036d07806d0c345ffc9e6683891fe4 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 14 May 2009 18:13:09 -0400 Subject: Fix nasty bugs with longjmp() looping for uw_set_input(); and bad variable indexes for nested JavaScript in jscomp --- src/c/driver.c | 22 +++++++--- src/c/urweb.c | 84 ++++++++++++++++++++++++++----------- src/jscomp.sml | 119 ++++++++++++++++++++++++++++++++++------------------ src/mono_reduce.sml | 3 +- 4 files changed, 156 insertions(+), 72 deletions(-) (limited to 'src') 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 -- cgit v1.2.3