Mercurial > urweb

comparison src/monoize.sml @ 609:56aaa1941dad

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
First gimpy RPC
author Adam Chlipala <adamc@hcoop.net>
date Sun, 15 Feb 2009 10:32:50 -0500
parents 330a7de47914
children 5891f47d7cff
comparison
equal deleted inserted replaced
608:330a7de47914 609:56aaa1941dad
2223 val (e2, fm) = monoExp (Env.pushERel env x t, st, fm) e2 2223 val (e2, fm) = monoExp (Env.pushERel env x t, st, fm) e2
2224 in 2224 in
2225 ((L'.ELet (x, t', e1, e2), loc), fm) 2225 ((L'.ELet (x, t', e1, e2), loc), fm)
2226 end 2226 end
2227 2227
2228 | L.EServerCall (n, es, ek) => 2228 | L.EServerCall (n, es, ek, t) =>
2229 let 2229 let
2230 val t = monoType env t
2231 val (_, _, _, name) = Env.lookupENamed env n
2230 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es 2232 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
2231 val (ek, fm) = monoExp (env, st, fm) ek 2233 val (ek, fm) = monoExp (env, st, fm) ek
2232 in 2234
2233 ((L'.EServerCall (n, es, ek), loc), fm) 2235 val ekf = (L'.EAbs ("f",
2236 (L'.TFun (t,
2237 (L'.TFun ((L'.TRecord [], loc),
2238 (L'.TRecord [], loc)), loc)), loc),
2239 (L'.TFun (t,
2240 (L'.TRecord [], loc)), loc),
2241 (L'.EAbs ("x",
2242 t,
2243 (L'.TRecord [], loc),
2244 (L'.EApp ((L'.EApp ((L'.ERel 1, loc),
2245 (L'.ERel 0, loc)), loc),
2246 (L'.ERecord [], loc)), loc)), loc)), loc)
2247 val ek = (L'.EApp (ekf, ek), loc)
2248 in
2249 ((L'.EServerCall (name, es, ek, t), loc), fm)
2234 end 2250 end
2235 end 2251 end
2236 2252
2237 fun monoDecl (env, fm) (all as (d, loc)) = 2253 fun monoDecl (env, fm) (all as (d, loc)) =
2238 let 2254 let
2278 end 2294 end
2279 | L.DExport (ek, n) => 2295 | L.DExport (ek, n) =>
2280 let 2296 let
2281 val (_, t, _, s) = Env.lookupENamed env n 2297 val (_, t, _, s) = Env.lookupENamed env n
2282 2298
2283 fun unwind (t, _) = 2299 fun unwind (t, args) =
2284 case t of 2300 case #1 t of
2285 L.TFun (dom, ran) => dom :: unwind ran 2301 L.TFun (dom, ran) => unwind (ran, dom :: args)
2286 | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => 2302 | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
2287 (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: unwind t 2303 unwind (t, (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: args)
2288 | _ => [] 2304 | _ => (rev args, t)
2289 2305
2290 val ts = map (monoType env) (unwind t) 2306 val (ts, ran) = unwind (t, [])
2291 in 2307 val ts = map (monoType env) ts
2292 SOME (env, fm, [(L'.DExport (ek, s, n, ts), loc)]) 2308 val ran = monoType env ran
2309 in
2310 SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)])
2293 end 2311 end
2294 | L.DTable (x, n, (L.CRecord (_, xts), _), s) => 2312 | L.DTable (x, n, (L.CRecord (_, xts), _), s) =>
2295 let 2313 let
2296 val t = (L.CFfi ("Basis", "string"), loc) 2314 val t = (L.CFfi ("Basis", "string"), loc)
2297 val t' = (L'.TFfi ("Basis", "string"), loc) 2315 val t' = (L'.TFfi ("Basis", "string"), loc)