Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/Elaborator/elaborate/elabtop.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/Elaborator/elaborate/elabtop.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 902 - (view) (download)

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

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0