L'alias (t as 'a) peut etre utilise avec tout type t (pas seulement

objet et type construit).


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

4 files changed, 82 insertions, 134 deletions

diff --git a/parsing/parser.mly b/parsing/parser.mly
index 47ff7cbe2..6973c3407 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -885,6 +885,8 @@ core_type:
       { mktyp(Ptyp_arrow($1, $3)) }
   | core_type_tuple
       { mktyp(Ptyp_tuple(List.rev $1)) }
+  | core_type AS type_parameter
+      { mktyp(Ptyp_alias($1, $3)) }
 ;
 
 simple_core_type:
@@ -892,32 +894,26 @@ simple_core_type:
       { mktyp(Ptyp_var $2) }
   | UNDERSCORE
       { mktyp(Ptyp_any) }
-  | type_longident alias
-      { mktyp(Ptyp_constr($1, [], $2)) }
-  | simple_core_type type_longident alias %prec prec_constr_appl
-      { mktyp(Ptyp_constr($2, [$1], $3)) }
-  | LPAREN core_type_comma_list RPAREN type_longident alias
+  | type_longident
+      { mktyp(Ptyp_constr($1, [])) }
+  | simple_core_type type_longident %prec prec_constr_appl
+      { mktyp(Ptyp_constr($2, [$1])) }
+  | LPAREN core_type_comma_list RPAREN type_longident
       %prec prec_constr_appl
-      { mktyp(Ptyp_constr($4, List.rev $2, $5)) }
+      { mktyp(Ptyp_constr($4, List.rev $2)) }
   | LPAREN core_type RPAREN
       { $2 }
-  | LESS meth_list GREATER alias
-      { mktyp(Ptyp_object($2, $4)) }
-  | LESS GREATER alias
-      { mktyp(Ptyp_object([], $3)) }
-  | SHARP class_longident alias
-      { mktyp(Ptyp_class($2, [], $3)) }
-  | simple_core_type SHARP class_longident alias %prec prec_constr_appl
-      { mktyp(Ptyp_class($3, [$1], $4)) }
-  | LPAREN core_type_comma_list RPAREN SHARP class_longident alias
+  | LESS meth_list GREATER
+      { mktyp(Ptyp_object $2) }
+  | LESS GREATER
+      { mktyp(Ptyp_object []) }
+  | SHARP class_longident
+      { mktyp(Ptyp_class($2, [])) }
+  | simple_core_type SHARP class_longident %prec prec_constr_appl
+      { mktyp(Ptyp_class($3, [$1])) }
+  | LPAREN core_type_comma_list RPAREN SHARP class_longident
       %prec prec_constr_appl
-      { mktyp(Ptyp_class($5, List.rev $2, $6)) }
-;
-alias:
-    AS type_parameter
-      { Some $2 }
-  | /* empty */
-      {None}
+      { mktyp(Ptyp_class($5, List.rev $2)) }
 ;
 core_type_tuple:
     simple_core_type STAR simple_core_type
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 96fd1d2c2..7b57b7cc2 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -26,9 +26,10 @@ and core_type_desc =
   | Ptyp_var of string
   | Ptyp_arrow of core_type * core_type
   | Ptyp_tuple of core_type list
