diff --git a/lambda/translattribute.ml b/lambda/translattribute.ml index b8d072700cd..869482d4ce3 100644 --- a/lambda/translattribute.ml +++ b/lambda/translattribute.ml @@ -363,9 +363,11 @@ let add_check_attribute expr loc attributes = | Assume p -> Printf.sprintf "%s assume" (to_string p) | Default_check -> assert false in - match expr, get_check_attribute attributes with - | expr, [] -> expr - | Lfunction({ attr = { stub = false } as attr } as funct), [check] -> + match expr with + | Lfunction({ attr = { stub = false } as attr } as funct) -> + begin match get_check_attribute attributes with + | [] -> expr + | [check] -> begin match attr.check with | Default_check -> () | Assert Noalloc | Assume Noalloc -> @@ -374,40 +376,36 @@ let add_check_attribute expr loc attributes = end; let attr = { attr with check } in Lfunction { funct with attr } - | expr, [check] -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute (to_string check)); - expr - | expr, a::b::_ -> - Location.prerr_warning loc - (Warnings.Duplicated_attribute - (Printf.sprintf "%s/%s"(to_string a) (to_string b))); - expr + | (_ :: _ :: _) -> assert false + end + | _ -> expr let add_poll_attribute expr loc attributes = - match expr, get_poll_attribute attributes with - | expr, Default_poll -> expr - | Lfunction({ attr = { stub = false } as attr } as funct), poll -> + match expr with + | Lfunction({ attr = { stub = false } as attr } as funct) -> + begin match get_poll_attribute attributes with + | Default_poll -> expr + | Error_poll as poll -> begin match attr.poll with | Default_poll -> () | Error_poll -> - Location.prerr_warning loc - (Warnings.Duplicated_attribute "error_poll") + Location.prerr_warning loc + (Warnings.Duplicated_attribute "error_poll") end; let attr = { attr with poll } in check_poll_inline loc attr; check_poll_local loc attr; let attr = { attr with inline = Never_inline; local = Never_local } in Lfunction { funct with attr } - | expr, Error_poll -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "error_poll"); - expr + end + | _ -> expr let add_loop_attribute expr loc attributes = - match expr, get_loop_attribute attributes with - | expr, Default_loop -> expr - | Lfunction({ attr = { stub = false } as attr } as funct), loop -> + match expr with + | Lfunction({ attr = { stub = false } as attr } as funct) -> + begin match get_loop_attribute attributes with + | Default_loop -> expr + | (Always_loop | Never_loop) as loop -> begin match attr.loop with | Default_loop -> () | Always_loop | Never_loop -> @@ -416,10 +414,8 @@ let add_loop_attribute expr loc attributes = end; let attr = { attr with loop } in Lfunction { funct with attr = attr } - | expr, (Always_loop | Never_loop) -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "loop"); - expr + end + | _ -> expr (* Get the [@inlined] attribute payload (or default if not present). *) let get_inlined_attribute e = diff --git a/otherlibs/dynlink/dune b/otherlibs/dynlink/dune index c67a9f1b5b5..fe1ed17fa1f 100644 --- a/otherlibs/dynlink/dune +++ b/otherlibs/dynlink/dune @@ -355,14 +355,10 @@ .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Location.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Ident.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Longident.cmo - .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Builtin_attributes.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Compilation_unit.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Linkage_name.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Symbol.cmo - .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Type_immediacy.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Path.cmo - .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Attr_helper.cmo - .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Primitive.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Types.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Syntaxerr.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Bytesections.cmo @@ -375,6 +371,10 @@ .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Persistent_env.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Docstrings.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Ast_helper.cmo + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Builtin_attributes.cmo + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Type_immediacy.cmo + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Attr_helper.cmo + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Primitive.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Predef.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Ast_mapper.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Subst.cmo @@ -413,14 +413,10 @@ .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Location.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Ident.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Longident.cmx - .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Builtin_attributes.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Compilation_unit.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Linkage_name.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Symbol.cmx - .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Type_immediacy.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Path.cmx - .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Attr_helper.cmx - .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Primitive.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Types.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Syntaxerr.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Bytesections.cmx @@ -433,6 +429,10 @@ .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Persistent_env.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Docstrings.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Ast_helper.cmx + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Builtin_attributes.cmx + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Type_immediacy.cmx + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Attr_helper.cmx + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Primitive.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Predef.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Ast_mapper.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Subst.cmx diff --git a/testsuite/tests/warnings/w53.compilers.reference b/testsuite/tests/warnings/w53.compilers.reference index 443fd8f414a..8847a4ff8b9 100644 --- a/testsuite/tests/warnings/w53.compilers.reference +++ b/testsuite/tests/warnings/w53.compilers.reference @@ -6,10 +6,6 @@ File "w53.ml", line 12, characters 4-5: 12 | let h x = x [@inline] (* rejected *) ^ Warning 32 [unused-value-declaration]: unused value h. -File "w53.ml", line 334, characters 2-33: -334 | let x : int64 = 42L [@@noalloc] (* rejected *) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context File "w53.ml", line 12, characters 14-20: 12 | let h x = x [@inline] (* rejected *) ^^^^^^ @@ -562,6 +558,10 @@ File "w53.ml", line 333, characters 19-26: 333 | type s1 = Foo1 [@noalloc] (* rejected *) ^^^^^^^ Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context +File "w53.ml", line 334, characters 25-32: +334 | let x : int64 = 42L [@@noalloc] (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context File "w53.ml", line 336, characters 46-53: 336 | external y : (int64 [@noalloc]) -> (int64 [@noalloc]) = "x" (* rejected *) ^^^^^^^