diff --git a/ocaml/lambda/translattribute.ml b/ocaml/lambda/translattribute.ml index 4f4aa0e56c9..d648430ed37 100644 --- a/ocaml/lambda/translattribute.ml +++ b/ocaml/lambda/translattribute.ml @@ -57,108 +57,12 @@ let is_unrolled = function | {txt="inline"|"ocaml.inline"|"inlined"|"ocaml.inlined"} -> false | _ -> assert false -let get_payload get_from_exp = - let open Parsetree in - function - | PStr [{pstr_desc = Pstr_eval (exp, [])}] -> get_from_exp exp - | _ -> Result.Error () - -let get_optional_payload get_from_exp = - let open Parsetree in - function - | PStr [] -> Result.Ok None - | other -> Result.map Option.some (get_payload get_from_exp other) - -let get_id_from_exp = - let open Parsetree in - function - | { pexp_desc = Pexp_ident { txt = Longident.Lident id } } -> Result.Ok id - | _ -> Result.Error () - -let get_int_from_exp = - let open Parsetree in - function - | { pexp_desc = Pexp_constant (Pconst_integer(s, None)) } -> - begin match Misc.Int_literal_converter.int s with - | n -> Result.Ok n - | exception (Failure _) -> Result.Error () - end - | _ -> Result.Error () - -let get_construct_from_exp = - let open Parsetree in - function - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident constr }, None) } -> - Result.Ok constr - | _ -> Result.Error () - -let get_bool_from_exp exp = - Result.bind (get_construct_from_exp exp) - (function - | "true" -> Result.Ok true - | "false" -> Result.Ok false - | _ -> Result.Error ()) - -let get_ids_from_exp exp = - let open Parsetree in - (match exp with - | { pexp_desc = Pexp_apply (exp, args) } -> - get_id_from_exp exp :: - List.map (function - | (Nolabel, Parg_expr arg) -> get_id_from_exp arg - | (_, _) -> Result.Error ()) - args - | _ -> [get_id_from_exp exp]) - |> List.fold_left (fun acc r -> - match acc, r with - | Result.Ok ids, Ok id -> Result.Ok (id::ids) - | (Result.Error _ | Ok _), _ -> Result.Error ()) - (Ok []) - |> Result.map List.rev - - -(* [parse_ids_payload] requires that each element in [cases] - the first component (string list) is alphabetically sorted. *) -let parse_ids_payload txt loc ~default ~empty cases payload = - let[@local] warn () = - let ( %> ) f g x = g (f x) in - let msg = - cases - |> List.map (fst %> String.concat " " %> Printf.sprintf "'%s'") - |> String.concat ", " - |> Printf.sprintf "It must be either %s or empty" - in - Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg)); - default - in - match get_optional_payload get_ids_from_exp payload with - | Error () -> warn () - | Ok None -> empty - | Ok (Some ids) -> - match List.assoc_opt (List.sort String.compare ids) cases with - | Some r -> r - | None -> warn () - -let parse_id_payload txt loc ~default ~empty cases payload = - let[@local] warn () = - let ( %> ) f g x = g (f x) in - let msg = - cases - |> List.map (fst %> Printf.sprintf "'%s'") - |> String.concat ", " - |> Printf.sprintf "It must be either %s or empty" - in - Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg)); - default - in - match get_optional_payload get_id_from_exp payload with - | Error () -> warn () - | Ok None -> empty - | Ok (Some id) -> - match List.assoc_opt id cases with - | Some r -> r - | None -> warn () +let parse_id_payload txt loc options ~default ~empty payload = + match + Builtin_attributes.parse_optional_id_payload txt loc options ~empty payload + with + | Ok a -> a + | Error () -> default let parse_inline_attribute attr : inline_attribute = match attr with diff --git a/ocaml/otherlibs/dynlink/Makefile b/ocaml/otherlibs/dynlink/Makefile index ca5b202d3d4..7bbac2a5a65 100644 --- a/ocaml/otherlibs/dynlink/Makefile +++ b/ocaml/otherlibs/dynlink/Makefile @@ -129,7 +129,10 @@ COMPILERLIBS_SOURCES=\ file_formats/cmi_format.ml \ typing/persistent_env.ml \ typing/env.ml \ +<<<<<<< HEAD typing/shape_reduce.ml \ +======= +>>>>>>> fb471efa (Parse `zero_alloc` attributes into the typed tree (#2400)) lambda/debuginfo.ml \ lambda/lambda.ml \ lambda/runtimedef.ml \ diff --git a/ocaml/testsuite/tests/warnings/w53.ml b/ocaml/testsuite/tests/warnings/w53.ml index f4299588f59..d52e8500db8 100644 --- a/ocaml/testsuite/tests/warnings/w53.ml +++ b/ocaml/testsuite/tests/warnings/w53.ml @@ -537,6 +537,7 @@ module TestZeroAllocStruct = struct let x = 42 in fun z -> z + x end +<<<<<<< HEAD (* TEST flags = "-w +A-60-70"; setup-ocamlc.byte-build-env; @@ -544,3 +545,5 @@ end ocamlc.byte; check-ocamlc.byte-output; *) +======= +>>>>>>> fb471efa (Parse `zero_alloc` attributes into the typed tree (#2400)) diff --git a/ocaml/testsuite/tests/warnings/w53_marshalled.ml b/ocaml/testsuite/tests/warnings/w53_marshalled.ml index 7d41ea60fd2..aca14d2ad70 100644 --- a/ocaml/testsuite/tests/warnings/w53_marshalled.ml +++ b/ocaml/testsuite/tests/warnings/w53_marshalled.ml @@ -1,3 +1,4 @@ +<<<<<<< HEAD (* TEST_BELOW (* Blank lines added here to preserve locations. *) @@ -17,6 +18,27 @@ +======= +(* TEST +readonly_files = "marshall_for_w53.ml w53.ml w53_zero_alloc_all.ml" +include ocamlcommon +* setup-ocamlc.byte-build-env +** ocamlc.byte +program = "${test_build_directory}/marshall_for_w53.exe" +all_modules = "marshall_for_w53.ml" +*** run +**** ocamlc.byte +flags = "-w +A-60-70" +module = "w53.marshalled.ml" +compiler_reference = "${test_source_directory}/w53.compilers.reference" +***** check-ocamlc.byte-output +**** setup-ocamlc.byte-build-env +***** ocamlc.byte +flags = "-w +A-60-70" +module = "w53_zero_alloc_all.marshalled.ml" +compiler_reference = "${test_source_directory}/w53_zero_alloc_all.compilers.reference" +****** check-ocamlc.byte-output +>>>>>>> fb471efa (Parse `zero_alloc` attributes into the typed tree (#2400)) *) (* This tests that warning 53 happen appropriately when dealing with marshalled diff --git a/ocaml/testsuite/tests/warnings/w53_zero_alloc_all.ml b/ocaml/testsuite/tests/warnings/w53_zero_alloc_all.ml index 16a5c737395..6135e8bc253 100644 --- a/ocaml/testsuite/tests/warnings/w53_zero_alloc_all.ml +++ b/ocaml/testsuite/tests/warnings/w53_zero_alloc_all.ml @@ -1,3 +1,4 @@ +<<<<<<< HEAD (* TEST_BELOW (* Blank lines added here to preserve locations. *) @@ -6,6 +7,16 @@ +======= +(* TEST + +flags = "-w +A-60-70" + +* setup-ocamlc.byte-build-env +** ocamlc.byte +compile_only = "true" +*** check-ocamlc.byte-output +>>>>>>> fb471efa (Parse `zero_alloc` attributes into the typed tree (#2400)) *) @@ -78,6 +89,7 @@ module TestZeroAllocStruct = struct let x = 42 in fun z -> z + x end +<<<<<<< HEAD (* TEST flags = "-w +A-60-70"; @@ -86,3 +98,5 @@ end ocamlc.byte; check-ocamlc.byte-output; *) +======= +>>>>>>> fb471efa (Parse `zero_alloc` attributes into the typed tree (#2400)) diff --git a/ocaml/typing/rec_check.ml b/ocaml/typing/rec_check.ml index 0747ba59628..37627b176ac 100644 --- a/ocaml/typing/rec_check.ml +++ b/ocaml/typing/rec_check.ml @@ -586,8 +586,8 @@ let rec expression : Typedtree.expression -> term_judg = | Texp_instvar (self_path, pth, _inst_var) -> join [path self_path << Dereference; path pth] | Texp_apply - ({exp_desc = Texp_ident (_, _, vd, Id_prim _, _)}, - [_, Arg (Targ_expr (arg, _))], _, _) + ({exp_desc = Texp_ident (_, _, vd, Id_prim _, _)}, [_, Arg (Targ_expr (arg, _))], _, + _, _) when is_ref vd -> (* G |- e: m[Guard] diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index a72c22cffc1..16fbc251ead 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -3987,7 +3987,7 @@ let rec is_nonexpansive exp = Val_prim {Primitive.prim_name = ("%raise" | "%reraise" | "%raise_notrace")}}, Id_prim _, _) }, - [Nolabel, Arg (Targ_expr (e, _))], _, _) -> + [Nolabel, Arg (Targ_expr (e, _))], _, _, _) -> is_nonexpansive e | Texp_array (_, _, _ :: _, _) | Texp_apply _