This attempts to make the various error messages given for failed static
accessibility checks more consistent, by using a consistent "accessibility
level of X is to deep" or "X has deeper accessibility level than" wording,
augmented by a reference to the relevant rule of the Ada Reference Manual
(latest version, in other words Ada 2022 with Amendment 1, when the rule
is still present, otherwise the last version where the rule was present).
The only exception is for illegal 'Access attribute references, where the
existing "nonlocal access vs local object" viewpoint is preserved.
Tested on x86-64/Linux, applied on the mainline.
2026-09-22 Eric Botcazou <[email protected]>
* accessibility.adb (Accessibility_Message): Adjust wording.
(Check_Return_Construct_Accessibility.Accessibility_Error): Ditto.
* sem_attr.adb (Resolve_Attribute) <Attribute_Access>: Likewise for
the specific error message given for subprograms.
* sem_ch3.adb (Analyze_Component_Declaration): Likewise for the
specific error message given for access components.
(Build_Derived_Record_Type): Add references to Ada 95 rules.
* sem_ch6.adb (Analyze_Function_Return): Adjust wording for the
error messages given for class-wide returns.
* sem_ch9.adb (Analyze_Requeue): Likewise for requeue statements.
* sem_ch13.adb (Analyze_Attribute_Definition_Clause) <Storage_Pool>:
Add reference to Ada 2012 accessibility rule.
* sem_res.adb (Resolve_Actuals.Check_Aliased_Parameter): Adjust
wording for the error messages for actuals of aliased parameters.
(Resolve_Allocator): Likewise for allocators.
(Valid_Conversion): Likewise for conversions.
(Valid_Array_Conversion): Add Opnd_Type parameter instead of using
an up-level reference.
2026-09-22 Eric Botcazou <[email protected]>
* gnat.dg/access12.adb: Adjust error message.
* gnat.dg/aliased3.adb: Likewise.
--
Eric Botcazoudiff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb
index 42092bebbf9..852b57e41df 100644
--- a/gcc/ada/accessibility.adb
+++ b/gcc/ada/accessibility.adb
@@ -188,9 +188,12 @@ package body Accessibility is
---------------------------
procedure Accessibility_Message (N : Node_Id; Typ : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- P : constant Node_Id := Prefix (N);
- Indic : Node_Id := Parent (Parent (N));
+ Loc : constant Source_Ptr := Sloc (N);
+ P : constant Node_Id := Prefix (N);
+ Msg : constant String :=
+ "nonlocal access value cannot designate local object (RM 3.10.2(28))";
+
+ Indic : Node_Id;
begin
-- In an instance, this is a runtime check, but one we know will fail,
@@ -201,8 +204,7 @@ package body Accessibility is
Error_Msg_Warn := SPARK_Mode /= On
and then not
No_Dynamic_Accessibility_Checks_Enabled (P);
- Error_Msg_F
- ("non-local pointer cannot point to local object<<", P);
+ Error_Msg_F (Msg & "<<", P);
Error_Msg_F ("\Program_Error [<<", P);
Rewrite (N,
Make_Raise_Program_Error (Loc,
@@ -210,7 +212,7 @@ package body Accessibility is
Set_Etype (N, Typ);
else
- Error_Msg_F ("non-local pointer cannot point to local object", P);
+ Error_Msg_F (Msg, P);
-- Check for case where we have a missing access definition
@@ -2071,10 +2073,11 @@ package body Accessibility is
procedure Accessibility_Error is
Suffix : constant String :=
(if Is_Expression_Function_Or_Completion (Scope_Id)
- then "in expression function"
- else "in return");
+ then " in expression function (RM 6.8(5))"
+ else " in return (RM 6.5(5.9))");
Message : constant String :=
- "level of type of access discriminant is too deep " & Suffix;
+ "accessibility level of access discriminant is too deep"
+ & Suffix;
begin
-- In an instance, this is a runtime check, but one we know will fail
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index d711b45f13c..2814c2c1a89 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -12215,7 +12215,8 @@ package body Sem_Attr is
> Static_Type_Access_Level (Btyp)
then
Error_Msg_F
- ("subprogram must not be deeper than access type", P);
+ ("nonlocal access value cannot designate local"
+ & " subprogram (RM 3.10.2(32))", P);
-- Check the restriction of 3.10.2(32) that disallows the
-- access attribute within a generic body when the ultimate
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index d648da2f55e..837f662b7b4 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -8170,7 +8170,7 @@ package body Sem_Ch13 is
then
Error_Msg_N
("subpool access type has deeper accessibility "
- & "level than pool", Ent);
+ & "level than pool (RM 13.11.4(23))", Ent);
return;
end if;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index c204fe6ea05..9aec12d24a7 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -2142,15 +2142,15 @@ package body Sem_Ch3 is
("access to specific tagged type required (RM 3.9.2(9))", E);
end if;
- -- (Ada 2005: AI-230): Accessibility check for anonymous
+ -- Ada 2005 (AI-230): Accessibility check for anonymous
-- components
if Static_Type_Access_Level (Etype (E))
> Static_Type_Access_Level (T, Deepest => True)
then
Error_Msg_N
- ("expression has deeper access level than component " &
- "(RM 3.10.2 (12.2))", E);
+ ("expression has deeper accessibility level than component"
+ & " (RM 3.10.2(12.2))", E);
end if;
-- The initialization expression is a reference to an access
@@ -2163,8 +2163,8 @@ package body Sem_Ch3 is
and then Present (Discriminal_Link (Entity (E)))
then
Error_Msg_N
- ("discriminant has deeper accessibility level than target",
- E);
+ ("access discriminant has deeper accessibility level than"
+ & " component (RM 3.10.2(12.2))", E);
end if;
end if;
end if;
@@ -9762,31 +9762,37 @@ package body Sem_Ch3 is
if Ada_Version >= Ada_2005 then
Check_Generic_Ancestors;
+ -- In Ada 95, the accessibility level of a record extension cannot
+ -- be deeper than that of its parent type.
+
elsif Static_Type_Access_Level (Derived_Type)
- /= Static_Type_Access_Level (Parent_Type)
+ > Static_Type_Access_Level (Parent_Type)
and then not Is_Generic_Type (Derived_Type)
then
if Is_Controlled (Parent_Type) then
Error_Msg_N
- ("controlled type must be declared at the library level",
- Indic);
+ ("controlled type must be declared at the library level"
+ & " (RM 3.9.1(3))", Indic);
else
Error_Msg_N
- ("type extension at deeper accessibility level than parent",
- Indic);
+ ("type extension at deeper accessibility level than parent"
+ & " (RM 3.9.1(3))", Indic);
end if;
+ -- In Ada 95, a type extension cannot be declared in a generic body
+ -- if the parent type is declared outside that body.
+
else
declare
GB : constant Node_Id := Enclosing_Generic_Body (Derived_Type);
+
begin
if Present (GB)
and then GB /= Enclosing_Generic_Body (Parent_Base)
then
Error_Msg_NE
("parent type of& must not be outside generic body"
- & " (RM 3.9.1(4))",
- Indic, Derived_Type);
+ & " (RM 3.9.1(4))", Indic, Derived_Type);
end if;
end;
end if;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 76da204abcf..80bc657eade 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -1094,17 +1094,15 @@ package body Sem_Ch6 is
-- If the result type is class-wide, then check that the return
-- expression's type is not declared at a deeper level than the
- -- function (RM05-6.5(5.6/2)).
+ -- function (RM 6.5(5.8)).
- if Ada_Version >= Ada_2005
- and then Is_Class_Wide_Type (R_Type)
- then
+ if Ada_Version >= Ada_2005 and then Is_Class_Wide_Type (R_Type) then
if Static_Type_Access_Level (Etype (Expr))
> Static_Subprogram_Access_Level (Scope_Id)
then
Error_Msg_N
- ("level of return expression type is deeper than "
- & "class-wide function!", Expr);
+ ("type of return expression has deeper accessibility level"
+ & " than class-wide function (RM 6.5(5.8))", Expr);
end if;
end if;
@@ -1117,9 +1115,8 @@ package body Sem_Ch6 is
Related_Nod => N);
end if;
- -- Perform static accessibility checks for cases involving
- -- dereferences of access parameters. Runtime accessibility checks
- -- get generated elsewhere.
+ -- Perform a static accessibility check for return-by-reference
+ -- of limited types in Ada 95 or if -gnatd.l is in effect.
if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L)
and then Is_Inherently_Limited_Type (Etype (Scope_Id))
@@ -1155,16 +1152,16 @@ package body Sem_Ch6 is
Reason => CE_Null_Not_Allowed);
end if;
- -- RM 6.5 (5.4/3): accessibility checks also apply if the return object
- -- has no initializing expression.
+ -- The above accessibility check in Ada 2005 also applies if the return
+ -- object has no initializing expression (RM 6.5(5.5)).
elsif Ada_Version > Ada_2005 and then Is_Class_Wide_Type (R_Type) then
if Static_Type_Access_Level (Etype (Defining_Identifier (Obj_Decl)))
> Static_Subprogram_Access_Level (Scope_Id)
then
Error_Msg_N
- ("level of return expression type is deeper than "
- & "class-wide function!", Obj_Decl);
+ ("type of return object has deeper accessibility level"
+ & " than class-wide function (RM 6.5(5.5))", Obj_Decl);
end if;
end if;
end Analyze_Function_Return;
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index ce8fe01f463..6c9f7b87636 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -2468,7 +2468,8 @@ package body Sem_Ch9 is
> Static_Local_Access_Level (Enclosing)
then
Error_Msg_N
- ("target object has invalid level for requeue", Target_Obj);
+ ("accessibility level of target object is too deep for requeue"
+ & " (RM 9.5.4(6))", Target_Obj);
end if;
end if;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index e862a8b7e78..c124b6d0e3d 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -3716,8 +3716,9 @@ package body Sem_Res is
procedure Accessibility_Error (S : String) is
begin
- Error_Msg_NE ("actual for aliased formal& has wrong accessibility"
- & " in " & S & " (RM 6.4.1(6.4))", A, F);
+ Error_Msg_NE
+ ("accessibility level of actual is too deep for aliased formal&"
+ & " in " & S & " (RM 6.4.1(6.4))", A, F);
end Accessibility_Error;
begin
@@ -5366,9 +5367,11 @@ package body Sem_Res is
Prefix : constant String :=
(if Nkind (Exp) = N_Attribute_Reference
then "prefix of attribute"
- else "type of access discriminant");
+ else "access discriminant");
Message : constant String :=
- Prefix & " has deeper level than allocator type";
+ Prefix
+ & " has deeper accessibility level than allocator type"
+ & " (RM 4.8(5.3))";
begin
-- In an instance, this is a runtime check, but one we know will fail
@@ -5719,10 +5722,12 @@ package body Sem_Res is
-- the case of an initialized allocator with a class-wide argument (see
-- Expand_Allocator_Expression).
- if Ada_Version >= Ada_2005
- and then Is_Class_Wide_Type (Desig_T)
- then
+ if Ada_Version >= Ada_2005 and then Is_Class_Wide_Type (Desig_T) then
declare
+ Message : constant String :=
+ "allocated type has deeper accessibility level than allocator"
+ & " type (RM 4.8(5.2))";
+
Exp_Typ : Entity_Id;
begin
@@ -5739,9 +5744,7 @@ package body Sem_Res is
then
if In_Instance_Body then
Error_Msg_Warn := SPARK_Mode /= On;
- Error_Msg_N
- ("type in allocator has deeper level than designated "
- & "class-wide type<<", E);
+ Error_Msg_N (Message & "<<", E);
Error_Msg_N ("\Program_Error [<<", E);
Rewrite (N,
@@ -5757,9 +5760,7 @@ package body Sem_Res is
elsif not Is_Generic_Type (Exp_Typ)
and then not In_Generic_Formal_Package (Exp_Typ)
then
- Error_Msg_N
- ("type in allocator has deeper level than designated "
- & "class-wide type", E);
+ Error_Msg_N (Message, E);
end if;
end if;
end;
@@ -13621,9 +13622,9 @@ package body Sem_Res is
Operand : Node_Id;
Report_Errs : Boolean := True) return Boolean
is
- Target_Type : constant Entity_Id := Base_Type (Target);
- Opnd_Type : Entity_Id;
- Inc_Ancestor : Entity_Id;
+ Message : constant String :=
+ " has deeper accessibility level than target type (RM 4.6(24.21))";
+ Target_Type : constant Entity_Id := Base_Type (Target);
function Conversion_Check
(Valid : Boolean;
@@ -13648,7 +13649,7 @@ package body Sem_Res is
-- discriminant selected from a dereference of another such "bad"
-- conversion argument.
- function Valid_Array_Conversion return Boolean;
+ function Valid_Array_Conversion (Opnd_Type : Entity_Id) return Boolean;
-- Check index and component conformance, and accessibility levels if
-- the component types are anonymous access types (Ada 2005).
@@ -13790,7 +13791,7 @@ package body Sem_Res is
-- Valid_Array_Conversion --
----------------------------
- function Valid_Array_Conversion return Boolean is
+ function Valid_Array_Conversion (Opnd_Type : Entity_Id) return Boolean is
Opnd_Comp_Type : constant Entity_Id := Component_Type (Opnd_Type);
Opnd_Comp_Base : constant Entity_Id := Base_Type (Opnd_Comp_Type);
@@ -13870,8 +13871,8 @@ package body Sem_Res is
if In_Instance_Body then
Error_Msg_Warn := SPARK_Mode /= On;
Report_Error_N
- ("source array type has deeper accessibility "
- & "level than target<<", Operand, Report_Errs);
+ ("operand array type" & Message & "<<",
+ Operand, Report_Errs);
Report_Error_N
("\Program_Error [<<", Operand, Report_Errs);
Rewrite (N,
@@ -13884,13 +13885,9 @@ package body Sem_Res is
else
Report_Error_N
- ("source array type has deeper accessibility "
- & "level than target", Operand, Report_Errs);
+ ("operand array type" & Message, Operand, Report_Errs);
return False;
end if;
-
- else
- null;
end if;
-- All other cases where component base types do not match
@@ -13920,6 +13917,11 @@ package body Sem_Res is
return True;
end Valid_Array_Conversion;
+ -- Local variables
+
+ Inc_Ancestor : Entity_Id;
+ Opnd_Type : Entity_Id;
+
-- Start of processing for Valid_Conversion
begin
@@ -14015,7 +14017,7 @@ package body Sem_Res is
return False;
else
- return Valid_Array_Conversion;
+ return Valid_Array_Conversion (Opnd_Type);
end if;
-- Ada 2005 (AI-251): Internally generated conversions of access to
@@ -14083,16 +14085,14 @@ package body Sem_Res is
end if;
end;
- -- Check the static accessibility rule of 4.6(17). Note that the
- -- check is not enforced when within an instance body, since the
- -- RM requires such cases to be caught at run time.
-
- -- If the operand is a rewriting of an allocator no check is needed
+ -- If the operand is a rewriting of an allocator, no check is needed
-- because there are no accessibility issues.
if Nkind (Original_Node (N)) = N_Allocator then
null;
+ -- Otherwise, check the static accessibility rules of 4.6(24.11-21)
+
elsif Ekind (Target_Type) /= E_Anonymous_Access_Type
or else Is_Local_Anonymous_Access (Target_Type)
or else Nkind (Associated_Node_For_Itype (Target_Type)) =
@@ -14137,8 +14137,7 @@ package body Sem_Res is
(Target_Type, Deepest => True)
then
Report_Error_N
- ("operand has deeper level than target", Operand,
- Report_Errs);
+ ("operand type" & Message, Operand, Report_Errs);
return False;
end if;
@@ -14151,7 +14150,8 @@ package body Sem_Res is
then
Report_Error_N
("implicit conversion of stand-alone anonymous "
- & "access object not allowed", Operand, Report_Errs);
+ & "access object not allowed (RM 8.6(27.1))",
+ Operand, Report_Errs);
return False;
-- Implicit conversions aren't allowed for anonymous access
@@ -14166,7 +14166,7 @@ package body Sem_Res is
then
Report_Error_N
("implicit conversion of anonymous access parameter "
- & "not allowed", Operand, Report_Errs);
+ & "not allowed (RM 8.6(27.1))", Operand, Report_Errs);
return False;
-- Detect access discriminant values that are illegal
@@ -14176,20 +14176,19 @@ package body Sem_Res is
then
Report_Error_N
("implicit conversion of anonymous access value "
- & "not allowed", Operand, Report_Errs);
+ & "not allowed (RM 8.6(27.1))", Operand, Report_Errs);
return False;
- -- In other cases, the level of the operand's type must be
- -- statically less deep than that of the target type, else
- -- implicit conversion is disallowed (by RM12-8.6(27.1/3)).
+ -- In other cases, the level of the operand type must not
+ -- be statically deeper than that of the target type.
elsif Static_Type_Access_Level (Opnd_Type)
> Static_Type_Access_Level
(Target_Type, Deepest => True)
then
Report_Error_N
- ("implicit conversion of anonymous access value "
- & "violates accessibility", Operand, Report_Errs);
+ ("anonymous access type" & Message,
+ Operand, Report_Errs);
return False;
end if;
end if;
@@ -14227,7 +14226,7 @@ package body Sem_Res is
if In_Instance_Body then
Error_Msg_Warn := SPARK_Mode /= On;
Report_Error_N
- ("cannot convert local pointer to non-local access type<<",
+ ("operand type" & Message & "<<",
Operand, Report_Errs);
Report_Error_N ("\Program_Error [<<", Operand, Report_Errs);
Rewrite (N,
@@ -14243,8 +14242,7 @@ package body Sem_Res is
if not Error_Posted (N) then
Report_Error_N
- ("cannot convert local pointer to non-local access type",
- Operand, Report_Errs);
+ ("operand type" & Message, Operand, Report_Errs);
end if;
return False;
end if;
@@ -14271,8 +14269,8 @@ package body Sem_Res is
if In_Instance_Body then
Error_Msg_Warn := SPARK_Mode /= On;
Report_Error_N
- ("cannot convert access discriminant to non-local "
- & "access type<<", Operand, Report_Errs);
+ ("access discriminant" & Message & "<<",
+ Operand, Report_Errs);
Report_Error_N
("\Program_Error [<<", Operand, Report_Errs);
Rewrite (N,
@@ -14285,8 +14283,7 @@ package body Sem_Res is
else
Report_Error_N
- ("cannot convert access discriminant to non-local "
- & "access type", Operand, Report_Errs);
+ ("access discriminant" & Message, Operand, Report_Errs);
return False;
end if;
end if;
@@ -14303,8 +14300,7 @@ package body Sem_Res is
and then Present (Discriminal_Link (Entity (Operand)))
then
Report_Error_N
- ("discriminant has deeper accessibility level than target",
- Operand, Report_Errs);
+ ("access discriminant" & Message, Operand, Report_Errs);
return False;
end if;
end if;
diff --git a/gcc/testsuite/gnat.dg/access12.adb b/gcc/testsuite/gnat.dg/access12.adb
index 5820b91deb2..3c12b9562c5 100644
--- a/gcc/testsuite/gnat.dg/access12.adb
+++ b/gcc/testsuite/gnat.dg/access12.adb
@@ -19,7 +19,7 @@ begin
if I = 1 then
X := 0;
end if;
- A := R.Element.all'Access; -- { dg-error "non-local pointer" }
+ A := R.Element.all'Access; -- { dg-error "nonlocal access" }
X := I;
end;
end loop;
diff --git a/gcc/testsuite/gnat.dg/aliased3.adb b/gcc/testsuite/gnat.dg/aliased3.adb
index 16355a90913..726dc03edb8 100644
--- a/gcc/testsuite/gnat.dg/aliased3.adb
+++ b/gcc/testsuite/gnat.dg/aliased3.adb
@@ -12,7 +12,7 @@ begin
R : aliased Integer := 123;
Y : access constant Integer;
begin
- Y := F (R); -- { dg-bogus "wrong accessibility in assignment" }
- X := F (R); -- { dg-error "wrong accessibility in assignment" }
+ Y := F (R); -- { dg-bogus "too deep for aliased formal" }
+ X := F (R); -- { dg-error "too deep for aliased formal" }
end;
end;
