summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-09-22 14:15:29 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-09-22 14:15:29 -0400
commit5053cc1cc65d193cc4d3298a9d2485c0139a9bf9 (patch)
tree4f6af43d27894091ed79d61f3202eacffd17fcfd
parentc328bb9c8bf1c3ac70b9e7e14157ecd2b6ba0b1d (diff)
Compiled an 'option' pattern-match
-rw-r--r--lib/js/urweb.js56
-rw-r--r--src/jscomp.sml24
-rw-r--r--tests/jscomp.ur11
3 files changed, 73 insertions, 18 deletions
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 0cafd8f8..13f93867 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -803,6 +803,39 @@ function lookup(env, n) {
throw "Out-of-bounds Ur variable reference";
}
+function execP(env, p, v) {
+ switch (p.c) {
+ case "w":
+ return env;
+ case "v":
+ return cons(v, env);
+ case "c":
+ if (v == p.v)
+ return env;
+ else
+ return false;
+ case "s":
+ if (v == null)
+ return false;
+ else
+ return execP(env, p.p, p.n ? v.v : v);
+ case "1":
+ if (v.n != p.n)
+ return false;
+ else
+ return execP(env, p.p, v.v);
+ case "r":
+ for (var fs = p.l; fs != null; fs = fs.next) {
+ env = execP(env, fs.data.p, v["_" + fs.data.n]);
+ if (env == false)
+ return false;
+ }
+ return env;
+ default:
+ throw ("Unknown Ur pattern kind" + p.c);
+ }
+}
+
function exec0(env, e) {
var stack = null;
@@ -872,16 +905,25 @@ function exec0(env, e) {
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;
+ case "m":
+ var ps;
+ for (ps = fr.p; ps != null; ps = ps.next) {
+ var r = execP(env, ps.data.p, v);
+ if (r != false) {
+ stack = cons({c: "a3", env: env}, stack.next);
+ env = r;
+ e = ps.data.b;
+ break;
+ }
+ }
+ if (ps == null)
+ throw "Match failure in Ur interpretation";
+ break;
default:
throw ("Unknown Ur continuation kind " + fr.c);
}
@@ -936,6 +978,10 @@ function exec0(env, e) {
stack = cons({c: "=", e2: e.e2}, stack);
e = e.e1;
break;
+ case "m":
+ stack = cons({c: "m", p: e.p}, stack);
+ e = e.e;
+ break;
case "e":
var env0 = env;
var e0 = e.e;
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 1f5d669a..570a708c 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -463,15 +463,16 @@ fun process file =
| PCon (Option, PConVar n, SOME p) =>
(case IM.find (someTs, n) of
NONE => raise Fail "Jscomp: Not in someTs"
- | 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:",
+ | SOME t =>
+ strcat [str ("{c:\"s\",n:"
+ ^ (if isNullable t then
+ "true"
+ else
+ "false")
+ ^ ",p:"),
+ jsPat p,
+ str "}"])
+ | PCon (_, pc, NONE) => strcat [str "{c:\"c\",v:",
patCon pc,
str "}"]
| PCon (_, pc, SOME p) => strcat [str "{c:\"1\",n:",
@@ -560,7 +561,6 @@ fun process file =
val old = e
val (e, st) = jsExp mode [] (e, st)
- val new = e
val e = deStrcat 0 e
val sc = "urfuncs[" ^ Int.toString n ^ "] = " ^ e ^ ";\n"
@@ -791,7 +791,7 @@ fun process file =
val (ps, st) =
foldr (fn ((p, e), (ps, st)) =>
let
- val (e, st) = jsE inner (e, st)
+ val (e, st) = jsE (inner + E.patBindsN p) (e, st)
in
(strcat [str "cons({p:",
jsPat p,
@@ -805,7 +805,7 @@ fun process file =
(str "null", st) pes
in
(strcat [str "{c:\"m\",e:",
- e,
+ e',
str ",p:",
ps,
str "}"], st)
diff --git a/tests/jscomp.ur b/tests/jscomp.ur
index c283ae4d..1d5e3b54 100644
--- a/tests/jscomp.ur
+++ b/tests/jscomp.ur
@@ -1,6 +1,11 @@
fun fst [a] [b] (x : a) (y : b) = x
fun snd [a] [b] (x : a) (y : b) = y
+fun fact n =
+ case n of
+ 0 => 1
+ | _ => n * fact (n - 1)
+
fun main () =
s <- source "";
s' <- source "";
@@ -21,7 +26,11 @@ fun main () =
<button value="-" onclick={s <- get s; alert (show (-(readError s : int)))}/>
<button value="+1" onclick={s <- get s; alert (show (readError s + 1))}/>
<button value="*3" onclick={s <- get s; alert (show ((readError s) * 3))}/>
- <button value="f" onclick={s <- get s; f <- get f; alert (show (f (readError s)))}/><br/><br/>
+ <button value="!" onclick={s <- get s; alert (show (fact (readError s)))}/>
+ <button value="f" onclick={s <- get s; f <- get f; alert (show (f (readError s)))}/>
+ <button value="+1P" onclick={s <- get s; case read s of
+ None => alert "Nada!"
+ | Some (n : int) => alert (show (n + 1))}/>
<button value="f2" onclick={s <- get s; s' <- get s'; f2 <- get f2; alert (f2 s s')}/><br/><br/>