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/branches/primop-branch-2/src/compiler/ElabData/modules/moduleutil.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch-2/src/compiler/ElabData/modules/moduleutil.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1957 - (view) (download)

1 : blume 903 (* COPYRIGHT (c) 1996 Bell Laboratories. *)
2 :     (* moduleutil.sml *)
3 :    
4 :     structure ModuleUtil : MODULEUTIL =
5 :     struct
6 :    
7 :     local structure S = Symbol
8 :     structure SP = SymPath
9 :     structure IP = InvPath
10 :     structure CVP = ConvertPaths
11 :     structure EP = EntPath
12 :     structure EPC = EntPathContext
13 :     structure A = Access
14 :     structure T = Types
15 :     structure TU = TypesUtil
16 :     structure V = VarCon
17 :     structure B = Bindings
18 :     structure EE = EntityEnv
19 :     structure ST = Stamps
20 :     structure M = Modules
21 :     structure MI = ModuleId
22 :     structure SE = StaticEnv
23 :     open Modules
24 :     in
25 :    
26 :     (* debugging hooks *)
27 :     val say = Control_Print.say
28 :     val debugging = ElabDataControl.mudebugging (* ref false *)
29 :     fun debugmsg (msg: string) =
30 :     if !debugging then (say msg; say "\n") else ()
31 :    
32 :     fun bug s = ErrorMsg.impossible ("ModuleUtil: " ^ s)
33 :    
34 :     (*
35 :     * Look up the entity corresponding to a given symbol in the `elements'
36 :     * of a signature and the corresponding `entities' from a structure
37 :     * realization. The (dynamic) access fields of structures and
38 :     * functors are adjusted before they are returned. The static accesses
39 :     * of types, structures, and functors are just returned.
40 :     *
41 :     * Used by the (structure and functor) matching functions.
42 :     *)
43 :    
44 :     exception Unbound of S.symbol
45 :    
46 :     fun getSpec (elements, sym) =
47 :     let fun h [] = (debugmsg("$getSpec "^S.name sym); raise (Unbound sym))
48 :     | h ((s, sp) :: elemr) = if S.eq(s, sym) then sp else h elemr
49 :     in h elements
50 :     end
51 :    
52 :     (*
53 :     * the following might be used to speedup the signature lookup process
54 :     *
55 :     * fun getSpec (elements, sym) =
56 :     * Env.look(elements,sym)
57 :     * handle Env.Unbound => raise (Unbound sym)
58 :     *
59 :     * we'll use more efficient represntations for elements in the future.
60 :     *)
61 :    
62 :     (*** return the entity variable of a particular spec ***)
63 :     fun getSpecVar (STRspec{entVar,...}) = SOME entVar
64 :     | getSpecVar (TYCspec{entVar,...}) = SOME entVar
65 :     | getSpecVar (FCTspec{entVar,...}) = SOME entVar
66 :     | getSpecVar _ = NONE
67 :    
68 :     (*** The function getTyc is used in modules/sigmatch.sml only ***)
69 :     fun getTyc (elements, entEnv, sym) =
70 :     case getSpec (elements, sym)
71 :     of TYCspec{entVar,...} => (EE.lookTycEnt(entEnv,entVar), entVar)
72 :     | _ => bug "getTyc: wrong spec"
73 :    
74 :     (*** The function getStr is used in modules/sigmatch.sml only ***)
75 :     fun getStr (elements, entEnv, sym, dacc, dinfo) =
76 :     case getSpec(elements, sym)
77 :     of STRspec{sign, slot, def, entVar} =>
78 :     (case EE.look(entEnv,entVar)
79 :     of STRent entity =>
80 :     (STR{sign = sign, rlzn = entity, access = A.selAcc(dacc,slot),
81 : georgekuan 1957 prim = PrimOpId.selStrPrimId (dinfo, slot)},
82 : blume 903 entVar)
83 :     | _ => bug "getStr: bad entity")
84 :     | _ => bug "getStr: wrong spec"
85 :    
86 :     (*** The function getFct is used in modules/sigmatch.sml only ***)
87 :     fun getFct (elements, entEnv, sym, dacc, dinfo) =
88 :     case getSpec(elements, sym)
89 :     of FCTspec{sign, slot, entVar} =>
90 :     (case EE.look(entEnv,entVar)
91 :     of FCTent entity =>
92 :     (FCT{sign = sign, rlzn = entity, access = A.selAcc(dacc,slot),
93 : georgekuan 1957 prim = PrimOpId.selStrPrimId (dinfo, slot)},
94 : blume 903 entVar)
95 :     | _ => bug "getFct: bad entity")
96 :     | _ => bug "getFct: wrong spec"
97 :    
98 :     val errorStrStamp = ST.special "ERRORstr"
99 :     val errorStrName = InvPath.IPATH[S.strSymbol "ERRORstr"]
100 :    
101 :     fun getStrStamp(STR { rlzn = {stamp, ...}, ... }) = stamp
102 :     | getStrStamp ERRORstr = errorStrStamp
103 :     | getStrStamp _ = bug "getStrStamp"
104 :    
105 :     fun getStrName(STR { rlzn = {rpath,...}, ... }) = rpath
106 :     | getStrName ERRORstr = errorStrName
107 :     | getStrName _ = bug "getStrName"
108 :    
109 : georgekuan 1957 fun getStrs (STR { sign = SIG sg, rlzn = {entities,...}, access,prim,...}) =
110 : blume 903 let val elements = #elements sg
111 :     in
112 :     List.mapPartial
113 :     (fn (sym,STRspec{sign,slot,def,entVar}) =>
114 :     SOME(STR{sign = sign,
115 :     rlzn = EE.lookStrEnt(entities,entVar),
116 :     access = A.selAcc(access, slot),
117 : georgekuan 1957 prim = PrimOpId.selStrPrimId (prim, slot)})
118 : blume 903 | _ => NONE)
119 :     elements
120 :     end
121 :     | getStrs ERRORstr = nil
122 :     | getStrs _ = bug "getStrs"
123 :    
124 :     fun getTycs (STR { sign = SIG sg, rlzn = {entities,...}, ... }) =
125 :     let val elements = #elements sg
126 :     val tycvars = List.mapPartial
127 :     (fn (sym,TYCspec{entVar,...}) => SOME entVar
128 :     | _ => NONE)
129 :     elements
130 :     in
131 :     List.map (fn tycVar => EE.lookTycEnt(entities,tycVar)) tycvars
132 :     end
133 :     | getTycs ERRORstr = nil
134 :     | getTycs _ = bug "getTycs (2)"
135 :    
136 :     fun getSigSymbols(SIG {symbols,...}) = symbols
137 :     | getSigSymbols _ = nil
138 :    
139 :     fun getStrSymbols(STR { sign, ... }) = getSigSymbols sign
140 :     | getStrSymbols _ = nil
141 :    
142 :     (*** Translate a tycon in a given entityEnv ***)
143 :     fun transTycon entEnv (T.PATHtyc{entPath,path,...}) =
144 :     (EE.lookTycEP(entEnv,entPath)
145 :     handle EE.Unbound =>
146 :     (debugmsg (String.concat["$transTycon ",
147 :     IP.toString path," ",
148 :     EP.entPathToString entPath]);
149 :     raise EE.Unbound))
150 :     | transTycon _ tycon = tycon
151 :    
152 :    
153 :     (*
154 :     * Translate a type in a given entityEnv
155 :     *
156 :     * We should never need to recurse inside each DEFtyc's body because
157 :     * a DEFtycs is either rigid or has been relativized as a whole into
158 :     * a PATHtyc with an entPath somewhere before.
159 :     *)
160 :     fun transType entEnv ty =
161 :     TU.mapTypeFull (transTycon entEnv) ty
162 :     handle EE.Unbound => (debugmsg "$transType"; raise EE.Unbound)
163 :    
164 :     (*
165 :     val transTyconPhase = (Stats.makePhase "Compiler 033 4-transTycon")
166 :     val transTycon =
167 :     fn x => fn y => (Stats.doPhase transTyconPhase (transTycon x) y)
168 :    
169 :     val transTypePhase = (Stats.makePhase "Compiler 033 5-transType")
170 :     val transType =
171 :     fn x => fn y => (Stats.doPhase transTypePhase (transType x) y)
172 :     *)
173 :    
174 :     fun strDefToStr(CONSTstrDef str, _) = str
175 :     | strDefToStr(VARstrDef(sign,entPath), entEnv) =
176 :     STR{sign=sign,rlzn=EE.lookStrEP(entEnv,entPath),
177 : georgekuan 1957 access=A.nullAcc, info=StrE []}
178 : blume 903
179 :     (*
180 :     * two pieces of essential structure information gathered during
181 :     * the environment lookup. SIGINFO is returned if the structure
182 :     * being searched is a STRSIG; otherwise it return STRINFO.
183 :     *)
184 :     datatype strInfo = SIGINFO of EP.entPath (* reverse order! *)
185 : macqueen 1946 | STRINFO of strEntity * A.access * InlInfo.inl_info
186 : blume 903
187 : macqueen 1946 val bogusInfo = STRINFO (bogusStrEntity, A.nullAcc, II.nullInfo)
188 : blume 903
189 :     fun getStrElem (sym, sign as SIG {elements,...}, sInfo) =
190 :     (case getSpec (elements,sym)
191 :     of STRspec{sign=subsig, slot, def, entVar} =>
192 :     (let val newInfo =
193 :     case sInfo
194 :     of SIGINFO ep => SIGINFO (entVar::ep)
195 :     | STRINFO ({entities,...}, dacc, dinfo) =>
196 :     STRINFO(EE.lookStrEnt(entities,entVar),
197 : macqueen 1946 A.selAcc(dacc,slot), II.selStrInfo (dinfo, slot))
198 : blume 903 in (subsig, newInfo)
199 :     end)
200 :     | _ => bug "getStrElem: wrong spec case")
201 :    
202 :     | getStrElem (sym, sign, _) = (sign, bogusInfo)
203 :    
204 :     fun getFctElem (sym, sign as SIG {elements,...},
205 :     sinfo as STRINFO(rlzn as {entities,...}, dacc, dinfo)) =
206 :     (case getSpec(elements, sym)
207 :     of FCTspec{sign=subfsig, entVar, slot} =>
208 :     FCT{sign=subfsig, rlzn=EE.lookFctEnt(entities,entVar),
209 :     access=A.selAcc(dacc, slot),
210 : macqueen 1946 info=II.selStrInfo (dinfo, slot)}
211 : blume 903 | _ => bug "mkFctVar - bad spec")
212 :    
213 :     | getFctElem _ = ERRORfct
214 :    
215 :     fun mkTyc (sym, sp, SIG {elements,...}, sInfo) =
216 :     (case getSpec (elements, sym)
217 :     of TYCspec{spec,entVar=ev,repl,scope} =>
218 :     (case sInfo
219 :     of SIGINFO ep =>
220 :     T.PATHtyc{arity=TU.tyconArity spec, entPath=rev(ev::ep),
221 :     path=CVP.invertSPath sp}
222 :     | STRINFO ({entities,...}, _, _) =>
223 :     EE.lookTycEnt(entities, ev))
224 :    
225 :     | _ => bug "mkTyc: wrong spec case")
226 :    
227 :     | mkTyc _ = T.ERRORtyc
228 :    
229 :     fun mkVal (sym, sp, sign as SIG {elements,...},
230 :     sInfo as STRINFO({entities,...}, dacc, dinfo)) : V.value =
231 :     (case getSpec(elements, sym) of
232 :     VALspec{spec,slot} =>
233 :     V.VAL(V.VALvar{access = A.selAcc(dacc,slot),
234 : macqueen 1946 info = II.selStrInfo (dinfo, slot),
235 : blume 903 path = sp,
236 :     typ = ref(transType entities spec)})
237 :     | CONspec{spec=T.DATACON{name, const, typ, rep, sign, lazyp},
238 :     slot} =>
239 :     let val newrep =
240 :     case (rep, slot)
241 :     of (A.EXN _, SOME i) => A.EXN (A.selAcc(dacc,i))
242 :     | _ => rep
243 :    
244 :     in
245 :     V.CON(T.DATACON{rep=newrep, name=name,
246 :     typ=transType entities typ,
247 :     const=const, sign=sign, lazyp=lazyp})
248 :     end
249 :     | _ => bug "mkVal: wrong spec")
250 :     | mkVal _ = V.VAL(V.ERRORvar)
251 :    
252 :     fun mkStrBase (sym, sign, sInfo) =
253 :     let val (newsig, newInfo) = getStrElem (sym, sign, sInfo)
254 :     in case newsig
255 :     of ERRORsig => ERRORstr
256 :     | _ =>
257 :     (case newInfo
258 :     of STRINFO(newrlzn, newacc, newinfo) =>
259 :     STR{sign=newsig, rlzn=newrlzn, access=newacc,
260 :     info=newinfo}
261 :     | SIGINFO ep => STRSIG{sign=newsig, entPath=rev ep})
262 :     end
263 :    
264 :     fun mkStr (sym, _, sign, sInfo) = mkStrBase (sym, sign, sInfo)
265 :    
266 :     fun mkStrDef (sym, _, sign, sInfo) =
267 :     let val (newsig, newInfo) = getStrElem (sym, sign, sInfo)
268 :     in case newsig
269 :     of ERRORsig => CONSTstrDef ERRORstr
270 :     | _ =>
271 :     (case newInfo
272 :     of STRINFO (newrlzn, newacc, newinfo) =>
273 :     CONSTstrDef(STR{sign=newsig, rlzn=newrlzn,
274 :     access=newacc, info=newinfo})
275 :     | SIGINFO ep => VARstrDef(newsig, rev ep))
276 :     end
277 :    
278 :     fun mkFct (sym, sp, sign, sInfo) = getFctElem (sym, sign, sInfo)
279 :    
280 :     fun getPath makeIt (str, SP.SPATH spath, fullsp) =
281 :     let fun loop([sym], sign, sInfo) = makeIt (sym, fullsp, sign, sInfo)
282 :     | loop(sym::rest, sign, sInfo) =
283 :     let val (newsig, newsInfo) = getStrElem (sym, sign, sInfo)
284 :     in loop(rest, newsig, newsInfo)
285 :     end
286 :     | loop _ = bug "getPath.loop"
287 :    
288 :     in case str
289 :     of STR { sign, rlzn, access, info } =>
290 :     loop(spath, sign, STRINFO(rlzn, access, info))
291 :     | STRSIG{sign, entPath} =>
292 :     loop(spath, sign, SIGINFO (rev entPath))
293 :     | _ => loop(spath, ERRORsig, bogusInfo)
294 :     end
295 :    
296 :     val getTycPath : M.Structure * SP.path * SP.path -> T.tycon =
297 :     getPath mkTyc
298 :     val getValPath : M.Structure * SP.path * SP.path -> V.value =
299 :     getPath mkVal
300 :     val getStrPath : M.Structure * SP.path * SP.path -> M.Structure =
301 :     getPath mkStr
302 :     val getFctPath : M.Structure * SP.path * SP.path -> M.Functor =
303 :     getPath mkFct
304 :     val getStrDef : M.Structure * SP.path * SP.path -> M.strDef =
305 :     getPath mkStrDef
306 :    
307 :     fun checkPathSig (sign: M.Signature, spath: SP.path) : S.symbol option =
308 :     let val str = STRSIG{sign=sign,entPath=[]:EP.entPath}
309 :     fun checkLast _ (sym,_,SIG {elements,...},_) =
310 :     (getSpec(elements,sym); ())
311 :     | checkLast _ (sym,_,ERRORsig,_) = ()
312 :     in getPath checkLast (str,spath,SP.empty);
313 :     NONE
314 :     end
315 :     handle Unbound sym => SOME sym
316 :    
317 :     fun errBinding sym =
318 :     case S.nameSpace sym
319 :     of S.VALspace => B.VALbind V.ERRORvar
320 :     | S.TYCspace => B.TYCbind T.ERRORtyc
321 :     | S.STRspace => B.STRbind M.ERRORstr
322 :     | S.FCTspace => B.FCTbind M.ERRORfct
323 :     | _ => raise (Unbound sym)
324 :    
325 :     fun eqSign (SIG { stamp = s1, closed = true, ... },
326 :     SIG { stamp = s2, closed = true, ... }) = ST.eq (s1, s2)
327 :     | eqSign _ = false
328 :    
329 :     fun eqOrigin(STR s1, STR s2) = ST.eq (#stamp (#rlzn s1), #stamp (#rlzn s2))
330 :     | eqOrigin _ = false
331 :    
332 :     (*
333 :     * The following functions are used in CMStaticEnv and module elaboration
334 :     * for building EntPathContexts. They extract module ids from modules.
335 :     *)
336 :     val tycId = MI.tycId'
337 :    
338 :     fun strId (STR sa) = MI.strId sa
339 :     | strId _ = bug "strId"
340 :    
341 :     fun strId2(SIG sa, rlzn : strEntity) = MI.strId2 (sa, rlzn)
342 :     | strId2 _ = bug "strId2"
343 :    
344 :     fun fctId (FCT fa) = MI.fctId fa
345 :     | fctId _ = bug "fctId"
346 :    
347 :     fun fctId2(sign, rlzn : fctEntity) = MI.fctId2 (sign, rlzn)
348 :    
349 :     (*
350 :     * The reason that relativizeType does not need to get inside
351 :     * DEFtyc is because of our assumptions that the body in DEFtyc
352 :     * has already been relativized, when DEFtyc is elaborated;
353 :     * otherwise, this DEFtyc must be a rigid tycon.
354 :     *)
355 :     fun relativizeTyc epContext : T.tycon -> T.tycon * bool =
356 :     let fun stamped tyc = let
357 :     val tyc_id = MI.tycId' tyc
358 :     in
359 :     (* debugmsg ("mapTyc: "^ModuleId.idToString tyc_id); *)
360 :     case EPC.lookTycPath(epContext,tyc_id)
361 :     of NONE => (debugmsg "tyc not mapped 1"; (tyc,false))
362 :     | SOME entPath =>
363 :     let val tyc' = T.PATHtyc{arity=TU.tyconArity tyc,
364 :     entPath=entPath,
365 :     path=TU.tycPath tyc}
366 :     in
367 :     debugmsg("tyc mapped: "^
368 :     Symbol.name(TypesUtil.tycName tyc'));
369 :     (tyc',true)
370 :     end
371 :     end
372 :    
373 :     fun mapTyc (tyc as (T.GENtyc _ | T.DEFtyc _)) = stamped tyc
374 :     | mapTyc(tyc as T.PATHtyc _) =
375 :     (* assume this is a local tycon within the current signature *)
376 :     (debugmsg "tyc not mapped 2";
377 :     (tyc,true))
378 :     | mapTyc tyc = (debugmsg "tyc not mapped 3"; (tyc,false))
379 :    
380 :     fun mapTyc' tyc =
381 :     (debugmsg("mapTyc': "^(Symbol.name(TypesUtil.tycName tyc)));
382 :     mapTyc tyc)
383 :     in mapTyc'
384 :     end
385 :    
386 :     fun relativizeType epContext ty : T.ty * bool =
387 :     let val relative = ref false
388 :     fun vizTyc tyc =
389 :     let val (tyc',rel) = relativizeTyc epContext tyc
390 :     in relative := (!relative orelse rel);
391 :     tyc'
392 :     end
393 :     in (TU.mapTypeFull vizTyc ty, !relative)
394 :     end
395 :    
396 :    
397 :     (*
398 :     val relativizeTypePhase = (Stats.makePhase "Compiler 033 2-vizType")
399 :     val relativizeType =
400 :     fn x => fn y =>
401 :     (Stats.doPhase relativizeTypePhase (relativizeType x) y)
402 :    
403 :     *)
404 :    
405 :     (*
406 :     * getBinding(sym,str): return binding for element sym of structure str
407 :     * - used only inside the function openStructure
408 :     * - raises ModuleUtil.Unbound if sym not found in sig
409 :     *)
410 :     fun getBinding (sym, str as STR st) =
411 :     (case st of
412 :     {sign as SIG _, rlzn, access=dacc, info=dinfo} =>
413 :     let val sinfo = STRINFO(rlzn, dacc, dinfo)
414 :     val entities = #entities rlzn
415 :     in
416 :     case S.nameSpace sym
417 :     of S.VALspace =>
418 :     (case mkVal (sym, SP.SPATH[sym], sign, sinfo)
419 :     of V.VAL v => B.VALbind v
420 :     | V.CON d => B.CONbind d)
421 :     | S.TYCspace =>
422 :     B.TYCbind (mkTyc (sym, SP.SPATH[sym], sign, sinfo))
423 :     | S.STRspace => B.STRbind (mkStrBase (sym, sign, sinfo))
424 :     | S.FCTspace => B.FCTbind (getFctElem (sym, sign, sinfo))
425 :     | sp => (debugmsg ("getBinding: "^S.symbolToString sym);
426 :     raise (Unbound sym))
427 :     end
428 :     | { sign = ERRORsig, ... } => errBinding sym)
429 :     | getBinding (sym, STRSIG{sign as SIG _,entPath=ep}) =
430 :     let val sinfo = SIGINFO(rev ep)
431 :     in
432 :     case S.nameSpace sym
433 :     of S.TYCspace =>
434 :     B.TYCbind (mkTyc (sym, SP.SPATH[sym], sign, sinfo))
435 :     | S.STRspace => B.STRbind (mkStrBase (sym, sign, sinfo))
436 :     | _ => (debugmsg ("getBinding: "^S.symbolToString sym);
437 :     raise (Unbound sym))
438 :     end
439 :     | getBinding (sym, ERRORstr) = errBinding sym
440 :     | getBinding _ = bug "getBinding - bad arg"
441 :    
442 :     fun openStructure (env: SE.staticEnv, str) =
443 :     let fun look sym =
444 :     getBinding (sym,str) handle Unbound _ => raise SE.Unbound
445 :     val symbols = getStrSymbols str
446 :     val genSyms = (fn () => symbols)
447 :     val nenv = SE.special(look, genSyms)
448 :     in SE.atop(nenv,env)
449 :     end
450 :    
451 : georgekuan 1957 (** Get a strPrimElem with all the primIds found in
452 :     a list of bindings
453 :    
454 :     Used in Elaborator/elaborate/elabmod.sml and
455 :     SigMatch
456 :     *)
457 :     fun strPrimElemInBinds [] = StrE []
458 :     | strPrimElemInBinds (bind::rest) =
459 :     let
460 :     val strPrims =
461 :     (case bind
462 :     of B.STRbind (M.STR { prim, ... }) => prim
463 :     | B.FCTbind (M.FCT { prim, ... }) => prim
464 :     | B.VALbind (V.VALvar {info, ...}) => PrimE info
465 :     | B.CONbind _ => PrimE NonPrim
466 :     | B.TYCbind _ =>
467 :     bug "unexpected binding in strPrimElemInBinds")
468 :     in
469 :     (case (strPrimElemInBinds rest) of
470 :     (StrE restPrims) =>
471 :     StrE (strPrims :: restPrims)
472 :     | PrimE id => StrE (PrimE id))
473 :     end
474 : blume 903
475 :     (* extract all signature names from a structure --
476 :     * doesn't look into functor components *)
477 :     fun getSignatureNames s = let
478 :     fun fromSig sign = let
479 :     fun sigNames(SIG {name,elements,...}, names) =
480 :     foldl (fn ((_,STRspec{sign,...}),ns) =>
481 :     sigNames(sign, ns)
482 :     | (_,ns) => ns)
483 :     (case name of SOME n => n::names | NONE => names)
484 :     elements
485 :     | sigNames(ERRORsig,names) = names
486 :     fun removeDups (x::(rest as y::_),z) =
487 :     if S.eq(x,y) then removeDups(rest,z) else removeDups(rest,x::z)
488 :     | removeDups (x::nil,z) = x::z
489 :     | removeDups (nil,z) = z
490 :     in removeDups(ListMergeSort.sort S.symbolGt(sigNames(sign,nil)), nil)
491 :     end
492 :     in
493 :     case s of
494 :     STR { sign, ... } => fromSig sign
495 :     | STRSIG { sign, ... } => fromSig sign
496 :     | ERRORstr => nil
497 :     end
498 :     end (* local *)
499 :     end (* structure ModuleUtil *)
500 :    

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