-  | Ptyp_constr of Longident.t * core_type list * string option
-  | Ptyp_object of core_field_type list * string option
-  | Ptyp_class of Longident.t * core_type list * string option
+  | Ptyp_constr of Longident.t * core_type list
+  | Ptyp_object of core_field_type list
+  | Ptyp_class of Longident.t * core_type list
+  | Ptyp_alias of core_type * string
 
 and core_field_type =
   { pfield_desc: core_field_desc;
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index d3fb2c04d..f636966c4 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -139,66 +139,73 @@ let reset_loop_marks () =
 let reset () =
   reset_names (); reset_loop_marks ()
 
-let rec typexp sch prio ty =
+let rec typexp sch prio0 ty =
   let ty = repr ty in
   try
     List.assq ty !names;
     print_string "'";
     print_string (name_of_type ty)
   with Not_found ->
-    match ty.desc with
+    let alias = List.memq ty !aliased in
+    if alias then begin
+      name_of_type ty;
+      if prio0 >= 1 then begin open_box 1; print_string "(" end
+      else open_box 0
+    end;
+    let prio = if alias then 0 else prio0 in
+    begin match ty.desc with
       Tvar ->
         if (not sch) or ty.level = generic_level
         then print_string "'"
         else print_string "'_";
         print_string(name_of_type ty)
     | Tarrow(ty1, ty2) ->
-        if prio >= 1 then begin open_box 1; print_string "(" end
+        if prio >= 2 then begin open_box 1; print_string "(" end
                      else open_box 0;
-        typexp sch 1 ty1;
+        typexp sch 2 ty1;
         print_string " ->"; print_space();
-        typexp sch 0 ty2;
-        if prio >= 1 then print_string ")";
+        typexp sch 1 ty2;
+        if prio >= 2 then print_string ")";
         close_box()
     | Ttuple tyl ->
-        if prio >= 2 then begin open_box 1; print_string "(" end
+        if prio >= 3 then begin open_box 1; print_string "(" end
                      else open_box 0;
-        typlist sch 2 " *" tyl;
-        if prio >= 2 then print_string ")";
+        typlist sch 3 " *" tyl;
+        if prio >= 3 then print_string ")";
         close_box()
     | Tconstr(p, tyl, abbrev) ->
         open_box 0;
-        if List.memq ty !aliased then begin
-          name_of_type ty;
-          if prio >= 1 then begin open_box 1; print_string "(" end
-        end;
-        open_box 0;
         begin match tyl with
           [] -> ()
         | [ty1] ->
-            typexp sch 2 ty1; print_space()
+            typexp sch 3 ty1; print_space()
         | tyl ->
             open_box 1; print_string "("; typlist sch 0 "," tyl;
             print_string ")"; close_box(); print_space()
         end;
         path p;
         close_box();
-        if List.memq ty !aliased then begin
-          print_string " as ";
-          print_string "'";
-          print_string (name_of_type ty);
-          remove_name_of_type ty;
-          if prio >= 1 then begin print_string ")"; close_box () end
-        end;
-        close_box()
     | Tobject (fi, nm) ->
-        typobject sch prio ty fi nm
+        typobject sch ty fi nm
 (*
-| Tfield _ -> typobject sch prio ty ty (ref None)
-| Tnil -> typobject sch prio ty ty (ref None)
+| Tfield _ -> typobject sch ty ty (ref None)
+| Tnil -> typobject sch ty ty (ref None)
 *)
     | _ ->
         fatal_error "Printtyp.typexp"
+    end;
+    if alias then begin
+      print_string " as ";
+      print_string "'";
+      print_string (name_of_type ty);
+      if not (opened_object ty) then
+        remove_name_of_type ty;
+      if prio0 >= 1 then print_string ")";
+      close_box()
+    end
+;    print_string "[";
+    print_int ty.level;
+    print_string "]"
 
 and typlist sch prio sep = function
     [] -> ()
@@ -207,11 +214,7 @@ and typlist sch prio sep = function
       typexp sch prio ty; print_string sep; print_space();
       typlist sch prio sep tyl
 
-and typobject sch prio ty fi nm =
-  if List.memq ty !aliased then begin
-    name_of_type ty;
-    if prio >= 1 then begin open_box 1; print_string "(" end
-  end;
+and typobject sch ty fi nm =
   begin match !nm with
     None ->
       open_box 2;
@@ -225,7 +228,7 @@ and typobject sch prio ty fi nm =
       begin match tyl with
         [] -> ()
       | [ty1] ->
-          typexp sch 2 ty1; print_space()
+          typexp sch 3 ty1; print_space()
       | tyl ->
           open_box 1; print_string "("; typlist sch 0 "," tyl;
           print_string ")"; close_box(); print_space()
@@ -237,14 +240,6 @@ and typobject sch prio ty fi nm =
       close_box()
   | _ ->
         fatal_error "Printtyp.typobject"
-  end;
-  if List.memq ty !aliased then begin
-    print_string " as ";
-    print_string "'";
-    print_string (name_of_type ty);
-    if not (opened_object ty) then
-        remove_name_of_type ty;
-    if prio >= 1 then begin print_string ")"; close_box () end
   end
 
 and typfields sch rest =
@@ -353,7 +348,7 @@ and constructor (name, args) =
   match args with
     [] -> ()
   | _  -> print_string " of ";
-          open_box 2; typlist false 2 " *" args; close_box()
+          open_box 2; typlist false 3 " *" args; close_box()
 
 and label (name, mut, arg) =
   begin match mut with
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 3c8cc8ea2..aa9e4d168 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -106,7 +106,7 @@ let rec transl_type env policy styp =
       newty (Tarrow(ty1, ty2))
   | Ptyp_tuple stl ->
       newty (Ttuple(List.map (transl_type env policy) stl))
-  | Ptyp_constr(lid, stl, alias) ->
+  | Ptyp_constr(lid, stl) ->
       let (path, decl) =
         try
           Env.lookup_type lid env
@@ -115,30 +115,8 @@ let rec transl_type env policy styp =
       if List.length stl <> decl.type_arity then
         raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
                                                            List.length stl)));
