adamc@29
|
1 (* Copyright (c) 2008, Adam Chlipala
|
adamc@29
|
2 * All rights reserved.
|
adamc@29
|
3 *
|
adamc@29
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@29
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@29
|
6 *
|
adamc@29
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@29
|
8 * this list of conditions and the following disclaimer.
|
adamc@29
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@29
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@29
|
11 * and/or other materials provided with the distribution.
|
adamc@29
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@29
|
13 * derived from this software without specific prior written permission.
|
adamc@29
|
14 *
|
adamc@29
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@29
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@29
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@29
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@29
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@29
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@29
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@29
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@29
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@29
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@29
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@29
|
26 *)
|
adamc@29
|
27
|
adamc@29
|
28 structure CjrEnv :> CJR_ENV = struct
|
adamc@29
|
29
|
adamc@29
|
30 open Cjr
|
adamc@29
|
31
|
adamc@29
|
32 structure IM = IntBinaryMap
|
adamc@29
|
33
|
adamc@29
|
34
|
adamc@29
|
35 exception UnboundRel of int
|
adamc@29
|
36 exception UnboundNamed of int
|
adamc@29
|
37 exception UnboundF of int
|
adamc@101
|
38 exception UnboundStruct of int
|
adamc@29
|
39
|
adamc@29
|
40 type env = {
|
adamc@29
|
41 namedT : (string * typ option) IM.map,
|
adamc@29
|
42
|
adamc@29
|
43 numRelE : int,
|
adamc@29
|
44 relE : (string * typ) list,
|
adamc@29
|
45 namedE : (string * typ) IM.map,
|
adamc@29
|
46
|
adamc@101
|
47 F : (string * typ * typ) IM.map,
|
adamc@101
|
48 structs : (string * typ) list IM.map
|
adamc@29
|
49 }
|
adamc@29
|
50
|
adamc@29
|
51 val empty = {
|
adamc@29
|
52 namedT = IM.empty,
|
adamc@29
|
53
|
adamc@29
|
54 numRelE = 0,
|
adamc@29
|
55 relE = [],
|
adamc@29
|
56 namedE = IM.empty,
|
adamc@29
|
57
|
adamc@101
|
58 F = IM.empty,
|
adamc@101
|
59 structs = IM.empty
|
adamc@29
|
60 }
|
adamc@29
|
61
|
adamc@29
|
62 fun pushTNamed (env : env) x n co =
|
adamc@29
|
63 {namedT = IM.insert (#namedT env, n, (x, co)),
|
adamc@29
|
64
|
adamc@29
|
65 numRelE = #numRelE env,
|
adamc@29
|
66 relE = #relE env,
|
adamc@29
|
67 namedE = #namedE env,
|
adamc@29
|
68
|
adamc@101
|
69 F = #F env,
|
adamc@101
|
70 structs = #structs env}
|
adamc@29
|
71
|
adamc@29
|
72 fun lookupTNamed (env : env) n =
|
adamc@29
|
73 case IM.find (#namedT env, n) of
|
adamc@29
|
74 NONE => raise UnboundNamed n
|
adamc@29
|
75 | SOME x => x
|
adamc@29
|
76
|
adamc@29
|
77 fun pushERel (env : env) x t =
|
adamc@29
|
78 {namedT = #namedT env,
|
adamc@29
|
79
|
adamc@29
|
80 numRelE = #numRelE env + 1,
|
adamc@29
|
81 relE = (x, t) :: #relE env,
|
adamc@29
|
82 namedE = #namedE env,
|
adamc@29
|
83
|
adamc@101
|
84 F = #F env,
|
adamc@101
|
85 structs = #structs env}
|
adamc@29
|
86
|
adamc@29
|
87 fun lookupERel (env : env) n =
|
adamc@29
|
88 (List.nth (#relE env, n))
|
adamc@29
|
89 handle Subscript => raise UnboundRel n
|
adamc@29
|
90
|
adamc@29
|
91 fun countERels (env : env) = #numRelE env
|
adamc@29
|
92
|
adamc@29
|
93 fun listERels (env : env) = #relE env
|
adamc@29
|
94
|
adamc@29
|
95 fun pushENamed (env : env) x n t =
|
adamc@29
|
96 {namedT = #namedT env,
|
adamc@29
|
97
|
adamc@29
|
98 numRelE = #numRelE env,
|
adamc@29
|
99 relE = #relE env,
|
adamc@29
|
100 namedE = IM.insert (#namedE env, n, (x, t)),
|
adamc@29
|
101
|
adamc@101
|
102 F = #F env,
|
adamc@101
|
103 structs = #structs env}
|
adamc@29
|
104
|
adamc@29
|
105 fun lookupENamed (env : env) n =
|
adamc@29
|
106 case IM.find (#namedE env, n) of
|
adamc@29
|
107 NONE => raise UnboundNamed n
|
adamc@29
|
108 | SOME x => x
|
adamc@29
|
109
|
adamc@29
|
110 fun pushF (env : env) n x dom ran =
|
adamc@29
|
111 {namedT = #namedT env,
|
adamc@29
|
112
|
adamc@29
|
113 numRelE = #numRelE env,
|
adamc@29
|
114 relE = #relE env,
|
adamc@29
|
115 namedE = #namedE env,
|
adamc@29
|
116
|
adamc@101
|
117 F = IM.insert (#F env, n, (x, dom, ran)),
|
adamc@101
|
118 structs = #structs env}
|
adamc@29
|
119
|
adamc@29
|
120 fun lookupF (env : env) n =
|
adamc@29
|
121 case IM.find (#F env, n) of
|
adamc@29
|
122 NONE => raise UnboundF n
|
adamc@29
|
123 | SOME x => x
|
adamc@29
|
124
|
adamc@101
|
125 fun pushStruct (env : env) n xts =
|
adamc@101
|
126 {namedT = #namedT env,
|
adamc@101
|
127
|
adamc@101
|
128 numRelE = #numRelE env,
|
adamc@101
|
129 relE = #relE env,
|
adamc@101
|
130 namedE = #namedE env,
|
adamc@101
|
131
|
adamc@101
|
132 F = #F env,
|
adamc@101
|
133 structs = IM.insert (#structs env, n, xts)}
|
adamc@101
|
134
|
adamc@101
|
135 fun lookupStruct (env : env) n =
|
adamc@101
|
136 case IM.find (#structs env, n) of
|
adamc@101
|
137 NONE => raise UnboundStruct n
|
adamc@101
|
138 | SOME x => x
|
adamc@101
|
139
|
adamc@29
|
140 fun declBinds env (d, _) =
|
adamc@29
|
141 case d of
|
adamc@29
|
142 DVal (x, n, t, _) => pushENamed env x n t
|
adamc@29
|
143 | DFun (n, x, dom, ran, _) => pushF env n x dom ran
|
adamc@101
|
144 | DStruct (n, xts) => pushStruct env n xts
|
adamc@29
|
145
|
adamc@29
|
146 end
|