Ada: Fix missing accessibility check in assignment for aliased parameter

This plugs a loophole related to static accessibility checks in assignment
for aliased parameters.

gcc/ada/
	PR ada/124376
	* sem_res.adb (Resolve_Actuals.Check_Aliased_Parameter): Deal with
	assignment statements.

gcc/testsuite/
	* gnat.dg/aliased3.adb: New test.

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 43ff97cd8c823a17cf01ec0e4d506371cd57a851..688347ba1aa4c30502195b870927ec63231b8b6c 100644 (file)
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -3799,6 +3799,14 @@ package body Sem_Res is
             then
                Accessibility_Error ("conversion");
 
+            elsif Ekind (Etype (Nam)) = E_Anonymous_Access_Type
+              and then Nkind (Parent (N)) = N_Assignment_Statement
+              and then Static_Accessibility_Level
+                         (Name (Parent (N)), Object_Decl_Level)
+                           < Static_Accessibility_Level (A, Object_Decl_Level)
+            then
+               Accessibility_Error ("assignment");
+
             elsif Nkind (Parent (N)) = N_Qualified_Expression
               and then Nkind (Parent (Parent (N))) = N_Allocator
               and then Type_Access_Level (Etype (Parent (Parent (N))))
@@ -3810,7 +3818,7 @@ package body Sem_Res is
               and then Comes_From_Source (N)
               and then Subprogram_Access_Level (Current_Subprogram)
                          < Static_Accessibility_Level
-                            (A, Object_Decl_Level, In_Return_Context => True)
+                             (A, Object_Decl_Level, In_Return_Context => True)
             then
                Accessibility_Error ("return");
             end if;

diff --git a/gcc/testsuite/gnat.dg/aliased3.adb b/gcc/testsuite/gnat.dg/aliased3.adb
new file mode 100644 (file)
index 0000000..16355a9
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/aliased3.adb
@@ -0,0 +1,18 @@
+-- { dg-do compile }
+
+procedure Aliased3 is
+
+   function F (R : aliased Integer) return access constant Integer is
+   (R'Access);
+
+   X : access constant Integer;
+
+begin
+   declare
+      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" }
+   end;
+end;