Test not generalizing local lets

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14038 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
2013-08-28 09:59:11 +00:00 · 2013-08-28 09:59:11 +00:00 · a18853fde9
parent cb1d7a036d
commit a18853fde9
1 changed files with 428 additions and 0 deletions
--- a/experimental/garrigue/nongeneral-let.diff
+++ b/experimental/garrigue/nongeneral-let.diff
@ -0,0 +1,428 @@
+Index: camlp4/Camlp4/Struct/Grammar/Delete.ml
+===================================================================
+--- camlp4/Camlp4/Struct/Grammar/Delete.ml	(revision 14037)
+++ camlp4/Camlp4/Struct/Grammar/Delete.ml	(working copy)
+@@ -35,17 +35,17 @@
+   open Structure;
+ 
+ value raise_rule_not_found entry symbols =
+-  let to_string f x =
+  let to_string : !'a. (_ -> 'a -> _) -> 'a -> _ = fun [f -> fun [x ->
+     let buff = Buffer.create 128 in
+     let ppf = Format.formatter_of_buffer buff in
+     do {
+       f ppf x;
+       Format.pp_print_flush ppf ();
+       Buffer.contents buff
+-    } in
+-    let entry = to_string Print.entry entry in
+-    let symbols = to_string Print.print_rule symbols in
+-    raise (Rule_not_found (symbols, entry))
+    }]] in
+  let entry = to_string Print.entry entry in
+  let symbols = to_string Print.print_rule symbols in
+  raise (Rule_not_found (symbols, entry))
+ ;
+ 
+ (* Deleting a rule *)
+Index: camlp4/boot/Camlp4.ml
+===================================================================
+--- camlp4/boot/Camlp4.ml	(revision 14037)
+++ camlp4/boot/Camlp4.ml	(working copy)
+@@ -18022,7 +18022,7 @@
+                 open Structure
+                   
+                 let raise_rule_not_found entry symbols =
+-                  let to_string f x =
+                  let to_string : 'a. (_ -> 'a -> _) -> 'a -> _ = fun f x ->
+                     let buff = Buffer.create 128 in
+                     let ppf = Format.formatter_of_buffer buff
+                     in
+Index: camlp4/Camlp4Filters/Camlp4FoldGenerator.ml
+===================================================================
+--- camlp4/Camlp4Filters/Camlp4FoldGenerator.ml	(revision 14037)
+++ camlp4/Camlp4Filters/Camlp4FoldGenerator.ml	(working copy)
+@@ -547,14 +547,18 @@
+ 
+   value processor =
+     let last = ref <:ctyp<>> in
+-    let generate_class' generator default c s n =
+    let generate_class'
+      : !'a 'b. (_ -> 'a -> _ -> _ -> 'b) -> 'b -> 'a -> _ -> _ -> 'b =
+      fun generator default c s n ->
+       match s with
+       [ "Fold"    -> generator Fold c last.val n
+       | "Map"     -> generator Map c last.val n
+       | "FoldMap" -> generator Fold_map c last.val n
+       | _ -> default ]
+     in
+-    let generate_class_from_module_name generator c default m =
+    let generate_class_from_module_name
+      : !'a 'b. (_ -> 'a -> _ -> _ -> 'b) -> 'a -> 'b -> _ -> 'b =
+      fun generator c default m ->
+       try Scanf.sscanf m "Camlp4%[^G]Generator" begin fun m' ->
+         try Scanf.sscanf m' "%[^0-9]%d" (generate_class' generator default c)
+         with [ End_of_file | Scanf.Scan_failure _ -> generate_class' generator default c m' 1 ]
+Index: stdlib/arg.ml
+===================================================================
+--- stdlib/arg.ml	(revision 14037)
+++ stdlib/arg.ml	(working copy)
+@@ -106,7 +106,7 @@
+   let l = Array.length argv in
+   let b = Buffer.create 200 in
+   let initpos = !current in
+-  let stop error =
+  let stop : 'a. _ -> 'a = fun error ->
+     let progname = if initpos < l then argv.(initpos) else "(?)" in
+     begin match error with
+       | Unknown "-help" -> ()
+Index: stdlib/printf.ml
+===================================================================
+--- stdlib/printf.ml	(revision 14037)
+++ stdlib/printf.ml	(working copy)
+@@ -492,7 +492,7 @@
+    Don't do this at home, kids. *)
+ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
+ 
+-  let get_arg spec n =
+  let get_arg : 'a. _ -> _ -> 'a = fun spec n ->
+     Obj.magic (args.(Sformat.int_of_index (get_index spec n))) in
+ 
+   let rec scan_positional n widths i =
+Index: stdlib/camlinternalOO.ml
+===================================================================
+--- stdlib/camlinternalOO.ml	(revision 14037)
+++ stdlib/camlinternalOO.ml	(working copy)
+@@ -349,7 +349,7 @@
+   init_table.env_init <- env_init
+ 
+ let dummy_class loc =
+-  let undef = fun _ -> raise (Undefined_recursive_module loc) in
+  let undef : 'a 'b.'a -> 'b = fun _ -> raise (Undefined_recursive_module loc) in
+   (Obj.magic undef, undef, undef, Obj.repr 0)
+ 
+ (**** Objects ****)
+@@ -527,7 +527,7 @@
+   | Closure of closure
+ 
+ let method_impl table i arr =
+-  let next () = incr i; magic arr.(!i) in
+  let next : 'a. unit -> 'a = fun () -> incr i; magic arr.(!i) in
+   match next() with
+     GetConst -> let x : t = next() in get_const x
+   | GetVar   -> let n = next() in get_var n
+Index: stdlib/scanf.ml
+===================================================================
+--- stdlib/scanf.ml	(revision 14037)
+++ stdlib/scanf.ml	(working copy)
+@@ -1324,10 +1324,11 @@
+ 
+   let limr = Array.length rv - 1 in
+ 
+-  let return v = Obj.magic v () in
+-  let delay f x () = f x in
+-  let stack f = delay (return f) in
+-  let no_stack f _x = f in
+  let return : 'a 'b 'c. ('a -> 'b) -> 'c = fun v -> Obj.magic v () in
+  let delay : 'a 'b. ('a -> 'b) -> 'a -> unit -> 'b = fun f x () -> f x in
+  let stack : 'a 'b 'd 'e. ('a -> 'b) -> 'd -> unit -> 'e =
+    fun f -> delay (return f) in
+  let no_stack : 'a 'b. 'a -> 'b -> 'a = fun f _x -> f in
+ 
+   let rec scan fmt =
+ 
+@@ -1380,7 +1381,8 @@
+       scan_conversion skip width_opt prec_opt ir f i
+ 
+     and scan_conversion skip width_opt prec_opt ir f i =
+-      let stack = if skip then no_stack else stack in
+      let stack : 'b 'd. (unit -> 'b) -> 'd -> unit -> 'b =
+        if skip then no_stack else stack in
+       let width = int_of_width_opt width_opt in
+       let prec = int_of_prec_opt prec_opt in
+       match Sformat.get fmt i with
+Index: typing/typemod.ml
+===================================================================
+--- typing/typemod.ml	(revision 14037)
+++ typing/typemod.ml	(working copy)
+@@ -420,7 +420,7 @@
+ 
+ (* let signature sg = List.map (fun item -> item.sig_type) sg *)
+ 
+-let rec transl_modtype env smty =
+let rec transl_modtype env smty : Typedtree.module_type =
+   let loc = smty.pmty_loc in
+   match smty.pmty_desc with
+     Pmty_ident lid ->
+@@ -609,7 +609,7 @@
+     List.fold_left
+       (fun env (id, _, mty) -> Env.add_module id mty.mty_type env)
+       env curr in
+-  let transition env_c curr =
+  let transition : 'a. _ -> (_ * _ * 'a) list -> _ = fun env_c curr ->
+     List.map2
+       (fun (_,smty) (id,id_loc,mty) -> (id, id_loc, transl_modtype env_c smty))
+       sdecls curr in
+Index: typing/typecore.ml
+===================================================================
+--- typing/typecore.ml	(revision 14037)
+++ typing/typecore.ml	(working copy)
+@@ -1373,9 +1373,9 @@
+ 
+   let ty_arrow gty ty = newty (Tarrow ("", instance_def gty, ty, Cok)) in
+ 
+-  let bad_conversion fmt i c =
+  let bad_conversion : 'a. string -> int -> char -> 'a = fun fmt i c ->
+     raise (Error (loc, Env.empty, Bad_conversion (fmt, i, c))) in
+-  let incomplete_format fmt =
+  let incomplete_format : 'a. string -> 'a = fun fmt ->
+     raise (Error (loc, Env.empty, Incomplete_format fmt)) in
+ 
+   let rec type_in_format fmt =
+@@ -3238,7 +3238,7 @@
+ 
+ (* Typing of let bindings *)
+ 
+-and type_let ?(check = fun s -> Warnings.Unused_var s)
+and type_let ?(global=false) ?(check = fun s -> Warnings.Unused_var s)
+              ?(check_strict = fun s -> Warnings.Unused_var_strict s)
+     env rec_flag spat_sexp_list scope allow =
+   begin_def();
+@@ -3368,7 +3368,7 @@
+         )
+       pat_list
+   in
+-  let exp_list =
+  let exp_gen_list =
+     List.map2
+       (fun (spat, sexp) (pat, slot) ->
+         let sexp =
+@@ -3386,9 +3386,12 @@
+             let exp = type_expect exp_env sexp ty' in
+             end_def ();
+             check_univars env true "definition" exp pat.pat_type vars;
+-            {exp with exp_type = instance env exp.exp_type}
+-        | _ -> type_expect exp_env sexp pat.pat_type)
+            {exp with exp_type = instance env exp.exp_type}, true
+        | _ ->
+            type_expect exp_env sexp pat.pat_type,
+            match sexp.pexp_desc with Pexp_ident _ -> true | _ -> false)
+       spat_sexp_list pat_slot_list in
+  let exp_list, gen_list = List.split exp_gen_list in
+   current_slot := None;
+   if is_recursive && not !rec_needed
+   && Warnings.is_active Warnings.Unused_rec_flag then
+@@ -3399,10 +3402,12 @@
+     pat_list exp_list;
+   end_def();
+   List.iter2
+-    (fun pat exp ->
+-       if not (is_nonexpansive exp) then
+    (fun pat (exp, gen) ->
+       if not (global || gen) then
+         iter_pattern (fun pat -> generalize_structure pat.pat_type) pat
+       else if not (is_nonexpansive exp) then
+          iter_pattern (fun pat -> generalize_expansive env pat.pat_type) pat)
+-    pat_list exp_list;
+    pat_list exp_gen_list;
+   List.iter
+     (fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat)
+     pat_list;
+@@ -3413,7 +3418,7 @@
+ let type_binding env rec_flag spat_sexp_list scope =
+   Typetexp.reset_type_variables();
+   let (pat_exp_list, new_env, unpacks) =
+-    type_let
+    type_let ~global:true
+       ~check:(fun s -> Warnings.Unused_value_declaration s)
+       ~check_strict:(fun s -> Warnings.Unused_value_declaration s)
+       env rec_flag spat_sexp_list scope false
+Index: typing/includecore.ml
+===================================================================
+--- typing/includecore.ml	(revision 14037)
+++ typing/includecore.ml	(working copy)
+@@ -123,7 +123,8 @@
+   | Record_representation of bool
+ 
+ let report_type_mismatch0 first second decl ppf err =
+-  let pr fmt = Format.fprintf ppf fmt in
+  let pr : 'a. ('a, Format.formatter, unit) format -> 'a
+      = fun fmt -> Format.fprintf ppf fmt in
+   match err with
+     Arity -> pr "They have different arities"
+   | Privacy -> pr "A private type would be revealed"
+Index: ocamldoc/odoc_html.ml
+===================================================================
+--- ocamldoc/odoc_html.ml	(revision 14037)
+++ ocamldoc/odoc_html.ml	(working copy)
+@@ -508,7 +508,7 @@
+       bs b "</table>\n"
+ 
+     method html_of_Index_list b =
+-      let index_if_not_empty l url m =
+      let index_if_not_empty : 'a. 'a list -> _ = fun l url m ->
+         match l with
+           [] -> ()
+         | _ -> bp b "<li><a href=\"%s\">%s</a></li>\n" url m
+@@ -977,7 +977,7 @@
+     (** A function to build the header of pages. *)
+     method prepare_header module_list =
+       let f b ?(nav=None) ?(comments=[]) t  =
+-        let link_if_not_empty l m url =
+        let link_if_not_empty : 'a. 'a list -> _ = fun l m url ->
+           match l with
+             [] -> ()
+           | _ ->
+Index: bytecomp/translmod.ml
+===================================================================
+--- bytecomp/translmod.ml	(revision 14037)
+++ bytecomp/translmod.ml	(working copy)
+@@ -773,7 +773,8 @@
+   Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)])
+ 
+ let transl_store_package component_names target_name coercion =
+-  let rec make_sequence fn pos arg =
+  let rec make_sequence : 'a. (int -> 'a -> _) -> int -> 'a list -> _ =
+    fun fn pos arg ->
+     match arg with
+       [] -> lambda_unit
+     | hd :: tl -> Lsequence(fn pos hd, make_sequence fn (pos + 1) tl) in
+Index: otherlibs/labltk/jpf/jpf_font.ml
+===================================================================
+--- otherlibs/labltk/jpf/jpf_font.ml	(revision 14037)
+++ otherlibs/labltk/jpf/jpf_font.ml	(working copy)
+@@ -131,7 +131,7 @@
+   }
+ 
+ let string_of_pattern =
+-  let pat f = function
+  let pat : 'a. ('a -> string) -> 'a option -> string = fun f -> function
+       Some x -> f x
+     | None -> "*"
+   in
+Index: otherlibs/labltk/browser/searchid.ml
+===================================================================
+--- otherlibs/labltk/browser/searchid.ml	(revision 14037)
+++ otherlibs/labltk/browser/searchid.ml	(working copy)
+@@ -396,7 +396,7 @@
+ let search_string_symbol text =
+   if text = "" then [] else
+   let lid = snd (longident_of_string text) [] in
+-  let try_lookup f k =
+  let try_lookup : 'a. _ -> 'a -> (_ * 'a) list = fun f k ->
+     try let _ = f lid Env.initial in [lid, k]
+     with Not_found | Env.Error _ -> []
+   in
+Index: otherlibs/labltk/browser/setpath.ml
+===================================================================
+--- otherlibs/labltk/browser/setpath.ml	(revision 14037)
+++ otherlibs/labltk/browser/setpath.ml	(working copy)
+@@ -117,12 +117,12 @@
+   bind_space_toggle dirbox;
+   bind_space_toggle pathbox;
+ 
+-  let add_paths _ =
+  let add_paths : 'a. 'a -> unit = fun _ ->
+     add_to_path pathbox ~base:!current_dir
+       ~dirs:(List.map (Listbox.curselection dirbox)
+               ~f:(fun x -> Listbox.get dirbox ~index:x));
+     Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End
+-  and remove_paths _ =
+  and remove_paths : 'a. 'a -> unit = fun _ ->
+     remove_path pathbox
+       ~dirs:(List.map (Listbox.curselection pathbox)
+               ~f:(fun x -> Listbox.get pathbox ~index:x))
+Index: otherlibs/labltk/browser/viewer.ml
+===================================================================
+--- otherlibs/labltk/browser/viewer.ml	(revision 14037)
+++ otherlibs/labltk/browser/viewer.ml	(working copy)
+@@ -507,7 +507,8 @@
+       if i < 3 then Listbox.delete box ~first:(`Num 0) ~last:`End
+       else destroy fm
+     done;
+-    let rec firsts n = function [] -> []
+    let rec firsts : 'a. int -> 'a list -> 'a list = fun n -> function
+        [] -> []
+       | a :: l -> if n > 0 then a :: firsts (pred n) l else [] in
+     shown_paths <- firsts (n-1) shown_paths;
+     boxes <- firsts (max 3 n) boxes
+Index: otherlibs/labltk/frx/frx_req.ml
+===================================================================
+--- otherlibs/labltk/frx/frx_req.ml	(revision 14037)
+++ otherlibs/labltk/frx/frx_req.ml	(working copy)
+@@ -40,7 +40,7 @@
+   let e =
+     Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in
+ 
+-  let activate _ =
+  let activate : 'a. 'a -> unit = fun _ ->
+     let v = Entry.get e in
+      Grab.release t;                    (* because of wm *)
+      destroy t;                         (* so action can call open_simple *)
+@@ -77,7 +77,7 @@
+ 
+   let waiting = Textvariable.create_temporary t in
+ 
+-  let activate _ =
+  let activate : 'a. 'a -> unit = fun _ ->
+      Grab.release t;                    (* because of wm *)
+      destroy t;                         (* so action can call open_simple *)
+      Textvariable.set waiting "1" in
+@@ -125,7 +125,7 @@
+     Listbox.insert lb End elements;
+ 
+   (* activation: we have to break() because we destroy the requester *)
+-  let activate _ =
+  let activate : 'a. 'a -> unit = fun _ ->
+     let l = List.map (Listbox.get lb) (Listbox.curselection lb) in
+     Grab.release t;
+     destroy t;
+Index: otherlibs/labltk/support/rawwidget.ml
+===================================================================
+--- otherlibs/labltk/support/rawwidget.ml	(revision 14037)
+++ otherlibs/labltk/support/rawwidget.ml	(working copy)
+@@ -67,7 +67,7 @@
+ (* This one is always created by opentk *)
+ let default_toplevel =
+   let wname = "." in
+-  let w = Typed (wname, "toplevel") in
+  let w : 'a. 'a raw_widget = Typed (wname, "toplevel") in
+     Hashtbl.add table wname w;
+     w
+ 
+@@ -145,7 +145,7 @@
+           then "." ^ name
+           else parentpath ^ "." ^ name
+     in
+-      let w = Typed(path,clas) in
+      let w :'a. 'a raw_widget = Typed(path,clas) in
+         Hashtbl.add table path w;
+         w
+ 
+Index: ocamlbuild/rule.ml
+===================================================================
+--- ocamlbuild/rule.ml	(revision 14037)
+++ ocamlbuild/rule.ml	(working copy)
+@@ -260,7 +260,8 @@
+                      which is deprecated and ignored."
+           name
+   in
+-  let res_add import xs xopt =
+  let res_add : 'b. ('a -> 'b) -> 'a list -> 'a option -> 'b list =
+    fun import xs xopt ->
+     let init =
+       match xopt with
+       | None -> []
+Index: ocamlbuild/main.ml
+===================================================================
+--- ocamlbuild/main.ml	(revision 14037)
+++ ocamlbuild/main.ml	(working copy)
+@@ -50,7 +50,7 @@
+ let show_documentation () =
+   let rules = Rule.get_rules () in
+   let flags = Flags.get_flags () in
+-  let pp fmt = Log.raw_dprintf (-1) fmt in
+  let pp : 'a. ('a,_,_) format -> 'a = fun fmt -> Log.raw_dprintf (-1) fmt in
+   List.iter begin fun rule ->
+     pp "%a@\n@\n" (Rule.pretty_print Resource.print_pattern) rule
+   end rules;