Mercurial > urweb
diff src/monoize.sml @ 609:56aaa1941dad
First gimpy RPC
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Sun, 15 Feb 2009 10:32:50 -0500 |
parents | 330a7de47914 |
children | 5891f47d7cff |
line wrap: on
line diff
--- a/src/monoize.sml Sun Feb 15 09:27:36 2009 -0500 +++ b/src/monoize.sml Sun Feb 15 10:32:50 2009 -0500 @@ -2225,12 +2225,28 @@ ((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 + + 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 (n, es, ek), loc), fm) + ((L'.EServerCall (name, es, ek, t), loc), fm) end end @@ -2280,16 +2296,18 @@ 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