bootstrapped camlp4 gadts extension

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

4 files changed, 61 insertions, 21 deletions

diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml
index fb467d836..f32cf3b1b 100644
--- a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml
+++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml
@@ -1116,6 +1116,12 @@ Very old (no more supported) syntax:\n\
             <:ctyp< $t1$ | $t2$ >>
         | s = a_UIDENT; "of"; t = constructor_arg_list ->
             <:ctyp< $uid:s$ of $t$ >>
+        | s = a_UIDENT; ":"; t = constructor_arg_list ; "->" ; ret = ctyp ->
+            <:ctyp< $uid:s$ : ($t$ -> $ret$) >>
+        | s = a_UIDENT; ":"; ret = constructor_arg_list ->
+	    match Ast.list_of_ctyp ret [] with 
+	      [ [c] -> <:ctyp<  $uid:s$ : $c$ >>
+	    | _ -> raise (Stream.Error "invalid generalized constructor type") ] 
         | s = a_UIDENT ->
             <:ctyp< $uid:s$ >>
       ] ]
diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml
index 1eab63ebf..5212d8f39 100644
--- a/camlp4/boot/Camlp4.ml
+++ b/camlp4/boot/Camlp4.ml
@@ -14543,7 +14543,7 @@ module Struct =
               | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (_, s)))), t) ->
                   (s, Immutable, (mkpolytype (ctyp t)), (mkloc loc))
               | _ -> assert false
-
+              
             let mkvariant =
               function
               | Ast.TyId (loc, (Ast.IdUid (_, s))) ->
@@ -14551,13 +14551,13 @@ module Struct =
               | Ast.TyOf (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), t) ->
                   ((conv_con s), (List.map ctyp (list_of_ctyp t [])), None,
                    (mkloc loc))
-              | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), TyArr(_,t1,t2)) ->
+              | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))),
+                  (Ast.TyArr (_, t1, t2))) ->
                   ((conv_con s), (List.map ctyp (list_of_ctyp t1 [])),
-                   Some (ctyp t2),(mkloc loc))
+                   (Some (ctyp t2)), (mkloc loc))
               | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), t) ->
-                  ((conv_con s), [], Some (ctyp t),
-                   (mkloc loc))
-              | _ -> assert false              
+                  ((conv_con s), [], (Some (ctyp t)), (mkloc loc))
+              | _ -> assert false
               
             let rec type_decl tl cl loc m pflag =
               function
@@ -14599,7 +14599,6 @@ module Struct =
               | Ast.MuMutable -> Mutable
               | Ast.MuNil -> Immutable
               | _ -> assert false
-
               
             let paolab lab p =
               match (lab, p) with
@@ -14619,10 +14618,10 @@ module Struct =
               match t with
               | Ast.TyApp (_, t1, t2) ->
                   type_parameters t1 (type_parameters t2 acc)
-              | Ast.TyQuP (_, s) -> (Some s, (true, false)) :: acc
-              | Ast.TyQuM (_, s) -> (Some s, (false, true)) :: acc
-              | Ast.TyQuo (_, s) -> (Some s, (false, false)) :: acc
-              | Ast.TyNil _ -> (None, (true, false)) :: acc
+              | Ast.TyQuP (_, s) -> ((Some s), (true, false)) :: acc
+              | Ast.TyQuM (_, s) -> ((Some s), (false, true)) :: acc
+              | Ast.TyQuo (_, s) -> ((Some s), (false, false)) :: acc
+              | Ast.TyAny _ -> (None, (true, false)) :: acc
               | _ -> assert false
               
             let rec class_parameters t acc =
@@ -14640,12 +14639,7 @@ module Struct =
                   type_parameters_and_type_name t1 (type_parameters t2 acc)
               | Ast.TyId (_, i) -> ((ident i), acc)
               | _ -> assert false
-
               
-
-
-
-
             let mkwithtyp pwith_type loc id_tpl ct =
               let (id, tpl) = type_parameters_and_type_name id_tpl [] in
               let (params, variance) = List.split tpl in
@@ -14737,7 +14731,8 @@ module Struct =
                          then
                            mkpat loc
                              (Ppat_construct (li,
-                                (Some (mkpat loc (Ppat_tuple al))), true, None))
+                                (Some (mkpat loc (Ppat_tuple al))), true,
+                                None))
                          else
                            (let a =
                               match al with
@@ -14820,7 +14815,8 @@ module Struct =
                   let is_closed = if wildcards = [] then Closed else Open
                   in
                     mkpat loc
-                      (Ppat_record (((List.map mklabpat ps), is_closed, None)))
+                      (Ppat_record
+                         (((List.map mklabpat ps), is_closed, None)))
               | PaStr (loc, s) ->
                   mkpat loc
                     (Ppat_constant
diff --git a/camlp4/boot/camlp4boot.ml b/camlp4/boot/camlp4boot.ml
index 20482abcb..08286b69d 100644
--- a/camlp4/boot/camlp4boot.ml
+++ b/camlp4/boot/camlp4boot.ml
@@ -4951,6 +4951,46 @@ Very old (no more supported) syntax:\n\
                          ([ Gram.Snterm
                               (Gram.Entry.obj
                                  (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+                            Gram.Skeyword ":";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (constructor_arg_list :
+                                   'constructor_arg_list Gram.Entry.t)) ],
+                          (Gram.Action.mk
+                             (fun (ret : 'constructor_arg_list) _
+                                (s : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+                                (match Ast.list_of_ctyp ret [] with
+                                 | [ c ] ->
+                                     Ast.TyCol (_loc,
+                                       (Ast.TyId (_loc,
+                                          (Ast.IdUid (_loc, s)))),
+                                       c)
+                                 | _ ->
+                                     raise
+                                       (Stream.Error
+                                          "invalid generalized constructor type") :
+                                  'constructor_declarations))));
+                         ([ Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+                            Gram.Skeyword ":";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (constructor_arg_list :
+                                   'constructor_arg_list Gram.Entry.t));
+                            Gram.Skeyword "->";
+                            Gram.Snterm
+                              (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+                          (Gram.Action.mk
+                             (fun (ret : 'ctyp) _ (t : 'constructor_arg_list)
+                                _ (s : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+                                (Ast.TyCol (_loc,
+                                   (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))),
+                                   (Ast.TyArr (_loc, t, ret))) :
+                                  'constructor_declarations))));
+                         ([ Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_UIDENT : 'a_UIDENT Gram.Entry.t));
                             Gram.Skeyword "of";
                             Gram.Snterm
                               (Gram.Entry.obj
diff --git a/parsing/parser.mly b/parsing/parser.mly
index fd821c79a..8b32847ce 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1396,9 +1396,7 @@ constructor_declarations:
 constructor_declaration:
     constr_ident constructor_arguments          {  ($1, $2, None, symbol_rloc()) }
 ;
-
-constructor_declaration:
-    constr_ident generalized_constructor_arguments          
+  | constr_ident generalized_constructor_arguments          
                                                 { let arg_types,ret_type = $2 in 
 						     ($1, arg_types,Some ret_type, symbol_rloc()) }
 ;