diff options
author | Jacques Garrigue <garrigue at math.nagoya-u.ac.jp> | 2006-01-16 02:25:50 +0000 |
---|---|---|
committer | Jacques Garrigue <garrigue at math.nagoya-u.ac.jp> | 2006-01-16 02:25:50 +0000 |
commit | 1359a5935384a4fd47636cacdd3f6d64f134eae7 (patch) | |
tree | c1b87e178382702ec21ce4af9454c38aa65af542 /testlabl | |
parent | 7bab155c6e8b28d74123dd1d2831829e23a2971d (diff) |
patch for 3.09.1
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@7326 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
Diffstat (limited to 'testlabl')
-rw-r--r-- | testlabl/objvariant.diffs | 354 |
1 files changed, 354 insertions, 0 deletions
diff --git a/testlabl/objvariant.diffs b/testlabl/objvariant.diffs new file mode 100644 index 000000000..75deb24cd --- /dev/null +++ b/testlabl/objvariant.diffs @@ -0,0 +1,354 @@ +? objvariants-3.09.1.diffs +? objvariants.diffs +Index: btype.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v +retrieving revision 1.37.4.1 +diff -u -r1.37.4.1 btype.ml +--- btype.ml 5 Dec 2005 13:18:42 -0000 1.37.4.1 ++++ btype.ml 16 Jan 2006 02:23:14 -0000 +@@ -177,7 +177,8 @@ + Tvariant row -> iter_row f row + | Tvar | Tunivar | Tsubst _ | Tconstr _ -> + Misc.may (fun (_,l) -> List.iter f l) row.row_name; +- List.iter f row.row_bound ++ List.iter f row.row_bound; ++ List.iter (fun (s,k,t) -> f t) row.row_object + | _ -> assert false + + let iter_type_expr f ty = +@@ -224,7 +225,9 @@ + | Some (path, tl) -> Some (path, List.map f tl) in + { row_fields = fields; row_more = more; + row_bound = !bound; row_fixed = row.row_fixed && fixed; +- row_closed = row.row_closed; row_name = name; } ++ row_closed = row.row_closed; row_name = name; ++ row_object = List.map (fun (s,k,t) -> (s,k,f t)) row.row_object; ++ } + + let rec copy_kind = function + Fvar{contents = Some k} -> copy_kind k +Index: ctype.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v +retrieving revision 1.197.2.6 +diff -u -r1.197.2.6 ctype.ml +--- ctype.ml 15 Dec 2005 02:28:38 -0000 1.197.2.6 ++++ ctype.ml 16 Jan 2006 02:23:15 -0000 +@@ -1421,7 +1421,7 @@ + newgenty + (Tvariant + {row_fields = fields; row_closed = closed; row_more = newvar(); +- row_bound = []; row_fixed = false; row_name = None }) ++ row_bound = []; row_fixed = false; row_name = None; row_object=[]}) + + (**** Unification ****) + +@@ -1724,8 +1724,11 @@ + else None + in + let bound = row1.row_bound @ row2.row_bound in ++ let opairs, _, miss2 = associate_fields row1.row_object row2.row_object in ++ let row_object = row1.row_object @ miss2 in + let row0 = {row_fields = []; row_more = more; row_bound = bound; +- row_closed = closed; row_fixed = fixed; row_name = name} in ++ row_closed = closed; row_fixed = fixed; row_name = name; ++ row_object = row_object } in + let set_more row rest = + let rest = + if closed then +@@ -1758,6 +1761,18 @@ + raise (Unify ((mkvariant [l,f1] true, + mkvariant [l,f2] true) :: trace))) + pairs; ++ List.iter (fun (s,_,ty1,_,ty2) -> unify env ty1 ty2) opairs; ++ if row_object <> [] then begin ++ List.iter ++ (fun (l,f) -> ++ match row_field_repr f with ++ Rpresent (Some ty) -> ++ let fi = build_fields generic_level row_object (newgenvar()) in ++ unify env (newgenty (Tobject (fi, ref None))) ty ++ | Rpresent None -> raise (Unify []) ++ | _ -> ()) ++ (row_repr row1).row_fields ++ end; + with exn -> + log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn + end +@@ -2789,7 +2804,8 @@ + let row = + { row_fields = List.map fst fields; row_more = newvar(); + row_bound = !bound; row_closed = posi; row_fixed = false; +- row_name = if c > Unchanged then None else row.row_name } ++ row_name = if c > Unchanged then None else row.row_name; ++ row_object = [] } + in + (newty (Tvariant row), Changed) + | Tobject (t1, _) -> +Index: oprint.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v +retrieving revision 1.22 +diff -u -r1.22 oprint.ml +--- oprint.ml 23 Mar 2005 03:08:37 -0000 1.22 ++++ oprint.ml 16 Jan 2006 02:23:15 -0000 +@@ -185,7 +185,7 @@ + fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields + | Otyp_stuff s -> fprintf ppf "%s" s + | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s +- | Otyp_variant (non_gen, row_fields, closed, tags) -> ++ | Otyp_variant (non_gen, row_fields, closed, tags, obj) -> + let print_present ppf = + function + None | Some [] -> () +@@ -198,12 +198,17 @@ + ppf fields + | Ovar_name (id, tyl) -> + fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id ++ and print_object ppf obj = ++ if obj <> [] then ++ fprintf ppf "@ as @[<2>< %a >@]" (print_fields (Some false)) obj + in +- fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a ]@]" (if non_gen then "_" else "") ++ fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a%a ]@]" ++ (if non_gen then "_" else "") + (if closed then if tags = None then " " else "< " + else if tags = None then "> " else "? ") + print_fields row_fields + print_present tags ++ print_object obj + | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty -> + fprintf ppf "@[<1>(%a)@]" print_out_type ty + | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> () +Index: outcometree.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v +retrieving revision 1.14 +diff -u -r1.14 outcometree.mli +--- outcometree.mli 23 Mar 2005 03:08:37 -0000 1.14 ++++ outcometree.mli 16 Jan 2006 02:23:15 -0000 +@@ -59,6 +59,7 @@ + | Otyp_var of bool * string + | Otyp_variant of + bool * out_variant * bool * (string list) option ++ * (string * out_type) list + | Otyp_poly of string list * out_type + and out_variant = + | Ovar_fields of (string * bool * out_type list) list +Index: printtyp.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v +retrieving revision 1.139.2.2 +diff -u -r1.139.2.2 printtyp.ml +--- printtyp.ml 7 Dec 2005 23:37:27 -0000 1.139.2.2 ++++ printtyp.ml 16 Jan 2006 02:23:15 -0000 +@@ -244,7 +244,10 @@ + visited_objects := px :: !visited_objects; + match row.row_name with + | Some(p, tyl) when namable_row row -> +- List.iter (mark_loops_rec visited) tyl ++ List.iter (mark_loops_rec visited) tyl; ++ if not (static_row row) then ++ List.iter (fun (s,k,t) -> mark_loops_rec visited t) ++ row.row_object + | _ -> + iter_row (mark_loops_rec visited) {row with row_bound = []} + end +@@ -343,25 +346,27 @@ + | _ -> false) + fields in + let all_present = List.length present = List.length fields in ++ let static = row.row_closed && all_present in ++ let obj = ++ if static then [] else ++ List.map (fun (s,k,t) -> (s, tree_of_typexp sch t)) row.row_object ++ in ++ let tags = if all_present then None else Some (List.map fst present) in + begin match row.row_name with + | Some(p, tyl) when namable_row row -> + let id = tree_of_path p in + let args = tree_of_typlist sch tyl in +- if row.row_closed && all_present then ++ if static then + Otyp_constr (id, args) + else + let non_gen = is_non_gen sch px in +- let tags = +- if all_present then None else Some (List.map fst present) in + Otyp_variant (non_gen, Ovar_name(tree_of_path p, args), +- row.row_closed, tags) ++ row.row_closed, tags, obj) + | _ -> +- let non_gen = +- not (row.row_closed && all_present) && is_non_gen sch px in ++ let non_gen = not static && is_non_gen sch px in + let fields = List.map (tree_of_row_field sch) fields in +- let tags = +- if all_present then None else Some (List.map fst present) in +- Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags) ++ Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, ++ tags, obj) + end + | Tobject (fi, nm) -> + tree_of_typobject sch fi nm +Index: typecore.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v +retrieving revision 1.176.2.2 +diff -u -r1.176.2.2 typecore.ml +--- typecore.ml 11 Dec 2005 09:56:33 -0000 1.176.2.2 ++++ typecore.ml 16 Jan 2006 02:23:15 -0000 +@@ -170,7 +170,8 @@ + (* Force check of well-formedness *) + unify_pat pat.pat_env pat + (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false; +- row_bound=[]; row_fixed=false; row_name=None})); ++ row_bound=[]; row_fixed=false; row_name=None; ++ row_object=[]})); + | _ -> () + + let rec iter_pattern f p = +@@ -251,7 +252,7 @@ + let ty = may_map (build_as_type env) p' in + newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar(); + row_bound=[]; row_name=None; +- row_fixed=false; row_closed=false}) ++ row_fixed=false; row_closed=false; row_object=[]}) + | Tpat_record lpl -> + let lbl = fst(List.hd lpl) in + if lbl.lbl_private = Private then p.pat_type else +@@ -318,7 +319,8 @@ + ([],[]) fields in + let row = + { row_fields = List.rev fields; row_more = newvar(); row_bound = !bound; +- row_closed = false; row_fixed = false; row_name = Some (path, tyl) } ++ row_closed = false; row_fixed = false; row_name = Some (path, tyl); ++ row_object = [] } + in + let ty = newty (Tvariant row) in + let gloc = {loc with Location.loc_ghost=true} in +@@ -428,7 +430,8 @@ + row_closed = false; + row_more = newvar (); + row_fixed = false; +- row_name = None } in ++ row_name = None; ++ row_object = [] } in + rp { + pat_desc = Tpat_variant(l, arg, row); + pat_loc = sp.ppat_loc; +@@ -976,7 +979,8 @@ + row_bound = []; + row_closed = false; + row_fixed = false; +- row_name = None}); ++ row_name = None; ++ row_object = []}); + exp_env = env } + | Pexp_record(lid_sexp_list, opt_sexp) -> + let ty = newvar() in +@@ -1261,8 +1265,30 @@ + assert false + end + | _ -> +- (Texp_send(obj, Tmeth_name met), +- filter_method env met Public obj.exp_type) ++ let obj, met_ty = ++ match expand_head env obj.exp_type with ++ {desc = Tvariant _} -> ++ let exp_ty = newvar () in ++ let met_ty = filter_method env met Public exp_ty in ++ let row = ++ {row_fields=[]; row_more=newvar(); ++ row_bound=[]; row_closed=false; ++ row_fixed=false; row_name=None; ++ row_object=[met, Fpresent, met_ty]} in ++ unify_exp env obj (newty (Tvariant row)); ++ let prim = Primitive.parse_declaration 1 ["%field1"] in ++ let ty = newty(Tarrow("", obj.exp_type, exp_ty, Cok)) in ++ let vd = {val_type = ty; val_kind = Val_prim prim} in ++ let esnd = ++ {exp_desc=Texp_ident(Path.Pident(Ident.create"snd"), vd); ++ exp_loc = Location.none; exp_type = ty; exp_env = env} ++ in ++ ({obj with exp_type = exp_ty; ++ exp_desc = Texp_apply(esnd,[Some obj, Required])}, ++ met_ty) ++ | _ -> (obj, filter_method env met Public obj.exp_type) ++ in ++ (Texp_send(obj, Tmeth_name met), met_ty) + in + if !Clflags.principal then begin + end_def (); +Index: types.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v +retrieving revision 1.25 +diff -u -r1.25 types.ml +--- types.ml 9 Dec 2004 12:40:53 -0000 1.25 ++++ types.ml 16 Jan 2006 02:23:15 -0000 +@@ -44,7 +44,9 @@ + row_bound: type_expr list; + row_closed: bool; + row_fixed: bool; +- row_name: (Path.t * type_expr list) option } ++ row_name: (Path.t * type_expr list) option; ++ row_object: (string * field_kind * type_expr) list; ++ } + + and row_field = + Rpresent of type_expr option +Index: types.mli +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v +retrieving revision 1.25 +diff -u -r1.25 types.mli +--- types.mli 9 Dec 2004 12:40:53 -0000 1.25 ++++ types.mli 16 Jan 2006 02:23:15 -0000 +@@ -43,7 +43,9 @@ + row_bound: type_expr list; + row_closed: bool; + row_fixed: bool; +- row_name: (Path.t * type_expr list) option } ++ row_name: (Path.t * type_expr list) option; ++ row_object: (string * field_kind * type_expr) list; ++ } + + and row_field = + Rpresent of type_expr option +Index: typetexp.ml +=================================================================== +RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v +retrieving revision 1.54 +diff -u -r1.54 typetexp.ml +--- typetexp.ml 22 Jul 2005 06:42:36 -0000 1.54 ++++ typetexp.ml 16 Jan 2006 02:23:15 -0000 +@@ -215,7 +215,8 @@ + in + let row = { row_closed = true; row_fields = fields; + row_bound = !bound; row_name = Some (path, args); +- row_fixed = false; row_more = newvar () } in ++ row_fixed = false; row_more = newvar (); ++ row_object = [] } in + let static = Btype.static_row row in + let row = + if static then row else +@@ -262,7 +263,7 @@ + let mkfield l f = + newty (Tvariant {row_fields=[l,f]; row_more=newvar(); + row_bound=[]; row_closed=true; +- row_fixed=false; row_name=None}) in ++ row_fixed=false; row_name=None; row_object=[]}) in + let add_typed_field loc l f fields = + try + let f' = List.assoc l fields in +@@ -345,7 +346,7 @@ + let row = + { row_fields = List.rev fields; row_more = newvar (); + row_bound = !bound; row_closed = closed; +- row_fixed = false; row_name = !name } in ++ row_fixed = false; row_name = !name; row_object = [] } in + let static = Btype.static_row row in + let row = + if static then row else |