https://gcc.gnu.org/g:b62377964795f9836b6a33505d588a3d898f8a63
commit r17-1962-gb62377964795f9836b6a33505d588a3d898f8a63 Author: Eric Botcazou <[email protected]> Date: Tue Jun 16 08:59:59 2026 +0200 ada: Fix internal error on type derived from untagged controlled private type 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. Diff: --- 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 2f799b0a169f..ed3061cc71af 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 ffd42201e863..47556e147f26 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
