adamc@25
|
1 (* Copyright (c) 2008, Adam Chlipala
|
adamc@25
|
2 * All rights reserved.
|
adamc@25
|
3 *
|
adamc@25
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@25
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@25
|
6 *
|
adamc@25
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@25
|
8 * this list of conditions and the following disclaimer.
|
adamc@25
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@25
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@25
|
11 * and/or other materials provided with the distribution.
|
adamc@25
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@25
|
13 * derived from this software without specific prior written permission.
|
adamc@25
|
14 *
|
adamc@25
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@25
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@25
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@25
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@25
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@25
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@25
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@25
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@25
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@25
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@25
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@25
|
26 *)
|
adamc@25
|
27
|
adamc@25
|
28 structure MonoEnv :> MONO_ENV = struct
|
adamc@25
|
29
|
adamc@25
|
30 open Mono
|
adamc@25
|
31
|
adamc@25
|
32 structure IM = IntBinaryMap
|
adamc@25
|
33
|
adamc@25
|
34
|
adamc@25
|
35 exception UnboundRel of int
|
adamc@25
|
36 exception UnboundNamed of int
|
adamc@25
|
37
|
adamc@25
|
38 type env = {
|
adamc@168
|
39 datatypes : (string * (string * int * typ option) list) IM.map,
|
adamc@178
|
40 constructors : (string * typ option * int) IM.map,
|
adamc@25
|
41
|
adamc@183
|
42 relE : (string * typ * exp option) list,
|
adamc@109
|
43 namedE : (string * typ * exp option * string) IM.map
|
adamc@25
|
44 }
|
adamc@25
|
45
|
adamc@25
|
46 val empty = {
|
adamc@168
|
47 datatypes = IM.empty,
|
adamc@178
|
48 constructors = IM.empty,
|
adamc@25
|
49
|
adamc@25
|
50 relE = [],
|
adamc@25
|
51 namedE = IM.empty
|
adamc@25
|
52 }
|
adamc@25
|
53
|
adamc@168
|
54 fun pushDatatype (env : env) x n xncs =
|
adamc@168
|
55 {datatypes = IM.insert (#datatypes env, n, (x, xncs)),
|
adamc@182
|
56 constructors = foldl (fn ((x, n', to), constructors) =>
|
adamc@182
|
57 IM.insert (constructors, n', (x, to, n)))
|
adamc@178
|
58 (#constructors env) xncs,
|
adamc@25
|
59
|
adamc@25
|
60 relE = #relE env,
|
adamc@25
|
61 namedE = #namedE env}
|
adamc@25
|
62
|
adamc@168
|
63 fun lookupDatatype (env : env) n =
|
adamc@168
|
64 case IM.find (#datatypes env, n) of
|
adamc@25
|
65 NONE => raise UnboundNamed n
|
adamc@25
|
66 | SOME x => x
|
adamc@25
|
67
|
adamc@178
|
68 fun lookupConstructor (env : env) n =
|
adamc@178
|
69 case IM.find (#constructors env, n) of
|
adamc@178
|
70 NONE => raise UnboundNamed n
|
adamc@178
|
71 | SOME x => x
|
adamc@178
|
72
|
adamc@183
|
73 fun pushERel (env : env) x t eo =
|
adamc@168
|
74 {datatypes = #datatypes env,
|
adamc@178
|
75 constructors = #constructors env,
|
adamc@25
|
76
|
adamc@183
|
77 relE = (x, t, eo) :: #relE env,
|
adamc@25
|
78 namedE = #namedE env}
|
adamc@25
|
79
|
adamc@25
|
80 fun lookupERel (env : env) n =
|
adamc@25
|
81 (List.nth (#relE env, n))
|
adamc@25
|
82 handle Subscript => raise UnboundRel n
|
adamc@25
|
83
|
adamc@109
|
84 fun pushENamed (env : env) x n t eo s =
|
adamc@168
|
85 {datatypes = #datatypes env,
|
adamc@178
|
86 constructors = #constructors env,
|
adamc@25
|
87
|
adamc@25
|
88 relE = #relE env,
|
adamc@109
|
89 namedE = IM.insert (#namedE env, n, (x, t, eo, s))}
|
adamc@25
|
90
|
adamc@25
|
91 fun lookupENamed (env : env) n =
|
adamc@25
|
92 case IM.find (#namedE env, n) of
|
adamc@25
|
93 NONE => raise UnboundNamed n
|
adamc@25
|
94 | SOME x => x
|
adamc@25
|
95
|
adamc@164
|
96 fun declBinds env (d, loc) =
|
adamc@25
|
97 case d of
|
adamc@164
|
98 DDatatype (x, n, xncs) =>
|
adamc@164
|
99 let
|
adamc@168
|
100 val env = pushDatatype env x n xncs
|
adamc@164
|
101 in
|
adamc@168
|
102 foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (TDatatype (n, xncs), loc) NONE ""
|
adamc@168
|
103 | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TDatatype (n, xncs), loc)), loc) NONE "")
|
adamc@164
|
104 env xncs
|
adamc@164
|
105 end
|
adamc@164
|
106 | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
|
adamc@126
|
107 | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis
|
adamc@109
|
108 | DExport _ => env
|
adamc@25
|
109
|
adamc@179
|
110 fun patBinds env (p, loc) =
|
adamc@179
|
111 case p of
|
adamc@179
|
112 PWild => env
|
adamc@183
|
113 | PVar (x, t) => pushERel env x t NONE
|
adamc@179
|
114 | PPrim _ => env
|
adamc@179
|
115 | PCon (_, NONE) => env
|
adamc@179
|
116 | PCon (_, SOME p) => patBinds env p
|
adamc@182
|
117 | PRecord xps => foldl (fn ((_, p, _), env) => patBinds env p) env xps
|
adamc@179
|
118
|
adamc@25
|
119 end
|