diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5c17f81e7c03..cbb1e1639600 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2019-09-18 Justin Squirek + + * 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 * 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 0c96d8c2a4a0..a20469cfa7c7 100644 --- 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 32297d12789c..bf677223c321 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2019-09-18 Justin Squirek + + * gnat.dg/access8.adb, gnat.dg/access8_pkg.adb, + gnat.dg/access8_pkg.ads: New testcase. + 2019-09-18 Eric Botcazou * 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 index 000000000000..d7eec2ac4ab4 --- /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 index 000000000000..9d7c9332b933 --- /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 index 000000000000..19c632dbe5cd --- /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;