Annotation of /sml/trunk/src/compiler/Semant/types/typesutil.sml

Parent Directory | Revision Log

---

Revision 126 - (view) (download)

1 :	monnier	16	(* Copyright 1996 by Bell Laboratories *)
2 :			(* typesutil.sml *)
3 :
4 :			structure TypesUtil : TYPESUTIL = struct
5 :
6 :			local
7 :			structure EM = ErrorMsg
8 :			structure SS = Substring
9 :			structure EP = EntPath
10 :			structure BT = BasicTypes
11 :			structure SP = SymPath
12 :			structure IP = InvPath
13 :			structure S = Symbol
14 :			structure ST = Stamps
15 :			structure A = Access
16 :			structure II = InlInfo
17 :			structure LT = PLambdaType
18 :			open Types VarCon
19 :			in
20 :
21 :			structure Types = Types
22 :
23 :			val array = Array.array
24 :			val sub = Array.sub
25 :			val update = Array.update
26 :			infix 9 sub
27 :
28 :			val --> = BasicTypes.-->
29 :			infix -->
30 :
31 :			val say = Control.Print.say
32 :			val debugging = ref false
33 :			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 :			let val name = SS.triml 1 (SS.all name) (* remove leading "'" *)
56 :			val (name, eq) =
57 :			if SS.sub(name,0) = #"'" (* initial "'" signifies equality *)
58 :			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 :			fun mkLITERALty (k: litKind, r: SourceMap.region) : ty =
69 :			VARty(mkTyvar(LITERAL{kind=k,region=r}))
70 :
71 :			fun mkSCHEMEty () : ty = VARty(mkTyvar(SCHEME false))
72 :
73 :			(*
74 :			* mkMETAty:
75 :			*
76 :			* This function returns a type that represents a new meta variable
77 :			* which does NOT appear in the "context" anywhere. To do the same
78 :			* thing for a meta variable which will appear in the context (because,
79 :			* for example, we are going to assign the resulting type to a program
80 :			* variable), use mkMETAtyBounded with the appropriate depth.
81 :			*)
82 :
83 :			fun mkMETAtyBounded depth : ty = VARty(mkTyvar (mkMETA depth))
84 :
85 :			fun mkMETAty() = mkMETAtyBounded infinity
86 :
87 :
88 :
89 :			(*************** primitive operations on tycons ***************)
90 :			fun bugTyc (s: string, tyc) =
91 :			case tyc
92 :			of (GENtyc{path,...}) =>
93 :			bug (s ^ " GENtyc " ^ S.name(IP.last path))
94 :			| (DEFtyc{path,...}) =>
95 :			bug (s ^ " DEFtyc " ^ S.name(IP.last path))
96 :			| (RECORDtyc _) => bug (s ^ " RECORDtyc")
97 :			| (PATHtyc{path,...}) =>
98 :			bug (s ^ " PATHtyc " ^ S.name(IP.last path))
99 :			| (RECtyc _) => bug (s ^ " RECtyc")
100 :			| (FREEtyc _) => bug (s ^ " FREEtyc")
101 :			| (ERRORtyc) => bug (s ^ " ERRORtyc")
102 :
103 :			(* short (single symbol) name of tycon *)
104 :			fun tycName(GENtyc{path,...} | DEFtyc{path,...} | PATHtyc{path,...}) = IP.last path
105 :			| tycName(RECORDtyc _) = S.tycSymbol "<RECORDtyc>"
106 :			| tycName(RECtyc _) = S.tycSymbol "<RECtyc>"
107 :			| tycName(FREEtyc _) = S.tycSymbol "<FREEtyc>"
108 :			| tycName ERRORtyc = S.tycSymbol "<ERRORtyc>"
109 :
110 :			(* get the stamp of a tycon *)
111 :			fun tycStamp(GENtyc{stamp,...}) = stamp
112 :			| tycStamp(DEFtyc{stamp,...}) = stamp
113 :			| tycStamp tycon = bugTyc("tycStamp",tycon)
114 :
115 :			(* full path name of tycon, an InvPath.path *)
116 :			fun tycPath (GENtyc{path,...}) : IP.path = path
117 :			| tycPath (DEFtyc{path,...}) = path
118 :			| tycPath (PATHtyc{path, ...}) = path
119 :			| tycPath ERRORtyc = IP.IPATH[S.tycSymbol "error"]
120 :			| tycPath tycon = bugTyc("tycPath",tycon)
121 :
122 :			fun tycEntPath(PATHtyc{entPath,...}) = entPath
123 :			| tycEntPath tycon = bugTyc("tycEntPath",tycon)
124 :
125 :			fun tyconArity(GENtyc{arity,...}) = arity
126 :			| tyconArity(PATHtyc{arity,...}) = arity
127 :			| tyconArity(DEFtyc{tyfun=TYFUN{arity,...},...}) = arity
128 :			| tyconArity(RECORDtyc l) = length l
129 :			| tyconArity(ERRORtyc) = 0
130 :			| tyconArity tycon = bugTyc("tyconArity",tycon)
131 :
132 :			fun setTycPath(tycon,path) =
133 :			case tycon
134 :			of GENtyc{stamp,arity,eq,kind,...} =>
135 :			GENtyc{stamp=stamp,path=path,arity=arity,eq=eq,kind=kind}
136 :			| DEFtyc{tyfun,strict,stamp,...} =>
137 :			DEFtyc{tyfun=tyfun,path=path,strict=strict,stamp=stamp}
138 :			| _ => bugTyc("setTycName",tycon)
139 :
140 :			fun eqTycon(GENtyc{stamp=s,...},GENtyc{stamp=s',...}) = Stamps.eq(s,s')
141 :			| eqTycon(ERRORtyc,_) = true
142 :			| eqTycon(_,ERRORtyc) = true
143 :			(* this rule for PATHtycs is conservatively correct, but is only an
144 :			approximation *)
145 :			| eqTycon(PATHtyc{entPath=ep,...},PATHtyc{entPath=ep',...}) =
146 :			EP.eqEntPath(ep,ep')
147 :			(*
148 :			* This last case used for comparing DEFtyc's, RECORDtyc's.
149 :			* Also used in PPBasics to check data constructors of
150 :			* a datatype. Used elsewhere?
151 :			*)
152 :			| eqTycon(RECORDtyc l1, RECORDtyc l2) = l1=l2
153 :			| eqTycon _ = false
154 :
155 :			(* for now... *)
156 :			fun mkCONty(ERRORtyc, _) = WILDCARDty
157 :			| mkCONty(tycon as DEFtyc{tyfun,strict,...}, args) =
158 :			CONty(tycon, ListPair.map
159 :			(fn (ty,strict) => if strict then ty else WILDCARDty)
160 :			(args,strict))
161 :			| mkCONty(tycon, args) = CONty(tycon, args);
162 :
163 :			fun prune(VARty(tv as ref(INSTANTIATED ty))) : ty =
164 :			let val pruned = prune ty
165 :			in tv := INSTANTIATED pruned; pruned
166 :			end
167 :			| prune ty = ty
168 :
169 :			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 :			in loop(tyvars,0)
185 :			end
186 :
187 :			exception SHARE
188 :
189 :			(* assume that f fails on identity, i.e. f x raises SHARE instead of
190 :			returning x *)
191 :			fun shareMap f nil = raise SHARE
192 :			| shareMap f (x::l) =
193 :			(f x) :: ((shareMap f l) handle SHARE => l)
194 :			handle SHARE => x :: (shareMap f l)
195 :
196 :			(*** This function should be merged with instantiatePoly soon --zsh ***)
197 :			fun applyTyfun(TYFUN{arity,body},args) =
198 :			let fun subst(IBOUND n) = List.nth(args,n)
199 :			| subst(CONty(tyc,args)) = CONty(tyc, shareMap subst args)
200 :			| subst(VARty(ref(INSTANTIATED ty))) = subst ty
201 :			| subst _ = raise SHARE
202 :			in if arity > 0
203 :			then subst body
204 :			handle SHARE => body
205 :			| Subscript => bug "applyTyfun - not enough arguments"
206 :			else body
207 :			end
208 :
209 :			fun mapTypeFull f =
210 :			let fun mapTy ty =
211 :			case ty
212 :			of CONty (tc, tl) =>
213 :			mkCONty(f tc, map mapTy tl)
214 :			| POLYty {sign, tyfun=TYFUN{arity, body}} =>
215 :			POLYty{sign=sign, tyfun=TYFUN{arity=arity,body=mapTy body}}
216 :			| VARty(ref(INSTANTIATED ty)) => mapTy ty
217 :			| _ => ty
218 :			in mapTy
219 :			end
220 :
221 :			fun appTypeFull f =
222 :			let fun appTy ty =
223 :			case ty
224 :			of CONty (tc, tl) => (f tc; app appTy tl)
225 :			| POLYty {sign, tyfun=TYFUN{arity, body}} => appTy body
226 :			| VARty(ref(INSTANTIATED ty)) => appTy ty
227 :			| _ => ()
228 :			in appTy
229 :			end
230 :
231 :
232 :			exception ReduceType
233 :
234 :			fun reduceType(CONty(DEFtyc{tyfun,...}, args)) = applyTyfun(tyfun,args)
235 :			| reduceType(POLYty{sign=[],tyfun=TYFUN{arity=0,body}}) = body
236 :			| reduceType(VARty(ref(INSTANTIATED ty))) = ty
237 :			| reduceType _ = raise ReduceType
238 :
239 :			fun headReduceType ty = headReduceType(reduceType ty) handle ReduceType => ty
240 :
241 :			fun equalType(ty,ty') =
242 :			let fun eq(IBOUND i1, IBOUND i2) = i1 = i2
243 :			| eq(VARty(tv),VARty(tv')) = eqTyvar(tv,tv')
244 :			| eq(ty as CONty(tycon, args), ty' as CONty(tycon', args')) =
245 :			if eqTycon(tycon, tycon') then ListPair.all equalType(args,args')
246 :			else (eq(reduceType ty, ty')
247 :			handle ReduceType =>
248 :			(eq(ty,reduceType ty') handle ReduceType => false))
249 :			| eq(ty1 as VARty _, ty2 as CONty _) =
250 :			(eq(ty1,reduceType ty2)
251 :			handle ReduceType => false)
252 :			| eq(ty1 as CONty _, ty2 as VARty _) =
253 :			(eq(reduceType ty1, ty2)
254 :			handle ReduceType => false)
255 :			| eq(WILDCARDty,_) = true
256 :			| eq(_,WILDCARDty) = true
257 :			| eq _ = false
258 :			in eq(prune ty, prune ty')
259 :			end
260 :
261 :			local
262 :			fun makeDummyType() =
263 :			CONty(GENtyc{stamp = Stamps.special "dummy",
264 :			path = IP.IPATH[S.tycSymbol "dummy"],
265 :			arity = 0, eq = ref YES,
266 :			kind = PRIMITIVE (PrimTyc.ptc_void)},[])
267 :			(*
268 :			* Making dummy type is a temporary hack ! pt_void is not used
269 :			* anywhere in the source language ... Requires major clean up
270 :			* in the future. (ZHONG)
271 :			*)
272 :
273 :			fun makeargs 0 = []
274 :			| makeargs i = makeDummyType() :: makeargs(i-1)
275 :			val args = makeargs 10
276 :			fun dargs(0,_,d) = d
277 :			| dargs(n,a::r,d) = dargs(n-1,r,a::d)
278 :			| dargs(n,[],d) = dargs(n-1,[],makeDummyType()::d)
279 :			in fun dummyargs n = dargs(n,args,[])
280 :			end
281 :
282 :			(* equalTycon. This definition deals only partially with types that
283 :			contain PATHtycs. There is no interpretation of the PATHtycs, but
284 :			PATHtycs with the same entPath will be seen as equal because of the
285 :			definition on eqTycon. *)
286 :			fun equalTycon(ERRORtyc,_) = true
287 :			| equalTycon(_,ERRORtyc) = true
288 :			| equalTycon(t1,t2) =
289 :			let val a1 = tyconArity t1 and a2 = tyconArity t2
290 :			in if a1<>a2 then false
291 :			else
292 :			let val args = dummyargs a1
293 :			in equalType(mkCONty(t1,args),mkCONty(t2,args))
294 :			end
295 :			end
296 :
297 :			(* instantiating polytypes *)
298 :
299 :			fun typeArgs n =
300 :			if n>0
301 :			then mkMETAty() :: typeArgs(n-1)
302 :			else []
303 :
304 :			val default_tvprop = false
305 :
306 :			fun mkPolySign 0 = []
307 :			| mkPolySign n = default_tvprop :: mkPolySign(n-1)
308 :
309 :			fun dconTyc(DATACON{typ,const,name,...}) =
310 :			let (* val _ = say "*** the screwed datacon ***"
311 :			val _ = say (S.name(name))
312 :			val _ = say " \n" *)
313 :			fun f (POLYty{tyfun=TYFUN{body,...},...},b) = f (body,b)
314 :			| f (CONty(tyc,_),true) = tyc
315 :			| f (CONty(_,[_,CONty(tyc,_)]),false) = tyc
316 :			| f _ = bug "dconTyc"
317 :			in f (typ,const)
318 :			end
319 :
320 :			fun boundargs n =
321 :			let fun loop(i) =
322 :			if i>=n then nil
323 :			else IBOUND i :: loop(i+1)
324 :			in loop 0
325 :			end
326 :
327 :			fun dconType(tyc,domain) =
328 :			let val arity = tyconArity tyc
329 :			in case arity
330 :			of 0 =>
331 :			(case domain
332 :			of NONE => CONty(tyc,[])
333 :			| SOME dom => dom --> CONty(tyc,[]))
334 :			| _ =>
335 :			POLYty{sign=mkPolySign arity,
336 :			tyfun=TYFUN{arity=arity,
337 :			body=case domain
338 :			of NONE =>
339 :			CONty(tyc,boundargs(arity))
340 :			| SOME dom =>
341 :			dom --> CONty(tyc,boundargs(arity))}}
342 :			end
343 :
344 :			(* matching a scheme against a target type -- used declaring overloadings *)
345 :			fun matchScheme(TYFUN{arity,body}: tyfun, target: ty) : ty =
346 :			let val tyenv = array(arity,UNDEFty)
347 :			fun matchTyvar(i:int, ty: ty) : unit =
348 :			case tyenv sub i
349 :			of UNDEFty => update(tyenv,i,ty)
350 :			| ty' => if equalType(ty,ty')
351 :			then ()
352 :			else bug("this compiler was inadvertantly \
353 :			\distributed to a user who insists on \
354 :			\playing with 'overload' declarations.")
355 :			fun match(scheme:ty, target:ty) =
356 :			case (prune scheme,prune(target))
357 :			of (WILDCARDty, _) => () (* Wildcards match any type *)
358 :			| (_, WILDCARDty) => () (* Wildcards match any type *)
359 :			| ((IBOUND i),ty) => matchTyvar(i,ty)
360 :			| (CONty(tycon1,args1), pt as CONty(tycon2,args2)) =>
361 :			if eqTycon(tycon1,tycon2)
362 :			then ListPair.app match (args1, args2)
363 :			else (match(reduceType scheme, target)
364 :			handle ReduceType =>
365 :			(match(scheme, reduceType pt)
366 :			handle ReduceType =>
367 :			bug "matchScheme, match -- tycons "))
368 :			| _ => bug "matchScheme, match"
369 :			in case prune target
370 :			of POLYty{sign,tyfun=TYFUN{arity=arity',body=body'}} =>
371 :			(match(body,body');
372 :			POLYty{sign = sign,
373 :			tyfun = TYFUN{arity = arity',
374 :			body = if arity>1
375 :	monnier	93	then BT.tupleTy(Array.foldr (op ::) nil tyenv)
376 :	monnier	16	else tyenv sub 0}})
377 :			| ty =>
378 :			(match(body,ty);
379 :			if arity>1
380 :	monnier	93	then BT.tupleTy(Array.foldr (op ::) nil tyenv)
381 :	monnier	16	else tyenv sub 0)
382 :			end
383 :
384 :			val rec compressTy =
385 :			fn t as VARty(x as ref(INSTANTIATED(VARty(ref v)))) =>
386 :			(x := v; compressTy t)
387 :			| VARty(ref(OPEN{kind=FLEX fields,...})) =>
388 :			app (compressTy o #2) fields
389 :			| CONty(tyc,tyl) => app compressTy tyl
390 :			| POLYty{tyfun=TYFUN{body,...},...} => compressTy body
391 :			| _ => ()
392 :
393 :			(*
394 :			* 8/18/92: cleaned up occ "state machine" some and fixed bug #612.
395 :			*
396 :			* Known behaviour of the attributes about the context that are kept:
397 :			*
398 :			* lamd = # of Abstr's seen so far. Starts at 0 with Root.
399 :			*
400 :			* top = true iff haven't seen a LetDef yet.
401 :			*)
402 :
403 :			abstype occ = OCC of {lamd: int, top: bool}
404 :			with
405 :
406 :			val Root = OCC{lamd=0, top=true}
407 :
408 :			fun LetDef(OCC{lamd,...}) = OCC{lamd=lamd, top=false}
409 :
410 :			fun Abstr(OCC{lamd,top}) = OCC{lamd=lamd+1, top=top}
411 :
412 :			fun lamdepth (OCC{lamd,...}) = lamd
413 :
414 :			fun toplevel (OCC{top,...}) = top
415 :
416 :			end (* abstype occ *)
417 :
418 :			(* instantiatePoly: ty -> ty * ty list
419 :			if argument is a POLYty, instantiates body of POLYty with new META typa
420 :			variables, returning the instantiatied body and the list of META tyvars.
421 :			if argument is not a POLYty, does nothing, returning argument type *)
422 :			fun instantiatePoly(POLYty{sign,tyfun}) : ty * ty list =
423 :			let val args =
424 :			map (fn eq =>
425 :			VARty(ref(OPEN{kind = META, depth = infinity, eq = eq})))
426 :			sign
427 :			in (applyTyfun(tyfun, args), args)
428 :			end
429 :			| instantiatePoly ty = (ty,[])
430 :
431 :			local
432 :			exception CHECKEQ
433 :			in
434 :			fun checkEqTySig(ty, sign: polysign) =
435 :			let fun eqty(VARty(ref(INSTANTIATED ty))) = eqty ty
436 :			| eqty(CONty(DEFtyc{tyfun,...}, args)) =
437 :			eqty(applyTyfun(tyfun,args))
438 :			| eqty(CONty(GENtyc{eq,...}, args)) =
439 :			(case !eq
440 :			of OBJ => ()
441 :			| YES => app eqty args
442 :			| (NO | ABS | IND) => raise CHECKEQ
443 :			| p => bug ("checkEqTySig: "^eqpropToString p))
444 :			| eqty(CONty(RECORDtyc _, args)) = app eqty args
445 :			| eqty(IBOUND n) = if List.nth(sign,n) then () else raise CHECKEQ
446 :			| eqty _ = ()
447 :			in eqty ty;
448 :			true
449 :			end
450 :			handle CHECKEQ => false
451 :			end
452 :
453 :			exception CompareTypes
454 :			fun compType(specty, specsign:polysign, actty,
455 :			actsign:polysign, actarity): unit =
456 :			let val env = array(actarity,UNDEFty)
457 :			fun comp'(WILDCARDty, _) = ()
458 :			| comp'(_, WILDCARDty) = ()
459 :			| comp'(ty1, IBOUND i) =
460 :			(case env sub i
461 :			of UNDEFty =>
462 :			(let val eq = List.nth(actsign,i)
463 :			in if eq andalso not(checkEqTySig(ty1,specsign))
464 :			then raise CompareTypes
465 :			else ();
466 :			update(env,i,ty1)
467 :			end handle Subscript => ())
468 :			| ty => if equalType(ty1,ty)
469 :			then ()
470 :			else raise CompareTypes)
471 :			| comp'(CONty(tycon1, args1), CONty(tycon2, args2)) =
472 :			if eqTycon(tycon1,tycon2)
473 :			then ListPair.app comp (args1,args2)
474 :			else raise CompareTypes
475 :			| comp' _ = raise CompareTypes
476 :			and comp(ty1,ty2) = comp'(headReduceType ty1, headReduceType ty2)
477 :			in comp(specty,actty)
478 :			end
479 :
480 :			(* returns true if actual type > spec type *)
481 :			fun compareTypes (spec : ty, actual: ty): bool =
482 :			let val actual = prune actual
483 :			in case spec
484 :			of POLYty{sign,tyfun=TYFUN{body,...}} =>
485 :			(case actual
486 :			of POLYty{sign=sign',tyfun=TYFUN{arity,body=body'}} =>
487 :			(compType(body,sign,body',sign',arity); true)
488 :			| WILDCARDty => true
489 :			| _ => false)
490 :			| WILDCARDty => true
491 :			| _ =>
492 :			(case actual
493 :			of POLYty{sign,tyfun=TYFUN{arity,body}} =>
494 :			(compType(spec,[],body,sign,arity); true)
495 :			| WILDCARDty => true
496 :			| _ => equalType(spec,actual))
497 :			end handle CompareTypes => false
498 :
499 :			(* given a single-type-variable type, extract out the tyvar *)
500 :			fun tyvarType (VARty (tv as ref(OPEN _))) = tv
501 :			| tyvarType (VARty (tv as ref(INSTANTIATED t))) = tyvarType t
502 :			| tyvarType WILDCARDty = ref(mkMETA infinity) (* fake a tyvar *)
503 :			| tyvarType (IBOUND i) = bug "tyvarType: IBOUND"
504 :			| tyvarType (CONty(_,_)) = bug "tyvarType: CONty"
505 :			| tyvarType (POLYty _) = bug "tyvarType: POLYty"
506 :			| tyvarType UNDEFty = bug "tyvarType: UNDEFty"
507 :			| tyvarType _ = bug "tyvarType 124"
508 :
509 :			(*
510 :			* getRecTyvarMap : int * ty -> (int -> bool)
511 :			* see if a bound tyvar has occurred in some datatypes, e.g. 'a list.
512 :			* this is useful for representation analysis. This function probably
513 :			* will soon be obsolete.
514 :			*)
515 :			fun getRecTyvarMap(n,ty) =
516 :			let val s = Array.array(n,false)
517 :			fun special(GENtyc{arity=0,...}) = false
518 :			| special(RECORDtyc _) = false
519 :			| special tyc = not(eqTycon(tyc,BT.arrowTycon))
520 :			(* orelse eqTycon(tyc,contTycon) *)
521 :
522 :			fun scan(b,(IBOUND n)) = if b then (update(s,n,true)) else ()
523 :			| scan(b,CONty(tyc,args)) =
524 :			let val nb = (special tyc) orelse b
525 :			in app (fn t => scan(nb,t)) args
526 :			end
527 :			| scan(b,VARty(ref(INSTANTIATED ty))) = scan(b,ty)
528 :			| scan _ = ()
529 :
530 :			val _ = scan(false,ty)
531 :
532 :			in fn i => (Array.sub(s,i) handle General.Subscript =>
533 :			bug "Strange things in TypesUtil.getRecTyvarMap")
534 :			end
535 :
536 :			fun gtLabel(a,b) =
537 :			let val a' = Symbol.name a and b' = Symbol.name b
538 :			val a0 = String.sub(a',0) and b0 = String.sub(b',0)
539 :			in if Char.isDigit a0
540 :			then if Char.isDigit b0
541 :			then (size a' > size b' orelse size a' = size b' andalso a' > b')
542 :			else false
543 :			else if Char.isDigit b0
544 :			then true
545 :			else (a' > b')
546 :			end
547 :
548 :			(* Tests used to implement the value restriction *)
549 :			(* Based on Ken Cline's version; allows refutable patterns *)
550 :			(* Modified to support CAST, and special binding CASEexp. (ZHONG) *)
551 :	monnier	106	(* Modified to allow applications of lazy val rec Y combinators to
552 :			be nonexpansive. (Taha, DBM) *)
553 :			local open Absyn in
554 :	monnier	16
555 :			fun isValue(VARexp _) = true
556 :			| isValue(CONexp _) = true
557 :			| isValue(INTexp _) = true
558 :			| isValue(WORDexp _) = true
559 :			| isValue(REALexp _) = true
560 :			| isValue(STRINGexp _) = true
561 :			| isValue(CHARexp _) = true
562 :			| isValue(FNexp _) = true
563 :			| isValue(RECORDexp fields) =
564 :			foldr (fn ((_,exp),x) => x andalso (isValue exp)) true fields
565 :			| isValue(SELECTexp(_, e)) = isValue e
566 :			| isValue(VECTORexp (exps, _)) =
567 :			foldr (fn (exp,x) => x andalso (isValue exp)) true exps
568 :			| isValue(SEQexp nil) = true
569 :			| isValue(SEQexp [e]) = isValue e
570 :			| isValue(SEQexp _) = false
571 :			| isValue(APPexp(rator, rand)) =
572 :			let fun isrefdcon(DATACON{rep=A.REF,...}) = true
573 :			| isrefdcon _ = false
574 :
575 :			fun iscast(VALvar{info,...}) = II.pureInfo info
576 :			| iscast _ = false
577 :
578 :	monnier	106	(* LAZY: The following function allows applications of the fixed-point
579 :			* combinators generated for lazy val recs to be non-expansive. *)
580 :	monnier	16	fun issafe(VALvar{path=(SymPath.SPATH [s]),...}) =
581 :	monnier	106	(case String.explode (Symbol.name s)
582 :			of (#"Y" :: #"$" :: _) => true
583 :			| _ => false)
584 :	monnier	16	| issafe _ = false
585 :
586 :			fun iscon (CONexp(dcon,_)) = not (isrefdcon dcon)
587 :			| iscon (MARKexp(e,_)) = iscon e
588 :			| iscon (VARexp(ref v, _)) = (iscast v) orelse (issafe v)
589 :			| iscon _ = false
590 :			in if iscon rator then isValue rand
591 :			else false
592 :			end
593 :			| isValue(CONSTRAINTexp(e,_)) = isValue e
594 :			| isValue(CASEexp(e, (RULE(p,_))::_, false)) =
595 :			(isValue e) andalso (irref p) (* special bind CASEexps *)
596 :			| isValue(LETexp(VALRECdec _, e)) = (isValue e) (* special RVB hacks *)
597 :			| isValue(MARKexp(e,_)) = isValue e
598 :			| isValue _ = false
599 :
600 :			(* testing if a binding pattern is irrefutable --- complete *)
601 :			and irref pp =
602 :			let fun udcon(DATACON{sign=A.CSIG(x,y),...}) = ((x+y) = 1)
603 :			| udcon _ = false
604 :
605 :			fun g (CONpat(dc,_)) = udcon dc
606 :			| g (APPpat(dc,_,p)) = (udcon dc) andalso (g p)
607 :			| g (RECORDpat{fields=ps,...}) =
608 :			let fun h((_, p)::r) = if g p then h r else false
609 :			| h _ = true
610 :			in h ps
611 :			end
612 :			| g (CONSTRAINTpat(p, _)) = g p
613 :			| g (LAYEREDpat(p1,p2)) = (g p1) andalso (g p2)
614 :			| g (ORpat(p1,p2)) = (g p1) andalso (g p2)
615 :			| g (VECTORpat(ps,_)) =
616 :			let fun h (p::r) = if g p then h r else false
617 :			| h _ = true
618 :			in h ps
619 :			end
620 :			| g _ = true
621 :			in g pp
622 :			end
623 :			end (* local *)
624 :
625 :			fun isVarTy(VARty(ref(INSTANTIATED ty))) = isVarTy ty
626 :			| isVarTy(VARty _) = true
627 :			| isVarTy(_) = false
628 :
629 :
630 :			(* sortFields, mapUnZip: two utility functions used in type checking
631 :			(typecheck.sml, mtderiv.sml, reconstruct.sml) *)
632 :
633 :			fun sortFields fields =
634 :			Sort.sort (fn ((Absyn.LABEL{number=n1,...},_),
635 :			(Absyn.LABEL{number=n2,...},_)) => n1>n2)
636 :			fields
637 :
638 :			fun mapUnZip f nil = (nil,nil)
639 :			| mapUnZip f (hd::tl) =
640 :			let val (x,y) = f(hd)
641 :			val (xl,yl) = mapUnZip f tl
642 :			in (x::xl,y::yl)
643 :			end
644 :
645 :			fun foldTypeEntire f =
646 :			let fun foldTc (tyc, b0) =
647 :			case tyc
648 :			of GENtyc{kind=DATATYPE{family={members=ms,...},...},...} => b0
649 :			(* foldl (fn ({dcons, ...},b) => foldl foldDcons b dcons) b0 ms *)
650 :			| GENtyc{kind=ABSTRACT tc, ...} => foldTc(tc, b0)
651 :			| DEFtyc{tyfun=TYFUN{arity,body}, ...} => foldTy(body, b0)
652 :			| _ => b0
653 :
654 :			and foldDcons({name, rep, domain=NONE}, b0) = b0
655 :			| foldDcons({domain=SOME ty, ...}, b0) = foldTy(ty, b0)
656 :
657 :			and foldTy (ty, b0) =
658 :			case ty
659 :			of CONty (tc, tl) =>
660 :			let val b1 = f(tc, b0)
661 :			val b2 = foldTc(tc, b1)
662 :			in foldl foldTy b2 tl
663 :			end
664 :			| POLYty {sign, tyfun=TYFUN{arity, body}} => foldTy(body, b0)
665 :			| VARty(ref(INSTANTIATED ty)) => foldTy(ty, b0)
666 :			| _ => b0
667 :			in foldTy
668 :			end
669 :
670 :			fun mapTypeEntire f =
671 :			let fun mapTy ty =
672 :			case ty
673 :			of CONty (tc, tl) =>
674 :			mkCONty(f(mapTc, tc), map mapTy tl)
675 :			| POLYty {sign, tyfun=TYFUN{arity, body}} =>
676 :			POLYty{sign=sign, tyfun=TYFUN{arity=arity,body=mapTy body}}
677 :			| VARty(ref(INSTANTIATED ty)) => mapTy ty
678 :			| _ => ty
679 :
680 :			and mapTc tyc =
681 :			case tyc
682 :			of GENtyc{stamp, arity, eq,
683 :			kind=DATATYPE{index,family={members,...},...},
684 :			path} => tyc
685 :			(*
686 :			* The following code needs to be rewritten !!! (ZHONG)
687 :
688 :			GENtyc{stamp=stamp, arity=arity, eq=eq, path=path,
689 :			kind=DATATYPE {index=index, members=map mapMb members,
690 :			lambdatyc = ref NONE}}
691 :			*)
692 :			| GENtyc{stamp, arity, eq, kind=ABSTRACT tc, path} =>
693 :			GENtyc{stamp=stamp, arity=arity, eq=eq, path=path,
694 :			kind=ABSTRACT (mapTc tc)}
695 :			| DEFtyc{stamp, strict, tyfun, path} =>
696 :			DEFtyc{stamp=stamp, strict=strict, tyfun=mapTf tyfun,
697 :			path=path}
698 :			| _ => tyc
699 :
700 :			and mapMb {tycname, stamp, arity, dcons, lambdatyc} =
701 :			{tycname=tycname, stamp=stamp, arity=arity,
702 :			dcons=(map mapDcons dcons), lambdatyc=ref NONE}
703 :
704 :			and mapDcons (x as {name, rep, domain=NONE}) = x
705 :			| mapDcons (x as {name, rep, domain=SOME ty}) =
706 :			{name=name, rep=rep, domain=SOME(mapTy ty)}
707 :
708 :			and mapTf (TYFUN{arity, body}) =
709 :			TYFUN{arity=arity, body=mapTy body}
710 :
711 :			in mapTy
712 :			end
713 :
714 :
715 :			(*
716 :			* Here, using a set implementation should suffice, however,
717 :			* I am using a binary dictionary instead. (ZHONG)
718 :			*)
719 :			local
720 :			structure TycSet = BinaryDict(struct type ord_key = ST.stamp
721 :			val cmpKey = ST.cmp
722 :			end)
723 :			in
724 :			type tycset = tycon TycSet.dict
725 :
726 :			val mkTycSet = TycSet.mkDict
727 :
728 :			fun addTycSet(tyc as GENtyc{stamp, ...}, tycset) =
729 :			TycSet.insert(tycset, stamp, tyc)
730 :			| addTycSet _ = bug "unexpected tycons in addTycSet"
731 :
732 :			fun inTycSet(tyc as GENtyc{stamp, ...}, tycset) =
733 :			(case TycSet.peek(tycset, stamp) of SOME _ => true | _ => false)
734 :			| inTycSet _ = false
735 :
736 :			fun filterSet(ty, tycs) =
737 :			let fun inList (a::r, tc) = if eqTycon(a, tc) then true else inList(r, tc)
738 :			| inList ([], tc) = false
739 :
740 :			fun pass1 (tc, tset) =
741 :			if inTycSet(tc, tycs) then
742 :			(if inList(tset, tc) then tset else tc::tset)
743 :			else tset
744 :			in foldTypeEntire pass1 (ty, [])
745 :			end
746 :			(*
747 :			val filterSet = fn x =>
748 :			Stats.doPhase(Stats.makePhase "Compiler 034 filterSet") filterSet x
749 :			*)
750 :
751 :			end (* local TycSet *)
752 :
753 :			(* The reformat function is called inside translate.sml to reformat
754 :			* a type abstraction packing inside PACKexp absyn. It is a hack. (ZHONG)
755 :			*)
756 :			fun reformat (ty, tycs, depth) =
757 :			let fun h ([], i, ks, ps, nts) = (rev ks, rev ps, rev nts)
758 :			| h ((tc as GENtyc{stamp, arity, eq,
759 :			kind=ABSTRACT itc, path})::rest, i, ks, ps, nts) =
760 :			let val tk = LT.tkc_int arity
761 :			val tps = TP_VAR{depth=depth, num=i, kind=tk}
762 :			val nkind = FLEXTYC tps
763 :			val ntc = GENtyc{stamp=stamp, arity=arity, eq=eq,
764 :			kind=nkind, path=path}
765 :			in h(rest, i+1, tk::ks, (TP_TYC itc)::ps, ntc::nts)
766 :			end
767 :			| h (_, _, _, _, _) = bug "non-abstract tycons seen in TU.reformat"
768 :
769 :			val (tks, tps, ntycs) = h(tycs, 0, [], [], [])
770 :
771 :			fun getTyc (foo, tc) =
772 :			let fun h(a::r, tc) = if eqTycon(a, tc) then a else h(r, tc)
773 :			| h([], tc) = foo tc
774 :			in h(ntycs, tc)
775 :			end
776 :
777 :			val nty = mapTypeEntire getTyc ty
778 :
779 :			in (nty, tks, tps)
780 :			end
781 :
782 :			val reformat = Stats.doPhase(Stats.makePhase "Compiler 047 reformat") reformat
783 :
784 :			fun dtSibling(n,tyc as GENtyc{kind=DATATYPE{index,stamps,freetycs,root,
785 :			family as {members,...}},...}) =
786 :			if n = index then tyc
787 :	monnier	106	else let val {tycname,arity,dcons,eq,lazyp,sign} = Vector.sub(members,n)
788 :	monnier	16	val stamp= Vector.sub(stamps,n)
789 :			in GENtyc{stamp=stamp,arity=arity,eq=eq,path=IP.IPATH[tycname],
790 :			kind=DATATYPE{index=n,stamps=stamps,freetycs=freetycs,
791 :			root=NONE (*!*),family=family}}
792 :			end
793 :			| dtSibling _ = bug "dtSibling"
794 :
795 :			(* NOTE: this only works (perhaps) for datatype declarations, but not
796 :			specifications. The reason: the root field is used to connect mutually
797 :			recursive datatype specifications together, its information cannot be
798 :			fully recovered in dtSibling. (ZHONG)
799 :			*)
800 :			fun extractDcons(tyc as GENtyc{kind=DATATYPE{index,stamps,freetycs,root,
801 :			family as {members,...}}, ...}
802 :			(* , sigContext,sigEntEnv *)) =
803 :	monnier	106	let val {dcons,sign,lazyp,...} = Vector.sub(members,index)
804 :	monnier	16	fun expandTyc(PATHtyc _) =
805 :			bug "expandTyc:PATHtyc" (* use expandTycon? *)
806 :			| expandTyc(RECtyc n) = dtSibling(n,tyc)
807 :			| expandTyc(FREEtyc n) =
808 :			((List.nth(freetycs,n)) handle _ =>
809 :			bug "unexpected freetycs in extractDcons")
810 :			| expandTyc tyc = tyc
811 :
812 :			fun expand ty = mapTypeFull expandTyc ty
813 :
814 :			fun mkDcon({name,rep,domain}) =
815 :	monnier	106	DATACON{name = name, rep = rep, sign = sign, lazyp = lazyp,
816 :	monnier	16	typ = dconType(tyc, Option.map expand domain),
817 :			const = case domain of NONE => true | _ => false}
818 :
819 :			in map mkDcon dcons
820 :			end
821 :			| extractDcons _ = bug "extractDcons"
822 :
823 :			fun mkStrict 0 = []
824 :	monnier	125	| mkStrict n = true :: mkStrict(n-1)
825 :	monnier	16
826 :			(* used in ElabSig for datatype replication specs, where the tyc arg
827 :			* is expected to be either a GENtyc/DATATYPE or a PATHtyc. *)
828 :			fun wrapDef(tyc as DEFtyc _,_) = tyc
829 :			| wrapDef(tyc,s) =
830 :			let val arity = tyconArity tyc
831 :			val name = tycName tyc
832 :			val args = boundargs arity
833 :			in DEFtyc{stamp=s,strict=mkStrict arity,path=IP.IPATH[name],
834 :			tyfun=TYFUN{arity=arity,body=CONty(tyc,args)}}
835 :			end
836 :
837 :			fun unWrapDef1(tyc as DEFtyc{tyfun=TYFUN{body=CONty(tyc',args),arity},...}) =
838 :			let fun formals((IBOUND i)::rest,j) = if i=j then formals(rest,j+1) else false
839 :			| formals(nil,_) = true
840 :			| formals _ = false
841 :			in if formals(args,0) then SOME tyc' else NONE
842 :			end
843 :			| unWrapDef1 tyc = NONE
844 :
845 :			fun unWrapDefStar tyc =
846 :			(case unWrapDef1 tyc
847 :			of SOME tyc' => unWrapDefStar tyc'
848 :			| NONE => tyc)
849 :
850 :			fun dummyTyGen () : unit -> Types.ty =
851 :			let val count = ref 0
852 :			fun next () = (count := !count + 1; !count)
853 :			fun nextTy () =
854 :			let val name = "X"^Int.toString(next())
855 :			in CONty(GENtyc{stamp = ST.special name,
856 :			path = IP.IPATH[S.tycSymbol name],
857 :			arity = 0, eq = ref NO,
858 :			kind = ABSTRACT BasicTypes.boolTycon},
859 :			[])
860 :			end
861 :			in nextTy
862 :			end
863 :
864 :			end (* local *)
865 :			end (* structure TypesUtil *)
866 :
867 :	monnier	93
868 :			(*
869 :	monnier	113	* $Log$
870 :	monnier	93	*)

---

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