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/SMLNJ/src/compiler/Semant/elaborate/elabmod.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/compiler/Semant/elaborate/elabmod.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 24 - (view) (download)

1 : monnier 16 (* Copyright 1996 by AT&T Bell Laboratories *)
2 :     (* elabmod.sml *)
3 :    
4 :     signature ELABMOD =
5 :     sig
6 :    
7 :     (* elaborate module-level declarations *)
8 :     val elabDecl :
9 :     {ast : Ast.dec,
10 :     statenv : StaticEnv.staticEnv,
11 :     entEnv : Modules.entityEnv,
12 :     context : ElabUtil.context, (* elab context *)
13 :     level : bool, (* T if top-level decl. *)
14 :     epContext : EntPathContext.context,
15 :     path : InvPath.path,
16 :     region : SourceMap.region,
17 :     compInfo : ElabUtil.compInfo} -> {absyn : Absyn.dec,
18 :     statenv : StaticEnv.staticEnv}
19 :    
20 :     val debugging : bool ref
21 :    
22 :     end (* signature ELABMOD *)
23 :    
24 :    
25 :     structure ElabMod : ELABMOD =
26 :     struct
27 :    
28 :     local structure S = Symbol
29 :     structure IP = InvPath
30 :     structure SP = SymPath
31 :     structure EP = EntPath
32 :     structure EPC = EntPathContext
33 :     structure EE = EntityEnv
34 :     structure T = Types
35 :     structure TU = TypesUtil
36 :     structure V = VarCon
37 :     structure M = Modules
38 :     structure MU = ModuleUtil
39 :     structure MI = ModuleId
40 :     structure L = Lookup
41 :     structure EU = ElabUtil
42 :     structure ET = ElabType
43 :     structure EC = ElabCore
44 :     structure ES = ElabSig
45 :     structure B = Bindings
46 :     structure LU = Lookup
47 :     structure SM = SigMatch
48 :     structure INS = Instantiate
49 :     structure II = InlInfo
50 :     structure SE = StaticEnv
51 :     structure EM = ErrorMsg
52 :     structure PP = PrettyPrint
53 :     structure A = Absyn
54 :     structure DA = Access
55 :     structure DI = DebIndex
56 :     structure PPU = PPUtil
57 :     structure ED = ElabDebug
58 :     open Ast Modules
59 :     in
60 :    
61 :     (* debugging *)
62 :     val say = Control.Print.say
63 :     val debugging = Control.CG.emdebugging (* ref false *)
64 :     fun debugmsg (msg: string) =
65 :     if !debugging then (say msg; say "\n") else ()
66 :    
67 :     fun bug msg = ErrorMsg.impossible("ElabMod: "^msg)
68 :    
69 :     val debugPrint = (fn x => ED.debugPrint debugging x)
70 :    
71 :     fun showStr(msg,str,env) =
72 :     ED.withInternals(fn () =>
73 :     debugPrint(msg,
74 :     (fn pps => fn str =>
75 :     PPModules.ppStructure pps (str, env, 100)),
76 :     str))
77 :    
78 :     fun showFct(msg,fct,env) =
79 :     ED.withInternals(fn () =>
80 :     debugPrint(msg,
81 :     (fn pps => fn fct' =>
82 :     PPModules.ppFunctor pps (fct', env, 100)),
83 :     fct))
84 :    
85 :     (*
86 :     * Check if an entity declaration is empty in order to avoid the unnecessary
87 :     * recompilation bug reported by Matthias Blume (ZHONG)
88 :     *)
89 :     fun nonEmptyEntDec (M.EMPTYdec | M.SEQdec []) = false
90 :     | nonEmptyEntDec _ = true
91 :    
92 :     fun seqEntDec ds =
93 :     let val nds = List.filter nonEmptyEntDec ds
94 :     in case nds of [] => M.EMPTYdec
95 :     | _ => M.SEQdec nds
96 :     end
97 :    
98 :     fun localEntDec(d1, d2) = seqEntDec [d1, d2]
99 :    
100 :     (* special symbols *)
101 :     val paramId = S.strSymbol "<param>"
102 :     val functorId = S.fctSymbol "<functor>"
103 :     val hiddenId = S.strSymbol "<hidden>"
104 :     val tempStrId = S.strSymbol "<tempStr>"
105 :     val tempFctId = S.fctSymbol "<tempFct>"
106 :     val fctbodyId = S.strSymbol "<fctbody>"
107 :     val anonfsigId = S.fsigSymbol "<anonfsig>"
108 :     val resultId = S.strSymbol "<resultStr>"
109 :     val returnId = S.strSymbol "<returnStr>"
110 :    
111 :     fun stripMarkSigb(MarkSigb(sigb',region'),region) =
112 :     stripMarkSigb(sigb',region')
113 :     | stripMarkSigb x = x
114 :    
115 :     fun stripMarkFsigb(MarkFsigb(fsigb',region'),region) =
116 :     stripMarkFsigb(fsigb',region')
117 :     | stripMarkFsigb x = x
118 :    
119 :     fun stripMarkFctb(MarkFctb(fctb',region'),region) =
120 :     stripMarkFctb(fctb',region')
121 :     | stripMarkFctb x = x
122 :    
123 :     fun stripMarkStrb(MarkStrb(strb',region'),region) =
124 :     stripMarkStrb(strb',region')
125 :     | stripMarkStrb x = x
126 :    
127 :     (* change of context on entering a structure *)
128 :     fun inStr (EU.TOP) = EU.INSTR
129 :     | inStr z = z
130 :    
131 :     (*
132 :     * Add modId to entPath mappings for all appropriate elements of a structure
133 :     * that has just been elaborated. If epc is the empty context (rigid), then
134 :     * this is an expensive no-op, so we test epc first. But, would this be
135 :     * equivalent to context=INFCT _ ?
136 :     *
137 :     * epc is the EntPathContext for the interior of the structure -- i.e.
138 :     * the structure binding's entVar has been added to the bindContext
139 :     *
140 :     * mapPaths is quite heavy weight right now; it can be simplified in
141 :     * several ways, first, all tycon stamps don't have to be remapped,
142 :     * if new tycon stamps are mapped by Instantiate, then each mapPaths
143 :     * only need to deal with structures and functors; even dealing with
144 :     * structures and functors can be distributed into the signature matching
145 :     * or the instantiation process. (ZHONG)
146 :     *)
147 :    
148 :     fun mapPaths0(epc, STR{sign, rlzn, ...}, flex) = mapEPC(epc, sign, rlzn, flex)
149 :     | mapPaths0 _ = ()
150 :    
151 : monnier 24 and mapPaths x =
152 :     Stats.doPhase (Stats.makePhase "Compiler 033 1-mapPaths") mapPaths0 x
153 : monnier 16
154 :     and mapEPC(epc, sign as SIG{elements,...},
155 :     rlzn as {entities, ...} : M.strEntity, flex) =
156 :     let fun doElem(_,TYCspec{entVar=ev, ...}) =
157 :     (*
158 :     * bind only if tycon is flexible -- have to pass flexibility
159 :     * tester -- but wait! what about a rigid structure with a
160 :     * new signature? Have to record even rigid strs and fcts in
161 :     * case they have new signatures
162 :     *)
163 :     (case EE.look(entities,ev)
164 :     of TYCent tyc =>
165 :     (case tyc
166 :     of T.ERRORtyc => ()
167 :     | _ =>
168 :     let val stamp = TU.tycStamp tyc
169 :     in if flex stamp
170 :     then EPC.bindPath(epc,MI.TYCid(stamp),ev)
171 :     else ()
172 :     end)
173 :     | ERRORent => ()
174 :     | _ => bug "mapEPC 1")
175 :    
176 :     | doElem(_,STRspec{entVar=ev,sign=s,...}) =
177 :     (*
178 :     * map this structure (unconditionally, because it may
179 :     * have a different signature)
180 :     *)
181 :     (case s (* don't record ERRORsig -- error tolerance *)
182 :     of SIG _ =>
183 :     (case EE.look(entities,ev)
184 :     of STRent nr =>
185 :     let val i = MU.strId2(s,nr)
186 :     in case EPC.lookPath(epc, i)
187 :     of SOME _ => ()
188 :     | _ => (EPC.bindPath(epc,i,ev);
189 :     mapEPC(EPC.enterOpen(epc,SOME ev),
190 :     s,nr,flex))
191 :     end
192 :     | ERRORent => ()
193 :     | _ => bug "mapEPC 2")
194 :     | ERRORsig => ())
195 :    
196 :     | doElem(_,FCTspec{entVar=ev,sign=s,...}) =
197 :     (* map this functor (unconditionally) *)
198 :     (case s
199 :     of FSIG _ =>
200 :     (case EE.look(entities,ev)
201 :     of FCTent nr =>
202 :     let val i = MU.fctId2(s,nr)
203 :     in EPC.bindPath(epc,i,ev)
204 :     end
205 :     | ERRORent => ()
206 :     | _ => bug "mapEPC 3")
207 :     | ERRORfsig => ())
208 :    
209 :     | doElem _ = ()
210 :    
211 :     in if EPC.isEmpty epc then () else List.app doElem elements
212 :     end
213 :    
214 :     | mapEPC _ = ()
215 :    
216 :     (*
217 :     fun bindReplTyc(EU.INFCT _, epctxt, mkStamp, dtyc) =
218 :     let val ev = mkStamp()
219 :     val tyc_id = MU.tycId dtyc
220 :     val texp =
221 :     case EPC.lookPath(epContext,tyc_id)
222 :     of NONE => (debugmsg "tyc not mapped 1"; M.CONSTtyc tyc)
223 :     | SOME entPath => M.VARtyc entPath
224 :     in EPC.bindPath(epctxt, tyc_id, ev);
225 :     M.TYCdec(ev,texp)
226 :     end
227 :     | bindReplTyc _ = (EE.empty, M.EMPTYdec)
228 :     *)
229 :    
230 :    
231 :     (*
232 :     * ASSERT: order of DEFtycs in tycs respects dependencies, i.e. no
233 :     * DEFtyc refers to tycons occurring after itself.
234 :     *)
235 :     fun bindNewTycs(EU.INFCT _, epctxt, mkStamp, dtycs, wtycs, rpath, err) =
236 :     let fun stripPath path =
237 :     let val namePath = IP.IPATH[IP.last path]
238 :     val prefix = IP.lastPrefix path
239 :     val _ = if IP.equal(rpath,prefix) then ()
240 :     else err EM.WARN
241 :     "Harmless compiler bug: bad type path prefix"
242 :     EM.nullErrorBody
243 :     in namePath
244 :     end
245 :    
246 :     val vizty = (fn ty => #1(MU.relativizeType epctxt ty))
247 :     val viztc = (fn tc => #1(MU.relativizeTyc epctxt tc))
248 :     (* this is ok because epContext has state; a bit ugly *)
249 :     val ndtycs =
250 :     (case dtycs
251 :     of ((T.GENtyc{kind=T.DATATYPE{index=0,family,freetycs,
252 :     stamps, root}, ...})::_) =>
253 :     let val rootev = mkStamp()
254 :     val rtevOp = SOME rootev
255 :     val nfreetycs = map viztc freetycs
256 :     val nstamps = Vector.map (fn _ => mkStamp()) stamps
257 :    
258 :     fun newdt (dt as T.GENtyc{kind=T.DATATYPE{index=i,...},
259 :     arity, eq, path, ...}) =
260 :     let val (ev, rtev) =
261 :     if i=0 then (rootev, NONE)
262 :     else (mkStamp(), rtevOp)
263 :    
264 :     val nkind =
265 :     T.DATATYPE{index=i, stamps=nstamps,
266 :     freetycs=nfreetycs,root=rtev,
267 :     family=family}
268 :     (* the rtev field in DATATYPE indicates
269 :     how to discover the new stamps when
270 :     such datatypes are being evalent-ed *)
271 :    
272 :     val ndt =
273 :     T.GENtyc{arity=arity, eq=eq, kind=nkind,
274 :     path=stripPath path,
275 :     stamp=Vector.sub(nstamps,i)}
276 :    
277 :     val _ = EPC.bindPath(epctxt, MU.tycId dt, ev)
278 :     in (ev, dt, M.FORMtyc ndt)
279 :     end
280 :     | newdt _ = bug "unexpected case in newdtyc"
281 :     in map newdt dtycs
282 :     end
283 :     | [] => []
284 :     | _ => bug "unexpected tycs in bindNewTycs")
285 :    
286 :     val nwtycs =
287 :     let fun newtc (tc as T.DEFtyc{stamp, tyfun=T.TYFUN{arity,body},
288 :     strict, path}) =
289 :     let val ev = mkStamp()
290 :     val _ = EPC.bindPath(epctxt, MU.tycId tc, ev)
291 :     val ntc =
292 :     T.DEFtyc{stamp=mkStamp(), strict=strict,
293 :     path=stripPath path,
294 :     tyfun=T.TYFUN{arity=arity,
295 :     body=vizty body}}
296 :     in (ev, tc, M.FORMtyc ntc)
297 :     end
298 :     | newtc _ = bug "unexpected case in newwtyc"
299 :     in map newtc wtycs
300 :     end
301 :    
302 :     fun bind((ev,tc,te)::tcs, entEnv, entDecs) =
303 :     bind(tcs, EE.bind(ev,M.TYCent(tc),entEnv),
304 :     M.TYCdec(ev, te)::entDecs)
305 :     | bind(nil, entEnv, entDecs) =
306 :     (EE.mark(mkStamp,entEnv), seqEntDec(rev entDecs))
307 :    
308 :     in bind(ndtycs@nwtycs, EE.empty, [])
309 :     end
310 :    
311 :     | bindNewTycs _ = (EE.empty, M.EMPTYdec)
312 :    
313 :    
314 :     (***************************************************************************
315 :     * *
316 :     * extractSig infers the signature for an arbitrary static environment. *
317 :     * *
318 :     * Recompute dynamic accesses after the elaboration of a structure body, *
319 :     * replacing the original dynamic access by a SLOT and generating a *
320 :     * thinning that will be used (in translate) to create the structure *
321 :     * record. *
322 :     * *
323 :     * Recompute all the dynamic accesses in an environment, suppress doubles *
324 :     * and allocate slots. Components are ordered so that slot allocation is *
325 :     * independant from the way elaboration is done. *
326 :     * *
327 :     * Should use Env.fold or Env.map? *
328 :     * *
329 :     ***************************************************************************)
330 :     fun extractSig (env, epContext, context,
331 :     compInfo as {mkStamp,...} : EU.compInfo) =
332 :     let fun getEpOp modId =
333 :     case context of EU.INFCT _ => EPC.lookPath(epContext, modId)
334 :     | _ => NONE
335 :     val relativize =
336 :     case context
337 :     of EU.INFCT _ => (fn ty => #1(MU.relativizeType epContext ty))
338 :     | _ => fn x => x
339 :    
340 :     fun addElems(x, elements) = x::elements
341 :    
342 :     fun transBind ((sym, binding),
343 :     (elements, entEnv, entDecl, trans, slotCount, fctflag)) =
344 :     case binding
345 :     of B.VALbind(V.VALvar{typ,path,...}) =>
346 :     let val spec = VALspec{spec=relativize(!typ),
347 :     slot=slotCount}
348 :     val elements' = addElems((sym, spec), elements)
349 :     in (elements', entEnv, entDecl, binding::trans,
350 :     slotCount+1, fctflag)
351 :     end
352 :    
353 :     | B.CONbind(dcon as T.DATACON{name,const,sign,typ,rep}) =>
354 :     let val typ' = relativize typ
355 :     val (rep', trans', slotOp, slotCount') =
356 :     case rep
357 :     of DA.EXN _ =>
358 :     (DA.EXN(DA.nullAcc), binding::trans,
359 :     SOME slotCount, slotCount+1)
360 :    
361 :     | _ => (rep, trans, NONE, slotCount)
362 :    
363 :     val ndcon = T.DATACON{name=name, const=const, sign=sign,
364 :     typ=typ', rep=rep'}
365 :    
366 :     val spec = CONspec{spec=ndcon, slot=slotOp}
367 :     val elements' = addElems((sym, spec), elements)
368 :    
369 :     in (elements', entEnv, entDecl, trans', slotCount', fctflag)
370 :     end
371 :    
372 :     | B.STRbind(str as STR{sign,rlzn,...}) =>
373 :     let val epOp = getEpOp(MU.strId str)
374 :     val (ev, entEnv', entDecl') =
375 :     case epOp
376 :     of SOME [x] => (x, entEnv, entDecl)
377 :     | _ =>
378 :     (let val x = mkStamp()
379 :     val ee = EE.bind(x, STRent rlzn, entEnv)
380 :     val ed =
381 :     case context
382 :     of EU.INFCT _ =>
383 :     (let val strExp =
384 :     case epOp
385 :     of SOME ep => M.VARstr ep
386 :     | _ => M.CONSTstr rlzn
387 :     in (M.STRdec(x, strExp, sym))::entDecl
388 :     end)
389 :     | _ => entDecl
390 :     in (x, ee, ed)
391 :     end)
392 :    
393 :     val spec = STRspec{sign=sign, slot=slotCount, def = NONE,
394 :     entVar=ev}
395 :     val elements' = addElems((sym, spec), elements)
396 :     val fctflag' =
397 :     (case sign
398 :     of SIG{fctflag=bb, ...} => fctflag orelse bb
399 :     | _ => fctflag)
400 :     in (elements', entEnv', entDecl', binding::trans,
401 :     slotCount+1, fctflag')
402 :     end
403 :    
404 :     | B.FCTbind(fct as FCT{sign, rlzn, ...}) =>
405 :     let val epOp = getEpOp(MU.fctId fct)
406 :     val (ev, entEnv', entDecl') =
407 :     case epOp
408 :     of SOME [x] => (x, entEnv, entDecl)
409 :     | _ =>
410 :     (let val x = mkStamp()
411 :     val ee = EE.bind(x, FCTent rlzn, entEnv)
412 :     val ed =
413 :     case context
414 :     of EU.INFCT _ =>
415 :     (let val fctExp =
416 :     case epOp
417 :     of SOME ep => M.VARfct ep
418 :     | _ => M.CONSTfct rlzn
419 :     in (M.FCTdec(x, fctExp))::entDecl
420 :     end)
421 :     | _ => entDecl
422 :     in (x, ee, ed)
423 :     end)
424 :    
425 :     val spec = FCTspec{sign=sign,slot=slotCount,entVar=ev}
426 :     val elements' = addElems((sym, spec), elements)
427 :     in (elements', entEnv', entDecl', binding::trans,
428 :     slotCount+1, true)
429 :     end
430 :    
431 :     | B.TYCbind tyc =>
432 :     let val epOp =
433 :     case tyc
434 :     of T.ERRORtyc => NONE
435 :     | _ => getEpOp(MU.tycId tyc)
436 :     val (ev, entEnv', entDecl') =
437 :     case epOp
438 :     of SOME [x] => (x, entEnv, entDecl)
439 :     | _ =>
440 :     (let val x = mkStamp()
441 :     val ee = EE.bind(x, TYCent tyc, entEnv)
442 :     val ed =
443 :     case context
444 :     of EU.INFCT _ =>
445 :     (let val tycExp =
446 :     case epOp
447 :     of SOME ep => M.VARtyc ep
448 :     | _ => M.CONSTtyc tyc
449 :     in (M.TYCdec(x, tycExp))::entDecl
450 :     end)
451 :     | _ => entDecl
452 :     in (x, ee, ed)
453 :     end)
454 :    
455 :     val spec = TYCspec{spec=T.ERRORtyc,entVar=ev,scope=0}
456 :     val elements' = addElems((sym, spec), elements)
457 :     (*
458 :     * Use of T.ERRORtyc here is a hack. It relies on the
459 :     * fact that the inferred signature would never be
460 :     * instantiated or signature-matched against. One might
461 :     * wonder what about a functor declaration with no result
462 :     * signature constraint ? the inferred fctSig would contain
463 :     * T.ERRORtyc --- fortunately the result-sig in this fctSig
464 :     * would never be matched against either. (ZHONG)
465 :     *)
466 :    
467 :     in (elements', entEnv', entDecl', trans, slotCount, fctflag)
468 :     end
469 :    
470 :     | _ => (elements, entEnv, entDecl, trans, slotCount, fctflag)
471 :    
472 :     val binders = SE.sort (Env.consolidate env)
473 :     val (elements, entEnv, entDecl, trans, _, fctflag) =
474 :     List.foldl transBind (nil, EE.empty, [], [], 0, false) binders
475 :    
476 :     in (rev elements, entEnv, rev entDecl, rev trans, fctflag)
477 :     end
478 :    
479 :    
480 :     (****************************************************************************
481 :     * *
482 :     * The constrStr function is used to carry out the signature matching *
483 :     * on structure declarations with signature constraints. The first argument *
484 :     * "transp" is a boolean flag; it is used to indicate whether the signature *
485 :     * matching should be done transparently (true) or opaquely (false). *
486 :     * *
487 :     ****************************************************************************)
488 :     fun constrStr(transp, sign, str, strDec, strExp, evOp, depth, entEnv, rpath,
489 :     env, region, compInfo) : A.dec * M.Structure * M.strExp =
490 :     let val {resDec=resDec1, resStr=resStr1, resExp=resExp1} =
491 :     SM.matchStr{sign=sign, str=str, strExp=strExp, evOp=evOp,
492 :     depth=depth, entEnv=entEnv, rpath=rpath, statenv=env,
493 :     region=region, compInfo=compInfo}
494 :    
495 :     in if transp then (A.SEQdec[strDec, resDec1], resStr1, resExp1)
496 :     else (let val {resDec=resDec2, resStr=resStr2, resExp=resExp2} =
497 :     SM.packStr{sign=sign, str=resStr1, strExp=resExp1,
498 :     depth=depth, entEnv=entEnv, rpath=rpath,
499 :     statenv=env, region=region, compInfo=compInfo}
500 :     in (A.SEQdec[strDec, resDec1, resDec2], resStr2, resExp2)
501 :     end)
502 :     end
503 :    
504 :    
505 :    
506 :     (*** elabStr: elaborate the raw structure, without signature constraint ***)
507 :     (*** several invariants:
508 :     Every structure expression strexp is now elaborated into a quadruple
509 :     (absdec, str, exp, ee) where absdec is the corresponding abstract
510 :     syntax tree, str is the resulting structure, exp is the entity
511 :     expressions, and ee is the delta entity environment collected while
512 :     elaborating the current structure expression. The deltaEntEnv is
513 :     designed to deal with LetStr and LetFct and to maintain the hidden
514 :     entity environment context.
515 :     *)
516 :     fun elabStr
517 :     (strexp: Ast.strexp,
518 :     name: S.symbol option,
519 :     env: SE.staticEnv,
520 :     entEnv: M.entityEnv,
521 :     context: EU.context,
522 :     epContext: EPC.context,
523 :     entsv: EP.entVar option,
524 :     rpath: IP.path,
525 :     region: SourceMap.region,
526 :     compInfo as {mkLvar=mkv, mkStamp, error, ...}: EU.compInfo)
527 :     : A.dec * M.Structure * M.strExp * EE.entityEnv =
528 :     let
529 :    
530 :     val sname = case name of SOME n => S.name n
531 :     | NONE => "<anonymous>"
532 :    
533 :     val depth = (case context of EU.INFCT{depth=d,...} => d
534 :     | _ => DI.top)
535 :    
536 :     val _ = debugmsg (">>elabStr: " ^ sname)
537 :    
538 :     (*
539 :     * elab: Ast.strexp * staticEnv * entityEnv * region
540 :     * -> A.dec * M.Structure * M.strExp * EE.entityEnv
541 :     *)
542 :     fun elab (BaseStr decl, env, entEnv, region) =
543 :     let val _ = debugmsg ">>elab[BaseStr]"
544 :    
545 :     (* we enter the epcontext when we get into BaseStr *)
546 :     val epContext'=EPC.enterOpen(epContext,entsv)
547 :     val (absDecl, entDecl, env', entEnv') =
548 :     elabDecl0(decl, env, entEnv, inStr context, true,
549 :     epContext', rpath, region, compInfo)
550 :     val _ = debugmsg "--elab[BaseStr]: elabDecl0 done"
551 :    
552 :     val (elements, entEnv'', entDecls, locations, fctflag) =
553 :     extractSig(env', epContext', context, compInfo)
554 :     val _ = debugmsg "--elab[BaseStr]: extractSig done"
555 :    
556 :     val (entEnvLocal, entDecLocal) =
557 :     case context
558 :     of EU.INFCT _ =>
559 :     (EE.mark(mkStamp,EE.atop(entEnv'',entEnv')),
560 :     seqEntDec(entDecl::entDecls))
561 :     | _ => (entEnv'', entDecl)
562 :    
563 :     val strExp = STRUCTURE{stamp=M.NEW, entDec=entDecLocal}
564 :    
565 :     val resStr =
566 :     let val symbols = map #1 elements
567 :     val sign =
568 :     M.SIG{name=NONE, closed=false, fctflag=fctflag,
569 :     stamp=mkStamp(), elements=elements,
570 :     symbols=symbols, boundeps=ref(NONE),
571 :     lambdaty=ref(NONE),
572 :     typsharing=nil, strsharing=nil}
573 :    
574 :     val strRlzn =
575 :     {stamp=mkStamp(), (* generate structure stamp *)
576 :     entities=EE.mark(mkStamp,EE.atop(entEnvLocal,entEnv)),
577 :     lambdaty=ref NONE, rpath=rpath}
578 :    
579 :     val dacc = DA.namedAcc(tempStrId, mkv)
580 :     val dinfo = II.mkStrInfo (map MU.extractInfo locations)
581 :    
582 :     in M.STR {sign=sign, rlzn=strRlzn, access=dacc, info=dinfo}
583 :     end
584 :    
585 :     val resDec =
586 :     let val body = A.LETstr(absDecl, A.STRstr(locations))
587 :     in A.STRdec [A.STRB {name=tempStrId, str=resStr, def=body}]
588 :     end
589 :    
590 :     val _ = debugmsg "<<elab[BaseStr]"
591 :    
592 :     in (resDec, resStr, strExp, EE.empty)
593 :     end
594 :    
595 :     | elab (AppStr(spath,args), env, entEnv, region) =
596 :     let val strexp' = LetStr(StrDec[Strb{name=returnId,constraint=NoSig,
597 :     def=AppStrI(spath,args)}],
598 :     VarStr([returnId,resultId]))
599 :     in elab(strexp', env, entEnv, region)
600 :     end
601 :    
602 :     | elab (AppStrI(spath,[(arg,b)]), env, entEnv, region) =
603 :     let val _ = debugmsg ">>elab[AppStr-one]"
604 :    
605 :     val fct = LU.lookFct(env, SP.SPATH spath, error region)
606 :    
607 :     val _ = debugmsg "--elab[AppStr-one]: functor lookup done"
608 :     val _ = showFct("--elab[AppStr]: functor ",fct,env)
609 :    
610 :     val entv = mkStamp() (* ev for the uncoerced argument *)
611 :     val (argDec, argStr, argExp, argDee) =
612 :     elabStr(arg, NONE, env, entEnv, context, epContext,
613 :     SOME entv, IP.IPATH[], region, compInfo)
614 :    
615 :     val _ = debugmsg "--elab[AppStr-one]: elab arg done"
616 :     val _ = showStr("--elab[AppStr-one]: arg str: ",argStr,env)
617 :    
618 :     in case (fct,argStr)
619 :     of ((M.ERRORfct,_) | (_,M.ERRORstr)) =>
620 :     (debugmsg "<<elab[AppStr-one]: error fct or arg";
621 :     (A.SEQdec[], M.ERRORstr, M.CONSTstr(M.bogusStrEntity), EE.empty))
622 :     | (M.FCT{rlzn=fctEnt,...},M.STR{rlzn=argEnt,...}) =>
623 :     let val resDee =
624 :     EE.mark(mkStamp, EE.bind(entv, M.STRent argEnt, argDee))
625 :     (* the argument structure should be bound to entv *)
626 :     val fctExp =
627 :     case EPC.lookPath(epContext, MU.fctId fct)
628 :     of SOME ep => VARfct ep
629 :     | NONE => CONSTfct fctEnt
630 :     val {resDec, resStr, resExp} =
631 :     SM.applyFct{fct=fct, fctExp=fctExp, argStr=argStr,
632 :     argExp=argExp, evOp = SOME entv, depth=depth,
633 :     epc=EPC.enterOpen(epContext,entsv),
634 :     statenv=env, rpath=rpath, region=region,
635 :     compInfo=compInfo}
636 :     val _ = debugmsg "--elab[AppStr-one]: applyFct done"
637 :     val _ = showStr("--elab[AppStr-one]: result: ",resStr,env)
638 :     val _ = debugmsg "<<elab[AppStr-one]"
639 :     in (A.SEQdec [argDec, resDec], resStr, resExp, resDee)
640 :     end
641 :     end (* AppStrI - one arg *)
642 :    
643 :     | elab (AppStrI(spath,arg :: larg), env, entEnv, region) =
644 :     let val _ = debugmsg ">>elab:[AppStr-many]"
645 :     val strexp' = LetStr(StrDec[Strb{name=hiddenId,constraint=NoSig,
646 :     def=AppStrI(spath,[arg])}],
647 :     AppStrI([hiddenId,functorId],larg))
648 :     in elab(strexp', env, entEnv, region)
649 :     end (* AppStrI - multiple args *)
650 :    
651 :     | elab (AppStrI(spath,[]), env, entEnv, region) =
652 :     bug "elabStr.AppStrI -- empty arg list"
653 :    
654 :     | elab (VarStr path, env, entEnv, region) =
655 :     let val _ = debugmsg ">>elab[VarStr]"
656 :     val str = LU.lookStr(env,SP.SPATH path,error region)
657 :     (*
658 :     val _ = showStr("--elab[VarStr]: str: ",str,env)
659 :     *)
660 :     val strRlzn =
661 :     case str
662 :     of STR{rlzn,...} => rlzn
663 :     | _ => M.bogusStrEntity (* error recovery *)
664 :     val resExp =
665 :     case str
666 :     of STR _ =>
667 :     ((* debugmsg "--elab[VarStr]: resExp/STR"; *)
668 :     case EPC.lookPath(epContext,MU.strId str)
669 :     of NONE => M.CONSTstr strRlzn
670 :     | SOME ep => M.VARstr ep)
671 :     | _ => M.CONSTstr M.bogusStrEntity (* error recovery *)
672 :    
673 :     in (* debugmsg "<<elab[VarStr]"; *)
674 :     (A.SEQdec [], str, resExp, EE.empty)
675 :     end
676 :    
677 :     | elab (LetStr(decl,str), env, entEnv, region) =
678 :     let val _ = debugmsg ">>elab[LetStr]"
679 :     val (localAbsDec, localEntDecl, env', entEnv') =
680 :     elabDecl0(decl, env, entEnv, context, true,
681 :     epContext, rpath, region, compInfo)
682 :     (* top = true: don't allow nongeneralized type variables
683 :     * in local decls because of bug 905/952. This is
684 :     * stricter than necessary. Could allow top = false
685 :     * if the body str contains no functors. To make the
686 :     * condition more precise, have to synthesize a boolean
687 :     * attribute indicating presence of functors [dbm] *)
688 :     (*
689 :     * DAVE? what context to use for the local decls?
690 :     * perhaps should null bindContext as for functor body?
691 :     * perhaps it doesn't matter because of relativization
692 :     * and the fact that local entities can't be referred
693 :     * to from outside.
694 :     *)
695 :     val _ = debugmsg "--elab[LetStr]: local elabDecl0 done"
696 :     val (bodyAbsDec, bodyStr, bodyExp, bodyDee) =
697 :     elab(str, SE.atop(env',env), EE.atop(entEnv',entEnv), region)
698 :    
699 :     val resDec = A.SEQdec [localAbsDec, bodyAbsDec]
700 :     val resExp = M.LETstr (localEntDecl, bodyExp)
701 :     val _ = debugmsg "<<elab[LetStr]: elab body str done"
702 :    
703 :     in (resDec, bodyStr, resExp, EE.mark(mkStamp,EE.atopSp(bodyDee,entEnv')))
704 :     end
705 :    
706 :     | elab (ConstrainedStr(strexp,constraint), env, entEnv, region) =
707 :     let val (entsv, evOp, csigOp, transp) =
708 :     let fun h x =
709 :     ES.elabSig {sigexp=x, nameOp=NONE, env=env,
710 :     entEnv=entEnv, epContext=epContext,
711 :     region=region, compInfo=compInfo}
712 :    
713 :     val (csigOp, transp) =
714 :     (case constraint
715 :     of Transparent x => (SOME (h x), true)
716 :     | Opaque x => (SOME (h x), false)
717 :     | _ => (NONE, true))
718 :    
719 :     val (entsv, evOp) =
720 :     case constraint
721 :     of NoSig => (entsv, NONE)
722 :     | _ => let val nentv = SOME(mkStamp())
723 :     in (nentv, nentv)
724 :     end
725 :     in (entsv, evOp, csigOp, transp)
726 :     end
727 :    
728 :     (** elaborating the structure body *)
729 :     val (strAbsDec, str, exp, deltaEntEnv) =
730 :     elabStr(strexp, NONE, env, entEnv, context,
731 :     epContext, entsv, rpath, region, compInfo)
732 :    
733 :     val resDee =
734 :     case constraint
735 :     of NoSig => deltaEntEnv
736 :     | _ =>
737 :     (case evOp
738 :     of SOME tmpev =>
739 :     let val strEnt =
740 :     case str of M.STR{rlzn,...} => rlzn
741 :     | _ => M.bogusStrEntity
742 :     in (EE.bind(tmpev, M.STRent strEnt, deltaEntEnv))
743 :     end
744 :     | _ => bug "unexpected while elaborating constrained str")
745 :    
746 :     (** elaborating the signature matching *)
747 :     val (resDec, resStr, resExp) =
748 :     case csigOp
749 :     of NONE =>
750 :     (if transp then ()
751 :     else (error region EM.COMPLAIN
752 :     "missing signature in abstraction declaration"
753 :     EM.nullErrorBody);
754 :     (strAbsDec, str, exp))
755 :     | SOME csig =>
756 :     constrStr(transp, csig, str, strAbsDec, exp,
757 :     evOp, depth, entEnv, rpath,
758 :     env, region, compInfo)
759 :    
760 :     in (resDec, resStr, resExp, resDee)
761 :     end
762 :    
763 :     | elab (MarkStr(strexp',region'),env,entEnv,region) =
764 :     let val (resDec, str, resExp, resDee) =
765 :     elab(strexp', env, entEnv, region')
766 :     in (A.MARKdec(resDec, region'), str, resExp, resDee)
767 :     end
768 :    
769 :     val (resDec, resStr, resExp, resDee) = elab(strexp, env, entEnv, region)
770 :     val _ = debugmsg "<<elabStr"
771 :    
772 :     in (resDec, resStr, resExp, resDee)
773 :     end (* end of function elabStr *)
774 :    
775 :    
776 :     (*** elabFct: elaborate the functor, possibly with signature constraint ***)
777 :     and elabFct
778 :     (fctexp: Ast.fctexp,
779 :     curried : bool,
780 :     name: S.symbol,
781 :     env: SE.staticEnv,
782 :     entEnv: M.entityEnv,
783 :     context: EU.context,
784 :     epContext: EPC.context,
785 :     rpath: IP.path,
786 :     region: SourceMap.region,
787 :     compInfo as {mkLvar=mkv, mkStamp, error, ...}: EU.compInfo)
788 :     : A.dec * M.Functor * M.fctExp * EE.entityEnv =
789 :    
790 :     let
791 :    
792 :     val depth = (case context of EU.INFCT{depth=d,...} => d
793 :     | _ => DI.top)
794 :     val _ = debugmsg (">>elabFct: " ^ (S.name name))
795 :    
796 :     in
797 :    
798 :     case fctexp
799 :     of VarFct(spath,constraintExpOp) =>
800 :     let val fct = LU.lookFct(env,SP.SPATH spath,error region)
801 :     in case fct
802 :     of ERRORfct =>
803 :     (A.SEQdec [], fct, CONSTfct(M.bogusFctEntity), EE.empty)
804 :     | _ =>
805 :     let val uncoercedExp =
806 :     (case EPC.lookPath(epContext, MU.fctId fct)
807 :     of SOME ep => VARfct ep
808 :     | NONE =>
809 :     let val rlzn = case fct
810 :     of FCT{rlzn, ...} => rlzn
811 :     | _ => M.bogusFctEntity
812 :     in CONSTfct rlzn
813 :     end)
814 :    
815 :     in case constraintExpOp
816 :     of NoSig => (A.SEQdec [], fct, uncoercedExp, EE.empty)
817 :     | Transparent astFsig =>
818 :     let val nameOp = SOME(anonfsigId)
819 :     val fsig =
820 :     ES.elabFctSig
821 :     {fsigexp=astFsig, nameOp=nameOp, env=env,
822 :     entEnv=entEnv, epContext=epContext,
823 :     region=region, compInfo=compInfo}
824 :    
825 :     val {resDec, resFct, resExp} =
826 :     SM.matchFct
827 :     {sign=fsig, fct=fct, fctExp=uncoercedExp,
828 :     depth=depth, entEnv=entEnv,
829 :     rpath=rpath, statenv=env, region=region,
830 :     compInfo=compInfo}
831 :     in (resDec, resFct, resExp, EE.empty)
832 :     end
833 :     | Opaque astFsig =>
834 :     bug "Opaque functor constraint not impl"
835 :     end
836 :     end
837 :    
838 :     | LetFct(decl,fct) =>
839 :     let val _ = debugmsg ">>elab[LetFct]"
840 :     val (localAbsDec, localEntDecl, env', entEnv') =
841 :     elabDecl0(decl, env, entEnv, context, true,
842 :     epContext, rpath, region, compInfo)
843 :     (* top = true: don't allow nongeneralized type variables
844 :     in local decls because of bug 905/952 [dbm] *)
845 :     val _ = debugmsg "--elab[LetFct]: local elabDecl0 done"
846 :     val (bodyAbsDec, bodyFct, bodyExp, bodyDee) =
847 :     elabFct(fct, false, name, SE.atop(env',env), EE.atop(entEnv',entEnv),
848 :     context, epContext, rpath, region, compInfo)
849 :    
850 :     val resAbsyn = A.SEQdec [localAbsDec, bodyAbsDec]
851 :     val resExp = M.LETfct(localEntDecl, bodyExp)
852 :     val resDee = EE.mark(mkStamp, EE.atopSp(bodyDee, entEnv'))
853 :    
854 :     in (resAbsyn, bodyFct, resExp, resDee)
855 :     end
856 :    
857 :     | AppFct(spath,larg,constraint) =>
858 :     let val fctexp' = LetFct(StrDec[Strb{name=hiddenId,constraint=NoSig,
859 :     def=AppStrI(spath,larg)}],
860 :     VarFct([hiddenId,functorId],constraint))
861 :    
862 :     in elabFct(fctexp', false, name, env, entEnv, context, epContext,
863 :     rpath, region, compInfo)
864 :     end
865 :    
866 :     | BaseFct{params=[(paramNameOp,paramSigExp)],body,constraint} =>
867 :     let val _ = debugmsg ">>elabFct[BaseFct]"
868 :     val body = if curried then body
869 :     else BaseStr(StrDec[Strb{name=resultId, def=body,
870 :     constraint=constraint}])
871 :     val constraint = if curried then constraint else NoSig
872 :     val (flex, depth) =
873 :     case context
874 :     of EU.INFCT {flex=f,depth=d} => (f, d)
875 :     | _ => (*** Entering functor for first time ***)
876 :     let val base = mkStamp()
877 :     fun h s = (case Stamps.cmp(base,s)
878 :     of LESS => true
879 :     | _ => false)
880 :     in (h, DI.top)
881 :     end
882 :     val paramName = case paramNameOp of NONE => paramId
883 :     | SOME n => n
884 :    
885 :     val paramEntVar = mkStamp()
886 :    
887 :     val _ = debugmsg (">>elabFct[BaseFct]: paramEntVar = "^
888 :     EP.entVarToString paramEntVar)
889 :    
890 :     val paramSig =
891 :     ES.elabSig {sigexp=paramSigExp, nameOp=NONE, env=env,
892 :     entEnv=entEnv, epContext=epContext,
893 :     region=region, compInfo=compInfo}
894 :     val _ = debugmsg "--elabFct[BaseFct]: paramSig defined"
895 :    
896 :     val _ = case paramSig
897 :     of ERRORsig => raise EM.Error
898 :     (* bail out -- not attempting to recover *)
899 :     | _ => ()
900 :    
901 :     (* now know that paramSig is defined *)
902 :     (* this creates new stamps, but we don't bother to update the
903 :     epcontext, we do it later through mapPaths *)
904 :     val {rlzn=paramRlzn, tycpaths=paramTps} =
905 :     INS.instParam
906 :     {sign=paramSig, entEnv=entEnv, region=region,
907 :     depth=depth, rpath=IP.IPATH(case paramNameOp
908 :     of NONE => []
909 :     | _ => [paramName]),
910 :     compInfo=compInfo}
911 :     val paramStr =
912 :     let val paramDacc = DA.namedAcc(paramName, mkv)
913 :     in M.STR{sign=paramSig, rlzn=paramRlzn,
914 :     access=paramDacc, info=II.nullInfo}
915 :     end
916 :    
917 :     val _ = debugmsg "--elabFct[BaseFct]: param instantiated"
918 :     val _ = showStr("--elabFct[BaseFct]: paramStr: ",paramStr,env)
919 :    
920 :     val entEnv' =
921 :     EE.mark(mkStamp,EE.bind(paramEntVar,M.STRent paramRlzn,entEnv))
922 :     val _ = debugmsg "--elabFct[BaseFct]: param EE.bind"
923 :    
924 :     val env' =
925 :     case paramNameOp
926 :     of NONE => MU.openStructure(env,paramStr)
927 :     | SOME _ => SE.bind(paramName, B.STRbind paramStr, env)
928 :     val _ = debugmsg "--elabFct[BaseFct]: param bound/opened"
929 :    
930 :     val epContext' = EPC.enterClosed epContext
931 :    
932 :     (* fill in pathEnv with paths for elements of paramStr *)
933 :     val _ = mapPaths(EPC.enterOpen(epContext', SOME paramEntVar),paramStr,flex)
934 :     val _ = EPC.bindPath(epContext',MU.strId paramStr,paramEntVar)
935 :     val _ = debugmsg "--elabFct[BaseFct]: epContext initialized"
936 :    
937 :     (* must elaborate result signature before the body is elaborated
938 :     so that epContext' is not changed *)
939 :     val (entsv, csigOp,csigTrans) =
940 :     let fun h x = ES.elabSig{sigexp=x, nameOp=NONE, env=env',
941 :     entEnv=entEnv', epContext=epContext',
942 :     region=region, compInfo=compInfo}
943 :     in case constraint
944 :     of NoSig => (NONE, NONE, true)
945 :     | Transparent x => (SOME (mkStamp()), SOME (h x), true)
946 :     | Opaque x => (SOME(mkStamp()), SOME (h x), false)
947 :     end
948 :    
949 :     val _ = debugmsg "--elabFct[BaseFct]: result signature elaborated"
950 :    
951 :     (* adjust the EU.context value; the depth refers to the number
952 :     of enclosing functor abstractions. (ZHONG) *)
953 :     val depth' = DI.next depth
954 :     val context' = EU.INFCT{flex=flex, depth=depth'}
955 :    
956 :     (* bodyDee was discarded here; however, it was not discarded when
957 :     functor is applied. *)
958 :     val (bodyAbsDec, bodyStr, bodyExp, bodyDee) =
959 :     elabStr(body, NONE, env', entEnv', context', epContext', entsv,
960 :     IP.IPATH [], region, compInfo)
961 :     val _ = debugmsg "--elabFct[BaseFct]: body elaborated"
962 :     val _ = showStr("--elabFct[BaseFct]: bodyStr: ",bodyStr,env)
963 :    
964 :     (* constrain by result signature, either transparent or opaque *)
965 :     val (bodyAbsDec', bodyStr', bodyExp') =
966 :     case csigOp
967 :     of NONE => (bodyAbsDec, bodyStr, bodyExp)
968 :     | SOME csig =>
969 :     constrStr(csigTrans, csig, bodyStr, bodyAbsDec, bodyExp,
970 :     entsv, depth', entEnv', IP.IPATH[], env',
971 :     region, compInfo)
972 :    
973 :     val _ = debugmsg "--elabFct[BaseFct]: body constrained"
974 :    
975 :     val fctExp = M.LAMBDA{param=paramEntVar,body=bodyExp'}
976 :    
977 :     val resFct =
978 :     let val bodySig' = case bodyStr' of STR{sign, ...} => sign
979 :     | _ => ERRORsig
980 :    
981 :     val fctSig =
982 :     M.FSIG{kind=NONE, paramsig=paramSig,
983 :     bodysig=bodySig', paramvar=paramEntVar,
984 :     paramsym=paramNameOp}
985 :    
986 :     val rlzn = {stamp=mkStamp(),
987 :     closure=M.CLOSURE{param=paramEntVar,
988 :     body=bodyExp',
989 :     env=entEnv},
990 :     (* Closure: Using the old entity environment !! *)
991 :     tycpath=NONE, lambdaty=ref NONE, rpath=rpath}
992 :    
993 :     val dacc = DA.namedAcc(name, mkv)
994 :    
995 :     in M.FCT{sign=fctSig, rlzn=rlzn, access=dacc, info=II.nullInfo}
996 :     end
997 :    
998 :     val _ = debugmsg "--elabFct[BaseFct]: resFct defined"
999 :    
1000 :     val resDec =
1001 :     let val x = A.FCTfct{param=paramStr, argtycs=paramTps,
1002 :     def=A.LETstr(bodyAbsDec',A.VARstr bodyStr')}
1003 :     in A.FCTdec [A.FCTB {name=name, fct=resFct, def=x}]
1004 :     end
1005 :    
1006 :     val _ = debugmsg "<<elabFct[BaseFct]"
1007 :     val _ = showStr("--elabFct[BaseFct]: paramStr: ",paramStr,env)
1008 :    
1009 :     in (resDec, resFct, fctExp, EE.empty)
1010 :     end
1011 :    
1012 :     | BaseFct{params=param :: lparam,body,constraint} =>
1013 :     let val fctexp' =
1014 :     BaseFct{params=[param],
1015 :     body=BaseStr(
1016 :     FctDec[Fctb{name=functorId,
1017 :     def=BaseFct{params=lparam, body=body,
1018 :     constraint=constraint}}]),
1019 :     constraint=NoSig}
1020 :    
1021 :     in elabFct(fctexp', true, name, env, entEnv, context, epContext,
1022 :     rpath, region, compInfo)
1023 :     end
1024 :    
1025 :     | BaseFct{params=[],...} => bug "elabFct"
1026 :    
1027 :     | MarkFct(fctexp',region') =>
1028 :     elabFct(fctexp', curried, name, env, entEnv, context, epContext,
1029 :     rpath, region', compInfo)
1030 :    
1031 :     end (* end of function elabFct *)
1032 :    
1033 :    
1034 :     (*** elabStrbs: elaborate structure bindings, with signature constraint ***)
1035 :     and elabStrbs(strbs: Ast.strb list,
1036 :     transp: bool,
1037 :     env0: SE.staticEnv,
1038 :     entEnv0: M.entityEnv,
1039 :     context: EU.context,
1040 :     epContext: EPC.context,
1041 :     rpath: IP.path,
1042 :     region: SourceMap.region,
1043 :     compInfo as {mkStamp,mkLvar=mkv,error,...}: EU.compInfo)
1044 :     : A.dec * M.entityDec * SE.staticEnv * entityEnv =
1045 :     let
1046 :    
1047 :     val depth = (case context of EU.INFCT{depth=d, ...} => d
1048 :     | _ => DI.top)
1049 :     val _ = debugmsg ">>elabStrbs"
1050 :    
1051 :     fun loop([], decls, entDecls, env, entEnv) =
1052 :     let val _ = debugmsg "<<elabStrbs"
1053 :     val resDec =
1054 :     let val decls' = rev decls
1055 :     in if transp then A.STRdec decls' else A.ABSdec decls'
1056 :     end
1057 :    
1058 :     val entDec = case entDecls of [] => M.EMPTYdec
1059 :     | _ => seqEntDec(rev entDecls)
1060 :     in (resDec, entDec, env, entEnv)
1061 :     end
1062 :    
1063 :     | loop(strb::rest, decls, entDecls, env, entEnv) =
1064 :     let val _ = debugmsg ">>elabStrbs"
1065 :     val (name, constraint, def, region') =
1066 :     case stripMarkStrb(strb,region)
1067 :     of (Strb{name=n,constraint=c,def=d},r) => (n, c, d, r)
1068 :     | _ => bug "non structure bindings in elabStrbs"
1069 :     val _ = debugmsg("--elabStrbs: structure "^S.name name)
1070 :    
1071 :     (* make up an entity variable for the current str declaration *)
1072 :     val entv = mkStamp() (* we don't always have to do this *)
1073 :    
1074 :     (* entsv is the context for evaluating the right-handside
1075 :     of a structure declaration *)
1076 :     val (entsv, evOp, csigOp, transp) =
1077 :     let fun h x =
1078 :     let val csig =
1079 :     ES.elabSig {sigexp=x, nameOp=NONE, env=env0,
1080 :     entEnv=entEnv0, epContext=epContext,
1081 :     region=region, compInfo=compInfo}
1082 :     in case csig
1083 :     of ERRORsig => NONE (* if constraint doesn't elaborate
1084 :     * pretend it didn't exist *)
1085 :     | _ => SOME csig
1086 :     end
1087 :     val (csigOp, transp) =
1088 :     (case constraint
1089 :     of Transparent x => (h x, transp)
1090 :     | Opaque x =>
1091 :     (case h x
1092 :     of NONE => (NONE, transp)
1093 :     | y => (y, false))
1094 :     | _ => (NONE, transp))
1095 :    
1096 :     (* the temporary anonymous structure *)
1097 :     val (entsv, evOp) =
1098 :     case csigOp
1099 :     of NONE => (entv, NONE)
1100 :     | _ => (let val nentv = mkStamp()
1101 :     in (nentv, SOME nentv)
1102 :     end)
1103 :     in (entsv, evOp, csigOp, transp)
1104 :     end
1105 :    
1106 :     (** elaborating the structure body *)
1107 :     val (strAbsDec, str, exp, deltaEntEnv) =
1108 :     elabStr(def, SOME name, env0, entEnv0, context, epContext,
1109 :     SOME entsv, IP.extend(rpath,name), region', compInfo)
1110 :    
1111 :     (** check for partially applied curried functor *)
1112 :     val str = if S.eq(name,returnId) then
1113 :     (* str should be functor application wrapper structure
1114 :     * with single structure component "resultStr" *)
1115 :     if (case str
1116 :     of ERRORstr => true
1117 :     | _ => (case MU.getStrSymbols str
1118 :     of [sym] => S.eq(sym,resultId)
1119 :     | _ => false))
1120 :     then str
1121 :     else (error region' EM.COMPLAIN
1122 :     ("structure " ^ S.name(IP.last rpath) ^
1123 :     " defined by partially applied functor")
1124 :     EM.nullErrorBody;
1125 :     ERRORstr)
1126 :     else str
1127 :    
1128 :     val _ = debugmsg "--elabStrbs: elabStr done"
1129 :     (*
1130 :     val _ = showStr("unconstrained structure: ",str,env)
1131 :     *)
1132 :     (** elaborating the signature matching: notice that we did
1133 :     introduce stamps during the abstraction matching, but
1134 :     these stamps are always visible, thus will always be
1135 :     caught by the post sig-matching "mapPaths" function call. *)
1136 :     val (resDec, resStr, resExp) =
1137 :     case csigOp
1138 :     of NONE =>
1139 :     (if transp then ()
1140 :     else (error region' EM.COMPLAIN
1141 :     "missing signature in abstraction declaration"
1142 :     EM.nullErrorBody);
1143 :     (strAbsDec, str, exp))
1144 :     | SOME csig =>
1145 :     constrStr(transp, csig, str, strAbsDec, exp,
1146 :     evOp, depth, entEnv0, IP.IPATH[name],
1147 :     StaticEnv.atop(env,env0), region, compInfo)
1148 :    
1149 :     val deltaEntEnv =
1150 :     case (evOp, csigOp)
1151 :     of (NONE, NONE) => deltaEntEnv
1152 :     | (SOME ev, SOME _) =>
1153 :     (case str
1154 :     of M.STR{rlzn,...} =>
1155 :     EE.bind(ev, M.STRent rlzn, deltaEntEnv)
1156 :     | _ =>
1157 :     EE.bind(ev, M.STRent M.bogusStrEntity, deltaEntEnv))
1158 :     | _ => bug "unexpected case in elabStrbs: deltaEntEnv"
1159 :    
1160 :     val _ = debugmsg "--elabStrbs: constrain done"
1161 :    
1162 :     val _ = showStr("--elabStrbs: resStr: ",resStr,env)
1163 :     (*
1164 :     * WARNING: bindStr modifies the access field of resStr; this
1165 :     * may create structures with same modIds but different dynamic
1166 :     * accesses --- BUT, we assume that before or during the pickling,
1167 :     * both the dynamic access and the inl_info will be updated
1168 :     * completely and replaced with proper persistent accesses (ZHONG)
1169 :     *)
1170 :     val (bindStr, strEnt) =
1171 :     case resStr
1172 :     of STR{rlzn, sign, access, info} =>
1173 :     (STR{rlzn = rlzn, sign = sign,
1174 :     access = DA.namedAcc(name, mkv),info = info},
1175 :     M.STRent rlzn)
1176 :     | _ => (resStr, M.STRent M.bogusStrEntity)
1177 :    
1178 :     val _ = showStr("--elabStrbs: bindStr: ",bindStr,env)
1179 :    
1180 :     val sb = A.STRB{name = name, str = bindStr,
1181 :     def = A.LETstr(resDec, A.VARstr resStr)}
1182 :     val decls' = sb :: decls
1183 :    
1184 :     val (entEnv', entDecls') =
1185 :     case context
1186 :     of EU.INFCT {flex,...} =>
1187 :     (let val entEnv1 = EE.atopSp(deltaEntEnv, entEnv)
1188 :     val entEnv2 = EE.bind(entv, strEnt, entEnv1)
1189 :     val entEnv3 = EE.mark(mkStamp, entEnv2)
1190 :    
1191 :     val _ = debugmsg "--elabStrbs: about to mapPaths bindStr"
1192 :     (*
1193 :     * We are remapping entPaths for elements of
1194 :     * the new structure unconditionally, even if
1195 :     * there is no signature constraint and the
1196 :     * defining strexp is BaseStr (DAVE).
1197 :     *)
1198 :     val _ = mapPaths(EPC.enterOpen(epContext, SOME entv),
1199 :     bindStr, flex)
1200 :     val _ = debugmsg "--elabStrbs: mapPaths bindStr done"
1201 :     val _ =
1202 :     (case bindStr
1203 :     of STR{rlzn, sign, ...} =>
1204 :     EPC.bindPath(epContext,
1205 :     MU.strId2(sign,rlzn), entv)
1206 :     | _ => ())
1207 :    
1208 :     in (entEnv3, ((M.STRdec(entv, resExp, name))::entDecls))
1209 :     end)
1210 :     | _ => (entEnv, entDecls)
1211 :    
1212 :     val _ = showStr("--elabStrbs: bindStr: ",bindStr,env)
1213 :    
1214 :     val env' = SE.bind(name, B.STRbind bindStr, env)
1215 :    
1216 :     in loop(rest, decls', entDecls', env', entEnv')
1217 :     end
1218 :    
1219 :     in loop(strbs, [], [], SE.empty, EE.empty)
1220 :     handle EE.Unbound =>
1221 :     (debugmsg("$elabStrbs0: " ^ (if transp then "StrDec" else "AbsDec"));
1222 :     raise EE.Unbound)
1223 :    
1224 :     end (* end of function elabStrbs *)
1225 :    
1226 :    
1227 :     (*** elabDecl0: elaborate an arbitrary module-level declarations ***)
1228 :     and elabDecl0
1229 :     (decl: Ast.dec,
1230 :     env0: SE.staticEnv,
1231 :     entEnv0: M.entityEnv,
1232 :     context: EU.context,
1233 :     top: bool,
1234 :     epContext: EPC.context,
1235 :     rpath: IP.path,
1236 :     region: SourceMap.region,
1237 :     compInfo as {mkStamp,mkLvar=mkv,error,transform,...}: EU.compInfo)
1238 :     : A.dec * entityDec * SE.staticEnv * entityEnv =
1239 :    
1240 :     (case decl
1241 :     of StrDec strbs =>
1242 :     elabStrbs(strbs, true, env0, entEnv0, context, epContext,
1243 :     rpath, region, compInfo)
1244 :    
1245 :     | AbsDec strbs =>
1246 :     elabStrbs(strbs, false, env0, entEnv0, context, epContext,
1247 :     rpath, region, compInfo)
1248 :    
1249 :     | OpenDec paths =>
1250 :     let val err = error region
1251 :     val strs = map (fn s => let val sp = SP.SPATH s
1252 :     in (sp, LU.lookStr(env0, sp, err))
1253 :     end) paths
1254 :    
1255 :     fun loop([], env) = (A.OPENdec strs, M.EMPTYdec, env, EE.empty)
1256 :     | loop((_, s)::r, env) = loop(r, MU.openStructure(env, s))
1257 :    
1258 :     in loop(strs, SE.empty)
1259 :     end
1260 :    
1261 :     | FctDec fctbs =>
1262 :     let val _ = debugmsg ">>elabFctbs"
1263 :    
1264 :     fun loop([], decls, entDecls, env, entEnv) =
1265 :     let val resDec = A.FCTdec (rev decls)
1266 :     val entDec = case entDecls of [] => M.EMPTYdec
1267 :     | _ => seqEntDec(rev entDecls)
1268 :     val _ = debugmsg "<<elabFctbs"
1269 :     in (resDec, entDec, env, entEnv)
1270 :     end
1271 :    
1272 :     | loop(fctb::rest, decls, entDecls, env, entEnv) =
1273 :     let val (name, def, region') =
1274 :     case stripMarkFctb(fctb,region)
1275 :     of (Fctb{name=n, def=d}, r) => (n, d, r)
1276 :     | _ => bug "non functor bindings for FctDec fctbs"
1277 :     val _ = debugmsg("--elabDecl0: functor "^S.name name)
1278 :    
1279 :     (* dynamic access is already assigned in elabFct *)
1280 :     val (fctAbsDec, fct, fctExp, deltaEntEnv) =
1281 :     elabFct(def, false, name, env0, entEnv0, context,
1282 :     epContext, rpath, region', compInfo)
1283 :    
1284 :     (*
1285 :     * WARNING: bindFct modifies the access field of fct;
1286 :     * this may create functors with same modIds but
1287 :     * different dynamic accesses --- BUT, we assume that
1288 :     * before or during the pickling, both the dynamic
1289 :     * access and the inl_info will be updated completely
1290 :     * and replaced with proper persistent accesses (ZHONG)
1291 :     *)
1292 :     val (bindFct, fctEnt) =
1293 :     case fct
1294 :     of FCT{rlzn, sign, access, info} =>
1295 :     (FCT{rlzn = rlzn, sign = sign, info = info,
1296 :     access = DA.namedAcc(name, mkv)},
1297 :     FCTent rlzn)
1298 :     | ERRORfct => (fct, ERRORent)
1299 :    
1300 :     val fb = A.FCTB{name = name, fct = bindFct,
1301 :     def = A.LETfct(fctAbsDec,A.VARfct fct)}
1302 :     val decls' = fb :: decls
1303 :    
1304 :     val (entEnv', entDecls') =
1305 :     case context
1306 :     of EU.INFCT _ =>
1307 :     (let val entVar = mkStamp()
1308 :     val _ = case bindFct
1309 :     of FCT _ =>
1310 :     EPC.bindPath(epContext,
1311 :     MU.fctId bindFct, entVar)
1312 :     | ERRORfct => ()
1313 :     val entEnv1 = EE.atopSp(deltaEntEnv, entEnv)
1314 :     val entEnv2 = EE.bind(entVar, fctEnt, entEnv1)
1315 :     val entEnv3 = EE.mark(mkStamp, entEnv2)
1316 :     in (entEnv3, M.FCTdec(entVar,fctExp)::entDecls)
1317 :     end)
1318 :     | _ => (entEnv, entDecls)
1319 :    
1320 :     val env' = SE.bind(name, B.FCTbind bindFct, env)
1321 :    
1322 :     in loop(rest, decls', entDecls', env', entEnv')
1323 :     end
1324 :    
1325 :     in loop(fctbs, nil, nil, SE.empty, EE.empty)
1326 :     handle EE.Unbound => (debugmsg("$elabDecl0: FctDec");
1327 :     raise EE.Unbound)
1328 :     end
1329 :    
1330 :     | SigDec sigbs =>
1331 :     let val _ = debugmsg ">>elabSigbs"
1332 :    
1333 :     fun loop([], sigs, env) =
1334 :     let val _ = debugmsg "<<elabSigbs"
1335 :     in (A.SIGdec (rev sigs), M.EMPTYdec, env, EE.empty)
1336 :     end
1337 :    
1338 :     | loop (sigb::rest, sigs, env) =
1339 :     let val (name, def, region') =
1340 :     case stripMarkSigb(sigb,region)
1341 :     of (Sigb{name=n,def=d},r) => (n, d, r)
1342 :     | _ => bug "non signature bindings for SigDec sigbs"
1343 :     val _ = debugmsg("--elabDecl0: signature "^S.name name)
1344 :    
1345 :     val s =
1346 :     ES.elabSig {sigexp=def, nameOp=SOME name, env=env0,
1347 :     entEnv=entEnv0, epContext=epContext,
1348 :     region=region', compInfo=compInfo}
1349 :     val _ = (* instantiate to check well-formedness *)
1350 :     if !Control.instantiateSigs
1351 :     then (INS.instParam
1352 :     {sign=s,entEnv=EE.empty,depth=DI.top,
1353 :     rpath=InvPath.empty,region=region',
1354 :     compInfo=compInfo};
1355 :     ())
1356 :     else ()
1357 :     in loop(rest, s::sigs, SE.bind(name, B.SIGbind s, env))
1358 :     end
1359 :    
1360 :     in loop(sigbs, nil, SE.empty)
1361 :     handle EE.Unbound => (debugmsg("$elabDecl0: SigDec");
1362 :     raise EE.Unbound)
1363 :     end
1364 :    
1365 :     | FsigDec fsigbs =>
1366 :     let val _ = debugmsg ">>elabFSigbs"
1367 :    
1368 :     fun loop([], fsigs, env) =
1369 :     let val _ = debugmsg "<<elabFSigbs"
1370 :     in (A.FSIGdec(rev fsigs), M.EMPTYdec, env, EE.empty)
1371 :     end
1372 :    
1373 :     | loop (fsigb::rest, fsigs, env) =
1374 :     let val (name, def, region') =
1375 :     case stripMarkFsigb(fsigb,region)
1376 :     of (Fsigb{name=n,def=d},r) => (n, d, r)
1377 :     | _ => bug "non fctSig bindings for FsigDec fsigbs"
1378 :     val _ = debugmsg("--elabDecl0: fctsig "^S.name name)
1379 :    
1380 :     val s =
1381 :     ES.elabFctSig {fsigexp=def, nameOp=SOME name, env=env0,
1382 :     entEnv=entEnv0, epContext=epContext,
1383 :     region=region', compInfo=compInfo}
1384 :     in loop(rest, s::fsigs, SE.bind(name, B.FSGbind s, env))
1385 :     end
1386 :    
1387 :     in loop(fsigbs, nil, SE.empty)
1388 :     handle EE.Unbound => (debugmsg("$elabDecl0: FsigDec");
1389 :     raise EE.Unbound)
1390 :     end
1391 :    
1392 :     | LocalDec(decl_in,decl_out) =>
1393 :     let val top_in = EU.hasModules decl_in orelse EU.hasModules decl_out
1394 :     (* if decl_in contains a functor declaration (at
1395 :     * any nesting depth, have to suppress ungeneralized
1396 :     * type variables to avoid bug 905/952. Using
1397 :     * EU.hasModules is a cheap conservative approximation to
1398 :     * checking for the presence of functor declarations, though
1399 :     * it excludes some legal SML 96 programs where structures
1400 :     * but not functors are present. *)
1401 :     val (absyn_in, entDecl_in, env_in, entEnv_in) =
1402 :     elabDecl0(decl_in, env0, entEnv0, context, top_in,
1403 :     epContext, rpath, region, compInfo)
1404 :    
1405 :     (*** DAVE? what is the right epContext to pass here? ***)
1406 :     val env = SE.atop(env_in,env0)
1407 :     val entEnv = EE.mark(mkStamp,EE.atop(entEnv_in,entEnv0))
1408 :     val (absyn_out, entDecl_out, env_out, entEnv_out) =
1409 :     elabDecl0(decl_out, env, entEnv, context, top,
1410 :     epContext, rpath, region, compInfo)
1411 :    
1412 :     val resAbsyn = A.LOCALdec(absyn_in,absyn_out)
1413 :    
1414 :    
1415 :     val (entDec, resEE) =
1416 :     case context
1417 :     of EU.INFCT _ =>
1418 :     (localEntDec(entDecl_in,entDecl_out),
1419 :     EE.mark(mkStamp,EE.atop(entEnv_out,entEnv_in)))
1420 :     | _ => (M.EMPTYdec, EE.empty)
1421 :    
1422 :     in (resAbsyn, entDec, env_out, resEE)
1423 :     end
1424 :    
1425 :     | SeqDec decls =>
1426 :     let val _ = debugmsg ">>elabSeqDec"
1427 :    
1428 :     fun loop([], asdecls, entdecls, env, entEnv) =
1429 :     let val resAbsyn = A.SEQdec(rev asdecls)
1430 :     val (entDec', entEnv') =
1431 :     case context
1432 :     of EU.INFCT _ =>
1433 :     (seqEntDec(rev entdecls), entEnv)
1434 :     | _ => (M.EMPTYdec, EE.empty)
1435 :    
1436 :     val _ = debugPrint("elabseq - symbols: ", ED.ppSymList,
1437 :     ED.envSymbols env)
1438 :     val _ = debugmsg "<<elabSeqDec"
1439 :    
1440 :     in (resAbsyn, entDec', env, entEnv')
1441 :     end
1442 :    
1443 :     | loop(decl::rest, asdecls, entDecls, env, entEnv) =
1444 :     let val env1 = SE.atop(env,env0)
1445 :     val entEnv1 = EE.mark(mkStamp, EE.atop(entEnv,entEnv0))
1446 :     val (absyn, entDecl, env', entEnv') =
1447 :     elabDecl0(decl, env1, entEnv1, context, top,
1448 :     epContext, rpath, region, compInfo)
1449 :     in loop(rest, absyn::asdecls, entDecl::entDecls,
1450 :     SE.atop(env',env),
1451 :     EE.mark(mkStamp,EE.atop(entEnv',entEnv)))
1452 :     end
1453 :    
1454 :     in loop(decls, nil, nil, SE.empty, EE.empty)
1455 :     handle EE.Unbound =>
1456 :     (debugmsg("$elabDecl0: SeqDec");
1457 :     raise EE.Unbound)
1458 :     end
1459 :    
1460 :     | TypeDec tbs =>
1461 :     (*** ASSERT: the tycons declared are all DEFtycs ***)
1462 :     (let val (dec, env) =
1463 :     ET.elabTYPEdec(tbs,env0,rpath,region,compInfo)
1464 :     val tycs = case dec
1465 :     of A.TYPEdec z => z
1466 :     | _ => bug "elabDecl0 for TypeDec"
1467 :     val (entEnv, entDec) =
1468 :     bindNewTycs(context, epContext, mkStamp, [], tycs, rpath,
1469 :     error region)
1470 :     in (dec, entDec, env, entEnv)
1471 :     end
1472 :     handle EE.Unbound =>
1473 :     (debugmsg("$elabDecl0: TypeDec");
1474 :     raise EE.Unbound))
1475 :    
1476 :     | DatatypeDec (x as {datatycs,withtycs}) =>
1477 :     (case datatycs
1478 :     of (Db{rhs=(Constrs _), ...}) :: _ =>
1479 :     let val isFree =
1480 :     (case context
1481 :     of EU.INFCT _ =>
1482 :     (fn tyc =>
1483 :     (case EPC.lookPath(epContext, MU.tycId tyc)
1484 :     of SOME _ => true
1485 :     | _ => false))
1486 :     | _ => (fn _ => false))
1487 :    
1488 :     val (datatycs,withtycs,_,env) =
1489 :     ET.elabDATATYPEdec(x, env0, [], EE.empty, isFree, rpath,
1490 :     region, compInfo)
1491 :     val (entEnv, entDec) =
1492 :     bindNewTycs(context, epContext, mkStamp,
1493 :     datatycs, withtycs, rpath, error region)
1494 :     val resDec =
1495 :     A.DATATYPEdec{datatycs=datatycs,withtycs=withtycs}
1496 :     in (resDec, entDec, env, entEnv)
1497 :     end
1498 :    
1499 :     | (Db{tyc=name,rhs=Repl syms,tyvars=nil}::nil) =>
1500 :     (case withtycs
1501 :     of _::_ =>
1502 :     (error region EM.COMPLAIN
1503 :     "withtype not allowed in datatype replication"
1504 :     EM.nullErrorBody;
1505 :     (A.SEQdec[],M.ERRORdec,SE.empty,EE.empty))
1506 :     | [] =>
1507 :     let val tyc = L.lookTyc(env0, SP.SPATH syms, error region)
1508 :     in case tyc
1509 :     of T.GENtyc{kind=T.DATATYPE _,...} =>
1510 :     let val dcons = TU.extractDcons tyc
1511 :     val envDcons =
1512 :     foldl (fn (d as T.DATACON{name,...},e)=>
1513 :     SE.bind(name,B.CONbind d, e))
1514 :     SE.empty dcons
1515 :     val env = SE.bind(name, B.TYCbind tyc,
1516 :     envDcons)
1517 :     val ev = mkStamp()
1518 :     val tyc_id = MU.tycId tyc
1519 :     val (ee_dec,ee_env) =
1520 :     case context
1521 :     of EU.INFCT _ => let
1522 :     val texp =
1523 :     case EPC.lookPath(epContext,tyc_id)
1524 :     of NONE => M.CONSTtyc tyc
1525 :     | SOME entPath => M.VARtyc entPath
1526 :     in (M.TYCdec(ev,texp),
1527 :     EE.bind(ev,M.TYCent tyc,EE.empty))
1528 :     end
1529 :     | _ => (M.EMPTYdec,EE.empty)
1530 :     val resDec = A.DATATYPEdec{datatycs=[tyc],
1531 :     withtycs=[]}
1532 :     in EPC.bindPath(epContext, tyc_id, ev);
1533 :     (resDec, ee_dec, env, ee_env)
1534 :     end
1535 :     | _ =>
1536 :     (error region EM.COMPLAIN
1537 :     "rhs of datatype replication not a datatype"
1538 :     EM.nullErrorBody;
1539 :     (A.SEQdec[],M.ERRORdec,SE.empty,EE.empty))
1540 :     end)
1541 :    
1542 :     | _ => (error region EM.COMPLAIN
1543 :     "argument type variables in datatype replication"
1544 :     EM.nullErrorBody;
1545 :     (A.SEQdec[],M.ERRORdec,SE.empty,EE.empty)))
1546 :    
1547 :     | AbstypeDec x =>
1548 :     (let val isFree =
1549 :     (case context
1550 :     of EU.INFCT _ =>
1551 :     (fn tyc =>
1552 :     (case EPC.lookPath(epContext, MU.tycId tyc)
1553 :     of SOME _ => true
1554 :     | _ => false))
1555 :     | _ => (fn _ => false))
1556 :    
1557 :     val (decl as A.ABSTYPEdec{abstycs,withtycs,...}, env') =
1558 :     EC.elabABSTYPEdec(x, env0, context, isFree,
1559 :     rpath, region, compInfo)
1560 :    
1561 :     (*
1562 :     * Potential bug: what about other datatype declarations within
1563 :     * the body of ABSTYPEdec ? they are local declarations; but
1564 :     * they may not be properly dealt with now ! (ZHONG)
1565 :     *)
1566 :    
1567 :     (* note that transform is applied to decl before type checking *)
1568 :     val decl' = Typecheck.decType(SE.atop(env',env0), transform decl,
1569 :     top, error, region)
1570 :     val (entEnv, entDec) =
1571 :     bindNewTycs(context, epContext, mkStamp, abstycs, withtycs,
1572 :     rpath, error region)
1573 :     in (decl', entDec, env', entEnv)
1574 :     end
1575 :     handle EE.Unbound =>
1576 :     (debugmsg("$elabDecl0: AbstypeDec");
1577 :     raise EE.Unbound))
1578 :    
1579 :     | MarkDec(decl',region') =>
1580 :     elabDecl0(decl', env0, entEnv0, context, top,
1581 :     epContext, rpath, region', compInfo)
1582 :    
1583 :     | dec =>
1584 :     (let val isFree =
1585 :     (case context
1586 :     of EU.INFCT _ =>
1587 :     (fn tyc =>
1588 :     (case EPC.lookPath(epContext, MU.tycId tyc)
1589 :     of SOME _ => true
1590 :     | _ => false))
1591 :     | _ => (fn _ => false))
1592 :    
1593 :     val (decl,env') = EC.elabDec(dec, env0, isFree,
1594 :     rpath, region, compInfo)
1595 :     handle EE.Unbound => (debugmsg("$EC.elabDec"); raise EE.Unbound)
1596 :     val _ = debugmsg (">>elabDecl0.dec[after EC.elabDec: top="
1597 :     ^ (Bool.toString top))
1598 :     val decl' = transform decl
1599 :     val _ = debugmsg ">>elabDecl0.dec[after transform]"
1600 :     val decl'' = Typecheck.decType(SE.atop(env',env0), decl',
1601 :     top, error, region)
1602 :     handle EE.Unbound => (debugmsg("$decType");
1603 :     raise EE.Unbound)
1604 :     val _ = debugmsg ">>elabDecl0.dec[after decType]"
1605 :     in (decl'', M.EMPTYdec, env', EE.empty)
1606 :     end handle EE.Unbound =>
1607 :     (debugmsg("$elabDecl0: CoreDec"); raise EE.Unbound)))
1608 :    
1609 :    
1610 :     (*** the top-level wrapper of the elabDecl0 function ***)
1611 :     fun elabDecl {ast, statenv, entEnv, context, level,
1612 :     epContext, path, region, compInfo} =
1613 :     let val (resDec, _, senv, _) =
1614 :     elabDecl0(ast, statenv, entEnv, context, level,
1615 :     epContext, path, region, compInfo)
1616 :     in {absyn=resDec, statenv=senv}
1617 :     end
1618 :    
1619 :     end (* local *)
1620 :     end (* structure ElabMod *)
1621 :    
1622 :    
1623 :     (*
1624 :     * $Log: elabmod.sml,v $
1625 :     * Revision 1.26 1998/01/06 22:48:27 dbm
1626 :     * Fix for bug 1327. Check for ERRORtyc in mapEPS.
1627 :     *
1628 :     * Revision 1.25 1997/12/06 16:46:01 dbm
1629 :     * Fix for bug 1317 (secondary compiler bug message).
1630 :     * In elabStrbs, ignore signature constraints that fail to elaborate
1631 :     * (i.e. where elabSig returns ERRORsig).
1632 :     *
1633 :     * Revision 1.24 1997/11/24 19:54:01 dbm
1634 :     * Incorporate resultId, returnId transforms into elaborator.
1635 :     * Ast constructor name changes.
1636 :     *
1637 :     * Revision 1.23 1997/10/01 18:10:40 dbm
1638 :     * Added stripPath in bindNewTycs to strip paths stored in TYCdecs to
1639 :     * the type name alone.
1640 :     *
1641 :     * Revision 1.22 1997/09/30 02:24:12 dbm
1642 :     * Added error recovery code to suppress secondary errors.
1643 :     *
1644 :     * Revision 1.21 1997/09/23 03:50:12 dbm
1645 :     * Changes to fix EntityEnv.Unbound errors.
1646 :     *
1647 :     * Revision 1.20 1997/09/17 21:28:52 dbm
1648 :     * New symbol parameter of STRdec.
1649 :     *
1650 :     * Revision 1.19 1997/09/15 16:37:36 dbm
1651 :     * Suppress call of enterClosed within function elabFct.
1652 :     * Add env0 to environment passed to signature matching to get
1653 :     * rid of "?." in types.
1654 :     *
1655 :     * Revision 1.18 1997/08/22 18:35:08 george
1656 :     * Many bug fixes; mainly on how to maintain the epcontext correctly. --- zsh
1657 :     *
1658 :     * Revision 1.15 1997/07/17 20:38:11 dbm
1659 :     * Added some debugging code.
1660 :     *
1661 :     * Revision 1.14 1997/07/15 16:03:48 dbm
1662 :     * Change in signature representation, eliminating extdefs, change in
1663 :     * type of relativizeType.
1664 :     *
1665 :     * Revision 1.13 1997/05/20 12:18:42 dbm
1666 :     * SML '97 sharing, where structure.
1667 :     *
1668 :     * Revision 1.12 1997/04/20 16:10:11 dbm
1669 :     * Change of wording of error messages associated with datatype replication.
1670 :     *
1671 :     * Revision 1.11 1997/04/18 15:41:34 george
1672 :     * Fixing the redundant recompilations caused by EMPTYdec in functor
1673 :     * body entity expressions. (reported by Matthias Blume) -- zsh
1674 :     *
1675 :     * Revision 1.10 1997/04/16 18:02:53 dbm
1676 :     * Very minor cleanup. Removed a handler used for debugging.
1677 :     *
1678 :     * Revision 1.9 1997/04/02 04:00:34 dbm
1679 :     * Passing rpath to functor application to fix bug 12.
1680 :     *
1681 :     * Revision 1.8 1997/03/27 17:21:10 dbm
1682 :     * Changed top parameter for elabDecl0 when elaborating the local decls in
1683 :     * LetStr and LetFct. This is to cover additional variants of bug 905 --
1684 :     * See test/bug905.x.sml for x=3,4,5,6.
1685 :     *
1686 :     * Revision 1.7 1997/03/22 18:12:48 dbm
1687 :     * Change in elaboration of LocalDec to fix bug 905/952. Use hasModules
1688 :     * to do a conservative check for the presence of functor declarations in
1689 :     * the inner or outer decls of the local.
1690 :     *
1691 :     * Revision 1.6 1997/03/17 18:48:24 dbm
1692 :     * Changes in datatype representation to support datatype replication.
1693 :     * Elaboration of datatype replication declarations.
1694 :     *
1695 :     * Revision 1.5 1997/02/26 21:49:22 george
1696 :     * Fixing the secondary error message bug, BUG 1150, of fctId
1697 :     * on "structure S = F()" reported by Mikael Pettersson.
1698 :     *
1699 :     * Revision 1.2 1997/01/21 13:24:57 george
1700 :     * Modify the entityExp definition to correctly implement the
1701 :     * datatype generativity in functor body. -- from zsh
1702 :     *
1703 :     *)

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