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)