[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  <kirtchev@adacore.com>

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

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 6d8572debd0525c47fbe655e7b6c61f68c3ebf0c..59597a3a39b7e182c0f5f9411f940e6fcb07d8fc 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,8 @@
+2018-07-16  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * exp_attr.adb (Build_Record_VS_Func): Handle corner cases dealing with
+       class-wide types and record extensions.
+
 2018-07-16  Justin Squirek  <squirek@adacore.com>
 
        * 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 45c12bfa2faa354a09acbc41a334caa71b73a87f..77e706a97c970cadf832784beca1d075cbc377e6 100644 (file)
--- 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 506bdf836fba1dac115f375e1d8641dcfbef17f8..89e2c79c23a6538111b5ce220cc61fa78afebd14 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2018-07-16  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * gnat.dg/validity_check3.adb, gnat.dg/validity_check3.ads: New
+       testcase.
+
 2018-07-16  Hristian Kirtchev  <kirtchev@adacore.com>
 
        * 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 (file)
index 0000000..925f9a6
--- /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 (file)
index 0000000..537f0ec
--- /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;