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/modules/instantiate.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch-3/compiler/Elaborator/modules/instantiate.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3347 - (view) (download)

1 : blume 902 (* Copyright 1996 by AT&T Bell Laboratories *)
2 :     (* instantiate.sml *)
3 :    
4 :     (*
5 :     * This function constructs a dummy structure which satisfies all sharing
6 :     * constraints (explicit or induced) of a given signature. The resulting
7 :     * structure is used as the dummy parameter of a functor while elaborating
8 :     * and abstracting the functor body.
9 :     *
10 :     * The process of constructing the structure is essentially a unification
11 :     * problem. The algorithm used here is based on the Linear Unification
12 :     * algorithm first presented in [1] which was subsequently corrected
13 :     * and cleaned up in [2].
14 :     *
15 :     * The basic algorithm makes 2 passes. The first pass builds a DAG in
16 :     * a quasi-top down fashion which corresponds to the minimal structure
17 :     * needed to match the signature. The second pass takes the DAG and
18 :     * constructs the actualy dummy structure in a bottom-up fashion.
19 :     * Pass 1 has a fairly complicated control structure. The major
20 :     * invariant is that no node in the graph is expanded unless all
21 :     * of its ancestors have been expanded. This insures that all sharing
22 :     * constraints (explicit or derived) have reached the node at the
23 :     * time of its expansion. The second major invariant is that no
24 :     * node is finalized until all members in its equivalence class have
25 :     * been found.
26 :     *
27 :     * [1] Paterson, M.S., and Wegman, M.N., "Linear Unification",
28 :     * J. Comp. Sys. Sci. 16,2 (April 1978), pp. 158-167.
29 :     *
30 :     * [2] de Champeaux, D., "About the Paterson-Wegman Linear Unification
31 :     * Algorithm", J. of Comp. Sys. Sci. 32, 1986, pp. 79-88.
32 :     *)
33 :    
34 :     signature INSTANTIATE =
35 :     sig
36 :    
37 : dbm 3291 (*** instantiation of the formal functor parameter and body signatures ***)
38 :     val instFormal :
39 : blume 902 {sign : Modules.Signature,
40 :     entEnv : Modules.entityEnv,
41 :     rpath : InvPath.path,
42 :     region : SourceMap.region,
43 : dbm 3291 compInfo : ElabUtil.compInfo}
44 :     -> {rlzn: Modules.strEntity,
45 : dbm 3347 primaries : (Types.tycon list * (Stamps.stamp * Modules.fctsig) list)}
46 : blume 902
47 :     (*** instantiation of the structure abstractions ***)
48 :     val instAbstr :
49 :     {sign : Modules.Signature,
50 :     entEnv : Modules.entityEnv,
51 : dbm 3304 srcRlzn : Modules.strEntity, (* rlzn of structure being abstracted *)
52 :     rpath : InvPath.path,
53 : blume 902 region : SourceMap.region,
54 : dbm 3291 compInfo : ElabUtil.compInfo}
55 : dbm 3347 -> {rlzn: Modules.strEntity,
56 :     primaryTycs : Types.tycon list}
57 : blume 902
58 :     val debugging : bool ref
59 :    
60 :     end (* signature INSTANTIATE *)
61 :    
62 : gkuan 2740 structure Instantiate : INSTANTIATE =
63 : blume 902 struct
64 :    
65 :     local structure A = Access
66 :     structure ED = ElabDebug
67 :     structure EE = EntityEnv
68 :     structure EM = ErrorMsg
69 :     structure EP = EntPath
70 :     structure EU = ElabUtil
71 :     structure IP = InvPath
72 :     structure M = Modules
73 :     structure MU = ModuleUtil
74 :     structure PU = PrintUtil
75 :     structure S = Symbol
76 :     structure SP = SymPath
77 :     structure ST = Stamps
78 :     structure T = Types
79 :     structure TU = TypesUtil
80 :     open Modules Types
81 :     in
82 :    
83 :     (* ----------------------- utility functions ----------------------------- *)
84 :    
85 :     (* debugging *)
86 :     val say = Control_Print.say
87 :     val debugging = ElabControl.insdebugging (* ref false *)
88 :     fun debugmsg (msg: string) = if !debugging then (say msg; say "\n") else ()
89 :     fun bug s = EM.impossible ("Instantiate: " ^ s)
90 :    
91 :     fun wrap fname f arg =
92 :     if !debugging then
93 :     let val _ = say (">> "^fname^"\n")
94 :     val result = f arg
95 :     in say ("<< "^fname^"\n");
96 :     result
97 :     end
98 :     else f arg
99 :    
100 :     fun debugType(msg: string, tyc: T.tycon) =
101 :     ED.withInternals(fn () =>
102 :     ED.debugPrint debugging
103 :     (msg, PPType.ppTycon StaticEnv.empty, tyc))
104 :    
105 :    
106 :     (* error state *)
107 :     val error_found = ref false
108 :    
109 :     val infinity = 1000000 (* a big integer *)
110 :    
111 :     fun push(r,x) = (r := x::(!r))
112 :    
113 :     fun pathName (path: IP.path) : string =
114 :     SP.toString(ConvertPaths.invertIPath path)
115 :    
116 :     val eqOrigin = MU.eqOrigin
117 :     val eqSig = MU.eqSign
118 :    
119 :     fun sameStructure (STR { sign = sg1, rlzn = { stamp = s1, ... }, ... },
120 :     STR { sign = sg2, rlzn = { stamp = s2, ... }, ... }) =
121 :     eqSig (sg1, sg2) andalso ST.eq (s1, s2)
122 :     | sameStructure _ = false
123 :    
124 :     fun signName (SIG { name, ... }) = getOpt (Option.map S.name name, "Anonymous")
125 :     | signName ERRORsig = "ERRORsig"
126 :    
127 :    
128 :     (* -------------------- important data structures ------------------------ *)
129 :    
130 :     (*
131 :     * the different kinds of instantiations
132 :     *)
133 :     datatype instKind
134 : dbm 3291 = INST_ABSTR of M.strEntity (* a sealed signature ascription *)
135 :     | INST_FORMAL (* instantiating a functor param sig or formal functor result sig *)
136 : blume 902
137 :     (* datatype stampInfo
138 :     * encodes an instruction about how to get a stamp for a new entity
139 :     *)
140 :     datatype stampInfo
141 :     = STAMP of ST.stamp (* here is the stamp *)
142 :     | PATH of EP.entPath (* get the stamp of the entity designated by the path *)
143 :     | GENERATE (* generate a new stamp (using the mkStamp parameter) *)
144 :    
145 :     (* datatype entityInfo
146 :     * The contents of the finalEnt field of the FinalStr inst variant.
147 :     * Defined in finalize (in buildStrClass), used in instToStr to
148 :     * determine how to find or build the realization entity.
149 :     *
150 :     * The bool argument of GENERATE_ENT is normally true when there was
151 :     * a VARstrDef applying to the structure spec with a different signature
152 :     * than the spec. This means that the spec signature should be considered
153 :     * as open, despite what it's "closed" field might say. This was introduced
154 :     * to fix bug 1238. [dbm, 8/13/97]
155 :     *)
156 :     datatype entityInfo
157 :     = CONST_ENT of M.strEntity (* here it is *)
158 :     | PATH_ENT of EP.entPath (* find it via this entityPath *)
159 :     | GENERATE_ENT of bool (* generate a new one *)
160 :    
161 :     datatype tycInst
162 :     = INST of tycon (* already instantiated *)
163 :     | NOTINST of tycon (* needing instantiation *)
164 :    
165 :     (*
166 :     * This datatype represents the continually changing DAG that is being
167 :     * constructed by instantiate. We start off with just an Initial node.
168 :     * It is expanded into a Partial node whose children are
169 : dbm 2737 * initialized to Initial nodes. When all of the members of the node's
170 : blume 902 * equivalence class have been found, and converted to Partial nodes,
171 :     * the node is converted to FinalStr. Finally, we recurse on the children
172 :     * of the node.
173 :     *
174 :     * Invariants:
175 :     *
176 :     * The parent node is in a singleton equivalence class.
177 :     *
178 :     * All nodes that are about to be explored are either Initial or Partial.
179 :     * (Exploring a Final node implies circularity.)
180 :     *
181 :     * If a Final node's expanded field is true, then all of its children
182 :     * are Final with expanded field true.
183 :     *)
184 :     datatype inst
185 :     (* structure instances *)
186 :     = FinalStr of (* the equivalence class of this node is fully explored *)
187 :     {sign : M.Signature,
188 :     stamp : stampInfo ref,
189 :     slotEnv : slotEnv,
190 :     finalEnt: entityInfo ref,
191 :     expanded : bool ref}
192 :     | PartialStr of (* we are in the process of exploring the equiv. class *)
193 :     {sign : M.Signature,
194 :     path : IP.path,
195 :     slotEnv : slotEnv,
196 :     comps : (S.symbol * slot) list, (* sorted by symbol *)
197 :     depth : int,
198 :     final_rep : inst option ref}
199 :     | InitialStr of (* haven't started exploring the equiv. class *)
200 :     {sign : M.Signature,
201 :     sigDepth : int,
202 :     path : IP.path,
203 :     epath : EP.entPath,
204 :     slotEnv : slotEnv,
205 :     inherited : constraint list ref}
206 :     | NullStr
207 :     | ErrorStr
208 :    
209 :     (* tycon instances *)
210 :     | FinalTyc of tycInst ref
211 :     | PartialTyc of
212 :     {tycon : tycon,
213 :     path : IP.path,
214 :     epath: EP.entPath}
215 :     | InitialTyc of
216 :     {tycon : tycon,
217 :     path : IP.path,
218 :     epath: EP.entPath,
219 :     inherited : constraint list ref}
220 :     | NullTyc
221 :     | ErrorTyc
222 :    
223 :     (* functor instances *)
224 :     | FinalFct of
225 :     {sign : M.fctSig,
226 :     def : M.Functor option ref,
227 :     path: IP.path,
228 :     epath: EP.entPath}
229 :     | NullFct
230 :    
231 :     (*
232 :     * A constraint is essentially a directed arc indicating that two
233 :     * nodes are to be identified. The constraint is always interpreted
234 :     * relative to a structure inst node. The my_path field is a symbolic
235 :     * path (in regular order) indicating which subcomponent of the local
236 :     * inst is participating in the sharing. The other component is accessed
237 :     * by first finding the inst node in the its_ancestor slot, and then following
238 :     * the symbolic path its_path to the node. By going through the
239 :     * ancestor, we are able to insure that the ancestor is explored
240 :     * before the actual component is, so that its inherited constraints are
241 :     * propagated downward properly.
242 :     *)
243 :     and constraint
244 :     = SHARE of {my_path : SP.path, (* regular symbolic path *)
245 :     its_ancestor : slot,
246 :     its_path : SP.path, (* regular symbolic path *)
247 :     depth : int} (* signature nesting depth of base constraint *)
248 :     | SDEFINE of strDef * int (* int is signature nesting depth of defn *)
249 :     | TDEFINE of tycInst * int (* int is signature nesting depth of defn *)
250 :    
251 :     (* slot: a node in the graph (maybe "node" would be a better name?) *)
252 :     withtype slot = inst ref
253 :    
254 :     (* slotEnv: association list mapping entVars to slots *)
255 :     and slotEnv = (EP.entVar * slot) list
256 :    
257 :    
258 :     (* debugging *)
259 :     fun instToString inst =
260 :     (case inst
261 :     of FinalStr{sign,stamp,slotEnv,finalEnt,expanded} =>
262 :     "FinalStr(" ^ signName(sign) ^ ")"
263 :     | PartialStr{sign,path,slotEnv,comps,depth,final_rep} =>
264 :     "PartialStr(" ^ IP.toString path ^ ")"
265 :     | InitialStr{sign,sigDepth,path,slotEnv,inherited,epath} =>
266 :     "InitialStr(" ^ IP.toString path ^ ")"
267 :     | FinalTyc(ref(INST tycon)) =>
268 :     "FinalTyc.INST(" ^ (S.name(TU.tycName tycon)) ^ ")"
269 :     | FinalTyc(ref(NOTINST tycon)) =>
270 :     "FinalTyc.NOTINST(" ^ (S.name(TU.tycName tycon)) ^ ")"
271 :     | PartialTyc{tycon,path,...} => "PartialTyc(" ^ IP.toString path ^ ")"
272 :     | InitialTyc{tycon,path,...} =>
273 :     "InitialTyc(" ^ IP.toString path ^ ")"
274 :     | FinalFct{path, ...} => "FinalFct(" ^ IP.toString path ^ ")"
275 :     | NullTyc => "NullTyc"
276 :     | NullStr => "NullStr"
277 :     | NullFct => "NullFct"
278 :     | ErrorStr => "ErrorStr"
279 :     | ErrorTyc => "ErrorTyc")
280 :    
281 :     fun lookSlot((ev,slot)::rest,ev') =
282 :     if EP.eqEntVar(ev,ev') then slot else lookSlot(rest,ev')
283 :     | lookSlot(nil,_) = bug "lookSlot"
284 :    
285 :     (*
286 :     * Get slot for signature element (tycon or structure) ---
287 : dbm 2737 * Lookup sym in sign, get its entVar, lookup this entVar in slotEnv
288 : blume 902 *)
289 :     fun getElemSlot(sym, SIG {elements,...}, slotEnv) : slot =
290 :     (case MU.getSpecVar(MU.getSpec(elements,sym))
291 :     of SOME v => lookSlot(slotEnv,v)
292 :     | NONE => bug "getElemSlot (1)")
293 :     | getElemSlot _ = bug "getElemSlot (2)"
294 :    
295 :     fun getElemSlots(SIG {elements,...}, slotEnv) : (S.symbol * slot) list =
296 :     let fun f (sym,spec) =
297 :     case MU.getSpecVar spec
298 :     of SOME v => SOME(sym,lookSlot(slotEnv,v))
299 :     | NONE => NONE
300 :     in List.mapPartial f elements
301 :     end
302 :     | getElemSlots _ = bug "getElemSlots"
303 :    
304 :     (* Retrieves all [formal] substructure components from a signature *)
305 :     fun getSubSigs (SIG {elements,...}) =
306 :     List.mapPartial
307 :     (fn (sym,STRspec{sign,entVar,...}) => SOME(sym,entVar,sign)
308 :     | _ => NONE) elements
309 :     | getSubSigs _ = []
310 :    
311 :    
312 :     (* translate a tycon to a tycInst *)
313 :     fun extTycToTycInst tyc =
314 :     case tyc
315 :     of (T.DEFtyc _ | T.PATHtyc _) => NOTINST tyc
316 :     (* may need instantiation -- could check
317 :     * first whether body of DEFtyc contains any
318 :     * PATHtycs -- see bug 1200. *)
319 :     | _ => INST tyc
320 :     (* GENtyc -- won't need instantiation *)
321 :    
322 :     (* getElemDefs : strDef * (unit -> stamp) * int -> (S.symbol * constraint) list
323 :     * returns the definition constraints for components of a strDef,
324 :     * sorted by the component name in ascending order
325 :     *)
326 :     fun getElemDefs (strDef,mkStamp,depth): (S.symbol * constraint) list =
327 :     let val comps =
328 :     (case strDef
329 :     of CONSTstrDef (STR {sign = SIG {elements,...},
330 :     rlzn as {entities,...}, ... }) =>
331 :     List.mapPartial
332 :     (fn (sym,STRspec{sign,entVar,def,slot}) =>
333 :     (debugmsg (">>getElemDefs.C: STRspec " ^
334 :     Symbol.name sym);
335 :     SOME(sym,SDEFINE(CONSTstrDef(
336 :     STR{sign=sign,
337 :     rlzn=EE.lookStrEnt(entities,
338 :     entVar),
339 :     access=A.nullAcc,
340 : blume 2222 prim=[]}),
341 : blume 902 depth))
342 :     before debugmsg ("<<getElemDefs.C: STRspec " ^
343 :     Symbol.name sym))
344 : dbm 2571 | (sym,(TYCspec{entVar,...})) =>
345 : blume 902 (debugmsg (">>getElemDefs.C: TYCspec " ^
346 :     Symbol.name sym);
347 :     let val tyc' = EE.lookTycEnt(entities,entVar)
348 :     val tycInst = extTycToTycInst tyc'
349 :     in debugType("#getElemDefs:TYCspec",tyc');
350 :     SOME(sym,TDEFINE(tycInst,depth))
351 :     end)
352 :     | _ => NONE)
353 :     elements
354 :     | VARstrDef(SIG {elements,...},entPath) =>
355 :     List.mapPartial
356 :     (fn (sym,STRspec{sign,entVar,def,slot}) =>
357 :     (debugmsg (">>getElemDefs.V: STRspec " ^ Symbol.name sym
358 :     ^", entPath: "^EP.entPathToString entPath
359 :     ^", entVar: "^EP.entVarToString entVar);
360 :     SOME(sym,SDEFINE(VARstrDef(sign,entPath@[entVar]),depth)))
361 : dbm 2571 | (sym,TYCspec{entVar,
362 :     info=RegTycSpec{spec=tyc,repl,scope}}) =>
363 :     (debugmsg (">>getElemDefs.V: TYCspec(Reg) " ^ Symbol.name sym
364 : blume 902 ^", entPath: "^EP.entPathToString entPath
365 :     ^", entVar: "^EP.entVarToString entVar);
366 :     SOME(sym,TDEFINE(NOTINST(
367 :     PATHtyc{arity=TU.tyconArity tyc,
368 :     entPath=entPath@[entVar],
369 :     path=TU.tycPath tyc}),
370 :     depth)))
371 : dbm 2571 | (sym,TYCspec{entVar,info=InfTycSpec{name,arity}}) =>
372 :     (debugmsg (">>getElemDefs.V: TYCspec(Inf) " ^ Symbol.name sym
373 :     ^", entPath: "^EP.entPathToString entPath
374 :     ^", entVar: "^EP.entVarToString entVar);
375 :     SOME(sym,TDEFINE(NOTINST(
376 :     PATHtyc{arity=arity,
377 :     entPath=entPath@[entVar],
378 :     path=IP.extend(IP.empty,name)}),
379 :     depth)))
380 : blume 902 | _ => NONE)
381 :     elements
382 :     | CONSTstrDef ERRORstr => nil
383 :     | _ => bug "getElemDefs")
384 :     in ListMergeSort.sort(fn((s1,_),(s2,_)) => S.symbolGt(s1,s2)) comps
385 :     end
386 :    
387 :    
388 :     (* mkElemSlots: Signature * slotEnv * IP.path * entityPath * int
389 :     * -> slotEnv * (S.symbol * slot) list
390 :     *
391 :     * create slots with initial insts for the components of the signature
392 :     * for a structure spec. slots are associated with element names and
393 : dbm 2737 * sorted in ascending order by element name. The slots are also
394 :     * added to the inherited slotEnv, bound to the corresponding element's
395 :     * entityVar, and the augmented slotEnv is returned.
396 : blume 902 *)
397 :     fun mkElemSlots(SIG {elements,...},slotEnv,rpath,epath,sigDepth) =
398 :     let fun mkSlot((sym,STRspec{sign as SIG {closed,...},
399 :     entVar,def,...}),slotEnv) =
400 :     (* a definitional structure spec is translated into a SDEFINE
401 :     * constraint *)
402 :     let val constraints =
403 :     case def
404 :     of NONE => []
405 :     | SOME(strDef,scope) => [SDEFINE(strDef,sigDepth-scope)]
406 :     in SOME (entVar, ref(InitialStr{sign=sign,
407 :     sigDepth=sigDepth,
408 :     path=IP.extend(rpath,sym),
409 :     slotEnv=(if closed then nil
410 :     else slotEnv),
411 :     epath=epath@[entVar],
412 :     inherited=ref constraints}))
413 :     end
414 :     | mkSlot((sym,STRspec{sign as ERRORsig,entVar,...}),slotEnv) =
415 :     SOME (entVar, ref(ErrorStr))
416 : dbm 2571 | mkSlot((sym,TYCspec{entVar,info=RegTycSpec{spec=tycon,repl,scope}}),
417 :     slotEnv) =
418 : blume 902 (case tycon
419 :     of DEFtyc{stamp,path,tyfun=TYFUN{arity,...},...} =>
420 :     (* translate a DEFtyc spec into a TDEFINE constraint *)
421 :     let val tycon' = GENtyc{stamp=stamp,arity=arity,path=path,
422 :     eq=ref(IND),kind=FORMAL,
423 :     stub = NONE}
424 :     in SOME(entVar,
425 :     ref(InitialTyc
426 :     {tycon=tycon',
427 :     path=IP.extend(rpath,sym),
428 :     epath=epath@[entVar],
429 :     inherited=ref[TDEFINE(NOTINST tycon,
430 :     sigDepth-scope)]}))
431 :     end
432 :     | _ =>
433 :     SOME(entVar,
434 :     ref(InitialTyc{tycon=tycon,
435 :     path=IP.extend(rpath,sym),
436 :     epath=epath@[entVar],
437 :     inherited=ref []})))
438 :     | mkSlot((sym,FCTspec{sign,entVar,...}),slotEnv) =
439 :     SOME (entVar,ref(FinalFct{sign=sign, def=ref NONE,
440 :     epath=epath@[entVar],
441 :     path=IP.extend(rpath,sym)}))
442 :     | mkSlot _ = NONE (* value element *)
443 :    
444 :     fun mkSlots(nil,slotEnv,slots) =
445 : dbm 2737 (slotEnv, ListMergeSort.sort
446 :     (fn((s1,_),(s2,_)) => S.symbolGt(s1,s2)) slots)
447 : blume 902 | mkSlots((element as (sym,_))::rest,slotEnv,slots) =
448 :     (case mkSlot(element,slotEnv)
449 :     of SOME(binder as (_,slot)) =>
450 :     mkSlots(rest, binder::slotEnv, (sym,slot)::slots)
451 :     | NONE => mkSlots(rest, slotEnv, slots))
452 :    
453 :     in mkSlots(elements,slotEnv,nil)
454 :     end
455 :     | mkElemSlots _ = bug "mkElemSlots"
456 :    
457 :    
458 :     (* debugging wrappers
459 :     val getSubSigs = wrap "getSubSigs" getSubSigs
460 :     val getElemDefs = wrap "getElemDefs" getElemDefs
461 :     val mkElemSlots = wrap "mkElemSlots" mkElemSlots
462 :     *)
463 :    
464 :     (* propDefs : (symbol * slot) list * (symbol * constraint) list -> unit
465 :     *
466 :     * Propogate definition constraints down to the components of a
467 :     * structure node that has a definition constraint. Called only
468 :     * in constrain in buildStrClass, i.e. when propogating constraints
469 :     * to children of a node.
470 :     *
471 :     * NOTE: does not check that each element in the first list has
472 :     * an associated constraint in the second list.
473 :     *
474 : dbm 2739 * ASSERT: both arguments of propDefs are sorted in ascending order by the
475 :     * symbol component (the arguments are produced by mkElementSlots and
476 : blume 902 * getElemDefs, respectively).
477 :     *
478 :     * ASSERT: all constraints in the second argument are SDEFINE or TDEFINE,
479 :     * as appropriate.
480 :     *)
481 :     fun propDefs(nil,_) = ()
482 :     | propDefs(_,nil) = ()
483 :     | propDefs(a1 as (sym1,sl)::rest1, a2 as (sym2,def)::rest2) =
484 :     if S.symbolGt(sym1,sym2) then propDefs(a1,rest2)
485 :     else if S.symbolGt(sym2,sym1) then propDefs(rest1,a2)
486 :     else (case !sl
487 :     of InitialStr {inherited, ...} => push(inherited, def)
488 :     | InitialTyc {inherited, ...} => push(inherited, def)
489 :     | ErrorStr => (error_found := true)
490 :     | ErrorTyc => ()
491 :     | _ => bug "propDefs";
492 :     propDefs(rest1,rest2))
493 :    
494 :    
495 :     (* propSharing : (S.symbol * slot) list * (S.symbol * slot) list -> unit
496 :     *
497 : dbm 2737 * Propogates inherited sharing constraints (SHARE) to the common
498 :     * elements of two structure nodes that are made to share by addInst
499 :     * (in buildStrClass).
500 : blume 902 *
501 :     * ASSERT: both arguments of propSharing are sorted in assending order by the
502 :     * symbol component.
503 :     *
504 :     * ASSERT: matching slots are either both InitialStr, both InitialTyc,
505 :     * or one is ErrorStr or ErrorTyc.
506 :     *)
507 :     fun propSharing(nil,_,_) = ()
508 :     | propSharing(_,nil,_) = ()
509 :     | propSharing(a1 as (sym1,slot1)::rest1,
510 :     a2 as (sym2,slot2)::rest2,
511 :     depth) =
512 :     if S.symbolGt(sym1,sym2) then propSharing(a1,rest2,depth)
513 :     else if S.symbolGt(sym2,sym1) then propSharing(rest1,a2,depth)
514 :     else (case (!slot1, !slot2)
515 :     of (InitialStr {inherited=inherited1, ...},
516 :     InitialStr {inherited=inherited2, ...}) =>
517 :     (push(inherited1,
518 :     SHARE{my_path=SP.empty,its_ancestor=slot2,
519 :     its_path=SP.empty,depth=depth});
520 :     push(inherited2,
521 :     SHARE{my_path=SP.empty,its_ancestor=slot1,
522 :     its_path=SP.empty,depth=depth}))
523 :     | (InitialTyc {inherited=inherited1, ...},
524 :     InitialTyc {inherited=inherited2, ...}) =>
525 :     (push(inherited1,
526 :     SHARE{my_path=SP.empty,its_ancestor=slot2,
527 :     its_path=SP.empty,depth=depth});
528 :     push(inherited2,
529 :     SHARE{my_path=SP.empty,its_ancestor=slot1,
530 :     its_path=SP.empty,depth=depth}))
531 :     | (ErrorStr,_) => ()
532 :     | (_,ErrorStr) => ()
533 :     | (ErrorTyc,_) => ()
534 :     | (_,ErrorTyc) => ()
535 :     | _ => bug "propSharing";
536 :     propSharing(rest1,rest2,depth))
537 :    
538 :    
539 :     (* debugging wrappers
540 :     val propSharing = wrap "propSharing" propSharing
541 :     *)
542 :    
543 :    
544 :     (**************************************************************************
545 : dbm 2737 * distributeS : Signature * slotEnv * int -> unit *
546 : blume 902 * *
547 :     * This function distributes the structure sharing constraints of a *
548 :     * signature to the children of a corresponding node. Note that this *
549 :     * only deals with the explicit constraints. Implied and inherited *
550 :     * constraints are propogated by propSharing and the constrain functions *
551 :     * of buildStrClass and buildTycClass. *
552 :     **************************************************************************)
553 :     exception DistributeS
554 :    
555 : dbm 2737 fun distributeS (sign as SIG {strsharing,...}, slotEnv, sigDepth) =
556 : blume 902 let fun stepPath (SP.SPATH(sym::path)) =
557 :     let val slot = getElemSlot(sym,sign,slotEnv)
558 :     in case !slot
559 :     of InitialStr{inherited, ...} =>
560 :     (SP.SPATH path, inherited, slot)
561 :     | ErrorStr => raise DistributeS
562 :     | _ => bug "distributeS.stepPath 1"
563 :     end
564 :     | stepPath (SP.SPATH []) = bug "distributeS.stepPath 2"
565 :    
566 :     fun distShare (p::rest) =
567 :     let val (p1, h1, slot1) = stepPath p
568 :     fun addConstraints (p2, h2, slot2) =
569 :     (push(h1,SHARE{my_path=p1, its_path=p2, its_ancestor=slot2,
570 :     depth=sigDepth});
571 :     push(h2,SHARE{my_path=p2, its_path=p1, its_ancestor=slot1,
572 :     depth=sigDepth}))
573 :     in app (fn p' => addConstraints (stepPath p')) rest
574 :     end
575 :     | distShare [] = ()
576 :    
577 :     in (app distShare strsharing) handle DistributeS => ()
578 :     end
579 :     | distributeS _ = ()
580 :    
581 :    
582 :     (****************************************************************************
583 : dbm 2737 * distributeT : Signature * slotEnv * (unit->stamp) * int -> unit *
584 : blume 902 * *
585 : dbm 2737 * This function distributes the signature's type sharing constraints *
586 :     * into the inherited fields of the instances for the children of the *
587 :     * corresponding node. *
588 : blume 902 ****************************************************************************)
589 :     exception DistributeT
590 :    
591 :     fun distributeT (sign as SIG {typsharing,...},
592 : dbm 2737 slotEnv, mkStamp, sigDepth) =
593 : blume 902 let fun stepPath(SP.SPATH[sym]) =
594 :     let val slot = getElemSlot(sym,sign,slotEnv)
595 :     in case !slot
596 :     of InitialTyc {inherited, ...} =>
597 :     (SP.SPATH[], inherited, slot)
598 :     | ErrorTyc => raise DistributeT
599 :     | _ => bug "distributeT:stepPath 1"
600 :     end
601 :     | stepPath(SP.SPATH(sym::path)) =
602 :     let val slot = getElemSlot(sym,sign,slotEnv)
603 :     in case !slot
604 :     of InitialStr {inherited, ...} =>
605 :     (SP.SPATH path, inherited, slot)
606 :     | ErrorStr => raise DistributeT
607 :     | _ => bug "distributeT:stepPath 2"
608 :     end
609 :     | stepPath _ = bug "distributeT:stepPath 3"
610 :    
611 :     fun distShare (p::rest) =
612 :     let val (p1,h1,slot1) = stepPath p
613 :     (* stepPath might raise MU.Unbound if there were errors
614 :     in the signature (testing/modules/tests/101.sml) *)
615 : dbm 2737 fun addConstraints (p2, h2, slot2) =
616 : blume 902 (push(h1,SHARE{my_path=p1, its_path=p2, its_ancestor=slot2,
617 :     depth=sigDepth});
618 :     push(h2,SHARE{my_path=p2, its_path=p1, its_ancestor=slot1,
619 :     depth=sigDepth}))
620 : dbm 2737 in app (fn p' => addConstraints (stepPath p')) rest
621 : blume 902 end
622 :     | distShare [] = ()
623 :    
624 :     in (app distShare typsharing) handle DistributeT => ()
625 :     end
626 :     | distributeT _ = ()
627 :    
628 :     (* debugging wrappers
629 :     val distributeS = wrap "distributeS" distributeS
630 :     val distributeT = wrap "distributeT" distributeT
631 :     *)
632 :    
633 :     exception ExploreInst of IP.path
634 :    
635 :    
636 : dbm 2739 (* THIS COMMENT PARTLY OBSOLETE? *)
637 : blume 902 (***************************************************************************
638 : dbm 2739 * buildStrClass : slot * int * (unit -> stamp) * EM.complainer
639 : blume 902 * -> unit
640 :     *
641 :     * The slot argument is assumed to contain an InitialStr.
642 :     * This function computes the equivalence class of the structure
643 :     * element associated with the slot. It proceeds as follows:
644 :     *
645 :     * 1. New slots are created for the elements of the signature.
646 :     *
647 :     * 2. The InitialStr is replaced by a PartialStr.
648 :     *
649 :     * 3. The signature's explicit type and structure sharing constraints are
650 :     * propogated to the member elements using distributeS and distributeT.
651 :     *
652 : dbm 2738 * 4. This node's inherited constraints are processed, using constrain.
653 :     * If a constraint equates an element to this node,
654 : dbm 2739 * the equivalence class is enlarged (using addIns)t or
655 : blume 902 * a definition is set (classDef). If a constraint applies to children
656 : dbm 2737 * of this node, it is propogated to the children. Processing a
657 : blume 902 * sharing constraint may require that an ancestor of the other node
658 :     * in the constraint first be explored by buildStrClass.
659 : dbm 2738 * Once constrain returns, class contains a list of equivalent PartialStr
660 : blume 902 * nodes that constitute the sharing equivalence class of the original
661 :     * node (thisSlot).
662 :     *
663 :     * 5. finalize is applied to the members of the class to turn them
664 :     * into FinalStrs. The FinalStrs are memoized in the PartialStr
665 :     * nodes to insure that equivalent nodes that have the same signature
666 :     * will contain the same FinalStr value.
667 :     *
668 :     * If two slots in the class have nodes that share the same signature,
669 : dbm 2739 * then the slots are made to point to the same PartialStr node. Of course,
670 : blume 902 * the sharing constraints for both must be propogated to the descendants.
671 :     *
672 :     ***************************************************************************)
673 :    
674 :     (* ASSERT: this_slot is an InitialStr *)
675 :     fun buildStrClass (this_slot: slot, classDepth: int,
676 : dbm 2738 mkStamp, err: EM.complainer) : unit =
677 : blume 902 let val class = ref ([this_slot] : slot list) (* the equivalence class *)
678 :     val classDef = ref (NONE : (strDef * int) option)
679 :     val minDepth = ref infinity
680 :     (* minimum signature nesting depth of the sharing constraints used
681 :     * in the construction of the equivalence class. *)
682 :    
683 :     (* for error messages *)
684 :     val this_path =
685 :     case !this_slot
686 :     of InitialStr{path,...} => ConvertPaths.invertIPath path
687 : dbm 3347 | _ => bug "buildStrClass: this_slot not InitialTyc"
688 : blume 902
689 :     (* addInst(old,new,depth);
690 :     * (1) Adds new to the current equivalence class in response to a sharing
691 :     * constraint relating old to new.
692 : dbm 2737 * (2) Converts the new node from InitialStr to PartialStr. Propagates sharing
693 :     * to the respective common components. Propagate downward the sharing
694 :    
695 : blume 902 * constraints in new's signature. Then apply constrain to each of the
696 :     * inherited constraints.
697 :     * depth is the signature nesting depth of this sharing constraint. *)
698 :     fun addInst (old: slot, new: slot, depth: int) : unit =
699 :     (minDepth := Int.min(!minDepth, depth);
700 :     case !new
701 :     of ErrorStr => ()
702 : dbm 2737 | PartialStr {depth, path, ...} =>
703 : blume 902 if (depth = classDepth) then () (* member current class *)
704 :     else raise ExploreInst path (* member of pending class *)
705 : dbm 2737 | InitialStr {sign, sigDepth, path, slotEnv, inherited, epath} =>
706 : blume 902 (case !old
707 : dbm 2737 of (p as (PartialStr{sign=oldSign,
708 :     slotEnv=oldSlotEnv,
709 : blume 902 comps=oldComps,...})) =>
710 : dbm 2737 if eqSig(sign,oldSign) then (* same sig *)
711 : blume 902 (new := p; (* share the old instance *)
712 :     push(class,new); (* add new slot to class *)
713 : dbm 2737 constrain(new,!inherited,sign,oldSlotEnv,path))
714 : blume 902 (* may be new inherited constraints *)
715 : dbm 2737 else (* new has different sig *)
716 : blume 902 (let val sigDepth' = sigDepth + 1
717 : dbm 2737 val (newSlotEnv,newComps) =
718 : blume 902 mkElemSlots(sign,slotEnv,path,epath,sigDepth')
719 :     in new := PartialStr{sign=sign,path=path,
720 : dbm 2737 slotEnv=newSlotEnv,
721 : blume 902 comps=newComps,
722 :     final_rep = ref NONE,
723 :     depth=classDepth};
724 : dbm 2737 push(class,new); (* add new to the class *)
725 : blume 902 propSharing(oldComps,newComps,depth);
726 : dbm 2737 distributeS (sign, newSlotEnv, sigDepth');
727 :     distributeT (sign, newSlotEnv, mkStamp,
728 : blume 902 sigDepth');
729 : dbm 2737 constrain (new, !inherited, sign, newSlotEnv, path)
730 : blume 902 end
731 :     handle (MU.Unbound _) => (* bad sharing paths *)
732 :     (error_found := true;
733 :     new := ErrorStr))
734 :     | ErrorStr => ()
735 :     (* could do more in this case -- all the above
736 :     * except for propSharing *)
737 :     | _ => bug "addInst 1")
738 :     | _ => if !error_found then new := ErrorStr
739 :     else bug "addInst.2")
740 :    
741 : dbm 2737
742 : blume 902 and constrain (oldSlot, inherited, sign, slotEnv, path) =
743 :     (* Class shares with some external structure *)
744 :     let fun constrain1 constraint =
745 :     case constraint
746 :     of (SDEFINE(strDef,depth)) =>
747 :     (debugmsg "constrain: SDEFINE";
748 :     case !classDef
749 :     of SOME _ =>
750 :     (* already defined -- ignore secondary definitions *)
751 :     if !ElabControl.multDefWarn then
752 :     err EM.WARN
753 :     ("multiple defs at structure spec: "
754 :     ^ SP.toString(ConvertPaths.invertIPath path)
755 :     ^ "\n (secondary definitions ignored)")
756 :     EM.nullErrorBody
757 :     else ()
758 :     | NONE =>
759 :     let val comps = case !oldSlot of
760 :     PartialStr x => #comps x
761 :     | _ => bug "constrain:PartialStr"
762 :     in classDef := SOME(strDef,depth);
763 :     propDefs (comps,getElemDefs(strDef,mkStamp,depth))
764 :     end)
765 :    
766 :     (* Class shares with the structure in slot -- explore it *)
767 :     | SHARE{my_path=SP.SPATH[],its_ancestor=newSlot,
768 :     its_path=SP.SPATH [], depth} =>
769 :     (debugmsg "<calling addInst to add member to this equiv class>";
770 :     addInst(oldSlot,newSlot,depth)
771 :     handle (ExploreInst path') =>
772 :     (err EM.COMPLAIN
773 :     "sharing structure with a descendent substructure"
774 :     EM.nullErrorBody;
775 :     newSlot := ErrorStr))
776 :    
777 :     (* Class shares with another structure. Make sure its ancestor
778 :     * has been explored. Then push the constraint down a level.
779 :     *)
780 :     | SHARE{my_path=SP.SPATH[],its_ancestor=slot,
781 :     its_path=SP.SPATH(sym::rest),depth} =>
782 :     (case (!slot)
783 :     of InitialStr _ =>
784 :     (debugmsg "<Having to call buildStrClass on an ancestor \
785 :     \of a node I'm equivalent to.>";
786 : dbm 2738 buildStrClass (slot, (classDepth+1), mkStamp, err)
787 : blume 902 handle (ExploreInst _) => bug "buildStrClass.4")
788 :     | ErrorStr => ()
789 :     | _ => ();
790 :    
791 :     debugmsg "<finished exploring his ancestor>";
792 :    
793 :     case (!slot)
794 :     of FinalStr {sign=sign', slotEnv=slotEnv', ...} =>
795 :     (debugmsg "<calling constrain recursively>";
796 :     constrain (oldSlot,
797 :     [SHARE{my_path=SP.SPATH[], its_path=SP.SPATH rest,
798 :     its_ancestor=getElemSlot(sym,sign',slotEnv'),
799 :     depth=depth}],
800 :     sign, slotEnv, path))
801 :     | PartialStr _ => (* do we need to check depth? *)
802 :     (err EM.COMPLAIN
803 :     "Sharing structure with a descendent substructure"
804 :     EM.nullErrorBody;
805 :     slot := ErrorStr)
806 :     | ErrorStr => ()
807 :     | _ => bug "buildStrClass.5")
808 :    
809 :     (* One of the node's children shares with someone. Push the
810 :     * constraint down to the child now that we are explored.
811 :     *)
812 :     | SHARE{my_path=SP.SPATH(sym::rest),
813 :     its_ancestor, its_path, depth} =>
814 :     let val { elements, ... } =
815 :     case sign of SIG s => s
816 :     | _ => bug "instantiate:constrain:SIG"
817 :     in case MU.getSpec(elements,sym)
818 : dbm 2571 of TYCspec{entVar,info=RegTycSpec{spec=tycon,repl,scope}} =>
819 : blume 902 (* ASSERT: rest = nil *)
820 :     (case !(lookSlot(slotEnv,entVar))
821 :     of InitialTyc {inherited, ...} =>
822 :     push(inherited,
823 :     SHARE{my_path=SP.SPATH[],
824 :     its_ancestor=its_ancestor,
825 :     its_path=its_path,depth=depth})
826 :     | _ => bug "buildStrClass.6")
827 :     | STRspec{entVar,...} =>
828 :     (case !(lookSlot(slotEnv,entVar))
829 :     of InitialStr {inherited, ...} =>
830 :     push(inherited,
831 :     SHARE{my_path=SP.SPATH rest,
832 :     its_ancestor=its_ancestor,
833 :     its_path=its_path,depth=depth})
834 :     | _ => bug "buildStrClass.7")
835 :     | _ => bug "buildStrClass.8"
836 :     end
837 :     | _ => bug "buildStrClass.9"
838 :     in app constrain1 (rev inherited)
839 :     end
840 :    
841 :     (*
842 :     * Converts all of the nodes in the class (which should be PartialStr)
843 :     * to Final nodes. Note that nodes which share the same signature
844 :     * should share the same FinalStr nodes. So, they are memoized using
845 :     * the final_rep field of the PartialStr node.
846 :     *)
847 :     fun finalize (stampInfoRef: stampInfo ref) slot =
848 :     case (!slot)
849 :     of ErrorStr => ()
850 :     | PartialStr {sign, path, slotEnv, final_rep, ...} =>
851 :     (case !final_rep
852 :     of SOME inst => slot := inst
853 :     | NONE =>
854 :     let val finalEnt =
855 :     case !classDef
856 :     of SOME(CONSTstrDef(STR{sign=sign',
857 :     rlzn, ... }),_) =>
858 :     if eqSig(sign,sign') then CONST_ENT rlzn
859 :     else GENERATE_ENT true
860 :     | SOME(VARstrDef(sign',entPath),_) =>
861 :     (* if eqSig(sign,sign') then PATH_ENT(entPath)
862 :     * else ...
863 :     * DBM: removed to fix bug 1445. Even when
864 :     * the signatures are equal, a free entvar
865 :     * reverence can be propogated by the structure
866 :     * declaration. See bug1445.1.sml. *)
867 :     GENERATE_ENT false
868 :     | SOME(CONSTstrDef(ERRORstr),_) =>
869 :     CONST_ENT bogusStrEntity
870 :     | NONE => GENERATE_ENT true
871 :     | _ => bug "buildStrClass.finalize 1"
872 :     val inst =
873 :     FinalStr {sign = sign,
874 :     stamp = stampInfoRef,
875 :     slotEnv = slotEnv,
876 :     finalEnt = ref finalEnt,
877 :     expanded = ref false}
878 :     in final_rep := SOME inst; (* memoize *)
879 :     slot := inst
880 :     end)
881 :     | _ => bug "buildStrClass.finalize 2"
882 :    
883 :     (* Should find everyone in the equiv. class and convert them to
884 :     * PartialStr nodes.
885 :     *)
886 :     in (* explore equivalence class, filling the class ref with a
887 :     * list of PartialStr insts *)
888 :     case !this_slot (* verify that this_slot is InitialStr *)
889 :     of (InitialStr {sign, sigDepth, path, slotEnv, inherited, epath}) =>
890 :     (let val sigDepth' = sigDepth + 1
891 :     val (slotEnv',newComps) =
892 :     mkElemSlots(sign,slotEnv,path,epath,sigDepth')
893 :     in this_slot :=
894 :     PartialStr{sign=sign,path=path,
895 :     slotEnv=slotEnv',
896 :     comps=newComps,
897 :     final_rep = ref NONE,
898 :     depth=classDepth};
899 : dbm 2737 distributeS (sign, slotEnv', sigDepth');
900 :     distributeT (sign, slotEnv', mkStamp, sigDepth');
901 : blume 902 constrain (this_slot, !inherited, sign, slotEnv', path)
902 :     end
903 :     handle (MU.Unbound _) => (* bad sharing paths *)
904 :     (error_found := true;
905 :     this_slot := ErrorStr))
906 :    
907 :     | _ => bug "buildStrClass.10"; (* not InitialStr *)
908 :    
909 :     (* BUG: needs fixing. DBM *)
910 :     (* verify that any class definition is defined outside of the
911 :     * outermost sharing constraint *)
912 :     case !classDef
913 :     of NONE => () (* no definition - ok *)
914 :     | SOME(_,depth) =>
915 :     if !minDepth <= depth
916 :     then (if !ElabControl.shareDefError
917 :     then classDef := SOME(CONSTstrDef ERRORstr,0)
918 :     else ();
919 :     err (if !ElabControl.shareDefError
920 :     then EM.COMPLAIN
921 :     else EM.WARN)
922 :     ("structure definition spec inside of sharing at: "^
923 :     SymPath.toString this_path)
924 :     EM.nullErrorBody)
925 :     else ();
926 :    
927 :     let val classStampInfo =
928 :     ref(case !classDef
929 :     of SOME(CONSTstrDef str,_) => STAMP(MU.getStrStamp str)
930 :     | SOME(VARstrDef(_,entPath),_) => PATH(entPath)
931 :     | NONE => GENERATE)
932 :    
933 :     in app (finalize classStampInfo) (!class)
934 :     end
935 :     end (* buildStrClass *)
936 :    
937 :     (* debugging wrappers
938 :     val buildStrClass = wrap "buildStrClass" buildStrClass
939 :     *)
940 :    
941 :     exception INCONSISTENT_EQ
942 :     (* raised if tycons with both YES and NO eqprops are found in an
943 :     * equivalence class *)
944 :    
945 :     (*************************************************************************
946 :     * buildTycClass: int * slot * entityEnv * instKind * rpath * (unit->stamp)
947 : dbm 2739 * * EM.complainer
948 : dbm 3347 * -> tycon option
949 : blume 902 *
950 :     * This function deals with exploration of type nodes in the instance
951 :     * graph. It is similar to the buildStrClass function above, but it is
952 :     * simpler since it doesn't have to worry about "children" of
953 :     * type nodes. However, we must check that the arities of equivalenced
954 :     * types are the same. Also, if they have constructors, we must check
955 :     * to see that they have the same constructor names. We don't know how
956 :     * to check that the types of the constructors are satisfiable -- this
957 :     * involves a limited form of second-order unification.
958 :     *
959 :     * But then, probably we should only allow two datatypes to be shared if their
960 :     * types are completely equivalent; otherwise, the behavior of the elaboration
961 :     * would be rather odd sometimes. (ZHONG)
962 :     *
963 : dbm 2739 * buildTycClass is only called once, in the InitialTyc case of expandInst
964 :     * in expand in sigToInst
965 : blume 902 *************************************************************************)
966 :    
967 : dbm 2739 (* ASSERT: this_slot is an InitialTyc
968 :     * This is clearly true given that buildTycClass is only called in
969 :     * a case branch (in expandInst) where the pattern is InitialTyc *)
970 : dbm 3347 fun buildTycClass (this_slot, instKind, rpath, mkStamp, err) =
971 : blume 902 let val class = ref ([] : slot list)
972 :     val classDef = ref (NONE : (tycInst * int) option)
973 :     val minDepth = ref infinity
974 :     (* minimum signature nesting depth of the sharing constraints used
975 :     * in the construction of the equivalence class. *)
976 :    
977 :     (* for error messages *)
978 :     val this_path =
979 :     case !this_slot
980 :     of InitialTyc{path,...} => ConvertPaths.invertIPath path
981 :     | _ => bug "buildTycClass: this_slot not InitialTyc"
982 :    
983 :     fun addInst (slot,depth)=
984 :     (minDepth := Int.min(!minDepth, depth);
985 :     case !slot
986 :     of InitialTyc {tycon, path, epath, inherited} =>
987 :     (debugmsg "<setting InitialTyc to PartialTyc>";
988 :     slot := PartialTyc{tycon=tycon, path=path, epath=epath};
989 :     push(class,slot);
990 :     app constrain (rev(!inherited)))
991 :     | PartialTyc _ => ()
992 :     | ErrorTyc => ()
993 :     | _ => bug "buildTycClass.addInst")
994 :    
995 :     and constrain (def as TDEFINE(d as (tycInst2,depth))) =
996 :     (case !classDef
997 :     of SOME _ =>
998 :     (* already defined -- ignore secondary definitions *)
999 :     if !ElabControl.multDefWarn then
1000 :     err EM.WARN
1001 :     ("multiple defs at tycon spec: "
1002 :     ^ SP.toString(ConvertPaths.invertIPath rpath)
1003 :     ^ "\n (secondary definitions ignored)")
1004 :     EM.nullErrorBody
1005 :     else ()
1006 :     | NONE => classDef := SOME d)
1007 :    
1008 :     | constrain (SHARE{my_path=SP.SPATH[], its_ancestor=slot,
1009 :     its_path=SP.SPATH[], depth}) =
1010 :     addInst(slot,depth)
1011 :    
1012 :     | constrain (SHARE{my_path=SP.SPATH[],its_ancestor=slot,
1013 :     its_path=SP.SPATH(sym::rest),depth}) =
1014 :     (case !slot
1015 :     of InitialStr _ =>
1016 : dbm 2738 (buildStrClass (slot, 0, mkStamp, err)
1017 : blume 902 handle ExploreInst _ => bug "buildTycClass.2")
1018 :     | _ => ();
1019 :    
1020 :     case !slot
1021 :     of FinalStr{sign, slotEnv, ...} =>
1022 :     constrain (SHARE{my_path=SP.SPATH[], its_path=SP.SPATH rest,
1023 :     its_ancestor=getElemSlot(sym,sign,slotEnv),
1024 :     depth=depth})
1025 :     | ErrorStr => ()
1026 :     | _ => bug "buildTycClass.3")
1027 :    
1028 :     | constrain _ = bug "buildTycClass:constrain.4"
1029 :    
1030 :    
1031 :     fun checkArity (ar1, ar2, path1: IP.path, path2: IP.path) =
1032 :     if ar1 = ar2 then true
1033 :     else (err EM.COMPLAIN
1034 :     ("inconsistent arities in type sharing "
1035 :     ^(pathName path1)^" = "^(pathName path2)^" : "
1036 :     ^(pathName path1)^" has arity "^(Int.toString ar1)^" and "
1037 :     ^(pathName path2)^" has arity "^(Int.toString ar2)^".")
1038 :     EM.nullErrorBody;
1039 :     false)
1040 :    
1041 :     val sortD = ListMergeSort.sort
1042 :     (fn ({name=name1,rep=_,domain=_},{name=name2,rep=_,domain=_}) =>
1043 :     S.symbolGt(name1,name2))
1044 :    
1045 :     fun eqDataCons({name=name1,rep=_,domain=_},{name=name2,rep=_,domain=_}) =
1046 :     S.eq(name1,name2)
1047 :    
1048 :     fun compareD ([], []) = true
1049 :     | compareD (d1::r1, d2::r2) =
1050 :     eqDataCons(d1,d2) andalso compareD (r1,r2)
1051 :     | compareD _ = false
1052 :    
1053 :     (* Eta-reduce type abbreviation tycons. Makes sure that DEFtyc is not
1054 :     * just an eta-expansion of another tycon.
1055 :     *)
1056 :     fun simplify(tyc0 as DEFtyc{tyfun=TYFUN{arity,body},...}) =
1057 :     (case body
1058 :     of CONty(RECORDtyc _,args) => tyc0
1059 :     | CONty(tyc,args) =>
1060 :     let fun isvars(IBOUND n ::rest,m) =
1061 :     if n = m then isvars(rest,m+1) else false
1062 :     | isvars (nil,_) = true
1063 :     | isvars _ = bug "simplify:isvars"
1064 :     in if length args = arity andalso
1065 :     isvars(map TU.prune args,0)
1066 :     then simplify tyc else tyc0
1067 :     end
1068 :     | _ => tyc0)
1069 :     | simplify tyc = tyc
1070 :    
1071 :     (*
1072 :     * Potential BUG on equality properties: when selecting the
1073 :     * candidate from a set of FORMAL tycons, the equality property
1074 :     * should be merged ... but this is not done right now (ZHONG)
1075 :     *)
1076 :    
1077 :     fun eqMax((NO, OBJ) |(NO, YES) | (YES, NO) | (OBJ, NO)) =
1078 :     raise INCONSISTENT_EQ
1079 :     | eqMax(_, YES) = YES
1080 :     | eqMax(_, OBJ) = YES
1081 :     | eqMax(ep, _) = ep
1082 :    
1083 :     (* scanForRep scans the tycons in the class, selecting a representative
1084 :     * according to the following rule:
1085 :     * if there is a datatype in the class, select the first one
1086 :     * otherwise, if there is a DEFtyc, select last of these
1087 :     (this case should go away in SML96)
1088 :     * otherwise, all the tycons are FORMAL, select last of these
1089 :     * creates a representative tycon for the class, giving
1090 :     * it a new stamp if it is a datatype or formal. *)
1091 :     fun scanForRep tyc_eps =
1092 :     let fun loop(ERRORtyc,epath,arity,eqprop,(tyc,ep)::rest) =
1093 :     (* initialization *)
1094 :     (case tyc
1095 :     of GENtyc { arity, eq, ... } =>
1096 :     loop(tyc,ep,arity,!eq,rest)
1097 :     | ERRORtyc =>
1098 :     loop(tyc,ep,0,IND,rest)
1099 :     | DEFtyc{tyfun=TYFUN{arity,...},path,...} =>
1100 :     bug "scanForRep 0"
1101 :     | _ => bug "scanForRep 1")
1102 :    
1103 :     | loop(tyc as GENtyc { kind, path = path, ... },
1104 :     epath, arity, eqprop, (tyc', epath') :: rest) =
1105 :     (case kind of
1106 :     DATATYPE _ =>
1107 :     (case tyc'
1108 :     of GENtyc {kind,arity=arity',eq,path=path',...} =>
1109 :     (checkArity(arity,arity',path,path');
1110 :     loop(tyc,epath,arity,eqMax(eqprop,!eq),rest))
1111 :     | ERRORtyc => loop(tyc,epath,arity,eqprop,rest)
1112 :     | DEFtyc{tyfun=TYFUN{arity=arity',...},
1113 :     path=path',...} =>
1114 :     bug "scanForRep 2"
1115 :     | _ => bug "scanForRep 2.1")
1116 :    
1117 :     | FORMAL =>
1118 :     (case tyc'
1119 :     of GENtyc {kind,arity=arity',eq,path=path',...} =>
1120 :     (checkArity(arity,arity',path,path');
1121 :     case kind
1122 :     of DATATYPE _ =>
1123 :     loop(tyc',epath',arity,
1124 :     eqMax(eqprop,!eq),rest)
1125 :     | _ => loop(tyc,epath,arity,
1126 :     eqMax(eqprop,!eq),rest))
1127 :     | ERRORtyc => loop(tyc,epath,arity,eqprop,rest)
1128 :     | DEFtyc{tyfun=TYFUN{arity=arity',...},
1129 :     path=path',...} =>
1130 :     bug "scanForRep 3"
1131 :     | _ => bug "scanForRep 3.1")
1132 :     | _ => bug "scanForRep 8")
1133 :     | loop(tyc,epath,arity,eprop,nil) = (tyc,epath,eprop)
1134 :    
1135 :     | loop _ = bug "scanForRep 4"
1136 :    
1137 :     val (reptyc,epath,eqprop) =
1138 :     case tyc_eps
1139 :     of [(tyc,epath)] =>
1140 :     let val eqprop =
1141 :     case tyc
1142 :     of GENtyc {eq, ...} => !eq
1143 :     | DEFtyc{tyfun=TYFUN{arity,...},...} => IND
1144 :     | ERRORtyc => IND
1145 :     | _ => bug "scanForRep 5"
1146 :     in (tyc,epath,eqprop)
1147 :     end
1148 :     | _ => loop(ERRORtyc,nil,0,IND,tyc_eps)
1149 :     in
1150 :     case reptyc
1151 :     of GENtyc {kind,arity,eq,path,...} =>
1152 :     (case kind
1153 :     of FORMAL =>
1154 : dbm 3291 let val knd =
1155 :     case instKind
1156 :     of INST_ABSTR {entities,...} =>
1157 :     T.ABSTRACT(EE.lookTycEP (entities, epath))
1158 :     | INST_FORMAL => T.FORMAL
1159 : blume 902 val tyc = GENtyc{stamp=mkStamp(), arity=arity,
1160 :     path=IP.append(rpath,path),
1161 :     kind=knd, eq=ref(eqprop),
1162 :     stub = NONE}
1163 : dbm 3347 in (FinalTyc(ref(INST tyc)), SOME tyc)
1164 : blume 902 end
1165 :     | DATATYPE _ =>
1166 :     let val tyc = GENtyc{stamp=mkStamp(), kind=kind,
1167 :     arity=arity, stub = NONE,
1168 :     eq=ref(eqprop), path=path}
1169 :     in (FinalTyc(ref(NOTINST tyc)), NONE)
1170 :     (* domains of dataconstructors will be instantiated
1171 :     * in instToTyc *)
1172 :     end
1173 : dbm 3347 | _ => bug "scanForRep 6")
1174 : blume 902 | ERRORtyc => (FinalTyc(ref(INST ERRORtyc)), NONE)
1175 : dbm 3347 | DEFtyc _ => bug "scanForRep 7"
1176 :     | _ => bug "scanForRep 8"
1177 : gkuan 2735 end (* fun scanForRep *)
1178 : blume 902
1179 :     fun getSlotEp slot =
1180 :     case !slot
1181 :     of PartialTyc{tycon, epath, ...} => (tycon, epath)
1182 :     | ErrorTyc => (ERRORtyc, nil: EP.entPath)
1183 :     | _ => bug "getSlotEp"
1184 :    
1185 :     fun finalize(defOp,slots) =
1186 :     let val (finalInst, tcOp) =
1187 :     case defOp
1188 :     of SOME(tycInst,_) => (FinalTyc(ref(tycInst)), NONE)
1189 :     | NONE =>
1190 :     (scanForRep(map getSlotEp slots)
1191 :     handle INCONSISTENT_EQ =>
1192 :     (err EM.COMPLAIN
1193 :     "inconsistent equality properties in type sharing"
1194 :     EM.nullErrorBody;
1195 :     (ErrorTyc,NONE)))
1196 :     in app (fn sl => sl := finalInst) slots;
1197 :     tcOp
1198 :     end
1199 :    
1200 :     val _ = addInst(this_slot,infinity)
1201 :    
1202 :     (* DBM: needs fixing (like the similar case in buildStrClass) *)
1203 :     (* verify that any class definition is defined outside of the
1204 :     * outermost sharing constraint *)
1205 :     val _ = case !classDef
1206 :     of NONE => () (* no definition - ok *)
1207 :     | SOME(_,depth) =>
1208 :     if !minDepth <= depth
1209 :     then (if !ElabControl.shareDefError
1210 :     then classDef := SOME(INST(ERRORtyc),0)
1211 :     else ();
1212 :     err (if !ElabControl.shareDefError
1213 :     then EM.COMPLAIN
1214 :     else EM.WARN)
1215 :     ("type definition spec inside of sharing at: "^
1216 :     SymPath.toString this_path)
1217 :     EM.nullErrorBody)
1218 :     else ()
1219 :    
1220 :     in finalize(!classDef,!class)
1221 :     end (* buildTycClass *)
1222 :    
1223 :     (* debugging wrapper
1224 :     val buildTycClass = wrap "buildTycClass" buildTycClass
1225 :     *)
1226 :    
1227 : dbm 2738 fun sigToInst (ERRORsig, instKind, rpath, err, compInfo) =
1228 : dbm 3347 (ErrorStr,[])
1229 : dbm 2738 | sigToInst (sign, instKind, rpath, err,
1230 : blume 902 compInfo as {mkStamp,...}: EU.compInfo) =
1231 : dbm 3347 let val primaryTycs : T.tycon list ref = ref [] (* the "primary" tycons *)
1232 : blume 902
1233 :     fun expand ErrorStr = ()
1234 :     | expand (FinalStr {expanded=ref true,...}) = ()
1235 :     | expand (FinalStr {sign,slotEnv,expanded,...}) =
1236 :     (*
1237 :     * We must expand the FinalStr inst in a top-down
1238 :     * fashion. So, we iterate through the bindings.
1239 :     * As we encounter structure or type element, we recursively
1240 :     * expand it.
1241 :     *)
1242 :     let fun expandInst (sym,slot) =
1243 :     (debugmsg("<Expanding element " ^ S.symbolToString sym ^ ">");
1244 :     case !slot
1245 :     of InitialStr _ =>
1246 :     (debugmsg("--expandInst: exploring InitialStr "^
1247 :     S.name sym);
1248 : dbm 2738 buildStrClass (slot, 0, mkStamp, err)
1249 : blume 902 handle ExploreInst _ => bug "expandInst 1";
1250 :    
1251 :     case !slot
1252 :     of (inst as (FinalStr _)) =>
1253 :     (debugmsg("--expandInst: expanding new FinalStr "^
1254 :     S.name sym);
1255 :     expand inst)
1256 :     | ErrorStr => ()
1257 :     | _ => bug "expand_substr 2")
1258 :     | PartialStr{path,...} =>
1259 :     bug ("expandInst: PartialStr "^IP.toString path)
1260 :     | inst as FinalStr _ =>
1261 :     (debugmsg("--expandInst: expanding old FinalStr "^
1262 :     S.name sym);
1263 :     expand inst)
1264 :     | InitialTyc _ =>
1265 : dbm 3347 (case buildTycClass(slot, instKind,
1266 :     rpath, mkStamp, err)
1267 :     of NONE => ()
1268 :     | SOME tyc => primaryTycs := (tyc::(!primaryTycs)))
1269 : blume 902 | _ => ())
1270 :    
1271 :     in debugmsg ">>expand"; expanded := true;
1272 :     app expandInst (getElemSlots(sign,slotEnv));
1273 :     debugmsg "<<expand"
1274 :     end
1275 :     | expand _ = bug "expand"
1276 :    
1277 :     val baseSlot = ref(InitialStr{sign=sign, sigDepth=1, path=rpath, epath=[],
1278 :     inherited=ref [], slotEnv=nil})
1279 :     (* correct initial value for sigDepth? *)
1280 :    
1281 : dbm 2738 val _ = buildStrClass(baseSlot, 0, mkStamp, err)
1282 : blume 902 handle (ExploreInst _) => bug "sigToInst 2"
1283 :    
1284 :     val strInst = !baseSlot
1285 :     val _ = expand strInst
1286 :    
1287 : dbm 3347 in (strInst, rev(!primaryTycs))
1288 : blume 902 end (* fun sigToInst *)
1289 :    
1290 :     exception Get_Origin (* who is going to catch it? *)
1291 :    
1292 :     fun get_stamp_info instance =
1293 :     case instance
1294 :     of (FinalStr {stamp,...}) => stamp
1295 :     | ErrorStr => raise Get_Origin
1296 :     | _ => bug "get_stamp_info"
1297 :    
1298 :    
1299 : gkuan 2961 fun instToStr (instance, entEnv, instKind, rpath: IP.path, err,
1300 : blume 902 compInfo as {mkStamp, ...}: EU.compInfo)
1301 : dbm 3347 : (M.strEntity * (ST.stamp * M.fctsig) list) =
1302 :     let val primFcts : (Stamps.stamp, M.fctsig) list = ref []
1303 :     fun instToStr' (instance as (FinalStr{sign as SIG {closed, elements,... },
1304 : blume 902 slotEnv,finalEnt,stamp,...}),
1305 :     entEnv, rpath: IP.path, failuresSoFar: int)
1306 :     : M.strEntity * int =
1307 :     (debugmsg (">>instToStr': " ^ IP.toString rpath);
1308 :     case !finalEnt
1309 :     of CONST_ENT strEnt => (strEnt,failuresSoFar) (* already visited *)
1310 :     | PATH_ENT ep =>
1311 :     (let val strEnt = EE.lookStrEP(entEnv,ep)
1312 :     in finalEnt := CONST_ENT strEnt;
1313 : dbm 2737 (strEnt,failuresSoFar)
1314 : blume 902 end
1315 : dbm 2737 handle EE.Unbound =>
1316 :     (debugmsg ("instToStr':PATH_ENT failed: "^
1317 :     EP.entPathToString ep);
1318 :     raise EE.Unbound))
1319 : blume 902 | GENERATE_ENT closedDef =>
1320 :     let
1321 :     (* Gets the stamp of an instance -- generates one if
1322 :     * one is not already built. *)
1323 :     fun getStamp instance : Stamps.stamp =
1324 :     let val stamp = get_stamp_info instance
1325 :     in case (!stamp)
1326 :     of STAMP s => (debugmsg "getStamp:STAMP"; s)
1327 :     | PATH ep =>
1328 :     (debugmsg ("getStamp:PATH "^EntPath.entPathToString ep);
1329 :     (let val {stamp=s,...} = EE.lookStrEP(entEnv,ep)
1330 :     in stamp := STAMP s; s
1331 :     end
1332 : dbm 2737 handle EE.Unbound => (debugmsg "getStamp:PATH failed";
1333 : blume 902 raise EE.Unbound)))
1334 :     | GENERATE =>
1335 :     let val s = mkStamp()
1336 :     in debugmsg "getStamp:GENERATE";
1337 : dbm 2737 stamp := STAMP s; s
1338 : blume 902 end
1339 :     end
1340 :    
1341 :     fun instToTyc(ref(INST tycon),_) = tycon
1342 :     (* already instantiated *)
1343 : dbm 2737 | instToTyc(r as ref(NOTINST tycon), entEnv) =
1344 :     let fun badtycon () = (* bogus tycon *)
1345 : blume 902 (debugType("#instToTyc(NOTINST/bogus)",tycon);
1346 :     r := INST ERRORtyc;
1347 :     ERRORtyc)
1348 :     in
1349 :     case tycon
1350 :     of T.DEFtyc{tyfun=T.TYFUN{arity, body},strict,
1351 :     stamp,path} =>
1352 :     (* DEFtyc body gets instantiated here *)
1353 :     (* debugging version *)
1354 :     (let val tc =
1355 :     (* if repl
1356 :     then (* eta reduce wrapped datatype *)
1357 :     let val T.CONty(tyc,_) = body
1358 :     in MU.transTycon entEnv tyc
1359 :     end
1360 : dbm 2737 else *)
1361 :     let val tf =
1362 :     T.TYFUN{arity=arity,
1363 :     body=MU.transType entEnv body}
1364 :     in T.DEFtyc{tyfun=tf, strict=strict,
1365 :     stamp=mkStamp(),
1366 :     path=IP.append(rpath,path)}
1367 :     end
1368 : blume 902 in debugType("#instToTyc(NOTINST/DEFtyc)",tc);
1369 :     r := INST tc;
1370 :     tc
1371 : dbm 2737 end
1372 :     handle EE.Unbound =>
1373 : blume 902 (debugmsg "#instToTyc(NOTINST/DEFtyc) failed";
1374 :     raise EE.Unbound))
1375 :    
1376 :     | T.GENtyc {stamp,arity,eq,path,kind,...} =>
1377 :     (case kind of
1378 :     z as T.DATATYPE {index,freetycs,stamps,
1379 :     family, root} =>
1380 :     (let
1381 :     (* no coordination of stamps between mutually
1382 :     * recursive families of datatypes? *)
1383 :     val nstamps =
1384 :     (case root
1385 :     of NONE =>
1386 :     (* this is the lead dt of family *)
1387 :     Vector.map
1388 :     (fn _ => mkStamp()) stamps
1389 :     | SOME rootev =>
1390 :     (* this is a secondary dt of a family,
1391 :     * find the stamp vector for the root
1392 :     * dt of the family, which should already
1393 :     * have been instantiated *)
1394 :     (case EE.lookTycEnt(entEnv, rootev)
1395 :     of T.GENtyc { kind =
1396 :     T.DATATYPE{stamps, ...},
1397 :     ... } => stamps
1398 :     | T.ERRORtyc =>
1399 :     Vector.map
1400 :     (fn _ => mkStamp()) stamps
1401 :     | _ =>
1402 :     (* oops, the root instantiation
1403 :     * is not a datatype (see bug 1414) *)
1404 :     bug "unexpected DATATYPE 354"))
1405 :     val s = Vector.sub(nstamps, index)
1406 :     val nfreetycs =
1407 :     map (MU.transTycon entEnv) freetycs
1408 :    
1409 :     val nkind =
1410 :     T.DATATYPE{index=index,
1411 :     family=family,
1412 :     stamps=nstamps,
1413 :     freetycs=nfreetycs,
1414 :     root=NONE} (* root ??? *)
1415 :    
1416 :     val tc =
1417 :     T.GENtyc{stamp=s, arity=arity, eq=eq,
1418 :     path=IP.append(rpath,path),
1419 :     kind=nkind,stub=NONE}
1420 :    
1421 :     in
1422 :     r := INST tc;
1423 :     tc
1424 :     end handle EE.Unbound =>
1425 :     (debugmsg "#instToTyc(NOTINST/DATA) failed";
1426 :     raise EE.Unbound))
1427 :     | _ => badtycon ())
1428 :     | PATHtyc{entPath,...} =>
1429 :     (let val _ =
1430 :     debugmsg ("#instToTyc(NOTINST/PATHtyc): "^
1431 :     EP.entPathToString entPath)
1432 :     val tyc = EE.lookTycEP(entEnv,entPath)
1433 :     in
1434 :     r := INST tyc;
1435 :     tyc
1436 :     end
1437 :     handle EE.Unbound =>
1438 :     (debugmsg "#instToTyc(NOTINST/PATHtyc) failed";
1439 :     raise EE.Unbound))
1440 :     | _ => badtycon ()
1441 :     end
1442 :    
1443 :     (*
1444 :     * Creates an entity from the instance node found
1445 :     * in the given slot.
1446 :     *)
1447 :     fun instToEntity (sym,slot,entEnv,failuresSoFar:int)
1448 :     : M.entity * int =
1449 :     (debugmsg ("instToEntity: "^Symbol.name sym^" "^
1450 :     Int.toString failuresSoFar);
1451 :     case !slot
1452 :     of (inst as (FinalStr _)) =>
1453 :     let val (strEntity,n) =
1454 :     instToStr'(inst, entEnv, IP.extend(rpath,sym),
1455 :     failuresSoFar)
1456 :     in (STRent strEntity, n)
1457 :     end
1458 :    
1459 :     | FinalTyc r =>
1460 :     (TYCent(instToTyc(r,entEnv)),failuresSoFar)
1461 :    
1462 : gkuan 3006 | FinalFct{sign as FSIG{paramvar,paramsig,bodysig,...},
1463 : blume 902 def, epath, path} =>
1464 :     (case !def
1465 :     of SOME(FCT { rlzn, ... }) => FCTent rlzn
1466 :     (*** would this case ever occur ??? ***)
1467 :    
1468 :     | NONE =>
1469 :     let val stamp = mkStamp()
1470 : dbm 3347 val (paramRlzn, primaryTycs, primaryFcts) =
1471 :     instGeneric{sign=paramsig, entEnv=entEnv,
1472 :     rpath=path,
1473 :     region=SourceMap.nullRegion,
1474 :     instKind=INST_FORMAL,
1475 :     compInfo=compInfo}
1476 : gkuan 2961 val (bodyExp) =
1477 : dbm 3291 case instKind
1478 :     of INST_ABSTR {entities,...} =>
1479 :     let val fctEnt = EE.lookFctEP (entities, epath)
1480 :     in M.ABSstr (bodysig,
1481 :     APPLY(CONSTfct fctEnt,
1482 :     VARstr [paramvar]))
1483 :     end
1484 :     | INST_FORMAL => M.FORMstr sign
1485 : dbm 3347 val exp = LAMBDA{param=paramvar,
1486 : blume 902 body=bodyExp,
1487 : dbm 3347 primaries=(primaryTycs,primaryFcts)}
1488 :     in primFcts := (stamp,sign)::!primFcts;
1489 :     FCTent {stamp = stamp,
1490 :     exp = exp,
1491 :     env = entEnv,
1492 :     rpath = path,
1493 :     stub = NONE,
1494 :     properties = PropList.newHolder ()}
1495 : blume 902 end
1496 :    
1497 :     | _ => bug "unexpected functor def in instToStr",
1498 :     failuresSoFar)
1499 :    
1500 :     | ErrorStr => (ERRORent,failuresSoFar)
1501 :     | ErrorTyc => (ERRORent,failuresSoFar)
1502 :     | inst => (say("bad inst: " ^ instToString inst ^ "\n");
1503 :     (ERRORent,failuresSoFar)))
1504 :    
1505 :     (* a DEFtyc entity instantiating a datatype spec (an
1506 :     * explicit or implicit datatype replication spec), must
1507 :     * be unwrapped, so that the instantiation is a datatype.
1508 :     * This replaces the unwrapping that was formerly done
1509 :     * in checkTycBinding in SigMatch. Fixes bugs 1364 and
1510 :     * 1432. [DBM]
1511 :     *)
1512 : dbm 2571 fun fixUpTycEnt (TYCspec{info=RegTycSpec{spec=GENtyc{kind=DATATYPE _,
1513 :     ...},...},...},
1514 : blume 902 TYCent(tyc)) =
1515 :     (* possible indirect datatype repl. See bug1432.7.sml *)
1516 :     TYCent(TU.unWrapDefStar tyc)
1517 : dbm 2571 | fixUpTycEnt (TYCspec{info=RegTycSpec{repl=true,...},...},
1518 :     TYCent(tyc)) =
1519 : blume 902 (* direct or indirect datatype repl. Original spec
1520 :     * was a datatype spec. See bug1432.1.sml *)
1521 :     TYCent(TU.unWrapDefStar tyc)
1522 :     | fixUpTycEnt (_,ent) = ent
1523 :    
1524 :     fun mkEntEnv (baseEntC) =
1525 :     foldl (fn ((sym,spec),(env,failCount)) =>
1526 :     (debugmsg ("mkEntEnv: "^Symbol.name sym);
1527 :     case MU.getSpecVar spec
1528 :     of SOME v =>
1529 :     (let val s = lookSlot(slotEnv,v)
1530 :     val (e,failures) =
1531 :     instToEntity(sym, s, env, failCount)
1532 :     val e = fixUpTycEnt(spec,e)
1533 :     in debugmsg ("ok: "^EP.entVarToString v);
1534 :     (EE.bind(v, e, env), failures)
1535 :     end
1536 :     handle EE.Unbound => (* tycon inst *)
1537 :     (debugmsg ("failed at: "^S.name sym);
1538 :     (env, failCount+1)))
1539 :     | NONE => (env,failCount)))
1540 :     baseEntC elements
1541 :    
1542 :     val (entEnv',failCount) =
1543 :     if closed andalso closedDef
1544 :     then (let val _ = debugmsg "mkEntEnv: closed"
1545 :     val (ee, fc) = mkEntEnv(EE.empty, 0)
1546 :     in (ee, fc+failuresSoFar)
1547 :     end)
1548 :     else (let val _ = debugmsg "mkEntEnv: not closed";
1549 :     val baseEntC =
1550 :     (MARKeenv{stamp = mkStamp(),
1551 :     env = entEnv,
1552 : dbm 3317 stub = NONE},
1553 : blume 902 failuresSoFar)
1554 :     val (ee, fc) = mkEntEnv(baseEntC)
1555 :     in (ee, fc)
1556 :     end)
1557 :    
1558 :     val strEnt={stamp =getStamp instance,
1559 :     rpath=rpath,
1560 :     entities=entEnv',
1561 : dbm 3317 stub=NONE,
1562 :     properties = PropList.newHolder ()}
1563 :    
1564 : blume 902 val _ = debugmsg (String.concat["--instToStr': failuresSoFar = ",
1565 :     Int.toString failuresSoFar,
1566 :     ", failCount = ",
1567 :     Int.toString failCount])
1568 :    
1569 :     in if failCount = 0
1570 :     then finalEnt := CONST_ENT strEnt
1571 :     else ();
1572 :     ED.withInternals(fn () =>
1573 :     ED.debugPrint debugging
1574 :     (("<<instToStr':" ^ IP.toString rpath^":"),
1575 :     (fn ppstrm => fn ent =>
1576 :     PPModules.ppEntity ppstrm (ent, StaticEnv.empty, 20)),
1577 :     M.STRent strEnt));
1578 :     (strEnt, failCount)
1579 :     end)
1580 :     | instToStr'(ErrorStr, _, _, failuresSoFar) =
1581 :     (bogusStrEntity,failuresSoFar)
1582 :     | instToStr' _ = bug "instToStr - instance not FinalStr"
1583 :    
1584 :     fun loop(strEnt,failures) =
1585 :     (debugmsg ("instToStr': failures = " ^ Int.toString failures);
1586 :     if failures = 0
1587 :     then strEnt
1588 :     else let val (strEnt',failures') =
1589 :     instToStr'(instance,entEnv,rpath,0)
1590 :     in if failures' < failures
1591 :     then loop(strEnt',failures')
1592 :     else (err EM.COMPLAIN "dependency cycle in instantiate"
1593 :     EM.nullErrorBody;
1594 :     strEnt')
1595 :     end)
1596 : dbm 3347 in (loop(instToStr'(instance,entEnv,rpath,0));
1597 :     !primFcts)
1598 : blume 902 end (* fun instToStr *)
1599 :    
1600 :     (*** fetching the TycKind for a particular functor signature ***)
1601 :    
1602 :     (*** the generic instantiation function ***)
1603 : dbm 2739 (* instGeneric :
1604 :     sign : Signature -- the signature to instantiate
1605 :     entEnv : entityEnv -- contextual entityEnv (for open signatures?)
1606 :     instKind : instKind -- kind of instantiation (parameter, formal body, abstr)
1607 :     rpath : InvPath.path -- context symbolic path (?)
1608 :     region: SourceMap.region -- soure region for error messages
1609 :     compInfo : compInfo -- for mkStamp and error
1610 :     ->
1611 : dbm 3291 strEnt : strEntity (str realization)
1612 : dbm 3347 primaryTycs : tycon list -- primary tycons
1613 :     primaryFcts : (stamp * fctsig) list -- primary fcts
1614 : dbm 2739 *)
1615 : blume 902 and instGeneric{sign, entEnv, instKind, rpath, region,
1616 :     compInfo as {mkStamp,error,...} : EU.compInfo} =
1617 :     let val _ = debugmsg (">>instantiate: "^signName sign)
1618 :     val _ = error_found := false
1619 :     fun err sev msg = (error_found := true; error region sev msg)
1620 : dbm 3291
1621 :     (* what was this supposed to do???
1622 : blume 902 val baseStamp = mkStamp()
1623 : dbm 3291 *)
1624 :    
1625 : dbm 3347 val (inst, primaryTycs) =
1626 : dbm 2738 sigToInst(sign, instKind, rpath, err, compInfo)
1627 : blume 902
1628 : dbm 3347 val (strEnt, primaryFcts) =
1629 : gkuan 2961 instToStr(inst,entEnv,instKind,rpath,err,compInfo)
1630 : blume 902
1631 : dbm 3347 (* let's not for now ...
1632 : dbm 3291 (* let's memoize the resulting bound tycon entity paths, tyceps *)
1633 : blume 902 val _ = case sign
1634 : dbm 3291 of M.SIG sigrec =>
1635 :     (case ModPropList.sigBoundeps sigrec
1636 :     of NONE => ModPropList.setSigBoundeps (sigrec, SOME tyceps)
1637 :     | _ => ())
1638 : blume 902 | _ => ()
1639 : dbm 3347 *)
1640 : blume 902 val _ = debugmsg "<<instantiate"
1641 : dbm 3347 in (strEnt, primaryTycs, primaryFcts)
1642 : blume 902 end
1643 :    
1644 :     (* debugging wrappers
1645 :     val sigToInst = wrap "sigToInst" sigToInst
1646 :     val instToStr = wrap "instToStr" instToStr
1647 :     val instGeneric = wrap "instantiate" instGeneric
1648 :     *)
1649 :    
1650 : dbm 3291 (* The exported instantiation functions: instFormal and instAbstr *)
1651 :    
1652 :     (* instFormal and instAbstr when called in EvalEntity will use the
1653 :     * abstycs and tyceps fields of the returned record to augment
1654 :     * an entity path context.
1655 :     * instFormal when called in ElabMod will only use the rlzn field.
1656 :     * instFmBody is called in ElabMod and EvalEntity, while instAbstr
1657 :     * is called in SigMatch and EvalEntity.
1658 :     * In SigMatch, the tyceps field returned by instAbstr is not used.
1659 :     * instFormal replaces the former instParam and instFmBody.
1660 :     *)
1661 :    
1662 : blume 902 (*** instantiation of the formal functor body signatures ***)
1663 : dbm 3291 fun instFormal{sign, entEnv, rpath, region, compInfo} =
1664 : dbm 3347 let val (rlzn, primaryTycs, primaryFcts)
1665 : dbm 3291 = instGeneric{sign=sign, entEnv=entEnv, instKind=INST_FORMAL,
1666 : blume 902 rpath=rpath, region=region, compInfo=compInfo}
1667 : dbm 3347 in {rlzn=rlzn, primaries=(primaryTycs,primaryFcts)}
1668 : blume 902 end
1669 :    
1670 :     (*** instantiation of the structure abstractions **)
1671 :     fun instAbstr{sign, entEnv, srcRlzn, rpath, region, compInfo} =
1672 : dbm 3347 let val (rlzn, primaryTycs, _)
1673 : blume 902 = instGeneric{sign=sign, entEnv=entEnv, instKind=INST_ABSTR srcRlzn,
1674 :     rpath=rpath, region=region, compInfo=compInfo}
1675 : dbm 3347 in {rlzn=rlzn, primaryTycs=primaryTycs}
1676 : blume 902 end
1677 :    
1678 : dbm 3291 val instFormal =
1679 :     Stats.doPhase (Stats.makePhase "Compiler 032 instformal") instFormal
1680 : blume 902
1681 :     (*
1682 :     val instAbstr =
1683 :     Stats.doPhase (Stats.makePhase "Compiler 032 3-instAbstr") instAbstr
1684 :     *)
1685 :    
1686 :     end (* local *)
1687 :     end (* structure Instantiate *)
1688 :    
1689 : blume 2222 (* [dbm, 6/16/06] Eliminated ii2ty from INSTANTIATE_PARAM. Eventually want
1690 :     to eliminate the parameterization completely. *)
1691 :    

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