Mercurial > urweb

comparison src/monoize.sml @ 196:890a61991263

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Lists all the way through
author Adam Chlipala <adamc@hcoop.net>
date Sat, 09 Aug 2008 16:48:32 -0400
parents 8a70e2919e86
children ab86aa858e6c
comparison
equal deleted inserted replaced
195:85b5f663bb86 196:890a61991263
31 structure Env = CoreEnv 31 structure Env = CoreEnv
32 32
33 structure L = Core 33 structure L = Core
34 structure L' = Mono 34 structure L' = Mono
35 35
36 val dummyTyp = (L'.TDatatype (L'.Enum, 0, []), E.dummySpan) 36 structure IM = IntBinaryMap
37
38 val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan)
37 39
38 fun monoName env (all as (c, loc)) = 40 fun monoName env (all as (c, loc)) =
39 let 41 let
40 fun poly () = 42 fun poly () =
41 (E.errorAt loc "Unsupported name constructor"; 43 (E.errorAt loc "Unsupported name constructor";
45 case c of 47 case c of
46 L.CName s => s 48 L.CName s => s
47 | _ => poly () 49 | _ => poly ()
48 end 50 end
49 51
50 fun monoType env (all as (c, loc)) = 52 fun monoType env =
51 let 53 let
52 fun poly () = 54 fun mt env dtmap (all as (c, loc)) =
53 (E.errorAt loc "Unsupported type constructor"; 55 let
54 Print.eprefaces' [("Constructor", CorePrint.p_con env all)]; 56 fun poly () =
55 dummyTyp) 57 (E.errorAt loc "Unsupported type constructor";
58 Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
59 dummyTyp)
60 in
61 case c of
62 L.TFun (c1, c2) => (L'.TFun (mt env dtmap c1, mt env dtmap c2), loc)
63 | L.TCFun _ => poly ()
64 | L.TRecord (L.CRecord ((L.KType, _), xcs), _) =>
65 (L'.TRecord (map (fn (x, t) => (monoName env x, mt env dtmap t)) xcs), loc)
66 | L.TRecord _ => poly ()
67
68 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
69 (L'.TFfi ("Basis", "string"), loc)
70 | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
71 (L'.TFfi ("Basis", "string"), loc)
72
73 | L.CRel _ => poly ()
74 | L.CNamed n =>
75 (case IM.find (dtmap, n) of
76 SOME r => (L'.TDatatype (n, r), loc)
77 | NONE =>
78 let
79 val r = ref (L'.Default, [])
80 val (_, xs, xncs) = Env.lookupDatatype env n
81
82 val dtmap' = IM.insert (dtmap, n, r)
83
84 val xncs = map (fn (x, n, to) => (x, n, Option.map (mt env dtmap') to)) xncs
85 in
86 case xs of
87 [] =>(r := (MonoUtil.classifyDatatype xncs, xncs);
88 (L'.TDatatype (n, r), loc))
89 | _ => poly ()
90 end)
91 | L.CFfi mx => (L'.TFfi mx, loc)
92 | L.CApp _ => poly ()
93 | L.CAbs _ => poly ()
94
95 | L.CName _ => poly ()
96
97 | L.CRecord _ => poly ()
98 | L.CConcat _ => poly ()
99 | L.CFold _ => poly ()
100 | L.CUnit => poly ()
101 end
56 in 102 in
57 case c of 103 mt env IM.empty
58 L.TFun (c1, c2) => (L'.TFun (monoType env c1, monoType env c2), loc)
59 | L.TCFun _ => poly ()
60 | L.TRecord (L.CRecord ((L.KType, _), xcs), _) =>
61 (L'.TRecord (map (fn (x, t) => (monoName env x, monoType env t)) xcs), loc)
62 | L.TRecord _ => poly ()
63
64 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
65 (L'.TFfi ("Basis", "string"), loc)
66 | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
67 (L'.TFfi ("Basis", "string"), loc)
68
69 | L.CRel _ => poly ()
70 | L.CNamed n =>
71 let
72 val (_, xs, xncs) = Env.lookupDatatype env n
73
74 val xncs = map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs
75 in
76 case xs of
77 [] => (L'.TDatatype (MonoUtil.classifyDatatype xncs, n, xncs), loc)
78 | _ => poly ()
79 end
80 | L.CFfi mx => (L'.TFfi mx, loc)
81 | L.CApp _ => poly ()
82 | L.CAbs _ => poly ()
83
84 | L.CName _ => poly ()
85
86 | L.CRecord _ => poly ()
87 | L.CConcat _ => poly ()
88 | L.CFold _ => poly ()
89 | L.CUnit => poly ()
90 end 104 end
91 105
92 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan) 106 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
93 107
94 structure IM = IntBinaryMap 108 structure IM = IntBinaryMap
202 | _ => 216 | _ =>
203 case t of 217 case t of
204 L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm) 218 L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm)
205 | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm) 219 | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm)
206 220
207 | L'.TDatatype (dk, i, _) => 221 | L'.TDatatype (i, ref (dk, _)) =>
208 let 222 let
209 fun makeDecl n fm = 223 fun makeDecl n fm =
210 let 224 let
211 val (x, _, xncs) = Env.lookupDatatype env i 225 val (x, _, xncs) = Env.lookupDatatype env i
212 226
731 in 745 in
732 case d of 746 case d of
733 L.DCon _ => NONE 747 L.DCon _ => NONE
734 | L.DDatatype (x, n, [], xncs) => 748 | L.DDatatype (x, n, [], xncs) =>
735 let 749 let
736 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs), loc) 750 val env' = Env.declBinds env all
737 in 751 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs), loc)
738 SOME (Env.declBinds env all, fm, d) 752 in
753 SOME (env', fm, d)
739 end 754 end
740 | L.DDatatype _ => poly () 755 | L.DDatatype _ => poly ()
741 | L.DVal (x, n, t, e, s) => 756 | L.DVal (x, n, t, e, s) =>
742 let 757 let
743 val (e, fm) = monoExp (env, St.empty, fm) e 758 val (e, fm) = monoExp (env, St.empty, fm) e