Mercurial > urweb
changeset 387:7abb28e9d51f
Binops; equality tested on int; lame 404 substitute
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 21 Oct 2008 09:50:19 -0400 |
| parents | ef43ed6cd1de |
| children | 2e93d18daf44 |
| files | src/cjr.sml src/cjr_print.sml src/cjrize.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml src/prepare.sml tests/eq.ur tests/eq.urp |
| diffstat | 11 files changed, 127 insertions(+), 7 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr.sml Sun Oct 19 16:49:09 2008 -0400 +++ b/src/cjr.sml Tue Oct 21 09:50:19 2008 -0400 @@ -66,6 +66,9 @@ | EFfiApp of string * string * exp list | EApp of exp * exp list + | EUnop of string * exp + | EBinop of string * exp * exp + | ERecord of int * (string * exp) list | EField of exp * string
--- a/src/cjr_print.sml Sun Oct 19 16:49:09 2008 -0400 +++ b/src/cjr_print.sml Tue Oct 21 09:50:19 2008 -0400 @@ -609,6 +609,25 @@ p_list_sep (box [string ",", space]) (p_exp env) args, string ")"]) + | EUnop (s, e1) => + parenIf par (box [string s, + space, + p_exp' true env e1]) + + | EBinop ("!strcmp", e1, e2) => + box [string "!strcmp(", + p_exp env e1, + string ",", + space, + p_exp env e2, + string ")"] + | EBinop (s, e1, e2) => + parenIf par (box [p_exp' true env e1, + space, + string s, + space, + p_exp' true env e2]) + | ERecord (i, xes) => box [string "({", space, string "struct", @@ -2060,6 +2079,8 @@ newline, p_list_sep newline (fn x => x) pds', newline, + string "uw_error(ctx, FATAL, \"Unknown page\");", + newline, string "}", newline, newline,
--- a/src/cjrize.sml Sun Oct 19 16:49:09 2008 -0400 +++ b/src/cjrize.sml Tue Oct 21 09:50:19 2008 -0400 @@ -249,6 +249,20 @@ Print.prefaces' [("Function", MonoPrint.p_exp MonoEnv.empty eAll)]; (dummye, sm)) + | L.EUnop (s, e1) => + let + val (e1, sm) = cifyExp (e1, sm) + in + ((L'.EUnop (s, e1), loc), sm) + end + | L.EBinop (s, e1, e2) => + let + val (e1, sm) = cifyExp (e1, sm) + val (e2, sm) = cifyExp (e2, sm) + in + ((L'.EBinop (s, e1, e2), loc), sm) + end + | L.ERecord xes => let val old_xts = map (fn (x, _, t) => (x, t)) xes
--- a/src/mono.sml Sun Oct 19 16:49:09 2008 -0400 +++ b/src/mono.sml Tue Oct 21 09:50:19 2008 -0400 @@ -67,6 +67,9 @@ | EApp of exp * exp | EAbs of string * typ * typ * exp + | EUnop of string * exp + | EBinop of string * exp * exp + | ERecord of (string * exp * typ) list | EField of exp * string
--- a/src/mono_print.sml Sun Oct 19 16:49:09 2008 -0400 +++ b/src/mono_print.sml Tue Oct 21 09:50:19 2008 -0400 @@ -158,6 +158,15 @@ space, p_exp (E.pushERel env x t NONE) e]) + | EUnop (s, e) => parenIf true (box [string s, + space, + p_exp' true env e]) + | EBinop (s, e1, e2) => parenIf true (box [p_exp' true env e1, + space, + string s, + space, + p_exp' true env e2]) + | ERecord xes => box [string "{", p_list (fn (x, e, _) => box [string x,
--- a/src/mono_reduce.sml Sun Oct 19 16:49:09 2008 -0400 +++ b/src/mono_reduce.sml Tue Oct 21 09:50:19 2008 -0400 @@ -54,6 +54,9 @@ | EApp ((EFfi _, _), _) => false | EApp _ => true + | EUnop (_, e) => impure e + | EBinop (_, e1, e2) => impure e1 orelse impure e2 + | ERecord xes => List.exists (fn (_, e, _) => impure e) xes | EField (e, _) => impure e @@ -233,6 +236,9 @@ | EApp _ => [Unsure] | EAbs _ => [] + | EUnop (_, e) => summarize d e + | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2 + | ERecord xets => List.concat (map (summarize d o #2) xets) | EField (e, _) => summarize d e
--- a/src/mono_util.sml Sun Oct 19 16:49:09 2008 -0400 +++ b/src/mono_util.sml Tue Oct 21 09:50:19 2008 -0400 @@ -175,6 +175,17 @@ fn e' => (EAbs (x, dom', ran', e'), loc)))) + | EUnop (s, e) => + S.map2 (mfe ctx e, + fn e' => + (EUnop (s, e'), loc)) + | EBinop (s, e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (EBinop (s, e1', e2'), loc))) + | ERecord xes => S.map2 (ListUtil.mapfold (fn (x, e, t) => S.bind2 (mfe ctx e,
--- a/src/monoize.sml Sun Oct 19 16:49:09 2008 -0400 +++ b/src/monoize.sml Tue Oct 21 09:50:19 2008 -0400 @@ -94,6 +94,12 @@ | L.CApp ((L.CFfi ("Basis", "option"), _), t) => (L'.TOption (mt env dtmap t), loc) + | L.CApp ((L.CFfi ("Basis", "eq"), _), t) => + let + val t = mt env dtmap t + in + (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc) + end | L.CApp ((L.CFfi ("Basis", "show"), _), t) => (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc) | L.CApp ((L.CFfi ("Basis", "read"), _), t) => @@ -492,6 +498,39 @@ end | L.ECon _ => poly () + | L.ECApp ((L.EFfi ("Basis", "eq"), _), t) => + let + val t = monoType env t + val b = (L'.TFfi ("Basis", "bool"), loc) + val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc) + in + ((L'.EAbs ("f", dom, dom, + (L'.ERel 0, loc)), loc), fm) + end + | L.ECApp ((L.EFfi ("Basis", "ne"), _), t) => + let + val t = monoType env t + val b = (L'.TFfi ("Basis", "bool"), loc) + val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc) + in + ((L'.EAbs ("f", dom, dom, + (L'.EAbs ("x", t, (L'.TFun (t, b), loc), + (L'.EAbs ("y", t, b, + (L'.EUnop ("!", (L'.EApp ((L'.EApp ((L'.ERel 2, loc), + (L'.ERel 1, loc)), loc), + (L'.ERel 0, loc)), loc)), loc)), + loc)), + loc)), + loc), fm) + end + | L.EFfi ("Basis", "eq_int") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), + (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc), + (L'.TFfi ("Basis", "bool"), loc), + (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + fm) + | L.ECApp ((L.EFfi ("Basis", "show"), _), t) => let val t = monoType env t
--- a/src/prepare.sml Sun Oct 19 16:49:09 2008 -0400 +++ b/src/prepare.sml Tue Oct 21 09:50:19 2008 -0400 @@ -88,6 +88,20 @@ ((EApp (e1, es), loc), sns) end + | EUnop (s, e1) => + let + val (e1, sns) = prepExp (e1, sns) + in + ((EUnop (s, e1), loc), sns) + end + | EBinop (s, e1, e2) => + let + val (e1, sns) = prepExp (e1, sns) + val (e2, sns) = prepExp (e2, sns) + in + ((EBinop (s, e1, e2), loc), sns) + end + | ERecord (rn, xes) => let val (xes, sns) = ListUtil.foldlMap (fn ((x, e), sns) =>
--- a/tests/eq.ur Sun Oct 19 16:49:09 2008 -0400 +++ b/tests/eq.ur Tue Oct 21 09:50:19 2008 -0400 @@ -1,7 +1,4 @@ -val b1 = 1 = 1 -val b2 = "Good" = "Bad" - -fun eq_pair (t1 :: Type) (t2 :: Type) (eq1 : eq t1) (eq2 : eq t2) (x : t1 * t2) (y : t1 * t2) = - x.1 = y.1 - -val b3 = True <> False +fun main () : transaction page = return <xml><body> + {txt _ (1 = 1)}, {txt _ (1 = 2)}<br/> + {txt _ (1 <> 1)}, {txt _ (1 <> 2)} +</body></xml>