/
elabtop.sml
209 lines (171 loc) · 7.05 KB
/
elabtop.sml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
(* COPYRIGHT (c) 1996 Bell Laboratories *)
(* elabtop.sml *)
signature ELABTOP =
sig
val elabTop: Ast.dec * StaticEnv.staticEnv * ElabUtil.compInfo
-> Absyn.dec * StaticEnv.staticEnv
val debugging : bool ref
end (* signature ELABTOP *)
(* functorized to factor out dependencies on FLINT... *)
functor ElabTopFn (structure ElabMod : ELABMOD) : ELABTOP =
struct
local structure PP = PrettyPrintNew
structure PU = PPUtilNew
structure S = Symbol
structure SP = SymPath
structure IP = InvPath
structure DA = Access
structure A = Absyn
structure T = Types
structure V = VarCon
structure M = Modules
structure MU = ModuleUtil
structure B = Bindings
structure SE = StaticEnv
structure L = Lookup
structure EU = ElabUtil
structure EE = EntityEnv
structure EP = EntPath
structure EPC = EntPathContext
open Ast
in
(* debugging *)
val say = Control_Print.say
val debugging = ref false
fun debugmsg (msg: string) =
if !debugging then (say msg; say "\n") else ()
val debugPrint = (fn x => ElabDebug.debugPrint debugging x)
(* localStrName: used in makeOpenDec to build redeclaration of components *)
val localStrName = S.strSymbol "<a funny structure>"
fun bug msg = ErrorMsg.impossible("ElabTop: "^msg)
(*
* makeOpenDecls is a hack; it is written to make sure that the backend
* will generate the right dynamic code for all structure components.
* Once the static environment and the dynamic environment are merged,
* these code should become obsolete. (ZHONG)
*)
fun makeOpenDecls (str, spath) =
let fun build (name, dl) =
(case S.nameSpace name
of S.VALspace =>
let val v = MU.getValPath(str, SP.SPATH[name],
SP.SPATH(spath@[name]))
in case v
of V.VAL(V.VALvar _) =>
ValDec([Vb{pat=VarPat[name],
exp=VarExp([localStrName,name]),
lazyp=false}],
nil)
:: dl
(* here is the source of bug 788. If name is bound
to a constructor in the top level environment,
then this will not have the desired affect of
rebinding name, but will probably result in a
type error. Possible fix would be to narrow down
the static environment. *)
| V.CON(T.DATACON{rep=DA.EXN _, ...}) =>
ExceptionDec [EbDef{exn=name,
edef=([localStrName,name])}] :: dl
| _ => dl
end
| S.STRspace =>
StrDec [Strb{name=name,
def=VarStr([localStrName,name]),
constraint=NoSig}] :: dl
| S.FCTspace =>
FctDec [Fctb{name=name,
def=VarFct([localStrName,name],NoSig)}] :: dl
| _ => dl)
val nds = foldr build [] (MU.getStrSymbols str)
in LocalDec(StrDec[Strb{name=localStrName, def=VarStr(spath),
constraint=NoSig}],
SeqDec nds)
end
(*
* The main purpose of having a separate layer of elabTop above elabDecl
* is to deal with the top-level OPEN declarations; once statenv and dynenv
* are merged, there should be no special treatment for OPEN declarations,
* and elabTop probably can be dramatically simplied. (ZHONG)
*)
fun elabTop(dec, env, compInfo as {error,...}: EU.compInfo) =
let
val _ = debugmsg ">>elabTop";
fun elab(SeqDec decs, env0, top, region) =
let fun h(dec, (abdecls, env)) =
let val (abdecl, env') = elab(dec, SE.atop(env,env0), top, region)
in (abdecl::abdecls, SE.atop(env', env))
end
val (abdecls,env') = foldl h ([], SE.empty) decs
in (A.SEQdec(rev abdecls),env')
end
| elab(LocalDec(decl_in, decl_out), env0, top, region) =
let val top_in = EU.hasModules decl_in orelse EU.hasModules decl_out
val (adec_in, env1) = elab(decl_in, env0, top_in, region)
val (adec_out, env2) =
elab(decl_out, SE.atop(env1, env0), top, region)
in (A.LOCALdec(adec_in, adec_out), env2)
end
| elab(MarkDec(dec,region'), env, top, region) =
let val (d,env)= elab(dec,env,top,region')
in (if !ElabControl.markabsyn then A.MARKdec(d,region')
else d, env)
end
| elab(OpenDec paths, env, top, region) =
let val _ = debugPrint("top level open: ",
(fn pps => fn paths =>
PU.ppSequence pps
{sep=(fn pps => PP.string pps ","),
pr=PU.ppSymPath, style=PU.INCONSISTENT}
(List.map SymPath.SPATH paths)), paths)
val err = error region
(* look up the structure variables *)
val strs = map (fn p => L.lookStr(env,SP.SPATH p,err)) paths
(* open their environments to add datatypes, etc. *)
fun h(M.ERRORstr, env) = env
| h(str, env) = MU.openStructure(env, str)
val openEnv = foldl h SE.empty strs
fun g((M.ERRORstr,spath), decs) = decs
| g((str,spath), decs) =
let val ndec = makeOpenDecls(str, spath)
in ndec::decs
end
val newDecs = foldr g [] (ListPair.zip(strs, paths))
(* hack to fix bugs 788, 847.
* narrow the static environment used to elaborate newDecs
* to one only binding the initial symbols of the paths.
* Doesn't hurt if more than one path has same head symbol. *)
val minEnv = foldl (fn (p,e) =>
let val h = (case p
of x::_ => x
| [] => bug "unexpected case OpenDec")
fun err' _ _ _ = ()
(* to suppress duplicate error messages *)
val str = L.lookStr(env,SP.SPATH [h],err')
in SE.bind(h,Bindings.STRbind str,e)
end)
SE.empty
paths
val {absyn=ds, statenv=env'} =
ElabMod.elabDecl{ast=(SeqDec newDecs), statenv=minEnv,
entEnv=EE.empty, context=EU.TOP,
level=top, tdepth=DebIndex.top,
epContext=EPC.initContext,
path=IP.IPATH[], region=region,
compInfo=compInfo}
val nenv = SE.consolidate(SE.atop(env',openEnv))
val strs' = ListPair.zip(map SP.SPATH paths,strs)
in (A.SEQdec [A.OPENdec strs', ds], nenv)
end
| elab(dec, env, top, region) =
let val _ = debugmsg "--elabTop.elab[dec]: calling ElabMod.elabDecl"
val {absyn=d, statenv=env'} =
ElabMod.elabDecl{ast=dec, statenv=env, entEnv=EE.empty,
context=EU.TOP, level=top, tdepth=DebIndex.top,
epContext=EPC.initContext, path=IP.IPATH[],
region=region,compInfo=compInfo}
in (d, env')
end
in elab(dec,env,true,SourceMap.nullRegion) before debugmsg "<<elabTop"
end
end (* local *)
end (* functor ElabTopFn *)