diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/c/urweb.c | 35 | ||||
-rw-r--r-- | src/cjrize.sml | 2 | ||||
-rw-r--r-- | src/mono.sml | 2 | ||||
-rw-r--r-- | src/mono_opt.sml | 5 | ||||
-rw-r--r-- | src/mono_print.sml | 3 | ||||
-rw-r--r-- | src/mono_reduce.sml | 2 | ||||
-rw-r--r-- | src/mono_util.sml | 4 | ||||
-rw-r--r-- | src/monoize.sml | 13 |
8 files changed, 66 insertions, 0 deletions
diff --git a/src/c/urweb.c b/src/c/urweb.c index 7a9b3e79..64cdb81e 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1056,6 +1056,41 @@ char *uw_Basis_ensqlBool(uw_Basis_bool b) { return (char *)&true; } +uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) { + char *r, *s2; + + uw_check_heap(ctx, strlen(s) * 4 + 2); + + r = s2 = ctx->heap_front; + *s2++ = '"'; + + for (; *s; s++) { + char c = *s; + + switch (c) { + case '"': + strcpy(s2, "\\\""); + s2 += 2; + break; + case '\\': + strcpy(s2, "\\\\"); + s2 += 2; + break; + default: + if (isprint(c)) + *s2++ = c; + else { + sprintf(s2, "\\%3o", c); + s2 += 4; + } + } + } + + strcpy(s2, "\""); + ctx->heap_front = s2 + 1; + return r; +} + uw_Basis_string uw_Basis_intToString(uw_context ctx, uw_Basis_int n) { int len; char *r; diff --git a/src/cjrize.sml b/src/cjrize.sml index 6c34923b..1152b0ef 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -420,6 +420,8 @@ fun cifyExp (eAll as (e, loc), sm) = ((L'.EUnurlify (e, t), loc), sm) end + | L.EJavaScript _ => raise Fail "EJavaScript remains" + fun cifyDecl ((d, loc), sm) = case d of L.DDatatype (x, n, xncs) => diff --git a/src/mono.sml b/src/mono.sml index f465d2bd..187b1853 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -96,6 +96,8 @@ datatype exp' = | EUnurlify of exp * typ + | EJavaScript of exp + withtype exp = exp' located diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 6c0e6e21..7f83c003 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -360,6 +360,11 @@ fun exp e = | EWrite (EPrim (Prim.String ""), loc) => ERecord [] + | EJavaScript (EAbs (_, (TRecord [], _), _, (EFfiApp ("Basis", "alert", [s]), _)), loc) => + EStrcat ((EPrim (Prim.String "alert("), loc), + (EStrcat ((EFfiApp ("Basis", "jsifyString", [s]), loc), + (EPrim (Prim.String ")"), loc)), loc)) + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) diff --git a/src/mono_print.sml b/src/mono_print.sml index 8d91d048..7b675438 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -275,6 +275,9 @@ fun p_exp' par env (e, _) = | EUnurlify (e, _) => box [string "unurlify(", p_exp env e, string ")"] + | EJavaScript e => box [string "JavaScript(", + p_exp env e, + string ")"] and p_exp env = p_exp' false env diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 9cf6d8e8..040414f3 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -75,6 +75,7 @@ fun impure (e, _) = | ELet (_, _, e1, e2) => impure e1 orelse impure e2 | EClosure (_, es) => List.exists impure es + | EJavaScript e => impure e val liftExpInExp = Monoize.liftExpInExp @@ -329,6 +330,7 @@ fun reduce file = | EDml e => summarize d e @ [WriteDb] | ENextval e => summarize d e @ [WriteDb] | EUnurlify (e, _) => summarize d e + | EJavaScript e => summarize d e fun exp env e = diff --git a/src/mono_util.sml b/src/mono_util.sml index 2b2476e7..18b5c948 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -311,6 +311,10 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mft t, fn t' => (EUnurlify (e', t'), loc))) + | EJavaScript e => + S.map2 (mfe ctx e, + fn e' => + (EJavaScript e', loc)) in mfe end diff --git a/src/monoize.sml b/src/monoize.sml index e23d4f80..e92a1c8a 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1744,6 +1744,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = result = (L'.TFfi ("Basis", "string"), loc)}), loc), fm) end + | (L'.TFun _, _) => + let + val s' = " " ^ lowercaseFirst x ^ "='" + in + ((L'.EStrcat (s, + (L'.EStrcat ( + (L'.EPrim (Prim.String s'), loc), + (L'.EStrcat ( + (L'.EJavaScript e, loc), + (L'.EPrim (Prim.String "'"), loc)), loc)), + loc)), loc), + fm) + end | _ => let val fooify = |