This is the second go at this patch, and now with a testcase!
In summary:
If the type is derived in the current compilation unit, and Allocate is not
overridden on derivation (as is typically the case with
Root_Storage_Pool_With_Subpools), the entity for Allocate for the derived
type is then an alias to System.Storage_Pools.Subpools.Allocate. When the
allocator is built, gnat_to_gnu_entity is called with definition == false
for the derived storage pool's allocate operation. An assertion is
gnat_to_gnu_entity fails in this case, since it is not a definition, and
Is_Public is false (since the entity is nested in the same compilation
unit).
This patch adds an extra check in the assertion (decl.c: gnat_to_gnu_entity)
that the entity has the Aliased property, and that the Alias is also Public.
Added a regression test for the declaration and allocation from a
Root_Pool_With_Subpools type derrived within the same compilation unit (a
package nested in a subprogram in this testcase).
diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index 871a309ab7d..ae49c2625f8 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -447,6 +447,17 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree
gnu_expr, bool definition)
/* If we get here, it means we have not yet done anything with this
entity.
If we are not defining it, it must be a type or an entity that is
defined
elsewhere or externally, otherwise we should have defined it already.
*/
+
+ /* One exception relates to an entity, typically an inherited operation,
+ which has an alias pointing to the parent's operation. Often such an
+ aliased entity will also carry with it the Is_Public property if it
was
+ declared in a separate compilation unit, but when a type is extended
+ within the current unit, the aliased entity will not pass this
+ assertion. It is neither defined (since it is an inherited operation,
+ and is not Public, since it is within the current compilation unit.
+
+ For this case we look for an Alias that is also Public */
+
gcc_assert (definition
|| is_type
|| kind == E_Discriminant
@@ -454,6 +465,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree
gnu_expr, bool definition)
|| kind == E_Label
|| (kind == E_Constant && Present (Full_View (gnat_entity)))
|| Is_Public (gnat_entity)
+ || (Present (Alias (gnat_entity)) && Is_Public (Alias
(gnat_entity)))
|| type_annotate_only);
/* Get the name of the entity and set up the line number and filename of
diff --git a/gcc/testsuite/gnat.dg/subpools1.adb
b/gcc/testsuite/gnat.dg/subpools1.adb
new file mode 100644
index 00000000000..87b9e53baca
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/subpools1.adb
@@ -0,0 +1,99 @@
+-- { dg-do compile }
+
+with System.Storage_Elements;
+with System.Storage_Pools.Subpools;
+
+procedure Subpools1 is
+
+ use System.Storage_Pools.Subpools;
+
+ package Local_Pools is
+
+ use System.Storage_Elements;
+
+ subtype Address is System.Address;
+ use type Address;
+
+ type Local_Pool is new Root_Storage_Pool_With_Subpools
+ with null record;
+
+ overriding
+ function Create_Subpool (Pool: in out Local_Pool)
+ return not null Subpool_Handle;
+
+ overriding
+ procedure Allocate_From_Subpool
+ (Pool : in out Local_Pool;
+ Storage_Address : out Address;
+ Size_In_Storage_Elements: in Storage_Count;
+ Alignment : in Storage_Count;
+ Subpool : in not null Subpool_Handle);
+
+ overriding
+ procedure Deallocate_Subpool
+ (Pool : in out Local_Pool;
+ Subpool: in out Subpool_Handle) is null;
+
+ overriding
+ function Default_Subpool_For_Pool (Pool: in out Local_Pool)
+ return not null Subpool_Handle;
+
+ end Local_Pools;
+
+ package body Local_Pools is
+
+ type Local_Subpool is new Root_Subpool with null record;
+
+ Dummy_Subpool: aliased Local_Subpool;
+
+ overriding
+ function Create_Subpool (Pool: in out Local_Pool)
+ return not null Subpool_Handle
+ is
+ begin
+ return Result: not null Subpool_Handle
+ := Dummy_Subpool'Unchecked_Access
+ do
+ Set_Pool_Of_Subpool (Result, Pool);
+ end return;
+ end Create_Subpool;
+
+
+ overriding
+ procedure Allocate_From_Subpool
+ (Pool : in out Local_Pool;
+ Storage_Address : out Address;
+ Size_In_Storage_Elements: in Storage_Count;
+ Alignment : in Storage_Count;
+ Subpool : in not null Subpool_Handle)
+ is
+ type Storage_Array_Access is access Storage_Array;
+
+ New_Alloc: Storage_Array_Access
+ := new Storage_Array (1 .. Size_In_Storage_Elements +
Alignment);
+ begin
+ for SE of New_Alloc.all loop
+ Storage_Address := SE'Address;
+ exit when Storage_Address mod Alignment = 0;
+ end loop;
+ end Allocate_From_Subpool;
+
+ overriding
+ function Default_Subpool_For_Pool (Pool: in out Local_Pool)
+ return not null Subpool_Handle
+ is (Dummy_Subpool'Unchecked_Access);
+
+ end Local_Pools;
+
+
+ A_Pool: Local_Pools.Local_Pool;
+ A_Subpool: Subpool_Handle := A_Pool.Create_Subpool;
+
+ type Integer_Access is access Integer with
+ Storage_Pool => A_Pool;
+
+ X: Integer_Access := new Integer;
+
+begin
+ null;
+end Subpools1;
Bootstrapped and tested from trunk on x86_64-unknown-freebsd12.1.
Cheers,
Richard Wai
ANNEXI-STRAYLINE
> -----Original Message-----
> From: Eric Botcazou <ebotca...@adacore.com>
> Sent: March 7, 2020 5:48 AM
> To: Richard Wai <rich...@annexi-strayline.com>
> Cc: gcc-patches@gcc.gnu.org
> Subject: Re: [PATCH] Ada: gcc-interface: fixed assertion for aliased
entities
>
> > Please excuse my ignorance as this is my first (and hopefully not
> > last) patch submission.. But I don't see any testcases in the Ada
> > testsuite except for the (outdated) ACATS tests, which doesn't cover
> > this assertion. So I'm honestly not sure how I should go about that..
>
> See testsuite/gnat.dg, there are around 3000 regressions tests.
>
> > Shall I add the Is_Public check to the Alias and resubmit the patch?
>
> Yes, please, but it can only be approved with an associated testcase.
>
> --
> Eric Botcazou
