Return to overload.sml CVS log

Up to [Research Unix] / researchv10no / cmd / sml / src / typing

Annotation of researchv10no/cmd/sml/src/typing/overload.sml, revision 1.1

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.