This restores the original computation of the scope depth of the innermost
enclosing master of a given node and performs a couple of other cleanups,
fixing the regression reported under PR ada/124369 in the process.
Note that this has uncovered an issue in the ACATS c3a0025 test and the change
contains the modification that has been submitted to the ACAA.
Tested on x86-64/Linux, applied on the mainline.
2026-03-12 Eric Botcazou <[email protected]>
PR ada/124369
* accessibility.adb (Accessibility_Message): Give an error instead
of a warning in an instance when No_Dynamic_Accessibility_Checks is
in effect.
(Innermost_Master_Scope_Depth): Restore the original computation of
the nearest enclosing dynamic scope.
* sem_attr.adb (Resolve_Attribute) <Attribute_Access>: Call the
Accessibility_Message routine in all cases to give accessibility
errors and do not return. Call the Static_Accessibility_Level
function in all cases to compute static accessibility levels.
Add guard before calling Prefix_With_Safe_Accessibility_Level.
2026-03-12 Eric Botcazou <[email protected]>
* ada/acats-3/tests/c3/c3a0025.a: Tweak.
* ada/acats-4/tests/c3/c3a0025.a: Likewise.
* gnat.dg/access12.adb: New test.
--
Eric Botcazoudiff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb
index 4c0863b798c..f1c5bd373e2 100644
--- a/gcc/ada/accessibility.adb
+++ b/gcc/ada/accessibility.adb
@@ -64,10 +64,13 @@ package body Accessibility is
begin
-- In an instance, this is a runtime check, but one we know will fail,
- -- so generate an appropriate warning.
+ -- so generate an appropriate warning. As usual, this kind of warning
+ -- is an error in SPARK mode or if No_Dynamic_Accessibility_Checks.
if In_Instance_Body then
- Error_Msg_Warn := SPARK_Mode /= On;
+ 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 ("\Program_Error [<<", P);
@@ -152,7 +155,7 @@ package body Accessibility is
begin
-- Locate the nearest enclosing node (by traversing Parents)
-- that Defining_Entity can be applied to, and return the
- -- depth of that entity's nearest enclosing scope.
+ -- depth of that entity's nearest enclosing dynamic scope.
-- The RM 7.6.1(3) definition of "master" includes statements
-- and conditions for loops among other things. Are these cases
@@ -162,19 +165,7 @@ package body Accessibility is
Ent := Defining_Entity_Or_Empty (Node_Par);
if Present (Ent) then
- -- X'Old is nested within the current subprogram, so we do not
- -- want Find_Enclosing_Scope of that subprogram. If this is an
- -- allocator, then we're looking for the innermost master of
- -- the call, so again we do not want Find_Enclosing_Scope.
-
- if (Nkind (N) = N_Attribute_Reference
- and then Attribute_Name (N) = Name_Old)
- or else Nkind (N) = N_Allocator
- then
- Encl_Scop := Ent;
- else
- Encl_Scop := Find_Enclosing_Scope (Ent);
- end if;
+ Encl_Scop := Nearest_Dynamic_Scope (Ent);
-- Ignore transient scopes made during expansion while also
-- taking into account certain expansions - like iterators
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 90eb682a094..161e5cd16c0 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -12043,29 +12043,7 @@ package body Sem_Attr is
Static_Accessibility_Level (N, Zero_On_Dynamic_Level) >
Deepest_Type_Access_Level (Btyp)
then
- -- In an instance, this is a runtime check, but one we know
- -- will fail, so generate an appropriate warning. As usual,
- -- this kind of warning is an error in SPARK mode.
-
- if In_Instance_Body then
- 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 ("\Program_Error [<<", P);
-
- Rewrite (N,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Accessibility_Check_Failed));
- Set_Etype (N, Typ);
-
- else
- Error_Msg_F
- ("non-local pointer cannot point to local object", P);
- end if;
+ Accessibility_Message (N, Typ);
end if;
if Attr_Id /= Attribute_Unrestricted_Access
@@ -12233,22 +12211,11 @@ package body Sem_Attr is
and then Ekind (Btyp)
= E_Anonymous_Access_Type)
- -- Call Accessibility_Level directly to avoid returning
- -- zero on cases where the prefix is an explicitly aliased
- -- parameter in a return statement, instead of using the
- -- normal Static_Accessibility_Level function.
-
- -- Shouldn't this be handled somehow in
- -- Static_Accessibility_Level ???
-
- and then Nkind (Accessibility_Level (P, Dynamic_Level))
- = N_Integer_Literal
and then
- Intval (Accessibility_Level (P, Dynamic_Level))
- > Deepest_Type_Access_Level (Btyp)
+ Static_Accessibility_Level (N, Zero_On_Dynamic_Level) >
+ Deepest_Type_Access_Level (Btyp)
then
Accessibility_Message (N, Typ);
- return;
end if;
end;
end if;
@@ -12274,7 +12241,6 @@ package body Sem_Attr is
and then Attr_Id /= Attribute_Unrestricted_Access
then
Accessibility_Message (N, Typ);
- return;
-- AI05-0225: If the context is not an access to protected
-- function, the prefix must be a variable, given that it may
@@ -12424,9 +12390,10 @@ package body Sem_Attr is
-- array type since a value conversion is like an aggregate with
-- respect to determining accessibility level (RM 3.10.2).
- if not Prefix_With_Safe_Accessibility_Level (N, Typ) then
+ if Nkind (N) /= N_Raise_Program_Error
+ and then not Prefix_With_Safe_Accessibility_Level (N, Typ)
+ then
Accessibility_Message (N, Typ);
- return;
end if;
-- Mark that address of entity is taken in case of
diff --git a/gcc/testsuite/ada/acats-3/tests/c3/c3a0025.a b/gcc/testsuite/ada/acats-3/tests/c3/c3a0025.a
index ea2cb2911e4..5d497860f81 100644
--- a/gcc/testsuite/ada/acats-3/tests/c3/c3a0025.a
+++ b/gcc/testsuite/ada/acats-3/tests/c3/c3a0025.a
@@ -324,8 +324,11 @@ begin
when Constraint_Error =>
null;
end;
- Obj := Func_1 (Non_Null_Init);
- if Obj /= Non_Null_Init then
+ -- Temporary deviation from the original test:
+ -- Obj := Func_1 (Non_Null_Init);
+ -- if Obj /= Non_Null_Init then
+
+ if Func_1 (Non_Null_Init) /= Non_Null_Init then
Report.Failed ("Func_1_OK: Wrong value");
end if;
end;
@@ -347,8 +350,11 @@ begin
when Constraint_Error =>
null;
end;
- Obj := Func_2 (Non_Null_Init);
- if Obj /= Non_Null_Init then
+ -- Temporary deviation from the original test:
+ -- Obj := Func_2 (Non_Null_Init);
+ -- if Obj /= Non_Null_Init then
+
+ if Func_2 (Non_Null_Init) /= Non_Null_Init then
Report.Failed ("Func_2_OK: Wrong value");
end if;
end;
diff --git a/gcc/testsuite/ada/acats-4/tests/c3/c3a0025.a b/gcc/testsuite/ada/acats-4/tests/c3/c3a0025.a
index ea2cb2911e4..5d497860f81 100644
--- a/gcc/testsuite/ada/acats-4/tests/c3/c3a0025.a
+++ b/gcc/testsuite/ada/acats-4/tests/c3/c3a0025.a
@@ -324,8 +324,11 @@ begin
when Constraint_Error =>
null;
end;
- Obj := Func_1 (Non_Null_Init);
- if Obj /= Non_Null_Init then
+ -- Temporary deviation from the original test:
+ -- Obj := Func_1 (Non_Null_Init);
+ -- if Obj /= Non_Null_Init then
+
+ if Func_1 (Non_Null_Init) /= Non_Null_Init then
Report.Failed ("Func_1_OK: Wrong value");
end if;
end;
@@ -347,8 +350,11 @@ begin
when Constraint_Error =>
null;
end;
- Obj := Func_2 (Non_Null_Init);
- if Obj /= Non_Null_Init then
+ -- Temporary deviation from the original test:
+ -- Obj := Func_2 (Non_Null_Init);
+ -- if Obj /= Non_Null_Init then
+
+ if Func_2 (Non_Null_Init) /= Non_Null_Init then
Report.Failed ("Func_2_OK: Wrong value");
end if;
end;
-- { dg-do compile }
procedure Access12 is
type Rec (Element : access Integer) is null record;
function Make_Rec (X : access Integer) return Rec is (Element => X);
type Acc is access all Integer;
A : Acc;
begin
for I in 1 .. 10 loop
declare
X : aliased Integer;
R : Rec := Make_Rec (X'Access);
begin
if I = 1 then
X := 0;
end if;
A := R.Element.all'Access; -- { dg-error "non-local pointer" }
X := I;
end;
end loop;
end;
