Mercurial > urweb

comparison src/monoize.sml @ 273:09c66a30ef32

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Table declarations pushed to Cjr
author Adam Chlipala <adamc@hcoop.net>
date Tue, 02 Sep 2008 13:09:54 -0400
parents 42dfb0d61cf0
children e4baf03a3a64
comparison
equal deleted inserted replaced
272:4d80d6122df1 273:09c66a30ef32
1370 | L.DDatatype (x, n, [], xncs) => 1370 | L.DDatatype (x, n, [], xncs) =>
1371 let 1371 let
1372 val env' = Env.declBinds env all 1372 val env' = Env.declBinds env all
1373 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs), loc) 1373 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs), loc)
1374 in 1374 in
1375 SOME (env', fm, d) 1375 SOME (env', fm, [d])
1376 end 1376 end
1377 | L.DDatatype _ => poly () 1377 | L.DDatatype _ => poly ()
1378 | L.DVal (x, n, t, e, s) => 1378 | L.DVal (x, n, t, e, s) =>
1379 let 1379 let
1380 val (e, fm) = monoExp (env, St.empty, fm) e 1380 val (e, fm) = monoExp (env, St.empty, fm) e
1381 in 1381 in
1382 SOME (Env.pushENamed env x n t NONE s, 1382 SOME (Env.pushENamed env x n t NONE s,
1383 fm, 1383 fm,
1384 (L'.DVal (x, n, monoType env t, e, s), loc)) 1384 [(L'.DVal (x, n, monoType env t, e, s), loc)])
1385 end 1385 end
1386 | L.DValRec vis => 1386 | L.DValRec vis =>
1387 let 1387 let
1388 val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis 1388 val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis
1389 1389
1396 end) 1396 end)
1397 fm vis 1397 fm vis
1398 in 1398 in
1399 SOME (env, 1399 SOME (env,
1400 fm, 1400 fm,
1401 (L'.DValRec vis, loc)) 1401 [(L'.DValRec vis, loc)])
1402 end 1402 end
1403 | L.DExport (ek, n) => 1403 | L.DExport (ek, n) =>
1404 let 1404 let
1405 val (_, t, _, s) = Env.lookupENamed env n 1405 val (_, t, _, s) = Env.lookupENamed env n
1406 1406
1409 L.TFun (dom, ran) => dom :: unwind ran 1409 L.TFun (dom, ran) => dom :: unwind ran
1410 | _ => [] 1410 | _ => []
1411 1411
1412 val ts = map (monoType env) (unwind t) 1412 val ts = map (monoType env) (unwind t)
1413 in 1413 in
1414 SOME (env, fm, (L'.DExport (ek, s, n, ts), loc)) 1414 SOME (env, fm, [(L'.DExport (ek, s, n, ts), loc)])
1415 end 1415 end
1416 | L.DTable (x, n, _, s) => 1416 | L.DTable (x, n, (L.CRecord (_, xts), _), s) =>
1417 let 1417 let
1418 val t = (L.CFfi ("Basis", "string"), loc) 1418 val t = (L.CFfi ("Basis", "string"), loc)
1419 val t' = (L'.TFfi ("Basis", "string"), loc) 1419 val t' = (L'.TFfi ("Basis", "string"), loc)
1420 val e = (L'.EPrim (Prim.String s), loc) 1420 val e = (L'.EPrim (Prim.String s), loc)
1421
1422 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
1421 in 1423 in
1422 SOME (Env.pushENamed env x n t NONE s, 1424 SOME (Env.pushENamed env x n t NONE s,
1423 fm, 1425 fm,
1424 (L'.DVal (x, n, t', e, s), loc)) 1426 [(L'.DTable (s, xts), loc),
1425 end 1427 (L'.DVal (x, n, t', e, s), loc)])
1426 | L.DDatabase s => SOME (env, fm, (L'.DDatabase s, loc)) 1428 end
1429 | L.DTable _ => poly ()
1430 | L.DDatabase s => SOME (env, fm, [(L'.DDatabase s, loc)])
1427 end 1431 end
1428 1432
1429 fun monoize env ds = 1433 fun monoize env ds =
1430 let 1434 let
1431 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) => 1435 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
1432 case monoDecl (env, fm) d of 1436 case monoDecl (env, fm) d of
1433 NONE => (env, fm, ds) 1437 NONE => (env, fm, ds)
1434 | SOME (env, fm, d) => 1438 | SOME (env, fm, ds') =>
1435 (env, 1439 (env,
1436 Fm.enter fm, 1440 Fm.enter fm,
1437 d :: Fm.decls fm @ ds)) 1441 ds' @ Fm.decls fm @ ds))
1438 (env, Fm.empty (CoreUtil.File.maxName ds + 1), []) ds 1442 (env, Fm.empty (CoreUtil.File.maxName ds + 1), []) ds
1439 in 1443 in
1440 rev ds 1444 rev ds
1441 end 1445 end
1442 1446