[Ada] Missing accessibility check on discrim assignment
diff mbox series

Message ID 20190918083945.GA145226@adacore.com
State New
Headers show
Series
  • [Ada] Missing accessibility check on discrim assignment
Related show

Commit Message

Pierre-Marie de Rodat Sept. 18, 2019, 8:39 a.m. UTC
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).

Tested on x86_64-pc-linux-gnu, committed on trunk

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.

Patch
diff mbox series

--- gcc/ada/exp_ch4.adb
+++ 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

--- /dev/null
new file mode 100644
+++ 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;

--- /dev/null
new file mode 100644
+++ 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;

--- /dev/null
new file mode 100644
+++ 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;