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-3/compiler/Elaborator/elaborate/elabmod.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch-3/compiler/Elaborator/elaborate/elabmod.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2571 - (view) (download)

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

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