Initial implementation of the override modifier.overridemethod

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

16 files changed, 77 insertions, 23 deletions

diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
index a4a904206b..7681d7a720 100644
--- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
+++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
@@ -1018,7 +1018,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
           [ <:ctyp<>> -> None
           | t -> Some (mkpolytype (ctyp t)) ] in
         let e = mkexp loc (Pexp_poly (expr e) t) in
-        [Pcf_meth (s, mkprivate b, e, mkloc loc) :: l]
+        [Pcf_meth (s, mkprivate b, False (* todo: override *), e, mkloc loc) :: l]
     | CrVal loc s b e -> [Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l]
     | CrVir loc s b t ->
         [Pcf_virt (s, mkprivate b, mkpolytype (ctyp t), mkloc loc) :: l]
diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml
index abaa0950c7..81d79b3728 100644
--- a/camlp4/boot/Camlp4.ml
+++ b/camlp4/boot/Camlp4.ml
@@ -14549,7 +14549,7 @@ module Struct =
                      | Ast.TyNil _ -> None
                      | t -> Some (mkpolytype (ctyp t))) in
                   let e = mkexp loc (Pexp_poly (expr e, t))
-                  in (Pcf_meth ((s, (mkprivate b), e, (mkloc loc)))) :: l
+                  in (Pcf_meth ((s, (mkprivate b), false, e, (mkloc loc)))) :: l
               | CrVal (loc, s, b, e) ->
                   (Pcf_val ((s, (mkmutable b), (expr e), (mkloc loc)))) :: l
               | CrVir (loc, s, b, t) ->
diff --git a/myocamlbuild.ml b/myocamlbuild.ml
index db2e377fdc..2529cdeeb3 100644
--- a/myocamlbuild.ml
+++ b/myocamlbuild.ml
@@ -199,8 +199,8 @@ let cold_camlp4boot = "camlp4boot" (* The installed version *);;
 
 flag ["ocaml"; "ocamlyacc"] (A"-v");;
 
-flag ["ocaml"; "compile"; "warn_Aler"] (S[A"-w";A"Aler"; A"-warn-error";A"Aler"]);;
-flag ["ocaml"; "compile"; "warn_Alerzv"] (S[A"-w";A"Alerzv"; A"-warn-error";A"Alerzv"]);;
+flag ["ocaml"; "compile"; "warn_Aler"] (S[A"-w";A"Aler-28"; A"-warn-error";A"Aler"]);;
+flag ["ocaml"; "compile"; "warn_Alerzv"] (S[A"-w";A"Alerzv-28"; A"-warn-error";A"Alerzv"]);;
 
 non_dependency "otherlibs/threads/pervasives.ml" "Unix";;
 non_dependency "otherlibs/threads/pervasives.ml" "String";;
diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile
index a9ce895918..17aefa7f2e 100644
--- a/ocamldoc/Makefile
+++ b/ocamldoc/Makefile
@@ -68,7 +68,7 @@ INCLUDES_NODEP=	-I $(OCAMLSRCDIR)/stdlib \
 
 INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP)
 
-COMPFLAGS=$(INCLUDES) -warn-error A
+COMPFLAGS=$(INCLUDES) -w -28 -warn-error A
 LINKFLAGS=$(INCLUDES) -nostdlib
 
 CMOFILES= odoc_config.cmo \
diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt
index caba5769ba..35a32c227a 100644
--- a/ocamldoc/Makefile.nt
+++ b/ocamldoc/Makefile.nt
@@ -14,7 +14,7 @@
 include ../config/Makefile
 
 CAMLRUN =../boot/ocamlrun
-OCAMLC   =$(CAMLRUN) ../ocamlc -warn-error A
+OCAMLC   =$(CAMLRUN) ../ocamlc -w -28 -warn-error A
 OCAMLOPT =$(CAMLRUN) ../ocamlopt
 OCAMLLEX =$(CAMLRUN) ../boot/ocamllex
 OCAMLYACC=../boot/ocamlyacc
diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml
index ec10277a18..63cddc120d 100644
--- a/ocamldoc/odoc_ast.ml
+++ b/ocamldoc/odoc_ast.ml
@@ -602,7 +602,7 @@ module Analyser =
 
             iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q
 
-        | (Parsetree.Pcf_meth  (label, private_flag, _, loc)) :: q ->
+        | (Parsetree.Pcf_meth  (label, private_flag, _, _, loc)) :: q ->
             let complete_name = Name.concat current_class_name label in
             let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
             let exp =
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 3b400c2bda..98e1a4ead2 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -197,6 +197,15 @@ let exp_of_label lbl =
 let pat_of_label lbl =
   mkpat (Ppat_var(Longident.last lbl))
 
+let parse_method_modifiers =
+  let rec aux override = function
+    | "override" :: rest -> aux true rest
+    | [] -> syntax_error()
+    | name :: args -> override, name, args
+  in
+  aux false
+
+
 %}
 
 /* Tokens */
@@ -677,11 +686,24 @@ virtual_method:
   | METHOD VIRTUAL private_flag label COLON poly_type
       { $4, $3, $6, symbol_rloc () }
 ;
-concrete_method :
-    METHOD private_flag label strict_binding
-      { $3, $2, ghexp(Pexp_poly ($4, None)), symbol_rloc () }
-  | METHOD private_flag label COLON poly_type EQUAL seq_expr
-      { $3, $2, ghexp(Pexp_poly($7,Some $5)), symbol_rloc () }
+concrete_method:
+    METHOD private_flag lident_list strict_binding_without_val_ident
+      {
+        let override, name, args = parse_method_modifiers (List.rev $3) in
+        let body = List.fold_right (fun arg body -> ghexp(Pexp_function("", None, [ghpat(Ppat_var arg), body]))) args $4 in
+        name, $2, override, ghexp(Pexp_poly (body, None)), symbol_rloc ()
+      }
+  | METHOD private_flag lident_list COLON poly_type EQUAL seq_expr
+      {
+        let override, name, args = parse_method_modifiers (List.rev $3) in
+        if args <> [] then syntax_error ();
+        name, $2, override, ghexp(Pexp_poly($7,Some $5)), symbol_rloc ()
+      }
+;
+
+lident_list:
+  | lident_list LIDENT { $2 :: $1 }
+  | LIDENT { [$1] }
 ;
 
 /* Class types */
@@ -778,6 +800,11 @@ seq_expr:
   | expr SEMI seq_expr            { mkexp(Pexp_sequence($1, $3)) }
 ;
 labeled_simple_pattern:
+    val_ident %prec below_EQUAL
+      { ("", None, mkpat(Ppat_var $1)) }
+  | labeled_simple_pattern_without_val_ident { $1 }
+;
+labeled_simple_pattern_without_val_ident:
     QUESTION LPAREN label_let_pattern opt_default RPAREN
       { ("?" ^ fst $3, $4, snd $3) }
   | QUESTION label_var
@@ -792,7 +819,7 @@ labeled_simple_pattern:
       { (fst $2, None, snd $2) }
   | LABEL simple_pattern
       { ($1, None, $2) }
-  | simple_pattern
+  | simple_pattern_without_val_ident
       { ("", None, $1) }
 ;
 pattern_var:
@@ -1034,9 +1061,13 @@ fun_binding:
       { let (t, t') = $1 in ghexp(Pexp_constraint($3, t, t')) }
 ;
 strict_binding:
+    val_ident %prec below_EQUAL fun_binding
+      { let (l, o, p) = ("", None, mkpat(Ppat_var $1)) in ghexp(Pexp_function(l, o, [p, $2])) }
+  | strict_binding_without_val_ident { $1 }
+strict_binding_without_val_ident:
     EQUAL seq_expr
       { $2 }
