![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to overload.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / src / typing|
Return to overload.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / typing |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: (* overload.sml *)
3:
4: structure Overload : OVERLOAD = struct
5:
6: structure Basics = Basics
7:
8: local open Basics TypesUtil PrintUtil ErrorMsg BasicTypes
9: PrintType
10: in
11:
12: type subst = (tyvar * tvkind) list
13:
14: exception SoftUnify
15:
16: fun copyScheme (tyfun as TYFUN{arity,...}) : ty * ty =
17: let val tvs = typeArgs arity
18: in (applyTyfun(tyfun,tvs),
19: if arity>1 then tupleTy tvs else hd tvs)
20: end
21:
22: fun rollBack subst =
23: let fun loop (nil,trace) = trace
24: | loop (((tv as ref kind),oldkind)::subst,trace) =
25: (tv := oldkind;
26: loop(subst,(tv,kind)::trace))
27: in loop(subst,nil)
28: end
29:
30: fun redoSubst nil = ()
31: | redoSubst ((tv,INSTANTIATED ty)::rest) =
32: (instantiate(tv, ty); redoSubst rest)
33: | redoSubst (_) = impossible "Overload--redoSubst"
34:
35: fun softUnify(ty1: ty, ty2: ty): subst =
36: let val subst: subst ref = ref nil
37: fun softInst(tv as ref kind: tyvar, ty: ty) : unit =
38: let fun scan(ty: ty) : unit = (* simple occurrence check *)
39: case ty
40: of VARty(tv') =>
41: if eqTyvar(tv, tv') then raise SoftUnify else ()
42: | CONty(_, args) => app scan args
43: | FLEXRECORDty(ref(OPEN fields)) =>
44: app (fn (_,ty') => scan ty') fields
45: | ty => () (* propagate error *)
46: in case kind
47: of META _ => ()
48: | _ => raise SoftUnify;
49: scan ty;
50: subst := (tv, kind)::(!subst);
51: tv := INSTANTIATED ty
52: end
53:
54: fun unify(ty1: ty, ty2: ty): unit =
55: let val ty1 = prune ty1
56: and ty2 = prune ty2
57: in case (ty1,ty2)
58: of (VARty(tv1),VARty(tv2)) =>
59: if eqTyvar(tv1,tv2) then () else softInst(tv1,ty2)
60: | (VARty(tv1),_) => softInst(tv1,ty2)
61: | (_,VARty(tv2)) => softInst(tv2,ty1)
62: | (CONty(ref tycon1, args1), CONty(ref tycon2, args2)) =>
63: if eqTycon(tycon1, tycon2)
64: then unifyLists(args1, args2)
65: else (unify(reduceType ty1, ty2)
66: handle ReduceType =>
67: unify(ty1, reduceType ty2)
68: handle ReduceType => raise SoftUnify)
69: | (ERRORty, _) => () (* propagate error *)
70: | (_, ERRORty) => () (* propagate error *)
71: | _ => raise SoftUnify
72: end
73:
74: and unifyLists([],[]) = ()
75: | unifyLists(ty1::rest1, ty2::rest2) =
76: (unify(ty1,ty2); unifyLists(rest1,rest2))
77: | unifyLists(_) = raise SoftUnify
78:
79: in unify(ty1,ty2)
80: handle SoftUnify => (rollBack(!subst); raise SoftUnify);
81: !subst
82: end
83:
84:
85: exception Overld
86:
87: datatype stack
88: = EMPTY
89: | PUSH of var ref * ty * stack
90: | MARK of stack
91:
92: val overloaded = ref EMPTY (* stack of currently unresolved overloaded vars *)
93:
94: fun resetOverloaded () = overloaded := EMPTY
95:
96: fun markOverloaded () = overloaded := MARK(!overloaded)
97:
98: fun pushOverloaded (refvar as ref(OVLDvar{options,scheme,...}) : var ref) =
99: let val (scheme',ty) = copyScheme(scheme)
100: in overloaded := PUSH(refvar,ty,!overloaded);
101: scheme'
102: end
103: | pushOverloaded _ = impossible "overload.1"
104:
105: fun resolveOVLDvar(rv as ref(OVLDvar{name,options,...}),context) =
106: (let fun findFirst({indicator, variant}::rest) =
107: ((softUnify(applyPoly(indicator,0,infinity), context), variant, rest)
108: handle SoftUnify => findFirst(rest))
109: | findFirst(nil) =
110: (complain("overloaded variable \"" ^ Symbol.name(name) ^
111: "\" not defined at type:");
112: print " ";
113: resetPrintType(); printType(context); newline();
114: raise Overld)
115: fun findSecond({indicator, variant}::rest) =
116: ((rollBack(softUnify(applyPoly(indicator,0,infinity), context));
117: complain("overloaded variable \"" ^ Symbol.name(name) ^
118: "\" cannot be resolved");
119: raise Overld)
120: handle SoftUnify => findSecond(rest))
121: | findSecond(nil) = ()
122: val (subst,var,restOptions) = findFirst(!options)
123: val subst = rollBack subst
124: in findSecond(restOptions);
125: redoSubst subst;
126: rv := var
127: end handle Overld => ())
128: | resolveOVLDvar _ = impossible "overload.2"
129:
130: fun resolveOverloaded () =
131: let fun loop EMPTY = ()
132: | loop(MARK(s)) = (overloaded := s)
133: | loop(PUSH(refvar,context,s)) =
134: (resolveOVLDvar(refvar,context); loop(s))
135: in loop(!overloaded)
136: end
137:
138: end (* local *)
139:
140: end (* structure Overload *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.