[Ada] Missing accessibility check on discrim assignment

This patch fixes an issue whereby assignments from anonymous access
descriminants which are part of stand alone objects of anonymous access
did not have runtime checks generated based on the accessibility level
of the object according to ARM 3.10.2 (12.5/3).

2019-09-18  Justin Squirek  <squirek@adacore.com>

gcc/ada/

	* exp_ch4.adb (Expand_N_Type_Conversion): Add calculation of an
	alternative operand for the purposes of generating accessibility
	checks.

gcc/testsuite/

	* gnat.dg/access8.adb, gnat.dg/access8_pkg.adb,
	gnat.dg/access8_pkg.ads: New testcase.

From-SVN: r275860

gcc/ada/ChangeLog

@@ -1,3 +1,9 @@
+2019-09-18  Justin Squirek  <squirek@adacore.com>
+
+	* exp_ch4.adb (Expand_N_Type_Conversion): Add calculation of an
+	alternative operand for the purposes of generating accessibility
+	checks.
+
 2019-09-18  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* exp_aggr.adb (Build_Array_Aggr_Code): In STEP 1 (c), duplicate

gcc/ada/exp_ch4.adb

@@ -11001,6 +11001,7 @@ package body Exp_Ch4 is
    procedure Expand_N_Type_Conversion (N : Node_Id) is
       Loc          : constant Source_Ptr := Sloc (N);
       Operand      : constant Node_Id    := Expression (N);
+      Operand_Acc  : Node_Id             := Operand;
       Target_Type  : Entity_Id           := Etype (N);
       Operand_Type : Entity_Id           := Etype (Operand);
 
@@ -11718,6 +11719,15 @@ package body Exp_Ch4 is
       --  Case of converting to an access type
 
       if Is_Access_Type (Target_Type) then
+         --  In terms of accessibility rules, an anonymous access discriminant
+         --  is not considered separate from its parent object.
+
+         if Nkind (Operand) = N_Selected_Component
+           and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant
+           and then Ekind (Operand_Type) = E_Anonymous_Access_Type
+         then
+            Operand_Acc := Original_Node (Prefix (Operand));
+         end if;
 
          --  If this type conversion was internally generated by the front end
          --  to displace the pointer to the object to reference an interface
@@ -11741,9 +11751,9 @@ package body Exp_Ch4 is
          --  other checks may still need to be applied below (such as tagged
          --  type checks).
 
-         elsif Is_Entity_Name (Operand)
-           and then Has_Extra_Accessibility (Entity (Operand))
-           and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
+         elsif Is_Entity_Name (Operand_Acc)
+           and then Has_Extra_Accessibility (Entity (Operand_Acc))
+           and then Ekind (Etype (Operand_Acc)) = E_Anonymous_Access_Type
            and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
                       or else Attribute_Name (Original_Node (N)) = Name_Access)
          then
@@ -11758,7 +11768,7 @@ package body Exp_Ch4 is
 
             else
                Apply_Accessibility_Check
-                 (Operand, Target_Type, Insert_Node => Operand);
+                 (Operand_Acc, Target_Type, Insert_Node => Operand);
             end if;
 
          --  If the level of the operand type is statically deeper than the

gcc/testsuite/ChangeLog

@@ -1,3 +1,8 @@
+2019-09-18  Justin Squirek  <squirek@adacore.com>
+
+	* gnat.dg/access8.adb, gnat.dg/access8_pkg.adb,
+	gnat.dg/access8_pkg.ads: New testcase.
+
 2019-09-18  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gnat.dg/aggr28.adb: New testcase.

gcc/testsuite/gnat.dg/access8.adb

@@ -0,0 +1,46 @@
+--  { dg-do run }
+--  { dg-options "-gnatws" }
+
+with Access8_Pkg;
+procedure Access8 is
+   Errors : Natural := 0;
+   outer_object_accessibility_check
+     : access Access8_Pkg.object;
+   outer_discriminant_accessibility_check
+     : access Access8_Pkg.discriminant;
+   Mistake
+     : access Access8_Pkg.discriminant;
+   outer_discriminant_copy_discriminant_check
+     : access Access8_Pkg.discriminant;
+begin
+   declare
+      obj
+        : aliased Access8_Pkg.object := Access8_Pkg.get;
+      inner_object
+        : access Access8_Pkg.object := obj'Access;
+      inner_discriminant
+        : access Access8_Pkg.discriminant := obj.d;
+   begin
+      begin
+         outer_object_accessibility_check
+           := inner_object;        --  ERROR
+      exception
+         when others => Errors := Errors + 1;
+      end;
+      begin
+         Mistake
+           := inner_object.d;      --  ERROR
+      exception
+         when others => Errors := Errors + 1;
+      end;
+      begin
+         outer_discriminant_copy_discriminant_check
+           := inner_discriminant;  --  ERROR
+      exception
+        when others => Errors := Errors + 1;
+      end;
+      if Errors /= 3 then
+         raise Program_Error;
+      end if;
+   end;
+end;

gcc/testsuite/gnat.dg/access8_pkg.adb

@@ -0,0 +1,30 @@
+--  { dg-options "-gnatws" }
+
+with Ada.Finalization;
+
+package body Access8_Pkg is
+
+   overriding procedure Initialize (O : in out Object) is
+   begin
+      null;
+   end;
+
+   overriding procedure Finalize (O : in out Object) is
+   begin
+      null;
+   end;
+
+   function Get return Object is
+   begin
+      return O : Object := Object'
+        (Ada.Finalization.Limited_Controlled
+          with D => new discriminant);
+   end;
+
+   function Get_Access return access Object is
+   begin
+      return new Object'
+        (Ada.Finalization.Limited_Controlled
+          with D => new Discriminant);
+   end;
+end;

gcc/testsuite/gnat.dg/access8_pkg.ads

@@ -0,0 +1,19 @@
+with Ada.Finalization;
+
+package Access8_Pkg is
+
+   type Discriminant is record
+      Component : Integer := 6;
+   end record;
+
+   type Object (D : access Discriminant)
+     is tagged limited private;
+
+   function Get return Object;
+   function Get_Access return access Object;
+private
+   type Object (D : access Discriminant)
+    is new Ada.Finalization.Limited_Controlled with null record;
+   overriding procedure Initialize (O : in out Object);
+   overriding procedure Finalize (O : in out Object);
+end;