summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-09-22 12:23:21 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-09-22 12:23:21 -0400
commit950fc955467d28baa7557992dc73044e0826b262 (patch)
treed6335ce5fefb5a16ea33ad1fe8316ea38ae06e22
parent020598d1989af90d999d822266eb9fc34543b67a (diff)
Hopefully complete refactoring of Jscomp to output ASTs; partial implementation of interpreter in runtime system (demo/alert works)
-rw-r--r--lib/js/urweb.js186
-rw-r--r--src/c/urweb.c12
-rw-r--r--src/jscomp.sml607
-rw-r--r--src/monoize.sml45
-rw-r--r--src/scriptcheck.sml9
5 files changed, 406 insertions, 453 deletions
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index a952c049..abdf2ab7 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -1,3 +1,17 @@
+// Function versions of operators
+
+function not(x) { return !x; }
+function neg(x) { return -x; }
+
+function eq(x, y) { return x == y; }
+function plus(x, y) { return x + y; }
+function minus(x, y) { return x - y; }
+function times(x, y) { return x * y; }
+function div(x, y) { return x / y; }
+function mod(x, y) { return x % y; }
+function lt(x, y) { return x < y; }
+function le(x, y) { return x <= y; }
+
// Lists
function cons(v, ls) {
@@ -765,8 +779,176 @@ function rv(chn, parse, k) {
// Key events
-function kc(e) {
- return window.event ? e.keyCode : e.which;
+var uw_event = null;
+
+function kc() {
+ return window.event ? uw_event.keyCode : uw_event.which;
+}
+
+
+// The Ur interpreter
+
+var urfuncs = [];
+
+function lookup(env, n) {
+ while (env != null) {
+ if (n == 0)
+ return env.data;
+ else {
+ --n;
+ env = env.next;
+ }
+ }
+
+ throw "Out-of-bounds Ur variable reference";
+}
+
+function exec0(env, e) {
+ var stack = null;
+
+ while (true) {
+ switch (e.c) {
+ case "c":
+ var v = e.v;
+ if (stack == null)
+ return v;
+ var fr = stack.data;
+
+ switch (fr.c) {
+ case "s":
+ e = {c: "c", v: {v: v}};
+ stack = stack.next;
+ break;
+ case "1":
+ e = {c: "c", v: {n: fr.n, v: v}};
+ stack = stack.next;
+ break;
+ case "f":
+ fr.args[fr.pos++] = v;
+ if (fr.a == null) {
+ e = {c: "c", v: fr.f.apply(null, fr.args)};
+ stack = stack.next;
+ } else {
+ e = fr.a.data;
+ fr.a = fr.a.next;
+ }
+ break;
+ case "a1":
+ if (v == null || !v.body)
+ throw "Ur: applying non-function";
+ stack = cons({c: "a2", env: v.env, body: v.body}, stack.next);
+ e = fr.x;
+ break;
+ case "a2":
+ stack = cons({c: "a3", env: env}, stack.next);
+ env = cons(v, fr.env);
+ e = fr.body;
+ break;
+ case "a3":
+ env = fr.env;
+ stack = stack.next;
+ break;
+ case "r":
+ fr.fs["_" + fr.n] = v;
+ if (fr.l == null) {
+ e = {c: "c", v: fr.fs};
+ stack = stack.next;
+ } else {
+ fr.n = fr.l.data.n;
+ e = fr.l.data.v;
+ fr.l = fr.l.next;
+ }
+ break;
+ case ".":
+ e = {c: "c", v: v["_" + fr.f]};
+ stack = stack.next;
+ break;
+ case ";":
+ e = fr.e2;
+ stack = stack.next;
+ break;
+ case "=1":
+ env = cons(v, env);
+ e = fr.e2;
+ stack = stack.next;
+ break;
+ case "=":
+ env = cons(v, env);
+ e = fr.e2;
+ stack = cons({c: "a3", env: env}, stack.next);
+ break;
+ default:
+ throw "Unknown Ur continuation kind";
+ }
+
+ break;
+ case "v":
+ e = {c: "c", v: lookup(env, e.n)};
+ break;
+ case "n":
+ e = {c: "c", v: urfuncs[e.n]};
+ break;
+ case "s":
+ stack = cons({c: "s"}, stack);
+ e = e.v;
+ break;
+ case "1":
+ stack = cons({c: "1", n: e.n}, stack);
+ e = e.v;
+ break;
+ case "f":
+ if (e.a == null)
+ e = {c: "c", v: e.f()};
+ else {
+ var args = [];
+ stack = cons({c: "f", f: e.f, args: args, pos: 0, a: e.a.next}, stack);
+ e = e.a.data;
+ }
+ break;
+ case "l":
+ e = {c: "c", v: {env: env, body: e.b}};
+ break;
+ case "a":
+ stack = cons({c: "a1", x: e.x}, stack);
+ e = e.f;
+ break;
+ case "r":
+ if (e.l == null)
+ throw "Empty Ur record in interpretation";
+ var fs = {};
+ stack = cons({c: "r", n: e.l.data.n, fs: fs, l: e.l.next}, stack);
+ e = e.l.data;
+ break;
+ case ".":
+ stack = cons({c: ".", f: e.f}, stack);
+ e = e.r;
+ break;
+ case ";":
+ stack = cons({c: ";", e2: e.e2}, stack);
+ e = e.e1;
+ break;
+ case "=":
+ stack = cons({c: "=", e2: e.e2}, stack);
+ e = e.e1;
+ break;
+ case "e":
+ var env0 = env;
+ var e0 = e.e;
+ e = {c: "c", v: cs(function() { return exec0(env0, e0); })};
+ break;
+ default:
+ throw "Unknown Ur expression kind";
+ }
+ }
+}
+
+function exec(e) {
+ var r = exec0(null, e);
+
+ if (r != null && r.body)
+ return function(v) { return exec0(cons(v, r.env), r.body); };
+ else
+ return r;
}
diff --git a/src/c/urweb.c b/src/c/urweb.c
index cd33a790..855841e1 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1286,12 +1286,12 @@ uw_Basis_int uw_Basis_new_client_source(uw_context ctx, uw_Basis_string s) {
int len;
size_t s_len = strlen(s);
- uw_check_script(ctx, 12 + INTS_MAX + s_len);
- sprintf(ctx->script.front, "var s%d=sc(%n", ctx->source_count, &len);
+ uw_check_script(ctx, 18 + INTS_MAX + s_len);
+ sprintf(ctx->script.front, "var s%d=sc(exec(%n", ctx->source_count, &len);
ctx->script.front += len;
strcpy(ctx->script.front, s);
ctx->script.front += s_len;
- strcpy(ctx->script.front, ");");
+ strcpy(ctx->script.front, "));");
ctx->script.front += 2;
return ctx->source_count++;
@@ -1301,12 +1301,12 @@ uw_unit uw_Basis_set_client_source(uw_context ctx, uw_Basis_int n, uw_Basis_stri
int len;
size_t s_len = strlen(s);
- uw_check_script(ctx, 6 + INTS_MAX + s_len);
- sprintf(ctx->script.front, "sv(s%d,%n", (int)n, &len);
+ uw_check_script(ctx, 12 + INTS_MAX + s_len);
+ sprintf(ctx->script.front, "sv(s%d,exec(%n", (int)n, &len);
ctx->script.front += len;
strcpy(ctx->script.front, s);
ctx->script.front += s_len;
- strcpy(ctx->script.front, ");");
+ strcpy(ctx->script.front, "));");
ctx->script.front += 2;
return uw_unit_v;
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 30f578c4..7d9ee955 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -51,132 +51,15 @@ type state = {
maxName : int
}
-fun varDepth (e, _) =
- case e of
- EPrim _ => 0
- | ERel _ => 0
- | ENamed _ => 0
- | ECon (_, _, NONE) => 0
- | ECon (_, _, SOME e) => varDepth e
- | ENone _ => 0
- | ESome (_, e) => varDepth e
- | EFfi _ => 0
- | EFfiApp (_, _, es) => foldl Int.max 0 (map varDepth es)
- | EApp (e1, e2) => Int.max (varDepth e1, varDepth e2)
- | EAbs _ => 0
- | EUnop (_, e) => varDepth e
- | EBinop (_, e1, e2) => Int.max (varDepth e1, varDepth e2)
- | ERecord xes => foldl Int.max 0 (map (fn (_, e, _) => varDepth e) xes)
- | EField (e, _) => varDepth e
- | ECase (e, pes, _) =>
- foldl Int.max (varDepth e)
- (map (fn (p, e) => E.patBindsN p + varDepth e) pes)
- | EStrcat (e1, e2) => Int.max (varDepth e1, varDepth e2)
- | EError (e, _) => varDepth e
- | EReturnBlob {blob = e1, mimeType = e2, ...} => Int.max (varDepth e1, varDepth e2)
- | EWrite e => varDepth e
- | ESeq (e1, e2) => Int.max (varDepth e1, varDepth e2)
- | ELet (_, _, e1, e2) => Int.max (varDepth e1, 1 + varDepth e2)
- | EClosure _ => 0
- | EQuery _ => 0
- | EDml _ => 0
- | ENextval _ => 0
- | EUnurlify _ => 0
- | EJavaScript _ => 0
- | ESignalReturn e => varDepth e
- | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
- | ESignalSource e => varDepth e
- | EServerCall (e, ek, _, _) => Int.max (varDepth e, varDepth ek)
- | ERecv (e, ek, _) => Int.max (varDepth e, varDepth ek)
- | ESleep (e, ek) => Int.max (varDepth e, varDepth ek)
-
-fun closedUpto d =
- let
- fun cu inner (e, _) =
- case e of
- EPrim _ => true
- | ERel n => n < inner orelse n - inner >= d
- | ENamed _ => true
- | ECon (_, _, NONE) => true
- | ECon (_, _, SOME e) => cu inner e
- | ENone _ => true
- | ESome (_, e) => cu inner e
- | EFfi _ => true
- | EFfiApp (_, _, es) => List.all (cu inner) es
- | EApp (e1, e2) => cu inner e1 andalso cu inner e2
- | EAbs (_, _, _, e) => cu (inner + 1) e
- | EUnop (_, e) => cu inner e
- | EBinop (_, e1, e2) => cu inner e1 andalso cu inner e2
- | ERecord xes => List.all (fn (_, e, _) => cu inner e) xes
- | EField (e, _) => cu inner e
- | ECase (e, pes, _) =>
- cu inner e
- andalso List.all (fn (p, e) => cu (inner + E.patBindsN p) e) pes
- | EStrcat (e1, e2) => cu inner e1 andalso cu inner e2
- | EError (e, _) => cu inner e
- | EReturnBlob {blob = e1, mimeType = e2, ...} => cu inner e1 andalso cu inner e2
- | EWrite e => cu inner e
- | ESeq (e1, e2) => cu inner e1 andalso cu inner e2
- | ELet (_, _, e1, e2) => cu inner e1 andalso cu (inner + 1) e2
- | EClosure (_, es) => List.all (cu inner) es
- | EQuery {query, body, initial, ...} =>
- cu inner query
- andalso cu (inner + 2) body
- andalso cu inner initial
- | EDml e => cu inner e
- | ENextval e => cu inner e
- | EUnurlify (e, _) => cu inner e
- | EJavaScript (_, e) => cu inner e
- | ESignalReturn e => cu inner e
- | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2
- | ESignalSource e => cu inner e
- | EServerCall (e, ek, _, _) => cu inner e andalso cu inner ek
- | ERecv (e, ek, _) => cu inner e andalso cu inner ek
- | ESleep (e, ek) => cu inner e andalso cu inner ek
- in
- cu 0
- end
-
fun strcat loc es =
case es of
[] => (EPrim (Prim.String ""), loc)
| [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}
-
exception CantEmbed of typ
-fun inString {needle, haystack} =
- let
- val (_, suffix) = Substring.position needle (Substring.full haystack)
- in
- not (Substring.isEmpty suffix)
- end
+fun inString {needle, haystack} = String.isSubstring needle haystack
fun process file =
let
@@ -520,14 +403,12 @@ fun process file =
let
val str = str loc
- fun var n = Int.toString (len + inner - n - 1)
-
fun patCon pc =
case pc of
PConVar n => str (Int.toString n)
| PConFfi {mod = "Basis", con = "True", ...} => str "true"
| PConFfi {mod = "Basis", con = "False", ...} => str "false"
- | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"")
+ | PConFfi {con, ...} => str ("\"" ^ con ^ "\"")
fun unsupported s =
(EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]");
@@ -566,98 +447,56 @@ fun process file =
| _ => str (Prim.toString p)
end
- fun jsPat depth inner (p, _) succ fail =
+ fun jsPat (p, _) =
case p of
- PWild => succ
- | PVar _ => strcat [str ("(_" ^ Int.toString (len + inner) ^ "=d"
- ^ Int.toString depth ^ ","),
- succ,
- str ")"]
- | PPrim p => strcat [str ("(d" ^ Int.toString depth ^ "=="),
+ PWild => str "{c:\"w\"}"
+ | PVar _ => str "{c:\"v\"}"
+ | PPrim p => strcat [str "{c:\"c\",v:",
jsPrim p,
- str "?",
- succ,
- str ":",
- fail,
- str ")"]
+ str "}"]
| PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) =>
- strcat [str ("(d" ^ Int.toString depth ^ "?"),
- succ,
- str ":",
- fail,
- str ")"]
+ str "{c:\"c\",v:true}"
| PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) =>
- strcat [str ("(d" ^ Int.toString depth ^ "?"),
- fail,
- str ":",
- succ,
- str ")"]
+ str "{c:\"c\",v:false}"
| PCon (Option, _, NONE) =>
- strcat [str ("(d" ^ Int.toString depth ^ "!=null?"),
- fail,
- str ":",
- succ,
- str ")"]
+ str "{c:\"c\",v:null}"
| PCon (Option, PConVar n, SOME p) =>
(case IM.find (someTs, n) of
NONE => raise Fail "Jscomp: Not in someTs"
- | SOME t =>
- strcat [str ("(d" ^ Int.toString depth ^ "!=null?(d"
- ^ Int.toString (depth+1) ^ "=d" ^ Int.toString depth
- ^ (if isNullable t then
- ".v,"
- else
- "")
- ^ ","),
- jsPat (depth+1) inner p succ fail,
- str "):",
- fail,
- str ")"])
- | PCon (_, pc, NONE) =>
- strcat [str ("(d" ^ Int.toString depth ^ "=="),
- patCon pc,
- str "?",
- succ,
- str ":",
- fail,
- str ")"]
- | PCon (_, pc, SOME p) =>
- strcat [str ("(d" ^ Int.toString depth ^ ".n=="),
- patCon pc,
- str ("?(d" ^ Int.toString (depth+1) ^ "=d" ^ Int.toString depth ^ ".v,"),
- jsPat (depth+1) inner p succ fail,
- str "):",
- fail,
- str ")"]
- | PRecord xps =>
- let
- val (_, succ) = foldl
- (fn ((x, p, _), (inner, succ)) =>
- (inner + E.patBindsN p,
- strcat [str ("(d" ^ Int.toString (depth+1) ^ "=d"
- ^ Int.toString depth ^ "._" ^ x ^ ","),
- jsPat (depth+1) inner p succ fail,
- str ")"]))
- (inner, succ) xps
- in
- succ
- end
- | PNone _ => strcat [str ("(d" ^ Int.toString depth ^ "!=null?"),
- fail,
- str ":",
- succ,
- str ")"]
- | PSome (t, p) => strcat [str ("(d" ^ Int.toString depth ^ "!=null?(d" ^ Int.toString (depth+1)
- ^ "=d" ^ Int.toString depth
+ | SOME t => strcat [str ("{c:\"s\",n:"
+ ^ (if isNullable t then
+ "true"
+ else
+ "false")
+ ^ ",p:"),
+ jsPat p,
+ str "}"])
+ | PCon (_, pc, NONE) => strcat [str "{c:\"0\",n:",
+ patCon pc,
+ str "}"]
+ | PCon (_, pc, SOME p) => strcat [str "{c:\"1\",n:",
+ patCon pc,
+ str ",p:",
+ jsPat p,
+ str "}"]
+ | PRecord xps => strcat [str "{c:\"r\",l:",
+ foldr (fn ((x, p, _), e) =>
+ strcat [str ("cons({n:\"" ^ x ^ "\",p:"),
+ jsPat p,
+ str "},",
+ e,
+ str ")"])
+ (str "null") xps,
+ str "}"]
+ | PNone _ => str "{c:\"c\",v:null}"
+ | PSome (t, p) => strcat [str ("{c:\"s\",n:"
^ (if isNullable t then
- ".v"
+ "true"
else
- "")
- ^ ","),
- jsPat (depth+1) inner p succ fail,
- str "):",
- fail,
- str ")"]
+ "false")
+ ^ ",p:"),
+ jsPat p,
+ str "}"]
val jsifyString = String.translate (fn #"\"" => "\\\""
| #"\\" => "\\\\"
@@ -677,39 +516,28 @@ fun process file =
raise Fail "Jscomp: deStrcat")
val quoteExp = quoteExp loc
-
- val hasQuery = U.Exp.exists {typ = fn _ => false,
- exp = fn EQuery _ => true
- | _ => false}
-
- val indirectQuery = U.Exp.exists {typ = fn _ => false,
- exp = fn ENamed n =>
- (case IM.find (nameds, n) of
- NONE => false
- | SOME e => hasQuery e)
- | _ => false}
-
in
- (*if indirectQuery e then
- Print.preface ("Indirect", MonoPrint.p_exp MonoEnv.empty e)
- else
- ();*)
-
(*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)
+ EPrim p => (strcat [str "{c:\"c\",v:",
+ jsPrim p,
+ str "}"],
+ st)
| ERel n =>
if n < inner then
- (str ("_" ^ var n), st)
+ (str ("{c:\"v\",n:" ^ Int.toString n ^ "}"), st)
else
let
val n = n - inner
(*val () = Print.prefaces "quote" [("t", MonoPrint.p_typ MonoEnv.empty
(List.nth (outer, n)))]*)
+ val (e, st) = quoteExp (List.nth (outer, n)) ((ERel n, loc), st)
in
- quoteExp (List.nth (outer, n)) ((ERel n, loc), st)
+ (strcat [str "{c:\"c\",v:",
+ e,
+ str "}"], st)
end
| ENamed n =>
@@ -731,11 +559,11 @@ fun process file =
maxName = #maxName st}
val old = e
- val (e, st) = jsExp mode [] 0 (e, st)
+ val (e, st) = jsExp mode [] (e, st)
val new = e
val e = deStrcat 0 e
- val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n"
+ val sc = "urfuncs[" ^ Int.toString n ^ "] = " ^ e ^ ";\n"
in
(*Print.prefaces "jsify'" [("old", MonoPrint.p_exp MonoEnv.empty old),
("new", MonoPrint.p_exp MonoEnv.empty new)];*)
@@ -748,10 +576,10 @@ fun process file =
maxName = #maxName st}
end
in
- (str ("_n" ^ Int.toString n), st)
+ (str ("{c:\"n\",n:" ^ Int.toString n ^ "}"), st)
end
- | ECon (Option, _, NONE) => (str "null", st)
+ | ECon (Option, _, NONE) => (str "{c:\"c\",v:null}", st)
| ECon (Option, PConVar n, SOME e) =>
let
val (e, st) = jsE inner (e, st)
@@ -760,32 +588,35 @@ fun process file =
NONE => raise Fail "Jscomp: Not in someTs [2]"
| SOME t =>
(if isNullable t then
- strcat [str "{v:",
+ strcat [str "{c:\"s\",v:",
e,
str "}"]
else
e, st)
end
- | ECon (_, pc, NONE) => (patCon pc, st)
+ | ECon (_, pc, NONE) => (strcat [str "{c:\"c\",v:",
+ patCon pc,
+ str "}"],
+ st)
| ECon (_, pc, SOME e) =>
let
val (s, st) = jsE inner (e, st)
in
- (strcat [str "{n:",
+ (strcat [str "{c:\"1\",n:",
patCon pc,
str ",v:",
s,
str "}"], st)
end
- | ENone _ => (str "null", st)
+ | ENone _ => (str "{c:\"c\",v:null}", st)
| ESome (t, e) =>
let
val (e, st) = jsE inner (e, st)
in
(if isNullable t then
- strcat [str "{v:", e, str "}"]
+ strcat [str "{c:\"s\",v:", e, str "}"]
else
e, st)
end
@@ -798,12 +629,11 @@ fun process file =
"ERROR")
| SOME s => s
in
- (str name, st)
+ (str ("{c:\"c\",v:" ^ name ^ "}"), st)
end
- | EFfiApp ("Basis", "sigString", [_]) => (strcat [str "\"",
- e,
- str "\""], st)
- | EFfiApp ("Basis", "kc", []) => (str "kc(event)", st)
+ | EFfiApp ("Basis", "sigString", [_]) => (strcat [str "{c:\"c\",v:\"",
+ e,
+ str "\"}"], st)
| EFfiApp (m, x, args) =>
let
val name = case Settings.jsFunc (m, x) of
@@ -811,34 +641,24 @@ fun process file =
^ x ^ " in JavaScript");
"ERROR")
| SOME s => s
+
+ val (e, st) = foldr (fn (e, (acc, st)) =>
+ let
+ val (e, st) = jsE inner (e, st)
+ in
+ (strcat [str "cons(",
+ e,
+ str ",",
+ acc,
+ str ")"],
+ st)
+ end)
+ (str "null", st) args
in
- case args of
- [] => (str (name ^ "()"), st)
- | [e] =>
- let
- val (e, st) = jsE inner (e, st)
- in
- (strcat [str (name ^ "("),
- e,
- str ")"], st)
- end
- | e :: es =>
- let
- val (e, st) = jsE inner (e, st)
- val (es, st) = ListUtil.foldlMapConcat
- (fn (e, st) =>
- let
- val (e, st) = jsE inner (e, st)
- in
- ([str ",", e], st)
- end)
- st es
- in
- (strcat (str (name ^ "(")
- :: e
- :: es
- @ [str ")"]), st)
- end
+ (strcat [str ("{c:\"f\",f:" ^ name ^ ",a:"),
+ e,
+ str "}"],
+ st)
end
| EApp (e1, e2) =>
@@ -846,90 +666,80 @@ fun process file =
val (e1, st) = jsE inner (e1, st)
val (e2, st) = jsE inner (e2, st)
in
- (strcat [e1, str "(", e2, str ")"], st)
+ (strcat [str "{c:\"a\",f:",
+ e1,
+ str ",x:",
+ e2,
+ str "}"], st)
end
| EAbs (_, _, _, e) =>
let
- val locals = List.tabulate
- (varDepth e,
- fn i => str ("var _" ^ Int.toString (len + inner + i + 1) ^ ";"))
val (e, st) = jsE (inner + 1) (e, st)
in
- (strcat (str ("function(_"
- ^ Int.toString (len + inner)
- ^ "){")
- :: locals
- @ [str "return ",
- e,
- str "}"]),
- st)
+ (strcat [str "{c:\"l\",b:",
+ e,
+ str "}"], st)
end
| EUnop (s, e) =>
let
+ val name = case s of
+ "!" => "not"
+ | "-" => "neg"
+ | _ => raise Fail "Jscomp: Unknown unary operator"
+
val (e, st) = jsE inner (e, st)
in
- (strcat [str ("(" ^ s),
+ (strcat [str ("{c:\"f\",f:" ^ name ^ ",:a:cons("),
e,
- str ")"],
+ str ",null)}"],
st)
end
- | EBinop ("strcmp", e1, e2) =>
- let
- val (e1, st) = jsE inner (e1, st)
- val (e2, st) = jsE inner (e2, st)
- in
- (strcat [str "strcmp(",
- e1,
- str ",",
- e2,
- str ")"],
- st)
- end
| EBinop (s, e1, e2) =>
let
- val s =
- case s of
- "!strcmp" => "=="
- | _ => s
+ val name = case s of
+ "==" => "eq"
+ | "!strcmp" => "eq"
+ | "+" => "plus"
+ | "-" => "minus"
+ | "*" => "times"
+ | "/" => "div"
+ | "%" => "mod"
+ | "<" => "lt"
+ | "<=" => "le"
+ | _ => raise Fail "Jscomp: Unknown binary operator"
val (e1, st) = jsE inner (e1, st)
val (e2, st) = jsE inner (e2, st)
in
- (strcat [str "(",
+ (strcat [str ("{c:\"f\",f:" ^ name ^ ",a:cons("),
e1,
- str s,
+ str ",cons(",
e2,
- str ")"],
+ str ",null))}"],
st)
end
- | ERecord [] => (str "null", st)
- | ERecord [(x, e, _)] =>
- let
- val (e, st) = jsE inner (e, st)
- in
- (strcat [str ("{_" ^ x ^ ":"), e, str "}"], st)
- end
- | ERecord ((x, e, _) :: xes) =>
+ | ERecord [] => (str "{c:\"c\",v:null}", st)
+ | ERecord xes =>
let
- val (e, st) = jsE inner (e, st)
-
val (es, st) =
foldr (fn ((x, e, _), (es, st)) =>
let
val (e, st) = jsE inner (e, st)
in
- (str (",_" ^ x ^ ":")
- :: e
- :: es,
+ (strcat [str ("cons({n:\"" ^ x ^ ",v:"),
+ e,
+ str "},",
+ es,
+ str ")"],
st)
end)
- ([str "}"], st) xes
+ (str "null", st) xes
in
- (strcat (str ("{_" ^ x ^ ":")
- :: e
- :: es),
+ (strcat [str "{c:\"r\",l:",
+ es,
+ str "}"],
st)
end
| EField (e', x) =>
@@ -938,8 +748,9 @@ fun process file =
let
val (e', st) = jsE inner (e', st)
in
- (strcat [e',
- str ("._" ^ x)], st)
+ (strcat [str "{c:\".\",r:",
+ e',
+ str (",f:\"" ^ x ^ "\"}")], st)
end
fun seek (e, xs) =
@@ -960,8 +771,12 @@ fun process file =
val e = (ERel n, loc)
val e = foldl (fn (x, e) => (EField (e, x), loc)) e xs
+ val (e, st) = quoteExp t (e, st)
in
- quoteExp t (e, st)
+ (strcat [str "{c:\"c\",v:",
+ e,
+ str "}"],
+ st)
end
| EField (e', x) => seek (e', x :: xs)
| _ => default ()
@@ -969,43 +784,31 @@ fun process file =
seek (e', [x])
end
- | ECase (e', pes, {result, ...}) =>
+ | ECase (e', pes, _) =>
let
- val plen = length pes
+ val (e', st) = jsE inner (e', st)
- 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(\"" ^ ErrorMsg.spanToString loc ^ "\")")
- 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)
- val caseVars = ListUtil.mapi (fn (i, _) => "c" ^ Int.toString i) pes
+ val (ps, st) =
+ foldr (fn ((p, e), (ps, st)) =>
+ let
+ val (e, st) = jsE inner (e, st)
+ in
+ (strcat [str "cons({p:",
+ jsPat p,
+ str ",b:",
+ e,
+ str "},",
+ ps,
+ str ")"],
+ st)
+ end)
+ (str "null", st) pes
in
- (strcat (str "(function (){ var "
- :: str (String.concatWith "," (normalVars @ patVars @ caseVars) ^ ";d0=")
- :: e
- :: str ";\nreturn ("
- :: List.revAppend (cases,
- [str "c0()) } ())"])), st)
+ (strcat [str "{c:\"m\",e:",
+ e,
+ str ",p:",
+ ps,
+ str "}"], st)
end
| EStrcat (e1, e2) =>
@@ -1013,43 +816,34 @@ fun process file =
val (e1, st) = jsE inner (e1, st)
val (e2, st) = jsE inner (e2, st)
in
- (strcat [str "cat(", e1, str ",", e2, str ")"], st)
+ (strcat [str "{c:\"f\",f:cat,a:cons(", e1, str ",cons(", e2, str ",null))}"], st)
end
| EError (e, _) =>
let
val (e, st) = jsE inner (e, st)
in
- (strcat [str "er(", e, str ")"],
+ (strcat [str "{c:\"f\",f:er,a:cons(", e, str ",null)}"],
st)
end
- | EWrite e =>
- let
- val (e, st) = jsE inner (e, st)
- in
- (strcat [str "document.write(",
- e,
- str ".v)"], st)
- end
-
| ESeq (e1, e2) =>
let
val (e1, st) = jsE inner (e1, st)
val (e2, st) = jsE inner (e2, st)
in
- (strcat [str "(", e1, str ",", e2, str ")"], st)
+ (strcat [str "{c:\";\",e1:", e1, str ",e2:", e2, str "}"], st)
end
| ELet (_, _, e1, e2) =>
let
val (e1, st) = jsE inner (e1, st)
val (e2, st) = jsE (inner + 1) (e2, st)
in
- (strcat [str ("(_" ^ Int.toString (len + inner) ^ "="),
+ (strcat [str "{c:\"=\",e1:",
e1,
- str ",",
+ str ",e2:",
e2,
- str ")"], st)
+ str "}"], st)
end
| EJavaScript (Source _, e) =>
@@ -1057,21 +851,16 @@ fun process file =
jsE inner (e, st))
| EJavaScript (_, e) =>
let
- val locals = List.tabulate
- (varDepth e,
- fn i => str ("var _" ^ Int.toString (len + inner + i) ^ ";"))
-
val (e, st) = jsE inner (e, st)
in
foundJavaScript := true;
- (strcat (str "cs(function(){"
- :: locals
- @ [str "return ",
- (*compact inner*) e,
- str "})"]),
+ (strcat [str "{c:\"e\",e:",
+ e,
+ str "}"],
st)
end
+ | EWrite _ => unsupported "EWrite"
| EClosure _ => unsupported "EClosure"
| EQuery _ => unsupported "Query"
| EDml _ => unsupported "DML"
@@ -1083,9 +872,9 @@ fun process file =
let
val (e, st) = jsE inner (e, st)
in
- (strcat [str "sr(",
+ (strcat [str "{c:\"f\",f:sr,a:cons(",
e,
- str ")"],
+ str ",null)}"],
st)
end
| ESignalBind (e1, e2) =>
@@ -1093,20 +882,20 @@ fun process file =
val (e1, st) = jsE inner (e1, st)
val (e2, st) = jsE inner (e2, st)
in
- (strcat [str "sb(",
+ (strcat [str "{c:\"b\",e1:",
e1,
- str ",",
+ str ",e2:",
e2,
- str ")"],
+ str "}"],
st)
end
| ESignalSource e =>
let
val (e, st) = jsE inner (e, st)
in
- (strcat [str "ss(",
+ (strcat [str "{c:\"f\",f:ss,a:cons(",
e,
- str ")"],
+ str ",null)}"],
st)
end
@@ -1116,16 +905,18 @@ fun process file =
val (ek, st) = jsE inner (ek, st)
val (unurl, st) = unurlifyExp loc (t, st)
in
- (strcat [str ("rc(cat(\"" ^ Settings.getUrlPrefix () ^ "\","),
+ (strcat [str ("{c:\"f\",f:rc,a:cons({c:\"c\",v:\""
+ ^ Settings.getUrlPrefix ()
+ ^ "\"},cons("),
e,
- str ("), function(s){var t=s.split(\"/\");var i=0;return "
- ^ unurl ^ "},"),
+ str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return "
+ ^ unurl ^ "}},cons({c:\"!\",e:"),
ek,
- str (","
+ str ("},cons("
^ (case eff of
ReadCookieWrite => "true"
| _ => "false")
- ^ ")")],
+ ^ ",null)))))}")],
st)
end
@@ -1135,12 +926,12 @@ fun process file =
val (ek, st) = jsE inner (ek, st)
val (unurl, st) = unurlifyExp loc (t, st)
in
- (strcat [str "rv(",
+ (strcat [str ("{c:\"f\",f:rv,a:cons("),
e,
- str (", function(s){var t=s.split(\"/\");var i=0;return "
- ^ unurl ^ "},"),
+ str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return "
+ ^ unurl ^ "}},cons({c:\"!\",e:"),
ek,
- str ")"],
+ str ("},null)))}")],
st)
end
@@ -1149,19 +940,18 @@ fun process file =
val (e, st) = jsE inner (e, st)
val (ek, st) = jsE inner (ek, st)
in
- (strcat [str "window.setTimeout(",
+ (strcat [str "{c:\"f\",f:window.setTimeout,a:cons(",
ek,
- str ", ",
+ str ",cons(",
e,
- str ")"],
+ str ",null))}"],
st)
end
end
in
- jsE
+ jsE 0
end
-
fun patBinds ((p, _), env) =
case p of
PWild => env
@@ -1350,28 +1140,9 @@ fun process file =
end
| EJavaScript (m, e') =>
- (let
- val len = length outer
- fun str s = (EPrim (Prim.String s), #2 e')
-
- val locals = List.tabulate
- (varDepth e',
- fn i => str ("var _" ^ Int.toString (len + i) ^ ";"))
-
- val (e', st) = jsExp m outer 0 (e', st)
-
- val e' =
- case locals of
- [] => e'
- | _ =>
- strcat (#2 e') (str "(function(){"
- :: locals
- @ [str "return ",
- e',
- str "}())"])
- in
- (e', st)
- end handle CantEmbed _ => (e, st))
+ (foundJavaScript := true;
+ jsExp m outer (e', st)
+ handle CantEmbed _ => (e, st))
| ESignalReturn e =>
let
diff --git a/src/monoize.sml b/src/monoize.sml
index 00230d1a..c0ae1fee 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2522,17 +2522,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| (L'.TFun (dom, _), _) =>
let
val s' = " " ^ lowercaseFirst x ^ "='"
- val e = case #1 dom of
- L'.TRecord [] => (L'.EApp (e, (L'.ERecord [], loc)), loc)
- | _ => (L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "kc", []), loc)),
- loc), (L'.ERecord [], loc)), loc)
+ val (e, s') =
+ case #1 dom of
+ L'.TRecord [] => ((L'.EApp (e, (L'.ERecord [], loc)), loc), s')
+ | _ => ((L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "kc", []), loc)),
+ loc), (L'.ERecord [], loc)), loc),
+ s' ^ "uwe=event;")
+ val s' = s' ^ "exec("
in
((L'.EStrcat (s,
(L'.EStrcat (
(L'.EPrim (Prim.String s'), loc),
(L'.EStrcat (
(L'.EJavaScript (L'.Attribute, e), loc),
- (L'.EPrim (Prim.String ";return false'"), loc)), loc)),
+ (L'.EPrim (Prim.String ");return false'"), loc)), loc)),
loc)), loc),
fm)
end
@@ -2621,13 +2624,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val assgns = List.mapPartial
(fn ("Source", _, _) => NONE
| ("Onchange", e, _) =>
- SOME (strcat [str "addOnChange(d,",
+ SOME (strcat [str "addOnChange(d,exec(",
(L'.EJavaScript (L'.Script, e), loc),
- str ")"])
+ str "))"])
| (x, e, _) =>
- SOME (strcat [str ("d." ^ lowercaseFirst x ^ "="),
+ SOME (strcat [str ("d." ^ lowercaseFirst x ^ "=exec("),
(L'.EJavaScript (L'.Script, e), loc),
- str ";"]))
+ str ");"]))
attrs
in
case assgns of
@@ -2646,7 +2649,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
let
val e = (L'.EApp (e, (L'.ERecord [], loc)), loc)
in
- (L'.EJavaScript (L'.Attribute, e), loc)
+ (L'.EStrcat ((L'.EPrim (Prim.String "exec("), loc),
+ (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc),
+ (L'.EPrim (Prim.String ")"), loc)), loc)), loc)
end
in
normal ("body",
@@ -2677,9 +2682,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
[("Signal", e, _)] =>
((L'.EStrcat
((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\""
- ^ tag ^ "\", ")), loc),
+ ^ tag ^ "\", exec(")), loc),
(L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
- (L'.EPrim (Prim.String (")</script>")), loc)), loc)), loc),
+ (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
fm)
| _ => raise Fail "Monoize: Bad dyn attributes"
end
@@ -2701,9 +2706,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
loc)), loc), fm)
end
| SOME (_, src, _) =>
- (strcat [str "<script type=\"text/javascript\">inp(",
+ (strcat [str "<script type=\"text/javascript\">inp(exec(",
(L'.EJavaScript (L'.Script, src), loc),
- str ")</script>"],
+ str "))</script>"],
fm))
| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
raise Fail "No name passed to textbox tag"))
@@ -2773,9 +2778,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
end
| SOME (_, src, _) =>
let
- val sc = strcat [str "inp(",
+ val sc = strcat [str "inp(exec(",
(L'.EJavaScript (L'.Script, src), loc),
- str ")"]
+ str "))"]
val sc = setAttrs sc
in
(strcat [str "<script type=\"text/javascript\">",
@@ -2796,9 +2801,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
end
| SOME (_, src, _) =>
let
- val sc = strcat [str "chk(",
+ val sc = strcat [str "chk(exec(",
(L'.EJavaScript (L'.Script, src), loc),
- str ")"]
+ str "))"]
val sc = setAttrs sc
in
(strcat [str "<script type=\"text/javascript\">",
@@ -2824,11 +2829,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
let
val (xml, fm) = monoExp (env, st, fm) xml
- val sc = strcat [str "sel(",
+ val sc = strcat [str "sel(exec(",
(L'.EJavaScript (L'.Script, src), loc),
str ",",
(L'.EJavaScript (L'.Script, xml), loc),
- str ")"]
+ str "))"]
val sc = setAttrs sc
in
(strcat [str "<script type=\"text/javascript\">",
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
index 09e9e884..c4623fc3 100644
--- a/src/scriptcheck.sml
+++ b/src/scriptcheck.sml
@@ -67,7 +67,7 @@ val events = ["abort",
"unload"]
val scriptWords = "<script"
- :: map (fn s => "on" ^ s ^ " ='") events
+ :: map (fn s => " on" ^ s ^ "='") events
val pushWords = ["rv("]
@@ -75,12 +75,7 @@ fun classify (ds, ps) =
let
val proto = Settings.currentProtocol ()
- fun inString {needle, haystack} =
- let
- val (_, suffix) = Substring.position needle (Substring.full haystack)
- in
- not (Substring.isEmpty suffix)
- end
+ fun inString {needle, haystack} = String.isSubstring needle haystack
fun hasClient {basis, words, onload} csids =
let