Mercurial > urweb
changeset 974:b851675a2c3d
Compiled an 'option' pattern-match
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 22 Sep 2009 14:15:29 -0400 |
| parents | e30c2409c9d0 |
| children | 8fe576c0bee9 |
| files | lib/js/urweb.js src/jscomp.sml tests/jscomp.ur |
| diffstat | 3 files changed, 73 insertions(+), 18 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/js/urweb.js Tue Sep 22 13:41:23 2009 -0400 +++ b/lib/js/urweb.js Tue Sep 22 14:15:29 2009 -0400 @@ -803,6 +803,39 @@ 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 @@ 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 @@ 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;
--- a/src/jscomp.sml Tue Sep 22 13:41:23 2009 -0400 +++ b/src/jscomp.sml Tue Sep 22 14:15:29 2009 -0400 @@ -463,15 +463,16 @@ | 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 @@ 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 @@ 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 @@ (str "null", st) pes in (strcat [str "{c:\"m\",e:", - e, + e', str ",p:", ps, str "}"], st)
--- a/tests/jscomp.ur Tue Sep 22 13:41:23 2009 -0400 +++ b/tests/jscomp.ur Tue Sep 22 14:15:29 2009 -0400 @@ -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 @@ <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/>