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 <squi...@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.--- 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;
