Commits

camlspotter  committed 8049094

make world

  • Participants
  • Parent commits 5b253af
  • Branches local-poly-test

Comments (0)

Files changed (25)

File boot/ocamlc

Binary file modified.

File boot/ocamldep

Binary file modified.

File boot/ocamllex

Binary file modified.

File bytecomp/translmod.ml

   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 fn pos arg =
     match arg with
       [] -> lambda_unit
     | hd :: tl -> Lsequence(fn pos hd, make_sequence fn (pos + 1) tl) in

File camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml

     | ExLab loc _ _ -> error loc "labeled expression not allowed here"
     | ExLaz loc e -> mkexp loc (Pexp_lazy (expr e))
     | ExLet loc rf bi e ->
-        mkexp loc (Pexp_let (mkrf rf) (binding bi []) (expr e))
+        mkexp loc (Pexp_let (mkrf rf) (binding bi []) (expr e) True)
     | ExLmd loc i me e -> mkexp loc (Pexp_letmodule (with_loc i loc) (module_expr me) (expr e))
     | ExMat loc e a -> mkexp loc (Pexp_match (expr e) (match_case a []))
     | ExNew loc id -> mkexp loc (Pexp_new (long_type_ident id))

File camlp4/boot/Camlp4.ml

                   error loc "labeled expression not allowed here"
               | ExLaz (loc, e) -> mkexp loc (Pexp_lazy (expr e))
               | ExLet (loc, rf, bi, e) ->
-                  mkexp loc (Pexp_let ((mkrf rf), (binding bi []), (expr e)))
+                  mkexp loc (Pexp_let ((mkrf rf), (binding bi []), (expr e), true))
               | ExLmd (loc, i, me, e) ->
                   mkexp loc
                     (Pexp_letmodule ((with_loc i loc), (module_expr me),

File parsing/parser.mly

   | simple_expr simple_labeled_expr_list
       { mkexp(Pexp_apply($1, List.rev $2)) }
   | LET rec_flag let_bindings IN seq_expr
-      { mkexp(Pexp_let($2, List.rev $3, $5)) }
+      { mkexp(Pexp_let($2, List.rev $3, $5, false)) }
+  | LET BANG rec_flag let_bindings IN seq_expr
+        { mkexp(Pexp_let($3, List.rev $4, $6, true)) }
   | LET MODULE UIDENT module_binding IN seq_expr
       { mkexp(Pexp_letmodule(mkrhs $3 3, $4, $6)) }
   | LET OPEN mod_longident IN seq_expr

File parsing/parsetree.mli

 and expression_desc =
     Pexp_ident of Longident.t loc
   | Pexp_constant of constant
-  | Pexp_let of rec_flag * (pattern * expression) list * expression
+  | Pexp_let of rec_flag * (pattern * expression) list * expression * bool (* poly or not *)
   | Pexp_function of label * expression option * (pattern * expression) list
   | Pexp_apply of expression * (label * expression) list
   | Pexp_match of expression * (pattern * expression) list

File parsing/printast.ml

   match x.pexp_desc with
   | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident li;
   | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c;
-  | Pexp_let (rf, l, e) ->
+  | Pexp_let (rf, l, e, _poly) ->
       line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
       list i pattern_x_expression_def ppf l;
       expression i ppf e;

File stdlib/arg.ml

   let l = Array.length argv in
   let b = Buffer.create 200 in
   let initpos = !current in
-  let stop error =
+  let! stop error =
     let progname = if initpos < l then argv.(initpos) else "(?)" in
     begin match error with
       | Unknown "-help" -> ()

File stdlib/camlinternalOO.ml

   init_table.env_init <- env_init
 
 let dummy_class loc =
-  let undef = fun _ -> raise (Undefined_recursive_module loc) in
+  let! undef = fun _ -> raise (Undefined_recursive_module loc) in
   (Obj.magic undef, undef, undef, Obj.repr 0)
 
 (**** Objects ****)

File stdlib/printf.ml

    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 spec n =
     Obj.magic (args.(Sformat.int_of_index (get_index spec n))) in
 
   let rec scan_positional n widths i =

File stdlib/scanf.ml

 
   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! stack f = delay (return f) in
+  let! no_stack f _x = f in
 
   let rec scan fmt =
 
       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 = 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

File tools/depend.ml

   match exp.pexp_desc with
     Pexp_ident l -> add bv l
   | Pexp_constant _ -> ()
-  | Pexp_let(rf, pel, e) ->
+  | Pexp_let(rf, pel, e, _) ->
       let bv = add_bindings rf bv pel in add_expr bv e
   | Pexp_function (_, opte, pel) ->
       add_opt add_expr bv opte; add_pat_expr_list bv pel

File tools/ocamlprof.ml

     Pexp_ident lid -> ()
   | Pexp_constant cst -> ()
 
-  | Pexp_let(_, spat_sexp_list, sbody) ->
+  | Pexp_let(_, spat_sexp_list, sbody, _) ->
     rewrite_patexp_list iflag spat_sexp_list;
     rewrite_exp iflag sbody
 

File tools/pprintast.ml

 
 and expression ppf x =
   match x.pexp_desc with
-  | Pexp_let (rf, l, e) ->
+  | Pexp_let (rf, l, e, _) ->
       let l1 = (List.hd l) in
       let l2 = (List.tl l) in
       pp_open_hvbox ppf 0 ;
         { ppat_desc = Ppat_var { txt ="*opt*" } },
         { pexp_desc = Pexp_let (_, [
               arg ,
-              { pexp_desc = Pexp_match (_, [ _; _, eo ] ) } ], e) }
+              { pexp_desc = Pexp_match (_, [ _; _, eo ] ) } ], e, false) }
       ]
     ) ->
       expression ppf { x with pexp_desc = Pexp_function(label, Some eo,

File tools/untypeast.ml

         Pexp_let (rec_flag,
           List.map (fun (pat, exp) ->
               untype_pattern pat, untype_expression exp) list,
-          untype_expression exp)
+          untype_expression exp, false)
     | Texp_function (label, cases, _) ->
         Pexp_function (label, None,
           List.map (fun (pat, exp) ->

File typing/includecore.ml

   string_of_int n ^ "th"
 
 let report_type_mismatch0 first second decl ppf err =
-  let pr fmt = Format.fprintf ppf fmt in
+  let! pr fmt = Format.fprintf ppf fmt in
   match err with
     Arity -> pr "They have different arities"
   | Privacy -> pr "A private type would be revealed"

File typing/typecore.ml

     | Pexp_function (_, eo, pel) ->
         may expr eo; List.iter (fun (_, e) -> expr e) pel
     | Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel
-    | Pexp_let (_, pel, e)
+    | Pexp_let (_, pel, e, _)
     | Pexp_match (e, pel)
     | Pexp_try (e, pel) -> expr e; List.iter (fun (_, e) -> expr e) pel
     | Pexp_array el
 
 let rec type_approx env sexp =
   match sexp.pexp_desc with
-    Pexp_let (_, _, e) -> type_approx env e
+    Pexp_let (_, _, e, _) -> type_approx env e
   | Pexp_function (p,_,(_,e)::_) when is_optional p ->
        newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok))
   | Pexp_function (p,_,(_,e)::_) ->
         exp_loc = loc; exp_extra = [];
         exp_type = type_constant cst;
         exp_env = env }
