clean up Types.Varianceabstract-new

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/abstract-new@13644 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

10 files changed, 67 insertions, 72 deletions

diff --git a/boot/ocamlc b/boot/ocamlc
index eb1f792519..d4784ab34b 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index 80eb55eab0..856571998b 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index 38e79434b7..62b97205f1 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 02e6c20fba..1d0257df7a 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -757,7 +757,7 @@ let rec generalize_expansive env var_level ty =
           abbrev := Mnil;
           List.iter2
             (fun v t ->
-              if Variance.(check may_weak v)
+              if Variance.(mem May_weak v)
               then generalize_contravariant env var_level t
               else generalize_expansive env var_level t)
             variance tyl
@@ -1694,7 +1694,7 @@ let occur_univar env ty =
             let td = Env.find_type p env in
             List.iter2
               (fun t v ->
-                if Variance.(check may_pos v || check may_neg v)
+                if Variance.(mem May_pos v || mem May_neg v)
                 then occur_rec bound t)
               tl td.type_variance
           with Not_found ->
@@ -1743,7 +1743,7 @@ let univars_escape env univar_pairs vl ty =
             let td = Env.find_type p env in
             List.iter2
               (fun t v ->
-                if Variance.(check may_pos v || check may_neg v) then occur t)
+                if Variance.(mem May_pos v || mem May_neg v) then occur t)
               tl td.type_variance
           with Not_found ->
             List.iter occur tl
@@ -2041,7 +2041,7 @@ and mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2 =
       if non_aliasable p1 decl then Format.eprintf "non_aliasable@."
       else Format.eprintf "aliasable@."; *)
       let inj =
-        try List.map Variance.(check inj) (Env.find_type p1 env).type_variance
+        try List.map Variance.(mem Inj) (Env.find_type p1 env).type_variance
         with Not_found -> List.map (fun _ -> false) tl1
       in
       List.iter2
@@ -2273,7 +2273,7 @@ and unify3 env t1 t1' t2 t2' =
             unify_list env tl1 tl2
           else
             let inj =
-              try List.map Variance.(check inj)
+              try List.map Variance.(mem Inj)
                     (Env.find_type p1 !env).type_variance
               with Not_found -> List.map (fun _ -> false) tl1
             in
@@ -2782,7 +2782,7 @@ let rec moregen inst_nongen var type_pairs env t1 t2 =
                 let decl = Env.find_type p1 env in
                 List.iter2
                   (fun v (t1, t2) ->
-                    let inv = Variance.(check may_pos v || check may_neg v) in
+                    let inv = Variance.(mem May_pos v || mem May_neg v) in
                     moregen inst_nongen (not inv) type_pairs env t1 t2)
                   decl.type_variance (List.combine tl1 tl2)
               with Not_found ->
