From a5aac267e64c578d55e6e269fa9e331f0d01da98 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Wed, 11 Mar 2020 10:47:34 +0100 Subject: [PATCH] Fix internal error on locally-defined subpools 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 of the derived type is an alias for System.Storage_Pools.Subpools.Allocate. The main assertion in gnat_to_gnu_entity fails in this case, since this is not a definition and Is_Public is false (since the entity is nested in the same compilation unit). 2020-03-11 Richard Wai * gcc-interface/decl.c (gnat_to_gnu_entity): Also test Is_Public on the Alias of the entitiy, if is present, in the main assertion. --- gcc/ada/ChangeLog | 5 ++ gcc/ada/gcc-interface/decl.c | 9 +++- gcc/testsuite/ChangeLog | 4 ++ gcc/testsuite/gnat.dg/subpools1.adb | 82 +++++++++++++++++++++++++++++ 4 files changed, 99 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gnat.dg/subpools1.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 64b2572d0b3..9df3840a411 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,8 @@ +2020-03-11 Richard Wai + + * gcc-interface/decl.c (gnat_to_gnu_entity): Also test Is_Public on + the Alias of the entitiy, if is present, in the main assertion. + 2020-02-06 Alexandre Oliva * raise-gcc.c (personality_body) [__ARM_EABI_UNWINDER__]: diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 871a309ab7d..80dfc55b601 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -446,7 +446,12 @@ 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. */ + elsewhere or externally, otherwise we should have defined it already. + + One exception is for an entity, typically an inherited operation, which is + a local alias for the parent's operation. It is neither defined, since it + is an inherited operation, nor public, since it is declared in the current + compilation unit, so we test Is_Public on the Alias entity instead. */ gcc_assert (definition || is_type || kind == E_Discriminant @@ -454,6 +459,8 @@ 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/ChangeLog b/gcc/testsuite/ChangeLog index af94cb47ae6..f43da846ec1 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2020-03-11 Richard Wai + + * gnat.dg/subpools1.adb: New test. + 2020-03-11 Jakub Jelinek PR target/94121 diff --git a/gcc/testsuite/gnat.dg/subpools1.adb b/gcc/testsuite/gnat.dg/subpools1.adb new file mode 100644 index 00000000000..b38a4ca232e --- /dev/null +++ b/gcc/testsuite/gnat.dg/subpools1.adb @@ -0,0 +1,82 @@ +-- { 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; + + 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 System.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; + + 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; + + overriding + procedure Allocate_From_Subpool + (Pool : in out Local_Pool; + Storage_Address : out System.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; + + end Local_Pools; + + A_Pool: Local_Pools.Local_Pool; + + type Integer_Access is access Integer with Storage_Pool => A_Pool; + + X: Integer_Access := new Integer; + +begin + null; +end; -- 2.30.2