summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-07-20 10:11:16 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-07-20 10:11:16 -0400
commitd76bf83a5e8eb9a0b4e194f83cfadd8d55c00dfd (patch)
tree8e7af4b896c122b1d91b8abb2024ea8f115f5d0e /src
parent1500c4fedf82243dfbee5fff8ea392905f0a8c80 (diff)
Form binding parameters threaded through
Diffstat (limited to 'src')
-rw-r--r--src/c/driver.c2
-rw-r--r--src/corify.sml8
-rw-r--r--src/elaborate.sml54
-rw-r--r--src/monoize.sml29
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) =>
generated by cgit v1.2.3 (git 2.39.1) at 2024-10-30 08:57:05 +0000