From 310090b591176fbe366f8573de1b95c539d9ae1b Mon Sep 17 00:00:00 2001 From: Jacques Garrigue Date: Thu, 2 Feb 2006 06:39:55 +0000 Subject: [PATCH] multimatch patch 2006-02-02 git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@7343 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- testlabl/multimatch.diffs | 1418 +++++++++++++++++++++++++++++++++++++ testlabl/multimatch.ml | 1 + 2 files changed, 1419 insertions(+) create mode 100644 testlabl/multimatch.diffs diff --git a/testlabl/multimatch.diffs b/testlabl/multimatch.diffs new file mode 100644 index 000000000..6eb34b72e --- /dev/null +++ b/testlabl/multimatch.diffs @@ -0,0 +1,1418 @@ +Index: parsing/lexer.mll +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/parsing/lexer.mll,v +retrieving revision 1.73 +diff -u -r1.73 lexer.mll +--- parsing/lexer.mll 11 Apr 2005 16:44:26 -0000 1.73 ++++ parsing/lexer.mll 2 Feb 2006 06:28:32 -0000 +@@ -63,6 +63,8 @@ + "match", MATCH; + "method", METHOD; + "module", MODULE; ++ "multifun", MULTIFUN; ++ "multimatch", MULTIMATCH; + "mutable", MUTABLE; + "new", NEW; + "object", OBJECT; +Index: parsing/parser.mly +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/parsing/parser.mly,v +retrieving revision 1.123 +diff -u -r1.123 parser.mly +--- parsing/parser.mly 23 Mar 2005 03:08:37 -0000 1.123 ++++ parsing/parser.mly 2 Feb 2006 06:28:32 -0000 +@@ -257,6 +257,8 @@ + %token MINUSDOT + %token MINUSGREATER + %token MODULE ++%token MULTIFUN ++%token MULTIMATCH + %token MUTABLE + %token NATIVEINT + %token NEW +@@ -325,7 +327,7 @@ + %nonassoc SEMI /* below EQUAL ({lbl=...; lbl=...}) */ + %nonassoc LET /* above SEMI ( ...; let ... in ...) */ + %nonassoc below_WITH +-%nonassoc FUNCTION WITH /* below BAR (match ... with ...) */ ++%nonassoc FUNCTION WITH MULTIFUN /* below BAR (match ... with ...) */ + %nonassoc AND /* above WITH (module rec A: SIG with ... and ...) */ + %nonassoc THEN /* below ELSE (if ... then ...) */ + %nonassoc ELSE /* (if ... then ... else ...) */ +@@ -804,8 +806,12 @@ + { mkexp(Pexp_function("", None, List.rev $3)) } + | FUN labeled_simple_pattern fun_def + { let (l,o,p) = $2 in mkexp(Pexp_function(l, o, [p, $3])) } ++ | MULTIFUN opt_bar match_cases ++ { mkexp(Pexp_multifun(List.rev $3)) } + | MATCH seq_expr WITH opt_bar match_cases +- { mkexp(Pexp_match($2, List.rev $5)) } ++ { mkexp(Pexp_match($2, List.rev $5, false)) } ++ | MULTIMATCH seq_expr WITH opt_bar match_cases ++ { mkexp(Pexp_match($2, List.rev $5, true)) } + | TRY seq_expr WITH opt_bar match_cases + { mkexp(Pexp_try($2, List.rev $5)) } + | TRY seq_expr WITH error +@@ -1318,10 +1324,10 @@ + | simple_core_type2 { Rinherit $1 } + ; + tag_field: +- name_tag OF opt_ampersand amper_type_list +- { Rtag ($1, $3, List.rev $4) } +- | name_tag +- { Rtag ($1, true, []) } ++ name_tag OF opt_ampersand amper_type_list amper_type_pair_list ++ { Rtag ($1, $3, List.rev $4, $5) } ++ | name_tag amper_type_pair_list ++ { Rtag ($1, true, [], $2) } + ; + opt_ampersand: + AMPERSAND { true } +@@ -1331,6 +1337,11 @@ + core_type { [$1] } + | amper_type_list AMPERSAND core_type { $3 :: $1 } + ; ++amper_type_pair_list: ++ AMPERSAND core_type EQUAL core_type amper_type_pair_list ++ { ($2, $4) :: $5 } ++ | /* empty */ ++ { [] } + opt_present: + LBRACKETGREATER name_tag_list RBRACKET { List.rev $2 } + | /* empty */ { [] } +Index: parsing/parsetree.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/parsing/parsetree.mli,v +retrieving revision 1.42 +diff -u -r1.42 parsetree.mli +--- parsing/parsetree.mli 23 Mar 2005 03:08:37 -0000 1.42 ++++ parsing/parsetree.mli 2 Feb 2006 06:28:32 -0000 +@@ -43,7 +43,7 @@ + | Pfield_var + + and row_field = +- Rtag of label * bool * core_type list ++ Rtag of label * bool * core_type list * (core_type * core_type) list + | Rinherit of core_type + + (* XXX Type expressions for the class language *) +@@ -86,7 +86,7 @@ + | Pexp_let of rec_flag * (pattern * expression) list * expression + | Pexp_function of label * expression option * (pattern * expression) list + | Pexp_apply of expression * (label * expression) list +- | Pexp_match of expression * (pattern * expression) list ++ | Pexp_match of expression * (pattern * expression) list * bool + | Pexp_try of expression * (pattern * expression) list + | Pexp_tuple of expression list + | Pexp_construct of Longident.t * expression option * bool +@@ -111,6 +111,7 @@ + | Pexp_lazy of expression + | Pexp_poly of expression * core_type option + | Pexp_object of class_structure ++ | Pexp_multifun of (pattern * expression) list + + (* Value descriptions *) + +Index: parsing/printast.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/parsing/printast.ml,v +retrieving revision 1.29 +diff -u -r1.29 printast.ml +--- parsing/printast.ml 4 Jan 2006 16:55:50 -0000 1.29 ++++ parsing/printast.ml 2 Feb 2006 06:28:32 -0000 +@@ -205,10 +205,14 @@ + line i ppf "Pexp_apply\n"; + expression i ppf e; + list i label_x_expression ppf l; +- | Pexp_match (e, l) -> ++ | Pexp_match (e, l, b) -> + line i ppf "Pexp_match\n"; + expression i ppf e; + list i pattern_x_expression_case ppf l; ++ bool i ppf b ++ | Pexp_multifun l -> ++ line i ppf "Pexp_multifun\n"; ++ list i pattern_x_expression_case ppf l; + | Pexp_try (e, l) -> + line i ppf "Pexp_try\n"; + expression i ppf e; +@@ -653,7 +657,7 @@ + + and label_x_bool_x_core_type_list i ppf x = + match x with +- Rtag (l, b, ctl) -> ++ Rtag (l, b, ctl, cstr) -> + line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b); + list (i+1) core_type ppf ctl + | Rinherit (ct) -> +Index: typing/btype.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v +retrieving revision 1.38 +diff -u -r1.38 btype.ml +--- typing/btype.ml 4 Jan 2006 16:55:50 -0000 1.38 ++++ typing/btype.ml 2 Feb 2006 06:28:32 -0000 +@@ -66,16 +66,16 @@ + Clink r when !r <> Cunknown -> commu_repr !r + | c -> c + +-let rec row_field_repr_aux tl = function +- Reither(_, tl', _, {contents = Some fi}) -> +- row_field_repr_aux (tl@tl') fi +- | Reither(c, tl', m, r) -> +- Reither(c, tl@tl', m, r) ++let rec row_field_repr_aux tl tl2 = function ++ Reither(_, tl', _, tl2', {contents = Some fi}) -> ++ row_field_repr_aux (tl@tl') (tl2@tl2') fi ++ | Reither(c, tl', m, tl2', r) -> ++ Reither(c, tl@tl', m, tl2@tl2', r) + | Rpresent (Some _) when tl <> [] -> + Rpresent (Some (List.hd tl)) + | fi -> fi + +-let row_field_repr fi = row_field_repr_aux [] fi ++let row_field_repr fi = row_field_repr_aux [] [] fi + + let rec rev_concat l ll = + match ll with +@@ -170,7 +170,8 @@ + (fun (_, fi) -> + match row_field_repr fi with + | Rpresent(Some ty) -> f ty +- | Reither(_, tl, _, _) -> List.iter f tl ++ | Reither(_, tl, _, tl2, _) -> ++ List.iter f tl; List.iter (fun (t1,t2) -> f t1; f t2) tl2 + | _ -> ()) + row.row_fields; + match (repr row.row_more).desc with +@@ -208,15 +209,17 @@ + (fun (l, fi) -> l, + match row_field_repr fi with + | Rpresent(Some ty) -> Rpresent(Some(f ty)) +- | Reither(c, tl, m, e) -> ++ | Reither(c, tl, m, tpl, e) -> + let e = if keep then e else ref None in + let m = if row.row_fixed then fixed else m in + let tl = List.map f tl in ++ let tl1 = List.map (fun (t1,_) -> repr (f t1)) tpl ++ and tl2 = List.map (fun (_,t2) -> repr (f t2)) tpl in + bound := List.filter + (function {desc=Tconstr(_,[],_)} -> false | _ -> true) +- (List.map repr tl) ++ (List.map repr tl @ tl1 @ tl2) + @ !bound; +- Reither(c, tl, m, e) ++ Reither(c, tl, m, List.combine tl1 tl2, e) + | _ -> fi) + row.row_fields in + let name = +Index: typing/ctype.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v +retrieving revision 1.200 +diff -u -r1.200 ctype.ml +--- typing/ctype.ml 6 Jan 2006 02:16:24 -0000 1.200 ++++ typing/ctype.ml 2 Feb 2006 06:28:32 -0000 +@@ -340,7 +340,7 @@ + let fi = filter_row_fields erase fi in + match row_field_repr f with + Rabsent -> fi +- | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi ++ | Reither(_,_,false,_,e) when erase -> set_row_field e Rabsent; fi + | _ -> p :: fi + + (**************************************) +@@ -1286,6 +1286,10 @@ + + module TypeMap = Map.Make (TypeOps) + ++ ++(* A list of univars which may appear free in a type, but only if generic *) ++let allowed_univars = ref TypeSet.empty ++ + (* Test the occurence of free univars in a type *) + (* that's way too expansive. Must do some kind of cacheing *) + let occur_univar env ty = +@@ -1307,7 +1311,12 @@ + then + match ty.desc with + Tunivar -> +- if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar()]) ++ if TypeSet.mem ty bound then () else ++ if TypeSet.mem ty !allowed_univars && ++ (ty.level = generic_level || ++ ty.level = pivot_level - generic_level) ++ then () ++ else raise (Unify [ty, newgenvar()]) + | Tpoly (ty, tyl) -> + let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in + occur_rec bound ty +@@ -1393,6 +1402,7 @@ + with exn -> univar_pairs := old_univars; raise exn + + let univar_pairs = ref [] ++let delayed_conditionals = ref [] + + + (*****************) +@@ -1691,9 +1701,11 @@ + with Not_found -> (h,l)::hl) + (List.map (fun (l,_) -> (hash_variant l, l)) row1.row_fields) + (List.map fst r2)); ++ let fixed1 = row1.row_fixed || rm1.desc <> Tvar ++ and fixed2 = row2.row_fixed || rm2.desc <> Tvar in + let more = +- if row1.row_fixed then rm1 else +- if row2.row_fixed then rm2 else ++ if fixed1 then rm1 else ++ if fixed2 then rm2 else + newgenvar () + in update_level env (min rm1.level rm2.level) more; + let fixed = row1.row_fixed || row2.row_fixed +@@ -1726,18 +1738,18 @@ + let bound = row1.row_bound @ row2.row_bound in + let row0 = {row_fields = []; row_more = more; row_bound = bound; + row_closed = closed; row_fixed = fixed; row_name = name} in +- let set_more row rest = ++ let set_more row row_fixed rest = + let rest = + if closed then + filter_row_fields row.row_closed rest + else rest in +- if rest <> [] && (row.row_closed || row.row_fixed) +- || closed && row.row_fixed && not row.row_closed then begin ++ if rest <> [] && (row.row_closed || row_fixed) ++ || closed && row_fixed && not row.row_closed then begin + let t1 = mkvariant [] true and t2 = mkvariant rest false in + raise (Unify [if row == row1 then (t1,t2) else (t2,t1)]) + end; + let rm = row_more row in +- if row.row_fixed then ++ if row_fixed then + if row0.row_more == rm then () else + if rm.desc = Tvar then link_type rm row0.row_more else + unify env rm row0.row_more +@@ -1748,11 +1760,11 @@ + in + let md1 = rm1.desc and md2 = rm2.desc in + begin try +- set_more row1 r2; +- set_more row2 r1; ++ set_more row1 fixed1 r2; ++ set_more row2 fixed2 r1; + List.iter + (fun (l,f1,f2) -> +- try unify_row_field env row1.row_fixed row2.row_fixed l f1 f2 ++ try unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 + with Unify trace -> + raise (Unify ((mkvariant [l,f1] true, + mkvariant [l,f2] true) :: trace))) +@@ -1761,13 +1773,13 @@ + log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn + end + +-and unify_row_field env fixed1 fixed2 l f1 f2 = ++and unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 = + let f1 = row_field_repr f1 and f2 = row_field_repr f2 in + if f1 == f2 then () else + match f1, f2 with + Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2 + | Rpresent None, Rpresent None -> () +- | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) -> ++ | Reither(c1, tl1, m1, tp1, e1), Reither(c2, tl2, m2, tp2, e2) -> + if e1 == e2 then () else + let redo = + (m1 || m2) && +@@ -1777,32 +1789,70 @@ + List.iter (unify env t1) tl; + !e1 <> None || !e2 <> None + end in +- if redo then unify_row_field env fixed1 fixed2 l f1 f2 else ++ let redo = ++ redo || begin ++ if tp1 = [] && fixed1 then unify_pairs env tp2; ++ if tp2 = [] && fixed2 then unify_pairs env tp1; ++ !e1 <> None || !e2 <> None ++ end ++ in ++ if redo then unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 else + let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in + let rec remq tl = function [] -> [] + | ty :: tl' -> + if List.memq ty tl then remq tl tl' else ty :: remq tl tl' + in + let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in ++ let repr_pairs = List.map (fun (t1,t2) -> repr t1, repr t2) in ++ let tp1 = repr_pairs tp1 and tp2 = repr_pairs tp2 in ++ let rec rempq tp = function [] -> [] ++ | (t1,t2 as p) :: tp' -> ++ if List.exists (fun (t1',t2') -> t1==t1' && t2==t2') (tp@tp') then ++ rempq tp tp' ++ else p :: rempq tp tp' ++ in ++ let tp1' = ++ if fixed2 then begin ++ delayed_conditionals := ++ (!univar_pairs, tp1, l, row2) :: !delayed_conditionals; ++ [] ++ end else rempq tp2 tp1 ++ and tp2' = ++ if fixed1 then begin ++ delayed_conditionals := ++ (!univar_pairs, tp2, l, row1) :: !delayed_conditionals; ++ [] ++ end else rempq tp1 tp2 ++ in + let e = ref None in +- let f1' = Reither(c1 || c2, tl1', m1 || m2, e) +- and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in +- set_row_field e1 f1'; set_row_field e2 f2'; +- | Reither(_, _, false, e1), Rabsent -> set_row_field e1 f2 +- | Rabsent, Reither(_, _, false, e2) -> set_row_field e2 f1 ++ let f1' = Reither(c1 || c2, tl1', m1 || m2, tp2', e) ++ and f2' = Reither(c1 || c2, tl2', m1 || m2, tp1', e) in ++ set_row_field e1 f1'; set_row_field e2 f2' ++ | Reither(_, _, false, _, e1), Rabsent -> set_row_field e1 f2 ++ | Rabsent, Reither(_, _, false, _, e2) -> set_row_field e2 f1 + | Rabsent, Rabsent -> () +- | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 -> ++ | Reither(false, tl, _, tp, e1), Rpresent(Some t2) when not fixed1 -> + set_row_field e1 f2; +- (try List.iter (fun t1 -> unify env t1 t2) tl ++ begin try ++ List.iter (fun t1 -> unify env t1 t2) tl; ++ List.iter (fun (t1,t2) -> unify env t1 t2) tp ++ with exn -> e1 := None; raise exn ++ end ++ | Rpresent(Some t1), Reither(false, tl, _, tp, e2) when not fixed2 -> ++ set_row_field e2 f1; ++ begin try ++ List.iter (unify env t1) tl; ++ List.iter (fun (t1,t2) -> unify env t1 t2) tp ++ with exn -> e2 := None; raise exn ++ end ++ | Reither(true, [], _, tpl, e1), Rpresent None when not fixed1 -> ++ set_row_field e1 f2; ++ (try List.iter (fun (t1,t2) -> unify env t1 t2) tpl + with exn -> e1 := None; raise exn) +- | Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 -> ++ | Rpresent None, Reither(true, [], _, tpl, e2) when not fixed2 -> + set_row_field e2 f1; +- (try List.iter (unify env t1) tl ++ (try List.iter (fun (t1,t2) -> unify env t1 t2) tpl + with exn -> e2 := None; raise exn) +- | Reither(true, [], _, e1), Rpresent None when not fixed1 -> +- set_row_field e1 f2 +- | Rpresent None, Reither(true, [], _, e2) when not fixed2 -> +- set_row_field e2 f1 + | _ -> raise (Unify []) + + +@@ -1920,6 +1970,166 @@ + (* Matching between type schemes *) + (***********************************) + ++(* Forward declaration (order should be reversed...) *) ++let equal' = ref (fun _ -> failwith "Ctype.equal'") ++ ++let make_generics_univars tyl = ++ let polyvars = ref TypeSet.empty in ++ let rec make_rec ty = ++ let ty = repr ty in ++ if ty.level = generic_level then begin ++ if ty.desc = Tvar then begin ++ log_type ty; ++ ty.desc <- Tunivar; ++ polyvars := TypeSet.add ty !polyvars ++ end ++ else if ty.desc = Tunivar then set_level ty (generic_level - 1); ++ ty.level <- pivot_level - generic_level; ++ iter_type_expr make_rec ty ++ end ++ in ++ List.iter make_rec tyl; ++ List.iter unmark_type tyl; ++ !polyvars ++ ++(* New version of moregeneral, using unification *) ++ ++let copy_cond (p,tpl,l,row) = ++ let row = ++ match repr (copy (newgenty (Tvariant row))) with ++ {desc=Tvariant row} -> row ++ | _ -> assert false ++ and pairs = ++ List.map (fun (t1,t2) -> copy t1, copy t2) tpl in ++ (p, pairs, l, row) ++ ++let get_row_field l row = ++ try row_field_repr (List.assoc l (row_repr row).row_fields) ++ with Not_found -> Rabsent ++ ++let rec check_conditional_list env cdtls pattvars tpls = ++ match cdtls with ++ [] -> ++ let finished = ++ List.for_all (fun (_,t1,t2) -> !equal' env false [t1] [t2]) tpls in ++ if not finished then begin ++ let polyvars = make_generics_univars pattvars in ++ delayed_conditionals := []; ++ allowed_univars := polyvars; ++ List.iter (fun (pairs, ty1, ty2) -> unify_pairs env ty1 ty2 pairs) ++ tpls; ++ check_conditionals env polyvars !delayed_conditionals ++ end ++ | (pairs, tpl1, l, row2 as cond) :: cdtls -> ++ let cont = check_conditional_list env cdtls pattvars in ++ let tpl1 = ++ List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpl1 in ++ let included = ++ List.for_all ++ (fun (t1,t2) -> ++ List.exists ++ (fun (_,t1',t2') -> !equal' env false [t1;t2] [t1';t2']) ++ tpls) ++ tpl1 in ++ if included then cont tpls else ++ match get_row_field l row2 with ++ Rpresent _ -> ++ cont (List.map (fun (t1,t2) -> (pairs,t1,t2)) tpl1 @ tpls) ++ | Rabsent -> cont tpls ++ | Reither (c, tl2, _, _, _) -> ++ cont tpls; ++ if c && tl2 <> [] then () (* cannot succeed *) else ++ let (pairs, tpl1, l, row2) = copy_cond cond ++ and tpls = List.map (fun (p,t1,t2) -> p, copy t1, copy t2) tpls ++ and pattvars = List.map copy pattvars ++ and cdtls = List.map copy_cond cdtls in ++ cleanup_types (); ++ let tl2, tpl2, e2 = ++ match get_row_field l row2 with ++ Reither (c, tl2, _, tpl2, e2) -> tl2, tpl2, e2 ++ | _ -> assert false ++ in ++ let snap = Btype.snapshot () in ++ let ok = ++ try ++ begin match tl2 with ++ [] -> ++ set_row_field e2 (Rpresent None) ++ | t::tl -> ++ set_row_field e2 (Rpresent (Some t)); ++ List.iter (unify env t) tl ++ end; ++ List.iter (fun (t1,t2) -> unify_pairs env t1 t2 pairs) tpl2; ++ true ++ with exn -> ++ Btype.backtrack snap; ++ false ++ in ++ (* This is not [cont] : types have been copied *) ++ if ok then ++ check_conditional_list env cdtls pattvars ++ (List.map (fun (t1,t2) -> (pairs,t1,t2)) tpl1 @ tpls) ++ ++and check_conditionals env polyvars cdtls = ++ let cdtls = List.map copy_cond cdtls in ++ let pattvars = ref [] in ++ TypeSet.iter ++ (fun ty -> ++ let ty = repr ty in ++ match ty.desc with ++ Tsubst ty -> ++ let ty = repr ty in ++ begin match ty.desc with ++ Tunivar -> ++ log_type ty; ++ ty.desc <- Tvar; ++ pattvars := ty :: !pattvars ++ | Ttuple [tv;_] -> ++ if tv.desc = Tunivar then ++ (log_type tv; tv.desc <- Tvar; pattvars := ty :: !pattvars) ++ else if tv.desc <> Tvar then assert false ++ | Tvar -> () ++ | _ -> assert false ++ end ++ | _ -> ()) ++ polyvars; ++ cleanup_types (); ++ check_conditional_list env cdtls !pattvars [] ++ ++ ++(* Must empty univar_pairs first *) ++let unify_poly env polyvars subj patt = ++ let old_level = !current_level in ++ current_level := generic_level; ++ delayed_conditionals := []; ++ allowed_univars := polyvars; ++ try ++ unify env subj patt; ++ check_conditionals env polyvars !delayed_conditionals; ++ current_level := old_level; ++ allowed_univars := TypeSet.empty; ++ delayed_conditionals := [] ++ with exn -> ++ current_level := old_level; ++ allowed_univars := TypeSet.empty; ++ delayed_conditionals := []; ++ raise exn ++ ++let moregeneral env _ subj patt = ++ let old_level = !current_level in ++ current_level := generic_level; ++ let subj = instance subj ++ and patt = instance patt in ++ let polyvars = make_generics_univars [patt] in ++ current_level := old_level; ++ let snap = Btype.snapshot () in ++ try ++ unify_poly env polyvars subj patt; ++ true ++ with Unify _ -> ++ Btype.backtrack snap; ++ false ++ + (* + Update the level of [ty]. First check that the levels of generic + variables from the subject are not lowered. +@@ -2072,35 +2282,101 @@ + Rpresent(Some t1), Rpresent(Some t2) -> + moregen inst_nongen type_pairs env t1 t2 + | Rpresent None, Rpresent None -> () +- | Reither(false, tl1, _, e1), Rpresent(Some t2) when not univ -> ++ | Reither(false, tl1, _, [], e1), Rpresent(Some t2) when not univ -> + set_row_field e1 f2; + List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1 +- | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) -> ++ | Reither(c1, tl1, _, tpl1, e1), Reither(c2, tl2, m2, tpl2, e2) -> + if e1 != e2 then begin + if c1 && not c2 then raise(Unify []); +- set_row_field e1 (Reither (c2, [], m2, e2)); +- if List.length tl1 = List.length tl2 then +- List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 +- else match tl2 with +- t2 :: _ -> ++ let tpl' = if tpl1 = [] then tpl2 else [] in ++ set_row_field e1 (Reither (c2, [], m2, tpl', e2)); ++ begin match tl2 with ++ [t2] -> + List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) + tl1 +- | [] -> +- if tl1 <> [] then raise (Unify []) ++ | _ -> ++ if List.length tl1 <> List.length tl2 then raise (Unify []); ++ List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 ++ end; ++ if tpl1 <> [] then ++ delayed_conditionals := ++ (!univar_pairs, tpl1, l, row2) :: !delayed_conditionals + end +- | Reither(true, [], _, e1), Rpresent None when not univ -> ++ | Reither(true, [], _, [], e1), Rpresent None when not univ -> + set_row_field e1 f2 +- | Reither(_, _, _, e1), Rabsent when not univ -> ++ | Reither(_, _, _, [], e1), Rabsent when not univ -> + set_row_field e1 f2 + | Rabsent, Rabsent -> () + | _ -> raise (Unify [])) + pairs + ++let check_conditional env (pairs, tpl1, l, row2) tpls cont = ++ let tpl1 = ++ List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpl1 in ++ let included = ++ List.for_all ++ (fun (t1,t2) -> ++ List.exists (fun (t1',t2') -> !equal' env false [t1;t2] [t1';t2']) ++ tpls) ++ tpl1 in ++ if tpl1 = [] || included then cont tpls else ++ match get_row_field l row2 with ++ Rpresent _ -> cont (tpl1 @ tpls) ++ | Rabsent -> cont tpls ++ | Reither (c, tl2, _, tpl2, e2) -> ++ if not c || tl2 = [] then begin ++ let snap = Btype.snapshot () in ++ let ok = ++ try ++ begin match tl2 with ++ [] -> ++ set_row_field e2 (Rpresent None) ++ | t::tl -> ++ set_row_field e2 (Rpresent (Some t)); ++ List.iter (unify env t) tl ++ end; ++ List.iter (fun (t1,t2) -> unify_pairs env t1 t2 pairs) tpl2; ++ true ++ with Unify _ -> false ++ in ++ if ok then cont (tpl1 @ tpls); ++ Btype.backtrack snap ++ end; ++ cont tpls ++ ++let rec check_conditionals inst_nongen env cdtls tpls = ++ match cdtls with ++ [] -> ++ let tpls = ++ List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpls in ++ if tpls = [] then () else begin ++ delayed_conditionals := []; ++ let tl1, tl2 = List.split tpls in ++ let type_pairs = TypePairs.create 13 in ++ List.iter2 (moregen false type_pairs env) tl2 tl1; ++ check_conditionals inst_nongen env !delayed_conditionals [] ++ end ++ | cdtl :: cdtls -> ++ check_conditional env cdtl tpls ++ (check_conditionals inst_nongen env cdtls) ++ ++ + (* Must empty univar_pairs first *) + let moregen inst_nongen type_pairs env patt subj = + univar_pairs := []; +- moregen inst_nongen type_pairs env patt subj ++ delayed_conditionals := []; ++ try ++ moregen inst_nongen type_pairs env patt subj; ++ check_conditionals inst_nongen env !delayed_conditionals []; ++ univar_pairs := []; ++ delayed_conditionals := [] ++ with exn -> ++ univar_pairs := []; ++ delayed_conditionals := []; ++ raise exn ++ + ++(* old implementation + (* + Non-generic variable can be instanciated only if [inst_nongen] is + true. So, [inst_nongen] should be set to false if the subject might +@@ -2128,6 +2404,7 @@ + in + current_level := old_level; + res ++*) + + + (* Alternative approach: "rigidify" a type scheme, +@@ -2296,30 +2573,36 @@ + {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2 + | _ -> raise Cannot_expand + with Cannot_expand -> ++ let eqtype_rec = eqtype rename type_pairs subst env in + let row1 = row_repr row1 and row2 = row_repr row2 in + let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in + if row1.row_closed <> row2.row_closed + || not row1.row_closed && (r1 <> [] || r2 <> []) + || filter_row_fields false (r1 @ r2) <> [] + then raise (Unify []); +- if not (static_row row1) then +- eqtype rename type_pairs subst env row1.row_more row2.row_more; ++ if not (static_row row1) then eqtype_rec row1.row_more row2.row_more; + List.iter + (fun (_,f1,f2) -> + match row_field_repr f1, row_field_repr f2 with + Rpresent(Some t1), Rpresent(Some t2) -> +- eqtype rename type_pairs subst env t1 t2 +- | Reither(true, [], _, _), Reither(true, [], _, _) -> +- () +- | Reither(false, t1::tl1, _, _), Reither(false, t2::tl2, _, _) -> +- eqtype rename type_pairs subst env t1 t2; ++ eqtype_rec t1 t2 ++ | Reither(true, [], _, tp1, _), Reither(true, [], _, tp2, _) -> ++ List.iter2 ++ (fun (t1,t1') (t2,t2') -> eqtype_rec t1 t2; eqtype_rec t1' t2') ++ tp1 tp2 ++ | Reither(false, t1::tl1, _, tpl1, _), ++ Reither(false, t2::tl2, _, tpl2, _) -> ++ eqtype_rec t1 t2; ++ List.iter2 ++ (fun (t1,t1') (t2,t2') -> eqtype_rec t1 t2; eqtype_rec t1' t2') ++ tpl1 tpl2; + if List.length tl1 = List.length tl2 then + (* if same length allow different types (meaning?) *) +- List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 ++ List.iter2 eqtype_rec tl1 tl2 + else begin + (* otherwise everything must be equal *) +- List.iter (eqtype rename type_pairs subst env t1) tl2; +- List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1 ++ List.iter (eqtype_rec t1) tl2; ++ List.iter (fun t1 -> eqtype_rec t1 t2) tl1 + end + | Rpresent None, Rpresent None -> () + | Rabsent, Rabsent -> () +@@ -2334,6 +2617,8 @@ + with + Unify _ -> false + ++let () = equal' := equal ++ + (* Must empty univar_pairs first *) + let eqtype rename type_pairs subst env t1 t2 = + univar_pairs := []; +@@ -2770,14 +3055,14 @@ + (fun (l,f as orig) -> match row_field_repr f with + Rpresent None -> + if posi then +- (l, Reither(true, [], false, ref None)), Unchanged ++ (l, Reither(true, [], false, [], ref None)), Unchanged + else + orig, Unchanged + | Rpresent(Some t) -> + let (t', c) = build_subtype env visited loops posi level' t in + if posi && level > 0 then begin + bound := t' :: !bound; +- (l, Reither(false, [t'], false, ref None)), c ++ (l, Reither(false, [t'], false, [], ref None)), c + end else + (l, Rpresent(Some t')), c + | _ -> assert false) +@@ -2960,11 +3245,11 @@ + List.fold_left + (fun cstrs (_,f1,f2) -> + match row_field_repr f1, row_field_repr f2 with +- (Rpresent None|Reither(true,_,_,_)), Rpresent None -> ++ (Rpresent None|Reither(true,_,_,[],_)), Rpresent None -> + cstrs + | Rpresent(Some t1), Rpresent(Some t2) -> + subtype_rec env ((t1, t2)::trace) t1 t2 cstrs +- | Reither(false, t1::_, _, _), Rpresent(Some t2) -> ++ | Reither(false, t1::_, _, [], _), Rpresent(Some t2) -> + subtype_rec env ((t1, t2)::trace) t1 t2 cstrs + | Rabsent, _ -> cstrs + | _ -> raise Exit) +@@ -2977,11 +3262,11 @@ + (fun cstrs (_,f1,f2) -> + match row_field_repr f1, row_field_repr f2 with + Rpresent None, Rpresent None +- | Reither(true,[],_,_), Reither(true,[],_,_) ++ | Reither(true,[],_,[],_), Reither(true,[],_,[],_) + | Rabsent, Rabsent -> + cstrs + | Rpresent(Some t1), Rpresent(Some t2) +- | Reither(false,[t1],_,_), Reither(false,[t2],_,_) -> ++ | Reither(false,[t1],_,[],_), Reither(false,[t2],_,[],_) -> + subtype_rec env ((t1, t2)::trace) t1 t2 cstrs + | _ -> raise Exit) + cstrs pairs +@@ -3079,16 +3364,26 @@ + let fields = List.map + (fun (l,f) -> + let f = row_field_repr f in l, +- match f with Reither(b, ty::(_::_ as tyl), m, e) -> +- let tyl' = +- List.fold_left +- (fun tyl ty -> +- if List.exists (fun ty' -> equal env false [ty] [ty']) tyl +- then tyl else ty::tyl) +- [ty] tyl ++ match f with Reither(b, tyl, m, tp, e) -> ++ let rem_dbl eq l = ++ List.rev ++ (List.fold_left ++ (fun xs x -> if List.exists (eq x) xs then xs else x::xs) ++ [] l) ++ in ++ let tyl' = rem_dbl (fun t1 t2 -> equal env false [t1] [t2]) tyl ++ and tp' = ++ List.filter ++ (fun (ty1,ty2) -> not (equal env false [ty1] [ty2])) tp ++ in ++ let tp' = ++ rem_dbl ++ (fun (t1,t2) (t1',t2') -> equal env false [t1;t2] [t1';t2']) ++ tp' + in +- if List.length tyl' <= List.length tyl then +- let f = Reither(b, List.rev tyl', m, ref None) in ++ if List.length tyl' < List.length tyl ++ || List.length tp' < List.length tp then ++ let f = Reither(b, tyl', m, tp', ref None) in + set_row_field e f; + f + else f +@@ -3344,9 +3639,9 @@ + List.iter + (fun (l,fi) -> + match row_field_repr fi with +- Reither (c, t1::(_::_ as tl), m, e) -> ++ Reither (c, t1::(_::_ as tl), m, tp, e) -> + List.iter (unify env t1) tl; +- set_row_field e (Reither (c, [t1], m, ref None)) ++ set_row_field e (Reither (c, [t1], m, tp, ref None)) + | _ -> + ()) + row.row_fields; +Index: typing/includecore.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/includecore.ml,v +retrieving revision 1.32 +diff -u -r1.32 includecore.ml +--- typing/includecore.ml 8 Aug 2005 05:40:52 -0000 1.32 ++++ typing/includecore.ml 2 Feb 2006 06:28:32 -0000 +@@ -71,10 +71,10 @@ + (fun (_, f1, f2) -> + match Btype.row_field_repr f1, Btype.row_field_repr f2 with + Rpresent(Some t1), +- (Rpresent(Some t2) | Reither(false, [t2], _, _)) -> ++ (Rpresent(Some t2) | Reither(false,[t2],_,[],_)) -> + to_equal := (t1,t2) :: !to_equal; true +- | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true +- | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_) ++ | Rpresent None, (Rpresent None | Reither(true,[],_,[],_)) -> true ++ | Reither(c1,tl1,_,[],_), Reither(c2,tl2,_,[],_) + when List.length tl1 = List.length tl2 && c1 = c2 -> + to_equal := List.combine tl1 tl2 @ !to_equal; true + | Rabsent, (Reither _ | Rabsent) -> true +Index: typing/oprint.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v +retrieving revision 1.22 +diff -u -r1.22 oprint.ml +--- typing/oprint.ml 23 Mar 2005 03:08:37 -0000 1.22 ++++ typing/oprint.ml 2 Feb 2006 06:28:33 -0000 +@@ -223,14 +223,18 @@ + print_fields rest ppf [] + | (s, t) :: l -> + fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l +-and print_row_field ppf (l, opt_amp, tyl) = ++and print_row_field ppf (l, opt_amp, tyl, tpl) = + let pr_of ppf = + if opt_amp then fprintf ppf " of@ &@ " + else if tyl <> [] then fprintf ppf " of@ " +- else fprintf ppf "" +- in +- fprintf ppf "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &") +- tyl ++ and pr_tp ppf (t1,t2) = ++ fprintf ppf "@[%a =@ %a@]" ++ print_out_type t1 ++ print_out_type t2 ++ in ++ fprintf ppf "@[`%s%t%a%a@]" l pr_of ++ (print_typlist print_out_type " &") tyl ++ (print_list_init pr_tp (fun ppf -> fprintf ppf " &@ ")) tpl + and print_typlist print_elem sep ppf = + function + [] -> () +Index: typing/outcometree.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v +retrieving revision 1.14 +diff -u -r1.14 outcometree.mli +--- typing/outcometree.mli 23 Mar 2005 03:08:37 -0000 1.14 ++++ typing/outcometree.mli 2 Feb 2006 06:28:33 -0000 +@@ -61,7 +61,8 @@ + bool * out_variant * bool * (string list) option + | Otyp_poly of string list * out_type + and out_variant = +- | Ovar_fields of (string * bool * out_type list) list ++ | Ovar_fields of ++ (string * bool * out_type list * (out_type * out_type) list ) list + | Ovar_name of out_ident * out_type list + + type out_class_type = +Index: typing/parmatch.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/parmatch.ml,v +retrieving revision 1.70 +diff -u -r1.70 parmatch.ml +--- typing/parmatch.ml 24 Mar 2005 17:20:54 -0000 1.70 ++++ typing/parmatch.ml 2 Feb 2006 06:28:33 -0000 +@@ -568,11 +568,11 @@ + List.fold_left + (fun nm (tag,f) -> + match Btype.row_field_repr f with +- | Reither(_, _, false, e) -> ++ | Reither(_, _, false, _, e) -> + (* m=false means that this tag is not explicitly matched *) + Btype.set_row_field e Rabsent; + None +- | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm) ++ | Rabsent | Reither (_, _, true, _, _) | Rpresent _ -> nm) + row.row_name row.row_fields in + if not row.row_closed || nm != row.row_name then begin + (* this unification cannot fail *) +@@ -605,8 +605,8 @@ + List.for_all + (fun (tag,f) -> + match Btype.row_field_repr f with +- Rabsent | Reither(_, _, false, _) -> true +- | Reither (_, _, true, _) ++ Rabsent | Reither(_, _, false, _, _) -> true ++ | Reither (_, _, true, _, _) + (* m=true, do not discard matched tags, rather warn *) + | Rpresent _ -> List.mem tag fields) + row.row_fields +@@ -739,7 +739,7 @@ + match Btype.row_field_repr f with + Rabsent (* | Reither _ *) -> others + (* This one is called after erasing pattern info *) +- | Reither (c, _, _, _) -> make_other_pat tag c :: others ++ | Reither (c, _, _, _, _) -> make_other_pat tag c :: others + | Rpresent arg -> make_other_pat tag (arg = None) :: others) + [] row.row_fields + with +Index: typing/printtyp.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v +retrieving revision 1.140 +diff -u -r1.140 printtyp.ml +--- typing/printtyp.ml 4 Jan 2006 16:55:50 -0000 1.140 ++++ typing/printtyp.ml 2 Feb 2006 06:28:33 -0000 +@@ -157,9 +157,12 @@ + and raw_field ppf = function + Rpresent None -> fprintf ppf "Rpresent None" + | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t +- | Reither (c,tl,m,e) -> +- fprintf ppf "@[Reither(%b,@,%a,@,%b,@,@[<1>ref%t@])@]" c +- raw_type_list tl m ++ | Reither (c,tl,m,tpl,e) -> ++ fprintf ppf "@[Reither(%b,@,%a,@,%b,@,%a,@,@[<1>ref%t@])@]" ++ c raw_type_list tl m ++ (raw_list ++ (fun ppf (t1,t2) -> ++ fprintf ppf "@[%a,@,%a@]" raw_type t1 raw_type t2)) tpl + (fun ppf -> + match !e with None -> fprintf ppf " None" + | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f) +@@ -219,8 +222,9 @@ + List.for_all + (fun (_, f) -> + match row_field_repr f with +- | Reither(c, l, _, _) -> +- row.row_closed && if c then l = [] else List.length l = 1 ++ | Reither(c, l, _, pl, _) -> ++ row.row_closed && pl = [] && ++ if c then l = [] else List.length l = 1 + | _ -> true) + row.row_fields + +@@ -392,13 +396,16 @@ + + and tree_of_row_field sch (l, f) = + match row_field_repr f with +- | Rpresent None | Reither(true, [], _, _) -> (l, false, []) +- | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty]) +- | Reither(c, tyl, _, _) -> +- if c (* contradiction: un constructeur constant qui a un argument *) +- then (l, true, tree_of_typlist sch tyl) +- else (l, false, tree_of_typlist sch tyl) +- | Rabsent -> (l, false, [] (* une erreur, en fait *)) ++ | Rpresent None | Reither(true, [], _, [], _) -> (l, false, [], []) ++ | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty], []) ++ | Reither(c, tyl, _, tpl, _) -> ++ let ttpl = ++ List.map ++ (fun (t1,t2) -> tree_of_typexp sch t1, tree_of_typexp sch t2) ++ tpl ++ in ++ (l, c && tpl = [], tree_of_typlist sch tyl, ttpl) ++ | Rabsent -> (l, false, [], [] (* une erreur, en fait *)) + + and tree_of_typlist sch tyl = + List.map (tree_of_typexp sch) tyl +Index: typing/typeclass.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.ml,v +retrieving revision 1.85 +diff -u -r1.85 typeclass.ml +--- typing/typeclass.ml 22 Jul 2005 06:42:36 -0000 1.85 ++++ typing/typeclass.ml 2 Feb 2006 06:28:33 -0000 +@@ -727,7 +727,7 @@ + {pexp_loc = loc; pexp_desc = + Pexp_match({pexp_loc = loc; pexp_desc = + Pexp_ident(Longident.Lident"*opt*")}, +- scases)} in ++ scases, false)} in + let sfun = + {pcl_loc = scl.pcl_loc; pcl_desc = + Pcl_fun(l, None, {ppat_loc = loc; ppat_desc = Ppat_var"*opt*"}, +Index: typing/typecore.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v +retrieving revision 1.178 +diff -u -r1.178 typecore.ml +--- typing/typecore.ml 6 Jan 2006 02:25:37 -0000 1.178 ++++ typing/typecore.ml 2 Feb 2006 06:28:33 -0000 +@@ -156,15 +156,21 @@ + let field = row_field tag row in + begin match field with + | Rabsent -> assert false +- | Reither (true, [], _, e) when not row.row_closed -> +- set_row_field e (Rpresent None) +- | Reither (false, ty::tl, _, e) when not row.row_closed -> ++ | Reither (true, [], _, tpl, e) when not row.row_closed -> ++ set_row_field e (Rpresent None); ++ List.iter ++ (fun (t1,t2) -> unify_pat pat.pat_env {pat with pat_type=t1} t2) ++ tpl ++ | Reither (false, ty::tl, _, tpl, e) when not row.row_closed -> + set_row_field e (Rpresent (Some ty)); ++ List.iter ++ (fun (t1,t2) -> unify_pat pat.pat_env {pat with pat_type=t1} t2) ++ tpl; + begin match opat with None -> assert false + | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl) + end +- | Reither (c, l, true, e) when not row.row_fixed -> +- set_row_field e (Reither (c, [], false, ref None)) ++ | Reither (c, l, true, tpl, e) when not row.row_fixed -> ++ set_row_field e (Reither (c, [], false, [], ref None)) + | _ -> () + end; + (* Force check of well-formedness *) +@@ -307,13 +313,13 @@ + match row_field_repr f with + Rpresent None -> + (l,None) :: pats, +- (l, Reither(true,[], true, ref None)) :: fields ++ (l, Reither(true,[], true, [], ref None)) :: fields + | Rpresent (Some ty) -> + bound := ty :: !bound; + (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; + pat_type=ty}) + :: pats, +- (l, Reither(false, [ty], true, ref None)) :: fields ++ (l, Reither(false, [ty], true, [], ref None)) :: fields + | _ -> pats, fields) + ([],[]) fields in + let row = +@@ -337,6 +343,18 @@ + pat pats in + rp { r with pat_loc = loc } + ++let rec flatten_or_pat pat = ++ match pat.pat_desc with ++ Tpat_or (p1, p2, _) -> ++ flatten_or_pat p1 @ flatten_or_pat p2 ++ | _ -> ++ [pat] ++ ++let all_variants pat = ++ List.for_all ++ (function {pat_desc=Tpat_variant _} -> true | _ -> false) ++ (flatten_or_pat pat) ++ + let rec find_record_qual = function + | [] -> None + | (Longident.Ldot (modname, _), _) :: _ -> Some modname +@@ -423,7 +441,7 @@ + let arg = may_map (type_pat env) sarg in + let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type] in + let row = { row_fields = +- [l, Reither(arg = None, arg_type, true, ref None)]; ++ [l, Reither(arg = None, arg_type, true, [], ref None)]; + row_bound = arg_type; + row_closed = false; + row_more = newvar (); +@@ -788,7 +806,7 @@ + newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok)) + | Pexp_function (p,_,(_,e)::_) -> + newty (Tarrow(p, newvar (), type_approx env e, Cok)) +- | Pexp_match (_, (_,e)::_) -> type_approx env e ++ | Pexp_match (_, (_,e)::_, false) -> type_approx env e + | Pexp_try (e, _) -> type_approx env e + | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l)) + | Pexp_ifthenelse (_,e,_) -> type_approx env e +@@ -939,17 +957,26 @@ + exp_loc = sexp.pexp_loc; + exp_type = ty_res; + exp_env = env } +- | Pexp_match(sarg, caselist) -> ++ | Pexp_match(sarg, caselist, multi) -> + let arg = type_exp env sarg in + let ty_res = newvar() in + let cases, partial = +- type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist ++ type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist ~multi + in + re { + exp_desc = Texp_match(arg, cases, partial); + exp_loc = sexp.pexp_loc; + exp_type = ty_res; + exp_env = env } ++ | Pexp_multifun caselist -> ++ let ty_arg = newvar() and ty_res = newvar() in ++ let cases, partial = ++ type_cases env ty_arg ty_res (Some sexp.pexp_loc) caselist ~multi:true ++ in ++ { exp_desc = Texp_function (cases, partial); ++ exp_loc = sexp.pexp_loc; ++ exp_type = newty (Tarrow ("", ty_arg, ty_res, Cok)); ++ exp_env = env } + | Pexp_try(sbody, caselist) -> + let body = type_exp env sbody in + let cases, _ = +@@ -1758,7 +1785,7 @@ + {pexp_loc = loc; pexp_desc = + Pexp_match({pexp_loc = loc; pexp_desc = + Pexp_ident(Longident.Lident"*opt*")}, +- scases)} in ++ scases, false)} in + let sfun = + {pexp_loc = sexp.pexp_loc; pexp_desc = + Pexp_function(l, None,[{ppat_loc = loc; ppat_desc = Ppat_var"*opt*"}, +@@ -1864,7 +1891,8 @@ + + (* Typing of match cases *) + +-and type_cases ?in_function env ty_arg ty_res partial_loc caselist = ++and type_cases ?in_function ?(multi=false) ++ env ty_arg ty_res partial_loc caselist = + let ty_arg' = newvar () in + let pattern_force = ref [] in + let pat_env_list = +@@ -1898,10 +1926,64 @@ + let cases = + List.map2 + (fun (pat, ext_env) (spat, sexp) -> +- let exp = type_expect ?in_function ext_env sexp ty_res in +- (pat, exp)) +- pat_env_list caselist +- in ++ let add_variant_case lab row ty_res ty_res' = ++ let fi = List.assoc lab (row_repr row).row_fields in ++ begin match row_field_repr fi with ++ Reither (c, _, m, _, e) -> ++ let row' = ++ { row_fields = ++ [lab, Reither(c,[],false,[ty_res,ty_res'], ref None)]; ++ row_more = newvar (); row_bound = [ty_res; ty_res']; ++ row_closed = false; row_fixed = false; row_name = None } ++ in ++ unify_pat ext_env {pat with pat_type= newty (Tvariant row)} ++ (newty (Tvariant row')) ++ | _ -> ++ unify_exp ext_env ++ { exp_desc = Texp_tuple []; exp_type = ty_res; ++ exp_env = ext_env; exp_loc = sexp.pexp_loc } ++ ty_res' ++ end ++ in ++ pat, ++ match pat.pat_desc with ++ _ when multi && all_variants pat -> ++ let ty_res' = newvar () in ++ List.iter ++ (function {pat_desc=Tpat_variant(lab,_,row)} -> ++ add_variant_case lab row ty_res ty_res' ++ | _ -> assert false) ++ (flatten_or_pat pat); ++ type_expect ?in_function ext_env sexp ty_res' ++ | Tpat_alias (p, id) when multi && all_variants p -> ++ let vd = Env.find_value (Path.Pident id) ext_env in ++ let row' = ++ match repr vd.val_type with ++ {desc=Tvariant row'} -> row' ++ | _ -> assert false ++ in ++ begin_def (); ++ let tv = newvar () in ++ let env = Env.add_value id {vd with val_type=tv} ext_env in ++ let exp = type_exp env sexp in ++ end_def (); ++ generalize exp.exp_type; ++ generalize tv; ++ List.iter ++ (function {pat_desc=Tpat_variant(lab,_,row)}, [tv'; ty'] -> ++ let fi' = List.assoc lab (row_repr row').row_fields in ++ let row' = ++ {row' with row_fields=[lab,fi']; row_more=newvar()} in ++ unify_pat ext_env {pat with pat_type=tv'} ++ (newty (Tvariant row')); ++ add_variant_case lab row ty_res ty' ++ | _ -> assert false) ++ (List.map (fun p -> p, instance_list [tv; exp.exp_type]) ++ (flatten_or_pat p)); ++ {exp with exp_type = instance exp.exp_type} ++ | _ -> ++ type_expect ?in_function ext_env sexp ty_res) ++ pat_env_list caselist in + let partial = + match partial_loc with None -> Partial + | Some loc -> Parmatch.check_partial loc cases +Index: typing/typedecl.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typedecl.ml,v +retrieving revision 1.75 +diff -u -r1.75 typedecl.ml +--- typing/typedecl.ml 16 Aug 2005 00:48:56 -0000 1.75 ++++ typing/typedecl.ml 2 Feb 2006 06:28:33 -0000 +@@ -432,8 +432,10 @@ + match Btype.row_field_repr f with + Rpresent (Some ty) -> + compute_same ty +- | Reither (_, tyl, _, _) -> +- List.iter compute_same tyl ++ | Reither (_, tyl, _, tpl, _) -> ++ List.iter compute_same tyl; ++ List.iter (compute_variance_rec true true true) ++ (List.map fst tpl @ List.map snd tpl) + | _ -> ()) + row.row_fields; + compute_same row.row_more +@@ -856,8 +858,8 @@ + explain row.row_fields + (fun (l,f) -> match Btype.row_field_repr f with + Rpresent (Some t) -> t +- | Reither (_,[t],_,_) -> t +- | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl) ++ | Reither (_,[t],_,_,_) -> t ++ | Reither (_,tl,_,_,_) -> Btype.newgenty (Ttuple tl) + | _ -> Btype.newgenty (Ttuple[])) + "case" (fun (lab,_) -> "`" ^ lab ^ " of ") + | _ -> trivial ty' +Index: typing/types.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v +retrieving revision 1.25 +diff -u -r1.25 types.ml +--- typing/types.ml 9 Dec 2004 12:40:53 -0000 1.25 ++++ typing/types.ml 2 Feb 2006 06:28:33 -0000 +@@ -48,7 +48,9 @@ + + and row_field = + Rpresent of type_expr option +- | Reither of bool * type_expr list * bool * row_field option ref ++ | Reither of ++ bool * type_expr list * bool * ++ (type_expr * type_expr) list * row_field option ref + | Rabsent + + and abbrev_memo = +Index: typing/types.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v +retrieving revision 1.25 +diff -u -r1.25 types.mli +--- typing/types.mli 9 Dec 2004 12:40:53 -0000 1.25 ++++ typing/types.mli 2 Feb 2006 06:28:33 -0000 +@@ -47,7 +47,9 @@ + + and row_field = + Rpresent of type_expr option +- | Reither of bool * type_expr list * bool * row_field option ref ++ | Reither of ++ bool * type_expr list * bool * ++ (type_expr * type_expr) list * row_field option ref + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) +Index: typing/typetexp.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v +retrieving revision 1.54 +diff -u -r1.54 typetexp.ml +--- typing/typetexp.ml 22 Jul 2005 06:42:36 -0000 1.54 ++++ typing/typetexp.ml 2 Feb 2006 06:28:33 -0000 +@@ -207,9 +207,9 @@ + match Btype.row_field_repr f with + | Rpresent (Some ty) -> + bound := ty :: !bound; +- Reither(false, [ty], false, ref None) ++ Reither(false, [ty], false, [], ref None) + | Rpresent None -> +- Reither (true, [], false, ref None) ++ Reither (true, [], false, [], ref None) + | _ -> f) + row.row_fields + in +@@ -273,13 +273,16 @@ + (l, f) :: fields + in + let rec add_field fields = function +- Rtag (l, c, stl) -> ++ Rtag (l, c, stl, stpl) -> + name := None; + let f = match present with + Some present when not (List.mem l present) -> +- let tl = List.map (transl_type env policy) stl in +- bound := tl @ !bound; +- Reither(c, tl, false, ref None) ++ let transl_list = List.map (transl_type env policy) in ++ let tl = transl_list stl in ++ let stpl1, stpl2 = List.split stpl in ++ let tpl1 = transl_list stpl1 and tpl2 = transl_list stpl2 in ++ bound := tl @ tpl1 @ tpl2 @ !bound; ++ Reither(c, tl, false, List.combine tpl1 tpl2, ref None) + | _ -> + if List.length stl > 1 || c && stl <> [] then + raise(Error(styp.ptyp_loc, Present_has_conjunction l)); +@@ -311,9 +314,9 @@ + begin match f with + Rpresent(Some ty) -> + bound := ty :: !bound; +- Reither(false, [ty], false, ref None) ++ Reither(false, [ty], false, [], ref None) + | Rpresent None -> +- Reither(true, [], false, ref None) ++ Reither(true, [], false, [], ref None) + | _ -> + assert false + end +@@ -406,7 +409,8 @@ + {row with row_fixed=true; + row_fields = List.map + (fun (s,f as p) -> match Btype.row_field_repr f with +- Reither (c, tl, m, r) -> s, Reither (c, tl, true, r) ++ Reither (c, tl, m, tpl, r) -> ++ s, Reither (c, tl, true, tpl, r) + | _ -> p) + row.row_fields}; + Btype.iter_row make_fixed_univars row +Index: typing/unused_var.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/unused_var.ml,v +retrieving revision 1.5 +diff -u -r1.5 unused_var.ml +--- typing/unused_var.ml 4 Jan 2006 16:55:50 -0000 1.5 ++++ typing/unused_var.ml 2 Feb 2006 06:28:33 -0000 +@@ -122,9 +122,11 @@ + | Pexp_apply (e, lel) -> + expression ppf tbl e; + List.iter (fun (_, e) -> expression ppf tbl e) lel; +- | Pexp_match (e, pel) -> ++ | Pexp_match (e, pel, _) -> + expression ppf tbl e; + match_pel ppf tbl pel; ++ | Pexp_multifun pel -> ++ match_pel ppf tbl pel; + | Pexp_try (e, pel) -> + expression ppf tbl e; + match_pel ppf tbl pel; +Index: bytecomp/matching.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/matching.ml,v +retrieving revision 1.67 +diff -u -r1.67 matching.ml +--- bytecomp/matching.ml 7 Sep 2005 16:07:48 -0000 1.67 ++++ bytecomp/matching.ml 2 Feb 2006 06:28:33 -0000 +@@ -1991,7 +1991,7 @@ + List.iter + (fun (_, f) -> + match Btype.row_field_repr f with +- Rabsent | Reither(true, _::_, _, _) -> () ++ Rabsent | Reither(true, _::_, _, _, _) -> () + | _ -> incr num_constr) + row.row_fields + else +Index: toplevel/genprintval.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/toplevel/genprintval.ml,v +retrieving revision 1.38 +diff -u -r1.38 genprintval.ml +--- toplevel/genprintval.ml 13 Jun 2005 04:55:53 -0000 1.38 ++++ toplevel/genprintval.ml 2 Feb 2006 06:28:33 -0000 +@@ -293,7 +293,7 @@ + | (l, f) :: fields -> + if Btype.hash_variant l = tag then + match Btype.row_field_repr f with +- | Rpresent(Some ty) | Reither(_,[ty],_,_) -> ++ | Rpresent(Some ty) | Reither(_,[ty],_,_,_) -> + let args = + tree_of_val (depth - 1) (O.field obj 1) ty in + Oval_variant (l, Some args) diff --git a/testlabl/multimatch.ml b/testlabl/multimatch.ml index 4add22106..7c9aa73f9 100644 --- a/testlabl/multimatch.ml +++ b/testlabl/multimatch.ml @@ -145,6 +145,7 @@ end = struct let poly = poly end;; (* type dispatch *) +type num = [ `Int | `Float ] let print0 = multifun `Int -> print_int | `Float -> print_float