enrich variant type syntaxvariants303

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

8 files changed, 56 insertions, 43 deletions

diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index c81d744ef5..57fad9ad70 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -127,7 +127,7 @@ let filter_matrix matcher pss =
   let rec filter_rec = function
     | (p::ps)::rem ->
         begin match p.pat_desc with
-        | Tpat_or (p1,p2) ->
+        | Tpat_or (p1,p2,_) ->
             filter_rec ((p1::ps)::(p2::ps)::rem)
         | Tpat_alias (p,_) ->
             filter_rec ((p::ps)::rem)
@@ -203,7 +203,7 @@ let filter_ctx q ctx =
   let rec filter_rec = function
     | ({right=p::ps} as l)::rem ->
         begin match p.pat_desc with
-        | Tpat_or (p1,p2) ->
+        | Tpat_or (p1,p2,_) ->
             filter_rec ({l with right=p1::ps}::{l with right=p2::ps}::rem)
         | Tpat_alias (p,_) ->
             filter_rec ({l with right=p::ps}::rem)
@@ -477,7 +477,7 @@ let up_ok (ps,act_p) l =
 exception Same
 
 let rec what_is_or = function
-  | {pat_desc = Tpat_or (p,_)} -> what_is_or p
+  | {pat_desc = Tpat_or (p,_,_)} -> what_is_or p
   | {pat_desc = (Tpat_alias (p,_))} -> what_is_or p        
   | {pat_desc=(Tpat_var _|Tpat_any)} -> fatal_error "Matching.what_is_or"
   | p -> p
@@ -501,8 +501,8 @@ let simplify_or p =
         with
         | Var q -> raise (Var {p with pat_desc = Tpat_alias (q,id)})
         end
-    | {pat_desc = Tpat_or (p1,p2)} ->
-        {p with pat_desc = Tpat_or (simpl_rec p1, simpl_rec p2)}
+    | {pat_desc = Tpat_or (p1,p2,_)} ->
+        {p with pat_desc = Tpat_or (simpl_rec p1, simpl_rec p2, None)}
     | {pat_desc = Tpat_record lbls} ->
         let all_lbls = all_record_args lbls in
         {p with pat_desc=Tpat_record all_lbls}        
@@ -540,10 +540,10 @@ let simplify_matching m = match m.args with
               record_ex_pat full_pat ;
               (full_pat::patl,action)::
               simplify rem
-          | Tpat_or (_,_) ->
+          | Tpat_or _ ->
               let pat_simple  = simplify_or pat in
               begin match pat_simple.pat_desc with
-              | Tpat_or (_,_) ->
+              | Tpat_or _ ->
                   let ex_pat = what_is_or pat_simple in
                   record_ex_pat ex_pat ;
                   (pat_simple :: patl, action) ::
@@ -611,7 +611,7 @@ let rec extract_vars r p = match p.pat_desc with
 | Tpat_array pats ->
     List.fold_left extract_vars r pats
 | Tpat_variant (_,Some p, _) -> extract_vars r p
-| Tpat_or (p,_) -> extract_vars r p
+| Tpat_or (p,_,_) -> extract_vars r p
 | Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> r
 
 exception Cannot_flatten
@@ -628,7 +628,7 @@ let mk_alpha_env arg aliases ids =
     ids
 
 let rec explode_or_pat arg patl mk_action rem vars aliases = function
-  | {pat_desc = Tpat_or (p1,p2)} ->
+  | {pat_desc = Tpat_or (p1,p2,_)} ->
       explode_or_pat
         arg patl mk_action
         (explode_or_pat arg patl mk_action rem vars aliases p2)
@@ -661,7 +661,7 @@ let compile_or argo cl clor al def = match clor with
       to_catch = []}
 | _  ->
     let rec do_cases = function
-      | ({pat_desc=Tpat_or (_,_)} as orp::patl, action)::rem ->
+      | ({pat_desc=Tpat_or _} as orp::patl, action)::rem ->
           let others,rem = get_equiv orp rem in          
           let orpm =
             {cases =
@@ -757,7 +757,7 @@ let all_vars _ = false
 *)
 
 let is_or p = match p.pat_desc with
-| Tpat_or (_,_) -> true
+| Tpat_or _ -> true
 | _ -> false
 
 (* Conditions for appending to the Or matrix *)
@@ -767,7 +767,7 @@ and condb act ps qs =  not (is_guarded act) && Parmatch.le_pats qs ps
 let or_ok p ps l =
   List.for_all
     (function
-      | ({pat_desc=Tpat_or (_,_)} as q::qs,act) ->
+      | ({pat_desc=Tpat_or _} as q::qs,act) ->
           conda p q || condb act ps qs
       | _ -> true)
     l
@@ -1510,11 +1510,11 @@ let rec list_as_pat = function
   | [] -> fatal_error "Matching.list_as_pat"
   | [pat] -> pat
   | pat::rem ->
