Mercurial > urweb

comparison src/monoize.sml @ 417:e0e9e9eca1cb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix nasty de Bruijn substitution bug; TcSum demo
author Adam Chlipala <adamc@hcoop.net>
date Thu, 23 Oct 2008 12:58:35 -0400
parents c5a3d223f157
children 0ce90d4d9ae7
comparison
equal deleted inserted replaced
416:679b2fbbd4d0 417:e0e9e9eca1cb
102 end 102 end
103 | L.CApp ((L.CFfi ("Basis", "num"), _), t) => 103 | L.CApp ((L.CFfi ("Basis", "num"), _), t) =>
104 let 104 let
105 val t = mt env dtmap t 105 val t = mt env dtmap t
106 in 106 in
107 (L'.TRecord [("Neg", (L'.TFun (t, t), loc)), 107 (L'.TRecord [("Zero", t),
108 ("Neg", (L'.TFun (t, t), loc)),
108 ("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), 109 ("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
109 ("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), 110 ("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
110 ("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), 111 ("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
111 ("Div", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), 112 ("Div", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
112 ("Mod", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], 113 ("Mod", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))],
489 (E.errorAt loc "Unsupported expression"; 490 (E.errorAt loc "Unsupported expression";
490 Print.eprefaces' [("Expression", CorePrint.p_exp env all)]; 491 Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
491 (dummyExp, fm)) 492 (dummyExp, fm))
492 493
493 fun numTy t = 494 fun numTy t =
494 (L'.TRecord [("Neg", (L'.TFun (t, t), loc)), 495 (L'.TRecord [("Zero", t),
496 ("Neg", (L'.TFun (t, t), loc)),
495 ("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), 497 ("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
496 ("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), 498 ("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
497 ("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), 499 ("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
498 ("Div", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), 500 ("Div", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
499 ("Mod", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc) 501 ("Mod", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc)
500 fun numEx (t, neg, plus, minus, times, dv, md) = 502 fun numEx (t, zero, neg, plus, minus, times, dv, md) =
501 ((L'.ERecord [("Neg", neg, (L'.TFun (t, t), loc)), 503 ((L'.ERecord [("Zero", (L'.EPrim zero, loc), t),
504 ("Neg", neg, (L'.TFun (t, t), loc)),
502 ("Plus", plus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), 505 ("Plus", plus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
503 ("Minus", minus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), 506 ("Minus", minus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
504 ("Times", times, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), 507 ("Times", times, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
505 ("Div", dv, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), 508 ("Div", dv, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)),
506 ("Mod", md, (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc), fm) 509 ("Mod", md, (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc), fm)
593 (L'.EAbs ("y", (L'.TFfi ("Basis", "string"), loc), 596 (L'.EAbs ("y", (L'.TFfi ("Basis", "string"), loc),
594 (L'.TFfi ("Basis", "bool"), loc), 597 (L'.TFfi ("Basis", "bool"), loc),
595 (L'.EBinop ("!strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), 598 (L'.EBinop ("!strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
596 fm) 599 fm)
597 600
601 | L.ECApp ((L.EFfi ("Basis", "zero"), _), t) =>
602 let
603 val t = monoType env t
604 in
605 ((L'.EAbs ("r", numTy t, t,
606 (L'.EField ((L'.ERel 0, loc), "Zero"), loc)), loc), fm)
607 end
598 | L.ECApp ((L.EFfi ("Basis", "neg"), _), t) => 608 | L.ECApp ((L.EFfi ("Basis", "neg"), _), t) =>
599 let 609 let
600 val t = monoType env t 610 val t = monoType env t
601 in 611 in
602 ((L'.EAbs ("r", numTy t, (L'.TFun (t, t), loc), 612 ((L'.EAbs ("r", numTy t, (L'.TFun (t, t), loc),
645 (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc), 655 (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc),
646 (L'.TFfi ("Basis", "int"), loc), 656 (L'.TFfi ("Basis", "int"), loc),
647 (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) 657 (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
648 in 658 in
649 numEx ((L'.TFfi ("Basis", "int"), loc), 659 numEx ((L'.TFfi ("Basis", "int"), loc),
660 Prim.Int (Int64.fromInt 0),
650 (L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), 661 (L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc),
651 (L'.TFfi ("Basis", "int"), loc), 662 (L'.TFfi ("Basis", "int"), loc),
652 (L'.EUnop ("-", (L'.ERel 0, loc)), loc)), loc), 663 (L'.EUnop ("-", (L'.ERel 0, loc)), loc)), loc),
653 intBin "+", 664 intBin "+",
654 intBin "-", 665 intBin "-",
664 (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc), 675 (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc),
665 (L'.TFfi ("Basis", "float"), loc), 676 (L'.TFfi ("Basis", "float"), loc),
666 (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) 677 (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
667 in 678 in
668 numEx ((L'.TFfi ("Basis", "float"), loc), 679 numEx ((L'.TFfi ("Basis", "float"), loc),
680 Prim.Float 0.0,
669 (L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), 681 (L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc),
670 (L'.TFfi ("Basis", "float"), loc), 682 (L'.TFfi ("Basis", "float"), loc),
671 (L'.EUnop ("-", (L'.ERel 0, loc)), loc)), loc), 683 (L'.EUnop ("-", (L'.ERel 0, loc)), loc)), loc),
672 floatBin "+", 684 floatBin "+",
673 floatBin "-", 685 floatBin "-",