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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2389 - (view) (download)

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

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