diff options
30 files changed, 209 insertions, 161 deletions
diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml index 6901b5594..50b962f89 100644 --- a/asmcomp/amd64/reload.ml +++ b/asmcomp/amd64/reload.ml @@ -62,7 +62,7 @@ class reload = object (self) inherit Reloadgen.reload_generic as super -method reload_operation op arg res = +method! reload_operation op arg res = match op with Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound) -> (* One of the two arguments can reside in the stack, but not both *) @@ -99,7 +99,7 @@ method reload_operation op arg res = | _ -> (* Other operations: all args and results in registers *) super#reload_operation op arg res -method reload_test tst arg = +method! reload_test tst arg = match tst with Iinttest cmp -> (* One of the two arguments can reside on stack *) diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index 26955f409..4921e5110 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -138,7 +138,7 @@ method select_addressing exp = | Ascaledadd(e1, e2, scale) -> (Iindexed2scaled(scale, d), Ctuple[e1; e2]) -method select_store addr exp = +method! select_store addr exp = match exp with Cconst_int n when self#is_immediate n -> (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) @@ -153,7 +153,7 @@ method select_store addr exp = | _ -> super#select_store addr exp -method select_operation op args = +method! select_operation op args = match op with (* Recognize the LEA instruction *) Caddi | Cadda | Csubi | Csuba -> @@ -217,7 +217,7 @@ method select_floatarith commutative regular_op mem_op args = (* Deal with register constraints *) -method insert_op_debug op dbg rs rd = +method! insert_op_debug op dbg rs rd = try let (rsrc, rdst) = pseudoregs_for_operation op rs rd in self#insert_moves rs rsrc; @@ -227,7 +227,7 @@ method insert_op_debug op dbg rs rd = with Use_default -> super#insert_op_debug op dbg rs rd -method insert_op op rs rd = +method! insert_op op rs rd = self#insert_op_debug op Debuginfo.none rs rd end diff --git a/asmcomp/i386/reload.ml b/asmcomp/i386/reload.ml index 3ed4aaaf6..539d45dae 100644 --- a/asmcomp/i386/reload.ml +++ b/asmcomp/i386/reload.ml @@ -28,7 +28,7 @@ class reload = object (self) inherit Reloadgen.reload_generic as super -method makereg r = +method! makereg r = match r.typ with Float -> r | _ -> super#makereg r @@ -37,7 +37,7 @@ method makereg r = will never be reloaded. Hence there is no need to make special cases for floating-point operations. *) -method reload_operation op arg res = +method! reload_operation op arg res = match op with Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound) -> (* One of the two arguments can reside in the stack *) @@ -66,7 +66,7 @@ method reload_operation op arg res = | _ -> (* Other operations: all args and results in registers *) super#reload_operation op arg res -method reload_test tst arg = +method! reload_test tst arg = match tst with Iinttest cmp -> (* One of the two arguments can reside on stack *) diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml index d9600f16d..5a8720fbe 100644 --- a/asmcomp/i386/selection.ml +++ b/asmcomp/i386/selection.ml @@ -159,7 +159,7 @@ inherit Selectgen.selector_generic as super method is_immediate (n : int) = true -method is_simple_expr e = +method! is_simple_expr e = match e with | Cop(Cextcall(fn, _, alloc, _), args) when !fast_math && List.mem fn inline_float_ops -> @@ -181,7 +181,7 @@ method select_addressing exp = | (Ascaledadd(e1, e2, scale), d) -> (Iindexed2scaled(scale, d), Ctuple[e1; e2]) -method select_store addr exp = +method! select_store addr exp = match exp with Cconst_int n -> (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) @@ -196,7 +196,7 @@ method select_store addr exp = | _ -> super#select_store addr exp -method select_operation op args = +method! select_operation op args = match op with (* Recognize the LEA instruction *) Caddi | Cadda | Csubi | Csuba -> @@ -269,7 +269,7 @@ method select_floatarith regular_op reversed_op mem_op mem_rev_op args = (* Deal with register constraints *) -method insert_op_debug op dbg rs rd = +method! insert_op_debug op dbg rs rd = try let (rsrc, rdst, move_res) = pseudoregs_for_operation op rs rd in self#insert_moves rs rsrc; @@ -282,7 +282,7 @@ method insert_op_debug op dbg rs rd = with Use_default -> super#insert_op_debug op dbg rs rd -method insert_op op rs rd = +method! insert_op op rs rd = self#insert_op_debug op Debuginfo.none rs rd (* Selection of push instructions for external calls *) @@ -302,7 +302,7 @@ method select_push exp = (Ispecific(Ipush_load_float addr), arg) | _ -> (Ispecific(Ipush), exp) -method emit_extcall_args env args = +method! emit_extcall_args env args = let rec size_pushes = function | [] -> 0 | e :: el -> Selectgen.size_expr env e + size_pushes el in diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 8989aa7de..46a38ecca 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex 99d892e53..35582ec50 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex a290fde30..811b9f03b 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml index a4a904206..dc5192bf0 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -1009,8 +1009,8 @@ module Make (Ast : Sig.Camlp4Ast) = struct | CrCtr loc t1 t2 -> [Pcf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l] | <:class_str_item< $cst1$; $cst2$ >> -> class_str_item cst1 (class_str_item cst2 l) - | CrInh _ ce "" -> [Pcf_inher (class_expr ce) None :: l] - | CrInh _ ce pb -> [Pcf_inher (class_expr ce) (Some pb) :: l] + | CrInh _ ce "" -> [Pcf_inher Fresh (class_expr ce) None :: l] + | CrInh _ ce pb -> [Pcf_inher Fresh (class_expr ce) (Some pb) :: l] | CrIni _ e -> [Pcf_init (expr e) :: l] | CrMth loc s b e t -> let t = @@ -1018,8 +1018,9 @@ 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] - | CrVal loc s b e -> [Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l] + [Pcf_meth (s, mkprivate b, Fresh, e, mkloc loc) :: l] + | CrVal loc s b e -> + [Pcf_val (s, mkmutable b, Fresh, expr e, mkloc loc) :: l] | CrVir loc s b t -> [Pcf_virt (s, mkprivate b, mkpolytype (ctyp t), mkloc loc) :: l] | CrVvr loc s b t -> diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml index abaa0950c..b2ae399fe 100644 --- a/camlp4/boot/Camlp4.ml +++ b/camlp4/boot/Camlp4.ml @@ -14539,9 +14539,9 @@ module Struct = (Pcf_cstr (((ctyp t1), (ctyp t2), (mkloc loc)))) :: l | Ast.CrSem (_, cst1, cst2) -> class_str_item cst1 (class_str_item cst2 l) - | CrInh (_, ce, "") -> (Pcf_inher (class_expr ce, None)) :: l + | CrInh (_, ce, "") -> (Pcf_inher (Fresh, class_expr ce, None)) :: l | CrInh (_, ce, pb) -> - (Pcf_inher (class_expr ce, Some pb)) :: l + (Pcf_inher (Fresh, class_expr ce, Some pb)) :: l | CrIni (_, e) -> (Pcf_init (expr e)) :: l | CrMth (loc, s, b, e, t) -> let t = @@ -14549,9 +14549,9 @@ 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), Fresh, e, (mkloc loc)))) :: l | CrVal (loc, s, b, e) -> - (Pcf_val ((s, (mkmutable b), (expr e), (mkloc loc)))) :: l + (Pcf_val ((s, (mkmutable b), Fresh, (expr e), (mkloc loc)))) :: l | CrVir (loc, s, b, t) -> (Pcf_virt ((s, (mkprivate b), (mkpolytype (ctyp t)), (mkloc loc)))) :: diff --git a/myocamlbuild.ml b/myocamlbuild.ml index b1ec1eb4d..92067c4d6 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"; A"-warn-error";A"Almer"]);; +flag ["ocaml"; "compile"; "warn_Alerzv"] (S[A"-w";A"Alerzv"; A"-warn-error";A"Almerzv"]);; non_dependency "otherlibs/threads/pervasives.ml" "Unix";; non_dependency "otherlibs/threads/pervasives.ml" "String";; diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index 242ac9c7c..4922d059a 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -514,17 +514,21 @@ module Analyser = in (acc_inher, acc_fields @ ele_comments) - | (Parsetree.Pcf_inher (p_clexp, _)) :: q -> + | (Parsetree.Pcf_inher (_, p_clexp, _)) :: q -> let tt_clexp = let n = List.length acc_inher in try Typedtree_search.get_nth_inherit_class_expr tt_cls n - with Not_found -> raise (Failure (Odoc_messages.inherit_classexp_not_found_in_typedtree n)) + with Not_found -> + raise (Failure ( + Odoc_messages.inherit_classexp_not_found_in_typedtree n)) in let (info_opt, ele_comments) = get_comments_in_class last_pos p_clexp.Parsetree.pcl_loc.Location.loc_start.Lexing.pos_cnum in - let text_opt = match info_opt with None -> None | Some i -> i.Odoc_types.i_desc in + let text_opt = + match info_opt with None -> None + | Some i -> i.Odoc_types.i_desc in let name = tt_name_of_class_expr tt_clexp in let inher = { @@ -537,8 +541,8 @@ module Analyser = p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum q - | ((Parsetree.Pcf_val (label, mutable_flag, _, loc) | - Parsetree.Pcf_valvirt (label, mutable_flag, _, loc) ) as x) :: q -> + | ((Parsetree.Pcf_val (label, mutable_flag, _, _, loc) | + Parsetree.Pcf_valvirt (label, mutable_flag, _, loc) ) as x) :: q -> let virt = match x with Parsetree.Pcf_val _ -> false | _ -> true in 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 @@ -602,7 +606,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/ocamldoc/odoc_cross.ml b/ocamldoc/odoc_cross.ml index 2af4d1e8b..2f81e5dbb 100644 --- a/ocamldoc/odoc_cross.ml +++ b/ocamldoc/odoc_cross.ml @@ -244,28 +244,28 @@ let lookup_exception name = class scan = object inherit Odoc_scan.scanner - method scan_value v = + method! scan_value v = add_known_element v.val_name (Odoc_search.Res_value v) - method scan_type t = + method! scan_type t = add_known_element t.ty_name (Odoc_search.Res_type t) - method scan_exception e = + method! scan_exception e = add_known_element e.ex_name (Odoc_search.Res_exception e) - method scan_attribute a = + method! scan_attribute a = add_known_element a.att_value.val_name (Odoc_search.Res_attribute a) - method scan_method m = + method! scan_method m = add_known_element m.met_value.val_name (Odoc_search.Res_method m) - method scan_class_pre c = + method! scan_class_pre c = add_known_element c.cl_name (Odoc_search.Res_class c); true - method scan_class_type_pre c = + method! scan_class_type_pre c = add_known_element c.clt_name (Odoc_search.Res_class_type c); true - method scan_module_pre m = + method! scan_module_pre m = add_known_element m.m_name (Odoc_search.Res_module m); true - method scan_module_type_pre m = + method! scan_module_type_pre m = add_known_element m.mt_name (Odoc_search.Res_module_type m); true diff --git a/ocamldoc/odoc_test.ml b/ocamldoc/odoc_test.ml index c11352fad..a9868f6ef 100644 --- a/ocamldoc/odoc_test.ml +++ b/ocamldoc/odoc_test.ml @@ -44,7 +44,7 @@ class string_gen = None -> [] | Some i -> i.i_custom ) - method scan_type t = + method! scan_type t = match test_kinds with [] -> () | _ -> @@ -59,7 +59,7 @@ class string_gen = ); - method scan_module_pre m = + method! scan_module_pre m = p fmt "#\n# module %s:\n" m.m_name ; if self#must_display_types then ( @@ -70,7 +70,7 @@ class string_gen = ); true - method scan_module_type_pre m = + method! scan_module_type_pre m = p fmt "#\n# module type %s:\n" m.mt_name ; if self#must_display_types then ( diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml index ad669b4d8..3a2e5db66 100644 --- a/ocamldoc/odoc_texi.ml +++ b/ocamldoc/odoc_texi.ml @@ -474,7 +474,7 @@ class texi = Raw " " ; Raw s ; Raw ": " ] @ t @ [ Newline ] ) params_list) - method text_of_raised_exceptions = function + method! text_of_raised_exceptions = function | [] -> [] | (s, t) :: [] -> [ linebreak ; @@ -490,12 +490,12 @@ class texi = (fun (ex, desc) ->(Code ex) :: (Raw " ") :: desc ) l ) ; Newline ] - method text_of_return_opt = function + method! text_of_return_opt = function | None -> [] | Some t -> (Bold [Raw Odoc_messages.returns ]) :: Raw " " :: t @ [ Newline ] - method text_of_custom c_l = + method! text_of_custom c_l = List.flatten (List.rev (List.fold_left @@ -509,7 +509,7 @@ class texi = acc ) [] c_l)) - method text_of_info ?(block=false) = function + method! text_of_info ?(block=false) = function | None -> [] | Some info -> let t = @@ -559,7 +559,7 @@ class texi = (self#relative_idents m_name (Odoc_info.string_of_type_expr typ))) - method text_of_short_type_expr m_name typ = + method! text_of_short_type_expr m_name typ = [ Raw (self#normal_type m_name typ) ] (** Return Texinfo code for a value. *) diff --git a/otherlibs/labltk/browser/jg_box.ml b/otherlibs/labltk/browser/jg_box.ml index 681e79e0b..3675f4bfa 100644 --- a/otherlibs/labltk/browser/jg_box.ml +++ b/otherlibs/labltk/browser/jg_box.ml @@ -39,7 +39,7 @@ let recenter lb ~index = class timed ?wait ?nocase get_texts = object val get_texts = get_texts inherit Jg_completion.timed [] ?wait ?nocase as super - method reset = + method! reset = texts <- get_texts (); super#reset end diff --git a/otherlibs/labltk/browser/jg_completion.ml b/otherlibs/labltk/browser/jg_completion.ml index feb03c42f..c93b099b3 100644 --- a/otherlibs/labltk/browser/jg_completion.ml +++ b/otherlibs/labltk/browser/jg_completion.ml @@ -41,13 +41,13 @@ class timed ?nocase ?wait texts = object (self) inherit completion texts ?nocase as super val wait = match wait with None -> 500 | Some n -> n val mutable timer = None - method add c = + method! add c = begin match timer with None -> self#reset | Some t -> Timer.remove t end; timer <- Some (Timer.add ~ms:wait ~callback:(fun () -> self#reset)); super#add c - method reset = + method! reset = timer <- None; super#reset end diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli index 2b37ca6e8..2530b44c6 100644 --- a/parsing/asttypes.mli +++ b/parsing/asttypes.mli @@ -33,6 +33,8 @@ type mutable_flag = Immutable | Mutable type virtual_flag = Virtual | Concrete +type override_flag = Override | Fresh + type closed_flag = Closed | Open type label = string diff --git a/parsing/lexer.mll b/parsing/lexer.mll index 4119945d7..5da264ec0 100644 --- a/parsing/lexer.mll +++ b/parsing/lexer.mll @@ -380,6 +380,7 @@ rule token = parse | ">]" { GREATERRBRACKET } | "}" { RBRACE } | ">}" { GREATERRBRACE } + | "!" { BANG } | "!=" { INFIXOP0 "!=" } | "+" { PLUS } @@ -387,7 +388,7 @@ rule token = parse | "-" { MINUS } | "-." { MINUSDOT } - | "!" symbolchar * + | "!" symbolchar + { PREFIXOP(Lexing.lexeme lexbuf) } | ['~' '?'] symbolchar + { PREFIXOP(Lexing.lexeme lexbuf) } diff --git a/parsing/parser.mly b/parsing/parser.mly index c9bbabbdd..3cf3ba412 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -213,6 +213,7 @@ let pat_of_label lbl = %token AS %token ASSERT %token BACKQUOTE +%token BANG %token BAR %token BARBAR %token BARRBRACKET @@ -374,7 +375,7 @@ The precedences must be listed from low to high. %nonassoc below_DOT %nonassoc DOT /* Finally, the first tokens of simple_expr are above everything else. */ -%nonassoc BACKQUOTE BEGIN CHAR FALSE FLOAT INT INT32 INT64 +%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT INT32 INT64 LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN NEW NATIVEINT PREFIXOP STRING TRUE UIDENT @@ -646,8 +647,8 @@ class_self_pattern: class_fields: /* empty */ { [] } - | class_fields INHERIT class_expr parent_binder - { Pcf_inher ($3, $4) :: $1 } + | class_fields INHERIT override_flag class_expr parent_binder + { Pcf_inher ($3, $4, $5) :: $1 } | class_fields VAL virtual_value { Pcf_valvirt $3 :: $1 } | class_fields VAL value @@ -668,29 +669,31 @@ parent_binder: { None } ; virtual_value: - MUTABLE VIRTUAL label COLON core_type - { $3, Mutable, $5, symbol_rloc () } + override_flag MUTABLE VIRTUAL label COLON core_type + { if $1 = Override then syntax_error (); + $4, Mutable, $6, symbol_rloc () } | VIRTUAL mutable_flag label COLON core_type { $3, $2, $5, symbol_rloc () } ; value: - mutable_flag label EQUAL seq_expr - { $2, $1, $4, symbol_rloc () } - | mutable_flag label type_constraint EQUAL seq_expr - { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))), + override_flag mutable_flag label EQUAL seq_expr + { $3, $2, $1, $5, symbol_rloc () } + | override_flag mutable_flag label type_constraint EQUAL seq_expr + { $3, $2, $1, (let (t, t') = $4 in ghexp(Pexp_constraint($6, t, t'))), symbol_rloc () } ; virtual_method: - METHOD PRIVATE VIRTUAL label COLON poly_type - { $4, Private, $6, symbol_rloc () } + METHOD override_flag PRIVATE VIRTUAL label COLON poly_type + { if $2 = Override then syntax_error (); + $5, Private, $7, symbol_rloc () } | 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 () } + METHOD override_flag private_flag label strict_binding + { $4, $3, $2, ghexp(Pexp_poly ($5, None)), symbol_rloc () } + | METHOD override_flag private_flag label COLON poly_type EQUAL seq_expr + { $4, $3, $2, ghexp(Pexp_poly($8,Some $6)), symbol_rloc () } ; /* Class types */ @@ -700,12 +703,14 @@ class_type: { $1 } | QUESTION LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type { mkcty(Pcty_fun("?" ^ $2 , - {ptyp_desc = Ptyp_constr(Ldot (Lident "*predef*", "option"), [$4]); + {ptyp_desc = + Ptyp_constr(Ldot (Lident "*predef*", "option"), [$4]); ptyp_loc = $4.ptyp_loc}, $6)) } | OPTLABEL simple_core_type_or_tuple MINUSGREATER class_type { mkcty(Pcty_fun("?" ^ $1 , - {ptyp_desc = Ptyp_constr(Ldot (Lident "*predef*", "option"), [$2]); + {ptyp_desc = + Ptyp_constr(Ldot (Lident "*predef*", "option"), [$2]); ptyp_loc = $2.ptyp_loc}, $4)) } | LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type @@ -988,6 +993,8 @@ simple_expr: { unclosed "[" 1 "]" 4 } | PREFIXOP simple_expr { mkexp(Pexp_apply(mkoperator $1 1, ["",$2])) } + | BANG simple_expr + { mkexp(Pexp_apply(mkoperator "!" 1, ["",$2])) } | NEW class_longident { mkexp(Pexp_new($2)) } | LBRACELESS field_expr_list opt_semi GREATERRBRACE @@ -1493,6 +1500,7 @@ operator: | INFIXOP2 { $1 } | INFIXOP3 { $1 } | INFIXOP4 { $1 } + | BANG { "!" } | PLUS { "+" } | PLUSDOT { "+." } | MINUS { "-" } @@ -1594,6 +1602,10 @@ virtual_flag: /* empty */ { Concrete } | VIRTUAL { Virtual } ; +override_flag: + /* empty */ { Fresh } + | BANG { Override } +; opt_bar: /* empty */ { () } | BAR { () } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 72cfd3a46..baa5e0245 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -185,11 +185,11 @@ and class_expr_desc = and class_structure = pattern * class_field list and class_field = - Pcf_inher of class_expr * string option + Pcf_inher of override_flag * class_expr * string option | Pcf_valvirt of (string * mutable_flag * core_type * Location.t) - | Pcf_val of (string * mutable_flag * expression * Location.t) + | Pcf_val of (string * mutable_flag * override_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 *override_flag * 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 514fbf779..676cf622f 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -65,6 +65,12 @@ let fmt_virtual_flag f x = | Concrete -> fprintf f "Concrete"; ;; +let fmt_override_flag f x = + match x with + | Override -> fprintf f "Override"; + | Fresh -> fprintf f "Fresh"; +;; + let fmt_rec_flag f x = match x with | Nonrecursive -> fprintf f "Nonrec"; @@ -453,25 +459,25 @@ and class_structure i ppf (p, l) = and class_field i ppf x = match x with - | Pcf_inher (ce, so) -> - line i ppf "Pcf_inher\n"; + | Pcf_inher (ovf, ce, so) -> + line i ppf "Pcf_inher %a\n" fmt_override_flag ovf; class_expr (i+1) ppf ce; option (i+1) string ppf so; | Pcf_valvirt (s, mf, ct, loc) -> - line i ppf - "Pcf_valvirt \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc; + line i ppf "Pcf_valvirt \"%s\" %a %a\n" + s fmt_mutable_flag mf fmt_location loc; core_type (i+1) ppf ct; - | Pcf_val (s, mf, e, loc) -> - line i ppf - "Pcf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc; + | Pcf_val (s, mf, ovf, e, loc) -> + line i ppf "Pcf_val \"%s\" %a %a %a\n" + s fmt_mutable_flag mf fmt_override_flag ovf fmt_location loc; expression (i+1) ppf e; | Pcf_virt (s, pf, ct, loc) -> - line i ppf - "Pcf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc; + 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) -> - line i ppf - "Pcf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc; + | Pcf_meth (s, pf, ovf, e, loc) -> + line i ppf "Pcf_meth \"%s\" %a %a %a\n" + s fmt_private_flag pf fmt_override_flag ovf 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/addlabels.ml b/tools/addlabels.ml index 87dace563..15ad6f5a1 100644 --- a/tools/addlabels.ml +++ b/tools/addlabels.ml @@ -296,10 +296,10 @@ let rec add_labels_class ~text ~classes ~values ~methods cl = in ignore (List.fold_left l ~init:values ~f: begin fun values -> function - | Pcf_val (s, _, e, _) -> + | Pcf_val (s, _, _, e, _) -> add_labels_expr ~text ~classes ~values e; SMap.removes [s] values - | Pcf_meth (s, _, e, _) -> + | Pcf_meth (s, _, _, e, _) -> begin try let labels = List.assoc s methods in insert_labels ~labels ~text e diff --git a/tools/depend.ml b/tools/depend.ml index 573f399f1..491df4fc2 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -291,11 +291,11 @@ and add_class_expr bv ce = add_class_expr bv ce; add_class_type bv ct and add_class_field bv = function - Pcf_inher(ce, _) -> add_class_expr bv ce - | Pcf_val(_, _, e, _) -> add_expr bv e + Pcf_inher(_, ce, _) -> add_class_expr bv ce + | 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 2fd2b044d..55f114c5e 100644 --- a/tools/ocamlprof.ml +++ b/tools/ocamlprof.ml @@ -321,11 +321,11 @@ and rewrite_trymatching l = 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_inher (_, cexpr, _) -> rewrite_class_expr iflag cexpr + | Pcf_val (_, _, _, sexp, _) -> rewrite_exp iflag 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 7f6c1de24..013275ca0 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 + | No_overriding of string * string exception Error of Location.t * error @@ -223,7 +224,12 @@ let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc = vars := Vars.add lab (id, mut, virt, ty) !vars; result -let inheritance self_type env concr_meths warn_meths loc parent = +let concr_vals vars = + Vars.fold + (fun id (_, vf, _) s -> if vf = Virtual then s else Concr.add id s) + vars Concr.empty + +let inheritance self_type env ovf concr_meths warn_vals loc parent = match scrape_class_type parent with Tcty_signature cl_sig -> @@ -238,22 +244,34 @@ let inheritance self_type env concr_meths warn_meths loc parent = assert false end; - let overridings = Concr.inter cl_sig.cty_concr warn_meths in - if not (Concr.is_empty overridings) then begin - let cname = - match parent with - Tcty_constr (p, _, _) -> Path.name p - | _ -> "inherited" - in - Location.prerr_warning loc - (Warnings.Method_override (cname :: Concr.elements overridings)) + (* Overriding *) + let over_meths = Concr.inter cl_sig.cty_concr concr_meths in + let concr_vals = concr_vals cl_sig.cty_vars in + let over_vals = Concr.inter concr_vals warn_vals in + begin match ovf with + Some Fresh -> + let cname = + match parent with + Tcty_constr (p, _, _) -> Path.name p + | _ -> "inherited" + in + if not (Concr.is_empty over_meths) then + Location.prerr_warning loc + (Warnings.Method_override (cname :: Concr.elements over_meths)); + if not (Concr.is_empty over_vals) then + Location.prerr_warning loc + (Warnings.Instance_variable_override + (cname :: Concr.elements over_vals)); + | Some Override + when Concr.is_empty over_meths && Concr.is_empty over_vals -> + raise (Error(loc, No_overriding ("",""))) + | _ -> () end; - let concr_meths = Concr.union cl_sig.cty_concr concr_meths in - (* No need to warn about overriding of inherited methods! *) - (* let warn_meths = Concr.union cl_sig.cty_concr warn_meths in *) + let concr_meths = Concr.union cl_sig.cty_concr concr_meths + and warn_vals = Concr.union concr_vals warn_vals in - (cl_sig, concr_meths, warn_meths) + (cl_sig, concr_meths, warn_vals) | _ -> raise(Error(loc, Structure_expected parent)) @@ -319,7 +337,7 @@ let rec class_type_field env self_type meths (val_sig, concr_meths, inher) = | _ -> inher in let (cl_sig, concr_meths, _) = - inheritance self_type env concr_meths Concr.empty sparent.pcty_loc + inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc parent in let val_sig = @@ -410,41 +428,31 @@ let class_type env scty = (*******************************) -module StringSet = Set.Make(struct type t = string let compare = compare end) - let rec class_field cl_num self_type meths vars - (val_env, met_env, par_env, fields, concr_meths, warn_meths, - warn_vals, inher) = + (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher) = function - Pcf_inher (sparent, super) -> + Pcf_inher (ovf, sparent, super) -> let parent = class_expr cl_num val_env par_env sparent in let inher = match parent.cl_type with Tcty_constr (p, tl, _) -> (p, tl) :: inher | _ -> inher in - let (cl_sig, concr_meths, warn_meths) = - inheritance self_type val_env concr_meths warn_meths sparent.pcl_loc - parent.cl_type + let (cl_sig, concr_meths, warn_vals) = + inheritance self_type val_env (Some ovf) concr_meths warn_vals + sparent.pcl_loc parent.cl_type in (* Variables *) - let (val_env, met_env, par_env, inh_vars, warn_vals) = + let (val_env, met_env, par_env, inh_vars) = Vars.fold - (fun lab info (val_env, met_env, par_env, inh_vars, warn_vals) -> + (fun lab info (val_env, met_env, par_env, inh_vars) -> let mut, vr, ty = info in let (id, val_env, met_env, par_env) = enter_val cl_num vars true lab mut vr ty val_env met_env par_env sparent.pcl_loc in - let warn_vals = - if vr = Virtual then warn_vals else - if StringSet.mem lab warn_vals then - (Location.prerr_warning sparent.pcl_loc - (Warnings.Instance_variable_override lab); warn_vals) - else StringSet.add lab warn_vals - in - (val_env, met_env, par_env, (lab, id) :: inh_vars, warn_vals)) - cl_sig.cty_vars (val_env, met_env, par_env, [], warn_vals) + (val_env, met_env, par_env, (lab, id) :: inh_vars)) + cl_sig.cty_vars (val_env, met_env, par_env, []) in (* Inherited concrete methods *) let inh_meths = @@ -465,7 +473,7 @@ let rec class_field cl_num self_type meths vars in (val_env, met_env, par_env, lazy(Cf_inher (parent, inh_vars, inh_meths))::fields, - concr_meths, warn_meths, warn_vals, inher) + concr_meths, warn_vals, inher) | Pcf_valvirt (lab, mut, styp, loc) -> if !Clflags.principal then Ctype.begin_def (); @@ -480,11 +488,16 @@ let rec class_field cl_num self_type meths vars in (val_env, met_env', par_env, lazy(Cf_val (lab, id, None, met_env' == met_env)) :: fields, - concr_meths, warn_meths, StringSet.remove lab warn_vals, inher) - - | Pcf_val (lab, mut, sexp, loc) -> - if StringSet.mem lab warn_vals then - Location.prerr_warning loc (Warnings.Instance_variable_override lab); + concr_meths, warn_vals, inher) + + | Pcf_val (lab, mut, ovf, sexp, loc) -> + if Concr.mem lab warn_vals then begin + if ovf = Fresh then + Location.prerr_warning loc (Warnings.Instance_variable_override[lab]) + end else begin + if ovf = Override then + raise(Error(loc, No_overriding ("instance variable", lab))) + end; if !Clflags.principal then Ctype.begin_def (); let exp = try type_exp val_env sexp with Ctype.Unify [(ty, _)] -> @@ -500,17 +513,19 @@ let rec class_field cl_num self_type meths vars in (val_env, met_env', par_env, lazy(Cf_val (lab, id, Some exp, met_env' == met_env)) :: fields, - concr_meths, warn_meths, StringSet.add lab warn_vals, inher) + concr_meths, Concr.add lab warn_vals, inher) | Pcf_virt (lab, priv, sty, loc) -> virtual_method val_env meths self_type lab priv sty loc; - let warn_meths = Concr.remove lab warn_meths in - (val_env, met_env, par_env, fields, concr_meths, warn_meths, - warn_vals, inher) - - | Pcf_meth (lab, priv, expr, loc) -> - if Concr.mem lab warn_meths then - Location.prerr_warning loc (Warnings.Method_override [lab]); + (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher) + + | Pcf_meth (lab, priv, ovf, expr, loc) -> + if Concr.mem lab concr_meths then begin + if ovf = Fresh then + Location.prerr_warning loc (Warnings.Method_override [lab]) + end else begin + if ovf = Override then raise(Error(loc, No_overriding("method", lab))) + end; let (_, ty) = Ctype.filter_self_method val_env lab priv meths self_type in @@ -551,12 +566,11 @@ let rec class_field cl_num self_type meths vars Cf_meth (lab, texp) end in (val_env, met_env, par_env, field::fields, - Concr.add lab concr_meths, Concr.add lab warn_meths, warn_vals, inher) + Concr.add lab concr_meths, warn_vals, inher) | Pcf_cstr (sty, sty', loc) -> type_constraint val_env sty sty' loc; - (val_env, met_env, par_env, fields, concr_meths, warn_meths, - warn_vals, inher) + (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher) | Pcf_let (rec_flag, sdefs, loc) -> let (defs, val_env) = @@ -586,7 +600,7 @@ let rec class_field cl_num self_type meths vars ([], met_env, par_env) in (val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields, - concr_meths, warn_meths, warn_vals, inher) + concr_meths, warn_vals, inher) | Pcf_init expr -> let expr = make_method cl_num expr in @@ -602,8 +616,7 @@ let rec class_field cl_num self_type meths vars Ctype.end_def (); Cf_init texp end in - (val_env, met_env, par_env, field::fields, - concr_meths, warn_meths, warn_vals, inher) + (val_env, met_env, par_env, field::fields, concr_meths, warn_vals, inher) and class_structure cl_num final val_env met_env loc (spat, str) = (* Environment for substructures *) @@ -648,10 +661,9 @@ and class_structure cl_num final val_env met_env loc (spat, str) = end; (* Typing of class fields *) - let (_, _, _, fields, concr_meths, _, _, inher) = + let (_, _, _, fields, concr_meths, _, inher) = List.fold_left (class_field cl_num self_type meths vars) - (val_env, meth_env, par_env, [], Concr.empty, Concr.empty, - StringSet.empty, []) + (val_env, meth_env, par_env, [], Concr.empty, Concr.empty, []) str in Ctype.unify val_env self_type (Ctype.newvar ()); @@ -1597,3 +1609,8 @@ let report_error ppf = function fprintf ppf "@[The instance variable is %s;@ it cannot be redefined as %s@]" mut1 mut2 + | No_overriding (_, "") -> + fprintf ppf "@[This inheritance does not override any method@ %s@]" + "instance variable" + | No_overriding (kind, name) -> + fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name diff --git a/typing/typeclass.mli b/typing/typeclass.mli index 20d2d3250..17ec69854 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 + | No_overriding of string * string exception Error of Location.t * error diff --git a/typing/types.mli b/typing/types.mli index 2f57df347..a4c640845 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -92,8 +92,7 @@ and value_kind = | Val_prim of Primitive.description (* Primitive *) | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) | Val_self of (Ident.t * type_expr) Meths.t ref * - (Ident.t * Asttypes.mutable_flag * - Asttypes.virtual_flag * type_expr) Vars.t ref * + (Ident.t * mutable_flag * virtual_flag * type_expr) Vars.t ref * string * type_expr (* Self *) | Val_anc of (string * Ident.t) list * string @@ -162,8 +161,7 @@ type class_type = and class_signature = { cty_self: type_expr; - cty_vars: - (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; + cty_vars: (mutable_flag * virtual_flag * type_expr) Vars.t; cty_concr: Concr.t; cty_inher: (Path.t * type_expr list) list } diff --git a/typing/unused_var.ml b/typing/unused_var.ml index d11a0b487..4339d9b0d 100644 --- a/typing/unused_var.ml +++ b/typing/unused_var.ml @@ -248,10 +248,10 @@ and class_structure ppf tbl (p, cfl) = and class_field ppf tbl cf = match cf with - | Pcf_inher (ce, _) -> class_expr ppf tbl ce; - | Pcf_val (_, _, e, _) -> expression ppf tbl e; + | 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 1624f06ca..8f84369d5 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -32,7 +32,7 @@ type t = | Statement_type (* 10 *) | Unused_match (* 11 *) | Unused_pat (* 12 *) - | Instance_variable_override of string (* 13 *) + | Instance_variable_override of string list (* 13 *) | Illegal_backslash (* 14 *) | Implicit_public_methods of string list (* 15 *) | Unerasable_optional_argument (* 16 *) @@ -199,7 +199,7 @@ let message = function | Labels_omitted -> "labels were omitted in the application of this function." | Method_override [lab] -> - "the method " ^ lab ^ " is overridden in the same class." + "the method " ^ lab ^ " is overridden." | Method_override (cname :: slist) -> String.concat " " ("the following methods are overriden by the class" @@ -216,9 +216,15 @@ let message = function "this expression should have type unit." | Unused_match -> "this match case is unused." | Unused_pat -> "this sub-pattern is unused." - | Instance_variable_override lab -> + | Instance_variable_override [lab] -> "the instance variable " ^ lab ^ " is overridden.\n" ^ "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" + | Instance_variable_override (cname :: slist) -> + String.concat " " + ("the following instance variables are overriden by the class" + :: cname :: ":\n " :: slist) ^ + "\nThe behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" + | Instance_variable_override [] -> assert false | Illegal_backslash -> "illegal backslash escape in string." | Implicit_public_methods l -> "the following private methods were made public implicitly:\n " diff --git a/utils/warnings.mli b/utils/warnings.mli index aefa87e72..0664788ed 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -27,7 +27,7 @@ type t = | Statement_type (* 10 *) | Unused_match (* 11 *) | Unused_pat (* 12 *) - | Instance_variable_override of string (* 13 *) + | Instance_variable_override of string list (* 13 *) | Illegal_backslash (* 14 *) | Implicit_public_methods of string list (* 15 *) | Unerasable_optional_argument (* 16 *) |