From 549d75742504bb3df218cc8bcc1abf3e9ddd3217 Mon Sep 17 00:00:00 2001 From: Chris Casinghino Date: Thu, 1 Dec 2022 09:34:36 -0500 Subject: [PATCH] Run "misplaced attributes" check when compiling mlis (#72) --- driver/compile_common.ml | 1 + parsing/builtin_attributes.ml | 14 ++++++------- parsing/builtin_attributes.mli | 1 + stdlib/obj.mli | 14 ++++++------- .../tests/warnings/w53.compilers.reference | 20 ++++++++----------- testsuite/tests/warnings/w53.ml | 2 +- .../warnings/w53_mli.compilers.reference | 4 ++++ testsuite/tests/warnings/w53_mli.mli | 16 +++++++++++++++ typing/typemod.ml | 2 ++ 9 files changed, 47 insertions(+), 27 deletions(-) create mode 100644 testsuite/tests/warnings/w53_mli.compilers.reference create mode 100644 testsuite/tests/warnings/w53_mli.mli diff --git a/driver/compile_common.ml b/driver/compile_common.ml index ed327b508b3e..b0f364b8bab6 100644 --- a/driver/compile_common.ml +++ b/driver/compile_common.ml @@ -69,6 +69,7 @@ let typecheck_intf info ast = sg); ignore (Includemod.signatures info.env ~mark:Mark_both sg sg); Typecore.force_delayed_checks (); + Builtin_attributes.warn_unused (); Warnings.check_fatal (); tsg diff --git a/parsing/builtin_attributes.ml b/parsing/builtin_attributes.ml index 31c43af6b5e2..cead3bc94605 100644 --- a/parsing/builtin_attributes.ml +++ b/parsing/builtin_attributes.ml @@ -200,13 +200,13 @@ let alert_attr x = let alert_attrs l = List.filter_map alert_attr l -let mark_alerts_used l = - List.iter (fun a -> - match a.attr_name.txt with - | "ocaml.deprecated"|"deprecated"|"ocaml.alert"|"alert" -> - mark_used a.attr_name - | _ -> ()) - l +let mark_alert_used a = + match a.attr_name.txt with + | "ocaml.deprecated"|"deprecated"|"ocaml.alert"|"alert" -> + mark_used a.attr_name + | _ -> () + +let mark_alerts_used l = List.iter mark_alert_used l let mark_warn_on_literal_pattern_used l = List.iter (fun a -> diff --git a/parsing/builtin_attributes.mli b/parsing/builtin_attributes.mli index 81337c227f49..98eeb0a2c5ec 100644 --- a/parsing/builtin_attributes.mli +++ b/parsing/builtin_attributes.mli @@ -49,6 +49,7 @@ val mk_internal: (** Marks alert attributes used for the purposes of misplaced attribute warnings. Call this when moving things with alert attributes into the environment. *) +val mark_alert_used : Parsetree.attribute -> unit val mark_alerts_used : Parsetree.attributes -> unit (** Marks "warn_on_literal_pattern" attributes used for the purposes of diff --git a/stdlib/obj.mli b/stdlib/obj.mli index 547b5379e334..d3d14e7e4999 100644 --- a/stdlib/obj.mli +++ b/stdlib/obj.mli @@ -28,7 +28,7 @@ type raw_data = nativeint (* @since 4.12 *) external repr : 'a -> t = "%identity" external obj : t -> 'a = "%identity" external magic : 'a -> 'b = "%obj_magic" -val [@inline always] is_block : t -> bool +val is_block : t -> bool external is_int : t -> bool = "%obj_is_int" external tag : t -> int = "caml_obj_tag" [@@noalloc] val size : t -> int @@ -57,8 +57,8 @@ val field : t -> int -> t *) val set_field : t -> int -> t -> unit -val [@inline always] double_field : t -> int -> float (* @since 3.11.2 *) -val [@inline always] set_double_field : t -> int -> float -> unit +val double_field : t -> int -> float (* @since 3.11.2 *) +val set_double_field : t -> int -> float -> unit (* @since 3.11.2 *) external raw_field : t -> int -> raw_data = "caml_obj_raw_field" @@ -111,14 +111,14 @@ module Extension_constructor : sig type t = extension_constructor val of_val : 'a -> t - val [@inline always] name : t -> string - val [@inline always] id : t -> int + val name : t -> string + val id : t -> int end val extension_constructor : 'a -> extension_constructor [@@ocaml.deprecated "use Obj.Extension_constructor.of_val"] -val [@inline always] extension_name : extension_constructor -> string +val extension_name : extension_constructor -> string [@@ocaml.deprecated "use Obj.Extension_constructor.name"] -val [@inline always] extension_id : extension_constructor -> int +val extension_id : extension_constructor -> int [@@ocaml.deprecated "use Obj.Extension_constructor.id"] module Ephemeron: sig diff --git a/testsuite/tests/warnings/w53.compilers.reference b/testsuite/tests/warnings/w53.compilers.reference index 5b330fd12aec..8559ab4abae2 100644 --- a/testsuite/tests/warnings/w53.compilers.reference +++ b/testsuite/tests/warnings/w53.compilers.reference @@ -86,10 +86,6 @@ File "w53.ml", line 52, characters 17-27: 52 | val a1 : int [@deprecated] (* rejected *) ^^^^^^^^^^ Warning 53 [misplaced-attribute]: the "deprecated" attribute cannot appear in this context -File "w53.ml", line 54, characters 19-29: -54 | val a3 : int [@@@deprecated] (* rejected *) - ^^^^^^^^^^ -Warning 53 [misplaced-attribute]: the "deprecated" attribute cannot appear in this context File "w53.ml", line 57, characters 6-14: 57 | let [@unrolled 42] rec test_unrolled x = (* rejected *) ^^^^^^^^ @@ -106,14 +102,14 @@ File "w53.ml", line 75, characters 14-25: 75 | type t4 [@@@immediate64] (* rejected *) ^^^^^^^^^^^ Warning 53 [misplaced-attribute]: the "immediate64" attribute cannot appear in this context -File "w53.ml", line 79, characters 15-24: -79 | let x = (4 [@immediate], 42 [@immediate64]) (* rejected *) - ^^^^^^^^^ -Warning 53 [misplaced-attribute]: the "immediate" attribute cannot appear in this context File "w53.ml", line 79, characters 32-43: 79 | let x = (4 [@immediate], 42 [@immediate64]) (* rejected *) ^^^^^^^^^^^ Warning 53 [misplaced-attribute]: the "immediate64" attribute cannot appear in this context +File "w53.ml", line 79, characters 15-24: +79 | let x = (4 [@immediate], 42 [@immediate64]) (* rejected *) + ^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "immediate" attribute cannot appear in this context File "w53.ml", line 84, characters 26-31: 84 | type t2 = {x : int} [@@@boxed] (* rejected *) ^^^^^ @@ -126,14 +122,14 @@ File "w53.ml", line 87, characters 17-24: 87 | val x : int [@@unboxed] (* rejected *) ^^^^^^^ Warning 53 [misplaced-attribute]: the "unboxed" attribute cannot appear in this context -File "w53.ml", line 91, characters 15-22: -91 | let x = (5 [@unboxed], 42 [@boxed]) (* rejected *) - ^^^^^^^ -Warning 53 [misplaced-attribute]: the "unboxed" attribute cannot appear in this context File "w53.ml", line 91, characters 30-35: 91 | let x = (5 [@unboxed], 42 [@boxed]) (* rejected *) ^^^^^ Warning 53 [misplaced-attribute]: the "boxed" attribute cannot appear in this context +File "w53.ml", line 91, characters 15-22: +91 | let x = (5 [@unboxed], 42 [@boxed]) (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "unboxed" attribute cannot appear in this context File "w53.ml", line 95, characters 21-30: 95 | type 'a t1 = 'a [@@principal] (* rejected *) ^^^^^^^^^ diff --git a/testsuite/tests/warnings/w53.ml b/testsuite/tests/warnings/w53.ml index 1a52f519d0b8..f19e03e19ffa 100644 --- a/testsuite/tests/warnings/w53.ml +++ b/testsuite/tests/warnings/w53.ml @@ -51,7 +51,7 @@ module J' = Set.Make [@@ocaml.inlined] module type K = sig val a1 : int [@deprecated] (* rejected *) val a2 : int [@@deprecated] (* accepted *) - val a3 : int [@@@deprecated] (* rejected *) + [@@@deprecated] (* accepted*) end let [@unrolled 42] rec test_unrolled x = (* rejected *) diff --git a/testsuite/tests/warnings/w53_mli.compilers.reference b/testsuite/tests/warnings/w53_mli.compilers.reference new file mode 100644 index 000000000000..9fb328f37af5 --- /dev/null +++ b/testsuite/tests/warnings/w53_mli.compilers.reference @@ -0,0 +1,4 @@ +File "w53_mli.mli", line 14, characters 15-25: +14 | val a1 : int [@deprecated] (* rejected *) + ^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "deprecated" attribute cannot appear in this context diff --git a/testsuite/tests/warnings/w53_mli.mli b/testsuite/tests/warnings/w53_mli.mli new file mode 100644 index 000000000000..6826e66b58d8 --- /dev/null +++ b/testsuite/tests/warnings/w53_mli.mli @@ -0,0 +1,16 @@ +(* TEST + +flags = "-w +A-60-70" + +* setup-ocamlc.byte-build-env +** ocamlc.byte +compile_only = "true" +*** check-ocamlc.byte-output + +*) + +(* Just ensure that we're running the check on mli files too *) + +val a1 : int [@deprecated] (* rejected *) +val a2 : int [@@deprecated] (* accepted *) + diff --git a/typing/typemod.ml b/typing/typemod.ml index abef4d95550f..d7224bb383f1 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -1756,6 +1756,7 @@ and transl_signature env (sg : Parsetree.signature) = typedtree, tsg, newenv | Psig_attribute attr -> Builtin_attributes.parse_standard_interface_attributes attr; + Builtin_attributes.mark_alert_used attr; mksig (Tsig_attribute attr) env loc, [], env | Psig_extension (ext, _attrs) -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) @@ -2890,6 +2891,7 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = raise (Error_forward (Builtin_attributes.error_of_extension ext)) | Pstr_attribute attr -> Builtin_attributes.parse_standard_implementation_attributes attr; + Builtin_attributes.mark_alert_used attr; Tstr_attribute attr, [], shape_map, env in let toplevel_sig = Option.value toplevel ~default:[] in