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/FLINT/trans/reptycprops.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch-3/compiler/FLINT/trans/reptycprops.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3293 - (view) (download)

1 : gkuan 2751 (* reptycprops.sml
2 :    
3 : gkuan 3293 This module processes the static information (realizations and signatures)
4 :     to obtain primary type component information for Translate. It fills in
5 :     tycpath and sigBoundeps information.
6 : gkuan 2751
7 :     sigBoundeps is a list of the representative entities for a signature
8 : gkuan 2963 This is used to determine which tycs in a functor parameter are
9 :     representative
10 : gkuan 2751 (and therefore we need to compute the FLINT kinds)
11 :    
12 : dbm 3224 Datatype bindings must be accounted for in Tycpath computations
13 : gkuan 2963 because they will be represented as TP_TYC(...).
14 : gkuan 2751 *)
15 :    
16 : dbm 3287 (* DBM [4/7/09]
17 :     * all references to bodyRlzn need to be removed, and functor closures should
18 :     * be used instead.
19 :     *)
20 :    
21 : gkuan 2972 signature REPTYCPROPS =
22 :     sig
23 : gkuan 3006 val getTk : Modules.fctSig * Modules.strEntity * Modules.strEntity
24 : gkuan 2989 * DebIndex.depth
25 : gkuan 3293 -> (TypesTP.tycpath list * TypesTP.tycpath FlexTycMap.map)
26 : gkuan 3027 val primaryCompInStruct : TypesTP.tycpath FlexTycMap.map * Modules.strEntity
27 :     * Modules.strEntity * Modules.Signature
28 :     * DebIndex.depth
29 :     -> TypesTP.tycpath FlexTycMap.map
30 :     * TypesTP.tycpath list
31 : gkuan 2972 end
32 :    
33 :     structure RepTycProps : REPTYCPROPS =
34 : gkuan 2751 struct
35 :    
36 :     local
37 :     structure M = Modules
38 :     structure TP = Types
39 : gkuan 2961 structure T = TypesTP
40 : gkuan 2751 structure EE = EntityEnv
41 :     structure EP = EntPath
42 :     structure SE = StaticEnv
43 :     structure PP = PrettyPrintNew
44 :     structure DI = DebIndex
45 :     structure LT = LtyExtern
46 :     structure TU = TypesUtil
47 :     structure S = Symbol
48 : gkuan 3293 (* structure AT = AbsynTP *)
49 : gkuan 2961 structure V = VarCon
50 : gkuan 2972 structure FTM = FlexTycMap
51 : gkuan 2751
52 : dbm 3045 (* A map from entity TYC or FCT stamps to the first corresponding EP *)
53 : gkuan 2751 structure EPMap = RedBlackMapFn (type ord_key = Stamps.stamp
54 :     val compare = Stamps.compare)
55 : dbm 3045 (* A StampSet ADT to keep track of unique stamps (embedded in different
56 : gkuan 2964 structures) we have seen *)
57 :     structure StampSet = RedBlackSetFn (type ord_key = Stamps.stamp
58 :     val compare = Stamps.compare)
59 : gkuan 2972
60 : gkuan 2751 open Absyn
61 : gkuan 2972
62 :     fun unionMaps [] = FTM.empty
63 :     | unionMaps (m::ms) = FTM.unionWith(fn(tp1,tp2) => tp1)
64 :     (m, unionMaps ms)
65 :    
66 : gkuan 2751 in
67 : gkuan 2976 val debugging = FLINT_Control.trdebugging
68 : gkuan 2751 val printStrFct = ref true
69 :    
70 :     (* Support functions *)
71 : dbm 3045 fun debugmsg(m) =
72 :     if !debugging then print ("RepTycProps: "^m^"\n") else ()
73 :    
74 : gkuan 2751 fun bug msg = ErrorMsg.impossible("RepTycProps: " ^ msg)
75 :    
76 : gkuan 2972 fun insertMap(m, x, obj) =
77 :     (debugmsg ("--insertMap "^Stamps.toShortString x);
78 : gkuan 3006 (case FTM.find(m, x)
79 :     of SOME _ => m
80 :     | NONE => (FTM.insert(m, x, obj))))
81 : gkuan 2972
82 : dbm 3045 (* prettyprinting functions for debugging *)
83 : gkuan 2751 local
84 :     structure ED = ElabDebug
85 : dbm 3045 structure PM = PPModules
86 : gkuan 2751 fun with_pp f = PP.with_default_pp f
87 :     in
88 : dbm 3045 fun ppTP tp = print "<tycpath>"
89 : gkuan 2961 (* ED.withInternals(
90 :     fn() => with_pp (
91 :     fn ppstrm => (print "\n";
92 :     PPType.ppTycPath SE.empty ppstrm tp;
93 :     print "\n"))) *)
94 : dbm 3045
95 : gkuan 2963 (* s denotes ppstrm *)
96 :    
97 :     fun ppSig sign =
98 :     let val pp = fn s =>
99 :     (PM.ppSignature s (sign, SE.empty, 20);
100 :     print "\n")
101 :     in
102 :     ED.withInternals (fn() => with_pp pp)
103 :     end
104 :    
105 :    
106 : gkuan 2751 fun ppEnt ent =
107 : gkuan 2963 with_pp (fn s => (PM.ppEntity s (ent, SE.empty, 20); print "\n"))
108 : gkuan 2751 fun ppEntities entenv =
109 : gkuan 2963 with_pp (fn s => (PM.ppEntityEnv s (entenv, SE.empty, 20); print "\n"))
110 : gkuan 2751 fun ppTycon tyc =
111 : gkuan 2963 ED.withInternals
112 :     (fn () => with_pp (fn s => (print "\n";
113 :     PPType.ppTycon SE.empty s tyc;
114 :     print "\n")))
115 : gkuan 2751 fun ppEP ep = print "<entpath>"
116 : gkuan 2963 (* with_pp (fn s => (print "\n";
117 :     PPModules.ppEntPath s ep;
118 :     print "\n")) *)
119 : gkuan 2751 fun ppFunsig fctsig =
120 : gkuan 2963 ED.withInternals
121 :     (fn () => with_pp (fn s => (PM.ppFunsig s (fctsig, SE.empty, 20);
122 :     print "\n")))
123 : gkuan 2751
124 : dbm 3045 end (* local ElabDebug, PPModules *)
125 : gkuan 3027 (*
126 : gkuan 2961 fun eqTycon(T.NoTP tc, T.NoTP tc') = TU.equalTycon(tc,tc')
127 :     | eqTycon _ = raise Fail "Unimplemented"
128 :    
129 :     fun eqTycPath(T.TP_VAR x, T.TP_VAR x') =
130 : gkuan 2751 (case (x, x')
131 :     of (v1 as {tdepth, num, kind},
132 :     v2 as {tdepth=tdepth', num=num', kind=kind'}) =>
133 :     if DI.eq(tdepth,tdepth') andalso
134 : gkuan 2972 num = num' andalso LT.tk_eqv(kind, kind')
135 : gkuan 2751 then true
136 :     else let fun printTPVar({tdepth, num, kind}) =
137 :     (print ("\nTP_VAR("^DI.di_print tdepth^
138 :     ", "^Int.toString num^", ");
139 :     (* PP.with_default_pp
140 :     (fn ppstrm => PPLty.ppTKind 20 ppstrm kind); *)
141 :     print ")")
142 :     in if !debugging
143 :     then
144 :     (print "\n===eqTycPath TP_VAR unequal===\n";
145 :     printTPVar v1; print "\n"; printTPVar v2)
146 :     else ();
147 : dbm 3045 false
148 : gkuan 2751 end)
149 : gkuan 2961 | eqTycPath(T.TP_TYC tyc, T.TP_TYC tyc') =
150 :     (debugmsg "--eqTycPath Tycon"; eqTycon(tyc, tyc'))
151 : gkuan 2751 (* typeutils eqTycon only compares DEFtyc stamps. equalTycon
152 :     resolves DEFtycs. Unfortunately, it appears that the tycs
153 :     this module obtains are reduced forms of the ones
154 :     Instantiate produces.
155 :     *)
156 : gkuan 2961 | eqTycPath(T.TP_FCT(partps, bodytps), T.TP_FCT(partps',bodytps')) =
157 : gkuan 2751 ListPair.allEq eqTycPath (partps, partps') andalso
158 :     ListPair.allEq eqTycPath (bodytps, bodytps')
159 : gkuan 2961 | eqTycPath(T.TP_APP(tp, argtps), T.TP_APP(tp',argtps')) =
160 : gkuan 2751 eqTycPath(tp,tp')
161 :     andalso ListPair.allEq eqTycPath (argtps, argtps')
162 : gkuan 2961 | eqTycPath(T.TP_SEL(tp, i), T.TP_SEL(tp', i')) =
163 : gkuan 2751 eqTycPath(tp,tp') andalso i = i'
164 :     | eqTycPath _ = (debugmsg "--eqTycPath other"; false)
165 :    
166 :     fun checkTycPath(tp, tp') =
167 :     if eqTycPath (tp, tp')
168 :     then true
169 :     else (print "\n===TycPath unequal===\nPrecomputed:\n";
170 :     ppTP tp; print "\nComputed on-the-fly:\n";
171 :     ppTP tp'; print "\n\n";
172 :     false)
173 :    
174 : gkuan 2961 fun checkTycPaths(tps, tps') =
175 : gkuan 2751 if length tps = length tps' andalso ListPair.allEq eqTycPath (tps, tps')
176 :     then true
177 :     else (print "\n===TycPaths unequal===\nOld:";
178 :     List.app ppTP tps; print "\nNew:";
179 :     List.app ppTP tps'; print "\n\n";
180 :     false)
181 : gkuan 3027 *)
182 : gkuan 2751
183 : gkuan 2961 (* Processing *)
184 :     (* entpaths gets all the entspaths from a list of elements
185 :     We are getting the entpaths from the signature (potentially
186 :     a functor parameter signature). The signature is generally
187 :     untrustworthy because it does not account for external constraints
188 :     such as structure definition (specs).
189 : gkuan 2751
190 : gkuan 2961 functor F(X: sig structure M : sig type t end = A end) = ...
191 : gkuan 2751
192 : gkuan 2961 The only thing we are interested in is the order of elements
193 :     given in the signature.
194 : gkuan 2751
195 : gkuan 2961 Whether entpath should actually processed into a tycpath
196 :     (and not a DATATYPE or DEFtyc) will be determined when we search
197 :     the entity environment. *)
198 :     fun entpaths([]) = []
199 :     | entpaths((_,spec)::rest) =
200 :     (case spec
201 :     of M.TYCspec{entVar,info} =>
202 :     [entVar]::entpaths(rest)
203 :     | M.STRspec{entVar, sign=M.SIG{elements,...}, def, ...} =>
204 :     (map (fn ep => entVar::ep) (entpaths elements))@
205 :     entpaths(rest)
206 :     | M.FCTspec{entVar, sign, slot} =>
207 :     [entVar]::entpaths(rest)
208 :     | _ => entpaths(rest))
209 :     (* fsigInElems : element list -> fctSig list
210 :     functor signatures in parameter signature order *)
211 :     fun fsigInElems([]) = []
212 :     | fsigInElems((_, spec)::rest) =
213 :     (case spec
214 : gkuan 2963 of M.FCTspec{entVar, sign, slot} => sign::fsigInElems(rest)
215 :     | M.STRspec{sign=M.SIG{elements=elems,...},...} =>
216 :     fsigInElems(elems) @ (fsigInElems rest)
217 : gkuan 2961 | _ => fsigInElems rest)
218 :    
219 :     (* repEPs : ep list * EntityEnv -> ep list
220 :     return the first EPs for each representative TYCent or FCTent
221 :     only for FORMAL and FLEXTYC though
222 : gkuan 2751
223 : gkuan 2961 Instantiate should have eliminated any seemingly FORMAL tycs
224 :     (that were actually constrained by a where or structure definition
225 : gkuan 2964 spec) by turning them into DEFtycs.
226 :    
227 :     The key here is that we need to avoid including duplicate stamps
228 :     which can be found at the tail of each entpath. *)
229 : gkuan 2961 fun repEPs(eps, env) =
230 : gkuan 2964 let fun loop([], env, renv, stmpseen) = []
231 :     | loop(ep::rest, env, renv, stmpseen) =
232 : gkuan 2961 let fun proc s =
233 : gkuan 2964 (debugmsg ("--repEPs adding stamp "^
234 :     Stamps.toShortString s^" path "^
235 :     EP.entPathToString ep);
236 :     (case rev ep
237 :     of [] => bug "repEPs: empty entpath"
238 :     | s'::_ =>
239 : gkuan 2976 (debugmsg ("--repEPs add stamp "^
240 :     Stamps.toShortString s'^
241 :     " to stmpseen");
242 :     (case (EPMap.find(renv, s),
243 : gkuan 2964 StampSet.member(stmpseen,s'))
244 : gkuan 2976 of ((_, false) | (NONE, _)) =>
245 : gkuan 2964 ep::loop(rest, env,
246 :     EPMap.insert(renv,s,ep),
247 :     StampSet.add(stmpseen,s'))
248 : gkuan 2976 | _ => loop(rest, env, renv, stmpseen)))))
249 : gkuan 2961 in
250 :     case EntityEnv.lookEP(env, ep)
251 :     handle EntityEnv.Unbound =>
252 : gkuan 2751 (print ("\nrepEPs Unbound "^
253 :     EP.entPathToString ep^"\n");
254 :     raise EntityEnv.Unbound)
255 :     of M.FCTent{stamp=s,...} => proc s
256 :     | M.TYCent tyc =>
257 :     (* If the rlzn says the entity contains a
258 :     DATATYPE or a DEFtyc, then we ignore.
259 :     Otherwise, we keep it as representative
260 :     (presumably a FORMAL or FLEXTYC) *)
261 :     (case tyc
262 :     of TP.GENtyc{stamp=s,kind,...} =>
263 :     (case kind
264 : gkuan 2964 of TP.DATATYPE _ =>
265 :     loop(rest, env, renv, stmpseen)
266 : gkuan 2751 | _ => proc s)
267 : gkuan 2964 | TP.DEFtyc _ => loop(rest,env, renv, stmpseen)
268 : gkuan 2751 | _ => bug "repEPs 0")
269 : gkuan 3006 | M.STRent _ => bug "repEPs 1"
270 :     | M.ERRORent => (* in MLRISC/ra/risc-ra.sml this actually happens *)
271 :     loop(rest,env,renv, stmpseen)
272 : gkuan 2751 handle EE.Unbound => bug ("repEPs Unbound"^
273 :     EP.entPathToString ep)
274 :     end
275 : gkuan 2964 in loop(eps, env, EPMap.empty, StampSet.empty)
276 : gkuan 2751 end (* fun repEPs *)
277 :    
278 : gkuan 2961 local
279 : gkuan 2972
280 : gkuan 2961 (* Should use tkc_int and tkc_fun instead of these
281 :     when TP information is eliminated from Elaborator *)
282 :     val buildKind = LT.tkc_int
283 :     in
284 : gkuan 3006 (* kinds : entenv * entenv * fctsig -> kind
285 : gkuan 2961 Computes the functor kind based on that functor's
286 :     functor signature and the current entity env. *)
287 : gkuan 3006 fun kinds(paramEnts, bodyEnts,
288 : gkuan 2961 M.FSIG{paramsig=M.SIG{elements=pelems,...},
289 :     bodysig=M.SIG{elements=belems,...},...}) =
290 :     let val _ = debugmsg ">>kinds\n";
291 :     val _ = debugmsg "--kinds[FCTent]\n"
292 :     val _ = if !debugging
293 :     then (print "--kinds eenv\n";
294 : gkuan 3006 ppEntities paramEnts;
295 : gkuan 2961 print "\n===\n")
296 :     else ()
297 : gkuan 3006 val peps = repEPs(entpaths pelems, paramEnts)
298 : gkuan 3007 val _ = debugmsg "--kinds peps computed"
299 : gkuan 2961 val pfsigs = fsigInElems pelems
300 : gkuan 3007 val _ = debugmsg "--kinds pfsigs computed"
301 : gkuan 3006
302 :     (* [TODO] This can be a problem. belems can refer to
303 :     formal functor body for curried functor,
304 :     but formal body signature has not been
305 :     instantiated with the actual argument realization. *)
306 :     val beps = repEPs(entpaths belems, bodyEnts)
307 : gkuan 3007 val _ = debugmsg "--kinds beps computed\n"
308 : gkuan 3006 val bfsigs = fsigInElems belems
309 : gkuan 3007 val _ = debugmsg "--kinds bfsigs computed\n"
310 : gkuan 2961 (* What is the correct eenv to look up belem entpaths?
311 :     *)
312 : gkuan 3006 fun loop ([], _, eenv) = []
313 : gkuan 3007 | loop (ep::eps, fsigs, eenv) =
314 : gkuan 2961 (case EE.lookEP(eenv, ep)
315 :     handle EE.Unbound =>
316 :     bug ("kinds Unbound "^
317 :     EP.entPathToString ep)
318 : gkuan 2963 of M.TYCent(TP.GENtyc{kind=TP.DATATYPE _, ...}) =>
319 : gkuan 3007 loop(eps, fsigs, eenv)
320 : gkuan 2963 | M.TYCent(TP.GENtyc{kind, arity, ...}) =>
321 : gkuan 2961 (* Use this when PK eliminated from front-end:
322 :     (LT.tkc_int arity)::loop(eps, pfsigs) *)
323 : gkuan 3007 (buildKind arity)::loop(eps, fsigs, eenv)
324 : dbm 3287 | M.FCTent{paramRlzn, bodyRlzn (* DELETE *),
325 : gkuan 2961 closure=M.CLOSURE{env, ...},
326 :     ...} =>
327 : dbm 3287 (* This should be using closure and paramRlzn --
328 :     * bodyRlzn is being deleted *)
329 : gkuan 3007 (case fsigs
330 : gkuan 2961 of [] => bug "kinds.1"
331 : gkuan 3007 | fsig::rest =>
332 :     kinds(#entities paramRlzn,
333 :     #entities bodyRlzn, fsig)::
334 : gkuan 3006 loop(eps, rest, eenv))
335 : gkuan 2961 | _ => bug "kinds.0")
336 : gkuan 3007
337 :     val paramtk = loop(peps,pfsigs,paramEnts)
338 :     val _ = debugmsg "--kinds paramtk computed"
339 :     val bodytk = loop(beps,bfsigs, bodyEnts)
340 :     val _ = debugmsg "--kinds bodytk computed"
341 : gkuan 3019 in (* Use this when PK eliminated from front-end: *)
342 : gkuan 3007 LT.tkc_fun(paramtk, LT.tkc_seq bodytk)
343 : gkuan 2961 end
344 : gkuan 3019 | kinds _ = bug "kinds.2" (* fun kinds *)
345 : gkuan 2976
346 : gkuan 3019 fun formalBody(ftmap0, bodyEnts, argTps, msig as M.SIG{elements, ...},
347 :     paramEnts, fsig, d, i) =
348 :     let val _ = debugmsg "--in formalBody kinds"
349 : gkuan 3006
350 : gkuan 3019 val M.FSIG{paramsig=M.SIG{elements=pelems,...},
351 :     bodysig=M.SIG{elements=belems,...},...} = fsig
352 :     val peps = repEPs(entpaths pelems, paramEnts)
353 :     val _ = debugmsg "--formalBody peps computed"
354 :     val pfsigs = fsigInElems pelems
355 :     val _ = debugmsg "--formalBody pfsigs computed"
356 :    
357 :     fun loopkind ([], _, eenv) = []
358 :     | loopkind (ep::eps, fsigs, eenv) =
359 :     (case EE.lookEP(eenv, ep)
360 : gkuan 3006 handle EE.Unbound =>
361 : gkuan 3019 bug ("kinds Unbound "^
362 : gkuan 3006 EP.entPathToString ep)
363 :     of M.TYCent(TP.GENtyc{kind=TP.DATATYPE _, ...}) =>
364 : gkuan 3019 loopkind(eps, fsigs, eenv)
365 :     | M.TYCent(TP.GENtyc{kind, arity, ...}) =>
366 :     (* Use this when PK eliminated from front-end:
367 :     (LT.tkc_int arity)::loop(eps, pfsigs) *)
368 :     (buildKind arity)::loopkind(eps, fsigs, eenv)
369 : dbm 3287 | M.FCTent{paramRlzn, bodyRlzn (* DELETE *),
370 : gkuan 3019 closure=M.CLOSURE{env, ...},
371 :     ...} =>
372 : dbm 3287 (* this should be using closure and paramRlzn *)
373 : gkuan 3019 (case fsigs
374 :     of [] => bug "kinds.1"
375 :     | fsig::rest =>
376 :     kinds(#entities paramRlzn,
377 :     #entities bodyRlzn, fsig)::
378 :     loopkind(eps, rest, eenv))
379 :     | _ => bug "kinds.0")
380 :    
381 :     val paramtk = loopkind(peps,pfsigs,paramEnts)
382 :     val _ = debugmsg "--formalBody paramtk computed"
383 :    
384 :     (* [TODO] This can be a problem. belems can refer to
385 :     formal functor body for curried functor,
386 :     but formal body signature has not been
387 :     instantiated with the actual argument realization. *)
388 :     val beps = repEPs(entpaths belems, bodyEnts)
389 :     val _ = debugmsg "--formalBody beps computed\n"
390 :     val bfsigs = fsigInElems belems
391 :     val _ = debugmsg "--formalBody bfsigs computed\n"
392 :     (* What is the correct eenv to look up belem entpaths?
393 :     *)
394 :    
395 :     val bodytk = loopkind(beps,bfsigs, bodyEnts)
396 :     val _ = debugmsg "--formalBody bodytk computed"
397 :    
398 :     val kind = LT.tkc_fun(paramtk, LT.tkc_seq bodytk)
399 :     (* kinds(paramEnts, bodyEnts, fsig) *)
400 :     val fctvar = T.TP_VAR{tdepth=d, num=i, kind=kind}
401 :     val _ = (debugmsg ("--formalBody elements ");
402 :     if !debugging then ppSig msig else ())
403 :    
404 :     val eps = entpaths(elements)
405 :     val _ = debugmsg ("--formalBody eps "^Int.toString (length eps))
406 : gkuan 3027 fun loop(ftmap, eenv, [], i, tps) = (ftmap, rev tps)
407 :     | loop(ftmap, eenv, ep::rest, i, tps) =
408 :     (case EE.lookEP(eenv, ep)
409 : gkuan 3019 of M.TYCent(TP.GENtyc{kind=TP.DATATYPE _, stamp, ...}) =>
410 :     let val _ = debugmsg ("--formalBody DATATYPE "^
411 :     Stamps.toShortString stamp)
412 : gkuan 3027 in loop(ftmap, eenv, rest, i, tps)
413 : gkuan 3019 end
414 : gkuan 3006 | M.TYCent(TP.GENtyc{stamp, kind, arity, ...}) =>
415 : gkuan 3019 let val tp = T.TP_SEL(T.TP_APP(fctvar, argTps), i)
416 : gkuan 3006 val _ = debugmsg ("--formalBody "^
417 :     Stamps.toShortString stamp^
418 :     " is index "^
419 :     Int.toString i)
420 :     in case FTM.find(ftmap, stamp)
421 : gkuan 3027 of SOME _ => loop(ftmap, eenv, rest, i, tps)
422 : gkuan 3006 | NONE => loop(insertMap(ftmap, stamp, tp),
423 : gkuan 3027 eenv,
424 : gkuan 3019 rest, i+1, tp::tps)
425 : gkuan 3006 end
426 : gkuan 3019 | M.TYCent _ =>
427 :     (debugmsg "--formalBody other TYCent GEN";
428 : gkuan 3027 loop(ftmap, eenv, rest, i, tps))
429 : gkuan 3019 | M.FCTent _ =>
430 :     (debugmsg "--formalBody FCTent";
431 : gkuan 3027 loop(ftmap, eenv, rest, i, tps))
432 :     (* | M.STRent{entities,...} =>
433 : gkuan 3019 (debugmsg "--formalBody STRent";
434 : gkuan 3027 loop(ftmap, eenv,
435 : gkuan 3019 (#2 (ListPair.unzip (EE.toList entities)))@rest,
436 : gkuan 3027 i, tps)) *)
437 : gkuan 3019 | _ => (debugmsg "--formalBody other ent";
438 : gkuan 3027 loop(ftmap, eenv, rest, i, tps)))
439 :     (* val bodyentsflat = #2 (ListPair.unzip (EE.toList bodyEnts)) *)
440 :     val (ftmap1, tps) = loop(ftmap0, bodyEnts, beps, 0, [])
441 :     (* val _ = debugmsg ("--formalBody bodyents "^
442 :     Int.toString(length bodyentsflat))*)
443 :     (* val (ftmap1, tps) = loop(ftmap0, bodyentsflat, 0, []) *)
444 : gkuan 3019 in (ftmap1, tps)
445 : gkuan 3006 end
446 :     | formalBody _ = bug "Unexpected signature in formalBody"
447 :    
448 : gkuan 2976 (* There are two kinds of tycpath computations, one for
449 :     * functor parameters and the other for functor parameter
450 :     * references in the body of a functor. In either case,
451 :     * we want to use the deBruijn index depth at the
452 :     * site of definition and not the incidental depth at the
453 :     * site of occurrence.
454 :     *)
455 : gkuan 2972 (* This is the important computation for generating TC_VAR
456 :     variable references to functor parameters.
457 :    
458 : gkuan 3006 FTM.map * M.strEntity * M.strEntity * M.sigrec * DI.depth
459 :     -> FTM.map * tycpath list
460 : gkuan 2972 *)
461 : gkuan 3006 (* The goal here, simply put, is to get the primary components
462 :     in rlzn where a component is primary if it is a representative
463 :     picked by instantiate in freerlzn. *)
464 :     fun primaryCompInStruct(ftmap0, freerlzn : M.strEntity,
465 : gkuan 3027 rlzn: M.strEntity, M.SIG (sign : M.sigrec), d) =
466 : gkuan 3006 let
467 :     val fsigs = fsigInElems(#elements sign)
468 : gkuan 3031 val _ = debugmsg ("--pri num of fsigs "^
469 :     Int.toString (length fsigs)
470 :     ^" depth "^DI.dp_print d)
471 : gkuan 3006 val entenv = #entities rlzn
472 :     val eps = repEPs(entpaths(#elements sign), #entities freerlzn)
473 : gkuan 3031 (* val eps' =
474 : gkuan 3019 let
475 : gkuan 3027 fun flatten((stamp, M.STRent{entities,...})::rest) =
476 : gkuan 3019 (map (fn ep => stamp::ep)
477 : gkuan 3027 (flatten(EE.toList entities))) @ flatten(rest)
478 :     | flatten((stamp, M.TYCent(TP.GENtyc _))::rest) =
479 : gkuan 3019 [stamp]::flatten(rest)
480 : gkuan 3027 | flatten((stamp, (M.FCTent _))::rest) =
481 : gkuan 3019 [stamp]::flatten(rest)
482 :     | flatten(_::rest) =
483 :     flatten(rest)
484 :     | flatten [] = []
485 : gkuan 3027 in flatten (EE.toList (#entities freerlzn))
486 : gkuan 3019 end
487 :     val _ = (debugmsg "---pri selected eps";
488 :     if !debugging
489 :     then (app (fn x => print((EP.entPathToString x)^";"))
490 :     eps; print "\n")
491 :     else ();
492 :     debugmsg "\n---pri selected eps'";
493 :     if !debugging
494 :     then (app (fn x => print ((EP.entPathToString x)^";"))
495 :     eps'; print "\n")
496 : gkuan 3031 else ()) *)
497 : gkuan 3027 (* val eps = eps' *)
498 : gkuan 3019
499 : gkuan 3006 val _ = debugmsg ("--primaryCompInStruct eps "^
500 :     Int.toString (length eps)^
501 :     " d="^DI.dp_print d)
502 : gkuan 2979 fun loop(ftmap, tps, entenv, [], i, _) = (ftmap, rev tps)
503 : gkuan 2976 | loop(ftmap, tps, entenv, ep::rest, i, fs) =
504 : gkuan 3006 (debugmsg ("-primaryCompInStruct loop "^Int.toString i);
505 : gkuan 2972 let val ev : Stamps.stamp = hd (rev ep)
506 :     in
507 :     case EE.lookEP(entenv, ep)
508 :     handle EntityEnv.Unbound =>
509 : gkuan 3019 (print "\npri for Unbound\n";
510 : gkuan 2972 raise EntityEnv.Unbound)
511 :     of M.TYCent(tyc as TP.GENtyc{kind=TP.DATATYPE _, stamp,...}) =>
512 : gkuan 2976 let val tp = T.TP_TYC(T.NoTP tyc)
513 : gkuan 3029 (* val _ = debugmsg "TYCent DATATYPE" *)
514 : gkuan 2976 in (loop(insertMap(ftmap, stamp, tp),
515 :     tp::tps, entenv, rest, i+1, fs))
516 :     end
517 : gkuan 2972 (* Datatypes should be represented directly in the
518 :     tycpath *)
519 :     | M.TYCent(TP.GENtyc{kind=TP.ABSTRACT(tyc),stamp=s1,...}) =>
520 : gkuan 2976 let val (tp,s) =
521 : gkuan 2972 (case tyc
522 :     of TP.GENtyc{kind=TP.DATATYPE _,stamp,...} =>
523 :     (T.TP_TYC(T.NoTP tyc), stamp)
524 :     | TP.GENtyc{kind=TP.FORMAL, arity, stamp, ...} =>
525 : gkuan 3035 (case FTM.find(ftmap, stamp)
526 : gkuan 2978 of SOME tp' => (tp', stamp)
527 : gkuan 3006 | NONE =>
528 :     (debugmsg ("--eps VAR depth "^DI.dp_print d);
529 :     (T.TP_VAR{tdepth=d,num=i,
530 :     kind=buildKind arity}, stamp)))
531 : gkuan 2972 | _ =>
532 : gkuan 3019 (debugmsg "--pri[GEN] nonformal/data abstract";
533 :     (T.TP_TYC(T.NoTP tyc), s1)))
534 : gkuan 2972 in
535 : gkuan 2976 loop(insertMap(ftmap, s, tp),
536 :     tp::tps, entenv,rest,i+1,fs)
537 : gkuan 2972 end
538 :    
539 :     | M.TYCent(TP.GENtyc{kind, arity, stamp, ...}) =>
540 : gkuan 3006 let val _ = debugmsg "--primaryCompInStruct[TYCent GENtyc]"
541 : gkuan 2976 val kind = buildKind arity
542 : gkuan 2978 (* Check if stamp is previously defined.
543 :     * If so, then this must be a variable occurrence
544 :     * and not a functor parameter binding
545 :     * so use the depth at the definition site
546 :     * (i.e., in the ftmap0 tycpath) instead of the
547 :     * current occurrence site depth. *)
548 :     val tp' =
549 : gkuan 3035 (case FTM.find(ftmap, stamp)
550 : gkuan 3006 of SOME tp' =>
551 :     (debugmsg ("--primaryCompInStruct[TYCent GENtyc] found stmp "^Stamps.toShortString stamp);
552 :     tp')
553 : gkuan 2978 | NONE =>
554 : gkuan 3006 (debugmsg ("--primaryCompInStruct[TYCent GENtyc] generating "^Stamps.toShortString stamp^" depth="^DI.dp_print d);
555 :     T.TP_VAR {tdepth=d,num=i, kind=kind}))
556 : gkuan 2972 (* val _ = checkTycPath(tp, tp') *)
557 :     in
558 :     loop(insertMap(ftmap, stamp, tp'),
559 : gkuan 2976 tp'::tps, entenv, rest, i+1, fs)
560 : gkuan 2972 end
561 :     | M.TYCent tyc =>
562 : gkuan 3006 (debugmsg "--primaryCompInStruct[TYCent]";
563 : gkuan 2976 (let val tp = T.TP_TYC(T.NoTP tyc)
564 :     in loop(insertMap(ftmap, ev, tp),
565 :     tp::tps, entenv, rest, i+1, fs)
566 :     end))
567 : dbm 3287 | M.FCTent {stamp, paramRlzn, bodyRlzn (* DELETE *),
568 : gkuan 3006 closure=M.CLOSURE{env=closenv,...},...} =>
569 :     (debugmsg "--primaryCompInStruct[FCTent SOME]";
570 : dbm 3287 (* this should be using closure and paramRlzn *)
571 : gkuan 3027 ( case fs
572 : gkuan 3006 of [] => bug "primaryCompInStruct.1"
573 : gkuan 3007 | (fsig as M.FSIG{bodysig=bsig as M.SIG bsr,
574 : gkuan 3027 paramsig=paramsig as M.SIG psr,
575 :     ...})::srest =>
576 : gkuan 3006 let
577 : gkuan 3019 (* If FCTent is a result from a partially
578 :     applied functor, then the given bsr
579 :     is no longer reliable, because it
580 :     may only give the signature of the
581 :     result after curried application when
582 :     we need the signature for the
583 :     original functor before partial
584 :     application *)
585 : gkuan 3006 val paramEnts = #entities paramRlzn
586 :     val bodyEnts = #entities bodyRlzn
587 :     val _ =
588 : gkuan 2972 if !debugging then
589 :     (print "\n===FCTent paramEnts===\n";
590 :     ppEntities paramEnts;
591 : gkuan 3006 print "\n===FCTent bodyEnts===\n";
592 :     ppEntities bodyEnts;
593 : gkuan 3019 (* print "\n===FCTent eenv===\n";
594 :     ppEntities entenv; *)
595 : gkuan 3006 print "\n===FCTent closenv===\n";
596 :     ppEntities closenv;
597 : gkuan 3027 print "\n--kinds[FCTent] Funsig\n"
598 :     (* ; ppFunsig fsig;
599 : gkuan 3019 (* print "\n===FCTent sign===\n";
600 : gkuan 3027 ppSig (M.SIG sign); *)print "\n"*)
601 : gkuan 3019 )
602 : gkuan 2972 else ()
603 : gkuan 3006
604 :     val argRepEPs =
605 :     repEPs(entpaths(#elements psr),
606 :     #entities paramRlzn)
607 : gkuan 3027 (* val psr = {stamp = Stamps.special "bogusSig",
608 :     name=NONE, closed=true, fctflag=false,
609 :     elements=[],
610 :     properties = PropList.newHolder (),
611 :     (* boundeps=ref NONE, lambdaty=ref NONE *)
612 :     typsharing=[], strsharing=[],
613 :     stub = NONE} *)
614 : gkuan 3006 val (ftmap1, argtps) =
615 :     primaryCompInStruct(ftmap,
616 :     paramRlzn,
617 :     paramRlzn,
618 : gkuan 3027 paramsig,
619 : gkuan 3006 DI.next d)
620 :    
621 : gkuan 3019
622 : gkuan 3006 (* [TODO] Replace free instantiation
623 :     components with actual argument
624 :     realization components. *)
625 : gkuan 3019 (*val knds = kinds(paramEnts,
626 : gkuan 3006 #entities bodyRlzn,
627 : gkuan 3019 fsig)
628 :     val _ = debugmsg "<<kinds done\n" *)
629 : gkuan 3006
630 :     (* Can't do normal flextyc tycpath
631 :     construction here because actual
632 :     argument is not yet available.
633 :     Must traverse bodyRlzn in signature
634 :     order and add TP_SEL(TC_APP(tv,args),i)
635 :     for each FORMAL GENtyc *)
636 :     val _ = debugmsg ("pri[FCT]TP_VAR depth "^
637 :     DI.dp_print d)
638 : gkuan 3027 (* val fsig =
639 :     M.FSIG{kind=NONE,
640 :     paramsig=M.SIG psr,
641 :     paramvar=Stamps.special "bogusP",
642 :     paramsym=NONE,
643 :     bodysig=M.SIG psr}
644 :     val bsig = M.SIG psr *)
645 : dbm 3287 (* BOGUS! bodyRlzn is being DELETED *)
646 : gkuan 3006 val (ftmap2,bodytps) =
647 :     formalBody(ftmap1, #entities bodyRlzn,
648 :     argtps, bsig,
649 : gkuan 3019 (* T.TP_VAR{tdepth=d,
650 : gkuan 3006 num=i,
651 :     kind=knds
652 : gkuan 3019 } *)
653 :     paramEnts,
654 :     fsig, d, i)
655 : gkuan 3006 val tp' = T.TP_FCT(argtps, bodytps)
656 : gkuan 2972 (* val _ = checkTycPath(tp, tp') *)
657 :     in
658 : gkuan 3006 loop(ftmap2,
659 :     tp'::tps, entenv, rest, i+1, srest)
660 :     end
661 : gkuan 3027 | _ => bug "unexpected errorFSIG"))
662 : gkuan 3006 | _ => bug "primaryCompInStruct 0"
663 : gkuan 2972 end (* loop *) )
664 : gkuan 3006 handle EE.Unbound => bug "primaryCompInStruct Unbound"
665 : gkuan 3035 in loop(ftmap0, [], entenv, eps, 0, fsigs)
666 : gkuan 3006 end (* fun primaryCompInStruct *)
667 : gkuan 3027 | primaryCompInStruct _ = bug "Unexpected error signature"
668 : gkuan 2972
669 : gkuan 3006 (* Get the primary components in a realization R0 but replacing any
670 :     occurrences of entities in a realization R1 with the
671 :     corresponding entities in a realization R2. *)
672 :     (* fun primariesWithParamRepl(ftmap0, bodyRlzn : M.strEntity,
673 :     freeRlzn : M.strEntity,
674 :     argRlzn : M.strEntity,
675 :     sign : M.sigrec, d) =
676 :     let *)
677 :    
678 :    
679 : gkuan 3027 fun getTk(M.FSIG{paramsig=paramsig as M.SIG ps, ...}, dummyRlzn,
680 :     argRlzn,
681 : gkuan 2989 d) =
682 : gkuan 2972 let
683 :     val _ = debugmsg ">>getTk"
684 : gkuan 2978 val (ftmap, argtycs') =
685 : gkuan 3027 primaryCompInStruct(FTM.empty, dummyRlzn, argRlzn,
686 :     paramsig, d)
687 : gkuan 2972 val _ = debugmsg "<<getTk"
688 :     in (argtycs', ftmap)
689 :     end (* getTk *)
690 :     | getTk _ = bug "getTk 0"
691 :    
692 :     end (* local *)
693 : gkuan 2751 end (* local *)
694 :    
695 :     end (* structure RepTycProps *)

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