@@ -3615,7 +3615,7 @@ let rec build_subtype env visited loops posi level t =
         let tl' =
           List.map2
             (fun v t ->
-              let (co,cn,_) = Variance.get_upper v in
+              let (co,cn) = Variance.get_upper v in
               if cn then
                 if co then (t, Unchanged)
                 else build_subtype env visited loops (not posi) level t
@@ -3769,7 +3769,7 @@ let rec subtype_rec env trace t1 t2 cstrs =
           let decl = Env.find_type p1 env in
           List.fold_left2
             (fun cstrs v (t1, t2) ->
-              let (co, cn, _) = Variance.get_upper v in
+              let (co, cn) = Variance.get_upper v in
               if co then
                 if cn then
                   (trace, newty2 t1.level (Ttuple[t1]),
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 6529497605..ed350d8866 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -260,7 +260,7 @@ let type_declarations ?(equality = false) env name decl1 id decl2 =
       (fun ty (v1,v2) ->
         let open Variance in
         let imp a b = not a || b in
-        let (co1,cn1,ct1) = get_upper v1 and (co2,cn2,ct2) = get_upper v2 in
+        let (co1,cn1) = get_upper v1 and (co2,cn2) = get_upper v2 in
         imp abstr (imp co1 co2 && imp cn1 cn2) &&
         (abstr || Btype.(is_Tvar (repr ty)) || co1 = co2 && cn1 = cn2) && 
         let (p1,n1,i1,j1) = get_lower v1 and (p2,n2,i2,j2) = get_lower v2 in
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 81046ffeb6..876d8ae5e6 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -739,8 +739,8 @@ let rec tree_of_type_decl id decl =
     let vari =
       List.map2
         (fun ty v ->
-          let (co,cn,_) = Variance.get_upper v in
-          let i = abstr' && Variance.(check inj v) in
+          let (co,cn) = Variance.get_upper v in
+          let i = abstr' && Variance.(mem Inj v) in
           if abstr || not (is_Tvar (repr ty))
           then (co,cn,i) else (true,true,i))
         decl.type_params decl.type_variance
@@ -941,7 +941,7 @@ let tree_of_class_params params =
   List.map (function Otyp_var (_, s) -> s | _ -> "?") tyl
 
 let class_variance =
-  List.map Variance.(fun v -> check may_pos v, check may_neg v)
+  List.map Variance.(fun v -> mem May_pos v, mem May_neg v)
 
 let tree_of_class_declaration id cl rs =
   let params = filter_params cl.cty_params in
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index c984d69210..7624f05767 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -492,16 +492,16 @@ let compute_variance env tvl vari ty =
     let vari' =
       try TypeMap.find ty !visited with Not_found -> Variance.null in
     if Variance.subset vari vari' then () else
-    let vari = Variance.lub vari vari' in
+    let vari = Variance.union vari vari' in
     visited := TypeMap.add ty vari !visited;
     let compute_same = compute_variance_rec vari in
     match ty.desc with
       Tarrow (_, ty1, ty2, _) ->
         let open Variance in
-        let v = exchange vari in
+        let v = conjugate vari in
         let v1 =
-          if check may_pos v || check may_neg v
-          then set may_weak true v else v
+          if mem May_pos v || mem May_neg v
+          then set May_weak true v else v
         in
         compute_variance_rec v1 ty1;
         compute_same ty2
@@ -512,24 +512,24 @@ let compute_variance env tvl vari ty =
         if tl = [] then () else begin
           try
             let decl = Env.find_type path env in
-            let cvari f = check f vari in
+            let cvari f = mem f vari in
             List.iter2
               (fun ty v ->
-                let cv f = check f v in
+                let cv f = mem f v in
                 let strict =
-                  cvari inv && cv inj || (cvari pos || cvari neg) && cv inv
+                  cvari Inv && cv Inj || (cvari Pos || cvari Neg) && cv Inv
                 in
                 if strict then compute_variance_rec full ty else
-                let p1 = glb v vari
-                and n1 = glb v (exchange vari) in
+                let p1 = inter v vari
+                and n1 = inter v (conjugate vari) in
                 let v1 = 
-                  lub (glb covariant (lub p1 (exchange p1)))
-                    (glb (exchange covariant) (lub n1 (exchange n1)))
+                  union (inter covariant (union p1 (conjugate p1)))
+                    (inter (conjugate covariant) (union n1 (conjugate n1)))
                 and weak =
-                  cvari may_weak && (cv may_pos || cv may_neg) ||
-                  (cvari may_pos || cvari may_neg) && cv may_weak
+                  cvari May_weak && (cv May_pos || cv May_neg) ||
+                  (cvari May_pos || cvari May_neg) && cv May_weak
                 in
-                let v2 = set may_weak weak v1 in
+                let v2 = set May_weak weak v1 in
                 compute_variance_rec v2 ty)
               tl decl.type_variance
           with Not_found ->
@@ -559,14 +559,14 @@ let compute_variance env tvl vari ty =
     | Tvar _ | Tnil | Tlink _ | Tunivar _ -> ()
     | Tpackage (_, _, tyl) ->
         let v =
-          Variance.(if check pos vari || check neg vari then full else may_inv)
+          Variance.(if mem Pos vari || mem Neg vari then full else may_inv)
         in
         List.iter (compute_variance_rec v) tyl
   in
   compute_variance_rec vari ty;
   List.iter
     (fun (ty, var) ->
-      try var := Variance.lub !var (TypeMap.find ty !visited)
+      try var := Variance.union !var (TypeMap.find ty !visited)
       with Not_found -> ())
     tvl
 
@@ -586,9 +586,9 @@ let whole_type decl =
 
 let make p n i =
   let open Variance in
-  set may_pos p (set may_neg n (set may_weak n (set inj i null)))
+  set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
 
-let compute_variance_type env chk (required, loc) decl tyl =
+let compute_variance_type env check (required, loc) decl tyl =
   (* Requirements *)
   let required =
     List.map (fun (c,n,i) -> if c || n then (c,n,i) else (true,true,i))
@@ -598,7 +598,7 @@ let compute_variance_type env chk (required, loc) decl tyl =
   let params = List.map Btype.repr decl.type_params in
   let tvl0 = List.map make_variance params in
   let args = Btype.newgenty (Ttuple params) in
-  let fvl = if chk then Ctype.free_variables args else [] in
+  let fvl = if check then Ctype.free_variables args else [] in
   let fvl = List.filter (fun v -> not (List.memq v params)) fvl in
   let tvl1 = List.map make_variance fvl in
   let tvl2 = List.map make_variance fvl in
@@ -609,13 +609,13 @@ let compute_variance_type env chk (required, loc) decl tyl =
     (fun (cn,ty) ->
       compute_variance env tvl (if cn then full else covariant) ty)
     tyl;
-  if chk then begin
+  if check then begin
     (* Check variance of parameters *)
     let pos = ref 0 in
     List.iter2
       (fun (ty, var) (c, n, i) ->
         incr pos;
-        let (co,cn,_) = get_upper !var and ij = check inj !var in
+        let (co,cn) = get_upper !var and ij = mem Inj !var in
         if Btype.is_Tvar ty && (co && not c || cn && not n || not ij && i)
         then raise (Error(loc, Bad_variance (!pos, (co,cn,ij), (c,n,i)))))
       tvl0 required;
@@ -624,12 +624,12 @@ let compute_variance_type env chk (required, loc) decl tyl =
       (fun (p,n,i) ty ->
         let v =
           if Btype.is_Tvar ty then full else
-          if p then if n then full else covariant else exchange covariant in
+          if p then if n then full else covariant else conjugate covariant in
         compute_variance env tvl2 v ty)
       required params;
     List.iter2
       (fun (ty, v1) (_, v2) ->
-        let (c1,n1,_) = get_upper !v1 and (c2,n2,_,i2) = get_lower !v2 in
+        let (c1,n1) = get_upper !v1 and (c2,n2,_,i2) = get_lower !v2 in
         if c1 && not c2 || n1 && not n2 then
         let code = if not i2 then -2 else if c2 || n2 then -1 else -3 in
         raise (Error (loc, Bad_variance (code, (c1,n1,false), (c2,n2,false)))))
@@ -644,15 +644,16 @@ let compute_variance_type env chk (required, loc) decl tyl =
         if tr = Type_private || not (Btype.is_Tvar ty) then (p, n) (* set *)
         else (false, false) (* only check *)
       and i = concr  || i && tr = Type_private in
-      let v = lub v (make p n i) in
+      let v = union v (make p n i) in
       let v =
         if not concr then v else
-        if check pos v && check neg v then full else
+        if mem Pos v && mem Neg v then full else
         if Btype.is_Tvar ty then v else
-        lub v (if p then if n then full else covariant else exchange covariant)
+        union v
+          (if p then if n then full else covariant else conjugate covariant)
       in
       if decl.type_kind = Type_abstract && tr = Type_public then v else
-      set may_weak (check may_neg v) v)
+      set May_weak (mem May_neg v) v)
     tvl0 required
 
 let add_false = List.map (fun ty -> false, ty)
@@ -737,7 +738,7 @@ let rec compute_variance_fixpoint env decls required variances =
       new_decls required
   in
   let new_variances =
-    List.map2 (List.map2 Variance.lub) new_variances variances in
+    List.map2 (List.map2 Variance.union) new_variances variances in
   if new_variances <> variances then
     compute_variance_fixpoint env decls required new_variances
   else begin
diff --git a/typing/typemod.ml b/typing/typemod.ml
index de759f7433..510a099141 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -116,7 +116,7 @@ let sig_item desc typ env loc = {
 
 let make p n i =
   let open Variance in
-  set may_pos p (set may_neg n (set may_weak n (set inj i null)))
+  set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
 
 let merge_constraint initial_env loc  sg lid constr =
   let real_id = ref None in
diff --git a/typing/types.ml b/typing/types.ml
index b00b41faf6..7e679301d7 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -142,29 +142,30 @@ and record_representation =
 
 module Variance = struct
   type t = int
-  type f = int
-  let lub v1 v2 = v1 lor v2
-  let glb v1 v2 = v1 land v2
+  type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv
+  let single = function
+    | May_pos -> 1
+    | May_neg -> 2
+    | May_weak -> 4
+    | Inj -> 8
+    | Pos -> 16
+    | Neg -> 32
+    | Inv -> 64
+  let union v1 v2 = v1 lor v2
+  let inter v1 v2 = v1 land v2
   let subset v1 v2 = (v1 land v2 = v1)
-  let set f b v =
-    if b then v lor f else  v land (lnot f)
-  let check = subset
-  let may_pos = 1
-  let may_neg = 2
-  let may_weak = 4
-  let inj = 8
-  let pos = 16
-  let neg = 32
-  let inv = 64
+  let set x b v =
+    if b then v lor single x else  v land (lnot (single x))
+  let mem x = subset (single x)
   let null = 0
   let may_inv = 7
   let full = 127
-  let covariant = may_pos lor pos lor inj
+  let covariant = single May_pos lor single Pos lor single Inj
   let swap f1 f2 v =
-    let v' = set f1 (check f2 v) v in set f2 (check f1 v) v'
-  let exchange v = swap may_pos may_neg (swap pos neg v)
-  let get_upper v = (check may_pos v, check may_neg v, check may_weak v)
-  let get_lower v = (check pos v, check neg v, check inv v, check inj v)
+    let v' = set f1 (mem f2 v) v in set f2 (mem f1 v) v'
+  let conjugate v = swap May_pos May_neg (swap Pos Neg v)
+  let get_upper v = (mem May_pos v, mem May_neg v)
+  let get_lower v = (mem Pos v, mem Neg v, mem Inv v, mem Inj v)
 end 
 
 (* Type definitions *)
diff --git a/typing/types.mli b/typing/types.mli
index 7bd3766b1d..43e19ad9ac 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -139,25 +139,18 @@ and record_representation =
 
 module Variance : sig
   type t
+  type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv
   val null : t                          (* no occurence *)
   val full : t                          (* strictly invariant *)
   val covariant : t                     (* strictly covariant *)
   val may_inv : t                       (* maybe invariant *)
-  val lub : t -> t -> t
-  val glb : t -> t -> t
+  val union  : t -> t -> t
+  val inter  : t -> t -> t
   val subset : t -> t -> bool
-  type f
   val set : f -> bool -> t -> t
-  val check : f -> t -> bool
-  val exchange : t -> t                 (* exchange positive and negative *)
-  val may_pos : f
-  val may_neg : f
-  val may_weak : f
-  val inj : f
-  val pos : f
-  val neg : f
-  val inv : f
-  val get_upper : t -> bool * bool * bool   (* may_pos, may_neg, may_weak *)
+  val mem : f -> t -> bool
+  val conjugate : t -> t                (* exchange positive and negative *)
+  val get_upper : t -> bool * bool                  (* may_pos, may_neg   *)
   val get_lower : t -> bool * bool * bool * bool    (* pos, neg, inv, inj *)
 end