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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 418 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/Semant/elaborate/include.sml

1 : monnier 249 (* Copyright 1996 by AT&T Bell Laboratories *)
2 :     (* include.sml *)
3 :    
4 :     signature INCLUDE =
5 :     sig
6 :    
7 :     val elabInclude:
8 :     Modules.Signature * StaticEnv.staticEnv * Modules.elements
9 :     * Symbol.symbol list * int * SourceMap.region * ElabUtil.compInfo
10 :     -> StaticEnv.staticEnv * Modules.elements * Symbol.symbol list
11 :     * Modules.sharespec list (* type sharing *)
12 :     * Modules.sharespec list (* structure sharing *)
13 :     * int (* slots *) * bool (* fctflag *)
14 :    
15 :     val debugging : bool ref
16 :    
17 :     end (* signature INCLUDE *)
18 :    
19 :    
20 :     structure Include: INCLUDE =
21 :     struct
22 :    
23 :     local structure EM = ErrorMsg
24 :     structure IP = InvPath
25 :     structure A = Access
26 :     structure TU = TypesUtil
27 :     structure M = Modules
28 :     structure MU = ModuleUtil
29 :     structure B = Bindings
30 :     structure EU = ElabUtil
31 :     structure EP = EntPath
32 :     structure S = Symbol
33 :     structure SE = StaticEnv
34 :     open Modules Types VarCon
35 :     in
36 :    
37 :     fun bug msg = EM.impossible ("Include: " ^ msg)
38 :     val debugging = ref false
39 :     val say = Control.Print.say
40 :     fun debugmsg (msg: string) = if (!debugging) then (say msg; say "\n") else ()
41 :    
42 :     fun addElement (elem,elements) = elem::elements
43 :    
44 :     fun substElem(new as (name,spec),(old as (name',_))::rest) =
45 :     if S.eq(name,name') then new::rest
46 :     else old::substElem(new,rest)
47 :     | substElem(_,nil) = bug "substElem"
48 :    
49 :     datatype tyc_compat = KEEP_OLD | REPLACE | INCOMPATIBLE
50 :    
51 :     fun compatible(newtyc,oldtyc) =
52 :     if TU.tyconArity newtyc <> TU.tyconArity oldtyc then INCOMPATIBLE
53 :     else (case (newtyc,oldtyc)
54 :     of (GENtyc{kind=FORMAL,...}, GENtyc{kind=FORMAL,...}) => KEEP_OLD
55 :     | (_, GENtyc{kind=FORMAL,...}) => REPLACE
56 :     | _ => INCOMPATIBLE)
57 :    
58 :     fun specified(symbol,elements) =
59 :     List.exists (fn (n,_) => S.eq(symbol,n)) elements
60 :    
61 :     (*** elaborating IncludeSpec in signatures ***)
62 :     (* BUG! currently doesn't deal with general sigexp case (e.g. sigid where ...) *)
63 :     fun elabInclude(SIG{elements=newElements, symbols=newSymbols,
64 :     boundeps, lambdaty, typsharing, strsharing,
65 :     name, closed, fctflag, stamp},
66 :     oldEnv, oldElements, oldSymbols, oldSlots,
67 :     region, compInfo as {mkStamp,error,...} : EU.compInfo) =
68 :     let
69 :    
70 :     val err = error region
71 :    
72 :     (*
73 :     * When including a list of specs into the current signature; some tycon's
74 :     * entVars might be adjusted, this would force all the types in the specs
75 :     * being adjusted also. This adjustment is implemented using this tycmap
76 :     * table.
77 :     *)
78 :     exception TycMap
79 :    
80 :     val tycMap : (EP.entVar * tycon) list ref = ref []
81 :    
82 :     fun addMap z = (tycMap := (z::(!tycMap)))
83 :     fun getMap z = (!tycMap)
84 :    
85 :     fun lookTycMap(ev,[]) = raise TycMap
86 :     | lookTycMap(ev,(ev',tyc)::rest) =
87 :     if EP.eqEntVar(ev,ev') then tyc else lookTycMap(ev,rest)
88 :    
89 :     (*
90 :     * adjustType does not get inside each DEFtyc's body because we
91 :     * assume that the body has been adjusted already.
92 :     *)
93 :     fun adjustType(ty,[]) = ty
94 :     | adjustType(ty,tycmap) =
95 :     let fun newtyc (tyc as PATHtyc{entPath=[ev],...}) =
96 :     (lookTycMap(ev,tycmap) handle TycMap => tyc)
97 :     | newtyc tyc = tyc
98 :     in TU.mapTypeFull newtyc ty
99 :     end
100 :    
101 :     (*
102 :     * The adjustTyc function is only called at each type specification site.
103 :     *
104 :     * The stamp for DEFtyc is changed; fortunately, this is OK because
105 :     * all other references to this DEFtyc is via PATHtyc.
106 :     *)
107 :     fun adjustTyc(tycon,[]) = tycon
108 :     | adjustTyc(tycon,tycmap) =
109 :     (case tycon
110 :     of DEFtyc{stamp=s, tyfun=TYFUN{arity,body}, strict, path} =>
111 :     DEFtyc{tyfun=TYFUN{arity=arity,body=adjustType(body,tycmap)},
112 :     stamp=mkStamp(), strict=strict, path=path}
113 :     | GENtyc _ => tycon
114 :     | PATHtyc{entPath=[ev],...} =>
115 :     (lookTycMap(ev,tycmap) handle TycMap => tycon)
116 :     | _ => bug "adjustTyc")
117 :    
118 :     (*
119 :     * Changing the stamp of an ANONYMOUS signature may cause unnecessary
120 :     * signature maching operations.
121 :     *)
122 :     and adjustSig(sign,[]) = sign
123 :     | adjustSig(sign as SIG{name, closed, fctflag,
124 :     stamp, elements, symbols, boundeps,
125 :     lambdaty, typsharing, strsharing}, tycmap) =
126 :     (if closed then sign
127 :     else SIG{name=name, closed=false, fctflag=fctflag,
128 :     stamp= mkStamp(), boundeps=ref NONE,
129 :     lambdaty=ref NONE, elements=adjustElems(elements,tycmap),
130 :     symbols=symbols, typsharing=typsharing,
131 :     strsharing=strsharing})
132 :    
133 :     and adjustFsig(sign as FSIG{kind,paramsig,bodysig,paramvar,paramsym},tycmap) =
134 :     let val paramsig' = adjustSig(paramsig,tycmap)
135 :     val bodysig' = adjustSig(bodysig,tycmap)
136 :     in FSIG{kind=kind,paramsig=paramsig',bodysig=bodysig',
137 :     paramvar=paramvar,paramsym=paramsym}
138 :     end
139 :    
140 :     and adjustElems(elements,tycmap) = map (adjustElem tycmap) elements
141 :    
142 :     and adjustElem tycmap (sym,spec) =
143 :     let val nspec =
144 :     case spec
145 :     of TYCspec{spec=tycon, entVar=ev, repl=r, scope=s} =>
146 :     TYCspec{spec=adjustTyc(tycon,tycmap),entVar=ev, repl=r, scope=s}
147 :     | STRspec{sign, entVar=ev, def=d, slot=s} =>
148 :     STRspec{sign=adjustSig(sign,tycmap),entVar=ev,def=d,slot=s}
149 :     (* BUG: def component may need adjustment? *)
150 :     | FCTspec{sign, entVar=ev, slot=s} =>
151 :     FCTspec{sign=adjustFsig(sign,tycmap),entVar=ev,slot=s}
152 :     | VALspec{spec=typ, slot=s} =>
153 :     VALspec{spec=adjustType(typ,tycmap), slot=s}
154 :     | CONspec{spec=DATACON{rep,name,typ,const,sign,lazyp},slot=s} =>
155 :     CONspec{spec=DATACON{rep=rep,name=name,const=const,lazyp=lazyp,
156 :     typ=adjustType(typ,tycmap),sign=sign},
157 :     slot=s}
158 :     in (sym, nspec)
159 :     end
160 :    
161 :     fun addElem((name,nspec: M.spec), env, elems, syms, slot) =
162 :     case nspec
163 :     of TYCspec{spec=tc, entVar=ev, repl=r, scope=s} =>
164 :     (let val TYCspec{spec=otc,entVar=oev,repl=or,scope=os} =
165 :     MU.getSpec(elems,name)
166 :     in case compatible(tc,otc)
167 :     of KEEP_OLD =>
168 :     let val ntc = PATHtyc{arity=TU.tyconArity otc,
169 :     entPath=[oev], path=IP.IPATH[name]}
170 :     val _ = addMap(ev,ntc)
171 :     in (env, elems, syms, slot)
172 :     end
173 :     | REPLACE =>
174 :     let val ntc = adjustTyc(tc, getMap())
175 :     val nspec' = TYCspec{spec=ntc,entVar=oev,repl=or,scope=s} (*?*)
176 :     val elems' = substElem((name,nspec'),elems)
177 :    
178 :     val ntc = PATHtyc{arity=TU.tyconArity ntc,
179 :     entPath=[oev], path=IP.IPATH[name]}
180 :     val _ = addMap(ev,ntc)
181 :    
182 :     in (env, elems', syms, slot)
183 :     end
184 :     | INCOMPATIBLE =>
185 :     (err EM.COMPLAIN ("duplicate specifications for type "
186 :     ^ S.name name ^ " caused by include")
187 :     EM.nullErrorBody;
188 :     (env, elems, syms, slot))
189 :     end handle MU.Unbound _ => (* new tycon *)
190 :     (let val ntyc = PATHtyc{arity=TU.tyconArity tc, entPath=[ev],
191 :     path=IP.IPATH[name]}
192 :     val env' = SE.bind(name, B.TYCbind ntyc, env)
193 :    
194 :     val spec' = TYCspec{spec=adjustTyc(tc, getMap()),
195 :     entVar=ev,repl=r,scope=s}
196 :     val elems' = addElement((name,spec'), elems)
197 :     val syms' = name :: syms
198 :     in (env', elems', syms', slot)
199 :     end))
200 :    
201 :     | STRspec{sign, entVar, def, ...} =>
202 :     (if specified(name,elems)
203 :     then (err EM.COMPLAIN ("duplicate specifications for structure "
204 :     ^ S.name name ^ " caused by include")
205 :     EM.nullErrorBody;
206 :     (env, elems, syms, slot))
207 :     else (* new specification - ok *)
208 :     let val newsign = adjustSig(sign,getMap())
209 :     val newspec = STRspec{sign=newsign,slot=slot,entVar=entVar,def=def}
210 :     val nstr = STRSIG{sign=newsign, entPath=[entVar]}
211 :     val env' = SE.bind(name, B.STRbind nstr, env)
212 :     val elems' = addElement((name,newspec), elems)
213 :     val syms' = name :: syms
214 :     in (env', elems', syms', slot+1)
215 :     end)
216 :    
217 :     | FCTspec{sign,entVar, ...} =>
218 :     (if specified(name,elems)
219 :     then (err EM.COMPLAIN ("duplicate specifications for functor "
220 :     ^ S.name name ^ " caused by include")
221 :     EM.nullErrorBody;
222 :     (env, elems, syms, slot))
223 :     else (* new specification - ok *)
224 :     let val newsign = adjustFsig(sign,getMap())
225 :     val newspec = FCTspec{sign=newsign,slot=slot,entVar=entVar}
226 :     val elems' = addElement((name,newspec), elems)
227 :     val syms' = name :: syms
228 :     in (env, elems', syms', slot+1)
229 :     end)
230 :    
231 :     | VALspec{spec=typ, ...} =>
232 :     (if specified(name,elems)
233 :     then (err EM.COMPLAIN ("duplicate value specifications for "
234 :     ^ S.name name ^ " caused by include")
235 :     EM.nullErrorBody;
236 :     (env, elems, syms, slot))
237 :     else (* new specification - ok *)
238 :     let val newtyp = adjustType(typ,getMap())
239 :     val newspec = VALspec{spec=newtyp,slot=slot}
240 :     val elems' = addElement((name,newspec), elems)
241 :     val syms' = name :: syms
242 :     in (env, elems', syms', slot+1)
243 :     end)
244 :    
245 :     | CONspec{spec=DATACON{rep,name,typ,const,sign,lazyp},...} =>
246 :     (if specified(name,elems)
247 :     then (err EM.COMPLAIN ("duplicate constructor specifications for "
248 :     ^ S.name name ^ " caused by include")
249 :     EM.nullErrorBody;
250 :     (env, elems, syms, slot))
251 :     else (* new specification - ok *)
252 :     let val newtyp = adjustType(typ,getMap())
253 :     val ndcon = DATACON {rep=rep, name=name, typ=newtyp,
254 :     const=const, sign=sign, lazyp=lazyp}
255 :     val (slotOp, slot') =
256 :     case rep
257 :     of A.EXN _ => (SOME slot, slot+1)
258 :     | _ => (NONE, slot)
259 :    
260 :     val newspec = CONspec {spec=ndcon,slot=slotOp}
261 :     val elems' = addElement((name,newspec), elems)
262 :     val syms' = name :: syms
263 :     in (env, elems', syms', slot')
264 :     end)
265 :    
266 :     fun addElems(nelems, [], env, elems, syms, slot) = (env, elems, syms, slot)
267 :     | addElems(e::nelems, s::rest, env, elems, syms, slot) =
268 :     let (*** should use s to search for e in nelems if
269 :     elements is represented as a real env. ***)
270 :     val (env', elems', syms', slot') =
271 :     addElem(e, env, elems, syms, slot)
272 :     in addElems(nelems, rest, env', elems', syms', slot')
273 :     end
274 :     | addElems _ = bug "addElems"
275 :    
276 :     val (env', elems', syms', slots') =
277 :     addElems(newElements, newSymbols,
278 :     oldEnv, oldElements, oldSymbols, oldSlots)
279 :    
280 :     in (env',elems', syms', typsharing, strsharing, slots', fctflag)
281 :    
282 :     end (* end of case #1 for function elabInclude *)
283 :    
284 :     | elabInclude(ERRORsig, env, elems, syms, slots, region, compInfo) =
285 :     (env, elems, syms, [], [], slots, false)
286 :    
287 :     end (* local *)
288 :     end (* structure Include *)
289 :    

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