summaryrefslogtreecommitdiffstats
path: root/testlabl
diff options
context:
space:
mode:
authorJacques Garrigue <garrigue at math.nagoya-u.ac.jp>2006-01-16 02:25:50 +0000
committerJacques Garrigue <garrigue at math.nagoya-u.ac.jp>2006-01-16 02:25:50 +0000
commit1359a5935384a4fd47636cacdd3f6d64f134eae7 (patch)
treec1b87e178382702ec21ce4af9454c38aa65af542 /testlabl
parent7bab155c6e8b28d74123dd1d2831829e23a2971d (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.diffs354
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