Mercurial > urweb

comparison src/mono_env.sml @ 168:25b169416ea8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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