summaryrefslogtreecommitdiff
path: root/src/monoize.sml
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-02-15 10:32:50 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-02-15 10:32:50 -0500
commit1557ac806159fe58eaa442527f73e569dd04f88e (patch)
tree97a0ff4ed73faa83667f997d5fa13306ba98789b /src/monoize.sml
parente27335a18e8f4b1cca2749e8d41863b3cbef9b62 (diff)
First gimpy RPC
Diffstat (limited to 'src/monoize.sml')
-rw-r--r--src/monoize.sml38
1 files changed, 28 insertions, 10 deletions
diff --git a/src/monoize.sml b/src/monoize.sml
index fb1ac2f1..43c3f47d 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2225,12 +2225,28 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.ELet (x, t', e1, e2), loc), fm)
end
- | L.EServerCall (n, es, ek) =>
+ | L.EServerCall (n, es, ek, t) =>
let
+ val t = monoType env t
+ val (_, _, _, name) = Env.lookupENamed env n
val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
val (ek, fm) = monoExp (env, st, fm) ek
- in
- ((L'.EServerCall (n, es, ek), loc), fm)
+
+ val ekf = (L'.EAbs ("f",
+ (L'.TFun (t,
+ (L'.TFun ((L'.TRecord [], loc),
+ (L'.TRecord [], loc)), loc)), loc),
+ (L'.TFun (t,
+ (L'.TRecord [], loc)), loc),
+ (L'.EAbs ("x",
+ t,
+ (L'.TRecord [], loc),
+ (L'.EApp ((L'.EApp ((L'.ERel 1, loc),
+ (L'.ERel 0, loc)), loc),
+ (L'.ERecord [], loc)), loc)), loc)), loc)
+ val ek = (L'.EApp (ekf, ek), loc)
+ in
+ ((L'.EServerCall (name, es, ek, t), loc), fm)
end
end
@@ -2280,16 +2296,18 @@ fun monoDecl (env, fm) (all as (d, loc)) =
let
val (_, t, _, s) = Env.lookupENamed env n
- fun unwind (t, _) =
- case t of
- L.TFun (dom, ran) => dom :: unwind ran
+ fun unwind (t, args) =
+ case #1 t of
+ L.TFun (dom, ran) => unwind (ran, dom :: args)
| L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
- (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: unwind t
- | _ => []
+ unwind (t, (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: args)
+ | _ => (rev args, t)
- val ts = map (monoType env) (unwind t)
+ val (ts, ran) = unwind (t, [])
+ val ts = map (monoType env) ts
+ val ran = monoType env ran
in
- SOME (env, fm, [(L'.DExport (ek, s, n, ts), loc)])
+ SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)])
end
| L.DTable (x, n, (L.CRecord (_, xts), _), s) =>
let