fix PR#5674: move Texp_poly and Texp_newtype to exp_extra

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

4 files changed, 26 insertions, 28 deletions

diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index 28969ff14..55a0e2eca 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -230,19 +230,26 @@ and pattern i ppf x =
       line i ppf "Ppat_lazy\n";
       pattern i ppf p;
 
-and expression i ppf x =
-  line i ppf "expression %a\n" fmt_location x.exp_loc;
-  let i = i+1 in
-  match x.exp_extra with
-    | (Texp_constraint (cto1, cto2), _) :: rem ->
+and expression_extra i ppf x =
+  match x with
+  | Texp_constraint (cto1, cto2) ->
       line i ppf "Pexp_constraint\n";
       option i core_type ppf cto1;
       option i core_type ppf cto2;
-      expression i ppf { x with exp_extra = rem }
-  | (Texp_open (m, _,_), _) :: rem ->
+  | Texp_open (m, _, _) ->
       line i ppf "Pexp_open \"%a\"\n" fmt_path m;
-      expression i ppf { x with exp_extra = rem }
-    | [] ->
+  | Texp_poly cto ->
+      line i ppf "Pexp_poly\n";
+      option i core_type ppf cto;
+  | Texp_newtype s ->
+      line i ppf "Pexp_newtype \"%s\"\n" s;
+
+and expression i ppf x =
+  line i ppf "expression %a\n" fmt_location x.exp_loc;
+  let i =
+    List.fold_left (fun i (extra,_) -> expression_extra i ppf extra; i+1)
+      (i+1) x.exp_extra
+  in
   match x.exp_desc with
   | Texp_ident (li,_,_) -> line i ppf "Pexp_ident %a\n" fmt_path li;
   | Texp_instvar (_, li,_) -> line i ppf "Pexp_instvar %a\n" fmt_path li;
@@ -342,16 +349,9 @@ and expression i ppf x =
   | Texp_lazy (e) ->
       line i ppf "Pexp_lazy";
       expression i ppf e;
-  | Texp_poly (e, cto) ->
-      line i ppf "Pexp_poly\n";
-      expression i ppf e;
-      option i core_type ppf cto;
   | Texp_object (s, _) ->
       line i ppf "Pexp_object";
       class_structure i ppf s
-  | Texp_newtype (s, e) ->
-      line i ppf "Pexp_newtype \"%s\"\n" s;
-      expression i ppf e
   | Texp_pack me ->
       line i ppf "Pexp_pack";
       module_expr i ppf me
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 8cbfae52f..a13eb5498 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -994,9 +994,6 @@ let rec is_nonexpansive exp =
   match exp.exp_desc with
     Texp_ident(_,_,_) -> true
   | Texp_constant _ -> true
-  | Texp_poly (e, _)
-  | Texp_newtype (_, e)
-    -> is_nonexpansive e
   | Texp_let(rec_flag, pat_exp_list, body) ->
       List.for_all (fun (pat, exp) -> is_nonexpansive exp) pat_exp_list &&
       is_nonexpansive body
@@ -2247,7 +2244,7 @@ and type_expect ?in_function env sexp ty_expected =
         match (expand_head env ty).desc with
           Tpoly (ty', []) ->
             let exp = type_expect env sbody ty' in
-            re { exp with exp_type = instance env ty }
+            { exp with exp_type = instance env ty }
         | Tpoly (ty', tl) ->
             (* One more level to generalize locally *)
             begin_def ();
@@ -2260,15 +2257,15 @@ and type_expect ?in_function env sexp ty_expected =
             let exp = type_expect env sbody ty'' in
             end_def ();
             check_univars env false "method" exp ty_expected vars;
-            re { exp with exp_type = instance env ty }
+            { exp with exp_type = instance env ty }
         | Tvar _ ->
             let exp = type_exp env sbody in
             let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in
             unify_exp env exp ty;
-            re exp
+            exp
         | _ -> assert false
       in
-      re { exp with exp_desc = Texp_poly(exp, cty) }
+      re { exp with exp_extra = (Texp_poly cty, loc) :: exp.exp_extra }
   | Pexp_newtype(name, sbody) ->
       let ty = newvar () in
       (* remember original level *)
@@ -2312,7 +2309,8 @@ and type_expect ?in_function env sexp ty_expected =
 
       (* non-expansive if the body is non-expansive, so we don't introduce
          any new extra node in the typed AST. *)
-      rue { body with exp_loc = sexp.pexp_loc; exp_type = ety }
+      rue { body with exp_loc = loc; exp_type = ety;
+            exp_extra = (Texp_newtype name, loc) :: body.exp_extra }
   | Pexp_pack m ->
       let (p, nl, tl) =
         match Ctype.expand_head env (instance env ty_expected) with
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 08ab35e4c..fda05b041 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -61,6 +61,8 @@ and expression =
 and exp_extra =
   | Texp_constraint of core_type option * core_type option
   | Texp_open of Path.t * Longident.t loc * Env.t
+  | Texp_poly of core_type option
+  | Texp_newtype of string
 
 and expression_desc =
     Texp_ident of Path.t * Longident.t loc * Types.value_description
@@ -98,9 +100,7 @@ and expression_desc =
   | Texp_assert of expression
   | Texp_assertfalse
   | Texp_lazy of expression
-  | Texp_poly of expression * core_type option
   | Texp_object of class_structure * string list
-  | Texp_newtype of string * expression
   | Texp_pack of module_expr
 
 and meth =
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 436576d7a..81242993d 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -60,6 +60,8 @@ and expression =
 and exp_extra =
   | Texp_constraint of core_type option * core_type option
   | Texp_open of Path.t * Longident.t loc * Env.t
+  | Texp_poly of core_type option
+  | Texp_newtype of string
 
 and expression_desc =
     Texp_ident of Path.t * Longident.t loc * Types.value_description
@@ -97,9 +99,7 @@ and expression_desc =
   | Texp_assert of expression
   | Texp_assertfalse
   | Texp_lazy of expression
-  | Texp_poly of expression * core_type option
   | Texp_object of class_structure * string list
-  | Texp_newtype of string * expression
   | Texp_pack of module_expr
 
 and meth =