Mercurial > urweb
diff src/flat_util.sml @ 29:537db4ee89f4
Translation to Cjr
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 10 Jun 2008 18:28:43 -0400 |
| parents | 104d43266b33 |
| children | 198172560b73 |
line wrap: on
line diff
--- a/src/flat_util.sml Tue Jun 10 16:22:46 2008 -0400 +++ b/src/flat_util.sml Tue Jun 10 18:28:43 2008 -0400 @@ -48,7 +48,8 @@ fun compare ((t1, _), (t2, _)) = case (t1, t2) of - (TFun (d1, r1), TFun (d2, r2)) => + (TTop, TTop) => EQUAL + | (TFun (d1, r1), TFun (d2, r2)) => join (compare (d1, d2), fn () => compare (r1, r2)) | (TCode (d1, r1), TCode (d2, r2)) => join (compare (d1, d2), fn () => compare (r1, r2)) @@ -61,6 +62,9 @@ end | (TNamed n1, TNamed n2) => Int.compare (n1, n2) + | (TTop, _) => LESS + | (_, TTop) => GREATER + | (TFun _, _) => LESS | (_, TFun _) => GREATER @@ -83,7 +87,8 @@ and mft' (cAll as (c, loc)) = case c of - TFun (t1, t2) => + TTop => S.return2 cAll + | TFun (t1, t2) => S.bind2 (mft t1, fn t1' => S.map2 (mft t2, @@ -156,10 +161,12 @@ (EApp (e1', e2'), loc))) | ERecord xes => - S.map2 (ListUtil.mapfold (fn (x, e) => - S.map2 (mfe ctx e, + S.map2 (ListUtil.mapfold (fn (x, e, t) => + S.bind2 (mfe ctx e, fn e' => - (x, e'))) + S.map2 (mft t, + fn t' => + (x, e', t')))) xes, fn xes' => (ERecord xes', loc)) @@ -169,10 +176,12 @@ (EField (e', x), loc)) | ELet (xes, e) => - S.bind2 (ListUtil.mapfold (fn (x, e) => - S.map2 (mfe ctx e, - fn e' => - (x, e'))) + S.bind2 (ListUtil.mapfold (fn (x, t, e) => + S.bind2 (mft t, + fn t' => + S.map2 (mfe ctx e, + fn e' => + (x, t', e')))) xes, fn xes' => S.map2 (mfe ctx e,