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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* COPYRIGHT (c) 1998 Bell Laboratories *)
2 :     (* elabtype.sml *)
3 :    
4 :     structure ElabType : ELABTYPE =
5 :     struct
6 :    
7 :     local structure EM = ErrorMsg
8 :     structure S = Symbol
9 :     structure SP = SymPath
10 :     structure IP = InvPath
11 :     structure SE = StaticEnv
12 :     structure L = Lookup
13 :     structure B = Bindings
14 :     structure T = Types
15 :     structure TU = TypesUtil
16 :     structure BT = BasicTypes
17 :     structure EU = ElabUtil
18 :     structure TS = TyvarSet
19 :     open Symbol Absyn Ast PrintUtil Types TypesUtil VarCon
20 :     in
21 :    
22 :     val debugging = Control.CG.etdebugging (* ref false *)
23 :     val say = Control.Print.say
24 :     fun debugmsg (msg: string) =
25 :     if !debugging then (say msg; say "\n") else ()
26 :    
27 :     fun bug msg = ErrorMsg.impossible("ElabType: "^msg)
28 :    
29 :     (**** TYPES ****)
30 :    
31 :     val --> = BT.-->
32 :     infix -->
33 :    
34 :     fun elabTyv(tyv:Ast.tyvar,error,region:region) =
35 :     case tyv
36 :     of Tyv vt => mkTyvar(mkUBOUND(vt))
37 :     | MarkTyv(tyv,region) => elabTyv(tyv,error,region)
38 :    
39 :     fun elabTyvList (tyvars,error,region) =
40 :     let val tvs = map (fn tyv => elabTyv(tyv,error,region)) tyvars
41 :     val names = map (fn (ref(UBOUND{name,...})) => name
42 :     | _ => bug "elabTyvList") tvs
43 :     in EU.checkUniq((error region),"duplicate type variable name",names);
44 :     tvs
45 :     end
46 :    
47 :     fun elabType(ast:Ast.ty,env:SE.staticEnv,error,region:region)
48 :     : (Types.ty * TS.tyvarset) =
49 :     case ast
50 :     of VarTy vt =>
51 :     let val tyv = elabTyv(vt,error,region)
52 :     in (VARty tyv, TS.singleton tyv)
53 :     end
54 :     | ConTy (co,ts) =>
55 :     let val co1 =
56 :     if (S.name (hd co)) = "->"
57 :     then BT.arrowTycon
58 :     else L.lookArTyc(env,SP.SPATH co,length ts,error region)
59 :     val (lts1,lvt1) = elabTypeList(ts,env,error,region)
60 :     in (mkCONty (co1,lts1),lvt1)
61 :     end
62 :     | RecordTy lbs =>
63 :     let val (lbs1,lvt1) = elabTLabel(lbs,env,error,region)
64 :     in (BT.recordTy(EU.sortRecord(lbs1,error region)),lvt1)
65 :     end
66 :     | TupleTy ts =>
67 :     let val (lts1,lvt1) = elabTypeList(ts,env,error,region)
68 :     in (BT.tupleTy lts1,lvt1)
69 :     end
70 :     | MarkTy (ty,region) => elabType(ty,env,error,region)
71 :    
72 :     and elabTLabel(labs,env,error,region:region) =
73 :     foldr
74 :     (fn ((lb2,t2),(lts2,lvt2)) =>
75 :     let val (t3,lvt3) = elabType(t2,env,error,region)
76 :     in ((lb2,t3) :: lts2, TS.union(lvt3,lvt2,error region))
77 :     end)
78 :     ([],TS.empty) labs
79 :    
80 :     and elabTypeList(ts,env,error,region:region) =
81 :     foldr
82 :     (fn (t2,(lts2,lvt2)) =>
83 :     let val (t3,lvt3) = elabType(t2,env,error,region)
84 :     in (t3 :: lts2, TS.union(lvt3,lvt2,error region))
85 :     end)
86 :     ([],TS.empty) ts
87 :    
88 :    
89 :     (**** DATACON DECLARATIONS ****)
90 :     exception ISREC
91 :    
92 :     fun elabDB((args,name,def,region),env,rpath:IP.path,error) =
93 :     let val rhs = mkCONty(L.lookArTyc (env,SP.SPATH[name],length args,
94 :     error region),
95 :     map VARty args)
96 :    
97 :     fun checkrec(_,NONE) = ()
98 :     | checkrec(_,SOME typ) =
99 :     let fun findname(VarTy _) = ()
100 :     | findname(ConTy([co],ts)) =
101 :     if co = name then (raise ISREC)
102 :     else app findname ts
103 :     | findname(ConTy(_,ts)) = app findname ts
104 :     | findname(RecordTy lbs) = app (fn (_,t) => findname t) lbs
105 :     | findname(TupleTy ts) = app findname ts
106 :     | findname(MarkTy(t,_)) = findname t
107 :    
108 :     in findname(typ)
109 :     end
110 :    
111 :     fun elabConstr (name,SOME ty) =
112 :     let val (t,tv) = elabType(ty,env,error,region)
113 :     in ((name,false,(t --> rhs)),tv)
114 :     end
115 :     | elabConstr (name,NONE) = ((name,true,rhs),TS.empty)
116 :    
117 :     val arity = length args
118 :     val isrec = (app checkrec def; false) handle ISREC => true
119 :     val (dcl,tvs) =
120 :     foldr
121 :     (fn (d,(dcl1,tvs1)) =>
122 :     let val (dc2,tv2) = elabConstr d
123 :     in (dc2::dcl1,TS.union(tv2,tvs1,error region))
124 :     end)
125 :     ([],TS.empty) def
126 :     val _ = EU.checkBoundTyvars(tvs,args,error region)
127 :     val _ = TU.bindTyvars args
128 :     val sdcl = EU.sort3 dcl
129 :     val (reps, sign) = ConRep.infer isrec sdcl
130 :     fun bindDcons ((sym,const,typ),rep) =
131 :     let val _ = TU.compressTy typ
132 :     val typ =
133 :     if arity > 0
134 :     then POLYty {sign=mkPolySign arity,
135 :     tyfun=TYFUN{arity=arity,body=typ}}
136 :     else typ
137 :     in DATACON{name=sym, const=const, rep=rep,
138 :     sign=sign, typ=typ}
139 :     end
140 :     fun bindDconslist ((r1 as (name,_,_))::l1,r2::l2) =
141 :     let val dcon = bindDcons (r1,r2)
142 :     val (dcl,e2) = bindDconslist (l1,l2)
143 :     in (dcon::dcl,Env.bind(name,B.CONbind dcon,e2))
144 :     end
145 :     | bindDconslist ([],[]) = ([],SE.empty)
146 :     | bindDconslist _ = bug "elabDB.bindDconslist"
147 :    
148 :     in if length sdcl < length dcl (* duplicate constructor names *)
149 :     then let fun member(x:string,[]) = false
150 :     | member(x,y::r) = (x = y) orelse member(x,r)
151 :     fun dups([],l) = l
152 :     | dups(x::r,l) =
153 :     if member(x,r) andalso not(member(x,l))
154 :     then dups(r,x::l)
155 :     else dups(r,l)
156 :     fun add_commas [] = []
157 :     | add_commas (y as [_]) = y
158 :     | add_commas (s::r) = s :: "," :: add_commas(r)
159 :     val duplicates = dups(map (fn (n,_,_) => S.name n) dcl,[])
160 :     in error region EM.COMPLAIN
161 :     (concat["datatype ", S.name name,
162 :     " has duplicate constructor name(s): ",
163 :     concat(add_commas(duplicates))])
164 :     EM.nullErrorBody
165 :     end
166 :     else ();
167 :     bindDconslist(sdcl, reps)
168 :     end
169 :    
170 :    
171 :     (**** TYPE DECLARATIONS ****)
172 :    
173 :     fun elabTBlist(tbl:Ast.tb list,notwith:bool,env0,rpath,region,
174 :     {mkStamp,error,...}: EU.compInfo)
175 :     : T.tycon list * S.symbol list * SE.staticEnv =
176 :     let fun elabTB(tb: Ast.tb, env, region): (T.tycon * symbol) =
177 :     case tb
178 :     of Tb{tyc=name,def,tyvars} =>
179 :     let val tvs = elabTyvList(tyvars,error,region)
180 :     val (ty,tv) = elabType(def,env,error,region)
181 :     val arity = length tvs
182 :     val _ = EU.checkBoundTyvars(tv,tvs,error region)
183 :     val _ = TU.bindTyvars tvs
184 :     val _ = TU.compressTy ty
185 :     val tycon =
186 :     DEFtyc{stamp=mkStamp(),
187 :     path=InvPath.extend(rpath,name),
188 :     strict=EU.calc_strictness(arity,ty),
189 :     tyfun=TYFUN{arity=arity, body=ty}}
190 :     in (tycon,name)
191 :     end
192 :     | MarkTb(tb',region') => elabTB(tb',env,region')
193 :     fun loop(nil,tycons,names,env) = (rev tycons,rev names,env)
194 :     | loop(tb::rest,tycons,names,env) =
195 :     let val env' = if notwith then env0 else Env.atop(env,env0)
196 :     val (tycon,name) = elabTB(tb,env',region)
197 :     in loop(rest,tycon::tycons,name::names,
198 :     Env.bind(name,B.TYCbind tycon,env))
199 :     end
200 :     in loop(tbl,nil,nil,SE.empty)
201 :     end
202 :    
203 :     fun elabTYPEdec(tbl: Ast.tb list,env,rpath,region,
204 :     compInfo as {error,mkStamp,...}: EU.compInfo)
205 :     : Absyn.dec * SE.staticEnv =
206 :     let val _ = debugmsg ">>elabTYPEdec"
207 :     val (tycs,names,env') =
208 :     elabTBlist(tbl,true,env,rpath,region,compInfo)
209 :     val _ = debugmsg "--elabTYPEdec: elabTBlist done"
210 :     in EU.checkUniq(error region, "duplicate type definition", names);
211 :     debugmsg "<<elabTYPEdec";
212 :     (TYPEdec tycs, env')
213 :     end
214 :    
215 :     fun elabDATATYPEdec({datatycs,withtycs}, env0, sigContext,
216 :     sigEntEnv, isFree, rpath, region,
217 :     compInfo as {mkStamp,error,...}: EU.compInfo) =
218 :     let (* predefine datatypes *)
219 :     val _ = debugmsg ">>elabDATATYPEdec"
220 :     fun preprocess region (Db{tyc=name,rhs=Constrs def,tyvars}) =
221 :     {tvs=elabTyvList(tyvars,error,region),
222 :     name=name,def=def,region=region,
223 :     tyc=GENtyc{path=IP.extend(rpath,name),
224 :     arity=length tyvars,
225 :     stamp=mkStamp(),
226 :     eq=ref DATA,kind=TEMP}}
227 :     | preprocess _ (MarkDb(db',region')) = preprocess region' db'
228 :     val dbs = map (preprocess region) datatycs
229 :     val _ = debugmsg "--elabDATATYPEdec: preprocessing done"
230 :    
231 :     val envDTycs = (* staticEnv containing preliminary datatycs *)
232 :     foldl (fn ({name,tyc,...},env) =>
233 :     SE.bind(name, B.TYCbind tyc, env)) SE.empty dbs
234 :     val _ = debugmsg "--elabDATATYPEdec: envDTycs defined"
235 :    
236 :     (* elaborate associated withtycs *)
237 :     val (withtycs,withtycNames,envWTycs) =
238 :     elabTBlist(withtycs,false,SE.atop(envDTycs,env0),
239 :     rpath,region,compInfo)
240 :     val _ = debugmsg "--elabDATATYPEdec: withtycs elaborated"
241 :    
242 :     (* check for duplicate tycon names *)
243 :     val _ = EU.checkUniq(error region,
244 :     "duplicate type names in type declaration",
245 :     map #name dbs @ withtycNames);
246 :     val _ = debugmsg "--elabDATATYPEdec: uniqueness checked"
247 :    
248 :     (* staticEnv containing only new datatycs and withtycs *)
249 :     val envTycs = SE.atop(envWTycs, envDTycs)
250 :     (* staticEnv for evaluating the datacon types *)
251 :     val fullEnv = SE.atop(envTycs,env0)
252 :     val _ = debugmsg "--elabDATATYPEdec: envTycs, fullEnv defined"
253 :    
254 :     val prelimDtycs = map #tyc dbs
255 :    
256 :     (* the following functions pull out all the flexible components
257 :     inside the domains of the datatypes, and put them into the
258 :     freetycs field in the DATATYPE kind; this way, future
259 :     re-instantiations of the datatypes only need to modify the
260 :     freetycs list, rather than all the domains (ZHONG)
261 :     *)
262 :     val freeTycsRef = ref ([] : tycon list, 0)
263 :     fun regFree tyc =
264 :     let val (ss, n) = !freeTycsRef
265 :     fun h (x::rest, i) =
266 :     if eqTycon(tyc, x) then FREEtyc (i-1)
267 :     else h(rest, i-1)
268 :     | h ([], _) =
269 :     let val _ = (freeTycsRef := (tyc::ss, n+1))
270 :     in FREEtyc n
271 :     end
272 :     in h (ss, n)
273 :     end
274 :    
275 :     fun transTyc (tyc as GENtyc{kind=TEMP,...}) =
276 :     let fun g(tyc,i,x::rest) =
277 :     if eqTycon(tyc,x) then RECtyc i
278 :     else g(tyc,i+1,rest)
279 :     | g(tyc,_,nil) = tyc
280 :     in g(tyc,0,prelimDtycs)
281 :     end
282 :     | transTyc (tyc as (GENtyc _ | DEFtyc _ | PATHtyc _)) =
283 :     if isFree tyc then regFree tyc else tyc
284 :     | transTyc tyc = tyc
285 :    
286 :     fun transType t =
287 :     case TU.headReduceType t
288 :     of CONty(tyc, args) =>
289 :     CONty(transTyc tyc,map transType args)
290 :     | POLYty{sign,tyfun=TYFUN{arity,body}} =>
291 :     POLYty{sign=sign,
292 :     tyfun=TYFUN{arity=arity,body=transType body}}
293 :     | t => t
294 :    
295 :     (* elaborate the definition of a datatype *)
296 :     fun elabRHS ({tvs,name,def,region,tyc}, (i,done)) =
297 :     let val (datacons,_) =
298 :     elabDB((tvs,name,def,region),fullEnv,rpath,error)
299 :     fun mkDconDesc (DATACON{name,const,rep,sign,typ}) =
300 :     {name=name, rep=rep,
301 :     domain=
302 :     if const then NONE
303 :     else case transType typ
304 :     of CONty(_,[dom,_]) => SOME dom
305 :     | POLYty{tyfun=TYFUN{body=CONty(_,[dom,_]),...},
306 :     ...} => SOME dom
307 :     | _ => bug "elabRHS"}
308 :     in (i+1,
309 :     {name=name,
310 :     dconNames=map (fn DATACON{name,...} => name) datacons,
311 :     (* duplicate names removed *)
312 :     dcons=datacons,
313 :     dconDescs=map mkDconDesc datacons,
314 :     tyc=tyc,
315 :     index=i} :: done)
316 :     end
317 :    
318 :     val (_,dbs') = foldl elabRHS (0,nil) dbs
319 :     val dbs' = rev dbs'
320 :     val _ = debugmsg "--elabDATATYPEdec: RHS elaborated"
321 :    
322 :     fun mkMember{name,dcons,dconDescs,tyc=GENtyc{stamp,arity,eq,...},
323 :     dconNames,index} =
324 :     let val DATACON{sign,...}::_ = dcons
325 :     (* extract common sign from first datacon *)
326 :     in (stamp, {tycname=name,dcons=dconDescs,arity=arity,
327 :     eq=eq,sign=sign})
328 :     end
329 :    
330 :     val (mstamps, members) = ListPair.unzip (map mkMember dbs')
331 :    
332 :     val nstamps = Vector.fromList mstamps
333 :     val nfamily = {members=Vector.fromList members,
334 :     lambdatyc=ref NONE,
335 :     mkey=mkStamp()}
336 :     val nfreetycs =
337 :     let val (x, n) = !freeTycsRef
338 :     val _ = if length x = n then () (* sanity check *)
339 :     else bug "unexpected nfreetycs in elabDATATYPEdec"
340 :     in rev x
341 :     end
342 :     val _ = debugmsg "--elabDATATYPEdec: members defined"
343 :    
344 :     fun fixDtyc{name,index,tyc as GENtyc{path,arity,stamp,eq,kind},
345 :     dconNames,dcons,dconDescs} =
346 :     {old=tyc,
347 :     name=name,
348 :     new=GENtyc{path=path,arity=arity,stamp=stamp,eq=eq,
349 :     kind=DATATYPE{index=index,
350 :     stamps=nstamps,
351 :     family=nfamily,
352 :     freetycs=nfreetycs,
353 :     root=NONE}}}
354 :    
355 :     val dtycmap = map fixDtyc dbs' (* maps prelim to final datatycs *)
356 :     val _ = debugmsg "--elabDATATYPEdec: fixDtycs done"
357 :    
358 :     val finalDtycs = map #new dtycmap
359 :     val _ = debugmsg "--elabDATATYPEdec: finalDtycs defined"
360 :    
361 :     val _ = EqTypes.defineEqProps(finalDtycs,sigContext,sigEntEnv)
362 :     val _ = debugmsg "--elabDATATYPEdec: defineEqProps done"
363 :    
364 :    
365 :     fun applyMap m =
366 :     let fun sameTyc(GENtyc{stamp=s1,...},GENtyc{stamp=s2,...})
367 :     = Stamps.eq(s1,s2)
368 :     | sameTyc(tyc1 as DEFtyc _, tyc2 as DEFtyc _)
369 :     = equalTycon(tyc1, tyc2)
370 :     | sameTyc _ = false
371 :    
372 :     fun f(CONty(tyc, args)) =
373 :     let fun look({old,new,name}::rest) =
374 :     if sameTyc(old,tyc) then new else look rest
375 :     | look nil = tyc
376 :     in CONty(look m, map (applyMap m) args)
377 :     end
378 :     | f (POLYty{sign,tyfun=TYFUN{arity,body}}) =
379 :     POLYty{sign=sign,tyfun=TYFUN{arity=arity,body=f body}}
380 :     | f t = t
381 :     in f
382 :     end
383 :    
384 :     fun augTycmap (tyc as DEFtyc{tyfun=TYFUN{arity,body},stamp,
385 :     strict,path}, tycmap) =
386 :     {old=tyc,name=IP.last path,
387 :     new=DEFtyc{tyfun=TYFUN{arity=arity,body=applyMap tycmap body},
388 :     strict=strict,stamp=stamp,path=path}}
389 :     :: tycmap
390 :    
391 :     (* use foldr to preserve the order of the withtycs [dbm] *)
392 :     (* foldr is wrong! because withtycs will then be processed in the
393 :     reverse order. Notice that tycons in later part of withtycs
394 :     may refer to tycons in the earlier part of withtycs (ZHONG)
395 :     *)
396 :     val alltycmap = (* foldr *) foldl augTycmap dtycmap withtycs
397 :     val _ = debugmsg "--elabDATATYPEdec: alltycmap defined"
398 :    
399 :     fun header(_, 0, z) = z
400 :     | header(a::r, n, z) = if n > 0 then header(r, n-1, a::z)
401 :     else bug "header1 in elabDATATYPEdec"
402 :     | header([], _, _) = bug "header2 in elabDATATYPEdec"
403 :    
404 :     val finalWithtycs = map #new (header(alltycmap,length withtycs,[]))
405 :     val _ = debugmsg "--elabDATATYPEdec: finalWithtycs defined"
406 :    
407 :     fun fixDcon (DATACON{name,const,rep,sign,typ}) =
408 :     DATACON{name=name,const=const,rep=rep,sign=sign,
409 :     typ=applyMap alltycmap typ}
410 :    
411 :     val finalDcons = List.concat(map (map fixDcon) (map #dcons dbs'))
412 :     val _ = debugmsg "--elabDATATYPEdec: finalDcons defined"
413 :    
414 :     val envDcons = foldl (fn (d as DATACON{name,...},e)=>
415 :     SE.bind(name,B.CONbind d, e))
416 :     SE.empty
417 :     finalDcons
418 :    
419 :     val finalEnv = foldr (fn ({old,name,new},e) =>
420 :     SE.bind(name,B.TYCbind new,e))
421 :     envDcons alltycmap
422 :    
423 :     val _ = debugmsg "--elabDATATYPEdec: envDcons, finalEnv defined"
424 :    
425 :     in EU.checkUniq
426 :     (error region, "duplicate datacon names in datatype declaration",
427 :     List.concat(map #dconNames dbs'));
428 :     debugmsg "<<elabDATATYPEdec";
429 :     (finalDtycs,finalWithtycs,finalDcons,finalEnv)
430 :     end (* fun elabDATATYPEdec0 *)
431 :    
432 :     end (* local *)
433 :     end (* structure ElabType *)
434 :    

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