Annotation of /sml/branches/SMLNJ/src/compiler/Semant/modules/sigmatch.sml

Parent Directory | Revision Log

---

Revision 125 - (view) (download)

1 :	monnier	16	(* Copyright 1996 by AT&T Bell Laboratories *)
2 :			(* sigmatch.sml *)
3 :
4 :			signature SIGMATCH =
5 :			sig
6 :
7 :			(*** these four functions are only called inside elabmod.sml ***)
8 :			val matchStr :
9 :			{sign : Modules.Signature,
10 :			str : Modules.Structure,
11 :			strExp : Modules.strExp,
12 :			evOp : EntPath.entVar option,
13 :			depth : DebIndex.depth,
14 :			entEnv : Modules.entityEnv,
15 :			rpath : InvPath.path,
16 :			statenv : StaticEnv.staticEnv,
17 :			region : SourceMap.region,
18 :			compInfo : ElabUtil.compInfo} -> {resDec : Absyn.dec,
19 :			resStr : Modules.Structure,
20 :			resExp : Modules.strExp}
21 :
22 :			val matchFct :
23 :			{sign : Modules.fctSig,
24 :			fct : Modules.Functor,
25 :			fctExp : Modules.fctExp,
26 :			depth : DebIndex.depth,
27 :			entEnv : Modules.entityEnv,
28 :			rpath : InvPath.path,
29 :			statenv : StaticEnv.staticEnv,
30 :			region : SourceMap.region,
31 :			compInfo : ElabUtil.compInfo} -> {resDec : Absyn.dec,
32 :			resFct : Modules.Functor,
33 :			resExp : Modules.fctExp}
34 :
35 :			val packStr :
36 :			{sign : Modules.Signature,
37 :			str : Modules.Structure,
38 :			strExp : Modules.strExp,
39 :			depth : DebIndex.depth,
40 :			entEnv : Modules.entityEnv,
41 :			rpath : InvPath.path,
42 :			statenv : StaticEnv.staticEnv,
43 :			region : SourceMap.region,
44 :			compInfo : ElabUtil.compInfo} -> {resDec : Absyn.dec,
45 :			resStr : Modules.Structure,
46 :			resExp : Modules.strExp}
47 :
48 :			val applyFct :
49 :			{fct : Modules.Functor,
50 :			fctExp : Modules.fctExp,
51 :			argStr : Modules.Structure,
52 :			argExp : Modules.strExp,
53 :			evOp : EntPath.entVar option,
54 :			depth : DebIndex.depth,
55 :			epc : EntPathContext.context,
56 :			statenv : StaticEnv.staticEnv,
57 :			rpath : InvPath.path,
58 :			region : SourceMap.region,
59 :			compInfo : ElabUtil.compInfo} -> {resDec : Absyn.dec,
60 :			resStr : Modules.Structure,
61 :			resExp : Modules.strExp}
62 :
63 :
64 :			val debugging : bool ref
65 :			val showsigs : bool ref
66 :
67 :			end (* signature SIGMATCH *)
68 :
69 :
70 :			structure SigMatch: SIGMATCH =
71 :			struct
72 :
73 :			local structure A = Absyn
74 :			structure B = Bindings
75 :			structure DA = Access
76 :			structure DI = DebIndex
77 :			structure EE = EntityEnv
78 :			structure EM = ErrorMsg
79 :			structure EP = EntPath
80 :			structure EPC = EntPathContext
81 :			structure EU = ElabUtil
82 :			structure EV = EvalEntity
83 :			structure INS = Instantiate
84 :			structure II = InlInfo
85 :			structure IP = InvPath
86 :			structure M = Modules
87 :			structure MU = ModuleUtil
88 :			structure PP = PrettyPrint
89 :			structure S = Symbol
90 :			structure SE = StaticEnv
91 :			structure SP = SymPath
92 :			structure ST = Stamps
93 :			structure T = Types
94 :			structure TU = TypesUtil
95 :			structure V = VarCon
96 :
97 :			open Types Modules VarCon ElabDebug
98 :
99 :			in
100 :			exception BadBinding
101 :
102 :			val debugging = Control.CG.smdebugging (* ref false *)
103 :			val showsigs = ref false
104 :
105 :			val say = Control.Print.say
106 :			fun debugmsg (msg: string) =
107 :			if !debugging then (say msg; say "\n") else ()
108 :
109 :			fun bug msg = EM.impossible ("SigMatch:" ^ msg)
110 :			val nth = List.nth
111 :			fun for l f = app f l
112 :
113 :			fun symbolsToString [] = ""
114 :			| symbolsToString [n] = S.name n
115 :			| symbolsToString (n::r) =
116 :			concat(S.name n :: foldr (fn(n,b) => (","::S.name n::b)) [] r)
117 :
118 :			val BogusTy = UNDEFty
119 :
120 :			(*
121 :			* Bogus coercion expressions returned by the matching functions. These
122 :			* should never be evaluated.
123 :			*)
124 :
125 :			val bogusStrExp = M.VARstr []
126 :			val bogusFctExp = M.VARfct []
127 :
128 :			fun showStr (msg,str) =
129 :			withInternals(fn () =>
130 :			debugPrint debugging
131 :			(msg,
132 :			(fn pps => fn str =>
133 :			PPModules.ppStructure pps (str, SE.empty, 100)),
134 :			str))
135 :
136 :			fun exnRep (DA.EXN _, dacc) = DA.EXN dacc
137 :			| exnRep _ = bug "unexpected conrep in exnRep"
138 :
139 :			fun isNamed(SOME _) = true
140 :			| isNamed _ = false
141 :
142 :			val anonSym = S.strSymbol "<anonymousStr>"
143 :			val anonFsym = S.fctSymbol "<anonymousFct>"
144 :			val paramSym = S.strSymbol "<FsigParamInst>"
145 :
146 :			fun ident _ = ()
147 :
148 :			(* returns true and the new instantiations if actual type > spec type *)
149 :			(* matches an abstract version of a type with its actual version *)
150 :			fun absEqvTy (spec, actual, dinfo) : (ty list * tyvar list * ty * bool) =
151 :			let val actual = TU.prune actual
152 :			val spec = TU.prune spec
153 :			val (actinst, insttys0) = TU.instantiatePoly actual
154 :			val (specinst, stys) = TU.instantiatePoly spec
155 :			val _ = ListPair.app Unify.unifyTy (insttys0, stys)
156 :
157 :			(*
158 :			* This is a gross hack. Inlining-information such as primops
159 :			* (or inline-able expressions) are propagated through signature
160 :			* matching. However, their types may change. The following code
161 :			* is to figure out the proper type application arguments, insttys.
162 :			* The typechecker does similar hack. We will clean this up in the
163 :			* future (ZHONG).
164 :			*)
165 :			val insttys =
166 :			(case dinfo
167 :			of II.INL_PRIM(_, SOME st) =>
168 :			(let val (actinst', insttys') = TU.instantiatePoly st
169 :			in Unify.unifyTy(actinst', actinst) handle _ => ();
170 :			insttys'
171 :			end)
172 :			| _ =>insttys0)
173 :
174 :			val res = (Unify.unifyTy(actinst, specinst); true) handle _ => false
175 :
176 :			val instbtvs = map TU.tyvarType insttys0
177 :			(* should I use stys here instead, why insttys0 ? *)
178 :
179 :			in (insttys, instbtvs, specinst, res)
180 :			end
181 :
182 :			fun eqvTnspTy (spec, actual, dinfo) : (ty list * tyvar list) =
183 :			let val actual = TU.prune actual
184 :			val (actinst, insttys) = TU.instantiatePoly actual
185 :
186 :			(*
187 :			* This is a gross hack. Inlining-information such as primops
188 :			* (or inline-able expressions) are propagated through signature
189 :			* matching. However, their types may change. The following code
190 :			* is to figure out the proper type application arguments, insttys.
191 :			* The typechecker does similar hack. We will clean this up in the
192 :			* future (ZHONG).
193 :			*)
194 :			val insttys =
195 :			(case dinfo
196 :			of II.INL_PRIM(_, SOME st) =>
197 :			(let val (actinst', insttys') = TU.instantiatePoly st
198 :			in Unify.unifyTy(actinst', actinst) handle _ => ();
199 :			insttys'
200 :			end)
201 :			| _ =>insttys)
202 :
203 :			val (specinst, stys) = TU.instantiatePoly spec
204 :			val _ = ((Unify.unifyTy(actinst, specinst))
205 :			handle _ => bug "unexpected types in eqvTnspTy")
206 :			val btvs = map TU.tyvarType stys
207 :
208 :			in (insttys, btvs)
209 :			end
210 :
211 :
212 :			(**************************************************************************
213 :			* *
214 :			* Matching a structure against a signature: *
215 :			* *
216 :			* val matchStr1 : Signature * Structure * S.symbol * DI.depth * *
217 :			* entityEnv * EP.entPath * IP.path * staticEnv * *
218 :			* region * EU.compInfo *
219 :			* -> A.dec * M.Structure * M.strExp *
220 :			* *
221 :			* WARNING: epath is an inverse entPath, so it has to be reversed to *
222 :			* produce an entPath. *
223 :			* *
224 :			**************************************************************************)
225 :			fun matchStr1(specSig as SIG{closed, fctflag, stamp=sigStamp, elements=sigElements, ...},
226 :			str as STR{sign = SIG{elements=strElements,
227 :			stamp=strSigStamp, ...},
228 :			rlzn = {stamp=strStamp, entities=strEntEnv, ...},
229 :			access = rootAcc, info=rootInfo},
230 :			strName : S.symbol, depth, matchEntEnv,
231 :			epath: EP.entVar list, rpath: IP.path, statenv, region,
232 :			compInfo as {mkStamp, mkLvar=mkv, error, ...}: EU.compInfo) =
233 :
234 :			let
235 :
236 :			val err = error region
237 :			val _ = let fun h pps sign =PPModules.ppSignature pps (sign,statenv,6)
238 :			val s = ">>matchStr1 - specSig :"
239 :			in debugPrint (showsigs) (s, h, specSig)
240 :			end
241 :
242 :			fun matchTypes (spec, actual, dinfo, name) : (T.ty list * T.tyvar list) =
243 :			if TU.compareTypes(spec, actual) then
244 :			let val (insttys, btvs) = eqvTnspTy(spec, actual, dinfo)
245 :			in (insttys, btvs)
246 :			end
247 :			else (err EM.COMPLAIN
248 :			"value type in structure doesn't match signature spec"
249 :			(fn ppstrm =>
250 :			(PPType.resetPPType();
251 :			PP.add_newline ppstrm;
252 :			app (PP.add_string ppstrm) [" name: ", S.name name];
253 :			PP.add_newline ppstrm;
254 :			PP.add_string ppstrm "spec: ";
255 :			PPType.ppType statenv ppstrm spec;
256 :			PP.add_newline ppstrm;
257 :			PP.add_string ppstrm "actual: ";
258 :			PPType.ppType statenv ppstrm actual));
259 :			([],[]))
260 :
261 :			fun complain s = err EM.COMPLAIN s EM.nullErrorBody
262 :			fun complain' x = (complain x; raise BadBinding)
263 :
264 :			(*
265 :			* Compare datacon names of spec and actual datatype; this uses
266 :			* the fact that datacons have been sorted by name.
267 :			*)
268 :			fun compareDcons(spec,actual) =
269 :			let fun comp(l1 as dc1::r1, l2 as dc2::r2, s_only, a_only) =
270 :			if S.eq(dc1,dc2) then comp(r1,r2,s_only,a_only)
271 :			else if S.symbolGt(dc1,dc2)
272 :			then comp(l1,r2,s_only,dc2::a_only)
273 :			else comp(r1,l2,dc1::s_only,a_only)
274 :
275 :			| comp([], [], s_only, a_only) = (rev s_only, rev a_only)
276 :			| comp([], r, s_only, a_only) = (rev s_only, rev a_only @ r)
277 :			| comp(r, [], s_only, a_only) = (rev s_only @ r, rev a_only)
278 :			in comp(spec,actual,[],[])
279 :			end
280 :
281 :			fun checkTycBinding(_,T.ERRORtyc,_) = ()
282 :			| checkTycBinding(specTycon,strTycon,entEnv) =
283 :			let val specName = S.name(TU.tycName specTycon)
284 :			in case specTycon
285 :			of GENtyc{stamp=s,arity,kind=specKind,eq=ref eqprop,...} =>
286 :			if arity <> TU.tyconArity strTycon
287 :			then complain' ("tycon arity for " ^ specName
288 :			^ " does not match specified arity")
289 :			else (case (specKind, TU.unWrapDefStar strTycon)
290 :			of (DATATYPE{index,family={members,...} ,...},
291 :			GENtyc{arity=a',kind=DATATYPE{index=index',
292 :			family={members=members',...}, ...},
293 :			...}) =>
294 :			let val specDconSig = #dcons(Vector.sub(members,index))
295 :			val strDconSig = #dcons(Vector.sub(members',index'))
296 :			val specnames = map #name specDconSig
297 :			val strnames = map #name strDconSig
298 :
299 :			val _ = app (fn s =>
300 :			(debugmsg (S.name s))) specnames
301 :			val _ = debugmsg "******"
302 :			val _ = app (fn s =>
303 :			(debugmsg (S.name s))) strnames
304 :
305 :			in case compareDcons (specnames, strnames)
306 :			of ([],[]) => ()
307 :			| (s_only, a_only) =>
308 :			complain'(concat(List.concat
309 :			[["datatype ",specName,
310 :			" does not match specification"],
311 :			case s_only
312 :			of [] => []
313 :			| _ =>
314 :			["\n constructors in spec only: ",
315 :			symbolsToString s_only],
316 :			case a_only
317 :			of [] => []
318 :			| _ =>
319 :			["\n constructors in actual only: ",
320 :			symbolsToString a_only]]))
321 :			end
322 :			| (DATATYPE _, _) =>
323 :			complain'("type "^specName^" must be a datatype")
324 :			| (FORMAL, _) =>
325 :			if eqprop=YES andalso not(EqTypes.isEqTycon strTycon)
326 :			then complain'("type " ^ specName ^
327 :			" must be an equality type")
328 :			else ()
329 :			| _ =>
330 :			(debugPrint(debugging)("specTycon: ",
331 :			PPType.ppTycon statenv, specTycon);
332 :			debugPrint(debugging)("strTycon: ",
333 :			PPType.ppTycon statenv, strTycon);
334 :			bug "checkTycBinding 1" ))
335 :
336 :			| DEFtyc{tyfun=TYFUN{arity,body},strict,stamp,path} =>
337 :			let val ntyfun = TYFUN{arity=arity,body=MU.transType entEnv body}
338 :			val specTycon' = DEFtyc{tyfun=ntyfun,strict=strict,
339 :			stamp=stamp,path=path}
340 :			in if TU.equalTycon(specTycon',strTycon)
341 :			then ()
342 :			else (debugPrint(debugging)("specTycon': ",
343 :			PPType.ppTycon statenv, specTycon);
344 :			debugPrint(debugging)("strTycon: ",
345 :			PPType.ppTycon statenv, strTycon);
346 :			complain'("type " ^ specName ^
347 :			" does not match definitional specification"))
348 :			end
349 :			| ERRORtyc => raise BadBinding
350 :			| _ => bug "checkTycBinding 2"
351 :			end
352 :
353 :			(*** lookStr is only used inside the checkSharing function ***)
354 :			fun lookStr (elements,entEnv) (SP.SPATH spath) : (M.Signature * M.entity) =
355 :			let fun loop ([sym],elements,entEnv) =
356 :			((case MU.getSpec(elements,sym)
357 :	monnier	106	of STRspec{entVar,sign,...} =>
358 :			(debugmsg ("$lookStr.1: "^S.name sym^", "^EP.entVarToString entVar);
359 :			(sign,EE.look(entEnv,entVar)))
360 :	monnier	16	| _ => bug "looStr 1b")
361 :			handle MU.Unbound _ => bug "lookStr 1c")
362 :
363 :			| loop (sym::rest,elements,entEnv) =
364 :			((case MU.getSpec(elements,sym)
365 :			of STRspec{sign=SIG{elements,...},entVar,...} =>
366 :			(case EE.look(entEnv,entVar)
367 :	monnier	106	of STRent{entities,...} =>
368 :			(debugmsg ("$lookStr.2: "^S.name sym^", "^EP.entVarToString entVar); loop(rest,elements,entities))
369 :	monnier	16	| ERRORent => (ERRORsig,ERRORent)
370 :			| _ => bug "lookStr 2a")
371 :			| _ => bug "lookStr 2b")
372 :			handle MU.Unbound _ => bug "lookStr 2c")
373 :
374 :			| loop _ = bug "lookStr 3"
375 :			in loop(spath,elements,entEnv)
376 :			end
377 :
378 :			(*** lookTyc is only used inside the checkSharing function ***)
379 :			fun lookTyc (elements,entEnv) (SP.SPATH spath) : T.tycon =
380 :			let fun loop ([sym],elements,entEnv) =
381 :			((case MU.getSpec(elements,sym)
382 :			of TYCspec{entVar,...} =>
383 :			(case EE.look(entEnv,entVar)
384 :			of TYCent tycon => tycon
385 :			| ERRORent => ERRORtyc
386 :			| _ => bug "lookTyc 1a")
387 :			| _ => bug "looTyc 1b")
388 :			handle MU.Unbound _ => bug "lookTyc 1c")
389 :
390 :			| loop (sym::rest,elements,entEnv) =
391 :			((case MU.getSpec(elements,sym)
392 :			of STRspec{sign=SIG{elements,...},entVar,...} =>
393 :			(case EE.look(entEnv,entVar)
394 :			of STRent{entities,...} => loop(rest,elements,entities)
395 :			| ERRORent => ERRORtyc
396 :			| _ => bug "lookTyc 2a")
397 :			| _ => bug "lookTyc 2b")
398 :			handle MU.Unbound _ => bug ("lookTyc 2c:"^Symbol.name sym^
399 :			SP.toString(SP.SPATH spath)))
400 :
401 :			| loop _ = bug "lookTyc 3"
402 :			in loop(spath,elements,entEnv)
403 :			end
404 :
405 :			(*** verify whether all the sharing constraints are satisfied ***)
406 :			fun checkSharing(sign as ERRORsig, entEnv) = ()
407 :			(* don't do anything if an error has occured, resulting in an ERRORsig *)
408 :			| checkSharing(sign as SIG{elements, typsharing, strsharing,...},
409 :			entEnv) =
410 :			let fun errmsg sp x = SP.toString x ^ " # " ^ SP.toString sp
411 :
412 :			fun eqTyc(_,ERRORtyc) = true
413 :			| eqTyc(ERRORtyc,_) = true
414 :			| eqTyc(tyc1,tyc2) = TU.equalTycon(tyc1,tyc2)
415 :
416 :			val lookStr = lookStr (elements,entEnv)
417 :
418 :
419 :			fun commonElements(SIG{elements=elems1,...},SIG{elements=elems2,...}) =
420 :			let fun elemGt ((s1,_),(s2,_)) = S.symbolGt(s1,s2)
421 :			val elems1 = Sort.sort elemGt elems1
422 :			val elems2 = Sort.sort elemGt elems2
423 :			fun intersect(e1 as ((s1,spec1)::rest1),
424 :			e2 as ((s2,spec2)::rest2)) =
425 :			if S.eq(s1,s2) then (s1,spec1,spec2)::intersect(rest1,rest2)
426 :			else if S.symbolGt(s1,s2) then intersect(e1,rest2)
427 :			else intersect(rest1,e2)
428 :			| intersect(_,_) = nil
429 :			in intersect(elems1,elems2)
430 :			end
431 :			| commonElements _ = bug "commonElements"
432 :
433 :
434 :			fun appPairs test nil = ()
435 :			| appPairs test (a::r) =
436 :			(app (fn x => test(a,x)) r; appPairs test r)
437 :
438 :			fun compStr((p1,(sign1,ent1)),
439 :			(p2,(sign2,ent2))) =
440 :			(case (ent1,ent2)
441 :			of (STRent{stamp=s1,entities=ee1,...},
442 :			STRent{stamp=s2,entities=ee2,...}) =>
443 :			if ST.eq(s1,s2) then () (* shortcut! *)
444 :			else if MU.eqSign(sign1,sign2) then
445 :	monnier	106	let val _ = debugmsg "$compStr: equal signs"
446 :			val SIG{elements,...} = sign1
447 :	monnier	16	in for elements (fn
448 :			(sym,TYCspec{entVar,...}) =>
449 :			let val TYCent tyc1 = EE.look(ee1,entVar)
450 :			val TYCent tyc2 = EE.look(ee2,entVar)
451 :			in if eqTyc(tyc1,tyc2) then ()
452 :			else complain(
453 :			concat["implied type sharing violation: ",
454 :			errmsg (SP.extend(p1,sym))
455 :			(SP.extend(p2,sym))])
456 :			end
457 :			| (sym,STRspec{entVar,sign,...}) =>
458 :			let val ent1' = EE.look(ee1,entVar)
459 :			val ent2' = EE.look(ee2,entVar)
460 :			in compStr((SP.extend(p1,sym),(sign,ent1')),
461 :			(SP.extend(p2,sym),(sign,ent2')))
462 :			end
463 :			| _ => ())
464 :			end
465 :			else
466 :	monnier	106	let val _ = debugmsg "$compStr: unequal signs"
467 :			val common = commonElements(sign1,sign2)
468 :	monnier	16	in for common (fn
469 :			(sym,TYCspec{entVar=v1,...},
470 :			TYCspec{entVar=v2,...}) =>
471 :			let val TYCent tyc1 = EE.look(ee1,v1)
472 :			val TYCent tyc2 = EE.look(ee2,v2)
473 :			in if eqTyc(tyc1,tyc2) then ()
474 :			else complain(
475 :			concat["type sharing violation: ",
476 :			errmsg (SP.extend(p1,sym))
477 :			(SP.extend(p2,sym))])
478 :			end
479 :			| (sym,STRspec{entVar=v1,sign=sign1',...},
480 :			STRspec{entVar=v2,sign=sign2',...}) =>
481 :			let val str1 = EE.look(ee1,v1)
482 :			val str2 = EE.look(ee2,v2)
483 :	monnier	106	in compStr((SP.extend(p1,sym),(sign1',str1)),
484 :	monnier	125	(SP.extend(p2,sym),(sign2',str2)))
485 :	monnier	16	end
486 :			| _ => ()) (* values, constructors, functors *)
487 :			end
488 :			| (ERRORent,_) => () (* error upstream *)
489 :			| (_,ERRORent) => ()) (* error upstream *)
490 :
491 :			fun checkStr (paths) =
492 :			let val pathstrs = map (fn p => (p,lookStr p)) paths
493 :			in appPairs compStr pathstrs
494 :			end
495 :
496 :			fun checkTyc0 (firstPath, rest) =
497 :			let val lookTyc = lookTyc (elements,entEnv)
498 :			val errMsg = errmsg firstPath
499 :			val first = lookTyc firstPath
500 :			fun checkPath p =
501 :			if eqTyc(first, lookTyc p) then ()
502 :			else complain(concat["type sharing violation: ",errMsg p])
503 :			in app checkPath rest
504 :			end
505 :
506 :			fun checkTyc (sp::rest) = checkTyc0(sp,rest)
507 :
508 :			in app checkStr strsharing;
509 :			app checkTyc typsharing
510 :			end
511 :
512 :			(*
513 :			* Matching: Go through the `elements' of the specified signature, and
514 :			* construct a corresponding realization from entities found in the given
515 :			* structure. The structure's entities are found by using the entPath in
516 :			* each of the given structure signature's elements to access the given
517 :			* structure's realization = stored entEnv. Recurse into substructures.
518 :			* Build the formal realization in parallel. Finally check sharing
519 :			* constraints.
520 :			*)
521 :
522 :			(*
523 :			* val matchElems :
524 :			* (S.symbol * spec) list * entEnv * entityDec list * A.dec list
525 :			* * B.binding list
526 :			* -> (entEnv * entityDec list * A.dec list * B.binding list)
527 :			*
528 :			* Given the elements and the entities of a structure S, and a spec
529 :			* from a signature, extend the realization (entityEnv) with the
530 :			* entity specified by the spec, extend the list of
531 :			* coercions (entity declarations) with a declaration which
532 :			* will evaluate to the newly created entity, and extend the thinning.
533 :			*
534 :			* Assumption: if a match error occurs, then the resulting thinning
535 :			* and the list of entityDecs will never be used -- they will not be
536 :			* well-formed in case of errors.
537 :			*)
538 :
539 :			fun matchDefStr0(sigElements,signD,rlznD,signM,rlznM) =
540 :			let val dropVals = List.filter
541 :			(fn (s,(TYCspec _ | STRspec _ )) => true | _ => false)
542 :			fun elemGt ((s1,_),(s2,_)) = S.symbolGt(s1,s2)
543 :			val commonDM =
544 :			if MU.eqSign(signD,signM) then
545 :			let val SIG{elements=elems,...} = signD
546 :			val elems = Sort.sort elemGt (dropVals elems)
547 :			in map (fn (s,spec) => (s,spec,spec)) elems
548 :			end
549 :			else
550 :			let val SIG{elements=elemsD,...} = signD
551 :			val SIG{elements=elemsM,...} = signM
552 :			val elemsD = Sort.sort elemGt (dropVals elemsD)
553 :			val elemsM = Sort.sort elemGt (dropVals elemsM)
554 :			fun intersect(e1 as ((s1,spec1)::rest1),
555 :			e2 as ((s2,spec2)::rest2)) =
556 :			if S.eq(s1,s2) then (s1,spec1,spec2)::intersect(rest1,rest2)
557 :			else if S.symbolGt(s1,s2) then intersect(e1,rest2)
558 :			else intersect(rest1,e2)
559 :			| intersect(_,_) = nil
560 :			in intersect(elemsD,elemsM)
561 :			end
562 :			val sigElements' = dropVals sigElements
563 :			fun intersect'(elems1 as ((sym1,x)::rest1),
564 :			elems2 as ((sym2,y,z)::rest2)) =
565 :			if S.eq(sym1,sym2) then
566 :			(sym1,x,y,z)::intersect'(rest1,rest2)
567 :			else if S.symbolGt(sym1,sym2) then
568 :			intersect'(elems1,rest2) (* discard sym2 *)
569 :			else intersect'(rest1,elems2) (* discard sym1 *)
570 :			| intersect'(_,_) = nil
571 :			val common = intersect'(sigElements',commonDM)
572 :			fun loop nil = true
573 :			| loop ((sym,spec,specD,specM)::rest) =
574 :			(case spec
575 :			of TYCspec _ =>
576 :			let val TYCspec{entVar=evD,...} = specD
577 :			val TYCspec{entVar=evM,...} = specM
578 :			val {entities=eeD,...} = rlznD
579 :			val {entities=eeM,...} = rlznM
580 :			val TYCent tycD = EE.look(eeD,evD)
581 :			val TYCent tycM = EE.look(eeM,evM)
582 :			in TU.equalTycon(tycD,tycM)
583 :			end
584 :			| STRspec{sign=SIG{elements,...},...} =>
585 :			let val STRspec{entVar=evD,sign=signD',...} = specD
586 :			val STRspec{entVar=evM,sign=signM',...} = specM
587 :			val {entities=eeD,...} = rlznD
588 :			val {entities=eeM,...} = rlznM
589 :			val STRent rlznD' = EE.look(eeD,evD)
590 :			val STRent rlznM' = EE.look(eeM,evM)
591 :			in matchDefStr0(elements,signD',rlznD',signM',rlznM')
592 :			end
593 :			| _ => bug "matchStr")
594 :			in loop common
595 :			end
596 :
597 :			fun matchDefStr(sigElements,specStr,matchStr) =
598 :			case (specStr,matchStr)
599 :			of (STR{sign=signD,rlzn=rlznD,...},STR{sign=signM,rlzn=rlznM,...}) =>
600 :			let val {stamp=sD,...} = rlznD
601 :			val {stamp=sM,...} = rlznM
602 :			in if ST.eq(sD,sM) (* eqOrigin *)
603 :			then true
604 :			else matchDefStr0(sigElements,signD,rlznD,signM,rlznM)
605 :			end
606 :			| _ => bug "matchDefStr"
607 :
608 :			fun matchElems ([], entEnv, entDecs, decs, bindings, succeed) =
609 :			(entEnv, rev entDecs, rev decs, rev bindings, succeed)
610 :
611 :			| matchElems ((sym, spec) :: elems, entEnv, entDecs, decs, bindings, succeed) =
612 :
613 :			let val _ = debugmsg ">>matchElems"
614 :			fun matchErr (kindOp: string option) =
615 :			let val entEnv' =
616 :			case MU.getSpecVar spec
617 :			of SOME v => EE.bind(v, ERRORent, entEnv)
618 :			| NONE => entEnv
619 :
620 :			(* synthesize a new error binding to remove improper error
621 :			messages on inlInfo (ZHONG) *)
622 :			val bindings' =
623 :			case spec
624 :			of TYCspec _ => bindings
625 :			| CONspec {slot=NONE, ...} => bindings
626 :			| _ => (B.CONbind bogusEXN)::bindings
627 :
628 :			in case kindOp
629 :			of SOME kind =>
630 :			complain("unmatched " ^ kind ^ " specification: " ^ S.name sym)
631 :			| NONE => ();
632 :			matchElems(elems, entEnv', entDecs, decs, bindings', false)
633 :			end
634 :
635 :			fun typeInMatched (kind,typ) =
636 :			(MU.transType entEnv typ)
637 :			handle EE.Unbound =>
638 :			(debugPrint (debugging) (kind, PPType.ppType statenv,typ);
639 :			raise EE.Unbound)
640 :
641 :			fun typeInOriginal (kind,typ) =
642 :			(MU.transType strEntEnv typ)
643 :			handle EE.Unbound =>
644 :			(debugPrint (debugging) (kind, PPType.ppType statenv,typ);
645 :			raise EE.Unbound)
646 :
647 :			in case spec
648 :			of TYCspec{spec=specTycon,entVar,scope} =>
649 :			(let val _ = debugmsg(String.concat[">>matchElems TYCspec: ",
650 :			S.name sym, ", ",
651 :			ST.stampToString entVar])
652 :			val (strTycon, strEntVar) =
653 :			MU.getTyc(strElements, strEntEnv, sym)
654 :			handle EE.Unbound =>
655 :			(debugPrint(debugging) ("strEntEnv: ",
656 :			(fn pps => fn ee =>
657 :			PPModules.ppEntityEnv pps (ee,statenv,6)),
658 :			strEntEnv); raise EE.Unbound)
659 :
660 :			val _ = debugmsg ("--matchElems TYCspec - strEntVar: "^
661 :			ST.stampToString strEntVar)
662 :
663 :			(*** DAVE: please check the following ! ***)
664 :			val tycEntExp =
665 :			case epath of [] => CONSTtyc strTycon
666 :			| _ => VARtyc(rev(strEntVar::epath))
667 :
668 :			val _ = debugmsg "--matchElems TYCspec >> checkTycBinding"
669 :			val _ = checkTycBinding(specTycon, strTycon, entEnv)
670 :			val entEnv' = EE.bind(entVar, TYCent strTycon, entEnv)
671 :			val entDecs' = TYCdec(entVar, tycEntExp) :: entDecs
672 :			val _ = debugmsg "<<matchElems TYCspec << checkTycBinding"
673 :
674 :			in matchElems(elems, entEnv', entDecs', decs, bindings, succeed)
675 :			end handle MU.Unbound sym => matchErr (SOME "type")
676 :			| BadBinding => matchErr NONE
677 :			| EE.Unbound =>
678 :			(debugmsg ("$matchElems(TYCspec): "^S.name sym);
679 :			raise EE.Unbound))
680 :
681 :			| STRspec{sign=thisSpecSig, entVar, def, ...} =>
682 :			(let val _ = debugmsg(String.concat["--matchElems STRspec: ",
683 :			S.name sym,", ",
684 :			ST.stampToString entVar])
685 :			val (strStr, strEntVar) =
686 :			MU.getStr(strElements, strEntEnv, sym, rootAcc, rootInfo)
687 :
688 :			(* verify spec definition, if any *)
689 :			(* BUG: shallow test, comparing stamps --
690 :			* needs to be augmented with component-wise test when
691 :			* stamps disagree [dbm] *)
692 :			(* how should this verification interact with signatures? *)
693 :			val _ =
694 :			case def
695 :			of NONE => ()
696 :			| SOME(sd,_) =>
697 :			let val specStr = MU.strDefToStr(sd,entEnv)
698 :			in if matchDefStr(sigElements,specStr,strStr) then ()
699 :			else
700 :			(case sd
701 :			of M.VARstrDef(sign,ep) =>
702 :			debugmsg("spec def VAR: "^
703 :			EP.entPathToString ep ^ "\n")
704 :			| M.CONSTstrDef _ =>
705 :			debugmsg("spec def CONST\n");
706 :			showStr("specStr: ", specStr);
707 :			showStr("strStr: ", strStr);
708 :			complain("structure def spec for "^
709 :			S.name sym ^ " not matched"))
710 :			end
711 :
712 :			val epath' = strEntVar::epath
713 :			val rpath' = IP.extend(rpath, sym)
714 :			val (thinDec, thinStr, strExp) =
715 :			matchStr1(thisSpecSig, strStr, sym, depth, entEnv, epath',
716 :			rpath', statenv, region, compInfo)
717 :
718 :			val entEnv' =
719 :			let val strEnt =
720 :			case thinStr of M.STR{rlzn, ...} => rlzn
721 :			| _ => M.bogusStrEntity
722 :			in EE.bind(entVar, M.STRent strEnt, entEnv)
723 :			end
724 :
725 :			val entDecs' = M.STRdec(entVar, strExp, sym) :: entDecs
726 :			val decs' = thinDec :: decs
727 :			val bindings' = (B.STRbind thinStr)::bindings
728 :
729 :			in matchElems(elems, entEnv', entDecs', decs', bindings', succeed)
730 :			end handle MU.Unbound sym => matchErr (SOME "structure"))
731 :
732 :			| FCTspec{sign=specSig, entVar, ...} =>
733 :			(let val _ = debugmsg(String.concat["--matchElems FCTspec: ",
734 :			S.name sym,", ",
735 :			ST.stampToString entVar])
736 :
737 :			val (strFct, fctEntVar) =
738 :			MU.getFct(strElements, strEntEnv, sym, rootAcc, rootInfo)
739 :			val exp' = M.VARfct(rev(fctEntVar::epath))
740 :			val rpath' = IP.extend(rpath,sym)
741 :			val (thinDec, thinFct, fctExp) =
742 :			matchFct1(specSig, strFct, sym, depth, entEnv, exp',
743 :			rpath', statenv, region, compInfo)
744 :
745 :			val entEnv' =
746 :			let val fctEnt =
747 :			case thinFct of M.FCT{rlzn, ...} => rlzn
748 :			| _ => M.bogusFctEntity
749 :			in EE.bind(entVar, M.FCTent fctEnt, entEnv)
750 :			end
751 :
752 :			val entDecs' = M.FCTdec(entVar, fctExp) :: entDecs
753 :			val decs' = thinDec :: decs
754 :			val bindings' = (B.FCTbind thinFct)::bindings
755 :
756 :			in matchElems(elems, entEnv', entDecs', decs', bindings', succeed)
757 :			end handle MU.Unbound sym => matchErr(SOME "functor"))
758 :
759 :			| VALspec{spec=spectyp, ...} =>
760 :			((case (MU.getSpec(strElements, sym))
761 :			of VALspec{spec=acttyp, slot=actslot} =>
762 :			let val spectyp = typeInMatched("$specty(val/val)", spectyp)
763 :			val acttyp = typeInOriginal("$actty(val/val)", acttyp)
764 :			val dacc = DA.selAcc(rootAcc, actslot)
765 :			val dinfo = II.selInfo(rootInfo, actslot)
766 :			val (instys,btvs) =
767 :			matchTypes(spectyp, acttyp, dinfo, sym)
768 :
769 :			val spath = SP.SPATH[sym]
770 :			val actvar = VALvar{path=spath, typ=ref acttyp,
771 :			access=dacc, info=dinfo}
772 :
773 :			val (decs', nv) =
774 :			case (TU.headReduceType acttyp,
775 :			TU.headReduceType spectyp)
776 :			of ((POLYty _, _) | (_, POLYty _))=>
777 :			let val acc = DA.namedAcc(sym, mkv)
778 :			val specvar =
779 :			VALvar{path=spath, typ=ref spectyp,
780 :			access=acc, info=dinfo}
781 :			val vb =
782 :			A.VB {pat=A.VARpat specvar,
783 :			exp=A.VARexp(ref actvar, instys),
784 :			boundtvs=btvs, tyvars=ref []}
785 :
786 :			in ((A.VALdec [vb])::decs, specvar)
787 :			end
788 :			| _ => (decs, actvar)
789 :
790 :			val bindings' = (B.VALbind nv)::bindings
791 :
792 :			in matchElems(elems, entEnv, entDecs, decs', bindings', succeed)
793 :			end
794 :
795 :			| CONspec{spec=DATACON{typ=acttyp, name, const,
796 :	monnier	106	rep, sign, lazyp}, slot} =>
797 :	monnier	16	let val spectyp = typeInMatched("$specty(val/con)", spectyp)
798 :			val acttyp = typeInOriginal("$actty(val/con)", acttyp)
799 :			val (instys, btvs) =
800 :			matchTypes(spectyp, acttyp, II.nullInfo, name)
801 :
802 :			val nrep =
803 :			case slot
804 :			of SOME s => exnRep(rep, DA.selAcc(rootAcc, s))
805 :			| NONE => rep
806 :
807 :			val (decs', bindings') =
808 :			let val con =
809 :			DATACON{typ=acttyp, name=name, const=const,
810 :	monnier	106	rep=nrep, sign=sign, lazyp=lazyp}
811 :	monnier	16	val acc = DA.namedAcc(name, mkv)
812 :			val specvar =
813 :			VALvar{path=SP.SPATH[name], access=acc,
814 :			info=II.nullInfo, typ=ref spectyp}
815 :			val vb =
816 :			A.VB {pat=A.VARpat specvar,
817 :			exp=A.CONexp(con, instys),
818 :			boundtvs=btvs, tyvars=ref []}
819 :			in ((A.VALdec [vb])::decs,
820 :			(B.VALbind specvar)::bindings)
821 :			end
822 :			in matchElems(elems, entEnv, entDecs, decs',
823 :			bindings', succeed)
824 :			end
825 :
826 :			| _ => bug "matchVElem.1")
827 :			handle MU.Unbound sym => matchErr(SOME "value"))
828 :
829 :	monnier	106	| CONspec{spec=DATACON{name, typ=spectyp, lazyp,
830 :	monnier	16	rep=specrep, ...},...} =>
831 :			((case MU.getSpec(strElements, sym)
832 :			of CONspec{spec=DATACON{typ=acttyp, rep=actrep, const,
833 :			sign, ...}, slot} =>
834 :			if (DA.isExn specrep) = (DA.isExn actrep) then
835 :			let val spectyp = typeInMatched("$specty(con/con)", spectyp)
836 :			val acttyp = typeInOriginal("$actty(con/con)", acttyp)
837 :			val _ = matchTypes(spectyp, acttyp, II.nullInfo, name)
838 :
839 :			val bindings' =
840 :			case slot
841 :			of NONE => bindings
842 :			| SOME s =>
843 :			let val dacc = DA.selAcc(rootAcc, s)
844 :			val nrep = exnRep(actrep, dacc)
845 :			val con = DATACON{typ=acttyp, name=name,
846 :			const=const, rep=nrep,
847 :	monnier	106	sign=sign, lazyp=lazyp}
848 :	monnier	16	in (B.CONbind(con)) :: bindings
849 :			end
850 :
851 :			in matchElems(elems, entEnv, entDecs, decs, bindings', succeed)
852 :			end
853 :			else raise MU.Unbound sym
854 :
855 :			| VALspec _ =>
856 :			if DA.isExn specrep then matchErr(SOME "exception")
857 :			else matchErr(SOME "constructor")
858 :			| _ => bug "matchVElem.2")
859 :			handle MU.Unbound sym =>
860 :			if DA.isExn specrep then matchErr(SOME "exception")
861 :			else matchErr(SOME "constructor"))
862 :
863 :			end (* function matchElems *)
864 :
865 :			fun matchIt entEnv =
866 :			let val _ = debugmsg ">>matchIt"
867 :
868 :			val (resultEntEnv, entDecs, absDecs, bindings, succeed) =
869 :			matchElems(sigElements, entEnv, [], [], [], true)
870 :			handle EE.Unbound => (debugmsg "$matchIt 1"; raise EE.Unbound)
871 :			in if succeed then
872 :			let val resultEntEnv = EE.mark(mkStamp, resultEntEnv)
873 :			val _ = debugmsg "--matchIt: elements matched successfully"
874 :
875 :			val _ = checkSharing(specSig, resultEntEnv)
876 :			handle EE.Unbound => (debugmsg "$matchIt 3"; raise EE.Unbound)
877 :			val _ = debugmsg "--matchIt: sharing checked"
878 :
879 :			val resStr =
880 :			let val strEnt = {stamp = strStamp, entities = resultEntEnv,
881 :			lambdaty = ref NONE, rpath=rpath}
882 :			val dacc = DA.newAcc(mkv)
883 :			val dinfo = II.mkStrInfo (map MU.extractInfo bindings)
884 :			in M.STR{sign=specSig, rlzn=strEnt, access=dacc, info=dinfo}
885 :			end
886 :
887 :			val resDec =
888 :			let val body = A.LETstr(A.SEQdec absDecs, A.STRstr bindings)
889 :			in A.STRdec [A.STRB{name=strName, str=resStr, def=body}]
890 :			end
891 :
892 :			val resExp = M.STRUCTURE{stamp = GETSTAMP(M.VARstr(rev epath)),
893 :			entDec = SEQdec(entDecs)}
894 :
895 :			val _ = debugmsg "<<matchIt"
896 :			in (resDec, resStr, resExp)
897 :			end
898 :			else (A.SEQdec[],ERRORstr,M.CONSTstr(M.bogusStrEntity))
899 :			end
900 :
901 :			in
902 :
903 :			(* we should not do such short-cut matching because we need to
904 :			recalculuate the tycpath information for functor components.
905 :			But completely turning this off is a bit too expensive, so
906 :			we add a fctflag in the signature to indicate whether it
907 :			contains functor components.
908 :			*)
909 :			if (ST.eq(sigStamp, strSigStamp)) andalso closed andalso (not fctflag)
910 :			then (A.SEQdec [], str, M.VARstr (rev epath)) (* short-cut matching *)
911 :			else matchIt (if closed then EE.empty else matchEntEnv)
912 :			end
913 :
914 :			| matchStr1 _ = (A.SEQdec [], ERRORstr, bogusStrExp)
915 :			(* end of matchStr1 *)
916 :
917 :
918 :			(***************************************************************************
919 :			* val matchStr : *
920 :			* *
921 :			* {sign : Modules.Signature, *
922 :			* str : Modules.Structure, *
923 :			* strExp : Modules.strExp, *
924 :			* evOp : EntPath.entVar, *
925 :			* depth : DebIndex.depth, *
926 :			* entEnv : Modules.entityEnv, *
927 :			* rpath : InvPath.path, *
928 :			* statenv : StaticEnv.staticEnv, *
929 :			* region : SourceMap.region, *
930 :			* compInfo : ElabUtil.compInfo} -> {resDec : Absyn.dec, *
931 :			* resStr : Modules.Structure, *
932 :			* resExp : Modules.strExp} *
933 :			* *
934 :			***************************************************************************)
935 :			and matchStr {sign, str, strExp, evOp, depth, entEnv, rpath, statenv, region,
936 :			compInfo=compInfo as {mkStamp,...}: EU.compInfo} =
937 :
938 :			let val _ = debugmsg ">>matchStr"
939 :
940 :			val uncoerced = case evOp of SOME x => x | NONE => mkStamp()
941 :			val (resDec, resStr, exp) =
942 :			matchStr1 (sign, str, anonSym, depth, entEnv, [uncoerced], rpath,
943 :			statenv, region, compInfo)
944 :
945 :			val resExp = M.CONSTRAINstr{boundvar=uncoerced, raw=strExp, coercion=exp}
946 :			(* val resExp = M.LETstr(M.STRdec(uncoerced, strExp), exp) *)
947 :			(* val resExp = M.APPLY(M.LAMBDA{param=uncoerced, body=exp}, strExp) *)
948 :			val _ = debugmsg "<<matchStr"
949 :
950 :			in {resDec=resDec, resStr=resStr, resExp=resExp}
951 :			end
952 :			handle EE.Unbound => (debugmsg "$matchStr"; raise EE.Unbound)
953 :
954 :
955 :			(***************************************************************************
956 :			* *
957 :			* Matching a functor against a functor signature: *
958 :			* *
959 :			* val matchFct1 : fctSig * Functor * S.symbol * DI.depth * *
960 :			* entityEnv * M.fctExp * IP.path * staticEnv * *
961 :			* region * EU.compInfo *
962 :			* -> A.dec * M.Functor * M.fctExp *
963 :			* *
964 :			* Arguments: funsig F(fsigParVar : fsigParSig) = fsigBodySig *
965 :			* functor F(fctParVar : fctParSig) : fctBodySig = bodyExp *
966 :			* *
967 :			* Result: functor F(fctParVar : fctParSig) : fctBodySig = resBodyExp *
968 :			* *
969 :			***************************************************************************)
970 :			and matchFct1(specSig as FSIG{paramsig=fsigParamSig,paramvar=fsigParamVar,
971 :			paramsym,bodysig=fsigBodySig,...},
972 :			fct as FCT{rlzn=fctRlzn, ...}, fctName : S.symbol,
973 :			depth, entEnv, uncoercedFct, rpath, statenv, region,
974 :			compInfo as {mkStamp, mkLvar=mkv,...}: EU.compInfo)
975 :			: A.dec * M.Functor * M.fctExp =
976 :			(let
977 :
978 :			(*** the entity var for the source functor "uncoercedFct" *)
979 :			val uncoerced = mkStamp()
980 :			val srcFctExp = M.VARfct [uncoerced]
981 :			val paramSym = case paramsym of SOME x => x
982 :			| NONE => paramSym
983 :
984 :			(*** parameter signature instantiation ***)
985 :			val {rlzn=fsigParEnt, tycpaths=paramTps} =
986 :			INS.instParam{sign=fsigParamSig, entEnv=entEnv, depth=depth,
987 :			rpath=IP.IPATH[paramSym], region=region, compInfo=compInfo}
988 :
989 :			val depth'= DI.next depth
990 :			val fsigParInst =
991 :			let val fsigParDacc = DA.newAcc(mkv)
992 :			in M.STR{sign=fsigParamSig, rlzn=fsigParEnt,
993 :			access=fsigParDacc, info=II.nullInfo}
994 :			end
995 :
996 :			(*** applying fct to the fsigParInst structure ***)
997 :			val paramId = fsigParamVar (* mkStamp() *)
998 :			val {resDec=resDec1, resStr=resStr1, resExp=resExp1} =
999 :			let val paramExp = M.VARstr [paramId]
1000 :			in applyFct{fct=fct, fctExp=srcFctExp, argStr=fsigParInst,
1001 :			argExp=paramExp, evOp=NONE, depth=depth',
1002 :			epc=EPC.initContext (* ? ZHONG *), statenv=statenv,
1003 :			rpath = IP.empty, region=region, compInfo=compInfo}
1004 :			end
1005 :
1006 :			(*** matching the result structure against the body sig ***)
1007 :			val fsigBodySigEnv = EE.bind(fsigParamVar, STRent fsigParEnt, entEnv)
1008 :			val {resDec=resDec2, resStr=resStr2, resExp=resExp2} =
1009 :			let val rp = IP.IPATH[S.strSymbol "<FctResult>"]
1010 :			in matchStr{sign=fsigBodySig, str=resStr1, strExp=resExp1, evOp=NONE,
1011 :			depth=depth', entEnv=fsigBodySigEnv, rpath=rp,
1012 :			statenv=statenv, region=region, compInfo=compInfo}
1013 :			end
1014 :
1015 :			(*** constructing the tycpath for the resulting functor ***)
1016 :			val resTps =
1017 :			case resStr2
1018 :			of M.STR{rlzn, sign, ...} =>
1019 :			INS.getTycPaths{sign=sign, rlzn=rlzn, entEnv=fsigBodySigEnv,
1020 :			compInfo=compInfo}
1021 :			| _ => []
1022 :
1023 :			(*** the resulting coerced functor ***)
1024 :			val resFct =
1025 :			let val resExp3 = M.LETstr(M.FCTdec(uncoerced, M.CONSTfct fctRlzn),
1026 :			resExp2)
1027 :			val resClosure = CLOSURE{param=paramId, body=resExp3, env=entEnv}
1028 :			val tps = T.TP_FCT(paramTps, resTps)
1029 :
1030 :			val resRlzn = {stamp = (#stamp fctRlzn), (*** DAVE ? ***)
1031 :			closure = resClosure, rpath=rpath,
1032 :			tycpath=SOME tps, lambdaty=ref NONE}
1033 :
1034 :			in FCT{sign = specSig, rlzn = resRlzn,
1035 :			access = DA.newAcc(mkv), info = II.nullInfo}
1036 :			end
1037 :
1038 :			(*** the resulting functor absyn ***)
1039 :			val fdec =
1040 :			let val bodyAbs = A.LETstr(A.SEQdec [resDec1, resDec2], A.VARstr resStr2)
1041 :			val fctexp = A.FCTfct {param=fsigParInst, argtycs=paramTps, def=bodyAbs}
1042 :			in A.FCTdec [A.FCTB {name=anonFsym, fct=resFct, def=fctexp}]
1043 :			end
1044 :
1045 :			(*** the functor entity expression ***)
1046 :			val fctExp =
1047 :			M.LETfct(M.FCTdec(uncoerced, uncoercedFct),
1048 :			M.LAMBDA_TP{param = paramId, body = resExp2, sign=specSig})
1049 :
1050 :			in
1051 :			(fdec, resFct, fctExp)
1052 :
1053 :			end handle Match => (A.SEQdec [], ERRORfct, bogusFctExp))
1054 :			(*
1055 :			* This is intended to handle only the two left-hand side
1056 :			* occurrences of STR{ ... } above, and is very crude.
1057 :			* It should be replaced by case-expressions on the results of
1058 :			* match etc.
1059 :			*)
1060 :
1061 :			| matchFct1 _ = (A.SEQdec [], ERRORfct, bogusFctExp)
1062 :
1063 :
1064 :			(***************************************************************************
1065 :			* *
1066 :			* val matchFct : *
1067 :			* *
1068 :			* {sign : Modules.fctSig, *
1069 :			* fct : Modules.Functor, *
1070 :			* fctExp : Modules.fctExp, *
1071 :			* depth : DebIndex.depth, *
1072 :			* entEnv : Modules.entityEnv, *
1073 :			* rpath : InvPath.path, *
1074 :			* statenv : StaticEnv.staticEnv, *
1075 :			* region : SourceMap.region, *
1076 :			* compInfo : ElabUtil.compInfo} -> {resDec : Absyn.dec, *
1077 :			* resFct : Modules.Functor, *
1078 :			* resExp : Modules.fctExp} *
1079 :			* *
1080 :			***************************************************************************)
1081 :			and matchFct{sign, fct, fctExp, depth, entEnv, rpath,
1082 :			statenv, region, compInfo} =
1083 :			let val _ = debugmsg ">>matchFct"
1084 :
1085 :			val (resDec, resFct, resExp) =
1086 :			matchFct1 (sign, fct, anonFsym, depth, entEnv, fctExp, rpath,
1087 :			statenv, region, compInfo)
1088 :
1089 :			val _ = debugmsg "<<matchFct"
1090 :
1091 :			in {resDec=resDec, resFct=resFct, resExp=resExp}
1092 :			end
1093 :			handle EE.Unbound => (debugmsg "$matchFct"; raise EE.Unbound)
1094 :
1095 :
1096 :			(**************************************************************************
1097 :			* *
1098 :			* Packing a structure against a signature: *
1099 :			* *
1100 :			* val packStr1 : Signature * strEntity * Structure * TU.tycset * *
1101 :			* S.symbol * int * entityEnv * IP.path * staticEnv * *
1102 :			* region * EU.compInfo -> A.dec * M.Structure *
1103 :			* *
1104 :			**************************************************************************)
1105 :			and packStr1(specSig as M.SIG {elements=sigElements, ...},
1106 :			resRlzn as {entities=resEntEnv, ...},
1107 :			str as M.STR {rlzn=srcRlzn as {entities=srcEntEnv, ...},
1108 :			access=rootAcc, info=rootInfo, ...},
1109 :			abstycs, strName, depth, entEnv, rpath, statenv, region,
1110 :			compInfo as {mkLvar=mkv, error, ...}: EU.compInfo)
1111 :			: Absyn.dec * M.Structure =
1112 :
1113 :			let
1114 :
1115 :			fun typeInRes (kind,typ) =
1116 :			(MU.transType resEntEnv typ)
1117 :			handle EE.Unbound =>
1118 :			(debugPrint (debugging) (kind, PPType.ppType statenv, typ);
1119 :			raise EE.Unbound)
1120 :
1121 :			fun typeInSrc (kind,typ) =
1122 :			(MU.transType srcEntEnv typ)
1123 :			handle EE.Unbound =>
1124 :			(debugPrint (debugging) (kind, PPType.ppType statenv, typ);
1125 :			raise EE.Unbound)
1126 :
1127 :			fun packElems ([], entEnv, decs, bindings) = (rev decs, rev bindings)
1128 :			| packElems ((sym, spec) :: elems, entEnv, decs, bindings) =
1129 :			let val _ = debugmsg ">>packElems"
1130 :			in case spec
1131 :			of STRspec{sign=thisSpecsig, entVar=ev, slot=s,...} =>
1132 :			(case (EE.look(resEntEnv, ev), EE.look(srcEntEnv, ev))
1133 :			of (M.STRent resStrRlzn, M.STRent srcStrRlzn) =>
1134 :			let val srcStr = M.STR{sign=thisSpecsig, rlzn=srcStrRlzn,
1135 :			access=DA.selAcc(rootAcc,s),
1136 :			info=II.selInfo(rootInfo,s)}
1137 :
1138 :			val rpath' = IP.extend(rpath, sym)
1139 :			val (thinDec, thinStr) =
1140 :			packStr1(thisSpecsig, resStrRlzn, srcStr, abstycs,
1141 :			sym, depth, entEnv, rpath', statenv,
1142 :			region, compInfo)
1143 :
1144 :			val entEnv' =
1145 :			let val strEnt =
1146 :			case thinStr of M.STR{rlzn, ...} => rlzn
1147 :			| _ => M.bogusStrEntity
1148 :			in EE.bind(ev, M.STRent strEnt, entEnv)
1149 :			end
1150 :
1151 :			val decs' = thinDec :: decs
1152 :			val bindings' = (B.STRbind thinStr) :: bindings
1153 :
1154 :			in packElems(elems, entEnv', decs', bindings')
1155 :			end
1156 :			| _ => (* missing element, error has occurred - do nothing *)
1157 :			packElems(elems, entEnv, decs, bindings))
1158 :
1159 :			| FCTspec{sign=thisSpecsig, entVar=ev, slot=s} =>
1160 :			(case (EE.look(resEntEnv, ev), EE.look(srcEntEnv, ev))
1161 :			of (M.FCTent resFctRlzn, M.FCTent srcFctRlzn) =>
1162 :			let val srcFct = M.FCT{sign=thisSpecsig, rlzn=srcFctRlzn,
1163 :			access=DA.selAcc(rootAcc,s),
1164 :			info=II.selInfo(rootInfo,s)}
1165 :
1166 :			val rpath' = IP.extend(rpath, sym)
1167 :
1168 :			val (thinDec, thinFct) =
1169 :			packFct1(thisSpecsig, resFctRlzn, srcFct, abstycs,
1170 :			sym, depth, entEnv, rpath', statenv,
1171 :			region, compInfo)
1172 :
1173 :			val entEnv' =
1174 :			let val fctEnt =
1175 :			case thinFct of M.FCT{rlzn, ...} => rlzn
1176 :			| _ => M.bogusFctEntity
1177 :			in EE.bind(ev, M.FCTent fctEnt, entEnv)
1178 :			end
1179 :
1180 :			val decs' = thinDec :: decs
1181 :			val bindings' = (B.FCTbind thinFct) :: bindings
1182 :
1183 :			in packElems(elems, entEnv', decs', bindings')
1184 :			end
1185 :			| _ => packElems(elems, entEnv, decs, bindings))
1186 :
1187 :			| VALspec{spec=spectyp, slot=s} =>
1188 :			(let val restyp = typeInRes("$spec-resty(packStr-val)", spectyp)
1189 :			val srctyp = typeInSrc("$spec-srcty(packStr-val)", spectyp)
1190 :			val dacc = DA.selAcc(rootAcc, s)
1191 :			val dinfo = II.selInfo(rootInfo, s)
1192 :			val (instys, btvs, resinst, eqflag) =
1193 :			absEqvTy(restyp, srctyp, dinfo)
1194 :
1195 :			val spath = SP.SPATH[sym]
1196 :			val srcvar = VALvar{path=spath, typ=ref srctyp,
1197 :			access=dacc, info=dinfo}
1198 :
1199 :			val (decs', nv) =
1200 :			if eqflag then (decs, srcvar)
1201 :			else (let val acc = DA.namedAcc(sym, mkv)
1202 :			val resvar =
1203 :			VALvar{path=spath, typ=ref restyp,
1204 :			access=acc, info=II.nullInfo}
1205 :
1206 :			val ntycs = TU.filterSet(resinst, abstycs)
1207 :			val exp =
1208 :			A.PACKexp(A.VARexp(ref srcvar, instys),
1209 :			resinst, ntycs)
1210 :
1211 :			val vb = A.VB {pat=(A.VARpat resvar), exp=exp,
1212 :			boundtvs=btvs, tyvars=ref []}
1213 :
1214 :			in ((A.VALdec [vb])::decs, resvar)
1215 :			end)
1216 :
1217 :
1218 :			val bindings' = (B.VALbind nv)::bindings
1219 :			in packElems(elems, entEnv, decs', bindings')
1220 :			end)
1221 :
1222 :	monnier	106	| CONspec{spec=DATACON{name, typ, rep, const, sign, lazyp}, slot} =>
1223 :	monnier	16	(let val bindings' =
1224 :			case slot
1225 :			of NONE => bindings
1226 :			| SOME s =>
1227 :			let val restyp =
1228 :			typeInRes("$spec-resty(packStr-con)", typ)
1229 :			val dacc = DA.selAcc(rootAcc, s)
1230 :			val nrep = exnRep(rep, dacc)
1231 :	monnier	106	val con = DATACON{typ=restyp, name=name, lazyp=lazyp,
1232 :	monnier	16	const=const, rep=nrep, sign=sign}
1233 :			in (B.CONbind(con)) :: bindings
1234 :			end
1235 :
1236 :			in packElems(elems, entEnv, decs, bindings')
1237 :			end)
1238 :
1239 :			| TYCspec{spec=specTycon,entVar=ev,scope} =>
1240 :			(let val entEnv' = EE.bind(ev, EE.look(resEntEnv, ev), entEnv)
1241 :			in packElems(elems, entEnv', decs, bindings)
1242 :			end)
1243 :
1244 :			end (* function packElems *)
1245 :
1246 :
1247 :			val (absDecs, bindings) = packElems(sigElements, entEnv, [], [])
1248 :
1249 :			val resStr =
1250 :			let val dacc = DA.newAcc(mkv)
1251 :			val dinfo = II.mkStrInfo (map MU.extractInfo bindings)
1252 :			in M.STR{sign=specSig, rlzn=resRlzn, access=dacc, info=dinfo}
1253 :			end
1254 :
1255 :			val resDec =
1256 :			let val body = A.LETstr(A.SEQdec absDecs, A.STRstr bindings)
1257 :			in A.STRdec [A.STRB{name=strName, str=resStr, def=body}]
1258 :			end
1259 :
1260 :			in (resDec, resStr)
1261 :			end
1262 :
1263 :			| packStr1 _ = (A.SEQdec [], ERRORstr)
1264 :
1265 :
1266 :			(***************************************************************************
1267 :			* Abstraction matching of a structure against a signature: *
1268 :			* *
1269 :			* val packStr : *
1270 :			* {sign : Modules.Signature, *
1271 :			* str : Modules.Structure, *
1272 :			* strExp : Modules.strExp, *
1273 :			* depth : DebIndex.depth, *
1274 :			* entEnv : Modules.entityEnv, *
1275 :			* rpath : InvPath.path, *
1276 :			* statenv : StaticEnv.staticEnv, *
1277 :			* region : SourceMap.region, *
1278 :			* compInfo : ElabUtil.compInfo} -> {resDec : Absyn.dec, *
1279 :			* resStr : Modules.Structure, *
1280 :			* resExp : Modules.strExp} *
1281 :			* *
1282 :			* INVARIANT: the base signature for str should be exactly sign; in other *
1283 :			* words, str should have been matched against sign before it *
1284 :			* being packed against sign. *
1285 :			***************************************************************************)
1286 :			and packStr {sign, str, strExp, depth, entEnv, rpath,
1287 :			statenv, region, compInfo} =
1288 :			let val _ = debugmsg ">>>packStr"
1289 :
1290 :			val {rlzn=resRlzn, abstycs=abstycs, tyceps=_} =
1291 :			let val srcRlzn = case str of M.STR{rlzn, ...} => rlzn
1292 :			| _ => M.bogusStrEntity
1293 :			in INS.instAbstr {sign=sign, entEnv=entEnv, srcRlzn=srcRlzn,
1294 :			rpath=rpath, region=region, compInfo=compInfo}
1295 :			end
1296 :			val _ = debugmsg "packStr - instantiate done"
1297 :
1298 :			val abstycs' = foldr TU.addTycSet (TU.mkTycSet()) abstycs
1299 :
1300 :			val (resDec, resStr) =
1301 :			packStr1 (sign, resRlzn, str, abstycs', anonSym, depth,
1302 :			entEnv, rpath, statenv, region, compInfo)
1303 :			val _ = debugmsg "packStr - packStr1 done"
1304 :
1305 :			val resExp = M.ABSstr(sign, strExp)
1306 :			val _ = debugmsg "<<<packStr"
1307 :
1308 :			in {resDec=resDec, resStr=resStr, resExp=resExp}
1309 :			end
1310 :
1311 :
1312 :			(***************************************************************************
1313 :			* *
1314 :			* Packing a functor against a functor signature: *
1315 :			* *
1316 :			* val packFct1 : fctSig * fctEntity * Functor * tycon list * *
1317 :			* S.symbol * DI.depth * entityEnv * IP.path * staticEnv * *
1318 :			* region * EU.compInfo -> A.dec * M.Functor *
1319 :			* *
1320 :			***************************************************************************)
1321 :			and packFct1(specSig as FSIG{paramsig, paramvar, bodysig, ...}, resFctRlzn,
1322 :			srcFct as FCT {rlzn=srcFctRlzn, ...},
1323 :			abstycs1, fctName, depth, entEnv, rpath, statenv, region,
1324 :			compInfo as {mkStamp, mkLvar=mkv, error, ...}: EU.compInfo)
1325 :			: Absyn.dec * M.Functor =
1326 :
1327 :			let
1328 :
1329 :			val {rlzn=paramEnt, tycpaths=paramTps} =
1330 :			INS.instParam{sign=paramsig, entEnv=entEnv, depth=depth,
1331 :			rpath=IP.IPATH[paramSym], region=region, compInfo=compInfo}
1332 :
1333 :			val depth'= DI.next depth
1334 :			val paramStr =
1335 :			let val paramDacc = DA.newAcc(mkv)
1336 :			in M.STR{sign=paramsig, rlzn=paramEnt, access=paramDacc, info=II.nullInfo}
1337 :			end
1338 :
1339 :			val {resDec=rdec1, resStr=bodyStr, resExp=_} =
1340 :			applyFct{fct=srcFct, fctExp=CONSTfct srcFctRlzn, argStr=paramStr,
1341 :			argExp=CONSTstr paramEnt, evOp=NONE, depth=depth',
1342 :			epc=EPC.initContext (* ? ZHONG *), statenv=statenv,
1343 :			rpath=IP.empty, region=region, compInfo=compInfo}
1344 :
1345 :			(* val bodyRlzn = EV.evalApp(srcFctRlzn, paramEnt, depth', epc, compInfo) *)
1346 :			val bodyRlzn =
1347 :			case bodyStr of M.STR {rlzn, ...} => rlzn
1348 :			| _ => M.bogusStrEntity
1349 :
1350 :			val {rlzn=resRlzn, abstycs=abstycs2, tyceps=_} =
1351 :			let val entEnv' =
1352 :			EE.mark(mkStamp, EE.bind(paramvar, STRent paramEnt, entEnv))
1353 :			in INS.instAbstr {sign=bodysig, entEnv=entEnv', srcRlzn=bodyRlzn,
1354 :			rpath=rpath, region=region, compInfo=compInfo}
1355 :			end
1356 :
1357 :			val abstycs = foldr TU.addTycSet abstycs1 abstycs2
1358 :
1359 :			val (rdec2, resStr) =
1360 :			let val rpath' = IP.IPATH[S.strSymbol "<FctResult>"]
1361 :			in packStr1(bodysig, resRlzn, bodyStr, abstycs, anonSym,
1362 :			depth', entEnv, rpath', statenv, region, compInfo)
1363 :			end
1364 :
1365 :			val resFct =
1366 :			let val resDacc = DA.newAcc(mkv)
1367 :			in M.FCT{sign=specSig, rlzn=resFctRlzn, access=resDacc, info=II.nullInfo}
1368 :			end
1369 :
1370 :			val resDec =
1371 :			let val body = A.LETstr(rdec1, A.LETstr(rdec2, A.VARstr resStr))
1372 :			val fctexp = A.FCTfct{param=paramStr, argtycs=paramTps, def=body}
1373 :			in A.FCTdec [A.FCTB {name=fctName, fct=resFct, def=fctexp}]
1374 :			end
1375 :
1376 :			in (resDec, resFct)
1377 :
1378 :			end (* function packFct1 *)
1379 :
1380 :			| packFct1 _ = (A.SEQdec [], ERRORfct)
1381 :
1382 :
1383 :			(***************************************************************************
1384 :			* val applyFct : *
1385 :			* *
1386 :			* {fct : Modules.Functor, *
1387 :			* fctExp : Modules.fctExp, *
1388 :			* argStr : Modules.Structure, *
1389 :			* argExp : Modules.strExp, *
1390 :			* evOp : EntPath.entVar option, *
1391 :			* depth : DebIndex.depth, *
1392 :			* epc : EntPathContext.context, *
1393 :			* statenv : StaticEnv.staticEnv, *
1394 :			* rpath : InvPath.path, *
1395 :			* region : SourceMap.region, *
1396 :			* compInfo : ElabUtil.compInfo} -> {resDec : Absyn.dec, *
1397 :			* resStr : Modules.Structure, *
1398 :			* resExp : Modules.strExp} *
1399 :			* *
1400 :			* Matches and coerces the argument and then do the functor application. *
1401 :			* Returns the result structure, the result entity expression, and the *
1402 :			* result abstract syntax declaration of resStr. *
1403 :			* *
1404 :			* The argument matching takes place in the entityEnv stored in the *
1405 :			* functor closure; this is where the paramsig must be interpreted. *
1406 :			* *
1407 :			***************************************************************************)
1408 :			and applyFct{fct as FCT{sign=FSIG{paramsig, bodysig, ...},
1409 :			rlzn = fctRlzn as {closure=CLOSURE{env=fctEntEnv,
1410 :			...}, ...},
1411 :			...},
1412 :			fctExp, argStr, argExp, evOp, epc, depth, statenv, rpath, region,
1413 :			compInfo as {mkStamp, mkLvar=mkv, ...}} =
1414 :
1415 :			let val _ = debugmsg ">>applyFct"
1416 :
1417 :			(*** step #1: match the argument structure against paramSig ***)
1418 :			val {resDec=argDec1, resStr=argStr1, resExp=argExp1} =
1419 :			matchStr {sign=paramsig, str=argStr, strExp=argExp, evOp=evOp,
1420 :			depth=depth, entEnv=fctEntEnv, rpath=IP.IPATH[] (* ?DAVE *),
1421 :			statenv=statenv, region=region, compInfo=compInfo}
1422 :
1423 :			(*** step #2: do the functor application ***)
1424 :			val argRlzn = case argStr1 of M.STR{rlzn, ...} => rlzn
1425 :			| _ => M.bogusStrEntity
1426 :			val bodyRlzn = EV.evalApp(fctRlzn, argRlzn, depth, epc, rpath, compInfo)
1427 :			val resStr =
1428 :			let val bodyDacc = DA.namedAcc(anonSym,mkv)
1429 :			in M.STR {sign=bodysig, rlzn=bodyRlzn,
1430 :			access=bodyDacc, info=II.nullInfo}
1431 :			end
1432 :
1433 :			val resDec =
1434 :			let val argtycs = INS.getTycPaths{sign=paramsig, rlzn=argRlzn,
1435 :			entEnv=fctEntEnv, compInfo=compInfo}
1436 :			val body = A.APPstr{oper=fct, arg=argStr1, argtycs=argtycs}
1437 :			val resAbs = A.LETstr(argDec1, body)
1438 :
1439 :			in A.STRdec [A.STRB{name=anonSym, str=resStr, def=resAbs}]
1440 :			end
1441 :
1442 :			val resExp = M.APPLY(fctExp, argExp1)
1443 :			val _ = debugmsg "<<applyFct"
1444 :
1445 :			in {resDec=resDec, resStr=resStr, resExp=resExp}
1446 :			end
1447 :
1448 :			| applyFct {fct=ERRORfct, ...} =
1449 :			{resDec=A.STRdec [], resStr=M.ERRORstr,
1450 :			resExp=M.CONSTstr M.bogusStrEntity}
1451 :			| applyFct _ = bug "unexpected case in applyFct"
1452 :
1453 :
1454 :			(*** top leve wrappers: used for profiling the compilation time *)
1455 :			(*
1456 :			val matchStr =
1457 :			Stats.doPhase (Stats.makePhase "Compiler 034 1-matchStr") matchStr
1458 :
1459 :			val matchFct =
1460 :			Stats.doPhase (Stats.makePhase "Compiler 034 2-matchFct") matchFct
1461 :
1462 :			val packStr =
1463 :			Stats.doPhase (Stats.makePhase "Compiler 034 3-packStr") packStr
1464 :
1465 :			val applyFct =
1466 :			Stats.doPhase (Stats.makePhase "Compiler 034 4-applyFct") applyFct
1467 :			*)
1468 :
1469 :			end (* local *)
1470 :			end (* structure SigMatch *)
1471 :
1472 :
1473 :			(*
1474 :	monnier	113	* $Log$
1475 :	monnier	16	*)
1476 :

---

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