-      let (cstr, args) =
-        begin match alias with
-          None ->
-            let tl = List.map (transl_type env policy) stl in
-              (newty (Tconstr(path, tl, ref Mnil)), tl)
-        | Some alias ->
-            let cstr = newvar () in
-            begin try
-              Tbl.find alias !type_variables;
-              raise(Error(styp.ptyp_loc, Bound_type_variable alias))
-            with Not_found -> try
-              Tbl.find alias !aliases;
-              raise(Error(styp.ptyp_loc, Bound_type_variable alias))
-            with Not_found ->
-              aliases := Tbl.add alias cstr !aliases
-            end;
-            let tl = List.map (transl_type env policy) stl in
-            let cstr' = newty (Tconstr(path, tl, ref Mnil)) in
-            begin try unify env cstr' cstr with Unify trace ->
-              raise(Error(styp.ptyp_loc, Alias_type_mismatch trace))
-            end;
-            (cstr, tl)
-        end
-      in
+      let args = List.map (transl_type env policy) stl in
+      let cstr = newty (Tconstr(path, args, ref Mnil)) in
       let params = Ctype.instance_list decl.type_params in
       List.iter2
         (fun (sty, ty) ty' ->
@@ -146,26 +124,9 @@ let rec transl_type env policy styp =
              raise (Error(sty.ptyp_loc, Type_mismatch trace)))
         (List.combine stl args) params;
       cstr
-  | Ptyp_object(fields, None) ->
+  | Ptyp_object fields ->
       newobj (transl_fields env policy fields)
-  | Ptyp_object(fields, Some alias) ->
-      begin try
-        Tbl.find alias !type_variables;
-        raise(Error(styp.ptyp_loc, Bound_type_variable alias))
-      with Not_found -> try
-        Tbl.find alias !aliases;
-        raise(Error(styp.ptyp_loc, Bound_type_variable alias))
-      with Not_found ->
-        let obj = newvar () in
-        aliases := Tbl.add alias obj !aliases;
-        let obj' =
-          newty (Tobject (transl_fields env policy fields, ref None)) in
-        begin try unify env obj' obj with Unify trace ->
-          raise(Error(styp.ptyp_loc, Alias_type_mismatch trace))
-        end;
-        obj
-      end
-  | Ptyp_class(lid, stl, alias) ->
+  | Ptyp_class(lid, stl) ->
       if policy = Fixed then
         raise(Error(styp.ptyp_loc, Unbound_row_variable lid));
       let lid2 =
@@ -182,30 +143,9 @@ let rec transl_type env policy styp =
       if List.length stl <> decl.type_arity then
         raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
                                                            List.length stl)));
-      let cstr = new_global_var () in
-      let (ty, args) =
-        begin match alias with
-          None ->
-            let tl = List.map (transl_type env policy) stl in
-            (expand_abbrev env path tl (ref Mnil) cstr.level, tl)
-        | Some alias ->
-            begin try
-              Tbl.find alias !type_variables;
-              raise(Error(styp.ptyp_loc, Bound_type_variable alias))
-            with Not_found -> try
-              Tbl.find alias !aliases;
-              raise(Error(styp.ptyp_loc, Bound_type_variable alias))
-            with Not_found ->
-              aliases := Tbl.add alias cstr !aliases
-            end;
-            let tl = List.map (transl_type env policy) stl in
-            let cstr' = expand_abbrev env path tl (ref Mnil) cstr.level in
-            begin try unify env cstr' cstr with Unify trace ->
-              raise(Error(styp.ptyp_loc, Alias_type_mismatch trace))
-            end;
-            (cstr, tl)
-        end
-      in
+      let cstr' = new_global_var () in
+      let args = List.map (transl_type env policy) stl in
+      let ty = expand_abbrev env path args (ref Mnil) cstr'.level in
       let params = Ctype.instance_list decl.type_params in
       List.iter2
         (fun (sty, ty') ty ->
@@ -213,6 +153,22 @@ let rec transl_type env policy styp =
              raise (Error(sty.ptyp_loc, Type_mismatch trace)))
         (List.combine stl args) params;
       ty
+  | Ptyp_alias(st, alias) ->
+      begin try
+        Tbl.find alias !type_variables;
+        raise(Error(styp.ptyp_loc, Bound_type_variable alias))
+      with Not_found -> try
+        Tbl.find alias !aliases;
+        raise(Error(styp.ptyp_loc, Bound_type_variable alias))
+      with Not_found ->
+        let ty' = newvar () in
+        aliases := Tbl.add alias ty' !aliases;
+        let ty = transl_type env policy st in
+        begin try unify env ty ty' with Unify trace ->
+          raise(Error(styp.ptyp_loc, Alias_type_mismatch trace))
+        end;
+        ty
+      end 
 
 and transl_fields env policy =
   function