From: Eric Botcazou <[email protected]>
The problem stems from an internal confusion as to whether such a type has
a dispatch table. The answer is no and the fix is to additionally prevent
the associated class-wide type from being built.
gcc/ada/ChangeLog:
* exp_ch3.adb (Expand_Freeze_Record_Type): Minor cleanup.
* sem_ch3.adb (Build_Derived_Private_Type.Copy_And_Build): Set the
Is_Implicit_Full_View flag early in the case of a record type.
(Build_Derived_Record_Type): Do not build the class-wide type for
an implicit full view.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch3.adb | 13 +++++--------
gcc/ada/sem_ch3.adb | 19 ++++++++++++-------
2 files changed, 17 insertions(+), 15 deletions(-)
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 2f799b0a169..ed3061cc71a 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6548,22 +6548,19 @@ package body Exp_Ch3 is
Set_Is_Frozen (Typ);
- if not Is_Derived_Type (Typ)
- or else Is_Tagged_Type (Etype (Typ))
- then
- Set_All_DT_Position (Typ);
-
- -- If this is a type derived from an untagged private type whose
+ -- If the type is derived from an untagged private type whose
-- full view is tagged, the type is marked tagged for layout
-- reasons, but it has no dispatch table.
- elsif Is_Derived_Type (Typ)
- and then Is_Private_Type (Etype (Typ))
+ if Is_Derived_Type (Typ)
and then not Is_Tagged_Type (Etype (Typ))
then
+ pragma Assert (Is_Private_Type (Etype (Typ)));
return;
end if;
+ Set_All_DT_Position (Typ);
+
-- Create and decorate the tags. Suppress their creation when
-- not Tagged_Type_Expansion because the dispatching mechanism is
-- handled internally by the virtual target.
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index ffd42201e86..47556e147f2 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -8421,13 +8421,15 @@ package body Sem_Ch3 is
and then not Is_Generic_Type (Root_Type (Full_Parent)))
then
-- Copy and adjust declaration to provide a completion for what
- -- is originally a private declaration. Indicate that full view
- -- is internally generated.
+ -- is originally a private declaration. Indicate that the full
+ -- view is internally generated, and set Is_Implicit_Full_View
+ -- now for the sake of Build_Derived_Record_Type.
Set_Comes_From_Source (Full_N, False);
Set_Comes_From_Source (Full_Der, False);
Set_Parent (Full_Der, Full_N);
Set_Defining_Identifier (Full_N, Full_Der);
+ Set_Is_Implicit_Full_View (Full_Der);
-- If there are no constraints, adjust the subtype mark
@@ -10188,10 +10190,12 @@ package body Sem_Ch3 is
-- Set fields for tagged types
if Is_Tagged then
- -- Minor optimization: there is no need to generate the class-wide
- -- entity associated with an underlying record view.
+ -- Small optimization: there is no need to generate the class-wide
+ -- entity for either an implicit full or an underlying record view.
- if not Is_Underlying_Record_View (Derived_Type) then
+ if not Is_Implicit_Full_View (Derived_Type)
+ and then not Is_Underlying_Record_View (Derived_Type)
+ then
Make_Class_Wide_Type (Derived_Type);
end if;
@@ -10423,10 +10427,11 @@ package body Sem_Ch3 is
end if;
-- Update the class-wide type, which shares the now-completed entity
- -- list with its specific type. In case of underlying record views,
- -- we do not generate the corresponding class wide entity.
+ -- list with its specific type. But in the cases of implicit full or
+ -- underlying record views, we do not generate the class-wide type.
if Is_Tagged
+ and then not Is_Implicit_Full_View (Derived_Type)
and then not Is_Underlying_Record_View (Derived_Type)
then
Set_First_Entity
--
2.53.0
