ocaml-flambda
diff --git a/‎lambda/matching.ml
Lines changed: 1 addition & 1 deletion b/‎lambda/matching.ml
Lines changed: 1 addition & 1 deletion
diff --git a/‎parsing/builtin_attributes.ml
Lines changed: 17 additions & 1 deletion b/‎parsing/builtin_attributes.ml
Lines changed: 17 additions & 1 deletion
diff --git a/‎parsing/builtin_attributes.mli
Lines changed: 7 additions & 0 deletions b/‎parsing/builtin_attributes.mli
Lines changed: 7 additions & 0 deletions
diff --git a/‎parsing/location.ml
Lines changed: 6 additions & 2 deletions b/‎parsing/location.ml
Lines changed: 6 additions & 2 deletions
diff --git a/‎parsing/location.mli
Lines changed: 1 addition & 0 deletions b/‎parsing/location.mli
Lines changed: 1 addition & 0 deletions
diff --git a/‎testsuite/tests/typing-immediate/immediate.ml
Lines changed: 48 additions & 8 deletions b/‎testsuite/tests/typing-immediate/immediate.ml
Lines changed: 48 additions & 8 deletions
@@ -4151,7 +4151,7 @@ let report_error ppf = function
       fprintf ppf
         "Non-value detected in translation:@ Please report this error to \
          the Jane Street compilers team.@ %a"
-        (Jkind.Violation.report_with_name ~name:"This expression") err
+        (Jkind.Violation.report_with_name ~name:"this expression") err
   | Illegal_record_field c ->
       fprintf ppf
         "Sort %s detected where value was expected in a record field:@ Please \
 
@@ -105,7 +105,8 @@ let builtin_attrs =
   ; "builtin"; "ocaml.builtin"
   ; "no_effects"; "ocaml.no_effects"
   ; "no_coeffects"; "ocaml.no_coeffects"
