Mercurial > urweb
diff 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 |
line wrap: on
line diff
--- a/src/mono_env.sml Tue Jul 29 15:25:42 2008 -0400 +++ b/src/mono_env.sml Tue Jul 29 15:43:17 2008 -0400 @@ -36,32 +36,32 @@ exception UnboundNamed of int type env = { - namedT : (string * typ option) IM.map, + datatypes : (string * (string * int * typ option) list) IM.map, relE : (string * typ) list, namedE : (string * typ * exp option * string) IM.map } val empty = { - namedT = IM.empty, + datatypes = IM.empty, relE = [], namedE = IM.empty } -fun pushTNamed (env : env) x n co = - {namedT = IM.insert (#namedT env, n, (x, co)), +fun pushDatatype (env : env) x n xncs = + {datatypes = IM.insert (#datatypes env, n, (x, xncs)), relE = #relE env, namedE = #namedE env} -fun lookupTNamed (env : env) n = - case IM.find (#namedT env, n) of +fun lookupDatatype (env : env) n = + case IM.find (#datatypes env, n) of NONE => raise UnboundNamed n | SOME x => x fun pushERel (env : env) x t = - {namedT = #namedT env, + {datatypes = #datatypes env, relE = (x, t) :: #relE env, namedE = #namedE env} @@ -71,7 +71,7 @@ handle Subscript => raise UnboundRel n fun pushENamed (env : env) x n t eo s = - {namedT = #namedT env, + {datatypes = #datatypes env, relE = #relE env, namedE = IM.insert (#namedE env, n, (x, t, eo, s))} @@ -85,10 +85,10 @@ case d of DDatatype (x, n, xncs) => let - val env = pushTNamed env x n NONE + val env = pushDatatype env x n xncs in - foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (TNamed n, loc) NONE "" - | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TNamed n, loc)), loc) NONE "") + foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (TDatatype (n, xncs), loc) NONE "" + | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TDatatype (n, xncs), loc)), loc) NONE "") env xncs end | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s