From: Justin Squirek Date: Wed, 18 Sep 2019 08:33:17 +0000 (+0000) Subject: [Ada] Missing accessibility check on discrim assignment X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=1b2f53bb9ad9c903a126bbe5d6c5672550a54c13;p=gcc.git [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 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 5c17f81e7c0..cbb1e163960 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 0c96d8c2a4a..a20469cfa7c 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 32297d12789..bf677223c32 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 00000000000..d7eec2ac4ab --- /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 00000000000..9d7c9332b93 --- /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 00000000000..19c632dbe5c --- /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;