[Ada] Preparation for new description of interface thunks

This adjusts and exposes a couple of functions of the front-end used for the
generation of interface thunks so as to make them callable from gigi.  This
also propagates the debug info setting from the targets to the thunks so as
to make stepping into primitives work better in the debugger.

2018-09-26  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* exp_disp.adb (Expand_Interface_Conversion): Use Present test.
	(Expand_Interface_Thunk): Propagate debug info setting from
	target.
	* exp_util.ads (Find_Interface_Tag): Adjust comment.
	* exp_util.adb (Find_Interface_Tag): Remove assertions of
	success.
	* sem_util.adb (Is_Variable_Size_Record): Only look at
	components and robustify the implementation.
	* fe.h (Find_Interface_Tag): Declare.
	(Is_Variable_Size_Record): Likewise.

From-SVN: r264614

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 94f90d3c6ec4c204b7e1f4fdd6d719ce9dd24506..08087d97fc1f708b55fa2415f5e5fc4010172032 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,16 @@
+2018-09-26  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * exp_disp.adb (Expand_Interface_Conversion): Use Present test.
+       (Expand_Interface_Thunk): Propagate debug info setting from
+       target.
+       * exp_util.ads (Find_Interface_Tag): Adjust comment.
+       * exp_util.adb (Find_Interface_Tag): Remove assertions of
+       success.
+       * sem_util.adb (Is_Variable_Size_Record): Only look at
+       components and robustify the implementation.
+       * fe.h (Find_Interface_Tag): Declare.
+       (Is_Variable_Size_Record): Likewise.
+
 2018-09-26  Thomas Quinot  <quinot@adacore.com>
 
        * exp_util.adb (Make_CW_Equivalent_Type): Propagate bit order

diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 8270492fd7a8c7671e2b64ea902b93e38b601368..cf7ce4986a8148e426a931b5dd242ba5885568f2 100644 (file)
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -1454,7 +1454,7 @@ package body Exp_Disp is
       end if;
 
       Iface_Tag := Find_Interface_Tag (Operand_Typ, Iface_Typ);
-      pragma Assert (Iface_Tag /= Empty);
+      pragma Assert (Present (Iface_Tag));
 
       --  Keep separate access types to interfaces because one internal
       --  function is used to handle the null value (see following comments)
@@ -2046,6 +2046,7 @@ package body Exp_Disp is
       Set_Ekind (Thunk_Id, Ekind (Prim));
       Set_Is_Thunk (Thunk_Id);
       Set_Convention (Thunk_Id, Convention (Prim));
+      Set_Needs_Debug_Info (Thunk_Id, Needs_Debug_Info (Target));
       Set_Thunk_Entity (Thunk_Id, Target);
 
       --  Procedure case

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 31e36ee84d2b05f18d4ad166cb307b199a9c4de4..183797cd9f9edd8875a1ea4de7fd60162caaeeb4 100644 (file)
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -5529,7 +5529,6 @@ package body Exp_Util is
          then
             --  Skip the tag associated with the primary table
 
-            pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
             AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
             pragma Assert (Present (AI_Tag));
 
@@ -5590,14 +5589,12 @@ package body Exp_Util is
       --  primary dispatch table.
 
       if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
-         pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
          return First_Tag_Component (Typ);
 
       --  Otherwise we need to search for its associated tag component
 
       else
          Find_Tag (Typ);
-         pragma Assert (Found);
          return AI_Tag;
       end if;
    end Find_Interface_Tag;

diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 708da2004ae8bb4e869981412982e2dd3fd542ac..b5e2a7bbe146f526d0fda244c9801a3437c6312f 100644 (file)
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -585,8 +585,9 @@ package Exp_Util is
    function Find_Interface_Tag
      (T     : Entity_Id;
       Iface : Entity_Id) return Entity_Id;
-   --  Ada 2005 (AI-251): Given a type T implementing the interface Iface,
-   --  return the record component containing the tag of Iface.
+   --  Ada 2005 (AI-251): Given a type T and an interface Iface, return the
+   --  record component containing the tag of Iface if T implements Iface or
+   --  Empty if it does not.
 
    function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id;
    --  Find the first primitive operation of a tagged type T with name Name.

diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h
index 2d07aa506c739569db38f462e81311da11be9760..7c3204467dc3aa66576ece617bdede436f87ecff 100644 (file)
--- a/gcc/ada/fe.h
+++ b/gcc/ada/fe.h
@@ -159,8 +159,10 @@ extern void Get_External_Name      (Entity_Id, Boolean, String_Pointer);
 /* exp_util: */
 
 #define Is_Fully_Repped_Tagged_Type exp_util__is_fully_repped_tagged_type
+#define Find_Interface_Tag exp_util__find_interface_tag
 
 extern Boolean Is_Fully_Repped_Tagged_Type      (Entity_Id);
+extern Entity_Id Find_Interface_Tag            (Entity_Id, Entity_Id);
 
 /* lib: */
 
@@ -269,12 +271,14 @@ extern Boolean Is_OK_Static_Subtype       (Entity_Id);
 #define Defining_Entity                        sem_util__defining_entity
 #define First_Actual                   sem_util__first_actual
 #define Next_Actual                    sem_util__next_actual
+#define Is_Variable_Size_Record        sem_util__is_variable_size_record
 #define Requires_Transient_Scope       sem_util__requires_transient_scope
 
 extern Entity_Id Defining_Entity       (Node_Id);
 extern Node_Id First_Actual            (Node_Id);
 extern Node_Id Next_Actual             (Node_Id);
-extern Boolean Requires_Transient_Scope (Entity_Id);
+extern Boolean Is_Variable_Size_Record         (Entity_Id Id);
+extern Boolean Requires_Transient_Scope        (Entity_Id);
 
 /* sinfo: */
 

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 2b31cf752cb0c0c1c19fa83205210033c2a1d70a..7235c96a8d781e9141aa1f65d1ece18531366f62 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -17714,9 +17714,9 @@ package body Sem_Util is
    begin
       pragma Assert (Is_Record_Type (E));
 
-      Comp := First_Entity (E);
+      Comp := First_Component (E);
       while Present (Comp) loop
-         Comp_Typ := Etype (Comp);
+         Comp_Typ := Underlying_Type (Etype (Comp));
 
          --  Recursive call if the record type has discriminants
 
@@ -17732,7 +17732,7 @@ package body Sem_Util is
             return True;
          end if;
 
-         Next_Entity (Comp);
+         Next_Component (Comp);
       end loop;
 
       return False;