diff options
Diffstat (limited to 'gcc/ada/sem_ch3.adb')
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 1281 |
1 files changed, 787 insertions, 494 deletions
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 4c7b8e7..e9b4456 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,63 +23,67 @@ -- -- ------------------------------------------------------------------------------ -with Aspects; use Aspects; -with Atree; use Atree; -with Checks; use Checks; -with Contracts; use Contracts; -with Debug; use Debug; -with Elists; use Elists; -with Einfo; use Einfo; -with Errout; use Errout; -with Eval_Fat; use Eval_Fat; -with Exp_Ch3; use Exp_Ch3; -with Exp_Ch9; use Exp_Ch9; -with Exp_Disp; use Exp_Disp; -with Exp_Dist; use Exp_Dist; -with Exp_Tss; use Exp_Tss; -with Exp_Util; use Exp_Util; -with Freeze; use Freeze; -with Ghost; use Ghost; -with Itypes; use Itypes; -with Layout; use Layout; -with Lib; use Lib; -with Lib.Xref; use Lib.Xref; -with Namet; use Namet; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Opt; use Opt; -with Restrict; use Restrict; -with Rident; use Rident; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Case; use Sem_Case; -with Sem_Cat; use Sem_Cat; -with Sem_Ch6; use Sem_Ch6; -with Sem_Ch7; use Sem_Ch7; -with Sem_Ch8; use Sem_Ch8; -with Sem_Ch13; use Sem_Ch13; -with Sem_Dim; use Sem_Dim; -with Sem_Disp; use Sem_Disp; -with Sem_Dist; use Sem_Dist; -with Sem_Elab; use Sem_Elab; -with Sem_Elim; use Sem_Elim; -with Sem_Eval; use Sem_Eval; -with Sem_Mech; use Sem_Mech; -with Sem_Res; use Sem_Res; -with Sem_Smem; use Sem_Smem; -with Sem_Type; use Sem_Type; -with Sem_Util; use Sem_Util; -with Sem_Warn; use Sem_Warn; -with Stand; use Stand; -with Sinfo; use Sinfo; -with Sinput; use Sinput; -with Snames; use Snames; -with Targparm; use Targparm; -with Tbuild; use Tbuild; -with Ttypes; use Ttypes; -with Uintp; use Uintp; -with Urealp; use Urealp; +with Aspects; use Aspects; +with Atree; use Atree; +with Checks; use Checks; +with Contracts; use Contracts; +with Debug; use Debug; +with Elists; use Elists; +with Einfo; use Einfo; +with Einfo.Entities; use Einfo.Entities; +with Einfo.Utils; use Einfo.Utils; +with Errout; use Errout; +with Eval_Fat; use Eval_Fat; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch9; use Exp_Ch9; +with Exp_Disp; use Exp_Disp; +with Exp_Dist; use Exp_Dist; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Ghost; use Ghost; +with Itypes; use Itypes; +with Layout; use Layout; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Case; use Sem_Case; +with Sem_Cat; use Sem_Cat; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; +with Sem_Dim; use Sem_Dim; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Elab; use Sem_Elab; +with Sem_Elim; use Sem_Elim; +with Sem_Eval; use Sem_Eval; +with Sem_Mech; use Sem_Mech; +with Sem_Res; use Sem_Res; +with Sem_Smem; use Sem_Smem; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinfo.Nodes; use Sinfo.Nodes; +with Sinfo.Utils; use Sinfo.Utils; +with Sinput; use Sinput; +with Snames; use Snames; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uintp; use Uintp; +with Urealp; use Urealp; package body Sem_Ch3 is @@ -245,11 +249,12 @@ package body Sem_Ch3 is -- belongs must be a concurrent type or a descendant of a type with -- the reserved word 'limited' in its declaration. - procedure Check_Anonymous_Access_Components - (Typ_Decl : Node_Id; - Typ : Entity_Id; - Prev : Entity_Id; - Comp_List : Node_Id); + procedure Check_Anonymous_Access_Component + (Typ_Decl : Node_Id; + Typ : Entity_Id; + Prev : Entity_Id; + Comp_Def : Node_Id; + Access_Def : Node_Id); -- Ada 2005 AI-382: an access component in a record definition can refer to -- the enclosing record, in which case it denotes the type itself, and not -- the current instance of the type. We create an anonymous access type for @@ -259,6 +264,13 @@ package body Sem_Ch3 is -- circularity issues in Gigi. We create an incomplete type for the record -- declaration, which is the designated type of the anonymous access. + procedure Check_Anonymous_Access_Components + (Typ_Decl : Node_Id; + Typ : Entity_Id; + Prev : Entity_Id; + Comp_List : Node_Id); + -- Call Check_Anonymous_Access_Component on Comp_List + procedure Check_Constraining_Discriminant (New_Disc, Old_Disc : Entity_Id); -- Check that, if a new discriminant is used in a constraint defining the -- parent subtype of a derivation, its subtype is statically compatible @@ -840,22 +852,15 @@ package body Sem_Ch3 is -- the corresponding semantic routine if Present (Access_To_Subprogram_Definition (N)) then - - -- Compiler runtime units are compiled in Ada 2005 mode when building - -- the runtime library but must also be compilable in Ada 95 mode - -- (when bootstrapping the compiler). - - Check_Compiler_Unit ("anonymous access to subprogram", N); - Access_Subprogram_Declaration (T_Name => Anon_Type, T_Def => Access_To_Subprogram_Definition (N)); if Ekind (Anon_Type) = E_Access_Protected_Subprogram_Type then - Set_Ekind + Mutate_Ekind (Anon_Type, E_Anonymous_Access_Protected_Subprogram_Type); else - Set_Ekind (Anon_Type, E_Anonymous_Access_Subprogram_Type); + Mutate_Ekind (Anon_Type, E_Anonymous_Access_Subprogram_Type); end if; Set_Can_Use_Internal_Rep @@ -1285,10 +1290,10 @@ package body Sem_Ch3 is Check_Delayed_Subprogram (Desig_Type); if Protected_Present (T_Def) then - Set_Ekind (T_Name, E_Access_Protected_Subprogram_Type); + Mutate_Ekind (T_Name, E_Access_Protected_Subprogram_Type); Set_Convention (Desig_Type, Convention_Protected); else - Set_Ekind (T_Name, E_Access_Subprogram_Type); + Mutate_Ekind (T_Name, E_Access_Subprogram_Type); end if; Set_Can_Use_Internal_Rep (T_Name, @@ -1312,6 +1317,8 @@ package body Sem_Ch3 is Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def)); Check_Restriction (No_Access_Subprograms, T_Def); + + Create_Extra_Formals (Desig_Type); end Access_Subprogram_Declaration; ---------------------------- @@ -1319,22 +1326,48 @@ package body Sem_Ch3 is ---------------------------- procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is + + procedure Setup_Access_Type (Desig_Typ : Entity_Id); + -- After type declaration is analysed with T being an incomplete type, + -- this routine will mutate the kind of T to the appropriate access type + -- and set its directly designated type to Desig_Typ. + + ----------------------- + -- Setup_Access_Type -- + ----------------------- + + procedure Setup_Access_Type (Desig_Typ : Entity_Id) is + begin + if All_Present (Def) or else Constant_Present (Def) then + Mutate_Ekind (T, E_General_Access_Type); + else + Mutate_Ekind (T, E_Access_Type); + end if; + + Set_Directly_Designated_Type (T, Desig_Typ); + end Setup_Access_Type; + + -- Local variables + P : constant Node_Id := Parent (Def); S : constant Node_Id := Subtype_Indication (Def); Full_Desig : Entity_Id; + -- Start of processing for Access_Type_Declaration + begin -- Check for permissible use of incomplete type if Nkind (S) /= N_Subtype_Indication then + Analyze (S); if Nkind (S) in N_Has_Entity and then Present (Entity (S)) and then Ekind (Root_Type (Entity (S))) = E_Incomplete_Type then - Set_Directly_Designated_Type (T, Entity (S)); + Setup_Access_Type (Desig_Typ => Entity (S)); -- If the designated type is a limited view, we cannot tell if -- the full view contains tasks, and there is no way to handle @@ -1345,13 +1378,12 @@ package body Sem_Ch3 is if From_Limited_With (Entity (S)) and then not Is_Class_Wide_Type (Entity (S)) then - Set_Ekind (T, E_Access_Type); Build_Master_Entity (T); Build_Master_Renaming (T); end if; else - Set_Directly_Designated_Type (T, Process_Subtype (S, P, T, 'P')); + Setup_Access_Type (Desig_Typ => Process_Subtype (S, P, T, 'P')); end if; -- If the access definition is of the form: ACCESS NOT NULL .. @@ -1383,55 +1415,50 @@ package body Sem_Ch3 is end if; else - Set_Directly_Designated_Type (T, - Process_Subtype (S, P, T, 'P')); + Setup_Access_Type (Desig_Typ => Process_Subtype (S, P, T, 'P')); end if; - if All_Present (Def) or Constant_Present (Def) then - Set_Ekind (T, E_General_Access_Type); - else - Set_Ekind (T, E_Access_Type); - end if; + if not Error_Posted (T) then + Full_Desig := Designated_Type (T); - Full_Desig := Designated_Type (T); + if Base_Type (Full_Desig) = T then + Error_Msg_N ("access type cannot designate itself", S); - if Base_Type (Full_Desig) = T then - Error_Msg_N ("access type cannot designate itself", S); + -- In Ada 2005, the type may have a limited view through some unit in + -- its own context, allowing the following circularity that cannot be + -- detected earlier. - -- In Ada 2005, the type may have a limited view through some unit in - -- its own context, allowing the following circularity that cannot be - -- detected earlier. + elsif Is_Class_Wide_Type (Full_Desig) and then Etype (Full_Desig) = T + then + Error_Msg_N + ("access type cannot designate its own class-wide type", S); - elsif Is_Class_Wide_Type (Full_Desig) and then Etype (Full_Desig) = T - then - Error_Msg_N - ("access type cannot designate its own class-wide type", S); + -- Clean up indication of tagged status to prevent cascaded errors - -- Clean up indication of tagged status to prevent cascaded errors + Set_Is_Tagged_Type (T, False); + end if; - Set_Is_Tagged_Type (T, False); - end if; + Set_Etype (T, T); - Set_Etype (T, T); + -- For SPARK, check that the designated type is compatible with + -- respect to volatility with the access type. - -- For SPARK, check that the designated type is compatible with - -- respect to volatility with the access type. - - if SPARK_Mode /= Off - and then Comes_From_Source (T) - then - -- ??? UNIMPLEMENTED - -- In the case where the designated type is incomplete at this point, - -- performing this check here is harmless but the check will need to - -- be repeated when the designated type is complete. + if SPARK_Mode /= Off + and then Comes_From_Source (T) + then + -- ??? UNIMPLEMENTED + -- In the case where the designated type is incomplete at this + -- point, performing this check here is harmless but the check + -- will need to be repeated when the designated type is complete. - -- The preceding call to Comes_From_Source is needed because the - -- FE sometimes introduces implicitly declared access types. See, - -- for example, the expansion of nested_po.ads in OA28-015. + -- The preceding call to Comes_From_Source is needed because the + -- FE sometimes introduces implicitly declared access types. See, + -- for example, the expansion of nested_po.ads in OA28-015. - Check_Volatility_Compatibility - (Full_Desig, T, "designated type", "access type", - Srcpos_Bearer => T); + Check_Volatility_Compatibility + (Full_Desig, T, "designated type", "access type", + Srcpos_Bearer => T); + end if; end if; -- If the type has appeared already in a with_type clause, it is frozen @@ -1519,7 +1546,7 @@ package body Sem_Ch3 is Analyze_Component_Declaration (Decl); Set_Analyzed (Decl); - Set_Ekind (Tag, E_Component); + Mutate_Ekind (Tag, E_Component); Set_Is_Tag (Tag); Set_Is_Aliased (Tag); Set_Is_Independent (Tag); @@ -1560,7 +1587,7 @@ package body Sem_Ch3 is Analyze_Component_Declaration (Decl); Set_Analyzed (Decl); - Set_Ekind (Offset, E_Component); + Mutate_Ekind (Offset, E_Component); Set_Is_Aliased (Offset); Set_Is_Independent (Offset); Set_Related_Type (Offset, Iface); @@ -1580,9 +1607,8 @@ package body Sem_Ch3 is begin if not RTE_Available (RE_Interface_Tag) then - Error_Msg - ("(Ada 2005) interface types not supported by this run-time!", - Sloc (N)); + Error_Msg_N + ("(Ada 2005) interface types not supported by this run-time!", N); return; end if; @@ -1775,7 +1801,7 @@ package body Sem_Ch3 is elsif not Comes_From_Source (Prim) then Error_Msg_NE ("&inherits non-conforming preconditions and must " - & "be overridden (RM 6.1.1 (10-16)", + & "be overridden (RM 6.1.1 (10-16))", Parent (Tagged_Type), Prim); end if; end if; @@ -2057,21 +2083,10 @@ package body Sem_Ch3 is end if; end if; - -- Avoid reporting spurious errors if the component is initialized with - -- a raise expression (which is legal in any expression context) - - if Present (E) - and then - (Nkind (E) = N_Raise_Expression - or else (Nkind (E) = N_Qualified_Expression - and then Nkind (Expression (E)) = N_Raise_Expression)) - then - null; - -- The parent type may be a private view with unknown discriminants, -- and thus unconstrained. Regular components must be constrained. - elsif not Is_Definite_Subtype (T) + if not Is_Definite_Subtype (T) and then Chars (Id) /= Name_uParent then if Is_Class_Wide_Type (T) then @@ -2743,7 +2758,6 @@ package body Sem_Ch3 is Resolve_Aspects; elsif L /= Visible_Declarations (Parent (L)) - or else No (Private_Declarations (Parent (L))) or else Is_Empty_List (Private_Declarations (Parent (L))) then Adjust_Decl; @@ -2812,7 +2826,7 @@ package body Sem_Ch3 is -- to the first encountered body. -- ??? A cleaner approach may be possible and/or this solution - -- could be extended to general-purpose late primitives, TBD. + -- could be extended to general-purpose late primitives. if Present (Ctrl_Typ) then @@ -3040,7 +3054,7 @@ package body Sem_Ch3 is end if; end if; - -- TBD : other nonoverridable aspects. + -- What about other nonoverridable aspects??? end Check_Nonoverridable_Aspects; ------------------------------------ @@ -3057,6 +3071,7 @@ package body Sem_Ch3 is and then Ekind (Prev) = E_Incomplete_Type and then Is_Tagged_Type (Prev) and then Is_Tagged_Type (T) + and then Present (Primitive_Operations (Prev)) then Elmt := First_Elmt (Primitive_Operations (Prev)); while Present (Elmt) loop @@ -3169,7 +3184,7 @@ package body Sem_Ch3 is -- so that pre/postconditions can be handled directly on the -- generated wrapper. - if Ada_Version >= Ada_2020 + if Ada_Version >= Ada_2022 and then Present (Aspect_Specifications (N)) then Build_Access_Subprogram_Wrapper (N); @@ -3246,6 +3261,40 @@ package body Sem_Ch3 is return; end if; + -- Set the primitives list of the full type and its base type when + -- needed. T may be E_Void in cases of earlier errors, and in that + -- case we bypass this. + + if Ekind (T) /= E_Void + and then not Present (Direct_Primitive_Operations (T)) + then + if Etype (T) = T then + Set_Direct_Primitive_Operations (T, New_Elmt_List); + + -- If Etype of T is the base type (as opposed to a parent type) and + -- already has an associated list of primitive operations, then set + -- T's primitive list to the base type's list. Otherwise, create a + -- new empty primitives list and share the list between T and its + -- base type. The lists need to be shared in common between the two. + + elsif Etype (T) = Base_Type (T) then + + if not Present (Direct_Primitive_Operations (Base_Type (T))) then + Set_Direct_Primitive_Operations + (Base_Type (T), New_Elmt_List); + end if; + + Set_Direct_Primitive_Operations + (T, Direct_Primitive_Operations (Base_Type (T))); + + -- Case where the Etype is a parent type, so we need a new primitives + -- list for T. + + else + Set_Direct_Primitive_Operations (T, New_Elmt_List); + end if; + end if; + -- Some common processing for all types Set_Depends_On_Private (T, Has_Private_Component (T)); @@ -3398,7 +3447,7 @@ package body Sem_Ch3 is T := Find_Type_Name (N); - Set_Ekind (T, E_Incomplete_Type); + Mutate_Ekind (T, E_Incomplete_Type); Set_Etype (T, T); Set_Is_First_Subtype (T); Init_Size_Align (T); @@ -3478,9 +3527,7 @@ package body Sem_Ch3 is -- Check runtime support for synchronized interfaces - if (Is_Task_Interface (T) - or else Is_Protected_Interface (T) - or else Is_Synchronized_Interface (T)) + if Is_Concurrent_Interface (T) and then not RTE_Available (RE_Select_Specific_Data) then Error_Msg_CRT ("synchronized interfaces", T); @@ -3522,7 +3569,7 @@ package body Sem_Ch3 is Set_Etype (E, Universal_Integer); Set_Etype (Id, Universal_Integer); - Set_Ekind (Id, E_Named_Integer); + Mutate_Ekind (Id, E_Named_Integer); Set_Is_Frozen (Id, True); Set_Debug_Info_Needed (Id); @@ -3567,10 +3614,7 @@ package body Sem_Ch3 is if T = Any_Type then T := It.Typ; - elsif It.Typ = Universal_Real - or else - It.Typ = Universal_Integer - then + elsif Is_Universal_Numeric_Type (It.Typ) then -- Choose universal interpretation over any other T := It.Typ; @@ -3585,7 +3629,7 @@ package body Sem_Ch3 is if Is_Integer_Type (T) then Resolve (E, T); Set_Etype (Id, Universal_Integer); - Set_Ekind (Id, E_Named_Integer); + Mutate_Ekind (Id, E_Named_Integer); elsif Is_Real_Type (T) then @@ -3617,14 +3661,14 @@ package body Sem_Ch3 is Resolve (E, T); Set_Etype (Id, Universal_Real); - Set_Ekind (Id, E_Named_Real); + Mutate_Ekind (Id, E_Named_Real); else Wrong_Type (E, Any_Numeric); Resolve (E, T); Set_Etype (Id, T); - Set_Ekind (Id, E_Constant); + Mutate_Ekind (Id, E_Constant); Set_Never_Set_In_Source (Id, True); Set_Is_True_Constant (Id, True); return; @@ -4025,7 +4069,7 @@ package body Sem_Ch3 is T := Find_Type_Of_Object (Object_Definition (N), N); Set_Etype (Id, T); - Set_Ekind (Id, E_Variable); + Mutate_Ekind (Id, E_Variable); goto Leave; end if; @@ -4051,7 +4095,7 @@ package body Sem_Ch3 is if Error_Posted (Id) then Set_Etype (Id, T); - Set_Ekind (Id, E_Variable); + Mutate_Ekind (Id, E_Variable); goto Leave; end if; end if; @@ -4164,27 +4208,10 @@ package body Sem_Ch3 is Set_Related_Array_Object (Base_Type (T), Id); end if; - -- Special checks for protected objects not at library level + -- Check for protected objects not at library level if Has_Protected (T) and then not Is_Library_Level_Entity (Id) then Check_Restriction (No_Local_Protected_Objects, Id); - - -- Protected objects with interrupt handlers must be at library level - - -- Ada 2005: This test is not needed (and the corresponding clause - -- in the RM is removed) because accessibility checks are sufficient - -- to make handlers not at the library level illegal. - - -- AI05-0303: The AI is in fact a binding interpretation, and thus - -- applies to the '95 version of the language as well. - - if Is_Protected_Type (T) - and then Has_Interrupt_Handler (T) - and then Ada_Version < Ada_95 - then - Error_Msg_N - ("interrupt object can only be declared at library level", Id); - end if; end if; -- Check for violation of No_Local_Timing_Events @@ -4370,7 +4397,7 @@ package body Sem_Ch3 is and then In_Subrange_Of (Etype (Entity (E)), T) then Set_Is_Known_Valid (Id); - Set_Ekind (Id, E_Constant); + Mutate_Ekind (Id, E_Constant); Set_Actual_Subtype (Id, Etype (Entity (E))); end if; @@ -4515,7 +4542,7 @@ package body Sem_Ch3 is elsif Is_Class_Wide_Type (T) then Error_Msg_N - ("initialization required in class-wide declaration ", N); + ("initialization required in class-wide declaration", N); else Error_Msg_N @@ -4586,9 +4613,9 @@ package body Sem_Ch3 is elsif Is_Unchecked_Union (T) then if Constant_Present (N) or else Nkind (E) = N_Function_Call then - Set_Ekind (Id, E_Constant); + Mutate_Ekind (Id, E_Constant); else - Set_Ekind (Id, E_Variable); + Mutate_Ekind (Id, E_Variable); end if; -- If the expression is an aggregate it contains the required @@ -4625,6 +4652,13 @@ package body Sem_Ch3 is Related_Id := Empty; end if; + -- If the object has an unconstrained array subtype with fixed + -- lower bound, then sliding to that bound may be needed. + + if Is_Fixed_Lower_Bound_Array_Subtype (T) then + Expand_Sliding_Conversion (E, T); + end if; + Expand_Subtype_From_Expr (N => N, Unc_Type => T, @@ -4764,12 +4798,16 @@ package body Sem_Ch3 is -- Now establish the proper kind and type of the object + if Ekind (Id) = E_Void then + Reinit_Field_To_Zero (Id, F_Next_Inlined_Subprogram); + end if; + if Constant_Present (N) then - Set_Ekind (Id, E_Constant); + Mutate_Ekind (Id, E_Constant); Set_Is_True_Constant (Id); else - Set_Ekind (Id, E_Variable); + Mutate_Ekind (Id, E_Variable); -- A variable is set as shared passive if it appears in a shared -- passive package, and is at the outer level. This is not done for @@ -5097,13 +5135,13 @@ package body Sem_Ch3 is Parent_Base := Base_Type (Parent_Type); if Parent_Type = Any_Type or else Etype (Parent_Type) = Any_Type then - Set_Ekind (T, Ekind (Parent_Type)); + Mutate_Ekind (T, Ekind (Parent_Type)); Set_Etype (T, Any_Type); goto Leave; elsif not Is_Tagged_Type (Parent_Type) then Error_Msg_N - ("parent of type extension must be a tagged type ", Indic); + ("parent of type extension must be a tagged type", Indic); goto Leave; elsif Ekind (Parent_Type) in E_Void | E_Incomplete_Type then @@ -5116,12 +5154,14 @@ package body Sem_Ch3 is & "tagged type (RM 3.9.1 (3/1))", N); Set_Etype (T, Any_Type); - Set_Ekind (T, E_Limited_Private_Type); + Mutate_Ekind (T, E_Limited_Private_Type); Set_Private_Dependents (T, New_Elmt_List); Set_Error_Posted (T); goto Leave; end if; + Check_Wide_Character_Restriction (Parent_Type, Indic); + -- Perhaps the parent type should be changed to the class-wide type's -- specific type in this case to prevent cascading errors ??? @@ -5142,7 +5182,7 @@ package body Sem_Ch3 is Set_Is_Pure (T, Is_Pure (Current_Scope)); Set_Scope (T, Current_Scope); - Set_Ekind (T, E_Record_Type_With_Private); + Mutate_Ekind (T, E_Record_Type_With_Private); Init_Size_Align (T); Set_Default_SSO (T); Set_No_Reordering (T, No_Component_Reordering); @@ -5387,7 +5427,7 @@ package body Sem_Ch3 is -- (no aspects to examine on the generated declaration). if not Comes_From_Source (N) then - Set_Ekind (Id, Ekind (T)); + Mutate_Ekind (Id, Ekind (T)); if Present (Predicate_Function (Id)) then null; @@ -5413,11 +5453,11 @@ package body Sem_Ch3 is case Ekind (T) is when Array_Kind => - Set_Ekind (Id, E_Array_Subtype); + Mutate_Ekind (Id, E_Array_Subtype); Copy_Array_Subtype_Attributes (Id, T); when Decimal_Fixed_Point_Kind => - Set_Ekind (Id, E_Decimal_Fixed_Point_Subtype); + Mutate_Ekind (Id, E_Decimal_Fixed_Point_Subtype); Set_Digits_Value (Id, Digits_Value (T)); Set_Delta_Value (Id, Delta_Value (T)); Set_Scale_Value (Id, Scale_Value (T)); @@ -5429,7 +5469,7 @@ package body Sem_Ch3 is Set_RM_Size (Id, RM_Size (T)); when Enumeration_Kind => - Set_Ekind (Id, E_Enumeration_Subtype); + Mutate_Ekind (Id, E_Enumeration_Subtype); Set_First_Literal (Id, First_Literal (Base_Type (T))); Set_Scalar_Range (Id, Scalar_Range (T)); Set_Is_Character_Type (Id, Is_Character_Type (T)); @@ -5438,7 +5478,7 @@ package body Sem_Ch3 is Set_RM_Size (Id, RM_Size (T)); when Ordinary_Fixed_Point_Kind => - Set_Ekind (Id, E_Ordinary_Fixed_Point_Subtype); + Mutate_Ekind (Id, E_Ordinary_Fixed_Point_Subtype); Set_Scalar_Range (Id, Scalar_Range (T)); Set_Small_Value (Id, Small_Value (T)); Set_Delta_Value (Id, Delta_Value (T)); @@ -5447,7 +5487,7 @@ package body Sem_Ch3 is Set_RM_Size (Id, RM_Size (T)); when Float_Kind => - Set_Ekind (Id, E_Floating_Point_Subtype); + Mutate_Ekind (Id, E_Floating_Point_Subtype); Set_Scalar_Range (Id, Scalar_Range (T)); Set_Digits_Value (Id, Digits_Value (T)); Set_Is_Constrained (Id, Is_Constrained (T)); @@ -5456,21 +5496,21 @@ package body Sem_Ch3 is -- inherited subsequently when Analyze_Dimensions is called. when Signed_Integer_Kind => - Set_Ekind (Id, E_Signed_Integer_Subtype); + Mutate_Ekind (Id, E_Signed_Integer_Subtype); Set_Scalar_Range (Id, Scalar_Range (T)); Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Known_Valid (Id, Is_Known_Valid (T)); Set_RM_Size (Id, RM_Size (T)); when Modular_Integer_Kind => - Set_Ekind (Id, E_Modular_Integer_Subtype); + Mutate_Ekind (Id, E_Modular_Integer_Subtype); Set_Scalar_Range (Id, Scalar_Range (T)); Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Known_Valid (Id, Is_Known_Valid (T)); Set_RM_Size (Id, RM_Size (T)); when Class_Wide_Kind => - Set_Ekind (Id, E_Class_Wide_Subtype); + Mutate_Ekind (Id, E_Class_Wide_Subtype); Set_Class_Wide_Type (Id, Class_Wide_Type (T)); Set_Cloned_Subtype (Id, T); Set_Is_Tagged_Type (Id, True); @@ -5487,7 +5527,7 @@ package body Sem_Ch3 is when E_Record_Subtype | E_Record_Type => - Set_Ekind (Id, E_Record_Subtype); + Mutate_Ekind (Id, E_Record_Subtype); -- Subtype declarations introduced for formal type parameters -- in generic instantiations should inherit the Size value of @@ -5540,7 +5580,7 @@ package body Sem_Ch3 is end if; when Private_Kind => - Set_Ekind (Id, Subtype_Kind (Ekind (T))); + Mutate_Ekind (Id, Subtype_Kind (Ekind (T))); Set_Has_Discriminants (Id, Has_Discriminants (T)); Set_Is_Constrained (Id, Is_Constrained (T)); Set_First_Entity (Id, First_Entity (T)); @@ -5605,7 +5645,7 @@ package body Sem_Ch3 is end if; when Access_Kind => - Set_Ekind (Id, E_Access_Subtype); + Mutate_Ekind (Id, E_Access_Subtype); Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Access_Constant (Id, Is_Access_Constant (T)); @@ -5628,7 +5668,7 @@ package body Sem_Ch3 is end if; when Concurrent_Kind => - Set_Ekind (Id, Subtype_Kind (Ekind (T))); + Mutate_Ekind (Id, Subtype_Kind (Ekind (T))); Set_Corresponding_Record_Type (Id, Corresponding_Record_Type (T)); Set_First_Entity (Id, First_Entity (T)); @@ -5656,7 +5696,7 @@ package body Sem_Ch3 is -- propagate indication. Note that we also have to include -- subtypes for Ada 2012 extended use of incomplete types. - Set_Ekind (Id, E_Incomplete_Subtype); + Mutate_Ekind (Id, E_Incomplete_Subtype); Set_Is_Tagged_Type (Id, Is_Tagged_Type (T)); Set_Private_Dependents (Id, New_Elmt_List); @@ -5700,6 +5740,14 @@ package body Sem_Ch3 is Inherit_Predicate_Flags (Id, T); end if; + -- When prefixed calls are enabled for untagged types, the subtype + -- shares the primitive operations of its base type. + + if Extensions_Allowed then + Set_Direct_Primitive_Operations + (Id, Direct_Primitive_Operations (Base_Type (T))); + end if; + if Etype (Id) = Any_Type then goto Leave; end if; @@ -5731,7 +5779,16 @@ package body Sem_Ch3 is ((In_Instance and then not Comes_From_Source (N)) or else No (Aspect_Specifications (N))) then - Set_Subprograms_For_Type (Id, Subprograms_For_Type (T)); + -- Inherit Subprograms_For_Type from the full view, if present + + if Present (Full_View (T)) + and then Subprograms_For_Type (Full_View (T)) /= No_Elist + then + Set_Subprograms_For_Type + (Id, Subprograms_For_Type (Full_View (T))); + else + Set_Subprograms_For_Type (Id, Subprograms_For_Type (T)); + end if; -- If the current declaration created both a private and a full view, -- then propagate Predicate_Function to the latter as well. @@ -6023,6 +6080,7 @@ package body Sem_Ch3 is Nb_Index : Pos; Priv : Entity_Id; Related_Id : Entity_Id; + Has_FLB_Index : Boolean := False; begin if Nkind (Def) = N_Constrained_Array_Definition then @@ -6112,6 +6170,39 @@ package body Sem_Ch3 is Make_Index (Index, P, Related_Id, Nb_Index); + -- In the case where we have an unconstrained array with an index + -- given by a subtype_indication, this is necessarily a "fixed lower + -- bound" index. We change the upper bound of that index to the upper + -- bound of the index's subtype (denoted by the subtype_mark), since + -- that upper bound was originally set by the parser to be the same + -- as the lower bound. In truth, that upper bound corresponds to + -- a box ("<>"), and could be set to Empty, but it's convenient to + -- set it to the upper bound to avoid needing to add special tests + -- in various places for an Empty upper bound, and in any case that + -- accurately characterizes the index's range of values. + + if Nkind (Def) = N_Unconstrained_Array_Definition + and then Nkind (Index) = N_Subtype_Indication + then + declare + Index_Subtype_High_Bound : constant Entity_Id := + Type_High_Bound (Entity (Subtype_Mark (Index))); + begin + Set_High_Bound (Range_Expression (Constraint (Index)), + Index_Subtype_High_Bound); + + -- Record that the array type has one or more indexes with + -- a fixed lower bound. + + Has_FLB_Index := True; + + -- Mark the index as belonging to an array type with a fixed + -- lower bound. + + Set_Is_Fixed_Lower_Bound_Index_Subtype (Etype (Index)); + end; + end if; + -- Check error of subtype with predicate for index type Bad_Predicated_Subtype_Use @@ -6146,7 +6237,7 @@ package body Sem_Ch3 is -- the master_id associated with an anonymous access to task type -- component (see Expand_N_Full_Type_Declaration.Build_Master) - Set_Parent (Element_Type, Parent (T)); + Copy_Parent (To => Element_Type, From => T); -- Ada 2005 (AI-230): In case of components that are anonymous access -- types the level of accessibility depends on the enclosing type @@ -6181,6 +6272,12 @@ package body Sem_Ch3 is if Nkind (Def) = N_Constrained_Array_Definition then + if Ekind (T) in Incomplete_Or_Private_Kind then + Reinit_Field_To_Zero (T, F_Stored_Constraint); + else + pragma Assert (Ekind (T) = E_Void); + end if; + -- Establish Implicit_Base as unconstrained base type Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B'); @@ -6192,7 +6289,7 @@ package body Sem_Ch3 is -- The constrained array type is a subtype of the unconstrained one - Set_Ekind (T, E_Array_Subtype); + Mutate_Ekind (T, E_Array_Subtype); Init_Size_Align (T); Set_Etype (T, Implicit_Base); Set_Scope (T, Current_Scope); @@ -6222,12 +6319,20 @@ package body Sem_Ch3 is else pragma Assert (Nkind (Def) = N_Unconstrained_Array_Definition); - Set_Ekind (T, E_Array_Type); + if Ekind (T) in Incomplete_Or_Private_Kind then + Reinit_Field_To_Zero (T, F_Stored_Constraint); + else + pragma Assert (Ekind (T) = E_Void); + end if; + + Mutate_Ekind (T, E_Array_Type); Init_Size_Align (T); Set_Etype (T, T); Set_Scope (T, Current_Scope); Set_Component_Size (T, Uint_0); Set_Is_Constrained (T, False); + Set_Is_Fixed_Lower_Bound_Array_Subtype + (T, Has_FLB_Index); Set_First_Index (T, First (Subtype_Marks (Def))); Set_Has_Delayed_Freeze (T, True); Propagate_Concurrent_Flags (T, Element_Type); @@ -6495,7 +6600,7 @@ package body Sem_Ch3 is Scope_Stack.Append (Curr_Scope); end if; - Set_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type); + Mutate_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type); Set_Can_Use_Internal_Rep (Anon, not Always_Compatible_Rep_On_Target); return Anon; end Replace_Anonymous_Access_To_Protected_Subprogram; @@ -6668,7 +6773,7 @@ package body Sem_Ch3 is if Nkind (S) /= N_Subtype_Indication and then Subt /= Base_Type (Subt) then - Set_Ekind (Derived_Type, E_Access_Subtype); + Mutate_Ekind (Derived_Type, E_Access_Subtype); end if; if Ekind (Derived_Type) = E_Access_Subtype then @@ -6714,7 +6819,9 @@ package body Sem_Ch3 is Has_Private_Component (Derived_Type)); Conditional_Delay (Derived_Type, Subt); - if Is_Access_Subprogram_Type (Derived_Type) then + if Is_Access_Subprogram_Type (Derived_Type) + and then Is_Base_Type (Derived_Type) + then Set_Can_Use_Internal_Rep (Derived_Type, Can_Use_Internal_Rep (Parent_Type)); end if; @@ -6783,7 +6890,7 @@ package body Sem_Ch3 is Implicit_Base := Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B'); - Set_Ekind (Implicit_Base, Ekind (Parent_Base)); + Mutate_Ekind (Implicit_Base, Ekind (Parent_Base)); Set_Etype (Implicit_Base, Parent_Base); Copy_Array_Subtype_Attributes (Implicit_Base, Parent_Base); @@ -6797,7 +6904,7 @@ package body Sem_Ch3 is begin if not Is_Constrained (Parent_Type) then if Nkind (Indic) /= N_Subtype_Indication then - Set_Ekind (Derived_Type, E_Array_Type); + Mutate_Ekind (Derived_Type, E_Array_Type); Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type); Copy_Array_Base_Type_Attributes (Derived_Type, Parent_Type); @@ -6824,7 +6931,7 @@ package body Sem_Ch3 is if Nkind (Indic) /= N_Subtype_Indication then Make_Implicit_Base; - Set_Ekind (Derived_Type, Ekind (Parent_Type)); + Mutate_Ekind (Derived_Type, Ekind (Parent_Type)); Set_Etype (Derived_Type, Implicit_Base); Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type); @@ -7284,7 +7391,7 @@ package body Sem_Ch3 is New_Lit := Make_Defining_Identifier (Loc, Chars (Literal)); end if; - Set_Ekind (New_Lit, E_Enumeration_Literal); + Mutate_Ekind (New_Lit, E_Enumeration_Literal); Set_Enumeration_Pos (New_Lit, Enumeration_Pos (Literal)); Set_Enumeration_Rep (New_Lit, Enumeration_Rep (Literal)); Set_Enumeration_Rep_Expr (New_Lit, Empty); @@ -7304,7 +7411,7 @@ package body Sem_Ch3 is -- may be hidden by a previous explicit function definition (cf. -- c83031a). - Set_Ekind (Derived_Type, E_Enumeration_Subtype); + Mutate_Ekind (Derived_Type, E_Enumeration_Subtype); Set_Etype (Derived_Type, Implicit_Base); Type_Decl := @@ -7476,7 +7583,7 @@ package body Sem_Ch3 is Create_Itype (Ekind (Parent_Base), N, Derived_Type, 'B'); Set_Etype (Implicit_Base, Parent_Base); - Set_Ekind (Implicit_Base, Ekind (Parent_Base)); + Mutate_Ekind (Implicit_Base, Ekind (Parent_Base)); Set_Size_Info (Implicit_Base, Parent_Base); Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base)); Set_Parent (Implicit_Base, Parent (Derived_Type)); @@ -7516,7 +7623,7 @@ package body Sem_Ch3 is -- parent type (otherwise Process_Subtype has set the bounds) if No_Constraint then - Set_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type))); + Mutate_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type))); end if; -- If we did not have a range constraint, then set the range from the @@ -7945,7 +8052,7 @@ package body Sem_Ch3 is -- prevent spurious errors associated with missing overriding -- of abstract primitives (overridden only for Derived_Type). - Set_Ekind (Full_Der, E_Record_Type); + Mutate_Ekind (Full_Der, E_Record_Type); Set_Is_Underlying_Record_View (Full_Der); Set_Default_SSO (Full_Der); Set_No_Reordering (Full_Der, No_Component_Reordering); @@ -8845,7 +8952,7 @@ package body Sem_Ch3 is if Private_Extension then Type_Def := N; - Set_Ekind (Derived_Type, E_Record_Type_With_Private); + Mutate_Ekind (Derived_Type, E_Record_Type_With_Private); Set_Default_SSO (Derived_Type); Set_No_Reordering (Derived_Type, No_Component_Reordering); @@ -8860,7 +8967,7 @@ package body Sem_Ch3 is -- For untagged types we preserve the Ekind of the Parent_Base. if Present (Record_Extension_Part (Type_Def)) then - Set_Ekind (Derived_Type, E_Record_Type); + Mutate_Ekind (Derived_Type, E_Record_Type); Set_Default_SSO (Derived_Type); Set_No_Reordering (Derived_Type, No_Component_Reordering); @@ -8874,7 +8981,7 @@ package body Sem_Ch3 is end if; else - Set_Ekind (Derived_Type, Ekind (Parent_Base)); + Mutate_Ekind (Derived_Type, Ekind (Parent_Base)); end if; end if; @@ -9212,9 +9319,7 @@ package body Sem_Ch3 is and then Is_Limited_Record (Full_View (Parent_Type))) then if not Is_Interface (Parent_Type) - or else Is_Synchronized_Interface (Parent_Type) - or else Is_Protected_Interface (Parent_Type) - or else Is_Task_Interface (Parent_Type) + or else Is_Concurrent_Interface (Parent_Type) then Set_Is_Limited_Record (Derived_Type); end if; @@ -9453,6 +9558,13 @@ package body Sem_Ch3 is end; end if; + -- When prefixed-call syntax is allowed for untagged types, initialize + -- the list of primitive operations to an empty list. + + if Extensions_Allowed and then not Is_Tagged then + Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List); + end if; + -- Set fields for tagged types if Is_Tagged then @@ -9731,9 +9843,15 @@ package body Sem_Ch3 is begin -- Set common attributes + if Ekind (Derived_Type) in Incomplete_Or_Private_Kind + and then Ekind (Parent_Base) in Modular_Integer_Kind | Array_Kind + then + Reinit_Field_To_Zero (Derived_Type, F_Stored_Constraint); + end if; + Set_Scope (Derived_Type, Current_Scope); Set_Etype (Derived_Type, Parent_Base); - Set_Ekind (Derived_Type, Ekind (Parent_Base)); + Mutate_Ekind (Derived_Type, Ekind (Parent_Base)); Propagate_Concurrent_Flags (Derived_Type, Parent_Base); Set_Size_Info (Derived_Type, Parent_Type); @@ -9925,6 +10043,28 @@ package body Sem_Ch3 is return; end if; + -- If not already set, initialize the derived type's list of primitive + -- operations to an empty element list. + + if not Present (Direct_Primitive_Operations (Derived_Type)) then + Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List); + + -- If Etype of the derived type is the base type (as opposed to + -- a parent type) and doesn't have an associated list of primitive + -- operations, then set the base type's primitive list to the + -- derived type's list. The lists need to be shared in common + -- between the two. + + if Etype (Derived_Type) = Base_Type (Derived_Type) + and then + not Present (Direct_Primitive_Operations (Etype (Derived_Type))) + then + Set_Direct_Primitive_Operations + (Etype (Derived_Type), + Direct_Primitive_Operations (Derived_Type)); + end if; + end if; + -- Set delayed freeze and then derive subprograms, we need to do this -- in this order so that derived subprograms inherit the derived freeze -- if necessary. @@ -9952,7 +10092,7 @@ package body Sem_Ch3 is D_Minal := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim)); - Set_Ekind (D_Minal, E_In_Parameter); + Mutate_Ekind (D_Minal, E_In_Parameter); Set_Mechanism (D_Minal, Default_Mechanism); Set_Etype (D_Minal, Etype (Discrim)); Set_Scope (D_Minal, Current_Scope); @@ -9971,7 +10111,7 @@ package body Sem_Ch3 is then CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim)); - Set_Ekind (CR_Disc, E_In_Parameter); + Mutate_Ekind (CR_Disc, E_In_Parameter); Set_Mechanism (CR_Disc, Default_Mechanism); Set_Etype (CR_Disc, Etype (Discrim)); Set_Scope (CR_Disc, Current_Scope); @@ -10296,7 +10436,7 @@ package body Sem_Ch3 is if Discrim_Present then null; - elsif Nkind (Parent (Parent (Def))) = N_Component_Declaration + elsif Parent_Kind (Parent (Def)) = N_Component_Declaration and then Has_Per_Object_Constraint (Defining_Identifier (Parent (Parent (Def)))) then @@ -10362,7 +10502,7 @@ package body Sem_Ch3 is begin if Ekind (T) = E_Record_Type then - Set_Ekind (Def_Id, E_Record_Subtype); + Mutate_Ekind (Def_Id, E_Record_Subtype); -- Inherit preelaboration flag from base, for types for which it -- may have been set: records, private types, protected types. @@ -10371,15 +10511,15 @@ package body Sem_Ch3 is (Def_Id, Known_To_Have_Preelab_Init (T)); elsif Ekind (T) = E_Task_Type then - Set_Ekind (Def_Id, E_Task_Subtype); + Mutate_Ekind (Def_Id, E_Task_Subtype); elsif Ekind (T) = E_Protected_Type then - Set_Ekind (Def_Id, E_Protected_Subtype); + Mutate_Ekind (Def_Id, E_Protected_Subtype); Set_Known_To_Have_Preelab_Init (Def_Id, Known_To_Have_Preelab_Init (T)); elsif Is_Private_Type (T) then - Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); + Mutate_Ekind (Def_Id, Subtype_Kind (Ekind (T))); Set_Known_To_Have_Preelab_Init (Def_Id, Known_To_Have_Preelab_Init (T)); @@ -10388,7 +10528,7 @@ package body Sem_Ch3 is Set_Private_Dependents (Def_Id, New_Elmt_List); elsif Is_Class_Wide_Type (T) then - Set_Ekind (Def_Id, E_Class_Wide_Subtype); + Mutate_Ekind (Def_Id, E_Class_Wide_Subtype); else -- Incomplete type. Attach subtype to list of dependents, to be @@ -10401,9 +10541,9 @@ package body Sem_Ch3 is -- initialization procedure. if Ekind (T) = E_Incomplete_Type then - Set_Ekind (Def_Id, E_Incomplete_Subtype); + Mutate_Ekind (Def_Id, E_Incomplete_Subtype); else - Set_Ekind (Def_Id, Ekind (T)); + Mutate_Ekind (Def_Id, Ekind (T)); end if; if For_Access and then Within_Init_Proc then @@ -10902,6 +11042,15 @@ package body Sem_Ch3 is then null; + -- Skip reporting the error on Ada 2022 only subprograms + -- that require overriding if we are not in Ada 2022 mode. + + elsif Ada_Version < Ada_2022 + and then Requires_Overriding (Subp) + and then Is_Ada_2022_Only (Ultimate_Alias (Subp)) + then + null; + else Error_Msg_NE ("type must be declared abstract or & overridden", @@ -11070,18 +11219,35 @@ package body Sem_Ch3 is end if; end if; - -- Ada 2005 (AI95-0414) and Ada 2020 (AI12-0269): Diagnose failure to + -- Ada 2005 (AI95-0414) and Ada 2022 (AI12-0269): Diagnose failure to -- match No_Return in parent, but do it unconditionally in Ada 95 too -- for procedures, since this is our pragma. if Present (Overridden_Operation (Subp)) and then No_Return (Overridden_Operation (Subp)) - and then not No_Return (Subp) then - Error_Msg_N ("overriding subprogram & must be No_Return", Subp); - Error_Msg_N - ("\since overridden subprogram is No_Return (RM 6.5.1(6/2))", - Subp); + + -- If the subprogram is a renaming, check that the renamed + -- subprogram is No_Return. + + if Present (Renamed_Or_Alias (Subp)) then + if not No_Return (Renamed_Or_Alias (Subp)) then + Error_Msg_NE ("subprogram & must be No_Return", + Subp, + Renamed_Or_Alias (Subp)); + Error_Msg_N ("\since renaming & overrides No_Return " + & "subprogram (RM 6.5.1(6/2))", + Subp); + end if; + + -- Make sure that the subprogram itself is No_Return. + + elsif not No_Return (Subp) then + Error_Msg_N ("overriding subprogram & must be No_Return", Subp); + Error_Msg_N + ("\since overridden subprogram is No_Return (RM 6.5.1(6/2))", + Subp); + end if; end if; -- If the operation is a wrapper for a synchronized primitive, it @@ -11180,21 +11346,20 @@ package body Sem_Ch3 is end if; end Check_Aliased_Component_Types; - --------------------------------------- - -- Check_Anonymous_Access_Components -- - --------------------------------------- + -------------------------------------- + -- Check_Anonymous_Access_Component -- + -------------------------------------- - procedure Check_Anonymous_Access_Components - (Typ_Decl : Node_Id; - Typ : Entity_Id; - Prev : Entity_Id; - Comp_List : Node_Id) + procedure Check_Anonymous_Access_Component + (Typ_Decl : Node_Id; + Typ : Entity_Id; + Prev : Entity_Id; + Comp_Def : Node_Id; + Access_Def : Node_Id) is - Loc : constant Source_Ptr := Sloc (Typ_Decl); + Loc : constant Source_Ptr := Sloc (Comp_Def); Anon_Access : Entity_Id; Acc_Def : Node_Id; - Comp : Node_Id; - Comp_Def : Node_Id; Decl : Node_Id; Type_Def : Node_Id; @@ -11228,13 +11393,18 @@ package body Sem_Ch3 is -- Is_Tagged indicates whether the type is tagged. It is tagged if -- it's "is new ... with record" or else "is tagged record ...". + Typ_Def : constant Node_Id := + (if Nkind (Typ_Decl) = N_Full_Type_Declaration + then Type_Definition (Typ_Decl) else Empty); Is_Tagged : constant Boolean := - (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition - and then - Present (Record_Extension_Part (Type_Definition (Typ_Decl)))) - or else - (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition - and then Tagged_Present (Type_Definition (Typ_Decl))); + Present (Typ_Def) + and then + ((Nkind (Typ_Def) = N_Derived_Type_Definition + and then + Present (Record_Extension_Part (Typ_Def))) + or else + (Nkind (Typ_Def) = N_Record_Definition + and then Tagged_Present (Typ_Def))); begin -- If there is a previous partial view, no need to create a new one @@ -11452,88 +11622,104 @@ package body Sem_Ch3 is return False; end Mentions_T; - -- Start of processing for Check_Anonymous_Access_Components + -- Start of processing for Check_Anonymous_Access_Component begin - if No (Comp_List) then - return; - end if; + if Present (Access_Def) and then Mentions_T (Access_Def) then + Acc_Def := Access_To_Subprogram_Definition (Access_Def); - Comp := First (Component_Items (Comp_List)); - while Present (Comp) loop - if Nkind (Comp) = N_Component_Declaration - and then Present - (Access_Definition (Component_Definition (Comp))) - and then - Mentions_T (Access_Definition (Component_Definition (Comp))) - then - Comp_Def := Component_Definition (Comp); - Acc_Def := - Access_To_Subprogram_Definition (Access_Definition (Comp_Def)); - - Build_Incomplete_Type_Declaration; - Anon_Access := Make_Temporary (Loc, 'S'); - - -- Create a declaration for the anonymous access type: either - -- an access_to_object or an access_to_subprogram. - - if Present (Acc_Def) then - if Nkind (Acc_Def) = N_Access_Function_Definition then - Type_Def := - Make_Access_Function_Definition (Loc, - Parameter_Specifications => - Parameter_Specifications (Acc_Def), - Result_Definition => Result_Definition (Acc_Def)); - else - Type_Def := - Make_Access_Procedure_Definition (Loc, - Parameter_Specifications => - Parameter_Specifications (Acc_Def)); - end if; + Build_Incomplete_Type_Declaration; + Anon_Access := Make_Temporary (Loc, 'S'); + + -- Create a declaration for the anonymous access type: either + -- an access_to_object or an access_to_subprogram. + if Present (Acc_Def) then + if Nkind (Acc_Def) = N_Access_Function_Definition then + Type_Def := + Make_Access_Function_Definition (Loc, + Parameter_Specifications => + Parameter_Specifications (Acc_Def), + Result_Definition => Result_Definition (Acc_Def)); else Type_Def := - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - Relocate_Node - (Subtype_Mark (Access_Definition (Comp_Def)))); - - Set_Constant_Present - (Type_Def, Constant_Present (Access_Definition (Comp_Def))); - Set_All_Present - (Type_Def, All_Present (Access_Definition (Comp_Def))); + Make_Access_Procedure_Definition (Loc, + Parameter_Specifications => + Parameter_Specifications (Acc_Def)); end if; - Set_Null_Exclusion_Present - (Type_Def, - Null_Exclusion_Present (Access_Definition (Comp_Def))); + else + Type_Def := + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + Relocate_Node (Subtype_Mark (Access_Def))); - Decl := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Anon_Access, - Type_Definition => Type_Def); + Set_Constant_Present (Type_Def, Constant_Present (Access_Def)); + Set_All_Present (Type_Def, All_Present (Access_Def)); + end if; - Insert_Before (Typ_Decl, Decl); - Analyze (Decl); + Set_Null_Exclusion_Present + (Type_Def, Null_Exclusion_Present (Access_Def)); - -- If an access to subprogram, create the extra formals + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Anon_Access, + Type_Definition => Type_Def); - if Present (Acc_Def) then - Create_Extra_Formals (Designated_Type (Anon_Access)); - end if; + Insert_Before (Typ_Decl, Decl); + Analyze (Decl); + + -- If an access to subprogram, create the extra formals + + if Present (Acc_Def) then + Create_Extra_Formals (Designated_Type (Anon_Access)); + end if; + if Nkind (Comp_Def) = N_Component_Definition then Rewrite (Comp_Def, Make_Component_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (Anon_Access, Loc))); + Subtype_Indication => New_Occurrence_Of (Anon_Access, Loc))); + else + pragma Assert (Nkind (Comp_Def) = N_Discriminant_Specification); + Rewrite (Comp_Def, + Make_Discriminant_Specification (Loc, + Defining_Identifier => Defining_Identifier (Comp_Def), + Discriminant_Type => New_Occurrence_Of (Anon_Access, Loc))); + end if; - if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then - Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type); - else - Set_Ekind (Anon_Access, E_Anonymous_Access_Type); - end if; + if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then + Mutate_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type); + else + Mutate_Ekind (Anon_Access, E_Anonymous_Access_Type); + end if; + + Set_Is_Local_Anonymous_Access (Anon_Access); + end if; + end Check_Anonymous_Access_Component; + + --------------------------------------- + -- Check_Anonymous_Access_Components -- + --------------------------------------- - Set_Is_Local_Anonymous_Access (Anon_Access); + procedure Check_Anonymous_Access_Components + (Typ_Decl : Node_Id; + Typ : Entity_Id; + Prev : Entity_Id; + Comp_List : Node_Id) + is + Comp : Node_Id; + begin + if No (Comp_List) then + return; + end if; + + Comp := First (Component_Items (Comp_List)); + while Present (Comp) loop + if Nkind (Comp) = N_Component_Declaration then + Check_Anonymous_Access_Component + (Typ_Decl, Typ, Prev, + Component_Definition (Comp), + Access_Definition (Component_Definition (Comp))); end if; Next (Comp); @@ -12492,9 +12678,13 @@ package body Sem_Ch3 is Set_Homonym (Full, Save_Homonym); Set_Associated_Node_For_Itype (Full, Related_Nod); + if Ekind (Full) in Incomplete_Or_Private_Kind then + Reinit_Field_To_Zero (Full, F_Private_Dependents); + end if; + -- Set common attributes for all subtypes: kind, convention, etc. - Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base))); + Mutate_Ekind (Full, Subtype_Kind (Ekind (Full_Base))); Set_Convention (Full, Convention (Full_Base)); Set_Is_First_Subtype (Full, False); Set_Scope (Full, Scope (Priv)); @@ -13050,7 +13240,7 @@ package body Sem_Ch3 is Desig_Subtype := Create_Itype (E_Void, Related_Nod, Scope_Id => Scope (Desig_Type)); - Set_Ekind (Desig_Subtype, E_Record_Subtype); + Mutate_Ekind (Desig_Subtype, E_Record_Subtype); Def_Id := Entity (Subtype_Mark (S)); -- We indicate that the component has a per-object constraint @@ -13147,7 +13337,7 @@ package body Sem_Ch3 is if No (Def_Id) then Def_Id := Create_Itype (E_Access_Subtype, Related_Nod); else - Set_Ekind (Def_Id, E_Access_Subtype); + Mutate_Ekind (Def_Id, E_Access_Subtype); end if; if Constraint_OK then @@ -13225,6 +13415,7 @@ package body Sem_Ch3 is Index : Node_Id; S, T : Entity_Id; Constraint_OK : Boolean := True; + Is_FLB_Array_Subtype : Boolean := False; begin T := Entity (Subtype_Mark (SI)); @@ -13268,6 +13459,48 @@ package body Sem_Ch3 is for J in 1 .. Number_Of_Constraints loop Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J); + + -- If the subtype of the index has been set to indicate that + -- it has a fixed lower bound, then record that the subtype's + -- entity will need to be marked as being a fixed-lower-bound + -- array subtype. + + if S = First (Constraints (C)) then + Is_FLB_Array_Subtype := + Is_Fixed_Lower_Bound_Index_Subtype (Etype (S)); + + -- If the parent subtype (or should this be Etype of that?) + -- is an FLB array subtype, we flag an error, because we + -- don't currently allow subtypes of such subtypes to + -- specify a fixed lower bound for any of their indexes, + -- even if the index of the parent subtype is a "range <>" + -- index. + + if Is_FLB_Array_Subtype + and then Is_Fixed_Lower_Bound_Array_Subtype (T) + then + Error_Msg_NE + ("index with fixed lower bound not allowed for subtype " + & "of fixed-lower-bound }", S, T); + + Is_FLB_Array_Subtype := False; + end if; + + elsif Is_FLB_Array_Subtype + and then not Is_Fixed_Lower_Bound_Index_Subtype (Etype (S)) + then + Error_Msg_NE + ("constrained index not allowed for fixed-lower-bound " + & "subtype of}", S, T); + + elsif not Is_FLB_Array_Subtype + and then Is_Fixed_Lower_Bound_Index_Subtype (Etype (S)) + then + Error_Msg_NE + ("index with fixed lower bound not allowed for " + & "constrained subtype of}", S, T); + end if; + Next (Index); Next (S); end loop; @@ -13281,7 +13514,7 @@ package body Sem_Ch3 is Set_Parent (Def_Id, Related_Nod); else - Set_Ekind (Def_Id, E_Array_Subtype); + Mutate_Ekind (Def_Id, E_Array_Subtype); end if; Set_Size_Info (Def_Id, (T)); @@ -13294,7 +13527,9 @@ package body Sem_Ch3 is Set_First_Index (Def_Id, First_Index (T)); end if; - Set_Is_Constrained (Def_Id, True); + Set_Is_Constrained (Def_Id, not Is_FLB_Array_Subtype); + Set_Is_Fixed_Lower_Bound_Array_Subtype + (Def_Id, Is_FLB_Array_Subtype); Set_Is_Aliased (Def_Id, Is_Aliased (T)); Set_Is_Independent (Def_Id, Is_Independent (T)); Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); @@ -13844,7 +14079,7 @@ package body Sem_Ch3 is Bound_Val : Ureal; begin - Set_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype); + Mutate_Ekind (Def_Id, E_Decimal_Fixed_Point_Subtype); if Nkind (C) = N_Range_Constraint then Range_Expr := Range_Expression (C); @@ -13928,7 +14163,7 @@ package body Sem_Ch3 is begin -- Set a reasonable Ekind for the entity, including incomplete types. - Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); + Mutate_Ekind (Def_Id, Subtype_Kind (Ekind (T))); -- Set Etype to the known type, to reduce chances of cascaded errors @@ -13969,9 +14204,7 @@ package body Sem_Ch3 is (Has_Unknown_Discriminants (T) or else (not Has_Discriminants (T) - and then Has_Discriminants (Full_View (T)) - and then Present (Discriminant_Default_Value - (First_Discriminant (Full_View (T)))))) + and then Has_Defaulted_Discriminants (Full_View (T)))) then T := Full_View (T); E := Full_View (E); @@ -14056,7 +14289,7 @@ package body Sem_Ch3 is C : constant Node_Id := Constraint (S); begin - Set_Ekind (Def_Id, E_Enumeration_Subtype); + Mutate_Ekind (Def_Id, E_Enumeration_Subtype); Set_First_Literal (Def_Id, First_Literal (Base_Type (T))); @@ -14081,7 +14314,7 @@ package body Sem_Ch3 is Rais : Node_Id; begin - Set_Ekind (Def_Id, E_Floating_Point_Subtype); + Mutate_Ekind (Def_Id, E_Floating_Point_Subtype); Set_Etype (Def_Id, Base_Type (T)); Set_Size_Info (Def_Id, (T)); @@ -14158,6 +14391,7 @@ package body Sem_Ch3 is Def_Id : Entity_Id; R : Node_Id := Empty; T : constant Entity_Id := Etype (Index); + Is_FLB_Index : Boolean := False; begin Def_Id := @@ -14171,8 +14405,20 @@ package body Sem_Ch3 is then -- A Range attribute will be transformed into N_Range by Resolve - Analyze (S); - Set_Etype (S, T); + -- If a range has an Empty upper bound, then remember that for later + -- setting of the index subtype's Is_Fixed_Lower_Bound_Index_Subtype + -- flag, and also set the upper bound of the range to the index + -- subtype's upper bound rather than leaving it Empty. In truth, + -- that upper bound corresponds to a box ("<>"), but it's convenient + -- to set it to the upper bound to avoid needing to add special tests + -- in various places for an Empty upper bound, and in any case it + -- accurately characterizes the index's range of values. + + if Nkind (S) = N_Range and then not Present (High_Bound (S)) then + Is_FLB_Index := True; + Set_High_Bound (S, Type_High_Bound (T)); + end if; + R := S; Process_Range_Expr_In_Decl (R, T); @@ -14258,13 +14504,13 @@ package body Sem_Ch3 is -- Complete construction of the Itype if Is_Modular_Integer_Type (T) then - Set_Ekind (Def_Id, E_Modular_Integer_Subtype); + Mutate_Ekind (Def_Id, E_Modular_Integer_Subtype); elsif Is_Integer_Type (T) then - Set_Ekind (Def_Id, E_Signed_Integer_Subtype); + Mutate_Ekind (Def_Id, E_Signed_Integer_Subtype); else - Set_Ekind (Def_Id, E_Enumeration_Subtype); + Mutate_Ekind (Def_Id, E_Enumeration_Subtype); Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); Set_First_Literal (Def_Id, First_Literal (T)); end if; @@ -14273,7 +14519,22 @@ package body Sem_Ch3 is Set_RM_Size (Def_Id, RM_Size (T)); Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - Set_Scalar_Range (Def_Id, R); + -- If this is a range for a fixed-lower-bound subtype, then set the + -- index itype's low bound to the FLB and the index itype's upper bound + -- to the high bound of the parent array type's index subtype. Also, + -- mark the itype as an FLB index subtype. + + if Nkind (S) = N_Range and then Is_FLB_Index then + Set_Scalar_Range + (Def_Id, + Make_Range (Sloc (S), + Low_Bound => Low_Bound (S), + High_Bound => Type_High_Bound (T))); + Set_Is_Fixed_Lower_Bound_Index_Subtype (Def_Id); + + else + Set_Scalar_Range (Def_Id, R); + end if; Set_Etype (S, Def_Id); Set_Discrete_RM_Size (Def_Id); @@ -14291,9 +14552,9 @@ package body Sem_Ch3 is Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); if Is_Modular_Integer_Type (T) then - Set_Ekind (Def_Id, E_Modular_Integer_Subtype); + Mutate_Ekind (Def_Id, E_Modular_Integer_Subtype); else - Set_Ekind (Def_Id, E_Signed_Integer_Subtype); + Mutate_Ekind (Def_Id, E_Signed_Integer_Subtype); end if; Set_Etype (Def_Id, Base_Type (T)); @@ -14313,7 +14574,7 @@ package body Sem_Ch3 is Rais : Node_Id; begin - Set_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype); + Mutate_Ekind (Def_Id, E_Ordinary_Fixed_Point_Subtype); Set_Etype (Def_Id, Base_Type (T)); Set_Size_Info (Def_Id, (T)); Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); @@ -14490,7 +14751,7 @@ package body Sem_Ch3 is -- appropriate choice, since it allowed the attributes to be set -- in the first place. This Ekind value will be modified later. - Set_Ekind (Full, Ekind (Priv)); + Mutate_Ekind (Full, Ekind (Priv)); -- Also set Etype temporarily to Any_Type, again, in the absence -- of errors, it will be properly reset, and if there are errors, @@ -15112,7 +15373,7 @@ package body Sem_Ch3 is -- chain ensures that SPARK-related pragmas are not clobbered when the -- decimal fixed point type acts as a full view of a private type. - Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); + Mutate_Ekind (T, E_Decimal_Fixed_Point_Subtype); Set_Etype (T, Implicit_Base); Set_Size_Info (T, Implicit_Base); Inherit_Rep_Item_Chain (T, Implicit_Base); @@ -15504,7 +15765,7 @@ package body Sem_Ch3 is begin New_Subp := New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); - Set_Ekind (New_Subp, Ekind (Parent_Subp)); + Mutate_Ekind (New_Subp, Ekind (Parent_Subp)); -- Check whether the inherited subprogram is a private operation that -- should be inherited but not yet made visible. Such subprograms can @@ -15766,7 +16027,7 @@ package body Sem_Ch3 is -- that functions with controlling access results of record extensions -- with a null extension part require overriding (AI95-00391/06). - -- Ada 202x (AI12-0042): Similarly, set those properties for + -- Ada 2022 (AI12-0042): Similarly, set those properties for -- implementing the rule of RM 7.3.2(6.1/4). -- A subprogram subject to pragma Extensions_Visible with value False @@ -15923,7 +16184,7 @@ package body Sem_Ch3 is Set_Mechanism (New_Subp, Mechanism (Parent_Subp)); end if; - -- Ada 2020 (AI12-0279): If a Yield aspect is specified True for a + -- Ada 2022 (AI12-0279): If a Yield aspect is specified True for a -- primitive subprogram S of a type T, then the aspect is inherited -- by the corresponding primitive subprogram of each descendant of T. @@ -15933,6 +16194,8 @@ package body Sem_Ch3 is then Set_Has_Yield_Aspect (New_Subp, Has_Yield_Aspect (Alias (New_Subp))); end if; + + Set_Is_Ada_2022_Only (New_Subp, Is_Ada_2022_Only (Parent_Subp)); end Derive_Subprogram; ------------------------ @@ -16566,11 +16829,11 @@ package body Sem_Ch3 is Conditional_Delay (Derived_Type, Parent_Type); - Set_Ekind (Derived_Type, E_Enumeration_Subtype); + Mutate_Ekind (Derived_Type, E_Enumeration_Subtype); Set_Etype (Derived_Type, Implicit_Base); Set_Size_Info (Derived_Type, Parent_Type); - if Unknown_RM_Size (Derived_Type) then + if not Known_RM_Size (Derived_Type) then Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); end if; @@ -16815,7 +17078,7 @@ package body Sem_Ch3 is Error_Msg_N ("type cannot be used in its own definition", Indic); end if; - Set_Ekind (T, Ekind (Parent_Type)); + Mutate_Ekind (T, Ekind (Parent_Type)); Set_Etype (T, Any_Type); Set_Scalar_Range (T, Scalar_Range (Any_Type)); @@ -17081,6 +17344,8 @@ package body Sem_Ch3 is Error_Msg_N ("null exclusion can only apply to an access type", N); end if; + Check_Wide_Character_Restriction (Parent_Type, Indic); + -- Avoid deriving parent primitives of underlying record views Build_Derived_Type (N, Parent_Type, T, Is_Completion, @@ -17156,7 +17421,7 @@ package body Sem_Ch3 is R_Node := New_Node (N_Range, Sloc (Def)); Set_Low_Bound (R_Node, B_Node); - Set_Ekind (T, E_Enumeration_Type); + Mutate_Ekind (T, E_Enumeration_Type); Set_First_Literal (T, L); Set_Etype (T, T); Set_Is_Constrained (T); @@ -17170,7 +17435,7 @@ package body Sem_Ch3 is while Present (L) loop if Ekind (L) /= E_Enumeration_Literal then - Set_Ekind (L, E_Enumeration_Literal); + Mutate_Ekind (L, E_Enumeration_Literal); Set_Enumeration_Pos (L, Ev); Set_Enumeration_Rep (L, Ev); Set_Is_Known_Valid (L, True); @@ -17443,10 +17708,10 @@ package body Sem_Ch3 is and then Nkind (N) = N_Private_Type_Declaration then Error_Msg_NE - ("declaration of private } must be a tagged type ", Id, Prev); + ("declaration of private } must be a tagged type", Id, Prev); else Error_Msg_NE - ("full declaration of } must be a tagged type ", Id, Prev); + ("full declaration of } must be a tagged type", Id, Prev); end if; else @@ -17454,10 +17719,10 @@ package body Sem_Ch3 is and then Nkind (N) = N_Private_Type_Declaration then Error_Msg_NE - ("declaration of private } must be a tagged type ", Prev, Id); + ("declaration of private } must be a tagged type", Prev, Id); else Error_Msg_NE - ("full declaration of } must be a tagged type ", Prev, Id); + ("full declaration of } must be a tagged type", Prev, Id); end if; end if; end Tag_Mismatch; @@ -17547,7 +17812,7 @@ package body Sem_Ch3 is if Is_Tagged_Type (Prev) and then Present (Class_Wide_Type (Prev)) then - Set_Ekind (Id, Ekind (Prev)); -- will be reset later + Mutate_Ekind (Id, Ekind (Prev)); -- will be reset later Set_Class_Wide_Type (Id, Class_Wide_Type (Prev)); -- Type of the class-wide type is the current Id. Previously @@ -17825,6 +18090,44 @@ package body Sem_Ch3 is T := Make_Defining_Identifier (Sloc (P), Nam); + -- If In_Spec_Expression, for example within a pre/postcondition, + -- provide enough information for use of the subtype without + -- depending on full analysis and freezing, which will happen when + -- building the correspondiing subprogram. + + if In_Spec_Expression then + Analyze (Subtype_Mark (Obj_Def)); + + declare + Base_T : constant Entity_Id := Entity (Subtype_Mark (Obj_Def)); + Decl : constant Node_Id := + Make_Subtype_Declaration (Sloc (P), + Defining_Identifier => T, + Subtype_Indication => Relocate_Node (Obj_Def)); + begin + Set_Etype (T, Base_T); + Mutate_Ekind (T, Subtype_Kind (Ekind (Base_T))); + Set_Parent (T, Obj_Def); + + if Ekind (T) = E_Array_Subtype then + Set_First_Index (T, First_Index (Base_T)); + Set_Is_Constrained (T); + + elsif Ekind (T) = E_Record_Subtype then + Set_First_Entity (T, First_Entity (Base_T)); + Set_Has_Discriminants (T, Has_Discriminants (Base_T)); + Set_Is_Constrained (T); + end if; + + Insert_Before (Related_Nod, Decl); + end; + + return T; + end if; + + -- When generating code, insert subtype declaration ahead of + -- declaration that generated it. + Insert_Action (Obj_Def, Make_Subtype_Declaration (Sloc (P), Defining_Identifier => T, @@ -17856,9 +18159,8 @@ package body Sem_Ch3 is T := Access_Definition (Related_Nod, Obj_Def); Set_Is_Local_Anonymous_Access - (T, - V => (Ada_Version < Ada_2012) - or else (Nkind (P) /= N_Object_Declaration) + (T, Ada_Version < Ada_2012 + or else Nkind (P) /= N_Object_Declaration or else Is_Library_Level_Entity (Defining_Identifier (P))); -- Otherwise, the object definition is just a subtype_mark @@ -17903,10 +18205,6 @@ package body Sem_Ch3 is Typ := Entity (S); end if; - -- Check No_Wide_Characters restriction - - Check_Wide_Character_Restriction (Typ, S); - return Typ; end Find_Type_Of_Subtype_Indic; @@ -18106,7 +18404,7 @@ package body Sem_Ch3 is Set_Digits_Value (Implicit_Base, Digits_Value (Base_Typ)); Set_Float_Rep (Implicit_Base, Float_Rep (Base_Typ)); - Set_Ekind (T, E_Floating_Point_Subtype); + Mutate_Ekind (T, E_Floating_Point_Subtype); Set_Etype (T, Implicit_Base); Set_Size_Info (T, Implicit_Base); Set_RM_Size (T, RM_Size (Implicit_Base)); @@ -18593,7 +18891,7 @@ package body Sem_Ch3 is if Is_Tagged and then Ekind (New_C) = E_Component and then Nkind (N) /= N_Private_Extension_Declaration then - Set_Ekind (New_C, E_Void); + Mutate_Ekind (New_C, E_Void); end if; if Plain_Discrim then @@ -18792,56 +19090,6 @@ package body Sem_Ch3 is return False; end Is_EVF_Procedure; - ----------------------- - -- Is_Null_Extension -- - ----------------------- - - function Is_Null_Extension (T : Entity_Id) return Boolean is - Type_Decl : constant Node_Id := Parent (Base_Type (T)); - Comp_List : Node_Id; - Comp : Node_Id; - - begin - if Nkind (Type_Decl) /= N_Full_Type_Declaration - or else not Is_Tagged_Type (T) - or else Nkind (Type_Definition (Type_Decl)) /= - N_Derived_Type_Definition - or else No (Record_Extension_Part (Type_Definition (Type_Decl))) - then - return False; - end if; - - Comp_List := - Component_List (Record_Extension_Part (Type_Definition (Type_Decl))); - - if Present (Discriminant_Specifications (Type_Decl)) then - return False; - - elsif Present (Comp_List) - and then Is_Non_Empty_List (Component_Items (Comp_List)) - then - Comp := First (Component_Items (Comp_List)); - - -- Only user-defined components are relevant. The component list - -- may also contain a parent component and internal components - -- corresponding to secondary tags, but these do not determine - -- whether this is a null extension. - - while Present (Comp) loop - if Comes_From_Source (Comp) then - return False; - end if; - - Next (Comp); - end loop; - - return True; - - else - return True; - end if; - end Is_Null_Extension; - -------------------------- -- Is_Private_Primitive -- -------------------------- @@ -18927,21 +19175,8 @@ package body Sem_Ch3 is ------------------- function Is_Local_Type (Typ : Entity_Id) return Boolean is - Scop : Entity_Id; - begin - Scop := Scope (Typ); - while Present (Scop) - and then Scop /= Standard_Standard - loop - if Scop = Scope (Current_Scope) then - return True; - end if; - - Scop := Scope (Scop); - end loop; - - return False; + return Scope_Within (Inner => Typ, Outer => Scope (Current_Scope)); end Is_Local_Type; -- Start of processing for Is_Visible_Component @@ -19148,7 +19383,24 @@ package body Sem_Ch3 is -- abstract, its Etype points back to the specific root type, and it -- cannot have any invariants. - Set_Ekind (CW_Type, E_Class_Wide_Type); + if Ekind (CW_Type) in Incomplete_Or_Private_Kind then + Reinit_Field_To_Zero (CW_Type, F_Private_Dependents); + + elsif Ekind (CW_Type) in Concurrent_Kind then + Reinit_Field_To_Zero (CW_Type, F_First_Private_Entity); + Reinit_Field_To_Zero (CW_Type, F_Scope_Depth_Value); + + if Ekind (CW_Type) in Task_Kind then + Reinit_Field_To_Zero (CW_Type, F_Is_Elaboration_Checks_OK_Id); + Reinit_Field_To_Zero (CW_Type, F_Is_Elaboration_Warnings_OK_Id); + end if; + + if Ekind (CW_Type) in E_Task_Type | E_Protected_Type then + Reinit_Field_To_Zero (CW_Type, F_SPARK_Aux_Pragma_Inherited); + end if; + end if; + + Mutate_Ekind (CW_Type, E_Class_Wide_Type); Set_Is_Tagged_Type (CW_Type, True); Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List); Set_Is_Abstract_Type (CW_Type, False); @@ -19354,7 +19606,7 @@ package body Sem_Ch3 is else if not Is_Entity_Name (N) or else not Is_Type (Entity (N)) then - Error_Msg_N ("invalid subtype mark in discrete range ", N); + Error_Msg_N ("invalid subtype mark in discrete range", N); Set_Etype (N, Any_Integer); return; @@ -19426,13 +19678,13 @@ package body Sem_Ch3 is Set_Etype (Def_Id, Base_Type (T)); if Is_Signed_Integer_Type (T) then - Set_Ekind (Def_Id, E_Signed_Integer_Subtype); + Mutate_Ekind (Def_Id, E_Signed_Integer_Subtype); elsif Is_Modular_Integer_Type (T) then - Set_Ekind (Def_Id, E_Modular_Integer_Subtype); + Mutate_Ekind (Def_Id, E_Modular_Integer_Subtype); else - Set_Ekind (Def_Id, E_Enumeration_Subtype); + Mutate_Ekind (Def_Id, E_Enumeration_Subtype); Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); Set_First_Literal (Def_Id, First_Literal (T)); end if; @@ -19513,7 +19765,7 @@ package body Sem_Ch3 is begin -- If the mod expression is (exactly) 2 * literal, where literal is - -- 128 or less,then almost certainly the * was meant to be **. Warn. + -- 128 or less, then almost certainly the * was meant to be **. Warn. if Warn_On_Suspicious_Modulus_Value and then Nkind (Mod_Expr) = N_Op_Multiply @@ -19529,8 +19781,13 @@ package body Sem_Ch3 is -- Proceed with analysis of mod expression Analyze_And_Resolve (Mod_Expr, Any_Integer); + + if Ekind (T) in Incomplete_Or_Private_Kind then + Reinit_Field_To_Zero (T, F_Stored_Constraint); + end if; + Set_Etype (T, T); - Set_Ekind (T, E_Modular_Integer_Type); + Mutate_Ekind (T, E_Modular_Integer_Type); Init_Alignment (T); Set_Is_Constrained (T); @@ -19644,7 +19901,7 @@ package body Sem_Ch3 is begin Op := Make_Defining_Operator_Symbol (Loc, Name_Op_Concat); - Set_Ekind (Op, E_Operator); + Mutate_Ekind (Op, E_Operator); Set_Scope (Op, Current_Scope); Set_Etype (Op, Typ); Set_Homonym (Op, Get_Name_Entity_Id (Name_Op_Concat)); @@ -19930,7 +20187,7 @@ package body Sem_Ch3 is -- chain ensures that SPARK-related pragmas are not clobbered when the -- ordinary fixed point type acts as a full view of a private type. - Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); + Mutate_Ekind (T, E_Ordinary_Fixed_Point_Subtype); Set_Etype (T, Implicit_Base); Init_Size_Align (T); Inherit_Rep_Item_Chain (T, Implicit_Base); @@ -20064,19 +20321,34 @@ package body Sem_Ch3 is end if; if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then - Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr)); + Check_Anonymous_Access_Component + (Typ_Decl => N, + Typ => Defining_Identifier (N), + Prev => Prev, + Comp_Def => Discr, + Access_Def => Discriminant_Type (Discr)); + + -- if Check_Anonymous_Access_Component replaced Discr then + -- its Original_Node points to the old Discr and the access type + -- for Discr_Type has already been created. + + if Original_Node (Discr) /= Discr then + Discr_Type := Etype (Discriminant_Type (Discr)); + else + Discr_Type := + Access_Definition (Discr, Discriminant_Type (Discr)); - -- Ada 2005 (AI-254) + -- Ada 2005 (AI-254) - if Present (Access_To_Subprogram_Definition - (Discriminant_Type (Discr))) - and then Protected_Present (Access_To_Subprogram_Definition - (Discriminant_Type (Discr))) - then - Discr_Type := - Replace_Anonymous_Access_To_Protected_Subprogram (Discr); + if Present (Access_To_Subprogram_Definition + (Discriminant_Type (Discr))) + and then Protected_Present (Access_To_Subprogram_Definition + (Discriminant_Type (Discr))) + then + Discr_Type := + Replace_Anonymous_Access_To_Protected_Subprogram (Discr); + end if; end if; - else Find_Type (Discriminant_Type (Discr)); Discr_Type := Etype (Discriminant_Type (Discr)); @@ -20313,7 +20585,12 @@ package body Sem_Ch3 is Discr_Number := Uint_1; while Present (Discr) loop Id := Defining_Identifier (Discr); - Set_Ekind (Id, E_Discriminant); + + if Ekind (Id) = E_In_Parameter then + Reinit_Field_To_Zero (Id, F_Discriminal_Link); + end if; + + Mutate_Ekind (Id, E_Discriminant); Init_Component_Location (Id); Init_Esize (Id); Set_Discriminant_Number (Id, Discr_Number); @@ -20673,7 +20950,7 @@ package body Sem_Ch3 is & "has no discriminants", Full_T); end if; - -- ??????? Do we implement the following properly ????? + -- Do we implement the following properly??? -- If the ancestor subtype of a private extension has constrained -- discriminants, then the parent subtype of the full view shall -- impose a statically matching constraint on those discriminants @@ -20750,11 +21027,9 @@ package body Sem_Ch3 is if not Has_Unknown_Discriminants (Priv_T) and then not Has_Discriminants (Priv_T) - and then Has_Discriminants (Full_T) - and then - Present (Discriminant_Default_Value (First_Discriminant (Full_T))) + and then Has_Defaulted_Discriminants (Full_T) then - Set_Has_Constrained_Partial_View (Full_T); + Set_Has_Constrained_Partial_View (Base_Type (Full_T)); Set_Has_Constrained_Partial_View (Priv_T); end if; @@ -20816,48 +21091,48 @@ package body Sem_Ch3 is end loop; end; - -- If the private view was tagged, copy the new primitive operations - -- from the private view to the full view. + declare + Disp_Typ : Entity_Id; + Full_List : Elist_Id; + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + Priv_List : Elist_Id; + + function Contains + (E : Entity_Id; + L : Elist_Id) return Boolean; + -- Determine whether list L contains element E + + -------------- + -- Contains -- + -------------- + + function Contains + (E : Entity_Id; + L : Elist_Id) return Boolean + is + List_Elmt : Elmt_Id; - if Is_Tagged_Type (Full_T) then - declare - Disp_Typ : Entity_Id; - Full_List : Elist_Id; - Prim : Entity_Id; - Prim_Elmt : Elmt_Id; - Priv_List : Elist_Id; - - function Contains - (E : Entity_Id; - L : Elist_Id) return Boolean; - -- Determine whether list L contains element E - - -------------- - -- Contains -- - -------------- - - function Contains - (E : Entity_Id; - L : Elist_Id) return Boolean - is - List_Elmt : Elmt_Id; + begin + List_Elmt := First_Elmt (L); + while Present (List_Elmt) loop + if Node (List_Elmt) = E then + return True; + end if; - begin - List_Elmt := First_Elmt (L); - while Present (List_Elmt) loop - if Node (List_Elmt) = E then - return True; - end if; + Next_Elmt (List_Elmt); + end loop; - Next_Elmt (List_Elmt); - end loop; + return False; + end Contains; - return False; - end Contains; + -- Start of processing - -- Start of processing + begin + -- If the private view was tagged, copy the new primitive operations + -- from the private view to the full view. - begin + if Is_Tagged_Type (Full_T) then if Is_Tagged_Type (Priv_T) then Priv_List := Primitive_Operations (Priv_T); Prim_Elmt := First_Elmt (Priv_List); @@ -20991,8 +21266,23 @@ package body Sem_Ch3 is Propagate_Concurrent_Flags (Class_Wide_Type (Priv_T), Full_T); end if; - end; - end if; + + -- For untagged types, copy the primitives across from the private + -- view to the full view (when extensions are allowed), for support + -- of prefixed calls (when extensions are enabled). + + elsif Extensions_Allowed then + Priv_List := Primitive_Operations (Priv_T); + Prim_Elmt := First_Elmt (Priv_List); + + Full_List := Primitive_Operations (Full_T); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + Append_Elmt (Prim, Full_List); + Next_Elmt (Prim_Elmt); + end loop; + end if; + end; -- Ada 2005 AI 161: Check preelaborable initialization consistency @@ -21199,8 +21489,11 @@ package body Sem_Ch3 is then Set_Subtype_Indication (Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep))); + Reinit_Field_To_Zero + (Priv_Dep, F_Private_Dependents, + Old_Ekind => E_Incomplete_Subtype); + Mutate_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T))); Set_Etype (Priv_Dep, Full_T); - Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T))); Set_Analyzed (Parent (Priv_Dep), False); -- Reanalyze the declaration, suppressing the call to Enter_Name @@ -21774,7 +22067,7 @@ package body Sem_Ch3 is -- Set Ekind of orphan itype, to prevent cascaded errors if Present (Def_Id) then - Set_Ekind (Def_Id, Ekind (Any_Type)); + Mutate_Ekind (Def_Id, Ekind (Any_Type)); end if; -- Make recursive call, having got rid of the bogus constraint @@ -21965,7 +22258,7 @@ package body Sem_Ch3 is -- These flags must be initialized before calling Process_Discriminants -- because this routine makes use of them. - Set_Ekind (T, E_Record_Type); + Mutate_Ekind (T, E_Record_Type); Set_Etype (T, T); Init_Size_Align (T); Set_Interfaces (T, No_Elist); @@ -22069,7 +22362,7 @@ package body Sem_Ch3 is Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag); Enter_Name (Tag_Comp); - Set_Ekind (Tag_Comp, E_Component); + Mutate_Ekind (Tag_Comp, E_Component); Set_Is_Tag (Tag_Comp); Set_Is_Aliased (Tag_Comp); Set_Is_Independent (Tag_Comp); @@ -22142,10 +22435,10 @@ package body Sem_Ch3 is Final_Storage_Only := not Is_Controlled (T); - -- Ada 2005: Check whether an explicit Limited is present in a derived + -- Ada 2005: Check whether an explicit "limited" is present in a derived -- type declaration. - if Nkind (Parent (Def)) = N_Derived_Type_Definition + if Parent_Kind (Def) = N_Derived_Type_Definition and then Limited_Present (Parent (Def)) then Set_Is_Limited_Record (T); @@ -22179,7 +22472,7 @@ package body Sem_Ch3 is if Ekind (Component) = E_Void and then not Is_Itype (Component) then - Set_Ekind (Component, E_Component); + Mutate_Ekind (Component, E_Component); Init_Component_Location (Component); end if; @@ -22400,9 +22693,9 @@ package body Sem_Ch3 is -- Reset the kind of the subtype during analysis of the range, to -- catch possible premature use in the bounds themselves. - Set_Ekind (Def_Id, E_Void); + Mutate_Ekind (Def_Id, E_Void); Process_Range_Expr_In_Decl (R, Subt, Subtyp => Def_Id); - Set_Ekind (Def_Id, Kind); + Mutate_Ekind (Def_Id, Kind); end Set_Scalar_Range_For_Subtype; -------------------------------------------------------- @@ -22578,7 +22871,7 @@ package body Sem_Ch3 is Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ)); Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ)); - Set_Ekind (T, E_Signed_Integer_Subtype); + Mutate_Ekind (T, E_Signed_Integer_Subtype); Set_Etype (T, Implicit_Base); Set_Size_Info (T, Implicit_Base); Inherit_Rep_Item_Chain (T, Implicit_Base); |