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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 651 - (view) (download)

1 : monnier 249 (* COPYRIGHT 1996 AT&T Bell Laboratories. *)
2 :     (* overload.sml *)
3 :    
4 :     signature OVERLOAD =
5 :     sig
6 :     val resetOverloaded : unit -> unit
7 :     val pushOverloaded : VarCon.var ref * ErrorMsg.complainer -> Types.ty
8 :     val resolveOverloaded : StaticEnv.staticEnv -> unit
9 :     end (* signature OVERLOAD *)
10 :    
11 :     structure Overload : OVERLOAD =
12 :     struct
13 :    
14 :     local
15 :     structure EM = ErrorMsg
16 :     structure BT = BasicTypes
17 :     structure TU = TypesUtil
18 :     structure ED = ElabDebug
19 :     open VarCon Types
20 :     in
21 :    
22 :     (* debugging *)
23 :     val say = Control.Print.say
24 :     val debugging = ref false
25 :     fun debugmsg (msg: string) = if !debugging then (say msg; say "\n") else ()
26 :     fun bug msg = EM.impossible("Overload: "^msg)
27 :    
28 :     type subst = (tyvar * tvKind) list
29 :    
30 :     exception SoftUnify
31 :    
32 :     fun copyScheme (tyfun as TYFUN{arity,...}) : ty * ty =
33 :     let fun typeArgs n = if n>0 then TU.mkSCHEMEty() :: typeArgs(n-1) else []
34 :     val tvs = typeArgs arity
35 :     in (TU.applyTyfun(tyfun,tvs),if arity>1 then BT.tupleTy tvs else hd tvs)
36 :     end
37 :    
38 :     fun rollBack subst =
39 :     let fun loop (nil,trace) = trace
40 :     | loop (((tv as ref kind),oldkind)::subst,trace) =
41 :     (tv := oldkind;
42 :     loop(subst,(tv,kind)::trace))
43 :     in loop(subst,nil)
44 :     end
45 :    
46 :     fun redoSubst nil = ()
47 :     | redoSubst ((tv as ref(OPEN{kind=META, ...}),INSTANTIATED ty)::rest) =
48 :     (tv := INSTANTIATED ty; redoSubst rest)
49 :     | redoSubst (_) = bug "Overload--redoSubst"
50 :    
51 :     fun softUnify(ty1: ty, ty2: ty): unit =
52 :     let val subst: subst ref = ref nil
53 :     fun softInst(tv as ref info: tyvar, ty: ty) : unit =
54 :     let fun scan eq (ty: ty) : unit = (* simple occurrence check *)
55 :     case ty
56 :     of VARty(tv') =>
57 :     if TU.eqTyvar(tv, tv')
58 :     then raise SoftUnify
59 :     else (case tv'
60 :     of ref(OPEN{kind=FLEX fields,...}) =>
61 :     (* DBM: can this happen? *)
62 :     app (fn (_,ty') => scan eq ty') fields
63 :     | _ => ())
64 :     | CONty(tycon, args) =>
65 :     (* check equality property if necessary *)
66 :     if eq
67 :     then (case tycon
68 :     of DEFtyc _ =>
69 :     scan eq (TU.headReduceType ty)
70 : blume 587 | GENtyc gt =>
71 :     (case ! (#eq gt)
72 : monnier 249 of YES => app (scan eq) args
73 :     | OBJ => app (scan false) args
74 :     (* won't happen *)
75 :     | _ => raise SoftUnify)
76 :     | _ => raise SoftUnify) (* won't happen? *)
77 :     else app (scan eq) args
78 :     | ty => () (* propagate error *)
79 :     in case info
80 :     of (SCHEME eq | OPEN{kind=META,eq,...}) =>
81 :     (scan eq ty;
82 :     subst := (tv, info)::(!subst);
83 :     tv := INSTANTIATED ty)
84 :     | _ => raise SoftUnify
85 :     end
86 :    
87 :     fun unify(ty1: ty, ty2: ty): unit =
88 :     let val ty1 = TU.prune ty1
89 :     and ty2 = TU.prune ty2
90 :     in case (ty1,ty2)
91 :     of (WILDCARDty, _) => () (* wildcards unify with anything *)
92 :     | (_, WILDCARDty) => () (* wildcards unify with anything *)
93 :     | (VARty(tv1),VARty(tv2)) =>
94 :     if TU.eqTyvar(tv1,tv2) then () else softInst(tv1,ty2)
95 :     | (VARty(tv1),_) => softInst(tv1,ty2)
96 :     | (_,VARty(tv2)) => softInst(tv2,ty1)
97 :     | (CONty(tycon1, args1), CONty(tycon2, args2)) =>
98 :     if TU.eqTycon(tycon1, tycon2)
99 :     then unifyLists(args1, args2)
100 :     else (unify(TU.reduceType ty1, ty2)
101 :     handle TU.ReduceType =>
102 :     unify(ty1, TU.reduceType ty2)
103 :     handle TU.ReduceType => raise SoftUnify)
104 :     | _ => raise SoftUnify
105 :     end
106 :    
107 :     and unifyLists([],[]) = ()
108 :     | unifyLists(ty1::rest1, ty2::rest2) =
109 :     (unify(ty1,ty2); unifyLists(rest1,rest2))
110 :     | unifyLists(_) = raise SoftUnify
111 :    
112 :     in unify(ty1,ty2)
113 :     handle SoftUnify => (rollBack(!subst); raise SoftUnify)
114 :     end
115 :    
116 :     exception Overld
117 :    
118 :    
119 :     (* overloaded functions *)
120 :    
121 :     val overloaded = ref (nil: (var ref * ErrorMsg.complainer * ty) list)
122 :    
123 :     fun resetOverloaded () = overloaded := nil
124 :    
125 :     fun pushOverloaded (refvar as ref(OVLDvar{options,scheme,...}), err) =
126 :     let val (scheme',ty) = copyScheme(scheme)
127 :     in overloaded := (refvar,err,ty) :: !overloaded;
128 :     scheme'
129 :     end
130 :     | pushOverloaded _ = bug "overload.1"
131 :    
132 :     (* this resolveOverloaded implements defaulting behavior -- if more
133 :     * than one variant matches the context type, the first one matching
134 :     * (which will always be the first variant) is used as the default *)
135 :     fun resolveOverloaded env =
136 :     let fun resolveOVLDvar(rv as ref(OVLDvar{name,options,...}),err,context) =
137 :     let fun firstMatch({indicator, variant}::rest) =
138 :     let val (nty,_) = TU.instantiatePoly indicator
139 :     in (softUnify(nty, context); rv := variant)
140 :     handle SoftUnify => firstMatch(rest)
141 :     end
142 :     | firstMatch(nil) =
143 :     (err EM.COMPLAIN "overloaded variable not defined at type"
144 :     (fn ppstrm =>
145 :     (PPType.resetPPType();
146 :     PrettyPrint.add_newline ppstrm;
147 :     PrettyPrint.add_string ppstrm "symbol: ";
148 :     PPUtil.ppSym ppstrm name;
149 :     PrettyPrint.add_newline ppstrm;
150 :     PrettyPrint.add_string ppstrm "type: ";
151 :     PPType.ppType env ppstrm context));
152 :     ())
153 :    
154 :     in firstMatch(!options)
155 :     end
156 :     | resolveOVLDvar _ = bug "overload.2"
157 :    
158 :     in app resolveOVLDvar (!overloaded);
159 :     overloaded := nil
160 :     end
161 :    
162 :     end (* local *)
163 :     end (* structure Overload *)
164 :    

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