Mercurial > urweb
changeset 801:5f49a6b759cb
Fix nasty bugs with longjmp() looping for uw_set_input(); and bad variable indexes for nested JavaScript in jscomp
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 14 May 2009 18:13:09 -0400 |
| parents | e92cfac1608f |
| children | ef6de4075dc1 |
| files | include/urweb.h lib/ur/listPair.ur lib/ur/listPair.urs src/c/driver.c src/c/urweb.c src/jscomp.sml src/mono_reduce.sml |
| diffstat | 7 files changed, 173 insertions(+), 77 deletions(-) [+] |
line wrap: on
line diff
--- a/include/urweb.h Thu May 14 13:18:31 2009 -0400 +++ b/include/urweb.h Thu May 14 18:13:09 2009 -0400 @@ -43,8 +43,8 @@ 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);
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/ur/listPair.ur Thu May 14 18:13:09 2009 -0400 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/ur/listPair.urs Thu May 14 18:13:09 2009 -0400 @@ -0,0 +1,2 @@ +val mapX : a ::: Type -> b ::: Type -> ctx ::: {Unit} + -> (a -> b -> xml ctx [] []) -> list a -> list b -> xml ctx [] []
--- a/src/c/driver.c Thu May 14 13:18:31 2009 -0400 +++ b/src/c/driver.c Thu May 14 18:13:09 2009 -0400 @@ -403,9 +403,14 @@ 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 @@ 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 - uw_set_input(ctx, name, ""); + else if (uw_set_input(ctx, name, "")) { + puts(uw_error_message(ctx)); + goto done; + } } } }
--- a/src/c/urweb.c Thu May 14 13:18:31 2009 -0400 +++ b/src/c/urweb.c Thu May 14 18:13:09 2009 -0400 @@ -482,6 +482,13 @@ 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 @@ 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 >= uw_inputs_len) - uw_error(ctx, FATAL, "For subform name %s, index %d is out of range", value, n); + if (n < 0) { + uw_set_error(ctx, "Bad subform name %s", value); + return -1; + } + + 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 @@ } 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 @@ 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 >= uw_inputs_len) - uw_error(ctx, FATAL, "For subforms name %s, index %d is out of range", value, n); + if (n < 0) { + uw_set_error(ctx, "Bad subforms name %s", value); + return -1; + } + + 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 @@ } else if (!strcasecmp(name, ".i")) { input *inps; - if (!ctx->cur_container) - uw_error(ctx, FATAL, "New entry without container"); - - if (ctx->cur_container->kind != SUBFORMS) - uw_error(ctx, FATAL, "Bad kind for entry parent"); + if (!ctx->cur_container) { + uw_set_error(ctx, "New entry without container"); + return -1; + } + + 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 @@ } else { int n = uw_input_num(name); - if (n < 0) - uw_error(ctx, FATAL, "Bad input name %s", name); - - if (n >= uw_inputs_len) - uw_error(ctx, FATAL, "For input name %s, index %d is out of range", name, n); + if (n < 0) { + uw_set_error(ctx, "Bad input name %s", name); + return -1; + } + + 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 @@ } } -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 >= uw_inputs_len) - uw_error(ctx, FATAL, "For file input name %s, index %d is out of range", name, n); + if (n < 0) { + uw_set_error(ctx, "Bad file input name %s", name); + return -1; + } + + 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);
--- a/src/jscomp.sml Thu May 14 13:18:31 2009 -0400 +++ b/src/jscomp.sml Thu May 14 18:13:09 2009 -0400 @@ -143,6 +143,32 @@ | [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 @@ 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 @@ 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 @@ (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 @@ 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 @@ 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 + 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 (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 + 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 @@ | EJavaScript (_, _, SOME e) => (foundJavaScript := true; (strcat [str "cs(function(){return ", - e, + compact inner e, str "})"], st)) @@ -1054,8 +1090,11 @@ 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
--- a/src/mono_reduce.sml Thu May 14 13:18:31 2009 -0400 +++ b/src/mono_reduce.sml Thu May 14 18:13:09 2009 -0400 @@ -536,7 +536,8 @@ 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