-  | labeled_simple_pattern fun_binding
+  | labeled_simple_pattern_without_val_ident fun_binding
       { let (l, o, p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) }
   | LPAREN TYPE LIDENT RPAREN fun_binding
       { mkexp(Pexp_newtype($3, $5)) }
@@ -1119,6 +1150,9 @@ pattern:
 simple_pattern:
     val_ident %prec below_EQUAL
       { mkpat(Ppat_var $1) }
+  | simple_pattern_without_val_ident { $1 }
+;
+simple_pattern_without_val_ident:
   | UNDERSCORE
       { mkpat(Ppat_any) }
   | signed_constant
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index ca835be10e..099ba68775 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -189,7 +189,7 @@ and class_field =
   | Pcf_valvirt of (string * mutable_flag * core_type * Location.t)
   | Pcf_val   of (string * mutable_flag * expression * Location.t)
   | Pcf_virt  of (string * private_flag * core_type * Location.t)
-  | Pcf_meth  of (string * private_flag * expression * Location.t)
+  | Pcf_meth  of (string * private_flag * bool * expression * Location.t)
   | Pcf_cstr  of (core_type * core_type * Location.t)
   | Pcf_let   of rec_flag * (pattern * expression) list * Location.t
   | Pcf_init  of expression
diff --git a/parsing/printast.ml b/parsing/printast.ml
index d35f74949c..f9a3e7f11a 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -469,9 +469,9 @@ and class_field i ppf x =
       line i ppf
         "Pcf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
       core_type (i+1) ppf ct;
-  | Pcf_meth (s, pf, e, loc) ->
+  | Pcf_meth (s, pf, override, e, loc) ->
       line i ppf
-        "Pcf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
+        "Pcf_meth \"%s\" %s %a %a\n" s (if override then "override " else "") fmt_private_flag pf fmt_location loc;
       expression (i+1) ppf e;
   | Pcf_cstr (ct1, ct2, loc) ->
       line i ppf "Pcf_cstr %a\n" fmt_location loc;
diff --git a/tools/depend.ml b/tools/depend.ml
index 4d24070adb..fa907ea036 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -291,7 +291,7 @@ and add_class_field bv = function
   | Pcf_val(_, _, e, _) -> add_expr bv e
   | Pcf_valvirt(_, _, ty, _)
   | Pcf_virt(_, _, ty, _) -> add_type bv ty
-  | Pcf_meth(_, _, e, _) -> add_expr bv e
+  | Pcf_meth(_, _, _, e, _) -> add_expr bv e
   | Pcf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
   | Pcf_let(_, pel, _) -> add_pat_expr_list bv pel
   | Pcf_init e -> add_expr bv e
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index 2fd2b044df..b12a7e987e 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -323,9 +323,9 @@ and rewrite_class_field iflag =
   function
     Pcf_inher (cexpr, _)     -> rewrite_class_expr iflag cexpr
   | Pcf_val (_, _, sexp, _)  -> rewrite_exp iflag sexp
-  | Pcf_meth (_, _, ({pexp_desc = Pexp_function _} as sexp), _) ->
+  | Pcf_meth (_, _, _, ({pexp_desc = Pexp_function _} as sexp), _) ->
       rewrite_exp iflag sexp
-  | Pcf_meth (_, _, sexp, loc) ->
+  | Pcf_meth (_, _, _, sexp, loc) ->
       if !instr_fun && not loc.loc_ghost then insert_profile rw_exp sexp
       else rewrite_exp iflag sexp
   | Pcf_let(_, spat_sexp_list, _) ->
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 7f6c1de241..8bcdfc9319 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -50,6 +50,7 @@ type error =
       Ident.t * Types.class_declaration * (type_expr * type_expr) list
   | Final_self_clash of (type_expr * type_expr) list
   | Mutability_mismatch of string * mutable_flag
+  | MethodDoesNotOverride of string
 
 exception Error of Location.t * error
 
@@ -508,7 +509,16 @@ let rec class_field cl_num self_type meths vars
       (val_env, met_env, par_env, fields, concr_meths, warn_meths,
        warn_vals, inher)
 
