Mercurial > urweb
diff src/mono_util.sml @ 109:813e5a52063d
Remove closure conversion in favor of zany fun with modules, which also replaces 'page'
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Sun, 13 Jul 2008 10:17:06 -0400 |
parents | d101cb1efe55 |
children | 2d6116de9cca |
line wrap: on
line diff
--- a/src/mono_util.sml Thu Jul 10 16:05:14 2008 -0400 +++ b/src/mono_util.sml Sun Jul 13 10:17:06 2008 -0400 @@ -33,6 +33,48 @@ structure Typ = struct +fun join (o1, o2) = + case o1 of + EQUAL => o2 () + | v => v + +fun joinL f (os1, os2) = + case (os1, os2) of + (nil, nil) => EQUAL + | (nil, _) => LESS + | (h1 :: t1, h2 :: t2) => + join (f (h1, h2), fn () => joinL f (t1, t2)) + | (_ :: _, nil) => GREATER + +fun compare ((t1, _), (t2, _)) = + case (t1, t2) of + (TFun (d1, r1), TFun (d2, r2)) => + join (compare (d1, d2), fn () => compare (r1, r2)) + | (TRecord xts1, TRecord xts2) => + let + val xts1 = sortFields xts1 + val xts2 = sortFields xts2 + in + joinL compareFields (xts1, xts2) + end + | (TNamed n1, TNamed n2) => Int.compare (n1, n2) + | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2)) + + | (TFun _, _) => LESS + | (_, TFun _) => GREATER + + | (TRecord _, _) => LESS + | (_, TRecord _) => GREATER + + | (TNamed _, _) => LESS + | (_, TNamed _) => GREATER + +and compareFields ((x1, t1), (x2, t2)) = + join (String.compare (x1, x2), + fn () => compare (t1, t2)) + +and sortFields xts = ListMergeSort.sort (fn (x, y) => compareFields (x, y) = GREATER) xts + fun mapfold fc = let fun mft c acc = @@ -85,7 +127,7 @@ datatype binder = NamedT of string * int * typ option | RelE of string * typ - | NamedE of string * int * typ * exp option + | NamedE of string * int * typ * exp option * string fun mapfoldB {typ = fc, exp = fe, bind} = let @@ -211,21 +253,13 @@ and mfd' ctx (dAll as (d, loc)) = case d of - DVal (x, n, t, e) => + DVal (x, n, t, e, s) => S.bind2 (mft t, fn t' => S.map2 (mfe ctx e, fn e' => - (DVal (x, n, t', e'), loc))) - | DPage (xts, e) => - S.bind2 (ListUtil.mapfold (fn (x, t) => - S.map2 (mft t, - fn t' => - (x, t'))) xts, - fn xts' => - S.map2 (mfe ctx e, - fn e' => - (DPage (xts', e'), loc))) + (DVal (x, n, t', e', s), loc))) + | DExport _ => S.return2 dAll in mfd end @@ -262,8 +296,8 @@ let val ctx' = case #1 d' of - DVal (x, n, t, e) => bind (ctx, NamedE (x, n, t, SOME e)) - | DPage _ => ctx + DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s)) + | DExport _ => ctx in S.map2 (mff ctx' ds', fn ds' =>