-      {pat with pat_desc = Tpat_or (pat,list_as_pat rem)}
+      {pat with pat_desc = Tpat_or (pat,list_as_pat rem,None)}
 
 
 let rec pat_as_list k = function
-  | {pat_desc=Tpat_or (p1,p2)} ->
+  | {pat_desc=Tpat_or (p1,p2,_)} ->
       pat_as_list (pat_as_list k p2) p1
   | p -> p::k
 
@@ -1522,7 +1522,7 @@ let rec pat_as_list k = function
 exception All
 
 let rec extract_pat seen k p = match p.pat_desc with
-| Tpat_or (p1,p2) ->
+| Tpat_or (p1,p2,_) ->
     let k1,seen1 = extract_pat seen k p1 in
     extract_pat seen1 k1 p2
 | Tpat_alias (p,_) ->
@@ -2175,7 +2175,7 @@ let flatten_pattern size p =
 let rec flatten_pat_line size p k = match p.pat_desc with
 | Tpat_any ->  omegas size::k
 | Tpat_tuple args -> args::k
-| Tpat_or (p1,p2) ->
+| Tpat_or (p1,p2,_) ->
     flatten_pat_line size p1 (flatten_pat_line size p2 k)
 | _ -> fatal_error "Matching.flatten_pat_line"
 
diff --git a/camlp4/camlp4/ast2pt.ml b/camlp4/camlp4/ast2pt.ml
index 0bc2e445af..bfeac3f708 100644
--- a/camlp4/camlp4/ast2pt.ml
+++ b/camlp4/camlp4/ast2pt.ml
@@ -170,12 +170,13 @@ value rec ctyp =
   | TyTup loc tl -> mktyp loc (Ptyp_tuple (List.map ctyp tl))
   | TyUid loc s -> mktyp loc (Ptyp_constr (lident s) [])
   | TyVrn loc catl ool ->
-      let catl = List.map (fun (c, a, t) -> (c, a, List.map ctyp t)) catl in
+      let catl =
+        List.map (fun (c, a, t) -> Rtag c a (List.map ctyp t)) catl in
       let (clos, sl) =
         match ool with
-        [ None -> (True, List.map (fun (c, _, _) -> c) catl)
-        | Some None -> (False, List.map (fun (c, _, _) -> c) catl)
-        | Some (Some (clos, sl)) -> (clos, sl) ]
+        [ None -> (True, None)
+        | Some None -> (False, None)
+        | Some (Some (clos, sl)) -> (clos, Some sl) ]
       in
       mktyp loc (Ptyp_variant catl clos sl)
   | TyXnd loc c _ ->
diff --git a/camlp4/ocaml_src/camlp4/ast2pt.ml b/camlp4/ocaml_src/camlp4/ast2pt.ml
index 5198f3afaf..b613ef11f6 100644
--- a/camlp4/ocaml_src/camlp4/ast2pt.ml
+++ b/camlp4/ocaml_src/camlp4/ast2pt.ml
@@ -169,12 +169,13 @@ let rec ctyp =
   | TyTup (loc, tl) -> mktyp loc (Ptyp_tuple (List.map ctyp tl))
   | TyUid (loc, s) -> mktyp loc (Ptyp_constr (lident s, []))
   | TyVrn (loc, catl, ool) ->
-      let catl = List.map (fun (c, a, t) -> c, a, List.map ctyp t) catl in
+      let catl =
+        List.map (fun (c, a, t) -> Rtag(c, a, List.map ctyp t)) catl in
       let (clos, sl) =
         match ool with
-          None -> true, List.map (fun (c, _, _) -> c) catl
-        | Some None -> false, List.map (fun (c, _, _) -> c) catl
-        | Some (Some (clos, sl)) -> clos, sl
+          None -> true, None
+        | Some None -> false, None
+        | Some (Some (clos, sl)) -> clos, Some sl
       in
       mktyp loc (Ptyp_variant (catl, clos, sl))
   | TyXnd (loc, c, _) ->
diff --git a/camlp4/top/rprint.ml b/camlp4/top/rprint.ml
index 256e5c86d4..4b8ceab149 100644
--- a/camlp4/top/rprint.ml
+++ b/camlp4/top/rprint.ml
@@ -147,22 +147,23 @@ and print_simple_out_type ppf =
         [ None | Some [] -> ()
         | Some l -> fprintf ppf "@;<1 -2>> @[<hov>%a@]" pr_present l ]
       in
+      let print_fields ppf = fun
+        [ Ovar_fields fields ->
+            print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ")
+              ppf fields
+        | Ovar_name id tyl ->
+            fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id ]
+      in
       fprintf ppf "%s[|%s@[<hv>@[<hv>%a@]%a|]@]" (if non_gen then "_" else "")
         (if closed then if tags = None then " " else "< "
          else if tags = None then "> "
          else "? ")
