From bd3854a4322ba4570c6ee9c27c79549cdc057c7f Mon Sep 17 00:00:00 2001 From: Jacques Garrigue Date: Tue, 25 Sep 2001 09:34:06 +0000 Subject: enrich variant type syntax git-svn-id: http://caml.inria.fr/svn/ocaml/branches/variants303@3786 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- bytecomp/matching.ml | 32 ++++++++++++++++---------------- camlp4/camlp4/ast2pt.ml | 9 +++++---- camlp4/ocaml_src/camlp4/ast2pt.ml | 9 +++++---- camlp4/top/rprint.ml | 21 +++++++++++---------- otherlibs/labltk/browser/main.ml | 1 + otherlibs/labltk/browser/searchpos.ml | 11 ++++++++--- otherlibs/labltk/compiler/compile.ml | 11 ++++++----- tools/ocamldep.ml | 5 ++++- 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>> @[%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@[@[%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 "@[[>%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 _ = " Enable or disable warnings according to :\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 -- cgit v1.2.1