diff options
Diffstat (limited to 'gcc/ada/sem_util.adb')
| -rw-r--r-- | gcc/ada/sem_util.adb | 2131 |
1 files changed, 1388 insertions, 743 deletions
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1cf5c69..01a4e2b 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.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,53 +23,56 @@ -- -- ------------------------------------------------------------------------------ -with Casing; use Casing; -with Checks; use Checks; -with Debug; use Debug; -with Elists; use Elists; -with Errout; use Errout; -with Erroutc; use Erroutc; -with Exp_Ch3; use Exp_Ch3; -with Exp_Ch11; use Exp_Ch11; -with Exp_Util; use Exp_Util; -with Fname; use Fname; -with Freeze; use Freeze; -with Itypes; use Itypes; -with Lib; use Lib; -with Lib.Xref; use Lib.Xref; -with Namet.Sp; use Namet.Sp; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Output; use Output; -with Restrict; use Restrict; -with Rident; use Rident; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Attr; use Sem_Attr; -with Sem_Cat; use Sem_Cat; -with Sem_Ch6; use Sem_Ch6; -with Sem_Ch8; use Sem_Ch8; -with Sem_Ch13; use Sem_Ch13; -with Sem_Disp; use Sem_Disp; -with Sem_Elab; use Sem_Elab; -with Sem_Eval; use Sem_Eval; -with Sem_Prag; use Sem_Prag; -with Sem_Res; use Sem_Res; -with Sem_Warn; use Sem_Warn; -with Sem_Type; use Sem_Type; -with Sinfo; use Sinfo; -with Sinput; use Sinput; -with Stand; use Stand; +with Casing; use Casing; +with Checks; use Checks; +with Debug; use Debug; +with Einfo.Utils; use Einfo.Utils; +with Elists; use Elists; +with Errout; use Errout; +with Erroutc; use Erroutc; +with Exp_Ch3; use Exp_Ch3; +with Exp_Ch11; use Exp_Ch11; +with Exp_Util; use Exp_Util; +with Fname; use Fname; +with Freeze; use Freeze; +with Itypes; use Itypes; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Namet.Sp; use Namet.Sp; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Output; use Output; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Attr; use Sem_Attr; +with Sem_Cat; use Sem_Cat; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; +with Sem_Disp; use Sem_Disp; +with Sem_Elab; use Sem_Elab; +with Sem_Eval; use Sem_Eval; +with Sem_Prag; use Sem_Prag; +with Sem_Res; use Sem_Res; +with Sem_Warn; use Sem_Warn; +with Sem_Type; use Sem_Type; +with Sinfo; use Sinfo; +with Sinfo.Nodes; use Sinfo.Nodes; +with Sinfo.Utils; use Sinfo.Utils; +with Sinput; use Sinput; +with Stand; use Stand; with Style; -with Stringt; use Stringt; -with Targparm; use Targparm; -with Tbuild; use Tbuild; -with Ttypes; use Ttypes; -with Uname; use Uname; +with Stringt; use Stringt; +with Targparm; use Targparm; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Uname; use Uname; with GNAT.Heap_Sort_G; -with GNAT.HTable; use GNAT.HTable; +with GNAT.HTable; use GNAT.HTable; package body Sem_Util is @@ -146,7 +149,7 @@ package body Sem_Util is -- have a default. function Is_Preelaborable_Function (Id : Entity_Id) return Boolean; - -- Ada 2020: Determine whether the specified function is suitable as the + -- Ada 2022: Determine whether the specified function is suitable as the -- name of a call in a preelaborable construct (RM 10.2.1(7/5)). type Null_Status_Kind is @@ -174,9 +177,9 @@ package body Sem_Util is -- "subp:file:line:col", corresponding to the source location of the -- body of the subprogram. - ------------------------------ - -- Abstract_Interface_List -- - ------------------------------ + ----------------------------- + -- Abstract_Interface_List -- + ----------------------------- function Abstract_Interface_List (Typ : Entity_Id) return List_Id is Nod : Node_Id; @@ -257,7 +260,8 @@ package body Sem_Util is function Accessibility_Level (Expr : Node_Id; Level : Accessibility_Level_Kind; - In_Return_Context : Boolean := False) return Node_Id + In_Return_Context : Boolean := False; + Allow_Alt_Model : Boolean := True) return Node_Id is Loc : constant Source_Ptr := Sloc (Expr); @@ -269,25 +273,27 @@ package body Sem_Util is -- Construct an integer literal representing an accessibility level -- with its type set to Natural. - function Innermost_Master_Scope_Depth - (N : Node_Id) return Uint; + function Innermost_Master_Scope_Depth (N : Node_Id) return Uint; -- Returns the scope depth of the given node's innermost -- enclosing dynamic scope (effectively the accessibility -- level of the innermost enclosing master). - function Function_Call_Or_Allocator_Level - (N : Node_Id) return Node_Id; + function Function_Call_Or_Allocator_Level (N : Node_Id) return Node_Id; -- Centralized processing of subprogram calls which may appear in -- prefix notation. + function Typ_Access_Level (Typ : Entity_Id) return Uint + is (Type_Access_Level (Typ, Allow_Alt_Model)); + -- Renaming of Type_Access_Level with Allow_Alt_Model specified to avoid + -- passing the parameter specifically in every call. + ---------------------------------- -- Innermost_Master_Scope_Depth -- ---------------------------------- - function Innermost_Master_Scope_Depth - (N : Node_Id) return Uint - is + function Innermost_Master_Scope_Depth (N : Node_Id) return Uint is Encl_Scop : Entity_Id; + Ent : Entity_Id; Node_Par : Node_Id := Parent (N); Master_Lvl_Modifier : Int := 0; @@ -301,12 +307,10 @@ package body Sem_Util is -- among other things. These cases are detected properly ??? while Present (Node_Par) loop + Ent := Defining_Entity_Or_Empty (Node_Par); - if Present (Defining_Entity - (Node_Par, Empty_On_Errors => True)) - then - Encl_Scop := Nearest_Dynamic_Scope - (Defining_Entity (Node_Par)); + if Present (Ent) then + Encl_Scop := Nearest_Dynamic_Scope (Ent); -- Ignore transient scopes made during expansion @@ -377,7 +381,7 @@ package body Sem_Util is (Subprogram_Access_Level (Entity (Name (N)))); else return Make_Level_Literal - (Type_Access_Level (Etype (Prefix (Name (N))))); + (Typ_Access_Level (Etype (Prefix (Name (N))))); end if; -- We ignore coextensions as they cannot be implemented under the @@ -394,19 +398,40 @@ package body Sem_Util is -- Named access types have a designated level if Is_Named_Access_Type (Etype (N)) then - return Make_Level_Literal (Type_Access_Level (Etype (N))); + return Make_Level_Literal (Typ_Access_Level (Etype (N))); -- Otherwise, the level is dictated by RM 3.10.2 (10.7/3) else + -- Check No_Dynamic_Accessibility_Checks restriction override for + -- alternative accessibility model. + + if Allow_Alt_Model + and then No_Dynamic_Accessibility_Checks_Enabled (N) + and then Is_Anonymous_Access_Type (Etype (N)) + then + -- In the alternative model the level is that of the + -- designated type. + + if Debug_Flag_Underscore_B then + return Make_Level_Literal (Typ_Access_Level (Etype (N))); + + -- Otherwise the level is that of the subprogram + + else + return Make_Level_Literal + (Subprogram_Access_Level (Entity (Name (N)))); + end if; + end if; + if Nkind (N) = N_Function_Call then -- Dynamic checks are generated when we are within a return -- value or we are in a function call within an anonymous -- access discriminant constraint of a return object (signified -- by In_Return_Context) on the side of the callee. - -- So, in this case, return library accessibility level to null - -- out the check on the side of the caller. + -- So, in this case, return accessibility level of the + -- enclosing subprogram. if In_Return_Value (N) or else In_Return_Context @@ -416,6 +441,17 @@ package body Sem_Util is end if; end if; + -- When the call is being dereferenced the level is that of the + -- enclosing master of the dereferenced call. + + if Nkind (Parent (N)) in N_Explicit_Dereference + | N_Indexed_Component + | N_Selected_Component + then + return Make_Level_Literal + (Innermost_Master_Scope_Depth (Expr)); + end if; + -- Find any relevant enclosing parent nodes that designate an -- object being initialized. @@ -436,7 +472,7 @@ package body Sem_Util is and then Is_Named_Access_Type (Etype (Par)) then return Make_Level_Literal - (Type_Access_Level (Etype (Par))); + (Typ_Access_Level (Etype (Par))); end if; -- Jump out when we hit an object declaration or the right-hand @@ -553,7 +589,7 @@ package body Sem_Util is if Is_Named_Access_Type (Etype (Pre)) then return Make_Level_Literal - (Type_Access_Level (Etype (Pre))); + (Typ_Access_Level (Etype (Pre))); -- Anonymous access types @@ -618,8 +654,34 @@ package body Sem_Util is (Scope_Depth (Standard_Standard)); end if; - return - New_Occurrence_Of (Get_Dynamic_Accessibility (E), Loc); + -- No_Dynamic_Accessibility_Checks restriction override for + -- alternative accessibility model. + + if Allow_Alt_Model + and then No_Dynamic_Accessibility_Checks_Enabled (E) + then + -- In the alternative model the level is that of the + -- designated type entity's context. + + if Debug_Flag_Underscore_B then + return Make_Level_Literal (Typ_Access_Level (Etype (E))); + + -- Otherwise the level depends on the entity's context + + elsif Is_Formal (E) then + return Make_Level_Literal + (Subprogram_Access_Level + (Enclosing_Subprogram (E))); + else + return Make_Level_Literal + (Scope_Depth (Enclosing_Dynamic_Scope (E))); + end if; + end if; + + -- Return the dynamic level in the normal case + + return New_Occurrence_Of + (Get_Dynamic_Accessibility (E), Loc); -- Initialization procedures have a special extra accessitility -- parameter associated with the level at which the object @@ -637,8 +699,19 @@ package body Sem_Util is -- according to RM 3.10.2 (21). elsif Is_Type (E) then - return Make_Level_Literal - (Type_Access_Level (E) + 1); + -- When restriction No_Dynamic_Accessibility_Checks is active + -- along with -gnatd_b. + + if Allow_Alt_Model + and then No_Dynamic_Accessibility_Checks_Enabled (E) + and then Debug_Flag_Underscore_B + then + return Make_Level_Literal (Typ_Access_Level (E)); + end if; + + -- Normal path + + return Make_Level_Literal (Typ_Access_Level (E) + 1); -- Move up the renamed entity if it came from source since -- expansion may have created a dummy renaming under certain @@ -653,7 +726,7 @@ package body Sem_Util is elsif Is_Named_Access_Type (Etype (E)) then return Make_Level_Literal - (Type_Access_Level (Etype (E))); + (Typ_Access_Level (Etype (E))); -- When E is a component of the current instance of a -- protected type, we assume the level to be deeper than that of @@ -666,6 +739,15 @@ package body Sem_Util is return Make_Level_Literal (Scope_Depth (Enclosing_Dynamic_Scope (E)) + 1); + -- Check if E is an expansion-generated renaming of an iterator + -- by examining Related_Expression. If so, determine the + -- accessibility level based on the original expression. + + elsif Ekind (E) in E_Constant | E_Variable + and then Present (Related_Expression (E)) + then + return Accessibility_Level (Related_Expression (E)); + -- Normal object - get the level of the enclosing scope else @@ -695,7 +777,7 @@ package body Sem_Util is elsif Is_Named_Access_Type (Etype (Pre)) then return Make_Level_Literal - (Type_Access_Level (Etype (Pre))); + (Typ_Access_Level (Etype (Pre))); -- The current expression is a named access type, so there is no -- reason to look at the prefix. Instead obtain the level of E's @@ -703,21 +785,44 @@ package body Sem_Util is elsif Is_Named_Access_Type (Etype (E)) then return Make_Level_Literal - (Type_Access_Level (Etype (E))); + (Typ_Access_Level (Etype (E))); - -- A non-discriminant selected component where the component + -- A nondiscriminant selected component where the component -- is an anonymous access type means that its associated -- level is that of the containing type - see RM 3.10.2 (16). + -- Note that when restriction No_Dynamic_Accessibility_Checks is + -- in effect we treat discriminant components as regular + -- components. + elsif Nkind (E) = N_Selected_Component and then Ekind (Etype (E)) = E_Anonymous_Access_Type and then Ekind (Etype (Pre)) /= E_Anonymous_Access_Type - and then not (Nkind (Selector_Name (E)) in N_Has_Entity - and then Ekind (Entity (Selector_Name (E))) - = E_Discriminant) + and then (not (Nkind (Selector_Name (E)) in N_Has_Entity + and then Ekind (Entity (Selector_Name (E))) + = E_Discriminant) + + -- The alternative accessibility models both treat + -- discriminants as regular components. + + or else (No_Dynamic_Accessibility_Checks_Enabled (E) + and then Allow_Alt_Model)) then + -- When restriction No_Dynamic_Accessibility_Checks is active + -- and -gnatd_b set, the level is that of the designated type. + + if Allow_Alt_Model + and then No_Dynamic_Accessibility_Checks_Enabled (E) + and then Debug_Flag_Underscore_B + then + return Make_Level_Literal + (Typ_Access_Level (Etype (E))); + end if; + + -- Otherwise proceed normally + return Make_Level_Literal - (Type_Access_Level (Etype (Prefix (E)))); + (Typ_Access_Level (Etype (Prefix (E)))); -- Similar to the previous case - arrays featuring components of -- anonymous access components get their corresponding level from @@ -729,8 +834,21 @@ package body Sem_Util is and then Ekind (Component_Type (Base_Type (Etype (Pre)))) = E_Anonymous_Access_Type then + -- When restriction No_Dynamic_Accessibility_Checks is active + -- and -gnatd_b set, the level is that of the designated type. + + if Allow_Alt_Model + and then No_Dynamic_Accessibility_Checks_Enabled (E) + and then Debug_Flag_Underscore_B + then + return Make_Level_Literal + (Typ_Access_Level (Etype (E))); + end if; + + -- Otherwise proceed normally + return Make_Level_Literal - (Type_Access_Level (Etype (Prefix (E)))); + (Typ_Access_Level (Etype (Prefix (E)))); -- The accessibility calculation routine that handles function -- calls (Function_Call_Level) assumes, in the case the @@ -778,7 +896,7 @@ package body Sem_Util is when N_Qualified_Expression => if Is_Named_Access_Type (Etype (E)) then return Make_Level_Literal - (Type_Access_Level (Etype (E))); + (Typ_Access_Level (Etype (E))); else return Accessibility_Level (Expression (E)); end if; @@ -797,7 +915,7 @@ package body Sem_Util is -- its type. if Is_Named_Access_Type (Etype (Pre)) then - return Make_Level_Literal (Type_Access_Level (Etype (Pre))); + return Make_Level_Literal (Typ_Access_Level (Etype (Pre))); -- Otherwise, recurse deeper @@ -824,7 +942,7 @@ package body Sem_Util is elsif Is_Named_Access_Type (Etype (E)) then return Make_Level_Literal - (Type_Access_Level (Etype (E))); + (Typ_Access_Level (Etype (E))); -- In section RM 3.10.2 (10/4) the accessibility rules for -- aggregates and value conversions are outlined. Are these @@ -840,7 +958,7 @@ package body Sem_Util is -- expression's entity. when others => - return Make_Level_Literal (Type_Access_Level (Etype (E))); + return Make_Level_Literal (Typ_Access_Level (Etype (E))); end case; end Accessibility_Level; @@ -1000,11 +1118,7 @@ package body Sem_Util is and then Is_Entity_Name (Name (Expr)) and then Is_RTE (Entity (Name (Expr)), RE_To_Address) then - Expr := First (Parameter_Associations (Expr)); - - if Nkind (Expr) = N_Parameter_Association then - Expr := Explicit_Actual_Parameter (Expr); - end if; + Expr := First_Actual (Expr); -- We finally have the real expression @@ -1406,14 +1520,14 @@ package body Sem_Util is ----------------------------------------- procedure Apply_Compile_Time_Constraint_Error - (N : Node_Id; - Msg : String; - Reason : RT_Exception_Code; - Ent : Entity_Id := Empty; - Typ : Entity_Id := Empty; - Loc : Source_Ptr := No_Location; - Rep : Boolean := True; - Warn : Boolean := False) + (N : Node_Id; + Msg : String; + Reason : RT_Exception_Code; + Ent : Entity_Id := Empty; + Typ : Entity_Id := Empty; + Loc : Source_Ptr := No_Location; + Warn : Boolean := False; + Emit_Message : Boolean := True) is Stat : constant Boolean := Is_Static_Expression (N); R_Stat : constant Node_Id := @@ -1427,17 +1541,9 @@ package body Sem_Util is Rtyp := Typ; end if; - Discard_Node - (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn)); - - -- In GNATprove mode, do not replace the node with an exception raised. - -- In such a case, either the call to Compile_Time_Constraint_Error - -- issues an error which stops analysis, or it issues a warning in - -- a few cases where a suitable check flag is set for GNATprove to - -- generate a check message. - - if not Rep or GNATprove_Mode then - return; + if Emit_Message then + Discard_Node + (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn)); end if; -- Now we replace the node by an N_Raise_Constraint_Error node @@ -1676,6 +1782,7 @@ package body Sem_Util is Subt : Entity_Id; Disc_Type : Entity_Id; Obj : Node_Id; + Index : Node_Id; begin Loc := Sloc (N); @@ -1706,6 +1813,8 @@ package body Sem_Util is if Is_Array_Type (T) then Constraints := New_List; + Index := First_Index (T); + for J in 1 .. Number_Dimensions (T) loop -- Build an array subtype declaration with the nominal subtype and @@ -1713,13 +1822,24 @@ package body Sem_Util is -- local declarations for the subprogram, for analysis before any -- reference to the formal in the body. - Lo := - Make_Attribute_Reference (Loc, - Prefix => - Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), - Attribute_Name => Name_First, - Expressions => New_List ( - Make_Integer_Literal (Loc, J))); + -- If this is for an index with a fixed lower bound, then use + -- the fixed lower bound as the lower bound of the actual + -- subtype's corresponding index. + + if not Is_Constrained (T) + and then Is_Fixed_Lower_Bound_Index_Subtype (Etype (Index)) + then + Lo := New_Copy_Tree (Type_Low_Bound (Etype (Index))); + + else + Lo := + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), + Attribute_Name => Name_First, + Expressions => New_List ( + Make_Integer_Literal (Loc, J))); + end if; Hi := Make_Attribute_Reference (Loc, @@ -1730,6 +1850,8 @@ package body Sem_Util is Make_Integer_Literal (Loc, J))); Append (Make_Range (Loc, Lo, Hi), Constraints); + + Next_Index (Index); end loop; -- If the type has unknown discriminants there is no constrained @@ -2008,7 +2130,7 @@ package body Sem_Util is -- the original constraint from its component declaration. Sel := Entity (Selector_Name (N)); - if Nkind (Parent (Sel)) /= N_Component_Declaration then + if Parent_Kind (Sel) /= N_Component_Declaration then return Empty; end if; end if; @@ -2900,6 +3022,32 @@ package body Sem_Util is ----------------------------------- function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is + + function List_Cannot_Raise_CE (L : List_Id) return Boolean; + -- Returns True if none of the list members cannot possibly raise + -- Constraint_Error. + + -------------------------- + -- List_Cannot_Raise_CE -- + -------------------------- + + function List_Cannot_Raise_CE (L : List_Id) return Boolean is + N : Node_Id; + begin + N := First (L); + while Present (N) loop + if Cannot_Raise_Constraint_Error (N) then + Next (N); + else + return False; + end if; + end loop; + + return True; + end List_Cannot_Raise_CE; + + -- Start of processing for Cannot_Raise_Constraint_Error + begin if Compile_Time_Known_Value (Expr) then return True; @@ -2918,8 +3066,14 @@ package body Sem_Util is when N_Expanded_Name => return True; + when N_Indexed_Component => + return not Do_Range_Check (Expr) + and then Cannot_Raise_Constraint_Error (Prefix (Expr)) + and then List_Cannot_Raise_CE (Expressions (Expr)); + when N_Selected_Component => - return not Do_Discriminant_Check (Expr); + return not Do_Discriminant_Check (Expr) + and then Cannot_Raise_Constraint_Error (Prefix (Expr)); when N_Attribute_Reference => if Do_Overflow_Check (Expr) then @@ -2929,27 +3083,12 @@ package body Sem_Util is return True; else - declare - N : Node_Id; - - begin - N := First (Expressions (Expr)); - while Present (N) loop - if Cannot_Raise_Constraint_Error (N) then - Next (N); - else - return False; - end if; - end loop; - - return True; - end; + return List_Cannot_Raise_CE (Expressions (Expr)); end if; when N_Type_Conversion => if Do_Overflow_Check (Expr) or else Do_Length_Check (Expr) - or else Do_Tag_Check (Expr) then return False; else @@ -4683,10 +4822,6 @@ package body Sem_Util is -- and post-state. Prag is a [refined] postcondition or a contract-cases -- pragma. Result_Seen is set when the pragma mentions attribute 'Result - function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean; - -- Determine whether subprogram Subp_Id contains at least one IN OUT - -- formal parameter. - ------------------------------------------- -- Check_Result_And_Post_State_In_Pragma -- ------------------------------------------- @@ -5075,28 +5210,6 @@ package body Sem_Util is end if; end Check_Result_And_Post_State_In_Pragma; - -------------------------- - -- Has_In_Out_Parameter -- - -------------------------- - - function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean is - Formal : Entity_Id; - - begin - -- Traverse the formals looking for an IN OUT parameter - - Formal := First_Formal (Subp_Id); - while Present (Formal) loop - if Ekind (Formal) = E_In_Out_Parameter then - return True; - end if; - - Next_Formal (Formal); - end loop; - - return False; - end Has_In_Out_Parameter; - -- Local variables Items : constant Node_Id := Contract (Subp_Id); @@ -5176,10 +5289,10 @@ package body Sem_Util is null; -- Regardless of whether the function has postconditions or contract - -- cases, or whether they mention attribute 'Result, an IN OUT formal + -- cases, or whether they mention attribute 'Result, an [IN] OUT formal -- parameter is always treated as a result. - elsif Has_In_Out_Parameter (Spec_Id) then + elsif Has_Out_Or_In_Out_Parameter (Spec_Id) then null; -- The function has both a postcondition and contract cases and they do @@ -5596,6 +5709,13 @@ package body Sem_Util is if Ekind (State_Id) = E_Constant then null; + -- Overlays do not contribute to package state + + elsif Ekind (State_Id) = E_Variable + and then Present (Ultimate_Overlaid_Entity (State_Id)) + then + null; + -- Generate an error message of the form: -- body of package ... has unused hidden states @@ -6355,8 +6475,8 @@ package body Sem_Util is Is_Type_In_Pkg := Is_Package_Or_Generic_Package (B_Scope) and then - Nkind (Parent (Declaration_Node (First_Subtype (T)))) /= - N_Package_Body; + Parent_Kind (Declaration_Node (First_Subtype (T))) /= + N_Package_Body; while Present (Id) loop @@ -6374,8 +6494,8 @@ package body Sem_Util is and then (Is_Type_In_Pkg or else Is_Derived_Type (B_Type) or else Is_Primitive (Id)) - and then Nkind (Parent (Parent (Id))) - not in N_Formal_Subprogram_Declaration + and then Parent_Kind (Parent (Id)) + not in N_Formal_Subprogram_Declaration then Is_Prim := False; @@ -6446,7 +6566,7 @@ package body Sem_Util is -- appear in the target-specific extension to System. if No (Id) - and then B_Scope = RTU_Entity (System) + and then Is_RTU (B_Scope, System) and then Present_System_Aux then B_Scope := System_Aux_Id; @@ -6484,7 +6604,6 @@ package body Sem_Util is Remove (Op_List, Node (Second)); else - pragma Assert (False); raise Program_Error; end if; end if; @@ -6662,6 +6781,116 @@ package body Sem_Util is return N; end Compile_Time_Constraint_Error; + ---------------------------- + -- Compute_Returns_By_Ref -- + ---------------------------- + + procedure Compute_Returns_By_Ref (Func : Entity_Id) is + Typ : constant Entity_Id := Etype (Func); + Utyp : constant Entity_Id := Underlying_Type (Typ); + + begin + if Is_Limited_View (Typ) then + Set_Returns_By_Ref (Func); + + elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then + Set_Returns_By_Ref (Func); + end if; + end Compute_Returns_By_Ref; + + -------------------------------- + -- Collect_Types_In_Hierarchy -- + -------------------------------- + + function Collect_Types_In_Hierarchy + (Typ : Entity_Id; + Examine_Components : Boolean := False) return Elist_Id + is + Results : Elist_Id; + + procedure Process_Type (Typ : Entity_Id); + -- Collect type Typ if it satisfies function Predicate. Do so for its + -- parent type, base type, progenitor types, and any component types. + + ------------------ + -- Process_Type -- + ------------------ + + procedure Process_Type (Typ : Entity_Id) is + Comp : Entity_Id; + Iface_Elmt : Elmt_Id; + + begin + if not Is_Type (Typ) or else Error_Posted (Typ) then + return; + end if; + + -- Collect the current type if it satisfies the predicate + + if Predicate (Typ) then + Append_Elmt (Typ, Results); + end if; + + -- Process component types + + if Examine_Components then + + -- Examine components and discriminants + + if Is_Concurrent_Type (Typ) + or else Is_Incomplete_Or_Private_Type (Typ) + or else Is_Record_Type (Typ) + or else Has_Discriminants (Typ) + then + Comp := First_Component_Or_Discriminant (Typ); + + while Present (Comp) loop + Process_Type (Etype (Comp)); + + Next_Component_Or_Discriminant (Comp); + end loop; + + -- Examine array components + + elsif Ekind (Typ) = E_Array_Type then + Process_Type (Component_Type (Typ)); + end if; + end if; + + -- Examine parent type + + if Etype (Typ) /= Typ then + Process_Type (Etype (Typ)); + end if; + + -- Examine base type + + if Base_Type (Typ) /= Typ then + Process_Type (Base_Type (Typ)); + end if; + + -- Examine interfaces + + if Is_Record_Type (Typ) + and then Present (Interfaces (Typ)) + then + Iface_Elmt := First_Elmt (Interfaces (Typ)); + while Present (Iface_Elmt) loop + Process_Type (Node (Iface_Elmt)); + + Next_Elmt (Iface_Elmt); + end loop; + end if; + end Process_Type; + + -- Start of processing for Collect_Types_In_Hierarchy + + begin + Results := New_Elmt_List; + Process_Type (Typ); + return Results; + end Collect_Types_In_Hierarchy; + ----------------------- -- Conditional_Delay -- ----------------------- @@ -6873,19 +7102,30 @@ package body Sem_Util is ----------------------------- function Current_Entity_In_Scope (N : Name_Id) return Entity_Id is - E : Entity_Id; CS : constant Entity_Id := Current_Scope; - Transient_Case : constant Boolean := Scope_Is_Transient; + E : Entity_Id; begin E := Get_Name_Entity_Id (N); - while Present (E) - and then Scope (E) /= CS - and then (not Transient_Case or else Scope (E) /= Scope (CS)) - loop - E := Homonym (E); - end loop; + + if No (E) then + null; + + elsif Scope_Is_Transient then + while Present (E) loop + exit when Scope (E) = CS or else Scope (E) = Scope (CS); + + E := Homonym (E); + end loop; + + else + while Present (E) loop + exit when Scope (E) = CS; + + E := Homonym (E); + end loop; + end if; return E; end Current_Entity_In_Scope; @@ -6959,15 +7199,36 @@ package body Sem_Util is end Current_Subprogram; ------------------------------- + -- CW_Or_Has_Controlled_Part -- + ------------------------------- + + function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is + begin + return Is_Class_Wide_Type (T) or else Needs_Finalization (T); + end CW_Or_Has_Controlled_Part; + + ------------------------------- -- Deepest_Type_Access_Level -- ------------------------------- - function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is + function Deepest_Type_Access_Level + (Typ : Entity_Id; + Allow_Alt_Model : Boolean := True) return Uint + is begin if Ekind (Typ) = E_Anonymous_Access_Type and then not Is_Local_Anonymous_Access (Typ) and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration then + -- No_Dynamic_Accessibility_Checks override for alternative + -- accessibility model. + + if Allow_Alt_Model + and then No_Dynamic_Accessibility_Checks_Enabled (Typ) + then + return Type_Access_Level (Typ, Allow_Alt_Model); + end if; + -- Typ is the type of an Ada 2012 stand-alone object of an anonymous -- access type. @@ -6983,7 +7244,7 @@ package body Sem_Util is return UI_From_Int (Int'Last); else - return Type_Access_Level (Typ); + return Type_Access_Level (Typ, Allow_Alt_Model); end if; end Deepest_Type_Access_Level; @@ -6991,10 +7252,23 @@ package body Sem_Util is -- Defining_Entity -- --------------------- - function Defining_Entity - (N : Node_Id; - Empty_On_Errors : Boolean := False) return Entity_Id - is + function Defining_Entity (N : Node_Id) return Entity_Id is + Ent : constant Entity_Id := Defining_Entity_Or_Empty (N); + + begin + if Present (Ent) then + return Ent; + + else + raise Program_Error; + end if; + end Defining_Entity; + + ------------------------------ + -- Defining_Entity_Or_Empty -- + ------------------------------ + + function Defining_Entity_Or_Empty (N : Node_Id) return Entity_Id is begin case Nkind (N) is when N_Abstract_Subprogram_Declaration @@ -7093,13 +7367,9 @@ package body Sem_Util is return Entity (Identifier (N)); when others => - if Empty_On_Errors then - return Empty; - end if; - - raise Program_Error; + return Empty; end case; - end Defining_Entity; + end Defining_Entity_Or_Empty; -------------------------- -- Denotes_Discriminant -- @@ -7139,8 +7409,8 @@ package body Sem_Util is ------------------------- function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is - function Is_Renaming (N : Node_Id) return Boolean; - -- Return true if N names a renaming entity + function Is_Object_Renaming (N : Node_Id) return Boolean; + -- Return true if N names an object renaming entity function Is_Valid_Renaming (N : Node_Id) return Boolean; -- For renamings, return False if the prefix of any dereference within @@ -7148,185 +7418,144 @@ package body Sem_Util is -- renamed object_name contains references to variables or calls on -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3)) - ----------------- - -- Is_Renaming -- - ----------------- + ------------------------ + -- Is_Object_Renaming -- + ------------------------ - function Is_Renaming (N : Node_Id) return Boolean is + function Is_Object_Renaming (N : Node_Id) return Boolean is begin - if not Is_Entity_Name (N) then - return False; - end if; - - case Ekind (Entity (N)) is - when E_Variable | E_Constant => - return Present (Renamed_Object (Entity (N))); - - when E_Exception - | E_Function - | E_Generic_Function - | E_Generic_Package - | E_Generic_Procedure - | E_Operator - | E_Package - | E_Procedure - => - return Present (Renamed_Entity (Entity (N))); - - when others => - return False; - end case; - end Is_Renaming; + return Is_Entity_Name (N) + and then Ekind (Entity (N)) in E_Variable | E_Constant + and then Present (Renamed_Object (Entity (N))); + end Is_Object_Renaming; ----------------------- -- Is_Valid_Renaming -- ----------------------- function Is_Valid_Renaming (N : Node_Id) return Boolean is - function Check_Renaming (N : Node_Id) return Boolean; - -- Recursive function used to traverse all the prefixes of N - - -------------------- - -- Check_Renaming -- - -------------------- + begin + if Is_Object_Renaming (N) + and then not Is_Valid_Renaming (Renamed_Entity (Entity (N))) + then + return False; + end if; - function Check_Renaming (N : Node_Id) return Boolean is - begin - if Is_Renaming (N) - and then not Check_Renaming (Renamed_Entity (Entity (N))) - then - return False; - end if; + -- Check if any expression within the renamed object_name contains no + -- references to variables nor calls on nonstatic functions. - if Nkind (N) = N_Indexed_Component then - declare - Indx : Node_Id; + if Nkind (N) = N_Indexed_Component then + declare + Indx : Node_Id; - begin - Indx := First (Expressions (N)); - while Present (Indx) loop - if not Is_OK_Static_Expression (Indx) then - return False; - end if; + begin + Indx := First (Expressions (N)); + while Present (Indx) loop + if not Is_OK_Static_Expression (Indx) then + return False; + end if; - Next_Index (Indx); - end loop; - end; - end if; + Next_Index (Indx); + end loop; + end; - if Has_Prefix (N) then - declare - P : constant Node_Id := Prefix (N); + elsif Nkind (N) = N_Slice then + declare + Rng : constant Node_Id := Discrete_Range (N); + begin + -- Bounds specified as a range - begin - if Nkind (N) = N_Explicit_Dereference - and then Is_Variable (P) - then + if Nkind (Rng) = N_Range then + if not Is_OK_Static_Range (Rng) then return False; + end if; - elsif Is_Entity_Name (P) - and then Ekind (Entity (P)) = E_Function - then - return False; + -- Bounds specified as a constrained subtype indication - elsif Nkind (P) = N_Function_Call then + elsif Nkind (Rng) = N_Subtype_Indication then + if not Is_OK_Static_Range + (Range_Expression (Constraint (Rng))) + then return False; end if; - -- Recursion to continue traversing the prefix of the - -- renaming expression + -- Bounds specified as a subtype name - return Check_Renaming (P); - end; - end if; + elsif not Is_OK_Static_Expression (Rng) then + return False; + end if; + end; + end if; - return True; - end Check_Renaming; + if Has_Prefix (N) then + declare + P : constant Node_Id := Prefix (N); - -- Start of processing for Is_Valid_Renaming + begin + if Nkind (N) = N_Explicit_Dereference + and then Is_Variable (P) + then + return False; - begin - return Check_Renaming (N); - end Is_Valid_Renaming; + elsif Is_Entity_Name (P) + and then Ekind (Entity (P)) = E_Function + then + return False; - -- Local variables + elsif Nkind (P) = N_Function_Call then + return False; + end if; - Obj1 : Node_Id := A1; - Obj2 : Node_Id := A2; + -- Recursion to continue traversing the prefix of the + -- renaming expression + + return Is_Valid_Renaming (P); + end; + end if; + + return True; + end Is_Valid_Renaming; -- Start of processing for Denotes_Same_Object begin - -- Both names statically denote the same stand-alone object or parameter - -- (RM 6.4.1(6.5/3)) + -- Both names statically denote the same stand-alone object or + -- parameter (RM 6.4.1(6.6/3)). - if Is_Entity_Name (Obj1) - and then Is_Entity_Name (Obj2) - and then Entity (Obj1) = Entity (Obj2) + if Is_Entity_Name (A1) + and then Is_Entity_Name (A2) + and then Entity (A1) = Entity (A2) then return True; - end if; - - -- For renamings, the prefix of any dereference within the renamed - -- object_name is not a variable, and any expression within the - -- renamed object_name contains no references to variables nor - -- calls on nonstatic functions (RM 6.4.1(6.10/3)). - - if Is_Renaming (Obj1) then - if Is_Valid_Renaming (Obj1) then - Obj1 := Renamed_Entity (Entity (Obj1)); - else - return False; - end if; - end if; - - if Is_Renaming (Obj2) then - if Is_Valid_Renaming (Obj2) then - Obj2 := Renamed_Entity (Entity (Obj2)); - else - return False; - end if; - end if; - - -- No match if not same node kind (such cases are handled by - -- Denotes_Same_Prefix) - - if Nkind (Obj1) /= Nkind (Obj2) then - return False; - - -- After handling valid renamings, one of the two names statically - -- denoted a renaming declaration whose renamed object_name is known - -- to denote the same object as the other (RM 6.4.1(6.10/3)) - - elsif Is_Entity_Name (Obj1) then - if Is_Entity_Name (Obj2) then - return Entity (Obj1) = Entity (Obj2); - else - return False; - end if; -- Both names are selected_components, their prefixes are known to -- denote the same object, and their selector_names denote the same - -- component (RM 6.4.1(6.6/3)). + -- component (RM 6.4.1(6.7/3)). - elsif Nkind (Obj1) = N_Selected_Component then - return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) + elsif Nkind (A1) = N_Selected_Component + and then Nkind (A2) = N_Selected_Component + then + return Denotes_Same_Object (Prefix (A1), Prefix (A2)) and then - Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2)); + Entity (Selector_Name (A1)) = Entity (Selector_Name (A2)); -- Both names are dereferences and the dereferenced names are known to - -- denote the same object (RM 6.4.1(6.7/3)) + -- denote the same object (RM 6.4.1(6.8/3)). - elsif Nkind (Obj1) = N_Explicit_Dereference then - return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)); + elsif Nkind (A1) = N_Explicit_Dereference + and then Nkind (A2) = N_Explicit_Dereference + then + return Denotes_Same_Object (Prefix (A1), Prefix (A2)); -- Both names are indexed_components, their prefixes are known to denote -- the same object, and each of the pairs of corresponding index values -- are either both static expressions with the same static value or both - -- names that are known to denote the same object (RM 6.4.1(6.8/3)) + -- names that are known to denote the same object (RM 6.4.1(6.9/3)). - elsif Nkind (Obj1) = N_Indexed_Component then - if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then + elsif Nkind (A1) = N_Indexed_Component + and then Nkind (A2) = N_Indexed_Component + then + if not Denotes_Same_Object (Prefix (A1), Prefix (A2)) then return False; else declare @@ -7334,8 +7563,8 @@ package body Sem_Util is Indx2 : Node_Id; begin - Indx1 := First (Expressions (Obj1)); - Indx2 := First (Expressions (Obj2)); + Indx1 := First (Expressions (A1)); + Indx2 := First (Expressions (A2)); while Present (Indx1) loop -- Indexes must denote the same static value or same object @@ -7362,33 +7591,49 @@ package body Sem_Util is -- Both names are slices, their prefixes are known to denote the same -- object, and the two slices have statically matching index constraints - -- (RM 6.4.1(6.9/3)) + -- (RM 6.4.1(6.10/3)). - elsif Nkind (Obj1) = N_Slice - and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) + elsif Nkind (A1) = N_Slice + and then Nkind (A2) = N_Slice then - declare - Lo1, Lo2, Hi1, Hi2 : Node_Id; - - begin - Get_Index_Bounds (Etype (Obj1), Lo1, Hi1); - Get_Index_Bounds (Etype (Obj2), Lo2, Hi2); + if not Denotes_Same_Object (Prefix (A1), Prefix (A2)) then + return False; + else + declare + Lo1, Lo2, Hi1, Hi2 : Node_Id; - -- Check whether bounds are statically identical. There is no - -- attempt to detect partial overlap of slices. + begin + Get_Index_Bounds (Discrete_Range (A1), Lo1, Hi1); + Get_Index_Bounds (Discrete_Range (A2), Lo2, Hi2); + + -- Check whether bounds are statically identical. There is no + -- attempt to detect partial overlap of slices. + + return Is_OK_Static_Expression (Lo1) + and then Is_OK_Static_Expression (Lo2) + and then Is_OK_Static_Expression (Hi1) + and then Is_OK_Static_Expression (Hi2) + and then Expr_Value (Lo1) = Expr_Value (Lo2) + and then Expr_Value (Hi1) = Expr_Value (Hi2); + end; + end if; - return Denotes_Same_Object (Lo1, Lo2) - and then - Denotes_Same_Object (Hi1, Hi2); - end; + -- One of the two names statically denotes a renaming declaration whose + -- renamed object_name is known to denote the same object as the other; + -- the prefix of any dereference within the renamed object_name is not a + -- variable, and any expression within the renamed object_name contains + -- no references to variables nor calls on nonstatic functions (RM + -- 6.4.1(6.11/3)). - -- In the recursion, literals appear as indexes + elsif Is_Object_Renaming (A1) + and then Is_Valid_Renaming (A1) + then + return Denotes_Same_Object (Renamed_Entity (Entity (A1)), A2); - elsif Nkind (Obj1) = N_Integer_Literal - and then - Nkind (Obj2) = N_Integer_Literal + elsif Is_Object_Renaming (A2) + and then Is_Valid_Renaming (A2) then - return Intval (Obj1) = Intval (Obj2); + return Denotes_Same_Object (A1, Renamed_Entity (Entity (A2))); else return False; @@ -7793,11 +8038,7 @@ package body Sem_Util is Current_Node := Parent (Current_Node); end loop; - if Nkind (Current_Node) /= N_Compilation_Unit then - return Empty; - else - return Current_Node; - end if; + return Current_Node; end Enclosing_Comp_Unit_Node; -------------------------- @@ -8462,7 +8703,7 @@ package body Sem_Util is -- will be detected. Any_Type insures that no cascaded errors will occur else - Set_Ekind (Def_Id, E_Void); + Mutate_Ekind (Def_Id, E_Void); Set_Etype (Def_Id, Any_Type); end if; @@ -9280,6 +9521,10 @@ package body Sem_Util is Ent : out Entity_Id; Off : out Boolean) is + pragma Assert + (Nkind (N) = N_Attribute_Definition_Clause + and then Chars (N) = Name_Address); + Expr : Node_Id; begin @@ -9299,61 +9544,68 @@ package body Sem_Util is Ent := Empty; Off := False; - if Nkind (N) = N_Attribute_Definition_Clause - and then Chars (N) = Name_Address - then - Expr := Expression (N); + Expr := Expression (N); - -- This loop checks the form of the expression for Y'Address, - -- using recursion to deal with intermediate constants. + -- This loop checks the form of the expression for Y'Address, using + -- recursion to deal with intermediate constants. - loop - -- Check for Y'Address + loop + -- Check for Y'Address - if Nkind (Expr) = N_Attribute_Reference - and then Attribute_Name (Expr) = Name_Address - then - Expr := Prefix (Expr); - exit; + if Nkind (Expr) = N_Attribute_Reference + and then Attribute_Name (Expr) = Name_Address + then + Expr := Prefix (Expr); + exit; - -- Check for Const where Const is a constant entity + -- Check for Const where Const is a constant entity - elsif Is_Entity_Name (Expr) - and then Ekind (Entity (Expr)) = E_Constant - then - Expr := Constant_Value (Entity (Expr)); + elsif Is_Entity_Name (Expr) + and then Ekind (Entity (Expr)) = E_Constant + then + Expr := Constant_Value (Entity (Expr)); - -- Anything else does not need checking + -- Anything else does not need checking - else - return; - end if; - end loop; + else + return; + end if; + end loop; - -- This loop checks the form of the prefix for an entity, using - -- recursion to deal with intermediate components. + -- This loop checks the form of the prefix for an entity, using + -- recursion to deal with intermediate components. - loop - -- Check for Y where Y is an entity + loop + -- Check for Y where Y is an entity - if Is_Entity_Name (Expr) then - Ent := Entity (Expr); - return; + if Is_Entity_Name (Expr) then + Ent := Entity (Expr); - -- Check for components + -- If expansion is disabled, then we might see an entity of a + -- protected component or of a discriminant of a concurrent unit. + -- Ignore such entities, because further warnings for overlays + -- expect this routine to only collect entities of entire objects. - elsif Nkind (Expr) in N_Selected_Component | N_Indexed_Component - then - Expr := Prefix (Expr); - Off := True; + if Ekind (Ent) in E_Component | E_Discriminant then + pragma Assert + (not Expander_Active + and then Is_Concurrent_Type (Scope (Ent))); + Ent := Empty; + end if; + return; - -- Anything else does not need checking + -- Check for components - else - return; - end if; - end loop; - end if; + elsif Nkind (Expr) in N_Selected_Component | N_Indexed_Component then + Expr := Prefix (Expr); + Off := True; + + -- Anything else does not need checking + + else + return; + end if; + end loop; end Find_Overlaid_Entity; ------------------------- @@ -9899,6 +10151,18 @@ package body Sem_Util is Discrim_Value : Node_Id; Discrim_Value_Subtype : Node_Id; Discrim_Value_Status : Discriminant_Value_Status := Bad; + + function OK_Scope_For_Discrim_Value_Error_Messages return Boolean is + (Scope (Original_Record_Component + (Entity (First (Choices (Assoc))))) = Typ); + -- Used to avoid generating error messages having a source position + -- which refers to somewhere (e.g., a discriminant value in a derived + -- tagged type declaration) unrelated to the offending construct. This + -- is required for correctness - clients of Gather_Components such as + -- Sem_Ch3.Create_Constrained_Components depend on this function + -- returning True while processing semantically correct examples; + -- generating an error message in this case would be wrong. + begin Report_Errors := False; @@ -10043,7 +10307,7 @@ package body Sem_Util is then Discrim_Value_Status := Static_Expr; else - if Ada_Version >= Ada_2020 then + if Ada_Version >= Ada_2022 then if Original_Node (Discrim_Value) /= Discrim_Value and then Nkind (Discrim_Value) = N_Type_Conversion and then Etype (Original_Node (Discrim_Value)) @@ -10082,15 +10346,13 @@ package body Sem_Util is -- components are being gathered for an aggregate, in which case -- the caller must check Report_Errors. -- - -- In Ada 2020 the above rules are relaxed. A nonstatic governing + -- In Ada 2022 the above rules are relaxed. A nonstatic governing -- discriminant is OK as long as it has a static subtype and -- every value of that subtype (and there must be at least one) -- selects the same variant. - if Scope (Original_Record_Component - ((Entity (First (Choices (Assoc)))))) = Typ - then - if Ada_Version >= Ada_2020 then + if OK_Scope_For_Discrim_Value_Error_Messages then + if Ada_Version >= Ada_2022 then Error_Msg_FE ("value for discriminant & must be static or " & "discriminant's nominal subtype must be static " & @@ -10208,10 +10470,12 @@ package body Sem_Util is (Subset => Discrim_Value_Subtype_Intervals, Of_Set => Variant_Intervals) then - Error_Msg_NE - ("no single variant is associated with all values of " & - "the subtype of discriminant value &", - Discrim_Value, Discrim); + if OK_Scope_For_Discrim_Value_Error_Messages then + Error_Msg_NE + ("no single variant is associated with all values of " & + "the subtype of discriminant value &", + Discrim_Value, Discrim); + end if; Report_Errors := True; return; end if; @@ -10651,22 +10915,26 @@ package body Sem_Util is when E_Class_Wide_Type => return Get_Fullest_View (Root_Type (E), Include_PAT); - when E_Class_Wide_Subtype => + when E_Class_Wide_Subtype => if Present (Equivalent_Type (E)) then return Get_Fullest_View (Equivalent_Type (E), Include_PAT); elsif Present (Cloned_Subtype (E)) then return Get_Fullest_View (Cloned_Subtype (E), Include_PAT); end if; - when E_Protected_Type | E_Protected_Subtype - | E_Task_Type | E_Task_Subtype => + when E_Protected_Subtype + | E_Protected_Type + | E_Task_Subtype + | E_Task_Type + => if Present (Corresponding_Record_Type (E)) then return Get_Fullest_View (Corresponding_Record_Type (E), Include_PAT); end if; when E_Access_Protected_Subprogram_Type - | E_Anonymous_Access_Protected_Subprogram_Type => + | E_Anonymous_Access_Protected_Subprogram_Type + => if Present (Equivalent_Type (E)) then return Get_Fullest_View (Equivalent_Type (E), Include_PAT); end if; @@ -10822,6 +11090,23 @@ package body Sem_Util is end if; end Get_Index_Bounds; + function Get_Index_Bounds + (N : Node_Id; + Use_Full_View : Boolean := False) return Range_Nodes is + Result : Range_Nodes; + begin + Get_Index_Bounds (N, Result.First, Result.Last, Use_Full_View); + return Result; + end Get_Index_Bounds; + + function Get_Index_Bounds + (N : Node_Id; + Use_Full_View : Boolean := False) return Range_Values is + Nodes : constant Range_Nodes := Get_Index_Bounds (N, Use_Full_View); + begin + return (Expr_Value (Nodes.First), Expr_Value (Nodes.Last)); + end Get_Index_Bounds; + ----------------------------- -- Get_Interfacing_Aspects -- ----------------------------- @@ -11401,12 +11686,13 @@ package body Sem_Util is -- Has_Access_Values -- ----------------------- - function Has_Access_Values (T : Entity_Id) return Boolean is + function Has_Access_Values (T : Entity_Id) return Boolean + is Typ : constant Entity_Id := Underlying_Type (T); begin -- Case of a private type which is not completed yet. This can only - -- happen in the case of a generic format type appearing directly, or + -- happen in the case of a generic formal type appearing directly, or -- as a component of the type to which this function is being applied -- at the top level. Return False in this case, since we certainly do -- not know that the type contains access types. @@ -11548,7 +11834,7 @@ package body Sem_Util is if Default = Known_Compatible or else (Etype (Obj) = Etype (Expr) - and then (Unknown_Alignment (Obj) + and then (not Known_Alignment (Obj) or else Alignment (Obj) = Alignment (Etype (Obj)))) then @@ -11651,22 +11937,23 @@ package body Sem_Util is Set_Result (Known_Incompatible); end if; - -- See if Expr is an object with known alignment + -- See if Expr is an object with known alignment elsif Is_Entity_Name (Expr) and then Known_Alignment (Entity (Expr)) then + Offs := Uint_0; ExpA := Alignment (Entity (Expr)); - -- Otherwise, we can use the alignment of the type of - -- Expr given that we already checked for - -- discombobulating rep clauses for the cases of indexed - -- and selected components above. + -- Otherwise, we can use the alignment of the type of Expr + -- given that we already checked for discombobulating rep + -- clauses for the cases of indexed and selected components + -- above. elsif Known_Alignment (Etype (Expr)) then ExpA := Alignment (Etype (Expr)); - -- Otherwise the alignment is unknown + -- Otherwise the alignment is unknown else Set_Result (Default); @@ -11678,28 +11965,28 @@ package body Sem_Util is Set_Result (Known_Incompatible); end if; - -- If Expr is not a piece of a larger object, see if size - -- is given. If so, check that it is not too small for the - -- required alignment. + -- If Expr is a component or an entire object with a known + -- alignment, then we are fine. Otherwise, if its size is + -- known, it must be big enough for the required alignment. if Offs /= No_Uint then null; - -- See if Expr is an object with known size + -- See if Expr is an object with known size elsif Is_Entity_Name (Expr) and then Known_Static_Esize (Entity (Expr)) then SizA := Esize (Entity (Expr)); - -- Otherwise, we check the object size of the Expr type + -- Otherwise, we check the object size of the Expr type elsif Known_Static_Esize (Etype (Expr)) then SizA := Esize (Etype (Expr)); end if; -- If we got a size, see if it is a multiple of the Obj - -- alignment, if not, then the alignment cannot be + -- alignment; if not, then the alignment cannot be -- acceptable, since the size is always a multiple of the -- alignment. @@ -11737,25 +12024,24 @@ package body Sem_Util is -- where we do not know the alignment of Obj. if Known_Alignment (Entity (Expr)) - and then UI_To_Int (Alignment (Entity (Expr))) < - Ttypes.Maximum_Alignment + and then Alignment (Entity (Expr)) < Ttypes.Maximum_Alignment then Set_Result (Unknown); - -- Now check size of Expr object. Any size that is not an - -- even multiple of Maximum_Alignment is also worrisome - -- since it may cause the alignment of the object to be less - -- than the alignment of the type. + -- Now check size of Expr object. Any size that is not an even + -- multiple of Maximum_Alignment is also worrisome since it + -- may cause the alignment of the object to be less than the + -- alignment of the type. elsif Known_Static_Esize (Entity (Expr)) and then - (UI_To_Int (Esize (Entity (Expr))) mod - (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)) + Esize (Entity (Expr)) mod + (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit) /= 0 then Set_Result (Unknown); - -- Otherwise same type is decisive + -- Otherwise same type is decisive else Set_Result (Known_Compatible); @@ -11793,7 +12079,7 @@ package body Sem_Util is -- do it when there is an address clause since we can do more if the -- alignment is known. - if Unknown_Alignment (Obj) then + if not Known_Alignment (Obj) and then Known_Alignment (Etype (Obj)) then Set_Alignment (Obj, Alignment (Etype (Obj))); end if; @@ -11827,7 +12113,6 @@ package body Sem_Util is function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is begin return Has_Discriminants (Typ) - and then Present (First_Discriminant (Typ)) and then Present (Discriminant_Default_Value (First_Discriminant (Typ))); end Has_Defaulted_Discriminants; @@ -12444,6 +12729,84 @@ package body Sem_Util is return False; end Has_Fully_Default_Initializing_DIC_Pragma; + --------------------------------- + -- Has_Inferable_Discriminants -- + --------------------------------- + + function Has_Inferable_Discriminants (N : Node_Id) return Boolean is + + function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean; + -- Determines whether the left-most prefix of a selected component is a + -- formal parameter in a subprogram. Assumes N is a selected component. + + -------------------------------- + -- Prefix_Is_Formal_Parameter -- + -------------------------------- + + function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is + Sel_Comp : Node_Id; + + begin + -- Move to the left-most prefix by climbing up the tree + + Sel_Comp := N; + while Present (Parent (Sel_Comp)) + and then Nkind (Parent (Sel_Comp)) = N_Selected_Component + loop + Sel_Comp := Parent (Sel_Comp); + end loop; + + return Is_Formal (Entity (Prefix (Sel_Comp))); + end Prefix_Is_Formal_Parameter; + + -- Start of processing for Has_Inferable_Discriminants + + begin + -- For selected components, the subtype of the selector must be a + -- constrained Unchecked_Union. If the component is subject to a + -- per-object constraint, then the enclosing object must have inferable + -- discriminants. + + if Nkind (N) = N_Selected_Component then + if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then + + -- A small hack. If we have a per-object constrained selected + -- component of a formal parameter, return True since we do not + -- know the actual parameter association yet. + + if Prefix_Is_Formal_Parameter (N) then + return True; + + -- Otherwise, check the enclosing object and the selector + + else + return Has_Inferable_Discriminants (Prefix (N)) + and then Has_Inferable_Discriminants (Selector_Name (N)); + end if; + + -- The call to Has_Inferable_Discriminants will determine whether + -- the selector has a constrained Unchecked_Union nominal type. + + else + return Has_Inferable_Discriminants (Selector_Name (N)); + end if; + + -- A qualified expression has inferable discriminants if its subtype + -- mark is a constrained Unchecked_Union subtype. + + elsif Nkind (N) = N_Qualified_Expression then + return Is_Unchecked_Union (Etype (Subtype_Mark (N))) + and then Is_Constrained (Etype (Subtype_Mark (N))); + + -- For all other names, it is sufficient to have a constrained + -- Unchecked_Union nominal subtype. + + else + return Is_Unchecked_Union (Base_Type (Etype (N))) + and then Is_Constrained (Etype (N)); + end if; + end Has_Inferable_Discriminants; + -------------------- -- Has_Infinities -- -------------------- @@ -12944,6 +13307,44 @@ package body Sem_Util is and then Nkind (Node (First_Elmt (Constits))) = N_Null; end Has_Null_Refinement; + ------------------------------------------ + -- Has_Nonstatic_Class_Wide_Pre_Or_Post -- + ------------------------------------------ + + function Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post + (Subp : Entity_Id) return Boolean + is + Disp_Type : constant Entity_Id := Find_Dispatching_Type (Subp); + Prag : Node_Id; + Pragma_Arg : Node_Id; + + begin + if Present (Disp_Type) + and then Is_Abstract_Type (Disp_Type) + and then Present (Contract (Subp)) + then + Prag := Pre_Post_Conditions (Contract (Subp)); + + while Present (Prag) loop + if Pragma_Name (Prag) in Name_Precondition | Name_Postcondition + and then Class_Present (Prag) + then + Pragma_Arg := + Nlists.First + (Pragma_Argument_Associations (Prag)); + + if not Is_Static_Expression (Expression (Pragma_Arg)) then + return True; + end if; + end if; + + Prag := Next_Pragma (Prag); + end loop; + end if; + + return False; + end Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post; + ------------------------------- -- Has_Overriding_Initialize -- ------------------------------- @@ -13706,7 +14107,7 @@ package body Sem_Util is elsif Is_Record_Type (Typ) then Comp := First_Component (Typ); while Present (Comp) loop - if Is_Volatile_Object (Comp) then + if Is_Volatile_Object_Ref (Comp) then return True; end if; @@ -14080,7 +14481,9 @@ package body Sem_Util is -- In_Pre_Post_Condition -- --------------------------- - function In_Pre_Post_Condition (N : Node_Id) return Boolean is + function In_Pre_Post_Condition + (N : Node_Id; Class_Wide_Only : Boolean := False) return Boolean + is Par : Node_Id; Prag : Node_Id := Empty; Prag_Id : Pragma_Id; @@ -14106,13 +14509,24 @@ package body Sem_Util is if Present (Prag) then Prag_Id := Get_Pragma_Id (Prag); - return - Prag_Id = Pragma_Post - or else Prag_Id = Pragma_Post_Class - or else Prag_Id = Pragma_Postcondition - or else Prag_Id = Pragma_Pre - or else Prag_Id = Pragma_Pre_Class - or else Prag_Id = Pragma_Precondition; + if Class_Wide_Only then + return + Prag_Id = Pragma_Post_Class + or else Prag_Id = Pragma_Pre_Class + or else (Class_Present (Prag) + and then (Prag_Id = Pragma_Post + or else Prag_Id = Pragma_Postcondition + or else Prag_Id = Pragma_Pre + or else Prag_Id = Pragma_Precondition)); + else + return + Prag_Id = Pragma_Post + or else Prag_Id = Pragma_Post_Class + or else Prag_Id = Pragma_Postcondition + or else Prag_Id = Pragma_Pre + or else Prag_Id = Pragma_Pre_Class + or else Prag_Id = Pragma_Precondition; + end if; -- Otherwise the node is not enclosed by a pre/postcondition pragma @@ -14337,6 +14751,17 @@ package body Sem_Util is when N_Function_Call => if not In_Function_Call then In_Function_Call := True; + + -- When the function return type has implicit dereference + -- specified we know it cannot directly contribute to the + -- return value. + + if Present (Etype (Par)) + and then Has_Implicit_Dereference + (Get_Full_View (Etype (Par))) + then + return False; + end if; else return False; end if; @@ -14424,6 +14849,8 @@ package body Sem_Util is -------------------------------- function Incomplete_Or_Partial_View (Id : Entity_Id) return Entity_Id is + S : constant Entity_Id := Scope (Id); + function Inspect_Decls (Decls : List_Id; Taft : Boolean := False) return Entity_Id; @@ -14492,7 +14919,13 @@ package body Sem_Util is begin -- Deferred constant or incomplete type case - Prev := Current_Entity_In_Scope (Id); + Prev := Current_Entity (Id); + + while Present (Prev) loop + exit when Scope (Prev) = S; + + Prev := Homonym (Prev); + end loop; if Present (Prev) and then (Is_Incomplete_Type (Prev) or else Ekind (Prev) = E_Constant) @@ -14504,18 +14937,11 @@ package body Sem_Util is -- Private or Taft amendment type case - declare - Pkg : constant Entity_Id := Scope (Id); - Pkg_Decl : Node_Id := Pkg; - - begin - if Present (Pkg) - and then Is_Package_Or_Generic_Package (Pkg) - then - while Nkind (Pkg_Decl) /= N_Package_Specification loop - Pkg_Decl := Parent (Pkg_Decl); - end loop; + if Present (S) and then Is_Package_Or_Generic_Package (S) then + declare + Pkg_Decl : constant Node_Id := Package_Specification (S); + begin -- It is knows that Typ has a private view, look for it in the -- visible declarations of the enclosing scope. A special case -- of this is when the two views have been exchanged - the full @@ -14536,11 +14962,11 @@ package body Sem_Util is -- Taft amendment type. The incomplete view should be located in -- the private declarations of the enclosing scope. - elsif In_Package_Body (Pkg) then + elsif In_Package_Body (S) then return Inspect_Decls (Private_Declarations (Pkg_Decl), True); end if; - end if; - end; + end; + end if; -- The type has no incomplete or private view @@ -14616,6 +15042,12 @@ package body Sem_Util is return No_Uint; end if; + -- Do not attempt to compute offsets within multi-dimensional arrays + + if Present (Next_Index (Ind)) then + return No_Uint; + end if; + if Nkind (Ind) = N_Subtype_Indication then Ind := Constraint (Ind); @@ -14632,7 +15064,7 @@ package body Sem_Util is -- Return the scaled offset - return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound ((Ind)))); + return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound (Ind))); end Indexed_Component_Bit_Offset; ----------------------------- @@ -14867,8 +15299,6 @@ package body Sem_Util is Get_Next_Interp (I, It); end loop; - End_Interp_List; - else -- Prefix is unambiguous: mark the original prefix (which might -- Come_From_Source) as a reference, since the new (relocated) one @@ -15198,8 +15628,9 @@ package body Sem_Util is function Is_Access_Variable (E : Entity_Id) return Boolean is begin - return Is_Access_Object_Type (E) - and then not Is_Access_Constant (E); + return Is_Access_Type (E) + and then not Is_Access_Constant (E) + and then Ekind (Directly_Designated_Type (E)) /= E_Subprogram_Type; end Is_Access_Variable; ----------------------------- @@ -15251,7 +15682,9 @@ package body Sem_Util is when N_Parameter_Association => return N = Explicit_Actual_Parameter (Parent (N)); - when N_Subprogram_Call => + when N_Entry_Call_Statement + | N_Subprogram_Call + => return Is_List_Member (N) and then List_Containing (N) = Parameter_Associations (Parent (N)); @@ -15312,6 +15745,15 @@ package body Sem_Util is -- statement is aliased if its type is immutably limited. or else (Is_Return_Object (E) + and then Is_Limited_View (Etype (E))) + + -- The current instance of a limited type is aliased, so + -- we want to allow uses of T'Access in the init proc for + -- a limited type T. However, we don't want to mark the formal + -- parameter as being aliased since that could impact callers. + + or else (Is_Formal (E) + and then Chars (E) = Name_uInit and then Is_Limited_View (Etype (E))); elsif Nkind (Obj) = N_Selected_Component then @@ -15328,7 +15770,7 @@ package body Sem_Util is return Is_Tagged_Type (Etype (Obj)) and then Is_Aliased_View (Expression (Obj)); - -- Ada 202x AI12-0228 + -- Ada 2022 AI12-0228 elsif Nkind (Obj) = N_Qualified_Expression and then Ada_Version >= Ada_2012 @@ -15698,18 +16140,32 @@ package body Sem_Util is Aspect_Spec_1, Aspect_Spec_2 : Node_Id) return Boolean is function Names_Match (Nm1, Nm2 : Node_Id) return Boolean; + + ----------------- + -- Names_Match -- + ----------------- + function Names_Match (Nm1, Nm2 : Node_Id) return Boolean is begin if Nkind (Nm1) /= Nkind (Nm2) then return False; + -- This may be too restrictive given that visibility + -- may allow an identifier in one case and an expanded + -- name in the other. end if; case Nkind (Nm1) is when N_Identifier => return Name_Equals (Chars (Nm1), Chars (Nm2)); + when N_Expanded_Name => - return Names_Match (Prefix (Nm1), Prefix (Nm2)) - and then Names_Match (Selector_Name (Nm1), - Selector_Name (Nm2)); + -- An inherited operation has the same name as its + -- ancestor, but they may have different scopes. + -- This may be too permissive for Iterator_Element, which + -- is intended to be identical in parent and derived type. + + return Names_Match (Selector_Name (Nm1), + Selector_Name (Nm2)); + when N_Empty => return True; -- needed for Aggregate aspect checking @@ -15737,8 +16193,7 @@ package body Sem_Util is when Aspect_Default_Iterator | Aspect_Iterator_Element | Aspect_Constant_Indexing - | Aspect_Variable_Indexing - | Aspect_Implicit_Dereference => + | Aspect_Variable_Indexing => declare Item_1 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_1); Item_2 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_2); @@ -15754,6 +16209,13 @@ package body Sem_Util is Expression (Item_2)); end; + -- A confirming aspect for Implicit_Derenfence on a derived type + -- has already been checked in Analyze_Aspect_Implicit_Dereference, + -- including the presence of renamed discriminants. + + when Aspect_Implicit_Dereference => + return True; + -- one of a kind when Aspect_Aggregate => declare @@ -15810,11 +16272,9 @@ package body Sem_Util is function Is_Concurrent_Interface (T : Entity_Id) return Boolean is begin - return Is_Interface (T) - and then - (Is_Protected_Interface (T) - or else Is_Synchronized_Interface (T) - or else Is_Task_Interface (T)); + return Is_Protected_Interface (T) + or else Is_Synchronized_Interface (T) + or else Is_Task_Interface (T); end Is_Concurrent_Interface; ----------------------- @@ -16894,8 +17354,8 @@ package body Sem_Util is Nkind (E) = N_Function_Call and then not Configurable_Run_Time_Mode and then Nkind (Original_Node (E)) = N_Attribute_Reference - and then (Entity (Name (E)) = RTE (RE_Get_Ceiling) - or else Entity (Name (E)) = RTE (RO_PE_Get_Ceiling)); + and then (Is_RTE (Entity (Name (E)), RE_Get_Ceiling) + or else Is_RTE (Entity (Name (E)), RO_PE_Get_Ceiling)); end Is_Expanded_Priority_Attribute; ---------------------------- @@ -17050,7 +17510,8 @@ package body Sem_Util is function Is_Full_Access_Object (N : Node_Id) return Boolean is begin - return Is_Atomic_Object (N) or else Is_Volatile_Full_Access_Object (N); + return Is_Atomic_Object (N) + or else Is_Volatile_Full_Access_Object_Ref (N); end Is_Full_Access_Object; ------------------------------- @@ -17139,9 +17600,7 @@ package body Sem_Util is -- Record types elsif Is_Record_Type (Typ) then - if Has_Discriminants (Typ) - and then - Present (Discriminant_Default_Value (First_Discriminant (Typ))) + if Has_Defaulted_Discriminants (Typ) and then Is_Fully_Initialized_Variant (Typ) then return True; @@ -17685,7 +18144,9 @@ package body Sem_Util is Ent : constant Entity_Id := Entity (Expr); Sub : constant Entity_Id := Enclosing_Subprogram (Ent); begin - if Ekind (Ent) not in E_Variable | E_In_Out_Parameter then + if Ekind (Ent) + not in E_Variable | E_In_Out_Parameter | E_Out_Parameter + then return False; else return Present (Sub) and then Sub = Current_Subprogram; @@ -18174,10 +18635,10 @@ package body Sem_Util is when N_Function_Call => - -- Ada 2020 (AI12-0175): Calls to certain functions that are + -- Ada 2022 (AI12-0175): Calls to certain functions that are -- essentially unchecked conversions are preelaborable. - if Ada_Version >= Ada_2020 + if Ada_Version >= Ada_2022 and then Nkind (Expr) = N_Function_Call and then Is_Entity_Name (Name (Expr)) and then Is_Preelaborable_Function (Entity (Name (Expr))) @@ -18292,18 +18753,143 @@ package body Sem_Util is return False; end Is_Nontrivial_DIC_Procedure; + ----------------------- + -- Is_Null_Extension -- + ----------------------- + + function Is_Null_Extension + (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean + is + Type_Decl : Node_Id; + Type_Def : Node_Id; + begin + if Ignore_Privacy then + Type_Decl := Parent (Underlying_Type (Base_Type (T))); + else + Type_Decl := Parent (Base_Type (T)); + if Nkind (Type_Decl) /= N_Full_Type_Declaration then + return False; + end if; + end if; + pragma Assert (Nkind (Type_Decl) = N_Full_Type_Declaration); + Type_Def := Type_Definition (Type_Decl); + if Present (Discriminant_Specifications (Type_Decl)) + or else Nkind (Type_Def) /= N_Derived_Type_Definition + or else not Is_Tagged_Type (T) + or else No (Record_Extension_Part (Type_Def)) + then + return False; + end if; + + return Is_Null_Record_Definition (Record_Extension_Part (Type_Def)); + end Is_Null_Extension; + + -------------------------- + -- Is_Null_Extension_Of -- + -------------------------- + + function Is_Null_Extension_Of + (Descendant, Ancestor : Entity_Id) return Boolean + is + Ancestor_Type : constant Entity_Id + := Underlying_Type (Base_Type (Ancestor)); + Descendant_Type : Entity_Id := Underlying_Type (Base_Type (Descendant)); + begin + pragma Assert (Descendant_Type /= Ancestor_Type); + while Descendant_Type /= Ancestor_Type loop + if not Is_Null_Extension + (Descendant_Type, Ignore_Privacy => True) + then + return False; + end if; + Descendant_Type := Etype (Subtype_Indication + (Type_Definition (Parent (Descendant_Type)))); + Descendant_Type := Underlying_Type (Base_Type (Descendant_Type)); + end loop; + return True; + end Is_Null_Extension_Of; + + ------------------------------- + -- Is_Null_Record_Definition -- + ------------------------------- + + function Is_Null_Record_Definition (Record_Def : Node_Id) return Boolean is + Item : Node_Id; + begin + -- Testing Null_Present is just an optimization, not required. + + if Null_Present (Record_Def) then + return True; + elsif Present (Variant_Part (Component_List (Record_Def))) then + return False; + elsif not Present (Component_List (Record_Def)) then + return True; + end if; + + Item := First (Component_Items (Component_List (Record_Def))); + + while Present (Item) loop + if Nkind (Item) = N_Component_Declaration + and then Is_Internal_Name (Chars (Defining_Identifier (Item))) + then + null; + elsif Nkind (Item) = N_Pragma then + null; + else + return False; + end if; + Item := Next (Item); + end loop; + + return True; + end Is_Null_Record_Definition; + ------------------------- -- Is_Null_Record_Type -- ------------------------- - function Is_Null_Record_Type (T : Entity_Id) return Boolean is - Decl : constant Node_Id := Parent (T); + function Is_Null_Record_Type + (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean + is + Decl : Node_Id; + Type_Def : Node_Id; begin - return Nkind (Decl) = N_Full_Type_Declaration - and then Nkind (Type_Definition (Decl)) = N_Record_Definition - and then - (No (Component_List (Type_Definition (Decl))) - or else Null_Present (Component_List (Type_Definition (Decl)))); + if not Is_Record_Type (T) then + return False; + end if; + + if Ignore_Privacy then + Decl := Parent (Underlying_Type (Base_Type (T))); + else + Decl := Parent (Base_Type (T)); + if Nkind (Decl) /= N_Full_Type_Declaration then + return False; + end if; + end if; + pragma Assert (Nkind (Decl) = N_Full_Type_Declaration); + Type_Def := Type_Definition (Decl); + + if Has_Discriminants (Defining_Identifier (Decl)) then + return False; + end if; + + case Nkind (Type_Def) is + when N_Record_Definition => + return Is_Null_Record_Definition (Type_Def); + when N_Derived_Type_Definition => + if not Is_Null_Record_Type + (Etype (Subtype_Indication (Type_Def)), + Ignore_Privacy => Ignore_Privacy) + then + return False; + elsif not Is_Tagged_Type (T) then + return True; + else + return Is_Null_Extension (T, Ignore_Privacy => Ignore_Privacy); + end if; + when others => + return False; + end case; end Is_Null_Record_Type; --------------------- @@ -18317,7 +18903,9 @@ package body Sem_Util is -- This is because the parser always checks that prefixes of attributes -- are named. - return not (Is_Entity_Name (Prefix) and then Is_Type (Entity (Prefix))); + return not (Is_Entity_Name (Prefix) + and then Is_Type (Entity (Prefix)) + and then not Is_Current_Instance (Prefix)); end Is_Object_Image; ------------------------- @@ -18409,7 +18997,7 @@ package body Sem_Util is and then Is_Object_Reference (Expression (N)); else - -- AI12-0226: In Ada 202x a value conversion of an object is + -- AI12-0226: In Ada 2022 a value conversion of an object is -- an object. return Is_Object_Reference (Expression (N)); @@ -18557,8 +19145,9 @@ package body Sem_Util is ---------------------------- function Is_OK_Volatile_Context - (Context : Node_Id; - Obj_Ref : Node_Id) return Boolean + (Context : Node_Id; + Obj_Ref : Node_Id; + Check_Actuals : Boolean) return Boolean is function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean; -- Determine whether an arbitrary node denotes a call to a protected @@ -18633,21 +19222,14 @@ package body Sem_Util is ------------------------------ function Within_Volatile_Function (Id : Entity_Id) return Boolean is - Func_Id : Entity_Id; + pragma Assert (Ekind (Id) = E_Return_Statement); - begin - -- Traverse the scope stack looking for a [generic] function + Func_Id : constant Entity_Id := Return_Applies_To (Id); - Func_Id := Id; - while Present (Func_Id) and then Func_Id /= Standard_Standard loop - if Ekind (Func_Id) in E_Function | E_Generic_Function then - return Is_Volatile_Function (Func_Id); - end if; - - Func_Id := Scope (Func_Id); - end loop; + begin + pragma Assert (Ekind (Func_Id) in E_Function | E_Generic_Function); - return False; + return Is_Volatile_Function (Func_Id); end Within_Volatile_Function; -- Local variables @@ -18657,9 +19239,26 @@ package body Sem_Util is -- Start of processing for Is_OK_Volatile_Context begin + -- Ignore context restriction when doing preanalysis, e.g. on a copy of + -- an expression function, because this copy is not fully decorated and + -- it is not possible to reliably decide the legality of the context. + -- Any violations will be reported anyway when doing the full analysis. + + if not Full_Analysis then + return True; + end if; + + -- For actual parameters within explicit parameter associations switch + -- the context to the corresponding subprogram call. + + if Nkind (Context) = N_Parameter_Association then + return Is_OK_Volatile_Context (Context => Parent (Context), + Obj_Ref => Obj_Ref, + Check_Actuals => Check_Actuals); + -- The volatile object appears on either side of an assignment - if Nkind (Context) = N_Assignment_Statement then + elsif Nkind (Context) = N_Assignment_Statement then return True; -- The volatile object is part of the initialization expression of @@ -18677,7 +19276,7 @@ package body Sem_Util is -- function is volatile. if Is_Return_Object (Obj_Id) then - return Within_Volatile_Function (Obj_Id); + return Within_Volatile_Function (Scope (Obj_Id)); -- Otherwise this is a normal object initialization @@ -18728,8 +19327,9 @@ package body Sem_Util is N_Slice and then Prefix (Context) = Obj_Ref and then Is_OK_Volatile_Context - (Context => Parent (Context), - Obj_Ref => Context) + (Context => Parent (Context), + Obj_Ref => Context, + Check_Actuals => Check_Actuals) then return True; @@ -18761,8 +19361,9 @@ package body Sem_Util is | N_Unchecked_Type_Conversion and then Expression (Context) = Obj_Ref and then Is_OK_Volatile_Context - (Context => Parent (Context), - Obj_Ref => Context) + (Context => Parent (Context), + Obj_Ref => Context, + Check_Actuals => Check_Actuals) then return True; @@ -18777,17 +19378,43 @@ package body Sem_Util is elsif Within_Check (Context) then return True; - -- Assume that references to effectively volatile objects that appear - -- as actual parameters in a subprogram call are always legal. A full - -- legality check is done when the actuals are resolved (see routine - -- Resolve_Actuals). + -- References to effectively volatile objects that appear as actual + -- parameters in subprogram calls can be examined only after call itself + -- has been resolved. Before that, assume such references to be legal. - elsif Within_Subprogram_Call (Context) then - return True; + elsif Nkind (Context) in N_Subprogram_Call | N_Entry_Call_Statement then + if Check_Actuals then + declare + Call : Node_Id; + Formal : Entity_Id; + Subp : constant Entity_Id := Get_Called_Entity (Context); + begin + Find_Actual (Obj_Ref, Formal, Call); + pragma Assert (Call = Context); + + -- An effectively volatile object may act as an actual when the + -- corresponding formal is of a non-scalar effectively volatile + -- type (SPARK RM 7.1.3(10)). + + if not Is_Scalar_Type (Etype (Formal)) + and then Is_Effectively_Volatile_For_Reading (Etype (Formal)) + then + return True; - -- Otherwise the context is not suitable for an effectively volatile - -- object. + -- An effectively volatile object may act as an actual in a + -- call to an instance of Unchecked_Conversion. (SPARK RM + -- 7.1.3(10)). + elsif Is_Unchecked_Conversion_Instance (Subp) then + return True; + + else + return False; + end if; + end; + else + return True; + end if; else return False; end if; @@ -18860,7 +19487,7 @@ package body Sem_Util is elsif Is_Tagged_Type (Typ) then return True; - -- Case of non-discriminated record + -- Case of nondiscriminated record else declare @@ -19103,8 +19730,8 @@ package body Sem_Util is and then Aggregate_Type /= Any_Composite then if Is_Array_Type (Aggregate_Type) then - if Ada_Version >= Ada_2020 then - -- For Ada_2020, this predicate returns True for + if Ada_Version >= Ada_2022 then + -- For Ada 2022, this predicate returns True for -- any "repeatedly evaluated" expression. return True; end if; @@ -19517,10 +20144,10 @@ package body Sem_Util is elsif Nkind (N) = N_Null then return True; - -- Ada 2020 (AI12-0175): Calls to certain functions that are essentially + -- Ada 2022 (AI12-0175): Calls to certain functions that are essentially -- unchecked conversions are preelaborable. - elsif Ada_Version >= Ada_2020 + elsif Ada_Version >= Ada_2022 and then Nkind (N) = N_Function_Call and then Is_Entity_Name (Name (N)) and then Is_Preelaborable_Function (Entity (Name (N))) @@ -19749,7 +20376,8 @@ package body Sem_Util is function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is Orig_Node : Node_Id := Empty; - Subp_Decl : Node_Id := Parent (Parent (Proc_Nam)); + Subp_Decl : Node_Id := + (if No (Parent (Proc_Nam)) then Empty else Parent (Parent (Proc_Nam))); function Is_Entry (Nam : Node_Id) return Boolean; -- Determine whether Nam is an entry. Traverse selectors if there are @@ -20022,11 +20650,11 @@ package body Sem_Util is function Is_Static_Function (Subp : Entity_Id) return Boolean is begin - -- Always return False for pre Ada 2020 to e.g. ignore the Static - -- aspect in package Interfaces for Ada_Version < 2020 and also + -- Always return False for pre Ada 2022 to e.g. ignore the Static + -- aspect in package Interfaces for Ada_Version < 2022 and also -- for efficiency. - return Ada_Version >= Ada_2020 + return Ada_Version >= Ada_2022 and then Has_Aspect (Subp, Aspect_Static) and then (No (Find_Value_Of_Aspect (Subp, Aspect_Static)) @@ -20782,11 +21410,11 @@ package body Sem_Util is and then Scope (Scope (Scope (Root))) = Standard_Standard; end Is_Visibly_Controlled; - -------------------------------------- - -- Is_Volatile_Full_Access_Object -- - -------------------------------------- + ---------------------------------------- + -- Is_Volatile_Full_Access_Object_Ref -- + ---------------------------------------- - function Is_Volatile_Full_Access_Object (N : Node_Id) return Boolean is + function Is_Volatile_Full_Access_Object_Ref (N : Node_Id) return Boolean is function Is_VFA_Object_Entity (Id : Entity_Id) return Boolean; -- Determine whether arbitrary entity Id denotes an object that is -- Volatile_Full_Access. @@ -20804,7 +21432,7 @@ package body Sem_Util is Is_Volatile_Full_Access (Etype (Id))); end Is_VFA_Object_Entity; - -- Start of processing for Is_Volatile_Full_Access_Object + -- Start of processing for Is_Volatile_Full_Access_Object_Ref begin if Is_Entity_Name (N) then @@ -20819,7 +21447,7 @@ package body Sem_Util is else return False; end if; - end Is_Volatile_Full_Access_Object; + end Is_Volatile_Full_Access_Object_Ref; -------------------------- -- Is_Volatile_Function -- @@ -20829,9 +21457,11 @@ package body Sem_Util is begin pragma Assert (Ekind (Func_Id) in E_Function | E_Generic_Function); - -- A function declared within a protected type is volatile + -- A protected function is volatile - if Is_Protected_Type (Scope (Func_Id)) then + if Nkind (Parent (Unit_Declaration_Node (Func_Id))) = + N_Protected_Definition + then return True; -- An instance of Ada.Unchecked_Conversion is a volatile function if @@ -20851,11 +21481,11 @@ package body Sem_Util is end if; end Is_Volatile_Function; - ------------------------ - -- Is_Volatile_Object -- - ------------------------ + ---------------------------- + -- Is_Volatile_Object_Ref -- + ---------------------------- - function Is_Volatile_Object (N : Node_Id) return Boolean is + function Is_Volatile_Object_Ref (N : Node_Id) return Boolean is function Is_Volatile_Object_Entity (Id : Entity_Id) return Boolean; -- Determine whether arbitrary entity Id denotes an object that is -- Volatile. @@ -20901,7 +21531,7 @@ package body Sem_Util is then return True; - elsif Is_Volatile_Object (P) then + elsif Is_Volatile_Object_Ref (P) then return True; else @@ -20909,7 +21539,7 @@ package body Sem_Util is end if; end Prefix_Has_Volatile_Components; - -- Start of processing for Is_Volatile_Object + -- Start of processing for Is_Volatile_Object_Ref begin if Is_Entity_Name (N) then @@ -20928,7 +21558,7 @@ package body Sem_Util is else return False; end if; - end Is_Volatile_Object; + end Is_Volatile_Object_Ref; ----------------------------- -- Iterate_Call_Parameters -- @@ -22727,9 +23357,6 @@ package body Sem_Util is -- This routine performs low-level tree manipulations and needs access -- to the internals of the tree. - use Atree.Unchecked_Access; - use Atree_Private_Part; - EWA_Level : Nat := 0; -- This counter keeps track of how many N_Expression_With_Actions nodes -- are encountered during a depth-first traversal of the subtree. These @@ -23271,6 +23898,25 @@ package body Sem_Util is function Copy_Node_With_Replacement (N : Node_Id) return Node_Id is Result : Node_Id; + function Transform (U : Union_Id) return Union_Id; + -- Copies one field, replacing N with Result + + --------------- + -- Transform -- + --------------- + + function Transform (U : Union_Id) return Union_Id is + begin + return Copy_Field_With_Replacement + (Field => U, + Old_Par => N, + New_Par => Result); + end Transform; + + procedure Walk is new Walk_Sinfo_Fields_Pairwise (Transform); + + -- Start of processing for Copy_Node_With_Replacement + begin -- Assume that the node must be returned unchanged @@ -23281,35 +23927,7 @@ package body Sem_Util is Result := New_Copy (N); - Set_Field1 (Result, - Copy_Field_With_Replacement - (Field => Field1 (Result), - Old_Par => N, - New_Par => Result)); - - Set_Field2 (Result, - Copy_Field_With_Replacement - (Field => Field2 (Result), - Old_Par => N, - New_Par => Result)); - - Set_Field3 (Result, - Copy_Field_With_Replacement - (Field => Field3 (Result), - Old_Par => N, - New_Par => Result)); - - Set_Field4 (Result, - Copy_Field_With_Replacement - (Field => Field4 (Result), - Old_Par => N, - New_Par => Result)); - - Set_Field5 (Result, - Copy_Field_With_Replacement - (Field => Field5 (Result), - Old_Par => N, - New_Par => Result)); + Walk (Result, Result); -- Update the Comes_From_Source and Sloc attributes of the node -- in case the caller has supplied new values. @@ -23449,7 +24067,7 @@ package body Sem_Util is -- A new source location defaults the Comes_From_Source attribute if New_Sloc /= No_Location then - Set_Comes_From_Source (N, Default_Node.Comes_From_Source); + Set_Comes_From_Source (N, Get_Comes_From_Source_Default); Set_Sloc (N, New_Sloc); end if; end Update_CFS_Sloc; @@ -24056,25 +24674,37 @@ package body Sem_Util is EWA_Inner_Scope_Level := EWA_Inner_Scope_Level + 1; end if; - Visit_Field - (Field => Field1 (N), - Par_Nod => N); + -- If the node is a block, we need to process all declarations + -- in the block and make new entities for each. - Visit_Field - (Field => Field2 (N), - Par_Nod => N); + if Nkind (N) = N_Block_Statement and then Present (Declarations (N)) + then + declare + Decl : Node_Id := First (Declarations (N)); - Visit_Field - (Field => Field3 (N), - Par_Nod => N); + begin + while Present (Decl) loop + if Nkind (Decl) = N_Object_Declaration then + Add_New_Entity (Defining_Identifier (Decl), + New_Copy (Defining_Identifier (Decl))); + end if; - Visit_Field - (Field => Field4 (N), - Par_Nod => N); + Next (Decl); + end loop; + end; + end if; - Visit_Field - (Field => Field5 (N), - Par_Nod => N); + declare + procedure Action (U : Union_Id); + procedure Action (U : Union_Id) is + begin + Visit_Field (Field => U, Par_Nod => N); + end Action; + + procedure Walk is new Walk_Sinfo_Fields (Action); + begin + Walk (N); + end; if EWA_Level > 0 and then Nkind (N) in N_Block_Statement @@ -24284,10 +24914,10 @@ package body Sem_Util is (Chars (Related_Id), Suffix, Suffix_Index, Prefix)); begin - Set_Ekind (N, Kind); - Set_Is_Internal (N, True); - Append_Entity (N, Scope_Id); - Set_Public_Status (N); + Mutate_Ekind (N, Kind); + Set_Is_Internal (N, True); + Append_Entity (N, Scope_Id); + Set_Public_Status (N); if Kind in Type_Kind then Init_Size_Align (N); @@ -24309,7 +24939,7 @@ package body Sem_Util is N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); begin - Set_Ekind (N, Kind); + Mutate_Ekind (N, Kind); Set_Is_Internal (N, True); Append_Entity (N, Scope_Id); @@ -24941,7 +25571,7 @@ package body Sem_Util is Domain : constant Node_Id := Name (Parent (Ent)); begin - -- TBD : in the full version of the construct, the + -- ??? In the full version of the construct, the -- domain of iteration can be given by an expression. if Is_Entity_Name (Domain) then @@ -26008,14 +26638,16 @@ package body Sem_Util is Partial_DIC_Proc := Partial_DIC_Procedure (From_Typ); -- The setting of the attributes is intentionally conservative. This - -- prevents accidental clobbering of enabled attributes. + -- prevents accidental clobbering of enabled attributes. We need to + -- call Base_Type twice, because it is sometimes not set to an actual + -- base type. if Has_Inherited_DIC (From_Typ) then - Set_Has_Inherited_DIC (Typ); + Set_Has_Inherited_DIC (Base_Type (Base_Type (Typ))); end if; if Has_Own_DIC (From_Typ) then - Set_Has_Own_DIC (Typ); + Set_Has_Own_DIC (Base_Type (Base_Type (Typ))); end if; if Present (DIC_Proc) and then No (DIC_Procedure (Typ)) then @@ -26056,7 +26688,9 @@ package body Sem_Util is Part_IP := Partial_Invariant_Procedure (From_Typ); -- The setting of the attributes is intentionally conservative. This - -- prevents accidental clobbering of enabled attributes. + -- prevents accidental clobbering of enabled attributes. We need to + -- call Base_Type twice, because it is sometimes not set to an actual + -- base type. if Has_Inheritable_Invariants (From_Typ) then Set_Has_Inheritable_Invariants (Typ); @@ -26067,7 +26701,7 @@ package body Sem_Util is end if; if Has_Own_Invariants (From_Typ) then - Set_Has_Own_Invariants (Base_Type (Typ)); + Set_Has_Own_Invariants (Base_Type (Base_Type (Typ))); end if; if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then @@ -26371,6 +27005,8 @@ package body Sem_Util is -- generated before the next instruction. function Requires_Transient_Scope (Id : Entity_Id) return Boolean is + pragma Assert (if Present (Id) then Ekind (Id) in E_Void | Type_Kind); + function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean; -- This is called for untagged records and protected types, with -- nondefaulted discriminants. Returns True if the size of function @@ -26451,8 +27087,8 @@ package body Sem_Util is -- Do not set Has_Controlled_Component on a class-wide equivalent -- type. See Make_CW_Equivalent_Type. - if Present (Typ) - and then not Is_Frozen (Typ) + if not Is_Frozen (Typ) + and then Is_Base_Type (Typ) and then (Is_Record_Type (Typ) or else Is_Concurrent_Type (Typ) or else Is_Incomplete_Or_Private_Type (Typ)) @@ -26568,19 +27204,20 @@ package body Sem_Util is -- Start of processing for Requires_Transient_Scope begin - Ensure_Minimum_Decoration (Id); - -- This is a private type which is not completed yet. This can only -- happen in a default expression (of a formal parameter or of a -- record component). Do not expand transient scope in this case. if No (Typ) then return False; + end if; + + Ensure_Minimum_Decoration (Id); -- Do not expand transient scope for non-existent procedure return or -- string literal types. - elsif Typ = Standard_Void_Type + if Typ = Standard_Void_Type or else Ekind (Typ) = E_String_Literal_Subtype then return False; @@ -26721,7 +27358,7 @@ package body Sem_Util is is begin -- The only entities for which we track constant values are variables - -- which are not renamings, constants and formal parameters, so check + -- that are not renamings, constants and formal parameters, so check -- if we have this case. -- Note: it may seem odd to track constant values for constants, but in @@ -26792,7 +27429,7 @@ package body Sem_Util is -- or an exception handler). We skip this if Cond is True, since the -- capturing of values from conditional tests handles this ok. - if Cond then + if Cond or else No (N) then return True; end if; @@ -27163,66 +27800,6 @@ package body Sem_Util is return False; end Scope_Within_Or_Same; - -------------------- - -- Set_Convention -- - -------------------- - - procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is - begin - Basic_Set_Convention (E, Val); - - if Is_Type (E) - and then Is_Access_Subprogram_Type (Base_Type (E)) - and then Has_Foreign_Convention (E) - then - Set_Can_Use_Internal_Rep (E, False); - end if; - - -- If E is an object, including a component, and the type of E is an - -- anonymous access type with no convention set, then also set the - -- convention of the anonymous access type. We do not do this for - -- anonymous protected types, since protected types always have the - -- default convention. - - if Present (Etype (E)) - and then (Is_Object (E) - - -- Allow E_Void (happens for pragma Convention appearing - -- in the middle of a record applying to a component) - - or else Ekind (E) = E_Void) - then - declare - Typ : constant Entity_Id := Etype (E); - - begin - if Ekind (Typ) in E_Anonymous_Access_Type - | E_Anonymous_Access_Subprogram_Type - and then not Has_Convention_Pragma (Typ) - then - Basic_Set_Convention (Typ, Val); - Set_Has_Convention_Pragma (Typ); - - -- And for the access subprogram type, deal similarly with the - -- designated E_Subprogram_Type, which is always internal. - - if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then - declare - Dtype : constant Entity_Id := Designated_Type (Typ); - begin - if Ekind (Dtype) = E_Subprogram_Type - and then not Has_Convention_Pragma (Dtype) - then - Basic_Set_Convention (Dtype, Val); - Set_Has_Convention_Pragma (Dtype); - end if; - end; - end if; - end if; - end; - end if; - end Set_Convention; - ------------------------ -- Set_Current_Entity -- ------------------------ @@ -27789,7 +28366,7 @@ package body Sem_Util is Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2)); end if; - Set_Alignment (T1, Alignment (T2)); + Copy_Alignment (To => T1, From => T2); end Set_Size_Info; ------------------------------ @@ -28587,12 +29164,15 @@ package body Sem_Util is -- Type_Access_Level -- ----------------------- - function Type_Access_Level (Typ : Entity_Id) return Uint is - Btyp : Entity_Id; + function Type_Access_Level + (Typ : Entity_Id; + Allow_Alt_Model : Boolean := True; + Assoc_Ent : Entity_Id := Empty) return Uint + is + Btyp : Entity_Id := Base_Type (Typ); + Def_Ent : Entity_Id; begin - Btyp := Base_Type (Typ); - -- Ada 2005 (AI-230): For most cases of anonymous access types, we -- simply use the level where the type is declared. This is true for -- stand-alone object declarations, and for anonymous access types @@ -28603,13 +29183,62 @@ package body Sem_Util is if Is_Access_Type (Btyp) then if Ekind (Btyp) = E_Anonymous_Access_Type then + -- No_Dynamic_Accessibility_Checks restriction override for + -- alternative accessibility model. + + if Allow_Alt_Model + and then No_Dynamic_Accessibility_Checks_Enabled (Btyp) + then + -- In the -gnatd_b model, the level of an anonymous access + -- type is always that of the designated type. + + if Debug_Flag_Underscore_B then + return Type_Access_Level + (Designated_Type (Btyp), Allow_Alt_Model); + end if; + + -- When an anonymous access type's Assoc_Ent is specifiedi, + -- calculate the result based on the general accessibility + -- level routine. + + -- We would like to use Associated_Node_For_Itype here instead, + -- but in some cases it is not fine grained enough ??? + + if Present (Assoc_Ent) then + return Static_Accessibility_Level + (Assoc_Ent, Object_Decl_Level); + end if; + + -- Otherwise take the context of the anonymous access type into + -- account. + + -- Obtain the defining entity for the internally generated + -- anonymous access type. + + Def_Ent := Defining_Entity_Or_Empty + (Associated_Node_For_Itype (Typ)); + + if Present (Def_Ent) then + -- When the type comes from an anonymous access parameter, + -- the level is that of the subprogram declaration. + + if Ekind (Def_Ent) in Subprogram_Kind then + return Scope_Depth (Def_Ent); + + -- When the type is an access discriminant, the level is + -- that of the type. + + elsif Ekind (Def_Ent) = E_Discriminant then + return Scope_Depth (Scope (Def_Ent)); + end if; + end if; -- If the type is a nonlocal anonymous access type (such as for -- an access parameter) we treat it as being declared at the -- library level to ensure that names such as X.all'access don't -- fail static accessibility checks. - if not Is_Local_Anonymous_Access (Typ) then + elsif not Is_Local_Anonymous_Access (Typ) then return Scope_Depth (Standard_Standard); -- If this is a return object, the accessibility level is that of @@ -28643,7 +29272,7 @@ package body Sem_Util is -- Treat the return object's type as having the level of the -- function's result subtype (as per RM05-6.5(5.3/2)). - return Type_Access_Level (Etype (Scop)); + return Type_Access_Level (Etype (Scop), Allow_Alt_Model); end; end if; end if; @@ -28754,6 +29383,39 @@ package body Sem_Util is end if; end Type_Without_Stream_Operation; + ------------------------------ + -- Ultimate_Overlaid_Entity -- + ------------------------------ + + function Ultimate_Overlaid_Entity (E : Entity_Id) return Entity_Id is + Address : Node_Id; + Alias : Entity_Id := E; + Offset : Boolean; + + begin + -- Currently this routine is only called for stand-alone objects that + -- have been analysed, since the analysis of the Address aspect is often + -- delayed. + + pragma Assert (Ekind (E) in E_Constant | E_Variable); + + loop + Address := Address_Clause (Alias); + if Present (Address) then + Find_Overlaid_Entity (Address, Alias, Offset); + if Present (Alias) then + null; + else + return Empty; + end if; + elsif Alias = E then + return Empty; + else + return Alias; + end if; + end loop; + end Ultimate_Overlaid_Entity; + --------------------- -- Ultimate_Prefix -- --------------------- @@ -29186,9 +29848,7 @@ package body Sem_Util is if Nkind (Opnd) = N_Defining_Identifier or else not Is_Overloaded (Opnd) then - if Etype (Opnd) = Universal_Integer - or else Etype (Opnd) = Universal_Real - then + if Is_Universal_Numeric_Type (Etype (Opnd)) then return Etype (Opnd); else return Empty; @@ -29197,9 +29857,7 @@ package body Sem_Util is else Get_First_Interp (Opnd, Index, It); while Present (It.Typ) loop - if It.Typ = Universal_Integer - or else It.Typ = Universal_Real - then + if Is_Universal_Numeric_Type (It.Typ) then return It.Typ; end if; @@ -29255,42 +29913,55 @@ package body Sem_Util is -------------------- function Validated_View (Typ : Entity_Id) return Entity_Id is - Continue : Boolean; - Val_Typ : Entity_Id; - begin - Continue := True; - Val_Typ := Base_Type (Typ); + -- Scalar types can be always validated. In fast, switiching to the base + -- type would drop the range constraints and force validation to use a + -- larger type than necessary. + + if Is_Scalar_Type (Typ) then + return Typ; + + -- Array types can be validated even when they are derived, because + -- validation only requires their bounds and component types to be + -- accessible. In fact, switching to the parent type would pollute + -- expansion of attribute Valid_Scalars with unnecessary conversion + -- that might not be eliminated by the frontend. + + elsif Is_Array_Type (Typ) then + return Typ; + + -- For other types, in particular for record subtypes, we switch to the + -- base type. + + elsif not Is_Base_Type (Typ) then + return Validated_View (Base_Type (Typ)); -- Obtain the full view of the input type by stripping away concurrency, -- derivations, and privacy. - while Continue loop - Continue := False; - - if Is_Concurrent_Type (Val_Typ) then - if Present (Corresponding_Record_Type (Val_Typ)) then - Continue := True; - Val_Typ := Corresponding_Record_Type (Val_Typ); - end if; + elsif Is_Concurrent_Type (Typ) then + if Present (Corresponding_Record_Type (Typ)) then + return Corresponding_Record_Type (Typ); + else + return Typ; + end if; - elsif Is_Derived_Type (Val_Typ) then - Continue := True; - Val_Typ := Etype (Val_Typ); + elsif Is_Derived_Type (Typ) then + return Validated_View (Etype (Typ)); - elsif Is_Private_Type (Val_Typ) then - if Present (Underlying_Full_View (Val_Typ)) then - Continue := True; - Val_Typ := Underlying_Full_View (Val_Typ); + elsif Is_Private_Type (Typ) then + if Present (Underlying_Full_View (Typ)) then + return Validated_View (Underlying_Full_View (Typ)); - elsif Present (Full_View (Val_Typ)) then - Continue := True; - Val_Typ := Full_View (Val_Typ); - end if; + elsif Present (Full_View (Typ)) then + return Validated_View (Full_View (Typ)); + else + return Typ; end if; - end loop; - return Val_Typ; + else + return Typ; + end if; end Validated_View; ----------------------- @@ -29381,36 +30052,6 @@ package body Sem_Util is return Scope_Within_Or_Same (Scope (E), S); end Within_Scope; - ---------------------------- - -- Within_Subprogram_Call -- - ---------------------------- - - function Within_Subprogram_Call (N : Node_Id) return Boolean is - Par : Node_Id; - - begin - -- Climb the parent chain looking for a function or procedure call - - Par := N; - while Present (Par) loop - if Nkind (Par) in N_Entry_Call_Statement - | N_Function_Call - | N_Procedure_Call_Statement - then - return True; - - -- Prevent the search from going too far - - elsif Is_Body_Or_Package_Declaration (Par) then - exit; - end if; - - Par := Parent (Par); - end loop; - - return False; - end Within_Subprogram_Call; - ---------------- -- Wrong_Type -- ---------------- @@ -29939,7 +30580,7 @@ package body Sem_Util is procedure Normalize_Interval_List (List : in out Discrete_Interval_List; Last : out Nat); - -- Perform sorting and merging as required by Check_Consistency. + -- Perform sorting and merging as required by Check_Consistency ------------------------- -- Aggregate_Intervals -- @@ -29954,6 +30595,10 @@ package body Sem_Util is -- Count the number of intervals given in the aggregate N; the others -- choice (if present) is not taken into account. + ------------------------------ + -- Unmerged_Intervals_Count -- + ------------------------------ + function Unmerged_Intervals_Count return Nat is Count : Nat := 0; Choice : Node_Id; @@ -30054,7 +30699,7 @@ package body Sem_Util is (Discrete_Choices : List_Id) return Discrete_Interval_List is function Unmerged_Choice_Count return Nat; - -- The number of intervals before adjacent intervals are merged. + -- The number of intervals before adjacent intervals are merged --------------------------- -- Unmerged_Choice_Count -- @@ -30732,7 +31377,7 @@ package body Sem_Util is -- type case correctly, so we avoid that problem by -- returning True here. return True; - elsif Ada_Version < Ada_2020 then + elsif Ada_Version < Ada_2022 then return False; elsif not Is_Conditionally_Evaluated (Expr) then return False; @@ -31143,9 +31788,9 @@ package body Sem_Util is (Loc, Access_Type_Id, Type_Definition => Access_Type_Def); begin - Set_Ekind (Temp_Id, E_Variable); + Mutate_Ekind (Temp_Id, E_Variable); Set_Etype (Temp_Id, Access_Type_Id); - Set_Ekind (Access_Type_Id, E_Access_Type); + Mutate_Ekind (Access_Type_Id, E_Access_Type); if Append_Decls_In_Reverse_Order then Append_Item (Temp_Decl, Is_Eval_Stmt => False); |