From: Eric Botcazou Date: Thu, 12 Mar 2026 17:11:34 +0000 (+0100) Subject: Ada: Fix missing error for dangling pointer from access discriminant X-Git-Tag: basepoints/gcc-17~754 X-Git-Url: http://git.ipfire.org/gitweb/?a=commitdiff_plain;h=d8f49b41b01900751e73a2a01ca22f2246bd9af3;p=thirdparty%2Fgcc.git Ada: Fix missing error for dangling pointer from access discriminant 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. 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. gcc/ada/ 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) : 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. gcc/testsuite/ * ada/acats-3/tests/c3/c3a0025.a: Tweak. * ada/acats-4/tests/c3/c3a0025.a: Likewise. * gnat.dg/access12.adb: New test. --- diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb index a6518c21611..2e1406be9a6 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; diff --git a/gcc/testsuite/gnat.dg/access12.adb b/gcc/testsuite/gnat.dg/access12.adb new file mode 100644 index 00000000000..5820b91deb2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/access12.adb @@ -0,0 +1,26 @@ +-- { 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;