diff options
author | Adam Chlipala <adamc@hcoop.net> | 2008-07-20 10:11:16 -0400 |
---|---|---|
committer | Adam Chlipala <adamc@hcoop.net> | 2008-07-20 10:11:16 -0400 |
commit | d76bf83a5e8eb9a0b4e194f83cfadd8d55c00dfd (patch) | |
tree | 8e7af4b896c122b1d91b8abb2024ea8f115f5d0e /src | |
parent | 1500c4fedf82243dfbee5fff8ea392905f0a8c80 (diff) |
Form binding parameters threaded through
Diffstat (limited to 'src')
-rw-r--r-- | src/c/driver.c | 2 | ||||
-rw-r--r-- | src/corify.sml | 8 | ||||
-rw-r--r-- | src/elaborate.sml | 54 | ||||
-rw-r--r-- | src/monoize.sml | 29 |
4 files changed, 71 insertions, 22 deletions
diff --git a/src/c/driver.c b/src/c/driver.c index f79c166d..ac0b0c86 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -207,7 +207,7 @@ int main(int argc, char *argv[]) { pthread_mutex_lock(&queue_mutex); enqueue(new_fd); - pthread_mutex_unlock(&queue_mutex); pthread_cond_broadcast(&queue_cond); + pthread_mutex_unlock(&queue_mutex); } } diff --git a/src/corify.sml b/src/corify.sml index 13db0685..719b4215 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -480,9 +480,11 @@ fun corifyDecl ((d, loc : EM.span), st) = L.SgiVal (s, _, t as (L.TFun (dom, ran), _)) => (case (#1 dom, #1 ran) of (L.TRecord _, - L.CApp ((L.CModProj (_, [], "xml"), _), - (L.CRecord (_, [((L.CName "Html", _), - _)]), _))) => + L.CApp + ((L.CApp + ((L.CApp ((L.CModProj (_, [], "xml"), _), + (L.CRecord (_, [((L.CName "Html", _), + _)]), _)), _), _), _), _)) => let val ran = (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) val e = (L.EModProj (m, ms, s), loc) diff --git a/src/elaborate.sml b/src/elaborate.sml index eca00e54..6dc76a59 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -970,6 +970,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) = val kunit = (L'.KUnit, loc) val k = (L'.KRecord kunit, loc) + val kt = (L'.KRecord (L'.KType, loc), loc) val basis = case E.lookupStr env "Basis" of @@ -979,12 +980,19 @@ fun elabExp (env, denv) (eAll as (e, loc)) = fun xml () = let val ns = cunif (loc, k) + val use = cunif (loc, kt) + val bind = cunif (loc, kt) + + val t = (L'.CModProj (basis, [], "xml"), loc) + val t = (L'.CApp (t, ns), loc) + val t = (L'.CApp (t, use), loc) + val t = (L'.CApp (t, bind), loc) in - (ns, (L'.CApp ((L'.CModProj (basis, [], "xml"), loc), ns), loc)) + (ns, use, bind, t) end - val (ns1, c1) = xml () - val (ns2, c2) = xml () + val (ns1, use1, bind1, c1) = xml () + val (ns2, use2, bind2, c2) = xml () val gs3 = checkCon (env, denv) xml1' t1 c1 val gs4 = checkCon (env, denv) xml2' t2 c2 @@ -1017,10 +1025,17 @@ fun elabExp (env, denv) (eAll as (e, loc)) = val e = (L'.ECApp (e, shared), loc) val e = (L'.ECApp (e, ctx1), loc) val e = (L'.ECApp (e, ctx2), loc) + val e = (L'.ECApp (e, use1), loc) + val e = (L'.ECApp (e, use2), loc) + val e = (L'.ECApp (e, bind1), loc) + val e = (L'.ECApp (e, bind2), loc) val e = (L'.EApp (e, xml1'), loc) val e = (L'.EApp (e, xml2'), loc) - val t = (L'.CApp ((L'.CModProj (basis, [], "xml"), loc), shared), loc) + val t = (L'.CModProj (basis, [], "xml"), loc) + val t = (L'.CApp (t, shared), loc) + val t = (L'.CApp (t, (L'.CConcat (use1, use2), loc)), loc) + val t = (L'.CApp (t, (L'.CConcat (bind1, bind2), loc)), loc) fun doUnify (ns, ns') = let @@ -1049,6 +1064,8 @@ fun elabExp (env, denv) (eAll as (e, loc)) = in (e, t, (loc, env, denv, shared, ctx1) :: (loc, env, denv, shared, ctx2) + :: (loc, env, denv, use1, use2) + :: (loc, env, denv, bind1, bind2) :: gs1 @ gs2 @ gs3 @ gs4 @ gs5 @ gs6 @ gs7 @ gs8) end @@ -1975,14 +1992,27 @@ fun elabDecl ((d, loc), (env, denv, gs)) = ((L'.TFun (dom, ran), _), []) => (case (hnormCon (env, denv) dom, hnormCon (env, denv) ran) of (((L'.TRecord domR, _), []), - ((L'.CApp (tf, ranR), _), [])) => - (case (hnormCon (env, denv) tf, hnormCon (env, denv) ranR) of - ((tf, []), (ranR, [])) => - (case (hnormCon (env, denv) domR, hnormCon (env, denv) ranR) of - ((domR, []), (ranR, [])) => - (L'.SgiVal (x, n, (L'.TFun ((L'.TRecord domR, loc), - (L'.CApp (tf, ranR), loc)), - loc)), loc) + ((L'.CApp (tf, arg3), _), [])) => + (case (hnormCon (env, denv) tf, hnormCon (env, denv) arg3) of + (((L'.CApp (tf, arg2), _), []), + (((L'.CRecord (_, []), _), []))) => + (case (hnormCon (env, denv) tf) of + ((L'.CApp (tf, arg1), _), []) => + (case (hnormCon (env, denv) tf, + hnormCon (env, denv) domR, + hnormCon (env, denv) arg2) of + ((tf, []), (domR, []), + ((L'.CRecord (_, []), _), [])) => + let + val t = (L'.CApp (tf, arg1), loc) + val t = (L'.CApp (t, arg2), loc) + val t = (L'.CApp (t, arg3), loc) + in + (L'.SgiVal (x, n, (L'.TFun ((L'.TRecord domR, loc), + t), + loc)), loc) + end + | _ => all) | _ => all) | _ => all) | _ => all) diff --git a/src/monoize.sml b/src/monoize.sml index 4c28fb48..d35d9092 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -138,15 +138,28 @@ fun monoExp env (all as (e, loc)) = | L.EFfi mx => (L'.EFfi mx, loc) | L.EFfiApp (m, x, es) => (L'.EFfiApp (m, x, map (monoExp env) es), loc) - | L.EApp ((L.ECApp ((L.EFfi ("Basis", "cdata"), _), - _), _), se) => (L'.EFfiApp ("Basis", "htmlifyString", [monoExp env se]), loc) + | L.EApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _), + _), _), + _), _), + se) => (L'.EFfiApp ("Basis", "htmlifyString", [monoExp env se]), loc) | L.EApp ( (L.EApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( - (L.EFfi ("Basis", "join"), - _), _), _), + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "join"), + _), _), _), + _), _), + _), _), + _), _), + _), _), _), _), _), _), xml1), _), @@ -159,8 +172,12 @@ fun monoExp env (all as (e, loc)) = (L.ECApp ( (L.ECApp ( (L.ECApp ( - (L.EFfi ("Basis", "tag"), - _), _), _), _), _), _), _), _), _), + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "tag"), + _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), attrs), _), tag), _), xml) => |