[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

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 5c17f81e7c031fe920020d33087841b9b66b0465..cbb1e1639600e656c1666bccd9b1e24209f620b3 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/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

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 0c96d8c2a4a073a669192d66d4adeb25b866d85d..a20469cfa7c7985589adb7212da27404970134e9 100644 (file)
--- a/gcc/ada/exp_ch4.adb
+++ b/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

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 32297d12789c705428184540e8b6221fccc6947e..bf677223c321b55ed842f8fee0df751dea3614dc 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/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.

diff --git a/gcc/testsuite/gnat.dg/access8.adb b/gcc/testsuite/gnat.dg/access8.adb
new file mode 100644 (file)
index 0000000..d7eec2a
--- /dev/null
+++ b/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;

diff --git a/gcc/testsuite/gnat.dg/access8_pkg.adb b/gcc/testsuite/gnat.dg/access8_pkg.adb
new file mode 100644 (file)
index 0000000..9d7c933
--- /dev/null
+++ b/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;

diff --git a/gcc/testsuite/gnat.dg/access8_pkg.ads b/gcc/testsuite/gnat.dg/access8_pkg.ads
new file mode 100644 (file)
index 0000000..19c632d
--- /dev/null
+++ b/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;