-  | Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat ->
+  | Pexp_let(Nonrecursive, [spat, sval], sbody, _) when contains_gadt env spat ->
       type_expect ?in_function env
         {sexp with pexp_desc = Pexp_match (sval, [spat, sbody])}
         ty_expected
-  | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
+  | Pexp_let(rec_flag, spat_sexp_list, sbody, poly) ->
       let scp =
         match rec_flag with
         | Recursive -> Some (Annot.Idef loc)
         | Default -> None
       in
       let (pat_exp_list, new_env, unpacks) =
-        type_let env rec_flag spat_sexp_list scp true in
+        type_let ~polymorphism:poly env rec_flag spat_sexp_list scp true in
       let body =
         type_expect new_env (wrap_unpacks sbody unpacks) ty_expected in
       re {
            [ {ppat_loc = loc;
               ppat_desc = Ppat_var (mknoloc "*opt*")},
              {pexp_loc = loc;
-              pexp_desc = Pexp_let(Default, [spat, smatch], sbody);
+              pexp_desc = Pexp_let(Default, [spat, smatch], sbody, false);
              }
            ]
          )
 
 (* Typing of let bindings *)
 
-and type_let ?(top=false)
+and type_let ?(polymorphism=true)
              ?(check = fun s -> Warnings.Unused_var s)
              ?(check_strict = fun s -> Warnings.Unused_var_strict s)
     env rec_flag spat_sexp_list scope allow =
+ let polymorphism = true in
   begin_def();
   if !Clflags.principal then begin_def ();
 
     (fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [pat, exp]))
     pat_list exp_list;
   end_def();
-  let top = 
-    top || 
-      match String.capitalize(Filename.basename(chop_extension_if_any !Location.input_name)) with
-      | "Scanf" | "Printf" | "Arg" | "CamlinternalOO" | "Includecore" -> true
-      | _ -> false
-  in
-  if top then begin
+  if polymorphism then begin
   List.iter2
     (fun pat exp ->
        if not (is_nonexpansive exp) then
   Typetexp.reset_type_variables();
   let (pat_exp_list, new_env, unpacks) =
     type_let
-      ~top:true
+      ~polymorphism: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

File typing/typemod.ml

     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 env_c curr =
     List.map2
       (fun (_,smty) (id,id_loc,mty) -> (id, id_loc, transl_modtype env_c smty))
       sdecls curr in