-  | Pcf_meth (lab, priv, expr, loc)  ->
+  | Pcf_meth (lab, priv, override, expr, loc)  ->
+      begin
+        match override, Concr.mem lab concr_meths with
+        | true, false ->
+            raise(Error(loc, MethodDoesNotOverride lab));
+        | false, true ->
+            Location.prerr_warning loc (Warnings.Missing_override_modifier)
+        | true, true | false, false -> ()
+      end;
+
       if Concr.mem lab warn_meths then
         Location.prerr_warning loc (Warnings.Method_override [lab]);
       let (_, ty) =
@@ -1597,3 +1607,7 @@ let report_error ppf = function
       fprintf ppf
         "@[The instance variable is %s;@ it cannot be redefined as %s@]"
         mut1 mut2
+  | MethodDoesNotOverride lab ->
+      fprintf ppf
+        "@[The method %s does not override an existing method@]"
+        lab
diff --git a/typing/typeclass.mli b/typing/typeclass.mli
index 20d2d32503..32ef69f13b 100644
--- a/typing/typeclass.mli
+++ b/typing/typeclass.mli
@@ -75,6 +75,7 @@ type error =
       Ident.t * Types.class_declaration * (type_expr * type_expr) list
   | Final_self_clash of (type_expr * type_expr) list
   | Mutability_mismatch of string * mutable_flag
+  | MethodDoesNotOverride of string
 
 exception Error of Location.t * error
 
diff --git a/typing/unused_var.ml b/typing/unused_var.ml
index d11a0b487c..708ae1c99c 100644
--- a/typing/unused_var.ml
+++ b/typing/unused_var.ml
@@ -251,7 +251,7 @@ and class_field ppf tbl cf =
   | Pcf_inher (ce, _) -> class_expr ppf tbl ce;
   | Pcf_val (_, _, e, _) -> expression ppf tbl e;
   | Pcf_virt _ | Pcf_valvirt _ -> ()
-  | Pcf_meth (_, _, e, _) -> expression ppf tbl e;
+  | Pcf_meth (_, _, _, e, _) -> expression ppf tbl e;
   | Pcf_cstr _ -> ()
   | Pcf_let (recflag, pel, _) -> let_pel ppf tbl recflag pel None;
   | Pcf_init e -> expression ppf tbl e;
diff --git a/utils/warnings.ml b/utils/warnings.ml
index f66faa55a1..ed3cee82c4 100644
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -47,6 +47,7 @@ type t =
   | Bad_module_name of string               (* 25 *)
   | Unused_var of string                    (* 26 *)
   | Unused_var_strict of string             (* 27 *)
+  | Missing_override_modifier               (* 28 *)
 ;;
 
 (* If you remove a warning, leave a hole in the numbering.  NEVER change
@@ -83,9 +84,10 @@ let number = function
   | All_clauses_guarded -> 25
   | Unused_var _ -> 26
   | Unused_var_strict _ -> 27
+  | Missing_override_modifier -> 28
 ;;
 
-let last_warning_number = 27;;
+let last_warning_number = 28;;
 (* Must be the max number returned by the [number] function. *)
 
 let letter = function
@@ -238,6 +240,8 @@ let message = function
        but no fields are borrowed from the original."
   | Bad_module_name (modname) ->
       "bad source file name: \"" ^ modname ^ "\" is not a valid module name."
+  | Missing_override_modifier ->
+      "missing override modifier"
 ;;
 
 let nerrors = ref 0;;
diff --git a/utils/warnings.mli b/utils/warnings.mli
index 7ee18b0a0a..23bfd3902b 100644
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -42,6 +42,7 @@ type t =
   | Bad_module_name of string               (* 25 *)
   | Unused_var of string                    (* 26 *)
   | Unused_var_strict of string             (* 27 *)
+  | Missing_override_modifier               (* 28 *)
 ;;
 
 val parse_options : bool -> string -> unit;;