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

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/Semant/elaborate/elabsig.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/Semant/elaborate/elabsig.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* Copyright 1996 by AT&T Bell Laboratories *)
2 :     (* elabsig.sml *)
3 :    
4 :     signature ELABSIG =
5 :     sig
6 :    
7 :     val elabSig :
8 :     {sigexp : Ast.sigexp,
9 :     nameOp : Symbol.symbol option,
10 :     env : StaticEnv.staticEnv,
11 :     entEnv : Modules.entityEnv,
12 :     epContext : EntPathContext.context,
13 :     region : SourceMap.region,
14 :     compInfo : ElabUtil.compInfo} -> Modules.Signature
15 :    
16 :     val elabFctSig :
17 :     {fsigexp : Ast.fsigexp,
18 :     nameOp : Symbol.symbol option,
19 :     env : StaticEnv.staticEnv,
20 :     entEnv : Modules.entityEnv,
21 :     epContext : EntPathContext.context,
22 :     region : SourceMap.region,
23 :     compInfo : ElabUtil.compInfo} -> Modules.fctSig
24 :    
25 :     val debugging : bool ref
26 :    
27 :     end (* signature ELABSIG *)
28 :    
29 :    
30 :     structure ElabSig : ELABSIG =
31 :     struct
32 :    
33 :     local structure S = Symbol
34 :     structure EM = ErrorMsg
35 :     structure A = Access
36 :     structure EP = EntPath
37 :     structure EPC = EntPathContext
38 :     structure EE = EntityEnv
39 :     structure M = Modules
40 :     structure MU = ModuleUtil
41 :     structure B = Bindings
42 :     structure SP = SymPath
43 :     structure IP = InvPath
44 :     structure LU = Lookup
45 :     structure SE = StaticEnv
46 :     structure T = Types
47 :     structure BT = BasicTypes
48 :     structure TU = TypesUtil
49 :     structure EU = ElabUtil
50 :     structure ET = ElabType
51 :     structure EX = ExpandTycon
52 :     structure ST = Stamps
53 :     open Ast Modules
54 :     in
55 :    
56 :     (* debugging *)
57 :     fun bug msg = ErrorMsg.impossible ("ElabSig: " ^ msg)
58 :    
59 :     val say = Control.Print.say
60 :     val debugging = Control.CG.esdebugging (* ref false *)
61 :     fun debugmsg (msg: string) = if (!debugging) then (say msg; say "\n") else ()
62 :     fun debugPrint x = ElabDebug.debugPrint debugging x
63 :    
64 :     open ElabDebug
65 :     val debugPrint = (fn x => debugPrint debugging x)
66 :    
67 :     val resultId = Symbol.strSymbol "<resultStr>"
68 :    
69 :     (* utility stuff *)
70 :     fun stripMarkSig(MarkSig(sigexp,region'),_) = stripMarkSig(sigexp,region')
71 :     | stripMarkSig x = x
72 :    
73 :    
74 :     fun lookStrDef(env,spath,epContext,err) =
75 :     let val strDef = LU.lookStrDef(env,spath,err)
76 :     in case strDef
77 :     of VARstrDef _ => strDef
78 :     | CONSTstrDef str =>
79 :     (case str
80 :     of M.ERRORstr => strDef
81 :     | M.STR{sign,...} =>
82 :     (case EPC.lookPath(epContext,MU.strId str)
83 :     of NONE => strDef
84 :     | SOME entPath => VARstrDef(sign,entPath))
85 :     | M.STRSIG _ => bug "lookStrDef")
86 :     end
87 :    
88 :     (* code for processing where defs *)
89 :    
90 :     fun closedDefs defs =
91 :     not(List.exists
92 :     (fn ((_,TYCdef(_,_,true)) | (_,STRdef(_,VARstrDef _))) => true
93 :     | _ => false)
94 :     defs)
95 :    
96 :     (* defs = prepare whereDefs (* sorted by initial path symbol *) *)
97 :    
98 :     fun sortdefs(defs) =
99 :     let fun gt ([],_) = false
100 :     | gt (_,[]) = true
101 :     | gt (s1::_,s2::_) = Symbol.symbolGt(s1,s2)
102 :     in Sort.sort (fn ((p1,d1),(p2,d2)) => gt(p1,p2)) defs
103 :     end
104 :    
105 :     fun prepareDefs whereDefs =
106 :     sortdefs(map (fn (def as STRdef(SP.SPATH p,_)) => (p,def)
107 :     | (def as TYCdef(SP.SPATH p,_,_)) => (p,def))
108 :     whereDefs)
109 :    
110 :     fun pushDefs(elements,defs,error,mkStamp) =
111 :     let fun findDefs(sym,defs) =
112 :     let fun loop((item as (s::rest,def))::defs,this,others) =
113 :     if S.eq(s,sym) then loop(defs,(rest,def)::this,others)
114 :     else if S.symbolGt(s,sym) then
115 :     (sortdefs this,(rev others@(item::defs)))
116 :     else loop(defs,this,item::others)
117 :     | loop(nil,this,others) = (sortdefs this,rev others)
118 :     in loop(defs,nil,nil)
119 :     end
120 :     fun applyTycDef(tspec as TYCspec{entVar,spec,...},TYCdef(spath,tyc,_)) =
121 :     case spec
122 :     of T.GENtyc{kind=T.FORMAL,arity,...} =>
123 :     if TU.tyconArity tyc = arity
124 :     then TYCspec{entVar=entVar, spec=tyc, scope=SP.length spath}
125 :     else (error ("where type definition has wrong arity: " ^
126 :     SP.toString spath);
127 :     tspec)
128 :     | T.GENtyc{kind=T.DATATYPE _,arity,...} =>
129 :     (* We allow a where type to constrain a datatype spec,
130 :     * if rhs datatype is "compatible" with spec. We use
131 :     * an extremely weak notion of compatibility -- same arity. *)
132 :     if arity = TU.tyconArity tyc
133 :     then TYCspec{entVar=entVar, spec=tyc,
134 :     scope=SP.length spath}
135 :     else (error ("where type definition has wrong arity: " ^
136 :     SP.toString spath);
137 :     tspec)
138 :     | T.DEFtyc _ =>
139 :     (error ("where type defn applied to definitional spec: " ^
140 :     SP.toString spath);
141 :     tspec)
142 :     fun applyStrDefs(spec as STRspec{entVar,sign,def,slot},defs) =
143 :     (* in the case where the where def has a different signature,
144 :     * could propagate defs in to the components, as is done currently
145 :     * during instantiation. If a VARstrDef applies to a spec
146 :     * with a different signature, this propagation of VAR defs
147 :     * into the components means that the spec signature is
148 :     * open (i.e. the "closed" field should become false).
149 :     * This is currently being handled within instantiate. *)
150 :     (case def
151 :     of SOME _ =>
152 :     (error "where defn applied to definitional spec";
153 :     spec)
154 :     | NONE =>
155 :     (case defs
156 :     of (nil,STRdef(spath,strDef))::rest =>
157 :     (* applies directly *)
158 :     (case rest
159 :     of nil =>
160 :     STRspec{entVar=entVar,sign=sign,
161 :     def=SOME(strDef,SP.length spath),
162 :     slot=slot}
163 :     | _ => (error "redundant where definitions";
164 :     spec))
165 :     | _ => STRspec{entVar=entVar,def=NONE,slot=slot,
166 :     sign=addWhereDefs(sign,defs,NONE,
167 :     error,mkStamp)}))
168 :     fun loop(nil,defs,elems) = (* all elements processed *)
169 :     (case defs
170 :     of nil => rev elems (* all defs consumed *)
171 :     | _ => (* left-over defs *)
172 :     (app (fn (_,TYCdef(p,_,_)) =>
173 :     (error (concat
174 :     ["unbound left hand side in where type: ",
175 :     SP.toString p]))
176 :     | (_,STRdef(p,_)) =>
177 :     (error (concat
178 :     ["unbound left hand side in where (structure): ",
179 :     SP.toString p])))
180 :     defs;
181 :     rev elems))
182 :     | loop(elems0,nil,elems) =
183 :     rev elems @ elems0 (* all defs processed *)
184 :     | loop((elem as (sym,tspec as TYCspec _))::elems,defs,elems') =
185 :     let val (localdefs,otherdefs) = findDefs(sym,defs)
186 :     in case localdefs
187 :     of [(nil,tycDef as TYCdef(spath,tyc,rel))] =>
188 :     loop(elems,otherdefs,
189 :     (sym,applyTycDef(tspec,tycDef))::elems')
190 :     | nil => loop(elems,defs,elem::elems')
191 :     | _ => (error ("multiple where defs for "^S.name sym);
192 :     loop(elems,otherdefs,elem::elems'))
193 :     end
194 :     | loop((elem as (sym,sspec as STRspec _))::elems,defs,elems') =
195 :     let val (localdefs,otherdefs) = findDefs(sym,defs)
196 :     in case localdefs
197 :     of nil => (* no defs apply to this element *)
198 :     loop(elems,otherdefs,elem::elems')
199 :     | _ =>
200 :     loop(elems,otherdefs,
201 :     (sym,applyStrDefs(sspec,localdefs))::elems')
202 :     end
203 :     | loop(elem::elems,defs,elems') = loop(elems,defs,elem::elems')
204 :     in loop(elements,defs,nil)
205 :     end
206 :    
207 :     (* does this belong in ModuleUtil or ElabUtil? DBM *)
208 :     and addWhereDefs(sign,nil,nameOp,error,mkStamp) = bug "addWhereDefs"
209 :     | addWhereDefs(sign as SIG{name,closed,fctflag,stamp,
210 :     symbols,elements,boundeps,lambdaty,typsharing,strsharing},
211 :     whereDefs,nameOp,error,mkStamp) =
212 :     SIG{name=case nameOp
213 :     of SOME _ => nameOp (* new name provided *)
214 :     | NONE => name, (* retain old name (?) *)
215 :     closed=closed andalso closedDefs whereDefs,
216 :     fctflag=fctflag,
217 :     stamp=mkStamp(), (* give modified sig a new stamp
218 :     -- could stack stamps *)
219 :     symbols=symbols,
220 :     elements=pushDefs(elements,whereDefs,error,mkStamp),
221 :     boundeps=ref NONE,
222 :     lambdaty=ref NONE,
223 :     typsharing=typsharing,
224 :     strsharing=strsharing}
225 :    
226 :     fun localPath(p,elements) =
227 :     (MU.getSpec(elements,SP.first p); true) handle MU.Unbound _ => false
228 :    
229 :     val paramId = S.strSymbol "<param>"
230 :     val functorId = S.fctSymbol "<functor>"
231 :    
232 :     (*
233 :     * Elements are added in reverse order, so at the end, the elements
234 :     * lists must be reversed. In the long run, this could be changed
235 :     * if we move to a env-based representation of the elements.
236 :     *)
237 :     fun addElement(x,elements) = x::elements
238 :    
239 :     fun add(symbol,spec,elements,err) =
240 :     (* check to see whether symbol is already bound in the given env *)
241 :     (debugmsg (">>add: "^S.name symbol);
242 :     if List.exists (fn (n,_) => S.eq(symbol,n)) elements
243 :     then (* if so, this indicates a duplicate specification error *)
244 :     (err EM.COMPLAIN ("duplicate specifications for "
245 :     ^S.nameSpaceToString(S.nameSpace symbol)
246 :     ^" "^S.name symbol^" in signature")
247 :     EM.nullErrorBody;
248 :     elements)
249 :     (* otherwise, add the symbol *)
250 :     else addElement((symbol,spec),elements))
251 :    
252 :    
253 :     (* elaborating where type clauses around signatures *)
254 :     fun elabWhere (sigexp,env,epContext,mkStamp,error,region) =
255 :     let fun loop(AugSig(sigexp,whspecs),defs,region) =
256 :     let fun loop1(nil,defs) = loop(sigexp,defs,region)
257 :     | loop1(WhType(path,tyvars,ty)::rest,defs) =
258 :     let val spath = SP.SPATH path
259 :     val _ = debugmsg("elabWhere:WhType: " ^
260 :     SP.toString spath)
261 :     val tvs = ET.elabTyvList(tyvars,error,region)
262 :     val arity = length tvs
263 :     val (ty,tvs') = ET.elabType(ty,env,error,region)
264 :     val _ = EU.checkBoundTyvars(tvs',tvs,error region)
265 :     val _ = TU.bindTyvars tvs
266 :     val _ = TU.compressTy ty
267 :     val (nty,relative) = MU.relativizeType epContext ty
268 :     val tycon =
269 :     T.DEFtyc{stamp = mkStamp(),
270 :     path=IP.IPATH [List.last path],
271 :     strict=EU.calc_strictness(arity,ty),
272 :     tyfun=T.TYFUN{arity=arity,body=nty}}
273 :     in loop1(rest,TYCdef(spath,tycon,relative)::defs)
274 :     end
275 :     | loop1(WhStruct(lhs,rhs) ::rest,defs) =
276 :     (let val lhspath = SP.SPATH lhs
277 :     val strDef =
278 :     lookStrDef(env,SP.SPATH rhs,epContext,error region)
279 :     val strDef =
280 :     (* remove access & inline info (bug 1201) *)
281 :     case strDef
282 :     of CONSTstrDef(STR{sign,rlzn,...}) =>
283 :     CONSTstrDef(STR{sign=sign,rlzn=rlzn,
284 :     access=Access.nullAcc,
285 :     info=InlInfo.nullInfo})
286 :     | _ => strDef
287 :     in loop1(rest,STRdef(lhspath,strDef)::defs)
288 :     end
289 :     handle SE.Unbound =>
290 :     (error region EM.COMPLAIN
291 :     "unbound rhs in where clause"
292 :     EM.nullErrorBody;
293 :     loop1(rest,defs)))
294 :     in loop1(whspecs,defs)
295 :     end
296 :     | loop(MarkSig(sigexp,region),defs,_) =
297 :     loop(sigexp,defs,region)
298 :     | loop(sigexp,defs,region) = (sigexp,defs,region)
299 :     in loop(sigexp,nil,region)
300 :     end
301 :    
302 :     (*
303 :     * elabBody is the main function for elaborating signature bodies.
304 :     *
305 :     * Its return type is
306 :     *
307 :     * elements * symbols
308 :     * * tycShareSpec list * strShareSpec list * bool
309 :     *
310 :     * It does not need to return an updated statenv.
311 :     *)
312 :     fun elabBody(specs, env, entEnv, sctxt, epContext, region,
313 :     compInfo as {mkStamp,error,...} : EU.compInfo) =
314 :     let
315 :    
316 :     (*** elaborating type specification --- returning "env * elements" ***)
317 :     fun elabTYPEspec(tspecs, env, elements, symbols, eqspec, region) =
318 :     let val _ = debugmsg ">>elabTYPEspec"
319 :     val err = error region
320 :     val eq = if eqspec then T.YES else T.IND
321 :    
322 :     fun loop([], env, elems, syms) = (env, elems, syms)
323 :     | loop((name,tyvars,abbrev)::rest, env, elems, syms) =
324 :     let val tvs = ET.elabTyvList(tyvars,error,region)
325 :     val arity = length tvs
326 :     val tycon =
327 :     case abbrev
328 :     of SOME def =>
329 :     let val (ty,tvs') = ET.elabType(def,env,error,region)
330 :     val _ = EU.checkBoundTyvars(tvs',tvs,err)
331 :     val _ = TU.bindTyvars tvs
332 :     val _ = TU.compressTy ty
333 :     val (nty,_) = MU.relativizeType epContext ty
334 :     in T.DEFtyc{stamp = mkStamp(),
335 :     path=IP.IPATH [name],
336 :     strict=EU.calc_strictness(arity,ty),
337 :     tyfun=T.TYFUN{arity=arity,body=nty}}
338 :     end
339 :     | NONE => T.GENtyc{stamp = mkStamp(),
340 :     path = IP.IPATH [name],
341 :     arity = arity, eq = ref eq,
342 :     kind = T.FORMAL}
343 :    
344 :     val ev = mkStamp()
345 :     val etyc = T.PATHtyc{arity=arity,entPath=[ev],
346 :     path=IP.IPATH[name]}
347 :     val env' = SE.bind(name, B.TYCbind etyc, env)
348 :    
349 :     val ts = TYCspec{spec=tycon, entVar=ev,scope=0}
350 :     val elems' = add(name, ts, elems, err)
351 :    
352 :     in loop(rest, env', elems', name::syms)
353 :     end
354 :    
355 :     in loop(tspecs, env, elements, symbols)
356 :     end
357 :    
358 :     fun allButLast l = List.take(l,List.length l - 1)
359 :    
360 :     (* elaborate datatype replication specs.
361 :     * Uses DEFtyc wrappings of the rhs datatype in the resulting specs.
362 :     * Need to check that this will do the "right thing" in instantiate. *)
363 :     fun elabDATArepl(name,syms,env,elements,symbols,region) =
364 :     let val tyc = Lookup.lookTyc(env, SP.SPATH syms, error region)
365 :     in case tyc
366 :     of T.PATHtyc{entPath,arity,...} =>
367 :     (* local to current outermost signature *)
368 :     (* get the spec, using expandTycon. check it is a datatype *)
369 :     let val sigContext = elements::sctxt
370 :     val tyc' = EX.expandTycon(tyc,sigContext,entEnv)
371 :     in case tyc'
372 :     of T.GENtyc{kind=T.DATATYPE{index, family as {members,...},
373 :     stamps, freetycs, ...}, ...} =>
374 :     let val stamp = Vector.sub(stamps,index)
375 :     val {tycname, arity, dcons, sign, ...} =
376 :     Vector.sub(members,index)
377 :     (* add the type *)
378 :     val ev = mkStamp()
379 :     (* spec uses wrapped version of the PATHtyc!! *)
380 :     val tspec = TYCspec{spec=TU.wrapDef(tyc,mkStamp()),
381 :     entVar=ev,scope=0}
382 :     val elements' =
383 :     add(name,tspec,elements,error region)
384 :     val etyc = T.PATHtyc{arity=arity,entPath=[ev],
385 :     path=IP.IPATH[name]}
386 :     val env' = SE.bind(name, B.TYCbind etyc, env)
387 :     val symbols' = name::symbols
388 :     (* unlike normal case (rhs=Constrs), won't bother
389 :     to re-register the tyc in epContext *)
390 :    
391 :     val prefix = allButLast entPath
392 :     fun expandTyc(tyc as T.PATHtyc{entPath=ep,
393 :     arity,path}) =
394 :     (* see if the path ep is defined externally
395 :     * in the entEnv *)
396 :     ((EE.look(entEnv,hd ep);
397 :     tyc) (* external tyc *)
398 :     handle EE.Unbound =>
399 :     (* tyc is local to sig *)
400 :     T.PATHtyc{entPath=prefix @ ep,arity=arity,
401 :     path=path})
402 :     | expandTyc(T.FREEtyc n) =
403 :     ((List.nth(freetycs,n)) handle _ =>
404 :     bug "unexpected freetycs in expandTyc")
405 :     | expandTyc(T.RECtyc n) =
406 :     if n = index then etyc
407 :     (* could equivalently be tyc? *)
408 :     else let val stamp = Vector.sub(stamps,n)
409 :     val {tycname,arity,...} =
410 :     Vector.sub(members,n)
411 :     val tyc_id = ModuleId.TYCid stamp
412 :     in T.PATHtyc{arity=arity,
413 :     entPath=prefix@[stamp],
414 :     path=IP.IPATH[tycname]}
415 :     (* reconstructing the entPath for sibling
416 :     * datatypes using the fact that the entVar
417 :     * for a datatype spec is the same as the
418 :     * stamp of the datatype.
419 :     * See elabDATATYPEspec0 *)
420 :     end
421 :     | expandTyc tyc = tyc
422 :    
423 :     val expand = TU.mapTypeFull expandTyc
424 :    
425 :     fun addDcons([], elems, syms) = (elems, syms)
426 :     | addDcons((d as {name,rep,domain})::dds,
427 :     elems, syms) =
428 :     let val typ =
429 :     TU.dconType(tyc,Option.map expand domain)
430 :     val const = case domain
431 :     of NONE => true
432 :     | _ => false
433 :     val nd = T.DATACON {name=name,rep=rep,
434 :     const=const,
435 :     sign=sign,
436 :     typ=typ}
437 :     val dspec = CONspec{spec=nd, slot=NONE}
438 :     val elems' = add(name, dspec, elems,
439 :     error region)
440 :     in addDcons(dds, elems', name::syms)
441 :     end
442 :     val (elements'', symbols'') =
443 :     addDcons(dcons, elements', symbols')
444 :    
445 :     in (env', elements'', symbols'')
446 :     end
447 :     | _ => (* rhs does not denote a datatype *)
448 :     (error region EM.COMPLAIN
449 :     "rhs of datatype replication spec not a datatype"
450 :     EM.nullErrorBody;
451 :     (env,elements,symbols))
452 :     end
453 :     | T.GENtyc{arity,kind=T.DATATYPE _,...} =>
454 :     (* rhs is not local to current outermost signature *)
455 :     let val (tyc',_) = MU.relativizeTyc epContext tyc
456 :     in case tyc'
457 :     of T.PATHtyc{entPath,arity,...} =>
458 :     (* outside current sig but local to enclosing functor *)
459 :     let (* add the type *)
460 :     val ev = mkStamp()
461 :     (* spec uses wrapped version of the PATHtyc!! *)
462 :     val tspec = TYCspec{spec=TU.wrapDef(tyc',mkStamp()),
463 :     entVar=ev,scope=0}
464 :     val elements' = add(name,tspec,elements,error region)
465 :     val etyc = T.PATHtyc{arity=arity,entPath=[ev],
466 :     path=IP.IPATH[name]}
467 :     val env' = SE.bind(name, B.TYCbind etyc, env)
468 :     val symbols' = name::symbols
469 :    
470 :     (* get the dcons -- quick and dirty (buggy?) hack *)
471 :     val dcons = TU.extractDcons tyc
472 :     fun addDcons([], elems, syms) = (elems, syms)
473 :     | addDcons((d as T.DATACON{name,rep,const,sign,typ})::ds,
474 :     elems, syms) =
475 :     let val nd =
476 :     T.DATACON {name=name,rep=rep,
477 :     const=const,sign=sign,
478 :     typ= #1(MU.relativizeType epContext typ)}
479 :     val dspec = CONspec{spec=nd, slot=NONE}
480 :     val elems' = add(name, dspec, elems, error region)
481 :     in addDcons(ds, elems', name::syms)
482 :     end
483 :    
484 :     val (elements'', symbols'') =
485 :     addDcons(dcons, elements', symbols')
486 :     in (env', elements'', symbols'')
487 :    
488 :     end
489 :     | _ => (* fixed global *)
490 :     let (* add the type *)
491 :     val ev = mkStamp()
492 :     val tspec = M.TYCspec{spec=TU.wrapDef(tyc,mkStamp()),
493 :     entVar=ev,scope=0}
494 :     (* put in the constant tyc
495 :     how to treat this in instantiate?*)
496 :     val elements' = add(name,tspec,elements,error region)
497 :     val etyc = T.PATHtyc{arity=arity,entPath=[ev],
498 :     path=IP.IPATH[name]}
499 :     val env' = SE.bind(name, B.TYCbind etyc, env)
500 :     val symbols' = name::symbols
501 :    
502 :     val dcons = TU.extractDcons tyc
503 :     fun addDcons([], elems, syms) = (elems, syms)
504 :     | addDcons((dc as T.DATACON{name,...})::dcs,
505 :     elems, syms) =
506 :     let val dspec = CONspec{spec=dc, slot=NONE}
507 :     val elems' = add(name, dspec, elems, error region)
508 :     in addDcons(dcs, elems', name::syms)
509 :     end
510 :     val (elements'', symbols'') =
511 :     addDcons(dcons, elements', symbols')
512 :     in (env', elements'', symbols'')
513 :     end
514 :     end
515 :     | _ => (* rhs is not local to current (outermost) signature *)
516 :     (error region EM.COMPLAIN
517 :     "rhs of datatype replication spec not a datatype"
518 :     EM.nullErrorBody;
519 :     (env,elements,symbols))
520 :     end
521 :    
522 :    
523 :     (*** elaborating datatype specification ***)
524 :     fun elabDATATYPEspec0(dtycspec, env, elements, symbols, region) =
525 :     let val _ = debugmsg ">>elabDATATYPEspec"
526 :     val err = error region
527 :    
528 :     (* push a local epContext environment to be used to relativize the
529 :     datacon types and bodies of withtype defns within this declaration *)
530 :     val epContext = EPC.enterClosed(epContext)
531 :    
532 :     fun isFree (T.PATHtyc _) = true
533 :     | isFree tc =
534 :     (case EPC.lookPath(epContext, MU.tycId tc)
535 :     of SOME _ => true
536 :     | _ => false)
537 :    
538 :     val (dtycs,wtycs,dcons,_) =
539 :     ET.elabDATATYPEdec(dtycspec, env, elements::sctxt, entEnv,
540 :     isFree, IP.IPATH[], region, compInfo)
541 :     val _ = debugmsg "--elabDATATYPEspec: elabDATATYPEdec done"
542 :    
543 :     (* the following code readjusts the definitions of datatypes
544 :     and withtycs without changing their stamps; this is ok,
545 :     because all references to the datatypes with same tycs
546 :     will be relativized, so there won't be two datatycs with
547 :     same type stamps. The ones returned from elabDATATYPEdec,i.e.,
548 :     dtycs, are destroyed. (ZHONG)
549 :     *)
550 :     val vizty = (fn ty => #1(MU.relativizeType epContext ty))
551 :     val viztc = (fn tc => #1(MU.relativizeTyc epContext tc))
552 :     val ndtycs =
553 :     (case dtycs
554 :     of ((T.GENtyc{kind=T.DATATYPE{index=0,family,freetycs,
555 :     stamps, root}, stamp, ...})::_) =>
556 :     let (* MAJOR GROSS HACK: use the stamp of the type as its
557 :     * entVar. This makes possible to reconstruct the entPath
558 :     * associated with a RECty when translating the types of
559 :     * domains in elabDATArepl. See >>HACK<< signs.
560 :     *)
561 :     val rtev = stamp (* mkStamp() >>HACK<< *)
562 :     val nfreetycs = map viztc freetycs
563 :     fun newdt (dt as T.GENtyc{kind=T.DATATYPE{index=i,...},
564 :     arity, eq, path, ...}) =
565 :     let val s = Vector.sub(stamps, i)
566 :     val (ev, rt) =
567 :     if i=0 then (rtev, NONE)
568 :     else (s (* mkStamp() >>HACK<< *), SOME rtev)
569 :     val nkind =
570 :     T.DATATYPE{index=i, stamps=stamps,
571 :     freetycs=nfreetycs,root=rt,
572 :     family=family}
573 :     val ndt =
574 :     T.GENtyc{arity=arity, eq=eq, kind=nkind,
575 :     path=path, stamp=s}
576 :    
577 :     val _ = EPC.bindPath(epContext, MU.tycId ndt, ev)
578 :     in (ev, arity, ndt)
579 :     end
580 :     | newdt _ = bug "unexpected case in newdtyc"
581 :     in map newdt dtycs
582 :     end
583 :     | _ => bug "unexpected tycs in bindNewTycs")
584 :    
585 :     val nwtycs =
586 :     let fun newwt (T.DEFtyc{stamp, tyfun=T.TYFUN{arity,body},
587 :     strict, path}) =
588 :     let val ev = stamp (* mkStamp() >>HACK<< *)
589 :     val nwt =
590 :     T.DEFtyc{stamp=stamp,strict=strict,path=path,
591 :     tyfun=T.TYFUN{arity=arity, body=vizty body}}
592 :     val _ = EPC.bindPath(epContext, MU.tycId nwt, ev)
593 :     in (ev, arity, nwt)
594 :     end
595 :     in map newwt wtycs
596 :     end
597 :    
598 :     fun addTycs([], env, elems, syms) = (env, elems, syms)
599 :     | addTycs((ev,arity,tyc)::tycs, env, elems, syms) =
600 :     let val tspec = TYCspec{spec=tyc, entVar=ev, scope=0}
601 :     val name = TU.tycName tyc
602 :     val _ = debugmsg ("--elabDATATYPEspec - name: "^ S.name name)
603 :     val elems' = add(name, tspec, elems, err)
604 :     val etyc = T.PATHtyc{arity=arity,entPath=[ev],
605 :     path=IP.IPATH[name]}
606 :     val env' = SE.bind(name, B.TYCbind etyc, env)
607 :     in addTycs(tycs, env', elems', name::syms)
608 :     end
609 :     val (env', elements', symbols') =
610 :     addTycs(ndtycs@nwtycs, env, elements, symbols)
611 :     val _ = debugmsg "--elabDATATYPEspec: tycs added"
612 :    
613 :     fun addDcons([], elems, syms) = (elems, syms)
614 :     | addDcons((T.DATACON{name,rep,const,sign,typ})::ds, elems, syms) =
615 :     let val _ = debugPrint("addDcons - typ: ",
616 :     (fn pps => fn ty => PPType.ppType env pps ty), typ)
617 :     val nd = T.DATACON {name=name, rep=rep, const=const,
618 :     sign=sign, typ=vizty typ}
619 :     (** NOTICE that the call to vizty will kill all the
620 :     references to old datatycs, dtycs, because the
621 :     same stamp has been mapped to PATHtyc in epContext
622 :     already. Is it tricky ?! (ZHONG) *)
623 :    
624 :     val dspec = CONspec{spec=nd, slot=NONE}
625 :     val elems' = add(name, dspec, elems, err)
626 :     in addDcons(ds, elems', name::syms)
627 :     end
628 :    
629 :     val (elements'', symbols'') = addDcons(dcons, elements', symbols')
630 :     val _ = debugmsg "--elabDATATYPEspec: dcons added"
631 :     val _ = debugmsg "<<elabDATATYPEspec"
632 :    
633 :     in (env', elements'', symbols'')
634 :     end
635 :    
636 :     fun elabDATATYPEspec(db as {datatycs,withtycs}, env, elements, symbols, region) =
637 :     case datatycs
638 :     of ([spec as Db{rhs=Repl syms,tyc=name,tyvars=[]}]) =>
639 :     elabDATArepl(name,syms,env,elements,symbols,region)
640 :     | (Db{rhs=Constrs _,...}::_) =>
641 :     elabDATATYPEspec0(db,env,elements,symbols,region)
642 :     | _ => (error region EM.COMPLAIN "ill-formed datatype spec"
643 :     EM.nullErrorBody;
644 :     (env,elements,symbols))
645 :    
646 :     (*** elaborating structure specification ***)
647 :     fun elabSTRspec((name,sigexp,defOp), env, elements, syms, slots, region) =
648 :     let val _ = debugmsg ("--elabSTRspec: "^S.name name)
649 :     val region0 = region
650 :     val err = error region
651 :    
652 :     val ev = mkStamp() (* the entVar for this structure element *)
653 :    
654 :     val (sign,defStrOp) =
655 :     let val (sigexp,whereDefs,region) =
656 :     elabWhere(sigexp,env,epContext,mkStamp,error,region)
657 :     val sign =
658 :     case sigexp
659 :     of VarSig name' => LU.lookSig(env,name',err)
660 :     | BaseSig specs =>
661 :     let val (elements', symbols', tycShare', strShare',
662 :     fflag') =
663 :     elabBody(specs, env, entEnv, elements::sctxt,
664 :     epContext, region, compInfo)
665 :    
666 :     val sign' =
667 :     SIG{name=NONE, closed=false,fctflag=fflag',
668 :     stamp=mkStamp(), symbols=symbols',
669 :     elements=elements', boundeps=ref NONE,
670 :     lambdaty=ref NONE, typsharing=tycShare',
671 :     strsharing=strShare'}
672 :    
673 :     in sign'
674 :     end
675 :     | _ => bug "elabSTRspec.strspecs"
676 :    
677 :     val sign =
678 :     case sign
679 :     of ERRORsig => ERRORsig
680 :     | _ =>
681 :     (case whereDefs
682 :     of nil => sign (* no where defs *)
683 :     | _ => addWhereDefs(sign,prepareDefs whereDefs,
684 :     NONE,
685 :     (fn msg =>
686 :     error region
687 :     EM.COMPLAIN msg
688 :     EM.nullErrorBody),
689 :     mkStamp))
690 :     val defStrOp =
691 :     case defOp
692 :     of NONE => NONE
693 :     | SOME path =>
694 :     (SOME(lookStrDef(env,SP.SPATH path,epContext,
695 :     error region),
696 :     length path)
697 :     handle SE.Unbound =>
698 :     (error region EM.COMPLAIN
699 :     "unbound rhs in structure definition spec"
700 :     EM.nullErrorBody;
701 :     NONE))
702 :     in (sign, defStrOp)
703 :     end
704 :    
705 :     val _ = debugmsg "--elabSTRspec: signature elaborated"
706 :    
707 :     val env' = SE.bind(name, B.STRbind(STRSIG{sign=sign,entPath=[ev]}), env)
708 :     val strspec = STRspec{sign=sign,entVar=ev,def=defStrOp,slot=slots}
709 :     val elements' = add(name, strspec, elements, err)
710 :     val _ = debugmsg "<<elabSTRspec"
711 :    
712 :     val fflag = case sign of SIG{fctflag=ff,...} => ff
713 :     | _ => false
714 :    
715 :     in (env', elements', name::syms, fflag)
716 :    
717 :     end (* fun elabSTRspec *)
718 :    
719 :     (*** elaborating structure specifications ***)
720 :     fun elabSTRspecs([], env, elements, symbols, slots, region, fflag) =
721 :     (env, elements, symbols, [], [], slots, fflag)
722 :    
723 :     | elabSTRspecs(spec::rest, env, elements, symbols, slots, region, fflag) =
724 :     let val (env', elements', symbols', fctflag') =
725 :     elabSTRspec(spec, env, elements, symbols, slots, region)
726 :     in elabSTRspecs(rest, env', elements', symbols',
727 :     slots+1, region, fflag orelse fctflag')
728 :     end (* function elabSTRspecs *)
729 :    
730 :     (*
731 :     * Current signature's elements are passed in so that add can check for
732 :     * respecifications of the same name. The result accumulates new specs
733 :     * in the new values of elements that are returned in the result, along
734 :     * with the new value of slots.
735 :     *
736 :     * The env argument includes all previous specs (i.e. argument elements)
737 :     * at this signature level, as well as outer signature levels.
738 :     *
739 :     * The elements are in order of specification.
740 :     *
741 :     * The return type of elabSpec is
742 :     *
743 :     * SE.staticEnv * elements * tycShareSpec list * strShareSpec list
744 :     * * int (slot #)
745 :     *
746 :     * Only the IncludeSpec, ShareTycSpec, and ShareStrSpec cases can produce
747 :     * non-nil tycShareSpec and strShareSpec result components.
748 :     *)
749 :    
750 :     fun elabSpec (spec, env, elements, symbols, slots, region) =
751 :     case spec
752 :     of StrSpec specs =>
753 :     elabSTRspecs(specs, env, elements, symbols, slots, region, false)
754 :    
755 :     | FctSpec specs =>
756 :     let val _ = debugmsg "--elabSpec[FctSpec]"
757 :     val err = error region
758 :     fun fctspecs(nil,elems,syms,slots) =
759 :     (env, elems, syms, [], [], slots, true)
760 :     | fctspecs((name,fsig)::rest,elems,syms,slots) =
761 :     let val fctsig =
762 :     elabFctSig0 {fsigexp=fsig, nameOp=NONE, env=env,
763 :     entEnv=entEnv, sigContext=sctxt,
764 :     epContext=epContext, region=region,
765 :     compInfo=compInfo, curried=false}
766 :     val ev = mkStamp()
767 :     val spec = FCTspec{sign=fctsig, slot=slots, entVar=ev}
768 :     val elems' = add(name,spec,elems, err)
769 :     in fctspecs(rest, elems', name::syms, slots+1)
770 :     end
771 :    
772 :     in fctspecs(specs,elements,symbols,slots)
773 :     end
774 :    
775 :     | TycSpec (specs,eqspec) =>
776 :     let val _ = debugmsg "--elabSpec[TycSpec]"
777 :     val (env', elems', syms') =
778 :     elabTYPEspec(specs, env, elements, symbols, eqspec, region)
779 :     in (env', elems', syms', [], [], slots, false)
780 :     end
781 :    
782 :     | DataSpec spec =>
783 :     let val _ = debugmsg "--elabSpec[DataSpec]"
784 :     val (env', elems', syms') =
785 :     elabDATATYPEspec(spec, env, elements, symbols, region)
786 :     in (env', elems', syms', [], [], slots, false)
787 :     end
788 :    
789 :     | ValSpec specs =>
790 :     let val err = error region
791 :     fun valspecs(nil,elems,syms,slots) =
792 :     (env,elems,syms,[],[],slots,false)
793 :     | valspecs((name,ty)::rest,elems,syms,slots) =
794 :     let val _ = debugmsg ("--elabSpec[ValSpec]: " ^ S.name name)
795 :     val (ty,tv) = ET.elabType(ty,env,error,region)
796 :     val typ =
797 :     case TyvarSet.elements tv
798 :     of [] => ty
799 :     | tvs =>
800 :     let val sign = TU.bindTyvars1 tvs
801 :     in T.POLYty{sign=sign,
802 :     tyfun=T.TYFUN{arity=length tvs,
803 :     body=ty}}
804 :     end
805 :     val _ = TU.compressTy typ
806 :     val (typ,_) = MU.relativizeType epContext typ
807 :     val vspec = VALspec{spec=typ, slot=slots}
808 :     val elems' = add(name,vspec,elems,err)
809 :     in valspecs(rest, elems', name::syms, slots+1)
810 :     end
811 :     in valspecs(specs,elements,symbols,slots)
812 :     end
813 :    
814 :     | ExceSpec (specs) =>
815 :     let val err = error region
816 :     fun exnspecs(nil,elems,syms,slots) =
817 :     (env,elems,syms,[],[],slots, false)
818 :     | exnspecs((name,tyOp)::rest,elems,syms,slots) =
819 :     let val (typ, const) =
820 :     (case tyOp
821 :     of SOME ty =>
822 :     let val (body,tv) =
823 :     ET.elabType(ty,env,error,region)
824 :     val nty =
825 :     case TyvarSet.elements tv
826 :     of nil => BT.-->(body,BT.exnTy)
827 :     | _ =>
828 :     (err EM.COMPLAIN
829 :     ("type variable in exception spec: "
830 :     ^ S.name name)
831 :     EM.nullErrorBody;
832 :     T.WILDCARDty)
833 :     val _ = TU.compressTy nty
834 :     in (#1(MU.relativizeType epContext nty), false)
835 :     end
836 :     | NONE => (BT.exnTy, true))
837 :    
838 :     val rep = A.EXN(A.nullAcc)
839 :     val dcon = T.DATACON{name=name, const=const,
840 :     typ=typ, sign=A.CNIL, rep=rep}
841 :     val cspec = CONspec{spec=dcon, slot=SOME slots}
842 :     val elems' = add(name,cspec,elems,err)
843 :     in exnspecs(rest, elems', name::syms, slots+1)
844 :     end
845 :    
846 :     in exnspecs(specs,elements,symbols,slots)
847 :     end
848 :    
849 :     | MarkSpec (spec,region') =>
850 :     elabSpec(spec,env,elements,symbols,slots,region')
851 :    
852 :     | FixSpec {ops,fixity} =>
853 :     (error region EM.WARN
854 :     "Fixity specification in signatures are ignored"
855 :     EM.nullErrorBody;
856 :     (env,elements,symbols,[],[],slots,false))
857 :    
858 :     | ShareStrSpec pl =>
859 :     let fun loop(nil,internal) = internal
860 :     | loop(p::rest,paths) =
861 :     if localPath(SP.SPATH p,elements)
862 :     then (case lookStrDef(env,SP.SPATH p,epContext,error region)
863 :     of VARstrDef z => loop(rest,(SP.SPATH p)::paths)
864 :     | CONSTstrDef(ERRORstr) => loop(rest,paths)
865 :     (* lookStrDef has already complained *)
866 :     | _ => bug "elabSpec[ShareStrSpec]")
867 :     (* handle SE.Unbound =>
868 :     (error region EM.COMPLAIN
869 :     ("unbound path in structure sharing: " ^
870 :     SP.toString(SP.SPATH p))
871 :     EM.nullErrorBody;
872 :     loop(rest,paths))
873 :     *)
874 :     else (error region EM.COMPLAIN
875 :     ("nonlocal path in structure sharing: " ^
876 :     SP.toString(SP.SPATH p))
877 :     EM.nullErrorBody;
878 :     loop(rest,paths))
879 :    
880 :     val sharespec = loop(pl,nil)
881 :    
882 :     in (env,elements,symbols,[],[sharespec],slots,false)
883 :     end
884 :    
885 :     | ShareTycSpec pl =>
886 :     let fun loop(nil,paths) = paths
887 :     | loop(p::rest,paths) =
888 :     if localPath(SP.SPATH p,elements)
889 :     then (LU.lookTyc(env,SP.SPATH p,error region);
890 :     loop(rest,(SP.SPATH p)::paths))
891 :     else (error region EM.COMPLAIN
892 :     ("nonlocal path in type sharing: " ^
893 :     SP.toString(SP.SPATH p))
894 :     EM.nullErrorBody;
895 :     loop(rest,paths))
896 :    
897 :     val sharespec = loop(pl,nil)
898 :     in (env,elements,symbols,[sharespec],[],slots,false)
899 :     end
900 :    
901 :     | IncludeSpec sigexp => (* param was "name" *)
902 :     let val nsig = elabSig{sigexp=sigexp, nameOp=NONE, env=env,
903 :     entEnv=entEnv, epContext=epContext,
904 :     region=region, compInfo=compInfo}
905 :     (* LU.lookSig(env,name,error region) *)
906 :     (* BUG: this may not work with open sigexps *)
907 :     val (env',elems',syms',tycShare',strShare',slots',fctflag') =
908 :     Include.elabInclude(nsig, env, elements, symbols,
909 :     slots, region, compInfo)
910 :     in (env',elems',syms',tycShare',strShare',slots',fctflag')
911 :     end
912 :    
913 :    
914 :     and elabSpecs ([], env, elements, symbols, tycShare, strShare,
915 :     slots, region, fflag) =
916 :     (env, elements, symbols, tycShare, strShare, slots, fflag)
917 :    
918 :     | elabSpecs (spec::rest, env, elements, symbols, tycShare, strShare,
919 :     slots, region, fflag) =
920 :     let val (env',elems',syms',tycShare',strShare',slots', fflag') =
921 :     elabSpec(spec,env,elements,symbols,slots,region)
922 :    
923 :     in elabSpecs(rest, env', elems', syms',
924 :     tycShare'@tycShare, strShare'@strShare,
925 :     slots', region, fflag' orelse fflag)
926 :     end
927 :    
928 :     val (_,elements,symbols,tycShare,strShare,slots,fflag) =
929 :     elabSpecs(specs,env,nil,nil,nil,nil,0,region,false)
930 :    
931 :     in (rev elements,rev symbols,tycShare,strShare,fflag)
932 :    
933 :     end (* function elabBody *)
934 :    
935 :    
936 :     and elabFctSig0 {fsigexp, curried, nameOp, env, entEnv, sigContext, epContext,
937 :     region, compInfo as {mkStamp,error,...}: EU.compInfo} =
938 :     let val sname = case nameOp
939 :     of SOME name => S.name name
940 :     | _ => "<anonfsig>"
941 :     val _ = debugmsg (">>elabFctSig: " ^ sname)
942 :     in
943 :    
944 :     case fsigexp
945 :     of BaseFsig{param=[(paramNameOp,paramSpec)],result} =>
946 :     let val paramSig =
947 :     elabSig0 {sigexp=paramSpec, nameOp=NONE, env=env, entEnv=entEnv,
948 :     sigContext=sigContext, epContext=epContext,
949 :     region=region, compInfo=compInfo}
950 :     val paramName = case paramNameOp of NONE => paramId
951 :     | SOME sym => sym
952 :     val paramEntVar = mkStamp()
953 :     val paramStr = STRSIG {sign=paramSig,entPath=[paramEntVar]}
954 :    
955 :     local val paramSpec = STRspec {entVar=paramEntVar, sign=paramSig,
956 :     def=NONE, slot=0}
957 :     val paramElmt = [(paramName, paramSpec)]
958 :     in val nsctxt = paramElmt :: sigContext
959 :     end (* a temporary work-around for the sigContext hack *)
960 :    
961 :     val env' =
962 :     case paramNameOp
963 :     of SOME id => (* expose binding of paramName *)
964 :     SE.bind(id,B.STRbind paramStr,env)
965 :     | NONE => MU.openStructure(env,paramStr)
966 :    
967 :     val (result,region) = stripMarkSig(result,region)
968 :    
969 :     val result = if curried then result
970 :     else BaseSig[StrSpec[(resultId,result,NONE)]]
971 :    
972 :     val bodySig =
973 :     elabSig0 {sigexp=result, nameOp=NONE, env=env', entEnv=entEnv,
974 :     sigContext=nsctxt, epContext=epContext,
975 :     region=region, compInfo=compInfo}
976 :    
977 :     in FSIG{kind = nameOp,
978 :     paramsig = paramSig,
979 :     paramvar = paramEntVar,
980 :     paramsym = paramNameOp,
981 :     bodysig = bodySig}
982 :     end
983 :    
984 :     (*** currying fctSig arguments automatically inserts structure wrapping ***)
985 :     | BaseFsig{param = a::r,result} =>
986 :     let val nfsig = BaseSig[FctSpec[(functorId,BaseFsig{param=r,result=result})]]
987 :     in elabFctSig0 {fsigexp=BaseFsig{param=[a],result=nfsig}, nameOp=nameOp,
988 :     env=env, entEnv=entEnv, sigContext=sigContext,
989 :     epContext=epContext, region=region, compInfo=compInfo,
990 :     curried=true}
991 :     end
992 :    
993 :     | VarFsig name' =>
994 :     LU.lookFsig(env, name', error region)
995 :    
996 :     | BaseFsig{param = [],result} => bug "elabFctSig"
997 :    
998 :     | MarkFsig(fsigexp',region') =>
999 :     elabFctSig0 {fsigexp=fsigexp', nameOp=nameOp, env=env, entEnv=entEnv,
1000 :     epContext=epContext, sigContext=sigContext,
1001 :     region=region', compInfo=compInfo, curried=curried}
1002 :    
1003 :     end (* function elabFctSig0 *)
1004 :    
1005 :     and elabSig0 {sigexp, nameOp, env, entEnv, sigContext, epContext, region,
1006 :     compInfo as {mkStamp,error,...}: EU.compInfo} =
1007 :     let val region0 = region
1008 :     val sname = case nameOp
1009 :     of SOME name => S.name name
1010 :     | _ => "<anonfsig>"
1011 :     val _ = debugmsg (">>elabSig: " ^ sname)
1012 :    
1013 :     val (sigexp,whereDefs,region) =
1014 :     elabWhere(sigexp,env,epContext,mkStamp,error,region)
1015 :     val sign =
1016 :     case sigexp
1017 :     of VarSig name' => LU.lookSig(env,name',error region)
1018 :    
1019 :     | BaseSig specs =>
1020 :     let val _ = debugmsg "--elabSig >> BaseSig"
1021 :    
1022 :     val (elements, syms, tycShare, strShare, fflag) =
1023 :     elabBody(specs, env, entEnv, sigContext, epContext,
1024 :     region, compInfo)
1025 :     val _ = debugmsg "--elabSig: after elabBody"
1026 :    
1027 :     val sign=SIG{name = nameOp,
1028 :     closed = case nameOp
1029 :     of SOME _ => true
1030 :     | NONE => false,
1031 :     fctflag=fflag,
1032 :     stamp = mkStamp(),
1033 :     symbols = syms,
1034 :     elements = elements,
1035 :     boundeps = ref NONE,
1036 :     lambdaty = ref NONE,
1037 :     typsharing = tycShare,
1038 :     strsharing = strShare}
1039 :    
1040 :     in debugPrint("--elabSig: returned signature:",
1041 :     (fn pps => fn s => PPModules.ppSignature pps (s,env,6)),sign);
1042 :     debugmsg "--elabSig: << BaseSig";
1043 :     sign
1044 :     end
1045 :    
1046 :     | MarkSig(sigexp',region') => bug "elabSig0"
1047 :     (* elabWhere should have stripped this *)
1048 :    
1049 :     val sign =
1050 :     case sign
1051 :     of ERRORsig => ERRORsig
1052 :     | _ =>
1053 :     (case whereDefs
1054 :     of nil => sign (* no where defs *)
1055 :     | _ => addWhereDefs(sign,prepareDefs whereDefs,nameOp,
1056 :     (fn msg =>
1057 :     error region0
1058 :     EM.COMPLAIN msg
1059 :     EM.nullErrorBody),
1060 :     mkStamp))
1061 :    
1062 :     in sign
1063 :     end (* function elabSig0 *)
1064 :    
1065 :     and elabFctSig {fsigexp, nameOp, env, entEnv, epContext, region, compInfo} =
1066 :     elabFctSig0 {fsigexp=fsigexp, nameOp=nameOp, env=env, entEnv=entEnv,
1067 :     sigContext=[], epContext=epContext, region=region,
1068 :     compInfo=compInfo, curried=false}
1069 :    
1070 :     and elabSig {sigexp, nameOp, env, entEnv, epContext, region, compInfo} =
1071 :     elabSig0 {sigexp=sigexp, nameOp=nameOp, env=env, entEnv=entEnv,
1072 :     sigContext=[], epContext=epContext, region=region,
1073 :     compInfo=compInfo}
1074 :    
1075 :    
1076 :     val elabSigPhase = Stats.makePhase "Compiler 032 5-elabSig"
1077 :     val elabSig = fn x => Stats.doPhase elabSigPhase elabSig x
1078 :    
1079 :     end (* local *)
1080 :     end (* structure ElabSig *)
1081 :    
1082 :     (*
1083 :     * $Log: elabsig.sml,v $
1084 :     * Revision 1.17 1997/11/24 19:54:54 dbm
1085 :     * Incorporate resultId, returnId transforms into elaborator.
1086 :     * Ast constructor name changes.
1087 :     *
1088 :     * Revision 1.16 1997/10/26 23:11:31 dbm
1089 :     * Fix to allow "include <sigexp>" syntax (bug 1207). elabInclude simply
1090 :     * does not check for "closed=true" in the argument pattern.
1091 :     *
1092 :     * Revision 1.15 1997/10/19 23:47:28 dbm
1093 :     * (1) Fix for bug 1296 involving the hack of using the same stamp as
1094 :     * the entVar of a spec and the stamp of the corresponding formal
1095 :     * type. This is to allow the reconstruction of the correct entityPath
1096 :     * for turning RECtycs into PATHtycs in data constructor domains
1097 :     * when elaborating datatype replication specs.
1098 :     * (2) Zhong's fix for bug 1298, which relativizes dataconstructor
1099 :     * domains for datatype specs.
1100 :     *
1101 :     * Revision 1.14 1997/09/23 03:50:57 dbm
1102 :     * Change unWrapDef to unWrapDefStar.
1103 :     *
1104 :     * Revision 1.13 1997/09/10 22:12:08 dbm
1105 :     * Fix secondary error and improve error messages for unbound paths in
1106 :     * structure sharing specs.
1107 :     *
1108 :     * Revision 1.12 1997/09/05 04:39:29 dbm
1109 :     * Changes is TyvarSet signature (bug 1246).
1110 :     *
1111 :     * Revision 1.11 1997/08/22 18:35:10 george
1112 :     * Add code that maintains the fctflag field. -- zsh
1113 :     *
1114 :     * Revision 1.10 1997/08/15 20:37:11 dbm
1115 :     * Added local version of lookStrDef and modified expandTyc inside of
1116 :     * elabDATArepl to fix bug 1255. Eliminated obsolete types varPath and
1117 :     * pathLocality.
1118 :     *
1119 :     * Revision 1.9 1997/08/02 02:16:26 dbm
1120 :     * Change in type of EPContext.enterClosed. Partial implementation
1121 :     * of "include <sigexp>".
1122 :     *
1123 :     * Revision 1.8 1997/07/15 16:05:31 dbm
1124 :     * Change to push where defs into signatures to the spec they apply to.
1125 :     *
1126 :     * Revision 1.7 1997/05/20 12:19:08 dbm
1127 :     * SML '97 sharing, where structure.
1128 :     *
1129 :     * Revision 1.6 1997/04/14 21:29:34 dbm
1130 :     * Changed elaboration of AugSig to allow for simultaneous where defs.
1131 :     *
1132 :     * Revision 1.5 1997/03/17 18:49:08 dbm
1133 :     * Changes in datatype representation to support datatype replication.
1134 :     * Elaboration of datatype replication specifications.
1135 :     *
1136 :     * Revision 1.4 1997/02/26 21:49:33 george
1137 :     * Fixing the secondary error message bug, BUG 1150, of fctId
1138 :     * on "structure S = F()" reported by Mikael Pettersson.
1139 :     *
1140 :     *)

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