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

bytecomp/translcore.ml

@@ -833,9 +833,6 @@ and transl_exp0 e =
           cl_loc = e.exp_loc;
           cl_type = Cty_signature cty;
           cl_env = e.exp_env }
-  | Texp_poly (exp, _ )
-  | Texp_newtype (_, exp)
-    -> transl_exp exp
 
 and transl_list expr_list =
   List.map transl_exp expr_list

otherlibs/labltk/browser/searchpos.ml

@@ -819,7 +819,6 @@ and search_pos_expr ~pos exp =
       search_pos_class_structure ~pos cls
   | Texp_pack modexp ->
       search_pos_module_expr modexp ~pos
-  | _ -> assert false (* TODO ................................... *)
   end;
   add_found_str (`Exp(`Expr, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc
   end

tools/typedtreeIter.ml

@@ -228,8 +228,11 @@ module MakeIterator(Iter : IteratorArgument) : sig
       Iter.enter_expression exp;
       List.iter (function (cstr, _) ->
         match cstr with
-            Texp_constraint (cty1, cty2) -> option iter_core_type cty1; option iter_core_type cty2
-        | Texp_open (path, _, _) -> ())
+          Texp_constraint (cty1, cty2) ->
+            option iter_core_type cty1; option iter_core_type cty2
+        | Texp_open (path, _, _) -> ()
+        | Texp_poly cto -> option iter_core_type cto
+        | Texp_newtype s -> ())
         exp.exp_extra;
       begin
         match exp.exp_desc with
@@ -322,11 +325,6 @@ module MakeIterator(Iter : IteratorArgument) : sig
             iter_class_structure cl
         | Texp_pack (mexpr) ->
             iter_module_expr mexpr
-        | Texp_poly (exp, None) -> iter_expression exp
-        | Texp_poly (exp, Some ct) ->
-            iter_expression exp; iter_core_type ct
-        | Texp_newtype (s, exp) ->
-            iter_expression exp
       end;
       Iter.leave_expression exp;
 

tools/untypeast.ml

@@ -176,15 +176,22 @@ and untype_pattern pat =
 
 and option f x = match x with None -> None | Some e -> Some (f e)
 
+and untype_extra (extra, loc) sexp =
+  let desc =
+    match extra with
+      Texp_constraint (cty1, cty2) ->
+        Pexp_constraint (sexp,
+                         option untype_core_type cty1,
+                         option untype_core_type cty2)
+    | Texp_open (path, lid, _) -> Pexp_open (lid, sexp)
+    | Texp_poly cto -> Pexp_poly (sexp, option untype_core_type cto)
+    | Texp_newtype s -> Pexp_newtype (s, sexp)
+  in
+  { pexp_desc = desc;
+    pexp_loc = loc }
+      
 and untype_expression exp =
   let desc =
-  match exp.exp_extra with
-      (Texp_constraint (cty1, cty2), _) :: rem ->
-        Pexp_constraint (untype_expression { exp with exp_extra = rem },
-                         option untype_core_type cty1, option untype_core_type cty2)
-    | (Texp_open (path, lid, _), _) :: rem ->
-        Pexp_open (lid, untype_expression { exp with exp_extra = rem} )
-    | [] ->
     match exp.exp_desc with
       Texp_ident (path, lid, _) -> Pexp_ident (lid)
     | Texp_constant cst -> Pexp_constant cst
@@ -279,15 +286,10 @@ and untype_expression exp =
         Pexp_object (untype_class_structure cl)
     | Texp_pack (mexpr) ->
         Pexp_pack (untype_module_expr mexpr)
-    | Texp_poly (exp, None) -> Pexp_poly(untype_expression exp, None)
-    | Texp_poly (exp, Some ct) ->
-        Pexp_poly (untype_expression exp, Some (untype_core_type ct))
-    | Texp_newtype (s, exp) ->
-        Pexp_newtype (s, untype_expression exp)
   in
-  { pexp_loc = exp.exp_loc;
-    pexp_desc = desc;
-  }
+  List.fold_right untype_extra exp.exp_extra
+    { pexp_loc = exp.exp_loc;
+      pexp_desc = desc }
 
 and untype_package_type pack =
   (pack.pack_txt,

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

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

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 =

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 =