Initial commit.

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/monadic_let@13366 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

20 files changed, 321 insertions, 61 deletions

diff --git a/Changes b/Changes
index 8a62d4f0f8..04ea2d4f59 100644
--- a/Changes
+++ b/Changes
@@ -160,6 +160,11 @@ Language features:
   Using the -principal option guarantees forward compatibility.
 - New (module M) and (module M : S) syntax in patterns, for immediate
   unpacking of a first-class module.
+- Monadic notation with let! syntax. Expects standard `bind', `ret'
+  and `fail' bound in current environment. Supports irrefutable
+  patterns with default fail interface, where failing argument can be
+  defined in with clause. Supports direct optimisations of the created
+  closures.
 
 Compilers:
 - Revised simplification of let-alias (PR#5205, PR#5288)
diff --git a/boot/ocamlc b/boot/ocamlc
index bbf2d1f90f..5d32a54c5d 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index 89aaaca2ad..d18f8937bd 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index 084339c622..b750a3bc2b 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 4e8de1ba16..a80e71075f 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -629,6 +629,8 @@ and transl_exp0 e =
       Lconst(Const_base cst)
   | Texp_let(rec_flag, pat_expr_list, body) ->
       transl_let rec_flag pat_expr_list (event_before body (transl_exp body))
+  | Texp_monadic(pat_expr_list, body) ->
+    transl_monadic pat_expr_list (event_before body (transl_exp body))
   | Texp_function (_, pat_expr_list, partial) ->
       let ((kind, params), body) =
         event_function e
@@ -987,6 +989,14 @@ and transl_let rec_flag pat_expr_list body =
         (id, lam) in
       Lletrec(List.map2 transl_case pat_expr_list idlist, body)
 
+and transl_monadic pat_expr_list body =
+  let rec transl = function
+        [] ->
+          body
+      | (pat, expr) :: rem ->
+          Matching.for_let pat.pat_loc (transl_exp expr) pat (transl rem)
+      in transl pat_expr_list
+
 and transl_setinstvar self var expr =
   Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray),
                     [self; transl_path var; transl_exp expr])
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 6ba813c4cb..9cbe068926 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -745,6 +745,13 @@ and search_pos_expr ~pos exp =
         search_pos_expr exp' ~pos
       end;
       search_pos_expr exp ~pos
+  | Texp_monadic (expl, exp) ->
+      List.iter expl ~f:
+      begin fun (pat, exp') ->
+        search_pos_pat pat ~pos ~env:exp.exp_env;
+        search_pos_expr exp' ~pos
+      end;
+      search_pos_expr exp ~pos
   | Texp_function (_, l, _) ->
       List.iter l ~f:
       begin fun (pat, exp) ->
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index 3cb24a45ab..8eb499375c 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -258,6 +258,7 @@ module E = struct
   let ident ?loc a = mk ?loc (Pexp_ident a)
   let constant ?loc a = mk ?loc (Pexp_constant a)
   let let_ ?loc a b c = mk ?loc (Pexp_let (a, b, c))
+  let monadic ?loc a b = mk ?loc (Pexp_monadic (a, b))
   let function_ ?loc a b c = mk ?loc (Pexp_function (a, b, c))
   let apply ?loc a b = mk ?loc (Pexp_apply (a, b))
   let match_ ?loc a b = mk ?loc (Pexp_match (a, b))
@@ -299,6 +300,7 @@ module E = struct
     | Pexp_ident x -> ident ~loc (map_loc sub x)
     | Pexp_constant x -> constant ~loc x
     | Pexp_let (r, pel, e) -> let_ ~loc r (List.map (map_tuple (sub # pat) (sub # expr)) pel) (sub # expr e)
+    | Pexp_monadic (pel, e) -> monadic ~loc (List.map (map_tuple (sub # pat) (sub # expr)) pel) (sub # expr e)
     | Pexp_function (lab, def, pel) -> function_ ~loc lab (map_opt (sub # expr) def) (List.map (map_tuple (sub # pat) (sub # expr)) pel)
     | Pexp_apply (e, l) -> apply ~loc (sub # expr e) (List.map (map_snd (sub # expr)) l)
     | Pexp_match (e, l) -> match_ ~loc (sub # expr e) (List.map (map_tuple (sub # pat) (sub # expr)) l)
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 9d13b52a9a..38c7a926c4 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -967,6 +967,8 @@ expr:
       { mkexp(Pexp_apply($1, List.rev $2)) }
   | LET rec_flag let_bindings IN seq_expr
       { mkexp(Pexp_let($2, List.rev $3, $5)) }
+  | LET STAR let_bindings IN seq_expr
+      { mkexp(Pexp_monadic ($3, $5)) }
   | LET MODULE UIDENT module_binding IN seq_expr
       { mkexp(Pexp_letmodule(mkrhs $3 3, $4, $6)) }
   | LET OPEN mod_longident IN seq_expr
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index b802fc85a0..7aaaa1679d 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -88,6 +88,7 @@ and expression_desc =
     Pexp_ident of Longident.t loc
   | Pexp_constant of constant
   | Pexp_let of rec_flag * (pattern * expression) list * expression
+  | Pexp_monadic of (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
diff --git a/parsing/printast.ml b/parsing/printast.ml
index d217de18c3..5361cd9ff3 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -230,6 +230,10 @@ and expression i ppf x =
       line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
       list i pattern_x_expression_def ppf l;
       expression i ppf e;
+  | Pexp_monadic (l, e) ->
+      line i ppf "Pexp_monadic\n" ;
+      list i pattern_x_expression_def ppf l;
+      expression i ppf e;
   | Pexp_function (p, eo, l) ->
       line i ppf "Pexp_function \"%s\"\n" p;
       option i expression ppf eo;
diff --git a/tools/depend.ml b/tools/depend.ml
index 3e0c8b3863..56240928e1 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -134,6 +134,8 @@ let rec add_expr bv exp =
   | Pexp_constant _ -> ()
   | Pexp_let(rf, pel, e) ->
       let bv = add_bindings rf bv pel in add_expr bv e
+  | Pexp_monadic(pel, e) ->
+      let bv = add_bindings Default bv pel in add_expr bv e
   | Pexp_function (_, opte, pel) ->
       add_opt add_expr bv opte; add_pat_expr_list bv pel
   | Pexp_apply(e, el) ->
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index 16f9def1fc..da9bcee941 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -172,6 +172,10 @@ and rw_exp iflag sexp =
     rewrite_patexp_list iflag spat_sexp_list;
     rewrite_exp iflag sbody
 
+  | Pexp_monadic(spat_sexp_list, sbody) ->
+    rewrite_patexp_list iflag spat_sexp_list;
+    rewrite_exp iflag sbody
+
   | Pexp_function (_, _, caselist) ->
     if !instr_fun then
       rewrite_function iflag caselist
diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml
index b02a4d2df3..7fe2d8a750 100644
--- a/tools/tast_iter.ml
+++ b/tools/tast_iter.ml
@@ -97,6 +97,9 @@ let expression sub exp =
   | Texp_let (rec_flag, list, exp) ->
       sub # bindings (rec_flag, list);
       sub # expression exp
+  | Texp_monadic (list, exp) ->
+      sub # bindings (Default, list);
+      sub # expression exp
   | Texp_function (_, cases, _) ->
       sub # bindings (Nonrecursive, cases)
   | Texp_apply (exp, list) ->
diff --git a/tools/untypeast.ml b/tools/untypeast.ml
index 1fd2766e84..07a169bcf7 100644
--- a/tools/untypeast.ml
+++ b/tools/untypeast.ml
@@ -199,6 +199,10 @@ and untype_expression exp =
           List.map (fun (pat, exp) ->
               untype_pattern pat, untype_expression exp) list,
           untype_expression exp)
+    | Texp_monadic (list, exp) ->
+        Pexp_monadic (List.map (fun (pat, exp) ->
+              untype_pattern pat, untype_expression exp) list,
+          untype_expression exp)
     | Texp_function (label, cases, _) ->
         Pexp_function (label, None,
           List.map (fun (pat, exp) ->
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index f1351d0765..ef15234bdc 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -256,6 +256,10 @@ and expression i ppf x =
       line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
       list i pattern_x_expression_def ppf l;
       expression i ppf e;
+  | Texp_monadic (l, e) ->
+      line i ppf "Pexp_monadic\n";
+      list i pattern_x_expression_def ppf l;
+      expression i ppf e;
   | Texp_function (p, l, _partial) ->
       line i ppf "Pexp_function \"%s\"\n" p;
 (*      option i expression ppf eo; *)
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 6ff79925e0..f0e033f09d 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -34,7 +34,7 @@ type error =
   | Label_missing of Ident.t list
   | Label_not_mutable of Longident.t
   | Wrong_name of string * Path.t * Longident.t
-  | Name_type_mismatch of 
+  | Name_type_mismatch of
       string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
   | Incomplete_format of string
   | Bad_conversion of string * int * char
@@ -123,6 +123,7 @@ let iter_expression f e =
         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_monadic (pel, e)
     | Pexp_match (e, pel)
     | Pexp_try (e, pel) -> expr e; List.iter (fun (_, e) -> expr e) pel
     | Pexp_array el
@@ -572,7 +573,7 @@ end) = struct
       Longident.Lident s -> begin
         try
           List.find (fun nd -> get_name nd = s) descrs
-        with Not_found -> 
+        with Not_found ->
           raise (Error (lid.loc, env, Wrong_name (type_kind, tpath, lid.txt)))
       end
     | _ -> raise Not_found
@@ -641,9 +642,9 @@ end) = struct
 	with Not_found ->
           if lbls = [] then unbound_name_error env lid else
           let tp = (tpath0, expand_path env tpath) in
-	  let tpl = 
-            List.map 
-              (fun (lbl, _) -> 
+	  let tpl =
+            List.map
+              (fun (lbl, _) ->
                 let tp0 = get_type_path env lbl in
                 let tp = expand_path env tp0 in
                   (tp0, tp))
@@ -916,7 +917,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
         pat_env = !env }
   | Ppat_construct(lid, sarg, explicit_arity) ->
       let opath =
-        try 
+        try
           let (p0, p, _) = extract_concrete_variant !env expected_ty in
             Some (p0, p, true)
 	with Not_found -> None
@@ -928,7 +929,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
         | _ ->  Typetexp.find_all_constructors !env lid.loc lid.txt
       in
       let check_lk tpath constr =
-        if constr.cstr_generalized then 
+        if constr.cstr_generalized then
           raise (Error (lid.loc, !env,
                         Unqualified_gadt_pattern (tpath, constr.cstr_name)))
       in
@@ -1670,7 +1671,7 @@ let create_package_type loc env (p, l) =
 (* Helpers for type_cases *)
 
 let contains_variant_either ty =
-  let rec loop ty = 
+  let rec loop ty =
     let ty = repr ty in
     if ty.level >= lowest_level then begin
       mark_type_node ty;
@@ -1740,7 +1741,7 @@ let check_absent_variant env =
       unify_pat env {pat with pat_type = newty (Tvariant row')}
                     (correct_levels pat.pat_type)
       | _ -> ())
-      
+
 
 let dummy_expr = {pexp_desc = Pexp_tuple []; pexp_loc = Location.none}
 
@@ -1871,6 +1872,54 @@ and type_expect_ ?in_function env sexp ty_expected =
         exp_loc = loc; exp_extra = [];
         exp_type = body.exp_type;
         exp_env = env }
+  | Pexp_monadic(spat_sexp_list, sbody) ->
+      let default_loc = loc in
+      let scases = [
+         {ppat_loc = default_loc;
+          ppat_desc =
+            Ppat_construct
+              (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))),
+               Some {ppat_loc = default_loc;
+                     ppat_desc = Ppat_var (mknoloc "*sth*")},
+               false)},
+         {pexp_loc = default_loc;
+          pexp_desc = Pexp_ident(mknoloc (Longident.Lident "*sth*"))};
+         {ppat_loc = default_loc;
+          ppat_desc = Ppat_construct
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))),
+              None, false)},
+         {pexp_loc = default_loc;
+          pexp_desc = Pexp_ident(mknoloc (Longident.Lident "*predef*"))};
+      ] in
+      let smatch = {
+        pexp_loc = loc;
+        pexp_desc =
+          Pexp_match ({
+            pexp_loc = loc;
+            pexp_desc = Pexp_ident(mknoloc (Longident.Lident "*opt*"))
+            },
+            scases
+          )
+      } in
+      let spat =
+        {ppat_loc = default_loc;
+         ppat_desc = Ppat_construct
+             (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))),
+              None, false)} in
+      let sfun = {
+        pexp_loc = loc;
+        pexp_desc =
+         Pexp_function (
+           "**l**", None,
+           [ {ppat_loc = loc;
+              ppat_desc = Ppat_var (mknoloc "*opt*")},
+             {pexp_loc = loc;
+              pexp_desc = Pexp_let(Default, [spat, smatch], sbody);
+             }
+           ]
+         )
+      } in
+      type_expect ?in_function env sfun ty_expected
   | Pexp_function (l, Some default, [spat, sbody]) ->
       let default_loc = default.pexp_loc in
       let scases = [
@@ -1913,53 +1962,7 @@ and type_expect_ ?in_function env sexp ty_expected =
          )
       } in
       type_expect ?in_function env sfun ty_expected
-  | Pexp_function (l, _, caselist) ->
-      let (loc_fun, ty_fun) =
-        match in_function with Some p -> p
-        | None -> (loc, instance env ty_expected)
-      in
-      let separate = !Clflags.principal || Env.has_local_constraints env in
-      if separate then begin_def ();
-      let (ty_arg, ty_res) =
-        try filter_arrow env (instance env ty_expected) l
-        with Unify _ ->
-          match expand_head env ty_expected with
-            {desc = Tarrow _} as ty ->
-              raise(Error(loc, env, Abstract_wrong_label(l, ty)))
-          | _ ->
-              raise(Error(loc_fun, env,
-                          Too_many_arguments (in_function <> None, ty_fun)))
-      in
-      let ty_arg =
-        if is_optional l then
-          let tv = newvar() in
-          begin
-            try unify env ty_arg (type_option tv)
-            with Unify _ -> assert false
-          end;
-          type_option tv
-        else ty_arg
-      in
-      if separate then begin
-        end_def ();
-        generalize_structure ty_arg;
-        generalize_structure ty_res
-      end;
-      let cases, partial =
-        type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res
-          true loc caselist in
-      let not_function ty =
-        let ls, tvar = list_labels env ty in
-        ls = [] && not tvar
-      in
-      if is_optional l && not_function ty_res then
-        Location.prerr_warning (fst (List.hd cases)).pat_loc
-          Warnings.Unerasable_optional_argument;
-      re {
-        exp_desc = Texp_function(l,cases, partial);
-        exp_loc = loc; exp_extra = [];
-        exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
-        exp_env = env }
+  | Pexp_function (lab, _, caselist) -> type_function loc env ty_expected in_function lab caselist
   | Pexp_apply(sfunct, sargs) ->
       begin_def (); (* one more level for non-returning functions *)
       if !Clflags.principal then begin_def ();
@@ -1972,7 +1975,7 @@ and type_expect_ ?in_function env sexp ty_expected =
         let ty = expand_head env ty_fun in
         if List.memq ty seen then () else
         match ty.desc with
-          Tarrow (l, ty_arg, ty_fun, com) ->
+          Tarrow (lab, ty_arg, ty_fun, com) ->
             (try unify_var env (newvar()) ty_arg with Unify _ -> assert false);
             lower_args (ty::seen) ty_fun
         | _ -> ()
@@ -2082,7 +2085,7 @@ and type_expect_ ?in_function env sexp ty_expected =
         in
         match get_path ty_expected with
           None ->
-            let op = 
+            let op =
               match opt_exp with
                 None -> None
               | Some exp -> get_path exp.exp_type
@@ -2096,7 +2099,7 @@ and type_expect_ ?in_function env sexp ty_expected =
           (type_label_exp true env loc ty_record)
           opath lid_sexp_list in
       unify_exp_types loc env ty_record (instance env ty_expected);
-      
+
       (* type_label_a_list returns a list of labels sorted by lbl_pos *)
       (* note: check_duplicates would better be implemented in
          type_label_a_list directly *)
@@ -2699,7 +2702,7 @@ and type_label_access env loc srecord lid =
   let label = Label.disambiguate lid env opath labels in
   (record, label, opath)
 
-and type_label_exp create env loc ty_expected 
+and type_label_exp create env loc ty_expected
           (lid, label, sarg) =
   (* Here also ty_expected may be at generic_level *)
   begin_def ();
@@ -3381,6 +3384,201 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
     pat_list;
   (List.combine pat_list exp_list, new_env, unpacks)
 
+and type_function loc env ty_expected in_function lab caselist =
+      let (loc_fun, ty_fun) =
+        match in_function with Some p -> p
+        | None -> (loc, instance env ty_expected)
+      in
+      let separate = !Clflags.principal || Env.has_local_constraints env in
+      if separate then begin_def ();
+      let (ty_arg, ty_res) =
+        try filter_arrow env (instance env ty_expected) lab
+        with Unify _ ->
+          match expand_head env ty_expected with
+            {desc = Tarrow _} as ty ->
+              raise(Error(loc, env, Abstract_wrong_label(lab, ty)))
+          | _ ->
+              raise(Error(loc_fun, env,
+                          Too_many_arguments (in_function <> None, ty_fun)))
+      in
+      let ty_arg =
+        if is_optional lab then
+          let tv = newvar() in
+          begin
+            try unify env ty_arg (type_option tv)
+            with Unify _ -> assert false
+          end;
+          type_option tv
+        else ty_arg
+      in
+      if separate then begin
+        end_def ();
+        generalize_structure ty_arg;
+        generalize_structure ty_res
+      end;
+      let cases, partial =
+        type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res
+          true loc caselist in
+      let not_function ty =
+        let ls, tvar = list_labels env ty in
+        ls = [] && not tvar
+      in
+      if is_optional lab && not_function ty_res then
+        Location.prerr_warning (fst (List.hd cases)).pat_loc
+          Warnings.Unerasable_optional_argument;
+      re {
+        exp_desc = Texp_function(lab,cases, partial);
+        exp_loc = loc; exp_extra = [];
+        exp_type = instance env (newgenty (Tarrow(lab, ty_arg, ty_res, Cok)));
+        exp_env = env }
+
+and type_monadic ?(check = fun s -> Warnings.Unused_var s)
+             ?(check_strict = fun s -> Warnings.Unused_var_strict s)
+    env spat_sexp_list scope allow =
+  begin_def();
+  if !Clflags.principal then begin_def ();
+
+  let is_fake_let =
+    match spat_sexp_list with
+    | [_, {pexp_desc=Pexp_match(
+           {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}] ->
+        true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)
+    | _ ->
+        false
+  in
+  let check = if is_fake_let then check_strict else check in
+
+  let spatl =
+    List.map
+      (fun (spat, sexp) ->
+        match spat.ppat_desc, sexp.pexp_desc with
+          (Ppat_any | Ppat_constraint _), _ -> spat
+        | _, Pexp_constraint (_, _, Some sty)
+        | _, Pexp_constraint (_, Some sty, None) when !Clflags.principal ->
+            (* propagate type annotation to pattern,
+               to allow it to be generalized in -principal mode *)
+            {ppat_desc = Ppat_constraint (spat, sty);
+             ppat_loc = {spat.ppat_loc with Location.loc_ghost=true}}
+        | _ -> spat)
+      spat_sexp_list in
+  let nvs = List.map (fun _ -> newvar ()) spatl in
+  let (pat_list, new_env, force, unpacks) =
+    type_pattern_list env spatl scope nvs allow in
+  (* Polymorphic variant processing *)
+  List.iter
+    (fun pat ->
+      if has_variants pat then begin
+        Parmatch.pressure_variants env [pat];
+        iter_pattern finalize_variant pat
+      end)
+    pat_list;
+  (* Generalize the structure *)
+  let pat_list =
+    if !Clflags.principal then begin
+      end_def ();
+      List.map
+        (fun pat ->
+          iter_pattern (fun pat -> generalize_structure pat.pat_type) pat;
+          {pat with pat_type = instance env pat.pat_type})
+        pat_list
+    end else pat_list in
+  (* Only bind pattern variables after generalizing *)
+  List.iter (fun f -> f()) force;
+  let exp_env = env in
+  let current_slot = ref None in
+  let rec_needed = ref false in
+  let warn_unused =
+    Warnings.is_active (check "") || Warnings.is_active (check_strict "")
+  in
+  let pat_slot_list =
+    (* Algorithm to detect unused declarations in recursive bindings:
+       - During type checking of the definitions, we capture the 'value_used'
+         events on the bound identifiers and record them in a slot corresponding
+         to the current definition (!current_slot).
+         In effect, this creates a dependency graph between definitions.
+
+       - After type checking the definition (!current_slot = None),
+         when one of the bound identifier is effectively used, we trigger
+         again all the events recorded in the corresponding slot.
+         The effect is to traverse the transitive closure of the graph created
+         in the first step.
+
+       We also keep track of whether *all* variables in a given pattern
+       are unused. If this is the case, for local declarations, the issued
+       warning is 26, not 27.
+     *)
+    List.map
+      (fun pat ->
+        if not warn_unused then pat, None
+        else
+          let some_used = ref false in
+            (* has one of the identifier of this pattern been used? *)
+          let slot = ref [] in
+          List.iter
+            (fun (id,_) ->
+              let vd = Env.find_value (Path.Pident id) new_env in
+              (* note: Env.find_value does not trigger the value_used event *)
+              let name = Ident.name id in
+              let used = ref false in
+              if not (name = "" || name.[0] = '_' || name.[0] = '#') then
+                add_delayed_check
+                  (fun () ->
+                    if not !used then
+                      Location.prerr_warning vd.Types.val_loc
+                        ((if !some_used then check_strict else check) name)
+                  );
+              Env.set_value_used_callback
+                name vd
+                (fun () ->
+                  match !current_slot with
+                  | Some slot ->
+                      slot := (name, vd) :: !slot; rec_needed := true
+                  | None ->
+                      List.iter
+                        (fun (name, vd) -> Env.mark_value_used name vd)
+                        (get_ref slot);
+                      used := true;
+                      some_used := true
+                )
+            )
+            (Typedtree.pat_bound_idents pat);
+          pat, Some slot
+        )
+      pat_list
+  in
+  let exp_list =
+    List.map2
+      (fun (spat, sexp) (pat, slot) ->
+        match pat.pat_type.desc with
+        | Tpoly (ty, tl) ->
+            begin_def ();
+            if !Clflags.principal then begin_def ();
+            let vars, ty' = instance_poly ~keep_names:true true tl ty in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure ty'
+            end;
+            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)
+      spat_sexp_list pat_slot_list in
+  current_slot := None;
+  List.iter2
+    (fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [pat, exp]))
+    pat_list exp_list;
+  end_def();
+  List.iter2
+    (fun pat exp ->
+       if not (is_nonexpansive exp) then
+         iter_pattern (fun pat -> generalize_expansive env pat.pat_type) pat)
+    pat_list exp_list;
+  List.iter
+    (fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat)
+    pat_list;
+  (List.combine pat_list exp_list, new_env, unpacks)
+
 (* Typing of toplevel bindings *)
 
 let type_binding env rec_flag spat_sexp_list scope =
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 29aa97d3bd..327213ea46 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -66,6 +66,7 @@ and expression_desc =
     Texp_ident of Path.t * Longident.t loc * Types.value_description
   | Texp_constant of constant
   | Texp_let of rec_flag * (pattern * expression) list * expression
+  | Texp_monadic of (pattern * expression) list * expression
   | Texp_function of label * (pattern * expression) list * partial
   | Texp_apply of expression * (label * expression option * optional) list
   | Texp_match of expression * (pattern * expression) list * partial
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index d18058c348..e070bb3d03 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -65,6 +65,7 @@ and expression_desc =
     Texp_ident of Path.t * Longident.t loc * Types.value_description
   | Texp_constant of constant
   | Texp_let of rec_flag * (pattern * expression) list * expression
+  | Texp_monadic of (pattern * expression) list * expression
   | Texp_function of label * (pattern * expression) list * partial
   | Texp_apply of expression * (label * expression option * optional) list
   | Texp_match of expression * (pattern * expression) list * partial
diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml
index 7815556fc2..bb6d64d3f1 100644
--- a/typing/typedtreeIter.ml
+++ b/typing/typedtreeIter.ml
@@ -116,9 +116,12 @@ module MakeIterator(Iter : IteratorArgument) : sig
       iter_expression exp;
       Iter.leave_binding pat exp
 
+    and iter_bindings_norec list =
+      List.iter iter_binding list;
+
     and iter_bindings rec_flag list =
       Iter.enter_bindings rec_flag;
-      List.iter iter_binding list;
+      iter_bindings_norec list;
       Iter.leave_bindings rec_flag
 
     and iter_structure_item item =
@@ -240,6 +243,9 @@ module MakeIterator(Iter : IteratorArgument) : sig
         | Texp_let (rec_flag, list, exp) ->
             iter_bindings rec_flag list;
             iter_expression exp
+        | Texp_monadic (list, exp) ->
+            iter_bindings_norec list;
+            iter_expression exp
         | Texp_function (label, cases, _) ->
             iter_bindings Nonrecursive cases
         | Texp_apply (exp, list) ->
diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
index f455b2edd4..13624de201 100644
--- a/typing/typedtreeMap.ml
+++ b/typing/typedtreeMap.ml
@@ -90,6 +90,9 @@ module MakeMap(Map : MapArgument) = struct
 
   and map_binding (pat, exp) = (map_pattern pat, map_expression exp)
 
+  and map_bindings_norec list =
+    List.map map_binding list
+
   and map_bindings rec_flag list =
     List.map map_binding list
 
@@ -233,6 +236,9 @@ module MakeMap(Map : MapArgument) = struct
           Texp_let (rec_flag,
                     map_bindings rec_flag list,
                     map_expression exp)
+        | Texp_monadic (list, exp) ->
+          Texp_monadic (map_bindings_norec list,
+                        map_expression exp)
         | Texp_function (label, cases, partial) ->
           Texp_function (label, map_bindings Nonrecursive cases, partial)
         | Texp_apply (exp, list) ->