From: Javier Miranda Date: Mon, 11 Jun 2018 09:17:29 +0000 (+0000) Subject: [Ada] Wrong code in array aggregates of Ada coextensions X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=7ffe26fcf5c0ee0b4a6b3878859941fb534c9400;p=gcc.git [Ada] Wrong code in array aggregates of Ada coextensions 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. 2018-06-11 Javier Miranda 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. From-SVN: r261406 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 401c5d27f92..1946e548017 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2018-06-11 Javier Miranda + + * 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). + 2018-06-11 Ed Schonberg * exp_unst.adb (Search_Subprograms): Handle explicitly stubs at the top diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 3902d6eb806..69934f018ca 100644 --- a/gcc/ada/sem_util.adb +++ b/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; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index acb32155f20..45f2867cce7 100644 --- a/gcc/ada/sinfo.adb +++ b/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; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 22d71955d7e..c6e04e7920a 100644 --- a/gcc/ada/sinfo.ads +++ b/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 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 6d5e9644f99..0b16f0ccac4 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2018-06-11 Javier Miranda + + * gnat.dg/aggr23.adb, gnat.dg/aggr23_q.adb, gnat.dg/aggr23_tt.ads: New + testcase. + 2018-06-11 Ed Schonberg * gnat.dg/inline_always1.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/aggr23.adb b/gcc/testsuite/gnat.dg/aggr23.adb new file mode 100644 index 00000000000..a75396f7b15 --- /dev/null +++ b/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; diff --git a/gcc/testsuite/gnat.dg/aggr23_q.adb b/gcc/testsuite/gnat.dg/aggr23_q.adb new file mode 100644 index 00000000000..5ab8883225a --- /dev/null +++ b/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; diff --git a/gcc/testsuite/gnat.dg/aggr23_tt.ads b/gcc/testsuite/gnat.dg/aggr23_tt.ads new file mode 100644 index 00000000000..42ee8536b69 --- /dev/null +++ b/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;