aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
authorJavier Miranda <miranda@adacore.com>2018-11-14 11:42:10 +0000
committerPierre-Marie de Rodat <pmderodat@gcc.gnu.org>2018-11-14 11:42:10 +0000
commit4faf522bacd66cd03826c645b30c68f0fd785177 (patch)
treebdbf608da71836e0a46d5adad0020c4da73b5d95 /gcc
parentb6eb7548cf927d541477146a195e2bdd25900012 (diff)
downloadgcc-4faf522bacd66cd03826c645b30c68f0fd785177.zip
gcc-4faf522bacd66cd03826c645b30c68f0fd785177.tar.gz
gcc-4faf522bacd66cd03826c645b30c68f0fd785177.tar.bz2
[Ada] Crash on interface equality covered by a renaming declaration
The frontend crashes processing a tagged type that implements an interface which has an equality primitive (that is, "=") and covers such primitive by means of a renaming declaration. 2018-11-14 Javier Miranda <miranda@adacore.com> gcc/ada/ * exp_disp.adb (Expand_Interface_Thunk): Extend handling of renamings of the predefined equality primitive. (Make_Secondary_DT): When calling Expand_Interface_Thunk() pass it the primitive, instead of its Ultimate_Alias; required to allow the called routine to identify renamings of the predefined equality operation. gcc/testsuite/ * gnat.dg/equal5.adb, gnat.dg/equal5.ads: New testcase. From-SVN: r266130
Diffstat (limited to 'gcc')
-rw-r--r--gcc/ada/ChangeLog9
-rw-r--r--gcc/ada/exp_disp.adb19
-rw-r--r--gcc/testsuite/ChangeLog4
-rw-r--r--gcc/testsuite/gnat.dg/equal5.adb13
-rw-r--r--gcc/testsuite/gnat.dg/equal5.ads31
5 files changed, 67 insertions, 9 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 900d23a..7390a5c 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2018-11-14 Javier Miranda <miranda@adacore.com>
+
+ * exp_disp.adb (Expand_Interface_Thunk): Extend handling of
+ renamings of the predefined equality primitive.
+ (Make_Secondary_DT): When calling Expand_Interface_Thunk() pass
+ it the primitive, instead of its Ultimate_Alias; required to
+ allow the called routine to identify renamings of the predefined
+ equality operation.
+
2018-11-14 Hristian Kirtchev <kirtchev@adacore.com>
* freeze.adb (Check_Pragma_Thread_Local_Storage): New routine. A
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index f36cd1f..5a91249 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -1828,6 +1828,9 @@ package body Exp_Disp is
Formal : Node_Id;
Ftyp : Entity_Id;
Iface_Formal : Node_Id := Empty; -- initialize to prevent warning
+ Is_Predef_Op : constant Boolean :=
+ Is_Predefined_Dispatching_Operation (Prim)
+ or else Is_Predefined_Dispatching_Operation (Target);
New_Arg : Node_Id;
Offset_To_Top : Node_Id;
Target_Formal : Entity_Id;
@@ -1838,7 +1841,7 @@ package body Exp_Disp is
-- No thunk needed if the primitive has been eliminated
- if Is_Eliminated (Ultimate_Alias (Prim)) then
+ if Is_Eliminated (Target) then
return;
-- In case of primitives that are functions without formals and a
@@ -1859,9 +1862,10 @@ package body Exp_Disp is
-- actual object) generate code that modify its contents.
-- Note: This special management is not done for predefined primitives
- -- because???
+ -- because they don't have available the Interface_Alias attribute (see
+ -- Sem_Ch3.Add_Internal_Interface_Entities).
- if not Is_Predefined_Dispatching_Operation (Prim) then
+ if not Is_Predef_Op then
Iface_Formal := First_Formal (Interface_Alias (Prim));
end if;
@@ -1872,9 +1876,7 @@ package body Exp_Disp is
-- Use the interface type as the type of the controlling formal (see
-- comment above).
- if not Is_Controlling_Formal (Formal)
- or else Is_Predefined_Dispatching_Operation (Prim)
- then
+ if not Is_Controlling_Formal (Formal) or else Is_Predef_Op then
Ftyp := Etype (Formal);
Expr := New_Copy_Tree (Expression (Parent (Formal)));
else
@@ -1892,7 +1894,7 @@ package body Exp_Disp is
Parameter_Type => New_Occurrence_Of (Ftyp, Loc),
Expression => Expr));
- if not Is_Predefined_Dispatching_Operation (Prim) then
+ if not Is_Predef_Op then
Next_Formal (Iface_Formal);
end if;
@@ -4061,8 +4063,7 @@ package body Exp_Disp is
Alias (Prim);
else
- Expand_Interface_Thunk
- (Ultimate_Alias (Prim), Thunk_Id, Thunk_Code);
+ Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
if Present (Thunk_Id) then
Append_To (Result, Thunk_Code);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 00ad237..1a5888b 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-11-14 Javier Miranda <miranda@adacore.com>
+
+ * gnat.dg/equal5.adb, gnat.dg/equal5.ads: New testcase.
+
2018-11-14 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/compile_time_error1.adb,
diff --git a/gcc/testsuite/gnat.dg/equal5.adb b/gcc/testsuite/gnat.dg/equal5.adb
new file mode 100644
index 0000000..d98cff8
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/equal5.adb
@@ -0,0 +1,13 @@
+-- { dg-do compile }
+
+package body Equal5 is
+ function "="
+ (Left : Eq_Parent;
+ Right : Eq_Parent) return Boolean is (True);
+
+ procedure Op (Obj : Child_6) is null;
+
+ function Equals
+ (Left : Child_6;
+ Right : Child_6) return Boolean is (True);
+end Equal5;
diff --git a/gcc/testsuite/gnat.dg/equal5.ads b/gcc/testsuite/gnat.dg/equal5.ads
new file mode 100644
index 0000000..0bf3be0
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/equal5.ads
@@ -0,0 +1,31 @@
+package Equal5 is
+ type Eq_Parent is tagged null record;
+
+ function "="
+ (Left : Eq_Parent;
+ Right : Eq_Parent) return Boolean;
+
+ type Eq_Iface is interface;
+
+ function "="
+ (Left : Eq_Iface;
+ Right : Eq_Iface) return Boolean is abstract;
+ procedure Op (Obj : Eq_Iface) is abstract;
+
+ -----------------
+ -- Derivations --
+ -----------------
+
+ type Child_6 is new Eq_Parent and Eq_Iface with null record;
+
+ procedure Op (Obj : Child_6);
+
+ function Equals
+ (Left : Child_6;
+ Right : Child_6) return Boolean;
+
+ function "="
+ (Left : Child_6;
+ Right : Child_6) return Boolean renames Equals; -- Test
+
+end Equal5;