Simplify the bind pattersn to single one in typed tree. Skeleton of compilation to lambda.

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

7 files changed, 14 insertions, 18 deletions

diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 5b1a1493bf..54aa14352b 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -989,13 +989,8 @@ and transl_let rec_flag pat_expr_list body =
         (id, lam) in
       Lletrec(List.map2 transl_case pat_expr_list idlist, body)
 
-and transl_bind 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_bind (pat, expr) body =
+  Lapply (Lvar (Ident.create "bind"), [Lfunction (Curried, [Ident.create "**x**"], body)], pat.pat_loc)
 
 and transl_setinstvar self var expr =
   Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray),
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index e3abda2428..054e002e80 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -256,9 +256,9 @@ 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_bind (l, e) ->
+  | Texp_bind (b, e) ->
       line i ppf "Pexp_bind\n";
-      list i pattern_x_expression_def ppf l;
+      list i pattern_x_expression_def ppf [b];
       expression i ppf e;
   | Texp_function (p, l, _partial) ->
       line i ppf "Pexp_function \"%s\"\n" p;
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 2f2febc58b..fc138d64e8 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1873,12 +1873,14 @@ and type_expect_ ?in_function env sexp ty_expected =
         exp_type = body.exp_type;
         exp_env = env }
   | Pexp_bind(spat_sexp_list, sbody) ->
-      let (pat_exp_list, new_env, unpacks) =
+      let (pat_exp, new_env, unpacks) =
         type_let env Default spat_sexp_list None true in
+      let pat_exp = List.hd pat_exp in
+      let exp = type_function loc env ty_expected in_function "" spat_sexp_list in
       let body =
         type_expect new_env (wrap_unpacks sbody unpacks) ty_expected in
       re {
-        exp_desc = Texp_bind(pat_exp_list, body);
+        exp_desc = Texp_bind((fst pat_exp, exp), body);
         exp_loc = loc; exp_extra = [];
         exp_type = body.exp_type;
         exp_env = env }
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index b66c9d5c21..6a9559ff00 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -66,7 +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_bind of (pattern * expression) list * expression
+  | Texp_bind of (pattern * expression) * 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 43a6bfcb20..a15a8da5d7 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -65,7 +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_bind of (pattern * expression) list * expression
+  | Texp_bind of (pattern * expression) * 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 fd2e82b7e6..58ece4e8cd 100644
--- a/typing/typedtreeIter.ml
+++ b/typing/typedtreeIter.ml
@@ -243,8 +243,8 @@ module MakeIterator(Iter : IteratorArgument) : sig
         | Texp_let (rec_flag, list, exp) ->
             iter_bindings rec_flag list;
             iter_expression exp
-        | Texp_bind (list, exp) ->
-            iter_bindings_norec list;
+        | Texp_bind (b, exp) ->
+            iter_bindings_norec [b];
             iter_expression exp
         | Texp_function (label, cases, _) ->
             iter_bindings Nonrecursive cases
diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
index cf80516c43..4799f50027 100644
--- a/typing/typedtreeMap.ml
+++ b/typing/typedtreeMap.ml
@@ -236,9 +236,8 @@ module MakeMap(Map : MapArgument) = struct
           Texp_let (rec_flag,
                     map_bindings rec_flag list,
                     map_expression exp)
-        | Texp_bind (list, exp) ->
-          Texp_bind (map_bindings_norec list,
-                        map_expression exp)
+        | Texp_bind (b, exp) ->
+          Texp_bind (map_binding b, map_expression exp)
         | Texp_function (label, cases, partial) ->
           Texp_function (label, map_bindings Nonrecursive cases, partial)
         | Texp_apply (exp, list) ->