From f2f9cdad15a6eaadb93239092eb4441c535fa387 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Mon, 16 Jul 2018 14:11:09 +0000 Subject: [PATCH] [Ada] Crash on Indefinite_Hashed_Maps with -gnata -gnateV This patch corrects the generation of helper functions which verify the validity of record type scalar discriminants and scalar components when switches -gnata (assertions enabled) and -gnateV (validity checks on subprogram parameters) are in effect. 2018-07-16 Hristian Kirtchev gcc/ada/ * exp_attr.adb (Build_Record_VS_Func): Handle corner cases dealing with class-wide types and record extensions. gcc/testsuite/ * gnat.dg/validity_check3.adb, gnat.dg/validity_check3.ads: New testcase. From-SVN: r262715 --- gcc/ada/ChangeLog | 5 + gcc/ada/exp_attr.adb | 39 +++++++- gcc/testsuite/ChangeLog | 5 + gcc/testsuite/gnat.dg/validity_check3.adb | 96 ++++++++++++++++++ gcc/testsuite/gnat.dg/validity_check3.ads | 116 ++++++++++++++++++++++ 5 files changed, 257 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/validity_check3.adb create mode 100644 gcc/testsuite/gnat.dg/validity_check3.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6d8572debd0..59597a3a39b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,8 @@ +2018-07-16 Hristian Kirtchev + + * exp_attr.adb (Build_Record_VS_Func): Handle corner cases dealing with + class-wide types and record extensions. + 2018-07-16 Justin Squirek * sem_eval.adb (Eval_Integer_Literal): Add exception for avoiding diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 45c12bfa2fa..77e706a97c9 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -724,13 +724,44 @@ package body Exp_Attr is Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V'); Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'R'); - Rec_Decl : constant Node_Id := Declaration_Node (Rec_Typ); - Rec_Def : constant Node_Id := Type_Definition (Rec_Decl); + Comps : Node_Id; Stmts : List_Id; + Typ : Entity_Id; + Typ_Decl : Node_Id; + Typ_Def : Node_Id; + Typ_Ext : Node_Id; -- Start of processing for Build_Record_VS_Func begin + Typ := Rec_Typ; + + -- Use the root type when dealing with a class-wide type + + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); + end if; + + Typ_Decl := Declaration_Node (Typ); + Typ_Def := Type_Definition (Typ_Decl); + + -- The components of a derived type are located in the extension part + + if Nkind (Typ_Def) = N_Derived_Type_Definition then + Typ_Ext := Record_Extension_Part (Typ_Def); + + if Present (Typ_Ext) then + Comps := Component_List (Typ_Ext); + else + Comps := Empty; + end if; + + -- Otherwise the components are available in the definition + + else + Comps := Component_List (Typ_Def); + end if; + -- The code generated by this routine is as follows: -- -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is @@ -774,7 +805,7 @@ package body Exp_Attr is if not Is_Unchecked_Union (Rec_Typ) then Validate_Fields (Obj_Id => Obj_Id, - Fields => Discriminant_Specifications (Rec_Decl), + Fields => Discriminant_Specifications (Typ_Decl), Stmts => Stmts); end if; @@ -782,7 +813,7 @@ package body Exp_Attr is Validate_Component_List (Obj_Id => Obj_Id, - Comp_List => Component_List (Rec_Def), + Comp_List => Comps, Stmts => Stmts); -- Generate: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 506bdf836fb..89e2c79c23a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2018-07-16 Hristian Kirtchev + + * gnat.dg/validity_check3.adb, gnat.dg/validity_check3.ads: New + testcase. + 2018-07-16 Hristian Kirtchev * gnat.dg/wide_wide_value1.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/validity_check3.adb b/gcc/testsuite/gnat.dg/validity_check3.adb new file mode 100644 index 00000000000..925f9a6d8f2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/validity_check3.adb @@ -0,0 +1,96 @@ +-- { dg-do compile } +-- { dg-options "-gnata -gnateV" } + +package body Validity_Check3 is + procedure Proc_Priv_CW_1 (Param : Tag_1'Class) is begin null; end; + procedure Proc_Priv_CW_2 (Param : Tag_2'Class) is begin null; end; + procedure Proc_Priv_CW_3 (Param : Tag_3'Class) is begin null; end; + procedure Proc_Priv_CW_4 (Param : Tag_4'Class) is begin null; end; + procedure Proc_Priv_CW_5 (Param : Tag_5'Class) is begin null; end; + procedure Proc_Priv_CW_6 (Param : Tag_6'Class) is begin null; end; + + procedure Proc_Priv_Rec_1 (Param : Rec_1) is begin null; end; + procedure Proc_Priv_Rec_2 (Param : Rec_2) is begin null; end; + procedure Proc_Priv_Rec_3 (Param : Rec_3) is begin null; end; + procedure Proc_Priv_Rec_4 (Param : Rec_4) is begin null; end; + + procedure Proc_Priv_Tag_1 (Param : Tag_1) is begin null; end; + procedure Proc_Priv_Tag_2 (Param : Tag_2) is begin null; end; + procedure Proc_Priv_Tag_3 (Param : Tag_3) is begin null; end; + procedure Proc_Priv_Tag_4 (Param : Tag_4) is begin null; end; + procedure Proc_Priv_Tag_5 (Param : Tag_5) is begin null; end; + procedure Proc_Priv_Tag_6 (Param : Tag_6) is begin null; end; + + procedure Proc_Vis_CW_1 (Param : Tag_1'Class) is begin null; end; + procedure Proc_Vis_CW_2 (Param : Tag_2'Class) is begin null; end; + procedure Proc_Vis_CW_3 (Param : Tag_3'Class) is begin null; end; + procedure Proc_Vis_CW_4 (Param : Tag_4'Class) is begin null; end; + procedure Proc_Vis_CW_5 (Param : Tag_5'Class) is begin null; end; + procedure Proc_Vis_CW_6 (Param : Tag_6'Class) is begin null; end; + + procedure Proc_Vis_Rec_1 (Param : Rec_1) is begin null; end; + procedure Proc_Vis_Rec_2 (Param : Rec_2) is begin null; end; + procedure Proc_Vis_Rec_3 (Param : Rec_3) is begin null; end; + procedure Proc_Vis_Rec_4 (Param : Rec_4) is begin null; end; + + procedure Proc_Vis_Tag_1 (Param : Tag_1) is begin null; end; + procedure Proc_Vis_Tag_2 (Param : Tag_2) is begin null; end; + procedure Proc_Vis_Tag_3 (Param : Tag_3) is begin null; end; + procedure Proc_Vis_Tag_4 (Param : Tag_4) is begin null; end; + procedure Proc_Vis_Tag_5 (Param : Tag_5) is begin null; end; + procedure Proc_Vis_Tag_6 (Param : Tag_6) is begin null; end; + + procedure Call_All is + pragma Warnings (Off); + Obj_Rec_1 : Rec_1; + Obj_Rec_2 : Rec_2; + Obj_Rec_3 : Rec_3 (3); + Obj_Rec_4 : Rec_4 (4); + Obj_Tag_1 : Tag_1; + Obj_Tag_2 : Tag_2; + Obj_Tag_3 : Tag_3 (3); + Obj_Tag_4 : Tag_4 (4); + Obj_Tag_5 : Tag_5; + Obj_Tag_6 : Tag_6 (6); + pragma Warnings (On); + + begin + Proc_Priv_CW_1 (Obj_Tag_1); + Proc_Priv_CW_2 (Obj_Tag_2); + Proc_Priv_CW_3 (Obj_Tag_3); + Proc_Priv_CW_4 (Obj_Tag_4); + Proc_Priv_CW_5 (Obj_Tag_5); + Proc_Priv_CW_6 (Obj_Tag_6); + + Proc_Priv_Rec_1 (Obj_Rec_1); + Proc_Priv_Rec_2 (Obj_Rec_2); + Proc_Priv_Rec_3 (Obj_Rec_3); + Proc_Priv_Rec_4 (Obj_Rec_4); + + Proc_Priv_Tag_1 (Obj_Tag_1); + Proc_Priv_Tag_2 (Obj_Tag_2); + Proc_Priv_Tag_3 (Obj_Tag_3); + Proc_Priv_Tag_4 (Obj_Tag_4); + Proc_Priv_Tag_5 (Obj_Tag_5); + Proc_Priv_Tag_6 (Obj_Tag_6); + + Proc_Vis_CW_1 (Obj_Tag_1); + Proc_Vis_CW_2 (Obj_Tag_2); + Proc_Vis_CW_3 (Obj_Tag_3); + Proc_Vis_CW_4 (Obj_Tag_4); + Proc_Vis_CW_5 (Obj_Tag_5); + Proc_Vis_CW_6 (Obj_Tag_6); + + Proc_Vis_Rec_1 (Obj_Rec_1); + Proc_Vis_Rec_2 (Obj_Rec_2); + Proc_Vis_Rec_3 (Obj_Rec_3); + Proc_Vis_Rec_4 (Obj_Rec_4); + + Proc_Vis_Tag_1 (Obj_Tag_1); + Proc_Vis_Tag_2 (Obj_Tag_2); + Proc_Vis_Tag_3 (Obj_Tag_3); + Proc_Vis_Tag_4 (Obj_Tag_4); + Proc_Vis_Tag_5 (Obj_Tag_5); + Proc_Vis_Tag_6 (Obj_Tag_6); + end Call_All; +end Validity_Check3; diff --git a/gcc/testsuite/gnat.dg/validity_check3.ads b/gcc/testsuite/gnat.dg/validity_check3.ads new file mode 100644 index 00000000000..537f0ec1a9c --- /dev/null +++ b/gcc/testsuite/gnat.dg/validity_check3.ads @@ -0,0 +1,116 @@ +package Validity_Check3 is + procedure Call_All; + + type Rec_1 is private; + procedure Proc_Vis_Rec_1 (Param : Rec_1); + + type Rec_2 (<>) is private; + procedure Proc_Vis_Rec_2 (Param : Rec_2); + + type Rec_3 (<>) is private; + procedure Proc_Vis_Rec_3 (Param : Rec_3); + + type Rec_4 (Discr : Integer) is private; + procedure Proc_Vis_Rec_4 (Param : Rec_4); + + type Tag_1 is tagged private; + procedure Proc_Vis_Tag_1 (Param : Tag_1); + procedure Proc_Vis_CW_1 (Param : Tag_1'Class); + + type Tag_2 (<>) is tagged private; + procedure Proc_Vis_Tag_2 (Param : Tag_2); + procedure Proc_Vis_CW_2 (Param : Tag_2'Class); + + type Tag_3 (<>) is tagged private; + procedure Proc_Vis_Tag_3 (Param : Tag_3); + procedure Proc_Vis_CW_3 (Param : Tag_3'Class); + + type Tag_4 (Discr : Integer) is tagged private; + procedure Proc_Vis_Tag_4 (Param : Tag_4); + procedure Proc_Vis_CW_4 (Param : Tag_4'Class); + + type Tag_5 is new Tag_1 with private; + procedure Proc_Vis_Tag_5 (Param : Tag_5); + procedure Proc_Vis_CW_5 (Param : Tag_5'Class); + + type Tag_6 is new Tag_4 with private; + procedure Proc_Vis_Tag_6 (Param : Tag_6); + procedure Proc_Vis_CW_6 (Param : Tag_6'Class); + +private + type Rec_1 is record + Comp_1 : Integer; + Comp_2 : Boolean; + end record; + + procedure Proc_Priv_Rec_1 (Param : Rec_1); + + type Rec_2 is record + Comp_1 : Integer; + Comp_2 : Boolean; + end record; + + procedure Proc_Priv_Rec_2 (Param : Rec_2); + + type Rec_3 (Discr : Integer) is record + Comp_1 : Integer; + Comp_2 : Boolean; + end record; + + procedure Proc_Priv_Rec_3 (Param : Rec_3); + + type Rec_4 (Discr : Integer) is record + Comp_1 : Integer; + Comp_2 : Boolean; + end record; + + procedure Proc_Priv_Rec_4 (Param : Rec_4); + + type Tag_1 is tagged record + Comp_1 : Integer; + Comp_2 : Boolean; + end record; + + procedure Proc_Priv_Tag_1 (Param : Tag_1); + procedure Proc_Priv_CW_1 (Param : Tag_1'Class); + + type Tag_2 is tagged record + Comp_1 : Integer; + Comp_2 : Boolean; + end record; + + procedure Proc_Priv_Tag_2 (Param : Tag_2); + procedure Proc_Priv_CW_2 (Param : Tag_2'Class); + + type Tag_3 (Discr : Integer) is tagged record + Comp_1 : Integer; + Comp_2 : Boolean; + end record; + + procedure Proc_Priv_Tag_3 (Param : Tag_3); + procedure Proc_Priv_CW_3 (Param : Tag_3'Class); + + type Tag_4 (Discr : Integer) is tagged record + Comp_1 : Integer; + Comp_2 : Boolean; + end record; + + procedure Proc_Priv_Tag_4 (Param : Tag_4); + procedure Proc_Priv_CW_4 (Param : Tag_4'Class); + + type Tag_5 is new Tag_1 with record + Comp_3 : Integer; + Comp_4 : Boolean; + end record; + + procedure Proc_Priv_Tag_5 (Param : Tag_5); + procedure Proc_Priv_CW_5 (Param : Tag_5'Class); + + type Tag_6 is new Tag_4 with record + Comp_3 : Integer; + Comp_4 : Boolean; + end record; + + procedure Proc_Priv_Tag_6 (Param : Tag_6); + procedure Proc_Priv_CW_6 (Param : Tag_6'Class); +end Validity_Check3; -- 2.30.2