Mercurial > urweb
comparison src/mono_env.sml @ 168:25b169416ea8
Storing datatype constructors in type references past monoize
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Tue, 29 Jul 2008 15:43:17 -0400 |
parents | 6847741e1f5f |
children | eb3f9913bf31 |
comparison
equal
deleted
inserted
replaced
167:2be573fec9a6 | 168:25b169416ea8 |
---|---|
34 | 34 |
35 exception UnboundRel of int | 35 exception UnboundRel of int |
36 exception UnboundNamed of int | 36 exception UnboundNamed of int |
37 | 37 |
38 type env = { | 38 type env = { |
39 namedT : (string * typ option) IM.map, | 39 datatypes : (string * (string * int * typ option) list) IM.map, |
40 | 40 |
41 relE : (string * typ) list, | 41 relE : (string * typ) list, |
42 namedE : (string * typ * exp option * string) IM.map | 42 namedE : (string * typ * exp option * string) IM.map |
43 } | 43 } |
44 | 44 |
45 val empty = { | 45 val empty = { |
46 namedT = IM.empty, | 46 datatypes = IM.empty, |
47 | 47 |
48 relE = [], | 48 relE = [], |
49 namedE = IM.empty | 49 namedE = IM.empty |
50 } | 50 } |
51 | 51 |
52 fun pushTNamed (env : env) x n co = | 52 fun pushDatatype (env : env) x n xncs = |
53 {namedT = IM.insert (#namedT env, n, (x, co)), | 53 {datatypes = IM.insert (#datatypes env, n, (x, xncs)), |
54 | 54 |
55 relE = #relE env, | 55 relE = #relE env, |
56 namedE = #namedE env} | 56 namedE = #namedE env} |
57 | 57 |
58 fun lookupTNamed (env : env) n = | 58 fun lookupDatatype (env : env) n = |
59 case IM.find (#namedT env, n) of | 59 case IM.find (#datatypes env, n) of |
60 NONE => raise UnboundNamed n | 60 NONE => raise UnboundNamed n |
61 | SOME x => x | 61 | SOME x => x |
62 | 62 |
63 fun pushERel (env : env) x t = | 63 fun pushERel (env : env) x t = |
64 {namedT = #namedT env, | 64 {datatypes = #datatypes env, |
65 | 65 |
66 relE = (x, t) :: #relE env, | 66 relE = (x, t) :: #relE env, |
67 namedE = #namedE env} | 67 namedE = #namedE env} |
68 | 68 |
69 fun lookupERel (env : env) n = | 69 fun lookupERel (env : env) n = |
70 (List.nth (#relE env, n)) | 70 (List.nth (#relE env, n)) |
71 handle Subscript => raise UnboundRel n | 71 handle Subscript => raise UnboundRel n |
72 | 72 |
73 fun pushENamed (env : env) x n t eo s = | 73 fun pushENamed (env : env) x n t eo s = |
74 {namedT = #namedT env, | 74 {datatypes = #datatypes env, |
75 | 75 |
76 relE = #relE env, | 76 relE = #relE env, |
77 namedE = IM.insert (#namedE env, n, (x, t, eo, s))} | 77 namedE = IM.insert (#namedE env, n, (x, t, eo, s))} |
78 | 78 |
79 fun lookupENamed (env : env) n = | 79 fun lookupENamed (env : env) n = |
83 | 83 |
84 fun declBinds env (d, loc) = | 84 fun declBinds env (d, loc) = |
85 case d of | 85 case d of |
86 DDatatype (x, n, xncs) => | 86 DDatatype (x, n, xncs) => |
87 let | 87 let |
88 val env = pushTNamed env x n NONE | 88 val env = pushDatatype env x n xncs |
89 in | 89 in |
90 foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (TNamed n, loc) NONE "" | 90 foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (TDatatype (n, xncs), loc) NONE "" |
91 | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TNamed n, loc)), loc) NONE "") | 91 | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TDatatype (n, xncs), loc)), loc) NONE "") |
92 env xncs | 92 env xncs |
93 end | 93 end |
94 | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s | 94 | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s |
95 | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis | 95 | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis |
96 | DExport _ => env | 96 | DExport _ => env |