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/compiler/ElabData/types/typesutil.sml
ViewVC logotype

Annotation of /sml/trunk/compiler/ElabData/types/typesutil.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4443 - (view) (download)

1 : jhr 4431 (* typesutil.sml
2 :     *
3 :     * COPYRIGHT (c) 2017 The Fellowship of SML/NJ (http://www.smlnj.org)
4 :     * All rights reserved.
5 :     *)
6 : blume 903
7 :     structure TypesUtil : TYPESUTIL = struct
8 :    
9 :     local
10 :     structure EM = ErrorMsg
11 :     structure SS = Substring
12 :     structure EP = EntPath
13 : jhr 4432 structure BT = BasicTypes
14 : blume 903 structure SP = SymPath
15 :     structure IP = InvPath
16 :     structure S = Symbol
17 :     structure ST = Stamps
18 :     structure A = Access
19 : jhr 4328 open Types VarCon
20 : blume 903 in
21 :    
22 :     val array = Array.array
23 :     val sub = Array.sub
24 :     val update = Array.update
25 :     infix 9 sub
26 :    
27 : jhr 4432 val --> = BT.-->
28 : blume 903 infix -->
29 :    
30 :     val say = Control_Print.say
31 : dbm 3117 val debugging = ElabDataControl.tudebugging
32 : dbm 2492 fun debugmsg msg = if !debugging then say ("TypesUtil: " ^ msg ^ "\n") else ()
33 : blume 903 fun bug msg = EM.impossible("TypesUtil: "^msg)
34 :    
35 :     fun eqpropToString p =
36 :     case p
37 :     of NO => "NO"
38 :     | YES => "YES"
39 :     | IND => "IND"
40 :     | OBJ => "OBJ"
41 :     | DATA => "DATA"
42 :     | UNDEF => "UNDEF"
43 :     | ABS => "ABS"
44 :    
45 :    
46 :     (*************** operations to build tyvars, VARtys ***************)
47 :    
48 :     fun mkMETA depth =
49 :     OPEN{kind=META, depth=depth, eq=false}
50 :    
51 :     fun mkFLEX(fields, depth) =
52 :     OPEN{kind=FLEX fields, depth=depth, eq=false}
53 :    
54 :     fun extract_varname_info name =
55 : jhr 1861 let val name = SS.triml 1 (SS.full name) (* remove leading "'" *)
56 : blume 903 val (name, eq) =
57 : jhr 4328 if SS.sub(name,0) = #"'" (* initial "'" signifies equality *)
58 : blume 903 then (SS.triml 1 name,true)
59 :     else (name,false)
60 :     in (SS.string name, eq)
61 :     end
62 :    
63 :     fun mkUBOUND(id : Symbol.symbol) : tvKind =
64 :     let val (name, eq) = extract_varname_info (Symbol.name id)
65 :     in UBOUND{name=Symbol.tyvSymbol name, depth=infinity, eq=eq}
66 :     end
67 :    
68 : dbm 4000 (* mkLITERALty moved to ElabCore because of use of OverloadLit *)
69 : blume 903
70 :     (*
71 :     * mkMETAty:
72 :     *
73 :     * This function returns a type that represents a new meta variable
74 :     * which does NOT appear in the "context" anywhere. To do the same
75 :     * thing for a meta variable which will appear in the context (because,
76 :     * for example, we are going to assign the resulting type to a program
77 :     * variable), use mkMETAtyBounded with the appropriate depth.
78 :     *)
79 :    
80 : dbm 2492 fun mkMETAtyBounded (depth: int) : ty = VARty(mkTyvar (mkMETA depth))
81 : blume 903
82 :     fun mkMETAty() = mkMETAtyBounded infinity
83 :    
84 :    
85 :    
86 :     (*************** primitive operations on tycons ***************)
87 :     fun bugTyc (s: string, tyc) =
88 :     case tyc
89 :     of GENtyc { path, ... } => bug (s ^ " GENtyc " ^ S.name (IP.last path))
90 :     | DEFtyc {path,...} => bug (s ^ " DEFtyc " ^ S.name(IP.last path))
91 :     | RECORDtyc _ => bug (s ^ " RECORDtyc")
92 :     | PATHtyc{path,...} => bug (s ^ " PATHtyc " ^ S.name(IP.last path))
93 :     | RECtyc _ => bug (s ^ " RECtyc")
94 :     | FREEtyc _ => bug (s ^ " FREEtyc")
95 :     | ERRORtyc => bug (s ^ " ERRORtyc")
96 :    
97 :     (* short (single symbol) name of tycon *)
98 :     fun tycName (GENtyc { path, ... } | DEFtyc{path,...} | PATHtyc{path,...}) =
99 :     IP.last path
100 :     | tycName (RECORDtyc _) = S.tycSymbol "<RECORDtyc>"
101 :     | tycName (RECtyc _) = S.tycSymbol "<RECtyc>"
102 :     | tycName (FREEtyc _) = S.tycSymbol "<FREEtyc>"
103 :     | tycName ERRORtyc = S.tycSymbol "<ERRORtyc>"
104 :    
105 :     (* get the stamp of a tycon *)
106 :     fun tycStamp (GENtyc { stamp, ... } | DEFtyc { stamp, ... }) = stamp
107 :     | tycStamp tycon = bugTyc("tycStamp",tycon)
108 :    
109 :     (* full path name of tycon, an InvPath.path *)
110 :     fun tycPath (GENtyc{path,...} | DEFtyc{path,...} | PATHtyc{path,...}) = path
111 :     | tycPath ERRORtyc = IP.IPATH[S.tycSymbol "error"]
112 :     | tycPath tycon = bugTyc("tycPath",tycon)
113 :    
114 :     fun tycEntPath(PATHtyc{entPath,...}) = entPath
115 :     | tycEntPath tycon = bugTyc("tycEntPath",tycon)
116 :    
117 :     fun tyconArity(GENtyc { arity, ... } | PATHtyc{arity,...}) = arity
118 :     | tyconArity(DEFtyc{tyfun=TYFUN{arity,...},...}) = arity
119 :     | tyconArity(RECORDtyc l) = length l
120 :     | tyconArity(ERRORtyc) = 0
121 :     | tyconArity tycon = bugTyc("tyconArity",tycon)
122 :    
123 :     fun setTycPath(tycon,path) =
124 :     case tycon
125 :     of GENtyc { stamp, arity, eq, kind, path = _, stub = _ } =>
126 :     GENtyc { stamp = stamp, arity = arity, eq = eq, kind = kind,
127 :     path = path, stub = NONE }
128 :     | DEFtyc{tyfun,strict,stamp,path=_} =>
129 :     DEFtyc{tyfun=tyfun,path=path,strict=strict,stamp=stamp}
130 :     | _ => bugTyc("setTycName",tycon)
131 :    
132 :     fun eqRecordLabels(nil,nil) = true
133 :     | eqRecordLabels(x::xs,y::ys) = Symbol.eq(x,y) andalso eqRecordLabels(xs,ys)
134 :     | eqRecordLabels _ = false
135 :    
136 :     fun eqTycon (GENtyc g, GENtyc g') = Stamps.eq (#stamp g, #stamp g')
137 :     | eqTycon (ERRORtyc,_) = true
138 :     | eqTycon (_,ERRORtyc) = true
139 :     (* this rule for PATHtycs is conservatively correct, but is only an
140 :     approximation *)
141 :     | eqTycon(PATHtyc{entPath=ep,...},PATHtyc{entPath=ep',...}) =
142 :     EP.eqEntPath(ep,ep')
143 : dbm 2492 | eqTycon(RECORDtyc l1, RECORDtyc l2) = eqRecordLabels(l1,l2)
144 : blume 903 (*
145 : dbm 2492 * This next case used for comparing DEFtyc's, where we can be
146 :     * sure they are equal if they share the same creation stamp,
147 :     * but otherwise we'll assume they may be different.
148 : blume 903 * Also used in PPBasics to check data constructors of
149 :     * a datatype. Used elsewhere?
150 :     *)
151 : dbm 2492 | eqTycon(DEFtyc{stamp=s1,...},DEFtyc{stamp=s2,...}) =
152 :     Stamps.eq(s1,s2)
153 : blume 903 | eqTycon _ = false
154 :    
155 : dbm 4000 (* prune: ty -> ty; eliminates INSTANTIATED indirections *)
156 : dbm 3117 fun prune(VARty(tv as ref(INSTANTIATED ty)) |
157 :     MARKty(VARty(tv as ref(INSTANTIATED ty)),_)) : ty =
158 : blume 903 let val pruned = prune ty
159 : dbm 2492 in tv := INSTANTIATED pruned; pruned
160 : blume 903 end
161 :     | prune ty = ty
162 : jhr 4328
163 : dbm 2492 fun pruneTyvar(tv as ref(INSTANTIATED ty)) : ty =
164 :     let val pruned = prune ty
165 :     in tv := INSTANTIATED pruned; pruned
166 :     end
167 :     | pruneTyvar _ = bug "pruneTyvar: not an instantiated tyvar"
168 :    
169 : blume 903 fun eqTyvar(tv1: tyvar, tv2: tyvar) = (tv1 = tv2)
170 :    
171 :     fun bindTyvars(tyvars: tyvar list) : unit =
172 :     let fun loop([],_) = ()
173 :     | loop(tv::rest,n) =
174 :     (tv := INSTANTIATED (IBOUND n);
175 :     loop(rest,n+1))
176 :     in loop(tyvars,0)
177 :     end
178 :    
179 :     fun bindTyvars1(tyvars: tyvar list) : Types.polysign =
180 :     let fun loop([],_) = []
181 :     | loop((tv as ref(UBOUND{eq,...}))::rest,n) =
182 :     (tv := INSTANTIATED (IBOUND n);
183 :     eq :: loop(rest,n+1))
184 :     | loop _ = bug "bindTyvars1:UBOUND"
185 :     in loop(tyvars,0)
186 :     end
187 :    
188 :     exception SHARE
189 :    
190 : jhr 4328 (* assume that f fails on identity, i.e. f x raises SHARE instead of
191 : blume 903 returning x *)
192 :     fun shareMap f nil = raise SHARE
193 :     | shareMap f (x::l) =
194 :     (f x) :: ((shareMap f l) handle SHARE => l)
195 :     handle SHARE => x :: (shareMap f l)
196 :    
197 : dbm 4000 (* applyTyfun is more general than instantiatePoly and has
198 :     many uses beyond applyPoly *)
199 : dbm 2492 fun applyTyfun(TYFUN{arity,body}, args: ty list) =
200 : blume 903 let fun subst(IBOUND n) = List.nth(args,n)
201 :     | subst(CONty(tyc,args)) = CONty(tyc, shareMap subst args)
202 :     | subst(VARty(ref(INSTANTIATED ty))) = subst ty
203 : dbm 3117 | subst(MARKty(ty,_)) = subst ty
204 : blume 903 | subst _ = raise SHARE
205 : dbm 2492 in if arity <> length args
206 :     then (say ("$$$ applyTyfun: arity = "^(Int.toString arity)^
207 :     ", |args| = "^(Int.toString(length args))^"\n");
208 :     bug "applyTyfun: arity mismatch")
209 :     else if arity > 0
210 :     then subst body
211 :     handle SHARE => body
212 :     | Subscript => bug "applyTyfun - not enough arguments"
213 : blume 903 else body
214 :     end
215 :    
216 : dbm 2492 fun applyPoly(POLYty{tyfun,...}, args) =
217 :     applyTyfun(tyfun, args)
218 :     | applyPoly _ = bug "TypesUtil.applyPoly"
219 :    
220 : blume 903 fun mapTypeFull f =
221 :     let fun mapTy ty =
222 :     case ty
223 : jhr 4328 of CONty (tc, tl) =>
224 : dbm 2492 CONty(f tc, map mapTy tl)
225 : blume 903 | POLYty {sign, tyfun=TYFUN{arity, body}} =>
226 :     POLYty{sign=sign, tyfun=TYFUN{arity=arity,body=mapTy body}}
227 :     | VARty(ref(INSTANTIATED ty)) => mapTy ty
228 : dbm 3117 | MARKty(ty, region) => mapTy ty
229 : blume 903 | _ => ty
230 :     in mapTy
231 :     end
232 :    
233 :     fun appTypeFull f =
234 :     let fun appTy ty =
235 :     case ty
236 :     of CONty (tc, tl) => (f tc; app appTy tl)
237 :     | POLYty {sign, tyfun=TYFUN{arity, body}} => appTy body
238 :     | VARty(ref(INSTANTIATED ty)) => appTy ty
239 : dbm 3117 | MARKty(ty, region) => appTy ty
240 : blume 903 | _ => ()
241 :     in appTy
242 :     end
243 :    
244 :    
245 :     exception ReduceType
246 :    
247 :     fun reduceType(CONty(DEFtyc{tyfun,...}, args)) = applyTyfun(tyfun,args)
248 :     | reduceType(POLYty{sign=[],tyfun=TYFUN{arity=0,body}}) = body
249 :     | reduceType(VARty(ref(INSTANTIATED ty))) = ty
250 : dbm 4000 | reduceType(MARKty(ty, region)) = ty
251 : blume 903 | reduceType _ = raise ReduceType
252 :    
253 :     fun headReduceType ty = headReduceType(reduceType ty) handle ReduceType => ty
254 :    
255 : dbm 2492 fun equalType(ty: ty,ty': ty) : bool =
256 : blume 903 let fun eq(IBOUND i1, IBOUND i2) = i1 = i2
257 : dbm 4000 | eq(ty1 as VARty(tv1), ty2 as VARty(tv2)) =
258 :     eqTyvar(tv1,tv2) orelse
259 :     (case (tv1,tv2)
260 :     of (ref(INSTANTIATED ty1'), ref(INSTANTIATED ty2')) =>
261 :     equalType(ty1', ty2')
262 :     | (ref(INSTANTIATED ty1'), _) =>
263 :     equalType(ty1',ty2)
264 :     | (_, ref(INSTANTIATED ty2')) =>
265 :     equalType(ty1,ty2')
266 :     | _ => false)
267 : blume 903 | eq(ty as CONty(tycon, args), ty' as CONty(tycon', args')) =
268 : dbm 2492 if eqTycon(tycon, tycon') then
269 :     (case tycon
270 :     of DEFtyc{strict,...} =>
271 :     (* since tycons are equal, both are DEFtycs with
272 :     * the same arity and strict field values *)
273 :     let fun eqargs([],[],[]) = true
274 :     | eqargs(true::ss,ty1::rest1,ty2::rest2) =
275 :     equalType(ty1,ty2) andalso eqargs(ss,rest1,rest2)
276 :     | eqargs(false::ss,ty1::rest1,ty2::rest2) =
277 :     eqargs(ss,rest1,rest2)
278 :     | eqargs _ = bug "eqargs in equalType [TypesUtil]"
279 :     in eqargs(strict,args,args')
280 :     end
281 :     | _ => ListPair.all equalType(args,args'))
282 : blume 903 else (eq(reduceType ty, ty')
283 :     handle ReduceType =>
284 : dbm 4000 (eq(ty,reduceType ty')
285 :     handle ReduceType => false))
286 : blume 903 | eq(ty1 as (VARty _ | IBOUND _), ty2 as CONty _) =
287 : dbm 4000 (eq(prune ty1,reduceType ty2)
288 : blume 903 handle ReduceType => false)
289 :     | eq(ty1 as CONty _, ty2 as (VARty _ | IBOUND _)) =
290 : dbm 4000 (eq(reduceType ty1, prune ty2)
291 : blume 903 handle ReduceType => false)
292 :     | eq(WILDCARDty,_) = true
293 :     | eq(_,WILDCARDty) = true
294 : dbm 3117 | eq(ty1, MARKty(ty, region)) = eq(ty1, ty)
295 :     | eq(MARKty(ty, region), ty2) = eq(ty, ty2)
296 : blume 903 | eq _ = false
297 :     in eq(prune ty, prune ty')
298 :     end
299 :    
300 : dbm 2492 fun equalTypeP(POLYty{sign=s1,tyfun=TYFUN{body=b1,...}},
301 :     POLYty{sign=s2,tyfun=TYFUN{body=b2,...}}) =
302 :     if s1 = s2 then equalType(b1,b2) else false
303 :     | equalTypeP(POLYty _, t2) = false
304 :     | equalTypeP(t1, POLYty _) = false
305 :     | equalTypeP(t1,t2) = equalType(t1,t2)
306 :    
307 : blume 903 local
308 :     (* making dummy argument lists to be used in equalTycon *)
309 :     val generator = Stamps.newGenerator()
310 :     fun makeDummyType() =
311 :     CONty(GENtyc{stamp = Stamps.fresh generator,
312 :     path = IP.IPATH[Symbol.tycSymbol "dummy"],
313 :     arity = 0, eq = ref YES, stub = NONE,
314 : dbm 4437 kind = PRIMITIVE},[])
315 : blume 903 (*
316 :     * Making dummy type is a temporary hack ! pt_void is not used
317 : jhr 4328 * anywhere in the source language ... Requires major clean up
318 : blume 903 * in the future. (ZHONG)
319 :     * DBM: shouldn't cause any problem here. Only thing relevant
320 :     * property of the dummy types is that they have different stamps
321 :     * and their stamps should not agree with those of any "real" tycons.
322 :     *)
323 :     (* precomputing dummy argument lists
324 :     * -- perhaps a bit of over-optimization here. [dbm] *)
325 :     fun makeargs (0,args) = args
326 :     | makeargs (i,args) = makeargs(i-1, makeDummyType()::args)
327 :     val args10 = makeargs(10,[]) (* 10 dummys *)
328 :     val args1 = [hd args10]
329 :     val args2 = List.take (args10,2)
330 :     val args3 = List.take (args10,3) (* rarely need more than 3 args *)
331 : jhr 4328 in fun dummyargs 0 = []
332 : blume 903 | dummyargs 1 = args1
333 :     | dummyargs 2 = args2
334 :     | dummyargs 3 = args3
335 :     | dummyargs n =
336 :     if n <= 10 then List.take (args10,n) (* should be plenty *)
337 :     else makeargs(n-10,args10) (* but make new dummys if needed *)
338 :     end
339 :    
340 :     (* equalTycon. This definition deals only partially with types that
341 :     contain PATHtycs. There is no interpretation of the PATHtycs, but
342 :     PATHtycs with the same entPath will be seen as equal because of the
343 :     definition on eqTycon. *)
344 :     fun equalTycon(ERRORtyc,_) = true
345 :     | equalTycon(_,ERRORtyc) = true
346 :     | equalTycon(t1,t2) =
347 :     let val a1 = tyconArity t1 and a2 = tyconArity t2
348 : dbm 2492 in a1=a2 andalso
349 :     (let val args = dummyargs a1
350 :     in equalType(CONty(t1,args),CONty(t2,args))
351 :     end)
352 : blume 903 end
353 :    
354 :     (* instantiating polytypes *)
355 :    
356 : jhr 4328 fun typeArgs n =
357 : blume 903 if n>0
358 :     then mkMETAty() :: typeArgs(n-1)
359 :     else []
360 :    
361 :     val default_tvprop = false
362 :    
363 :     fun mkPolySign 0 = []
364 :     | mkPolySign n = default_tvprop :: mkPolySign(n-1)
365 :    
366 :     fun dconTyc(DATACON{typ,const,name,...}) =
367 :     let (* val _ = say "*** the screwed datacon ***"
368 :     val _ = say (S.name(name))
369 :     val _ = say " \n" *)
370 :     fun f (POLYty{tyfun=TYFUN{body,...},...},b) = f (body,b)
371 :     | f (CONty(tyc,_),true) = tyc
372 :     | f (CONty(_,[_,CONty(tyc,_)]),false) = tyc
373 : dbm 3117 | f (MARKty(ty, region), b) = f(ty, b)
374 : blume 903 | f _ = bug "dconTyc"
375 :     in f (typ,const)
376 :     end
377 :    
378 : jhr 4328 fun boundargs n =
379 : blume 903 let fun loop(i) =
380 :     if i>=n then nil
381 :     else IBOUND i :: loop(i+1)
382 :     in loop 0
383 :     end
384 :    
385 :     fun dconType (tyc,domain) =
386 : dbm 2492 (case tyconArity tyc
387 :     of 0 => (case domain
388 :     of NONE => CONty(tyc,[])
389 :     | SOME dom => dom --> CONty(tyc,[]))
390 :     | arity =>
391 :     POLYty{sign=mkPolySign arity,
392 :     tyfun=TYFUN{arity=arity,
393 :     body = case domain
394 :     of NONE => CONty(tyc,boundargs(arity))
395 :     | SOME dom =>
396 :     dom --> CONty(tyc,boundargs(arity))}})
397 : blume 903
398 : dbm 4000 (* inClass: ty * ty list -> bool
399 :     * inClass(ty,tys) tests whether ty occurs in the list tys;
400 :     * used in overloading resolution for operators and literals *)
401 :     fun inClass(ty, tys) = List.exists (fn ty' => equalType(ty,ty')) tys
402 : blume 903
403 : dbm 4000
404 : blume 903 val rec compressTy =
405 :     fn t as VARty(x as ref(INSTANTIATED(VARty(ref v)))) =>
406 :     (x := v; compressTy t)
407 :     | VARty(ref(OPEN{kind=FLEX fields,...})) =>
408 :     app (compressTy o #2) fields
409 :     | CONty(tyc,tyl) => app compressTy tyl
410 :     | POLYty{tyfun=TYFUN{body,...},...} => compressTy body
411 :     | _ => ()
412 :    
413 :     (*
414 :     * 8/18/92: cleaned up occ "state machine" some and fixed bug #612.
415 :     * Known behaviour of the attributes about the context that are kept:
416 :     * lamd = # of Abstr's seen so far. Starts at 0 with Root.
417 :     * top = true iff haven't seen a LetDef yet.
418 :     *)
419 :    
420 :     abstype occ = OCC of {lamd: int, top: bool}
421 :     with
422 :    
423 :     val Root = OCC{lamd=0, top=true}
424 :    
425 :     fun LetDef(OCC{lamd,...}) = OCC{lamd=lamd, top=false}
426 :    
427 :     fun Abstr(OCC{lamd,top}) = OCC{lamd=lamd+1, top=top}
428 :    
429 :     fun lamdepth (OCC{lamd,...}) = lamd
430 :    
431 :     fun toplevel (OCC{top,...}) = top
432 :    
433 :     end (* abstype occ *)
434 :    
435 : dbm 2492 (* instantiatePoly: ty -> ty * tyvar list
436 : blume 903 if argument is a POLYty, instantiates body of POLYty with new META typa
437 :     variables, returning the instantiatied body and the list of META tyvars.
438 :     if argument is not a POLYty, does nothing, returning argument type *)
439 : dbm 2492 fun instantiatePoly(POLYty{sign,tyfun}) : ty * tyvar list =
440 :     let val args = (* fresh OPEN metavariables *)
441 : jhr 4328 map (fn eq =>
442 : dbm 2492 ref(OPEN{kind = META, depth = infinity, eq = eq}))
443 : blume 903 sign
444 : dbm 2492 in (applyTyfun(tyfun, map VARty args), args)
445 : blume 903 end
446 :     | instantiatePoly ty = (ty,[])
447 :    
448 : jhr 4328 local
449 : blume 903 exception CHECKEQ
450 :     in
451 :     fun checkEqTySig(ty, sign: polysign) =
452 :     let fun eqty(VARty(ref(INSTANTIATED ty))) = eqty ty
453 :     | eqty(CONty(DEFtyc{tyfun,...}, args)) =
454 :     eqty(applyTyfun(tyfun,args))
455 :     | eqty(CONty(GENtyc { eq, ... }, args)) =
456 :     (case !eq
457 :     of OBJ => ()
458 :     | YES => app eqty args
459 :     | (NO | ABS | IND) => raise CHECKEQ
460 :     | p => bug ("checkEqTySig: "^eqpropToString p))
461 :     | eqty(CONty(RECORDtyc _, args)) = app eqty args
462 :     | eqty(IBOUND n) = if List.nth(sign,n) then () else raise CHECKEQ
463 :     | eqty _ = ()
464 :     in eqty ty;
465 :     true
466 :     end
467 :     handle CHECKEQ => false
468 : dbm 2492
469 :     fun checkEqTyInst(ty) =
470 :     let fun eqty(VARty(ref(INSTANTIATED ty))) = eqty ty
471 :     | eqty(VARty(ref(OPEN{eq,...}))) = if eq then () else raise CHECKEQ
472 : gkuan 2954 | eqty(VARty(ref(LBOUND{eq,...}))) = if eq then () else raise CHECKEQ
473 : dbm 2492 | eqty(CONty(DEFtyc{tyfun,...}, args)) =
474 :     eqty(applyTyfun(tyfun,args))
475 :     | eqty(CONty(GENtyc { eq, ... }, args)) =
476 :     (case !eq
477 :     of OBJ => ()
478 :     | YES => app eqty args
479 :     | (NO | ABS | IND) => raise CHECKEQ
480 :     | p => bug ("checkEqTyInst: "^eqpropToString p))
481 :     | eqty(CONty(RECORDtyc _, args)) = app eqty args
482 :     | eqty(IBOUND n) = bug "checkEqTyInst: IBOUND in instantiated polytype"
483 :     | eqty _ = () (* what other cases? dbm *)
484 :     in eqty ty;
485 :     true
486 :     end
487 :     handle CHECKEQ => false
488 : blume 903 end
489 :    
490 : dbm 2492 (* compType, compareTypes used to compare specification type with type of
491 :     * corresponding actual element. Check that spec type is an instance of
492 :     * the actual type *)
493 : blume 903 exception CompareTypes
494 :     fun compType(specty, specsign:polysign, actty,
495 :     actsign:polysign, actarity): unit =
496 : dbm 2492 let val env = array(actarity,UNDEFty) (* instantiations of IBOUNDs in actual body *)
497 : blume 903 fun comp'(WILDCARDty, _) = ()
498 :     | comp'(_, WILDCARDty) = ()
499 :     | comp'(ty1, IBOUND i) =
500 :     (case env sub i
501 :     of UNDEFty =>
502 :     (let val eq = List.nth(actsign,i)
503 :     in if eq andalso not(checkEqTySig(ty1,specsign))
504 :     then raise CompareTypes
505 : dbm 2492 else update(env,i,ty1)
506 : blume 903 end handle Subscript => ())
507 :     | ty => if equalType(ty1,ty)
508 :     then ()
509 :     else raise CompareTypes)
510 :     | comp'(CONty(tycon1, args1), CONty(tycon2, args2)) =
511 :     if eqTycon(tycon1,tycon2)
512 :     then ListPair.app comp (args1,args2)
513 :     else raise CompareTypes
514 :     | comp' _ = raise CompareTypes
515 :     and comp(ty1,ty2) = comp'(headReduceType ty1, headReduceType ty2)
516 :     in comp(specty,actty)
517 :     end
518 :    
519 : dbm 2492 (* returns true if actual type > spec type, i.e. if spec is an instance of actual *)
520 : jhr 4328 fun compareTypes (spec : ty, actual: ty): bool =
521 : blume 903 let val actual = prune actual
522 :     in case spec
523 :     of POLYty{sign,tyfun=TYFUN{body,...}} =>
524 :     (case actual
525 :     of POLYty{sign=sign',tyfun=TYFUN{arity,body=body'}} =>
526 :     (compType(body,sign,body',sign',arity); true)
527 :     | WILDCARDty => true
528 : dbm 2492 | _ => false) (* if spec is poly, then actual must be poly *)
529 : blume 903 | WILDCARDty => true
530 : dbm 2492 | _ => (* spec is a monotype *)
531 : blume 903 (case actual
532 :     of POLYty{sign,tyfun=TYFUN{arity,body}} =>
533 :     (compType(spec,[],body,sign,arity); true)
534 :     | WILDCARDty => true
535 :     | _ => equalType(spec,actual))
536 :     end handle CompareTypes => false
537 :    
538 : dbm 2492 exception WILDCARDmatch
539 :    
540 :     fun indexBoundTyvars (tdepth : int, []: tyvar list) : unit = ()
541 :     | indexBoundTyvars (tdepth, lboundtvs) =
542 :     let fun setbtvs (i, []) = ()
543 : gkuan 2954 | setbtvs (i, (tv as ref (OPEN{eq,...}))::rest) =
544 :     (tv := LBOUND{depth=tdepth,eq=eq,index=i};
545 : dbm 2492 setbtvs (i+1, rest))
546 :     | setbtvs (i, (tv as ref (LBOUND _))::res) =
547 :     bug ("unexpected tyvar LBOUND in indexBoundTyvars")
548 :     | setbtvs _ = bug "unexpected tyvar INSTANTIATED in mkPE"
549 :     in setbtvs(0, lboundtvs)
550 :     end
551 :    
552 :     (* matchInstTypes: bool * ty * ty -> (tyvar list * tyvar list) option
553 :     * The first argument tells matchInstTypes to ignore the abstract property
554 :     * of abstract types, i.e., this call is being used in FLINT where
555 : jhr 4328 * we can look into abstract types.
556 : gkuan 2954 * The third argument is a spec type (e.g. from a signature spec),
557 : dbm 3117 * while the fourth is a potentially more general actual type. The
558 : dbm 2492 * two types are instantiated (if they are polymorphic), and a one-way
559 : jhr 4328 * match is performed on their generic instantiations.
560 : dbm 2492 * [Note that the match cannot succeed if spec is polymorphic while
561 :     * actualTy is monomorphic.]
562 :     * This function is also used more generally to obtain instantiation
563 :     * parameters for a polytype (actualTy) to match one of its instantiations
564 :     * (specTy). This usage occurs in translate.sml where we match an occurrence
565 :     * type of a primop variable with the intrinsic type of the primop to obtain
566 :     * the instantiation parameters for the primop relative to its intrinsic type.
567 :     *)
568 :     fun matchInstTypes(doExpandAbstract,tdepth,specTy,actualTy) =
569 :     let fun debugmsg' msg = debugmsg ("matchInstTypes: " ^ msg)
570 : jhr 4328 fun expandAbstract(GENtyc {kind=ABSTRACT tyc', ...}) =
571 : dbm 2492 expandAbstract tyc'
572 :     | expandAbstract(tyc) = tyc
573 : jhr 4328 fun match'(WILDCARDty, _) = () (* possible? how?
574 : dbm 2492 [GK 4/20/07] See bug1179
575 :     We do matches against WILDCARDs
576 :     when signature matching fails to
577 :     match a type spec and yet we have
578 :     to match valspec and vals mentioning
579 :     that missing type. *)
580 :     | match'(_, WILDCARDty) = ()
581 : dbm 3117 | match'(MARKty (t, _), t') = match'(t, t')
582 :     | match'(t, MARKty (t', _)) = match'(t, t')
583 : dbm 2492 | match'(ty1, ty2 as VARty(tv as ref(OPEN{kind=META,eq,...}))) =
584 : jhr 4328 (* If we're told to ignore abstract, then we can't
585 : dbm 2492 check for equality types because the original GENtyc
586 :     was lost by setting the type to abstract imperatively.
587 : jhr 4328 Thus, if doExpandAbstract, we skip the equality type
588 : dbm 2492 check. At this point, the elaborator already checked
589 :     for equality types (before they were side-effected),
590 :     hence it is guaranteed that if one is an equality type
591 :     so is the other. The regression test suite coresml
592 : jhr 4328 d005a-ac.sml tests this. [GK 4/11/07]
593 : dbm 2492 *)
594 : jhr 4328 if not(doExpandAbstract) andalso
595 :     (eq andalso not(checkEqTyInst(ty1)))
596 : dbm 2492 then (debugmsg' "VARty META\n"; raise CompareTypes)
597 : jhr 4328 else if equalType(ty1, ty2)
598 : dbm 2492 then ()
599 :     else tv := INSTANTIATED ty1
600 :     | match'(ty1, VARty(tv as ref(INSTANTIATED ty2))) =
601 :     if equalType(ty1,ty2) then ()
602 :     else (debugmsg' "INSTANTIATED"; raise CompareTypes)
603 :     (* GK: Does this make sense? matchInstTypes should not apply
604 : jhr 4328 as is if all the metavariables have been translated
605 : dbm 2492 into LBOUNDs *)
606 : jhr 4328 | match'(ty1, ty2 as VARty(tv' as (ref(LBOUND _)))) =
607 : dbm 2492 if equalType(ty1,ty2) then ()
608 :     else (debugmsg' "matchInstTypes: matching and LBOUND tyvar";
609 :     raise CompareTypes)
610 :     | match'(CONty(tycon1, args1), CONty(tycon2, args2)) =
611 :     if eqTycon(tycon1,tycon2)
612 :     then ListPair.app match (args1,args2)
613 : jhr 4328 else
614 :     (* Example:
615 : dbm 2492 *)
616 :     if doExpandAbstract (* Expand GENtyc ABSTRACT for translate *)
617 :     then
618 :     let val tyc1 = expandAbstract tycon1
619 :     val tyc2 = expandAbstract tycon2
620 : jhr 4328 in if not (eqTycon(tyc1,tycon1)
621 :     andalso eqTycon(tyc2,tycon2))
622 : dbm 2492 then match(CONty(tyc1, args1),
623 :     CONty(tyc2, args2))
624 :     else raise CompareTypes
625 :     end
626 :     else (debugmsg' "CONty"; raise CompareTypes)
627 :     | match'(_, UNDEFty) = (debugmsg' "UNDEFty"; raise CompareTypes)
628 :     | match'(_, IBOUND _) = (debugmsg' "IBOUND"; raise CompareTypes)
629 :     | match'(_, POLYty _) = (debugmsg' "POLYty"; raise CompareTypes)
630 :     | match'(_, CONty _) = (debugmsg' "unmatched CONty"; raise CompareTypes)
631 : jhr 4328 | match'(t1, VARty vk) = (debugmsg' "VARty other";
632 : dbm 2492 raise CompareTypes)
633 :     and match(ty1,ty2) = match'(headReduceType ty1, headReduceType ty2)
634 :     val (actinst, actParamTvs) = instantiatePoly actualTy
635 :     val (specinst, specGenericTvs) = instantiatePoly specTy
636 : gkuan 2954 val _ = indexBoundTyvars(tdepth,specGenericTvs)
637 : dbm 2492 val _ = debugmsg' "Instantiated both\n"
638 :     in match(specinst, actinst);
639 :     debugmsg' "matched\n";
640 :     SOME(specGenericTvs, actParamTvs)
641 :     end handle CompareTypes => NONE
642 :    
643 : blume 903 (* given a single-type-variable type, extract out the tyvar *)
644 :     fun tyvarType (VARty (tv as ref(OPEN _))) = tv
645 :     | tyvarType (VARty (tv as ref(INSTANTIATED t))) = tyvarType t
646 :     | tyvarType WILDCARDty = ref(mkMETA infinity) (* fake a tyvar *)
647 :     | tyvarType (IBOUND i) = bug "tyvarType: IBOUND"
648 :     | tyvarType (CONty(_,_)) = bug "tyvarType: CONty"
649 :     | tyvarType (POLYty _) = bug "tyvarType: POLYty"
650 :     | tyvarType UNDEFty = bug "tyvarType: UNDEFty"
651 : jhr 4328 | tyvarType _ = bug "tyvarType - unexpected argument"
652 : blume 903
653 : jhr 4328 (*
654 :     * getRecTyvarMap : int * ty -> (int -> bool)
655 :     * see if a bound tyvar has occurred in some datatypes, e.g. 'a list.
656 : blume 903 * this is useful for representation analysis. This function probably
657 : jhr 4328 * will soon be obsolete (dbm: Why?).
658 : blume 903 *)
659 :     fun getRecTyvarMap (n,ty) =
660 :     let val s = Array.array(n,false)
661 :     fun notArrow tyc = not (eqTycon (tyc, BT.arrowTycon))
662 :     (* orelse eqTycon(tyc,contTycon) *)
663 :     fun special (tyc as GENtyc { arity, ... }) =
664 :     arity <> 0 andalso notArrow tyc
665 :     | special(RECORDtyc _) = false
666 :     | special tyc = notArrow tyc
667 :    
668 :     fun scan(b,(IBOUND n)) = if b then (update(s,n,true)) else ()
669 : jhr 4328 | scan(b,CONty(tyc,args)) =
670 : blume 903 let val nb = (special tyc) orelse b
671 :     in app (fn t => scan(nb,t)) args
672 :     end
673 :     | scan(b,VARty(ref(INSTANTIATED ty))) = scan(b,ty)
674 :     | scan _ = ()
675 :    
676 :     val _ = scan(false,ty)
677 :    
678 : jhr 4328 in fn i => (Array.sub(s,i) handle General.Subscript =>
679 : blume 903 bug "Strange things in TypesUtil.getRecTyvarMap")
680 :     end
681 :    
682 :     fun gtLabel(a,b) =
683 :     let val a' = Symbol.name a and b' = Symbol.name b
684 :     val a0 = String.sub(a',0) and b0 = String.sub(b',0)
685 :     in if Char.isDigit a0
686 : dbm 2492 then Char.isDigit b0
687 :     andalso (size a' > size b' orelse size a' = size b' andalso a' > b')
688 :     else Char.isDigit b0 orelse (a' > b')
689 : blume 903 end
690 :    
691 :     (* Tests used to implement the value restriction *)
692 :     (* Based on Ken Cline's version; allows refutable patterns *)
693 :     (* Modified to support CAST, and special binding CASEexp. (ZHONG) *)
694 :     (* Modified to allow applications of lazy val rec Y combinators to
695 : jhr 4328 be nonexpansive. (Taha, DBM) *)
696 : dbm 2492
697 : blume 903 local open Absyn in
698 :    
699 : dbm 2492 fun isValue (VARexp _) = true
700 :     | isValue (CONexp _) = true
701 :     | isValue (INTexp _) = true
702 :     | isValue (WORDexp _) = true
703 :     | isValue (REALexp _) = true
704 :     | isValue (STRINGexp _) = true
705 :     | isValue (CHARexp _) = true
706 :     | isValue (FNexp _) = true
707 :     | isValue (RECORDexp fields) =
708 :     foldr (fn ((_,exp),x) => x andalso (isValue exp)) true fields
709 :     | isValue (SELECTexp(_, e)) = isValue e
710 :     | isValue (VECTORexp (exps, _)) =
711 :     foldr (fn (exp,x) => x andalso (isValue exp)) true exps
712 :     | isValue (SEQexp nil) = true
713 :     | isValue (SEQexp [e]) = isValue e
714 :     | isValue (SEQexp _) = false
715 :     | isValue (APPexp(rator, rand)) =
716 :     let fun isrefdcon(DATACON{rep=A.REF,...}) = true
717 :     | isrefdcon _ = false
718 : jhr 4431 fun iscast (VALvar {prim, ...}) = PrimopId.isPrimCast prim
719 : dbm 2492 | iscast _ = false
720 : blume 903
721 : dbm 2492 (* LAZY: The following function allows applications of the
722 :     * fixed-point combinators generated for lazy val recs to
723 :     * be non-expansive. *)
724 : jhr 4328 fun issafe(VALvar{path=(SymPath.SPATH [s]),...}) =
725 : dbm 2492 (case String.explode (Symbol.name s)
726 :     of (#"Y" :: #"$" :: _) => true
727 :     | _ => false)
728 :     | issafe _ = false
729 : blume 903
730 : dbm 2492 fun iscon (CONexp(dcon,_)) = not (isrefdcon dcon)
731 :     | iscon (MARKexp(e,_)) = iscon e
732 :     | iscon (VARexp(ref v, _)) = (iscast v) orelse (issafe v)
733 :     | iscon _ = false
734 :     in if iscon rator then isValue rand
735 :     else false
736 :     end
737 :     | isValue (CONSTRAINTexp(e,_)) = isValue e
738 : jhr 4328 | isValue (CASEexp(e, (RULE(p,_))::_, false)) =
739 : dbm 2492 (isValue e) andalso (irref p) (* special bind CASEexps *)
740 :     | isValue (LETexp(VALRECdec _, e)) = (isValue e) (* special RVB hacks *)
741 :     | isValue (MARKexp(e,_)) = isValue e
742 :     | isValue _ = false
743 : blume 903
744 : dbm 2492
745 : jhr 4328
746 : blume 903 (* testing if a binding pattern is irrefutable --- complete *)
747 : jhr 4328 and irref pp =
748 : blume 903 let fun udcon(DATACON{sign=A.CSIG(x,y),...}) = ((x+y) = 1)
749 :     | udcon _ = false
750 :    
751 :     fun g (CONpat(dc,_)) = udcon dc
752 :     | g (APPpat(dc,_,p)) = (udcon dc) andalso (g p)
753 : jhr 4328 | g (RECORDpat{fields=ps,...}) =
754 : blume 903 let fun h((_, p)::r) = if g p then h r else false
755 : jhr 4328 | h _ = true
756 : blume 903 in h ps
757 :     end
758 :     | g (CONSTRAINTpat(p, _)) = g p
759 :     | g (LAYEREDpat(p1,p2)) = (g p1) andalso (g p2)
760 :     | g (ORpat(p1,p2)) = (g p1) andalso (g p2)
761 : jhr 4328 | g (VECTORpat(ps,_)) =
762 : blume 903 let fun h (p::r) = if g p then h r else false
763 :     | h _ = true
764 :     in h ps
765 :     end
766 : dbm 3648 | g (MARKpat(p,_)) = g p
767 : blume 903 | g _ = true
768 :     in g pp
769 :     end
770 :     end (* local *)
771 :    
772 : dbm 2492
773 : jhr 4328
774 : blume 903 fun isVarTy(VARty(ref(INSTANTIATED ty))) = isVarTy ty
775 :     | isVarTy(VARty _) = true
776 :     | isVarTy(_) = false
777 :    
778 :    
779 :     (* sortFields, mapUnZip: two utility functions used in type checking
780 :     (typecheck.sml, mtderiv.sml, reconstruct.sml) *)
781 :    
782 :     fun sortFields fields =
783 : dbm 3799 ListMergeSort.sort
784 :     (fn ((Absyn.LABEL{number=n1,...},_),
785 :     (Absyn.LABEL{number=n2,...},_)) => n1>n2)
786 :     fields
787 : blume 903
788 : dbm 3799 (* projectField : symbol * ty -> ty option *)
789 :     fun projectField (label: S.symbol, CONty(RECORDtyc fieldNames, fieldTypes)) =
790 :     let fun search (nil, _) = NONE
791 :     | search (n::ns, t::ts) =
792 :     if Symbol.eq (label,n) then SOME t
793 :     else search(ns,ts)
794 :     | search _ = bug "projectField - bad record type"
795 :     in search (fieldNames, fieldTypes)
796 :     end
797 :     | projectField _ = bug "projectField - not record type"
798 :    
799 :     (* mapUnZip : ('a -> 'b * 'c) -> 'a list -> 'b list * 'c list *)
800 : blume 903 fun mapUnZip f nil = (nil,nil)
801 :     | mapUnZip f (hd::tl) =
802 :     let val (x,y) = f(hd)
803 :     val (xl,yl) = mapUnZip f tl
804 :     in (x::xl,y::yl)
805 :     end
806 :    
807 :     fun foldTypeEntire f =
808 : jhr 4328 let fun foldTc (tyc, b0) =
809 : blume 903 case tyc
810 :     of GENtyc { kind, ... } =>
811 :     (case kind of
812 :     DATATYPE{family={members=ms,...},...} => b0
813 :     (* foldl (fn ({dcons, ...},b) => foldl foldDcons b dcons) b0 ms *)
814 :     | ABSTRACT tc => foldTc (tc, b0)
815 :     | _ => b0)
816 :     | DEFtyc{tyfun=TYFUN{arity,body}, ...} => foldTy(body, b0)
817 :     | _ => b0
818 :    
819 :     and foldDcons({name, rep, domain=NONE}, b0) = b0
820 :     | foldDcons({domain=SOME ty, ...}, b0) = foldTy(ty, b0)
821 :    
822 :     and foldTy (ty, b0) =
823 :     case ty
824 : jhr 4328 of CONty (tc, tl) =>
825 : blume 903 let val b1 = f(tc, b0)
826 :     val b2 = foldTc(tc, b1)
827 :     in foldl foldTy b2 tl
828 :     end
829 :     | POLYty {sign, tyfun=TYFUN{arity, body}} => foldTy(body, b0)
830 :     | VARty(ref(INSTANTIATED ty)) => foldTy(ty, b0)
831 :     | _ => b0
832 :     in foldTy
833 :     end
834 :    
835 :     fun mapTypeEntire f =
836 :     let fun mapTy ty =
837 :     case ty
838 : jhr 4328 of CONty (tc, tl) =>
839 : dbm 2492 CONty(f(mapTc, tc), map mapTy tl)
840 : blume 903 | POLYty {sign, tyfun=TYFUN{arity, body}} =>
841 :     POLYty{sign=sign, tyfun=TYFUN{arity=arity,body=mapTy body}}
842 :     | VARty(ref(INSTANTIATED ty)) => mapTy ty
843 :     | _ => ty
844 :    
845 : jhr 4328 and mapTc tyc =
846 : blume 903 case tyc
847 :     of GENtyc { stamp, arity, eq, path, kind, stub = _ } =>
848 :     (case kind of
849 :     DATATYPE{index,family={members,...},...} => tyc
850 :     (*
851 :     * The following code needs to be rewritten !!! (ZHONG)
852 :    
853 :     GENtyc{stamp=stamp, arity=arity, eq=eq, path=path,
854 : jhr 4328 kind=DATATYPE {index=index, members=map mapMb members,
855 : blume 903 lambdatyc = ref NONE}}
856 :     *)
857 :     | ABSTRACT tc =>
858 :     GENtyc {stamp=stamp, arity=arity, eq=eq, path=path,
859 :     kind= ABSTRACT (mapTc tc),
860 :     stub = NONE}
861 :     | _ => tyc)
862 : jhr 4328 | DEFtyc{stamp, strict, tyfun, path} =>
863 : blume 903 DEFtyc{stamp=stamp, strict=strict, tyfun=mapTf tyfun,
864 :     path=path}
865 :     | _ => tyc
866 :    
867 : jhr 4328 and mapMb {tycname, stamp, arity, dcons, lambdatyc} =
868 :     {tycname=tycname, stamp=stamp, arity=arity,
869 : blume 903 dcons=(map mapDcons dcons), lambdatyc=ref NONE}
870 :    
871 :     and mapDcons (x as {name, rep, domain=NONE}) = x
872 : jhr 4328 | mapDcons (x as {name, rep, domain=SOME ty}) =
873 : blume 903 {name=name, rep=rep, domain=SOME(mapTy ty)}
874 :    
875 : jhr 4328 and mapTf (TYFUN{arity, body}) =
876 : blume 903 TYFUN{arity=arity, body=mapTy body}
877 :    
878 :     in mapTy
879 :     end
880 :    
881 :    
882 :     (*
883 : jhr 4328 * Here, using a set implementation should suffice, however,
884 : blume 903 * I am using a binary dictionary instead. (ZHONG)
885 :     *)
886 :     local
887 :     structure TycSet = StampMap
888 :     in
889 :     type tycset = tycon TycSet.map
890 :    
891 :     val mkTycSet = fn () => TycSet.empty
892 :    
893 : jhr 4328 fun addTycSet(tyc as GENtyc { stamp, ... }, tycset) =
894 : blume 903 TycSet.insert (tycset, stamp, tyc)
895 :     | addTycSet _ = bug "unexpected tycons in addTycSet"
896 :    
897 :     fun inTycSet(tyc as GENtyc { stamp, ... }, tycset) =
898 :     isSome (TycSet.find(tycset, stamp))
899 :     | inTycSet _ = false
900 :    
901 : jhr 4328 fun filterSet(ty, tycs) =
902 : dbm 2492 let fun inList (a::r, tc) = eqTycon(a, tc) orelse inList(r, tc)
903 : blume 903 | inList ([], tc) = false
904 :    
905 : jhr 4328 fun pass1 (tc, tset) =
906 : blume 903 if inTycSet(tc, tycs) then
907 :     (if inList(tset, tc) then tset else tc::tset)
908 :     else tset
909 :     in foldTypeEntire pass1 (ty, [])
910 :     end
911 :     (*
912 :     val filterSet = fn x =>
913 :     Stats.doPhase(Stats.makePhase "Compiler 034 filterSet") filterSet x
914 :     *)
915 :    
916 :     end (* local TycSet *)
917 :    
918 :     (*
919 :     (* The reformat function is called inside translate.sml to reformat
920 :     * a type abstraction packing inside PACKexp absyn. It is a hack. (ZHONG)
921 :     *)
922 : jhr 4328 fun reformat { tp_var, tp_tyc } (ty, tycs, depth) =
923 : blume 903 let fun h ([], i, ks, ps, nts) = (rev ks, rev ps, rev nts)
924 :     | h (tc :: rest, i, ks, ps, nts) = let
925 :     fun noabs () = bug "non-abstract tycons seen in TU.reformat"
926 :     in
927 :     case tc
928 :     of GENtyc { stamp, arity, eq, path, kind, stub } =>
929 :     (case kind of
930 :     ABSTRACT itc => let
931 :     val tk = LT.tkc_int arity
932 :     val tps = tp_var { depth=depth, num=i, kind=tk}
933 :     val nkind = FLEXTYC tps
934 :     val ntc =
935 :     GENtyc { stamp = stamp, arity = arity,
936 :     eq = eq, kind = nkind, path = path,
937 :     stub = NONE}
938 :     in
939 :     h (rest, i+1, tk::ks, (tp_tyc itc)::ps, ntc::nts)
940 :     end
941 :     | _ => noabs ())
942 :     | _ => noabs ()
943 :     end
944 :    
945 :     val (tks, tps, ntycs) = h(tycs, 0, [], [], [])
946 :    
947 : jhr 4328 fun getTyc (foo, tc) =
948 : blume 903 let fun h(a::r, tc) = if eqTycon(a, tc) then a else h(r, tc)
949 :     | h([], tc) = foo tc
950 :     in h(ntycs, tc)
951 :     end
952 :    
953 :     val nty = mapTypeEntire getTyc ty
954 :    
955 :     in (nty, tks, tps)
956 :     end
957 :    
958 :     val reformat = Stats.doPhase(Stats.makePhase "Compiler 047 reformat") reformat
959 :     *)
960 :    
961 :     fun dtSibling(n,tyc as GENtyc { kind = DATATYPE dt, ... }) =
962 : dbm 4297 let val {index,stamps,freetycs,root, family as {members,...},stripped} = dt
963 : blume 903 in
964 :     if n = index then tyc
965 :     else let val {tycname,arity,dcons,eq,lazyp,sign} =
966 :     Vector.sub(members,n)
967 :     val stamp= Vector.sub(stamps,n)
968 :     in
969 :     GENtyc {stamp=stamp,
970 :     arity=arity,eq=eq,path=IP.IPATH[tycname],
971 :     kind=DATATYPE{index=n,stamps=stamps,
972 :     freetycs=freetycs,
973 :     root=NONE (*!*),
974 : dbm 4297 stripped=false,
975 : blume 903 family=family},
976 :     stub = NONE}
977 :     end
978 :     end
979 :     | dtSibling _ = bug "dtSibling"
980 :    
981 : jhr 4328 (* NOTE: this only works (perhaps) for datatype declarations, but not
982 : blume 903 specifications. The reason: the root field is used to connect mutually
983 :     recursive datatype specifications together, its information cannot be
984 :     fully recovered in dtSibling. (ZHONG)
985 :     *)
986 :     fun extractDcons (tyc as GENtyc { kind = DATATYPE dt, ... }) =
987 : dbm 4297 let val {index,freetycs,family as {members,...},...} = dt
988 : blume 903 val {dcons,sign,lazyp,...} = Vector.sub(members,index)
989 :     fun expandTyc(PATHtyc _) =
990 :     bug "expandTyc:PATHtyc" (* use expandTycon? *)
991 :     | expandTyc(RECtyc n) = dtSibling(n,tyc)
992 : jhr 4328 | expandTyc(FREEtyc n) =
993 : blume 903 ((List.nth(freetycs,n))
994 :     handle _ => bug "unexpected freetycs in extractDcons")
995 :     | expandTyc tyc = tyc
996 :    
997 :     fun expand ty = mapTypeFull expandTyc ty
998 :    
999 :     fun mkDcon({name,rep,domain}) =
1000 :     DATACON{name = name, rep = rep, sign = sign, lazyp = lazyp,
1001 :     typ = dconType (tyc, Option.map expand domain),
1002 :     const = case domain of NONE => true | _ => false}
1003 :    
1004 :     in map mkDcon dcons
1005 :     end
1006 : dbm 2603 | extractDcons ERRORtyc = bug "extractDcons ERRORtyc"
1007 :     | extractDcons (DEFtyc _) = bug "extractDcons DEFtyc"
1008 : blume 903 | extractDcons _ = bug "extractDcons"
1009 :    
1010 :     fun mkStrict 0 = []
1011 :     | mkStrict n = true :: mkStrict(n-1)
1012 :    
1013 :     (* used in ElabSig for datatype replication specs, where the tyc arg
1014 :     * is expected to be either a GENtyc/DATATYPE or a PATHtyc. *)
1015 :     fun wrapDef(tyc as DEFtyc _,_) = tyc
1016 :     | wrapDef(tyc,s) =
1017 :     let val arity = tyconArity tyc
1018 :     val name = tycName tyc
1019 :     val args = boundargs arity
1020 :     in DEFtyc{stamp=s,strict=mkStrict arity,path=IP.IPATH[name],
1021 :     tyfun=TYFUN{arity=arity,body=CONty(tyc,args)}}
1022 :     end
1023 :    
1024 :     (* eta-reduce a type function: \args.tc args => tc *)
1025 :     fun unWrapDef1(tyc as DEFtyc{tyfun=TYFUN{body=CONty(tyc',args),arity},...}) =
1026 :     let fun formals((IBOUND i)::rest,j) = if i=j then formals(rest,j+1) else false
1027 :     | formals(nil,_) = true
1028 :     | formals _ = false
1029 :     in if formals(args,0) then SOME tyc' else NONE
1030 :     end
1031 :     | unWrapDef1 tyc = NONE
1032 :    
1033 :     (* closure under iterated eta-reduction *)
1034 :     fun unWrapDefStar tyc =
1035 :     (case unWrapDef1 tyc
1036 :     of SOME tyc' => unWrapDefStar tyc'
1037 :     | NONE => tyc)
1038 :    
1039 : dbm 2492 (* dummyTyGen produces a generator of dummy types with names X0, X1, etc.
1040 :     * These are used to to instantiate type metavariables in top-level val
1041 :     * decls that are not generalized because of the value restriction. *)
1042 : blume 903 fun dummyTyGen () : unit -> Types.ty =
1043 :     let val count = ref 0
1044 :     fun next () = (count := !count + 1; !count)
1045 :     fun nextTy () =
1046 :     let val name = "X"^Int.toString(next())
1047 :     in CONty(GENtyc{stamp = ST.special name,
1048 :     path = IP.IPATH[S.tycSymbol name],
1049 :     arity = 0, eq = ref NO,
1050 :     kind = ABSTRACT BT.boolTycon,
1051 :     stub = NONE},
1052 :     [])
1053 :     end
1054 :     in nextTy
1055 :     end
1056 :    
1057 : dbm 4443 (* a crude translation of types to strings *)
1058 :     fun tyToString ty =
1059 :     let fun showargs tys =
1060 :     case tys
1061 :     of nil => ""
1062 :     | [ty] => tyToString ty
1063 :     | ty::tys => toToString ty ^ "," ^ showargs tys
1064 :     in case ty
1065 :     of VARty _ => "<tv>"
1066 :     | IBOUND n => "<"^Int.toString n^">"
1067 :     | CONty(tyc,args) =>
1068 :     if BT.isArrow ty
1069 :     then "(" ^ tyToString BT.domain ty ^ " -> " ^ tyToString BT.range ty ^ ")"
1070 :     else (if null args then "" else "("^showArgs args^")) ^ Symbol.name(tycName tyc)
1071 :     | POLYty{tyfun=TYFUN{body,arity},...} =>
1072 :     "<P" ^ Int.toString arity ^ ">[" ^ tyToString body ^ "]"
1073 :     | WILDCARDty => "<wc>"
1074 :     | UNDEFty => "<ud>"
1075 :     | MARKty (ty,_) => tyToString ty
1076 :     end
1077 : blume 903 end (* local *)
1078 :     end (* structure TypesUtil *)

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