The compiler generates wrong code when an array aggregate with an others choice
whose expression has nested object allocations (ie. others => new R (new S)) is
used to initialize an array of access to discriminated types whose discriminant
is an access type.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-06-11 Javier Miranda <mira...@adacore.com>
gcc/ada/
* sinfo.ads (Is_Dynamic_Coextension): Adding documentation.
(Is_Static_Coextension): Adding documentation.
* sinfo.adb (Is_Dynamic_Coextension): Extending the assertion.
(Is_Static_Coextension): Extending the assertion.
* sem_util.adb (Mark_Allocator): Clear Is_Static_Coextension when
setting flag Is_Dynamic_Coextension (and vice versa).
gcc/testsuite/
* gnat.dg/aggr23.adb, gnat.dg/aggr23_q.adb, gnat.dg/aggr23_tt.ads: New
testcase.
--- gcc/ada/sem_util.adb
+++ gcc/ada/sem_util.adb
@@ -18472,6 +18472,7 @@ package body Sem_Util is
begin
if Nkind (N) = N_Allocator then
if Is_Dynamic then
+ Set_Is_Static_Coextension (N, False);
Set_Is_Dynamic_Coextension (N);
-- If the allocator expression is potentially dynamic, it may
@@ -18482,8 +18483,10 @@ package body Sem_Util is
elsif Nkind (Expression (N)) = N_Qualified_Expression
and then Nkind (Expression (Expression (N))) = N_Op_Concat
then
+ Set_Is_Static_Coextension (N, False);
Set_Is_Dynamic_Coextension (N);
else
+ Set_Is_Dynamic_Coextension (N, False);
Set_Is_Static_Coextension (N);
end if;
end if;
--- gcc/ada/sinfo.adb
+++ gcc/ada/sinfo.adb
@@ -5350,6 +5350,8 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Allocator);
+ pragma Assert (not Val
+ or else not Is_Static_Coextension (N));
Set_Flag18 (N, Val);
end Set_Is_Dynamic_Coextension;
@@ -5613,6 +5615,8 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Allocator);
+ pragma Assert (not Val
+ or else not Is_Dynamic_Coextension (N));
Set_Flag14 (N, Val);
end Set_Is_Static_Coextension;
--- gcc/ada/sinfo.ads
+++ gcc/ada/sinfo.ads
@@ -1738,7 +1738,8 @@ package Sinfo is
-- Present in allocator nodes, to indicate that this is an allocator
-- for an access discriminant of a dynamically allocated object. The
-- coextension must be deallocated and finalized at the same time as
- -- the enclosing object.
+ -- the enclosing object. The partner flag Is_Static_Coextension must
+ -- be cleared before setting this flag to True.
-- Is_Effective_Use_Clause (Flag1-Sem)
-- Present in both N_Use_Type_Clause and N_Use_Package_Clause to indicate
@@ -1949,7 +1950,9 @@ package Sinfo is
-- Is_Static_Coextension (Flag14-Sem)
-- Present in N_Allocator nodes. Set if the allocator is a coextension
- -- of an object allocated on the stack rather than the heap.
+ -- of an object allocated on the stack rather than the heap. The partner
+ -- flag Is_Dynamic_Coextension must be cleared before setting this flag
+ -- to True.
-- Is_Static_Expression (Flag6-Sem)
-- Indicates that an expression is a static expression according to the
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/aggr23.adb
@@ -0,0 +1,9 @@
+-- { dg-options "-gnatws" }
+-- { dg-do run }
+
+with Aggr23_Q;
+
+procedure Aggr23 is
+begin
+ Aggr23_Q (2);
+end;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/aggr23_q.adb
@@ -0,0 +1,14 @@
+-- { dg-options "-gnatws" }
+
+with Ada.Text_IO; use Ada.Text_IO;
+
+with Aggr23_TT; use Aggr23_TT;
+
+procedure Aggr23_Q (Count : Natural) is
+ Ts : array (1 .. Count) of TA
+ := (others => new T (new Integer)); -- Test
+begin
+ if Ts (1).D = Ts (2).D then
+ Put ("ERROR");
+ end if;
+end;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/aggr23_tt.ads
@@ -0,0 +1,4 @@
+package Aggr23_TT is
+ type T (D : not null access Integer) is null record;
+ type TA is access T;
+end;