-        (print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| "))
-        row_fields print_present tags
+        print_fields row_fields print_present tags
   | Otyp_object fields rest ->
       fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
-  | Otyp_class ng id tyl tags ->
-      let print_present ppf =
-        fun
-        [ [] -> ()
-        | l -> fprintf ppf "@[<hov>[>%a@]" pr_present l ]
-      in
-      fprintf ppf "@[%a%s#%a%a@]" print_typargs tyl (if ng then "_" else "")
-        print_ident id print_present tags
+  | Otyp_class ng id tyl ->
+      fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "")
+        print_ident id
   | Otyp_manifest ty1 ty2 ->
       fprintf ppf "@[<2>%a ==@ %a@]" print_out_type ty1 print_out_type ty2
   | Otyp_sum constrs ->
diff --git a/otherlibs/labltk/browser/main.ml b/otherlibs/labltk/browser/main.ml
index 0379060b43..d828122448 100644
--- a/otherlibs/labltk/browser/main.ml
+++ b/otherlibs/labltk/browser/main.ml
@@ -35,6 +35,7 @@ let _ =
       "<flags>  Enable or disable warnings according to <flags>:\n\
         \032    A/a enable/disable all warnings\n\
         \032    C/c enable/disable suspicious comment\n\
+        \032    D/d enable/disable deprecated features\n\
         \032    F/f enable/disable partially applied function\n\
         \032    L/l enable/disable labels omitted in application\n\
         \032    M/m enable/disable overriden method\n\
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index d780385d8a..674864eae5 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -104,8 +104,11 @@ let rec search_pos_type t ~pos ~env =
     Ptyp_any
   | Ptyp_var _ -> ()
   | Ptyp_variant(tl, _, _) ->
-      List.iter tl
-        ~f:(fun (_,_,tl) -> List.iter tl ~f:(search_pos_type ~pos ~env))
+      List.iter tl ~f:
+        begin function
+            Rtag (_,_,tl) -> List.iter tl ~f:(search_pos_type ~pos ~env)
+          | Rinherit st -> search_pos_type ~pos ~env st
+        end
   | Ptyp_arrow (_, t1, t2) ->
       search_pos_type t1 ~pos ~env;
       search_pos_type t2 ~pos ~env
@@ -806,8 +809,10 @@ and search_pos_pat ~pos ~env pat =
       List.iter l ~f:(fun (_, pat) -> search_pos_pat pat ~pos ~env)
   | Tpat_array l ->
       List.iter l ~f:(search_pos_pat ~pos ~env)
-  | Tpat_or (a, b) ->
+  | Tpat_or (a, b, None) ->
       search_pos_pat a ~pos ~env; search_pos_pat b ~pos ~env
+  | Tpat_or (_, _, Some _) ->
+      ()
   end;
   add_found_str (`Exp(`Pat, pat.pat_type)) ~env ~loc:pat.pat_loc
   end
diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml
index ca51bafcf9..91b4c8647e 100644
--- a/otherlibs/labltk/compiler/compile.ml
+++ b/otherlibs/labltk/compiler/compile.ml
@@ -153,7 +153,7 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
           with
             Not_found -> prerr_endline ("ppMLtype " ^ s ^ " ?"); s
           else if not def && List.length typdef.constructors > 1 then
-            "#" ^ s
+            "[< " ^ s ^ "]"
           else s
         else s
       with Not_found -> s
@@ -448,8 +448,9 @@ let rec converterCAMLtoTK ~context_widget argname ty =
        name ^ args
  |  Subtype (s, s') ->
        let name = "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " " in
-       let args = if safetype then "(" ^ argname ^ " : #" ^ s' ^ "_" ^ s ^ ")"
-                  else argname
+       let args =
+         if safetype then "(" ^ argname ^ " : [< " ^ s' ^ "_" ^ s ^ "])"
+                     else argname
        in
        let args = 
            if requires_widget_context s then context_widget ^ " " ^ args
@@ -580,8 +581,8 @@ let write_CAMLtoTK ~w ~def:typdef ?safetype:(st = true) name =
         "dummy" in
     if st then begin
       w " : ";
-      if typdef.variant then w "#";
-      w name; w " -> tkArgs "
+      if typdef.variant then w ("[< " ^ name ^ "]") else w name;
+      w " -> tkArgs "
     end;
     w (" = function");
     List.iter constrs
diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml
index c595a61c08..cf095f3832 100644
--- a/tools/ocamldep.ml
+++ b/tools/ocamldep.ml
@@ -47,7 +47,10 @@ let rec add_type bv ty =
   | Ptyp_class(c, tl, _) -> add bv c; List.iter (add_type bv) tl
   | Ptyp_alias(t, s) -> add_type bv t
   | Ptyp_variant(fl, _, _) ->
-      List.iter (fun (_,_,stl) -> List.iter (add_type bv) stl) fl
+      List.iter
+        (function Rtag(_,_,stl) -> List.iter (add_type bv) stl
+          | Rinherit sty -> add_type bv sty)
+        fl
 
 and add_field_type bv ft =
   match ft.pfield_desc with