-  ; "only_generative_effects"; "ocaml.only_generative_effects";
+  ; "only_generative_effects"; "ocaml.only_generative_effects"
+  ; "error_message"; "ocaml.error_message"
   ]
 
 (* nroberts: When we upstream the builtin-attribute whitelisting, we shouldn't
@@ -696,3 +697,18 @@ let tailcall attr =
           (Warnings.Attribute_payload
              (t.attr_name.txt, "Only 'hint' is supported"));
         Ok (Some `Tail_if_possible)
+
+let error_message_attr l =
+  let inner x =
+    match x.attr_name.txt with
+    | "ocaml.error_message"|"error_message" ->
+      begin match string_of_payload x.attr_payload with
+      | Some _ as r ->
+        mark_used x.attr_name;
+        r
+      | None -> warn_payload x.attr_loc x.attr_name.txt
+                  "error_message attribute expects a string argument";
+        None
+      end
+    | _ -> None in
+  List.find_map inner l
@@ -208,3 +208,10 @@ val jkind_attribute_of_string : string -> jkind_attribute option
    as the attribute mechanism predates layouts.
 *)
 val jkind : Parsetree.attributes -> jkind_attribute Location.loc option
+
+(** Finds the first "error_message" attribute, marks it as used, and returns its
+    string payload. Returns [None] if no such attribute is present.
+
+    There should be at most one "error_message" attribute, additional ones are sliently
+    ignored. **)
+val error_message_attr : Parsetree.attributes -> string option
@@ -261,7 +261,7 @@ let print_filename ppf file =
    Some of the information (filename, line number or characters numbers) in the
    location might be invalid; in which case we do not print it.
  *)
-let print_loc ppf loc =
+let print_loc ~capitalize_first ppf loc =
   setup_colors ();
   let file_valid = function
     | "_none_" ->
@@ -287,7 +287,8 @@ let print_loc ppf loc =
 
   let first = ref true in
   let capitalize s =
-    if !first then (first := false; String.capitalize_ascii s)
+    if !first then (first := false;
+                    if capitalize_first then String.capitalize_ascii s else s)
     else s in
   let comma () =
     if !first then () else Format.fprintf ppf ", " in
@@ -316,6 +317,9 @@ let print_loc ppf loc =
 
   Format.fprintf ppf "@}"
 
+let print_loc_in_lowercase = print_loc ~capitalize_first:false
+let print_loc = print_loc ~capitalize_first:true
+
 (* Print a comma-separated list of locations *)
 let print_locs ppf locs =
   Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ")
 
@@ -202,6 +202,7 @@ val show_filename: string -> string
 val print_filename: formatter -> string -> unit
 
 val print_loc: formatter -> t -> unit
+val print_loc_in_lowercase: formatter -> t -> unit
 val print_locs: formatter -> t list -> unit
 
 
 
@@ -143,8 +143,14 @@ end;;
 Line 2, characters 2-31:
 2 |   type t = string [@@immediate]
       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type string has layout value, which is not a sublayout of immediate.
+Error: The layout of type string is value, because
+         it is the primitive value type string.
+       But the layout of type string must be a sublayout of immediate, because
+         of the definition of t at line 2, characters 2-31.
 |}];;
+(* CR layouts v2.9: The "of the definition of t ..." part is not great and it
+   should only refer to definitions that type check. Fixing it will involve
+   building a second [final_env] in [transl_type_decl] which is costly.  *)
 
 (* Cannot directly declare a non-immediate type as immediate (variant) *)
 module B = struct
@@ -154,7 +160,10 @@ end;;
 Line 2, characters 2-41:
 2 |   type t = Foo of int | Bar [@@immediate]
       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type t has layout value, which is not a sublayout of immediate.
+Error: The layout of type t is value, because
+         it's a boxed variant type.
+       But the layout of type t must be a sublayout of immediate, because
+         of the annotation on the declaration of the type t.
 |}];;
 
 (* Cannot directly declare a non-immediate type as immediate (record) *)
@@ -165,7 +174,10 @@ end;;
 Line 2, characters 2-38:
 2 |   type t = { foo : int } [@@immediate]
       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type t has layout value, which is not a sublayout of immediate.
+Error: The layout of type t is value, because
+         it's a boxed record type.
+       But the layout of type t must be a sublayout of immediate, because
+         of the annotation on the declaration of the type t.
 |}];;
 
 (* Not guaranteed that t is immediate, so this is an invalid declaration *)
@@ -177,7 +189,10 @@ end;;
 Line 3, characters 2-26:
 3 |   type s = t [@@immediate]
       ^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type t has layout value, which is not a sublayout of immediate.
+Error: The layout of type t is value, because
+         of the definition of t at line 2, characters 2-8.
+       But the layout of type t must be a sublayout of immediate, because
+         of the definition of s at line 3, characters 2-26.
 |}];;
 
 (* Can't ascribe to an immediate type signature with a non-immediate type *)
@@ -198,12 +213,14 @@ Error: Signature mismatch:
          type t = string
        is not included in
          type t : immediate
-       the first has layout value, which is not a sublayout of immediate.
+       The layout of the first is value, because
+         it is the primitive value type string.
+       But the layout of the first must be a sublayout of immediate, because
+         of the definition of t at line 1, characters 15-35.
 |}];;
 
 (* Same as above but with explicit signature *)
 module M_invalid : S = struct type t = string end;;
-module FM_invalid = F (struct type t = string end);;
 [%%expect{|
 Line 1, characters 23-49:
 1 | module M_invalid : S = struct type t = string end;;
@@ -214,7 +231,27 @@ Error: Signature mismatch:
          type t = string
        is not included in
          type t : immediate
-       the first has layout value, which is not a sublayout of immediate.
+       The layout of the first is value, because
+         it is the primitive value type string.
+       But the layout of the first must be a sublayout of immediate, because
+         of the definition of t at line 1, characters 20-40.
+|}];;
+
+module FM_invalid = F (struct type t = string end);;
+[%%expect{|
+Line 1, characters 20-50:
+1 | module FM_invalid = F (struct type t = string end);;
+                        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Modules do not match: sig type t = string end is not included in
+       S
+     Type declarations do not match:
+       type t = string
+     is not included in
+       type t : immediate
+     The layout of the first is value, because
+       it is the primitive value type string.
+     But the layout of the first must be a sublayout of immediate, because
+       of the definition of t at line 1, characters 20-40.
 |}];;
 
 (* Can't use a non-immediate type even if mutually recursive *)
@@ -226,7 +263,10 @@ end;;
 Line 2, characters 2-26:
 2 |   type t = s [@@immediate]
       ^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type s has layout value, which is not a sublayout of immediate.
+Error: The layout of type s is value, because
+         it is the primitive value type string.
+       But the layout of type s must be a sublayout of immediate, because
+         of the definition of t at line 2, characters 2-26.
 |}];;