diff mbox series

[COMMITTED] ada: Handle new Controlling_Tag format when converting to SCIL

Message ID 20230526073559.2068284-1-poulhies@adacore.com
State Committed
Commit 0e1bba09231634176893908f4402d57ef21477f8
Headers
Series [COMMITTED] ada: Handle new Controlling_Tag format when converting to SCIL |

Commit Message

Marc Poulhiès May 26, 2023, 7:35 a.m. UTC 
  From: Ghjuvan Lacambre <lacambre@adacore.com>

This commit fixes two CodePeer crashes that were introduced when the
format of the controlling tag changed.

gcc/ada/

	* exp_disp.adb (Expand_Dispatching_Call): Handle new Controlling_Tag.
	* sem_scil.adb (Check_SCIL_Node): Treat N_Object_Renaming_Declaration as
	N_Object_Declaration.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/exp_disp.adb | 34 ++++++++++++++++++++++++++--------
 gcc/ada/sem_scil.adb |  5 +++--
 2 files changed, 29 insertions(+), 10 deletions(-)
diff mbox series

Patch

diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index e7cae38d553..494ead7c144 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -1133,18 +1133,36 @@  package body Exp_Disp is
             Set_SCIL_Controlling_Tag (SCIL_Node,
               Parent (Entity (Prefix (Controlling_Tag))));
 
-         --  For a direct reference of the tag of the type the SCIL node
-         --  references the internal object declaration containing the tag
-         --  of the type.
+         --  Depending on whether a dereference is involved, the SCIL node
+         --  references the corresponding object/parameter declaration or
+         --  the internal object declaration containing the tag of the type.
 
          elsif Nkind (Controlling_Tag) = N_Attribute_Reference
             and then Attribute_Name (Controlling_Tag) = Name_Tag
          then
-            Set_SCIL_Controlling_Tag (SCIL_Node,
-              Parent
-                (Node
-                  (First_Elmt
-                    (Access_Disp_Table (Entity (Prefix (Controlling_Tag)))))));
+            declare
+               Prefix_Node : constant Node_Id   := Prefix (Controlling_Tag);
+               Ent         : constant Entity_Id := Entity
+                 (if Nkind (Prefix_Node) = N_Explicit_Dereference then
+                    Prefix (Prefix_Node)
+                  else
+                    Prefix_Node);
+
+            begin
+               if Ekind (Ent) in E_Record_Type
+                               | E_Record_Subtype
+                               | E_Record_Type_With_Private
+               then
+                  Set_SCIL_Controlling_Tag (SCIL_Node,
+                    Parent
+                      (Node
+                        (First_Elmt
+                          (Access_Disp_Table (Ent)))));
+
+               else
+                  Set_SCIL_Controlling_Tag (SCIL_Node, Parent (Ent));
+               end if;
+            end;
 
          --  Interfaces are not supported. For now we leave the SCIL node
          --  decorated with the Controlling_Tag. More work needed here???
diff --git a/gcc/ada/sem_scil.adb b/gcc/ada/sem_scil.adb
index 7c75c9d66bc..da8fab69a97 100644
--- a/gcc/ada/sem_scil.adb
+++ b/gcc/ada/sem_scil.adb
@@ -88,8 +88,9 @@  package body Sem_SCIL is
             --  object or parameter declaration. Interface types are still
             --  unsupported.
 
-            elsif Nkind (Ctrl_Tag) in
-                    N_Object_Declaration | N_Parameter_Specification
+            elsif Nkind (Ctrl_Tag) in N_Object_Renaming_Declaration
+                                    | N_Object_Declaration
+                                    | N_Parameter_Specification
             then
                Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag));