diff options
| author | Giuliano Belinassi <giuliano.belinassi@usp.br> | 2020-08-22 17:43:43 -0300 |
|---|---|---|
| committer | Giuliano Belinassi <giuliano.belinassi@usp.br> | 2020-08-22 17:43:43 -0300 |
| commit | a926878ddbd5a98b272c22171ce58663fc04c3e0 (patch) | |
| tree | 86af256e5d9a9c06263c00adc90e5fe348008c43 /gcc/ada/sem_util.adb | |
| parent | 542730f087133690b47e036dfd43eb0db8a650ce (diff) | |
| parent | 07cbaed8ba7d1b6e4ab3a9f44175502a4e1ecdb1 (diff) | |
| download | gcc-devel/autopar_devel.zip gcc-devel/autopar_devel.tar.gz gcc-devel/autopar_devel.tar.bz2 | |
Merge branch 'autopar_rebase2' into autopar_develdevel/autopar_devel
Quickly commit changes in the rebase branch.
Diffstat (limited to 'gcc/ada/sem_util.adb')
| -rw-r--r-- | gcc/ada/sem_util.adb | 4158 |
1 files changed, 2913 insertions, 1245 deletions
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e1703e9..679b3be 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2020, 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- -- @@ -36,6 +36,7 @@ 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; @@ -115,8 +116,8 @@ package body Sem_Util is (Item_Id : Entity_Id; Property : Name_Id) return Boolean; -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled. - -- Determine whether an abstract state or a variable denoted by entity - -- Item_Id has enabled property Property. + -- Determine whether the state abstraction, variable, or type denoted by + -- entity Item_Id has enabled property Property. function Has_Null_Extension (T : Entity_Id) return Boolean; -- T is a derived tagged type. Check whether the type extension is null. @@ -132,6 +133,10 @@ package body Sem_Util is -- components in the selected variant to determine whether all of them -- have a default. + function Is_Preelaborable_Function (Id : Entity_Id) return Boolean; + -- Ada 2020: 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 (Is_Null, -- This value indicates that a subexpression is known to have a null @@ -190,8 +195,7 @@ package body Sem_Util is Nod := Declaration_Node (Base_Type (Typ)); - if Nkind_In (Nod, N_Full_Type_Declaration, - N_Private_Type_Declaration) + if Nkind (Nod) in N_Full_Type_Declaration | N_Private_Type_Declaration then return Empty_List; end if; @@ -1019,11 +1023,13 @@ package body Sem_Util is HSS : Node_Id; begin - pragma Assert (Nkind_In (N, N_Block_Statement, - N_Entry_Body, - N_Package_Body, - N_Subprogram_Body, - N_Task_Body)); + pragma Assert + (Nkind (N) in + N_Block_Statement | + N_Entry_Body | + N_Package_Body | + N_Subprogram_Body | + N_Task_Body); HSS := Handled_Statement_Sequence (N); @@ -1218,6 +1224,10 @@ package body Sem_Util is -- Similar to previous one, for discriminated components constrained -- by the discriminant of the enclosing object. + function Copy_And_Maybe_Dereference (N : Node_Id) return Node_Id; + -- Copy the subtree rooted at N and insert an explicit dereference if it + -- is of an access type. + ----------------------------------- -- Build_Actual_Array_Constraint -- ----------------------------------- @@ -1239,7 +1249,7 @@ package body Sem_Util is if Denotes_Discriminant (Old_Lo) then Lo := Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (P), + Prefix => Copy_And_Maybe_Dereference (P), Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc)); else @@ -1257,7 +1267,7 @@ package body Sem_Util is if Denotes_Discriminant (Old_Hi) then Hi := Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (P), + Prefix => Copy_And_Maybe_Dereference (P), Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc)); else @@ -1286,7 +1296,7 @@ package body Sem_Util is while Present (D) loop if Denotes_Discriminant (Node (D)) then D_Val := Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (P), + Prefix => Copy_And_Maybe_Dereference (P), Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc)); else @@ -1322,13 +1332,13 @@ package body Sem_Util is D_Val := New_Copy_Tree (D); Set_Expression (D_Val, Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (P), + Prefix => Copy_And_Maybe_Dereference (P), Selector_Name => New_Occurrence_Of (Entity (Expression (D)), Loc))); elsif Denotes_Discriminant (D) then D_Val := Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (P), + Prefix => Copy_And_Maybe_Dereference (P), Selector_Name => New_Occurrence_Of (Entity (D), Loc)); else @@ -1342,6 +1352,22 @@ package body Sem_Util is return Constraints; end Build_Access_Record_Constraint; + -------------------------------- + -- Copy_And_Maybe_Dereference -- + -------------------------------- + + function Copy_And_Maybe_Dereference (N : Node_Id) return Node_Id is + New_N : constant Node_Id := New_Copy_Tree (N); + + begin + if Is_Access_Type (Etype (N)) then + return Make_Explicit_Dereference (Sloc (Parent (N)), New_N); + + else + return New_N; + end if; + end Copy_And_Maybe_Dereference; + -- Start of processing for Build_Actual_Subtype_Of_Component begin @@ -1396,7 +1422,7 @@ package body Sem_Util is if Ekind (Desig_Typ) = E_Array_Subtype then Id := First_Index (Desig_Typ); - -- Check whether an index bound is constrained by a discriminant. + -- Check whether an index bound is constrained by a discriminant while Present (Id) loop Index_Typ := Underlying_Type (Etype (Id)); @@ -1485,17 +1511,38 @@ package body Sem_Util is Loc : constant Source_Ptr := Sloc (Bod); Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id); Clone_Body : Node_Id; + Assoc_List : constant Elist_Id := New_Elmt_List; begin -- The declaration of the class-wide clone was created when the -- corresponding class-wide condition was analyzed. + -- The body of the original condition may contain references to + -- the formals of Spec_Id. In the body of the class-wide clone, + -- these must be replaced with the corresponding formals of + -- the clone. + + declare + Spec_Formal_Id : Entity_Id := First_Formal (Spec_Id); + Clone_Formal_Id : Entity_Id := First_Formal (Clone_Id); + begin + while Present (Spec_Formal_Id) loop + Append_Elmt (Spec_Formal_Id, Assoc_List); + Append_Elmt (Clone_Formal_Id, Assoc_List); + + Next_Formal (Spec_Formal_Id); + Next_Formal (Clone_Formal_Id); + end loop; + end; + Clone_Body := Make_Subprogram_Body (Loc, Specification => Copy_Subprogram_Spec (Parent (Clone_Id)), Declarations => Declarations (Bod), - Handled_Statement_Sequence => Handled_Statement_Sequence (Bod)); + Handled_Statement_Sequence => + New_Copy_Tree (Handled_Statement_Sequence (Bod), + Map => Assoc_List)); -- The new operation is internal and overriding indicators do not apply -- (the original primitive may have carried one). @@ -1618,6 +1665,13 @@ package body Sem_Util is -- wrapper call to inherited operation. Set_Class_Wide_Clone (Spec_Id, Clone_Id); + + -- Inherit debug info flag from Spec_Id to Clone_Id to allow debugging + -- of the class-wide clone subprogram. + + if Needs_Debug_Info (Spec_Id) then + Set_Debug_Info_Needed (Clone_Id); + end if; end Build_Class_Wide_Clone_Decl; ----------------------------- @@ -1656,6 +1710,78 @@ package body Sem_Util is return Decl; end Build_Component_Subtype; + ----------------------------- + -- Build_Constrained_Itype -- + ----------------------------- + + procedure Build_Constrained_Itype + (N : Node_Id; + Typ : Entity_Id; + New_Assoc_List : List_Id) + is + Constrs : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (N); + Def_Id : Entity_Id; + Indic : Node_Id; + New_Assoc : Node_Id; + Subtyp_Decl : Node_Id; + + begin + New_Assoc := First (New_Assoc_List); + while Present (New_Assoc) loop + + -- There is exactly one choice in the component association (and + -- it is either a discriminant, a component or the others clause). + pragma Assert (List_Length (Choices (New_Assoc)) = 1); + + -- Duplicate expression for the discriminant and put it on the + -- list of constraints for the itype declaration. + + if Is_Entity_Name (First (Choices (New_Assoc))) + and then + Ekind (Entity (First (Choices (New_Assoc)))) = E_Discriminant + then + Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc))); + end if; + + Next (New_Assoc); + end loop; + + if Has_Unknown_Discriminants (Typ) + and then Present (Underlying_Record_View (Typ)) + then + Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Underlying_Record_View (Typ), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Constrs)); + else + Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Base_Type (Typ), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Constrs)); + end if; + + Def_Id := Create_Itype (Ekind (Typ), N); + + Subtyp_Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Indication => Indic); + Set_Parent (Subtyp_Decl, Parent (N)); + + -- Itypes must be analyzed with checks off (see itypes.ads) + + Analyze (Subtyp_Decl, Suppress => All_Checks); + + Set_Etype (N, Def_Id); + end Build_Constrained_Itype; + --------------------------- -- Build_Default_Subtype -- --------------------------- @@ -1899,12 +2025,6 @@ package body Sem_Util is if Present (Elaboration_Entity (Spec_Id)) then return; - -- Ignore in ASIS mode, elaboration entity is not in source and plays - -- no role in analysis. - - elsif ASIS_Mode then - return; - -- Do not generate an elaboration entity in GNATprove move because the -- elaboration counter is a form of expansion. @@ -2099,6 +2219,81 @@ package body Sem_Util is return New_Spec; end Build_Overriding_Spec; + ------------------- + -- Build_Subtype -- + ------------------- + + function Build_Subtype + (Related_Node : Node_Id; + Loc : Source_Ptr; + Typ : Entity_Id; + Constraints : List_Id) + return Entity_Id + is + Indic : Node_Id; + Subtyp_Decl : Node_Id; + Def_Id : Entity_Id; + Btyp : Entity_Id := Base_Type (Typ); + + begin + -- The Related_Node better be here or else we won't be able to + -- attach new itypes to a node in the tree. + + pragma Assert (Present (Related_Node)); + + -- If the view of the component's type is incomplete or private + -- with unknown discriminants, then the constraint must be applied + -- to the full type. + + if Has_Unknown_Discriminants (Btyp) + and then Present (Underlying_Type (Btyp)) + then + Btyp := Underlying_Type (Btyp); + end if; + + Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Btyp, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, Constraints)); + + Def_Id := Create_Itype (Ekind (Typ), Related_Node); + + Subtyp_Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Indication => Indic); + + Set_Parent (Subtyp_Decl, Parent (Related_Node)); + + -- Itypes must be analyzed with checks off (see package Itypes) + + Analyze (Subtyp_Decl, Suppress => All_Checks); + + if Is_Itype (Def_Id) and then Has_Predicates (Typ) then + Inherit_Predicate_Flags (Def_Id, Typ); + + -- Indicate where the predicate function may be found + + if Is_Itype (Typ) then + if Present (Predicate_Function (Def_Id)) then + null; + + elsif Present (Predicate_Function (Typ)) then + Set_Predicate_Function (Def_Id, Predicate_Function (Typ)); + + else + Set_Predicated_Parent (Def_Id, Predicated_Parent (Typ)); + end if; + + elsif No (Predicate_Function (Def_Id)) then + Set_Predicated_Parent (Def_Id, Typ); + end if; + end if; + + return Def_Id; + end Build_Subtype; + ----------------------------------- -- Cannot_Raise_Constraint_Error -- ----------------------------------- @@ -2376,10 +2571,8 @@ package body Sem_Util is -- Don't collect identifiers of packages, called functions, etc - elsif Ekind_In (Entity (N), E_Package, - E_Function, - E_Procedure, - E_Entry) + elsif Ekind (Entity (N)) in + E_Package | E_Function | E_Procedure | E_Entry then return Skip; @@ -2399,9 +2592,8 @@ package body Sem_Util is -- to identify a corner case??? elsif Nkind (Parent (N)) = N_Component_Association - and then Nkind_In (Parent (Parent (N)), - N_Aggregate, - N_Extension_Aggregate) + and then Nkind (Parent (Parent (N))) in + N_Aggregate | N_Extension_Aggregate then declare Choice : constant Node_Id := First (Choices (Parent (N))); @@ -2435,15 +2627,15 @@ package body Sem_Util is return Abandon; end if; - if Ekind_In (Id, E_Function, E_Generic_Function) + if Ekind (Id) in E_Function | E_Generic_Function and then Has_Out_Or_In_Out_Parameter (Id) then Formal := First_Formal (Id); Actual := First_Actual (Call); while Present (Actual) and then Present (Formal) loop if Actual = N then - if Ekind_In (Formal, E_Out_Parameter, - E_In_Out_Parameter) + if Ekind (Formal) in E_Out_Parameter + | E_In_Out_Parameter then Is_Writable_Actual := True; end if; @@ -2594,15 +2786,15 @@ package body Sem_Util is if Ada_Version < Ada_2012 or else not Check_Actuals (N) - or else (not (Nkind (N) in N_Op) - and then not (Nkind (N) in N_Membership_Test) - and then not Nkind_In (N, N_Range, - N_Aggregate, - N_Extension_Aggregate, - N_Full_Type_Declaration, - N_Function_Call, - N_Procedure_Call_Statement, - N_Entry_Call_Statement)) + or else Nkind (N) not in N_Op + | N_Membership_Test + | N_Range + | N_Aggregate + | N_Extension_Aggregate + | N_Full_Type_Declaration + | N_Function_Call + | N_Procedure_Call_Statement + | N_Entry_Call_Statement or else (Nkind (N) = N_Full_Type_Declaration and then not Is_Record_Type (Defining_Identifier (N))) @@ -2642,7 +2834,7 @@ package body Sem_Util is Collect_Identifiers (Right_Opnd (N)); end if; - if Nkind_In (N, N_In, N_Not_In) + if Nkind (N) in N_In | N_Not_In and then Present (Alternatives (N)) then Expr := First (Alternatives (N)); @@ -2720,8 +2912,7 @@ package body Sem_Util is Formal := First_Formal (Id); Actual := First_Actual (N); while Present (Actual) and then Present (Formal) loop - if Ekind_In (Formal, E_Out_Parameter, - E_In_Out_Parameter) + if Ekind (Formal) in E_Out_Parameter | E_In_Out_Parameter then Collect_Identifiers (Actual); end if; @@ -2759,7 +2950,7 @@ package body Sem_Util is declare Count_Components : Uint := Uint_0; Num_Components : Uint; - Others_Assoc : Node_Id; + Others_Assoc : Node_Id := Empty; Others_Choice : Node_Id := Empty; Others_Box_Present : Boolean := False; @@ -2788,8 +2979,8 @@ package body Sem_Util is -- Count several components - elsif Nkind_In (Choice, N_Range, - N_Subtype_Indication) + elsif Nkind (Choice) in + N_Range | N_Subtype_Indication or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) then @@ -2844,6 +3035,8 @@ package body Sem_Util is -- minimum decoration required to collect the -- identifiers. + pragma Assert (Present (Others_Assoc)); + if not Expander_Active then Comp_Expr := Expression (Others_Assoc); else @@ -2889,8 +3082,8 @@ package body Sem_Util is while Present (Assoc) loop Choice := First (Choices (Assoc)); while Present (Choice) loop - if Nkind_In (Choice, N_Range, - N_Subtype_Indication) + if Nkind (Choice) in + N_Range | N_Subtype_Indication or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) then @@ -3250,8 +3443,8 @@ package body Sem_Util is elsif Nkind (P) = N_Parameter_Specification and then Scope (Current_Scope) = Scope (Nam) - and then Nkind_In (Parent (P), N_Entry_Declaration, - N_Subprogram_Declaration) + and then Nkind (Parent (P)) in + N_Entry_Declaration | N_Subprogram_Declaration then Error_Msg_N ("internal call cannot appear in default for formal of " @@ -3320,7 +3513,8 @@ package body Sem_Util is -- Loop through sequence of basic declarative items Outer : while Present (Decl) loop - if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body) + if Nkind (Decl) not in + N_Subprogram_Body | N_Package_Body | N_Task_Body and then Nkind (Decl) not in N_Body_Stub then Next (Decl); @@ -3339,10 +3533,6 @@ package body Sem_Util is Error_Msg_N ("(Ada 83) decl cannot appear after body#", Decl); end if; - else - Error_Msg_Sloc := Body_Sloc; - Check_SPARK_05_Restriction - ("decl cannot appear after body#", Decl); end if; end if; @@ -3362,7 +3552,7 @@ package body Sem_Util is Scop : Entity_Id; begin - pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable)); + pragma Assert (Ekind (Id) in E_Abstract_State | E_Variable); -- Nothing to do for internally-generated abstract states and variables -- because they do not represent the hidden state of the source unit. @@ -3387,23 +3577,21 @@ package body Sem_Util is return; -- Objects and states that appear immediately within a subprogram or - -- inside a construct nested within a subprogram do not introduce a - -- hidden state. They behave as local variable declarations. + -- entry inside a construct nested within a subprogram do not + -- introduce a hidden state. They behave as local variable + -- declarations. The same is true for elaboration code inside a block + -- or a task. - elsif Is_Subprogram (Context) then + elsif Is_Subprogram_Or_Entry (Context) + or else Ekind (Context) in E_Block | E_Task_Type + then return; - - -- When examining a package body, use the entity of the spec as it - -- carries the abstract state declarations. - - elsif Ekind (Context) = E_Package_Body then - Context := Spec_Entity (Context); end if; -- Stop the traversal when a package subject to a null abstract state -- has been found. - if Ekind_In (Context, E_Generic_Package, E_Package) + if Is_Package_Or_Generic_Package (Context) and then Has_Null_Abstract_State (Context) then exit; @@ -3613,7 +3801,7 @@ package body Sem_Util is -- Initial_Condition and Initializes as this is part of the -- elaboration checks for the constituent (SPARK RM 9(3)). - if Nam_In (Prag_Nam, Name_Initial_Condition, Name_Initializes) then + if Prag_Nam in Name_Initial_Condition | Name_Initializes then return; -- When the reference appears within pragma Depends or Global, @@ -3621,7 +3809,7 @@ package body Sem_Util is -- that the pragma may not encapsulated by the type definition, -- but this is still a valid context. - elsif Nam_In (Prag_Nam, Name_Depends, Name_Global) + elsif Prag_Nam in Name_Depends | Name_Global and then Is_Single_Task_Pragma (Par, Conc_Obj) then return; @@ -3630,8 +3818,8 @@ package body Sem_Util is -- The reference appears somewhere in the definition of a single -- concurrent type (SPARK RM 9(3)). - elsif Nkind_In (Par, N_Single_Protected_Declaration, - N_Single_Task_Declaration) + elsif Nkind (Par) in + N_Single_Protected_Declaration | N_Single_Task_Declaration and then Defining_Entity (Par) = Conc_Obj then return; @@ -3639,10 +3827,10 @@ package body Sem_Util is -- The reference appears within the declaration or body of a single -- concurrent type (SPARK RM 9(3)). - elsif Nkind_In (Par, N_Protected_Body, - N_Protected_Type_Declaration, - N_Task_Body, - N_Task_Type_Declaration) + elsif Nkind (Par) in N_Protected_Body + | N_Protected_Type_Declaration + | N_Task_Body + | N_Task_Type_Declaration and then Is_Single_Declaration_Or_Body (Par, Conc_Obj) then return; @@ -3661,10 +3849,10 @@ package body Sem_Util is -- real check was already performed in the original context of the -- reference. - elsif Nkind_In (Par, N_Package_Body, - N_Package_Declaration, - N_Subprogram_Body, - N_Subprogram_Declaration) + elsif Nkind (Par) in N_Package_Body + | N_Package_Declaration + | N_Subprogram_Body + | N_Subprogram_Declaration and then Is_Internal_Declaration_Or_Body (Par) then return; @@ -3874,10 +4062,10 @@ package body Sem_Util is -- Empty list (no global items) or single global item -- declaration (only input items). - if Nkind_In (List, N_Null, - N_Expanded_Name, - N_Identifier, - N_Selected_Component) + if Nkind (List) in N_Null + | N_Expanded_Name + | N_Identifier + | N_Selected_Component then return False; @@ -3928,7 +4116,7 @@ package body Sem_Util is Param := First_Formal (Subp); while Present (Param) loop - if Ekind_In (Param, E_Out_Parameter, E_In_Out_Parameter) then + if Ekind (Param) in E_Out_Parameter | E_In_Out_Parameter then return False; end if; @@ -3993,7 +4181,7 @@ package body Sem_Util is procedure Check_Conjuncts (Expr : Node_Id) is begin - if Nkind_In (Expr, N_Op_And, N_And_Then) then + if Nkind (Expr) in N_Op_And | N_And_Then then Check_Conjuncts (Left_Opnd (Expr)); Check_Conjuncts (Right_Opnd (Expr)); else @@ -4075,11 +4263,11 @@ package body Sem_Util is Ent : Entity_Id; begin - if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then + if Nkind (N) in N_Explicit_Dereference | N_Function_Call then Post_State_Seen := True; return Abandon; - elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then + elsif Nkind (N) in N_Expanded_Name | N_Identifier then Ent := Entity (N); -- Treat an undecorated reference as OK @@ -4089,10 +4277,10 @@ package body Sem_Util is -- A reference to an assignable entity is considered a -- change in the post-state of a subprogram. - or else Ekind_In (Ent, E_Generic_In_Out_Parameter, - E_In_Out_Parameter, - E_Out_Parameter, - E_Variable) + or else Ekind (Ent) in E_Generic_In_Out_Parameter + | E_In_Out_Parameter + | E_Out_Parameter + | E_Variable -- The reference may be modified through a dereference @@ -4150,8 +4338,7 @@ package body Sem_Util is -- Examine the expression of a postcondition - else pragma Assert (Nam_In (Nam, Name_Postcondition, - Name_Refined_Post)); + else pragma Assert (Nam in Name_Postcondition | Name_Refined_Post); Check_Expression (Expr); end if; end Check_Result_And_Post_State_In_Pragma; @@ -4225,8 +4412,8 @@ package body Sem_Util is Prag := Pre_Post_Conditions (Items); while Present (Prag) loop - if Nam_In (Pragma_Name_Unmapped (Prag), - Name_Postcondition, Name_Refined_Post) + if Pragma_Name_Unmapped (Prag) + in Name_Postcondition | Name_Refined_Post and then not Error_Posted (Prag) then Post_Prag := Prag; @@ -4253,7 +4440,7 @@ package body Sem_Util is -- Do not emit any errors if the subprogram is not a function - if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then + if Ekind (Spec_Id) not in E_Function | E_Generic_Function then null; -- Regardless of whether the function has postconditions or contract @@ -4386,8 +4573,8 @@ package body Sem_Util is if Present (Decls) then Decl := First (Decls); while Present (Decl) loop - if Nkind_In (Decl, N_Generic_Package_Declaration, - N_Package_Declaration) + if Nkind (Decl) in N_Generic_Package_Declaration + | N_Package_Declaration then Check_Package (Decl); end if; @@ -4430,10 +4617,10 @@ package body Sem_Util is -- An entry, protected, subprogram, or task body may declare a nested -- package. - elsif Nkind_In (Context, N_Entry_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body) + elsif Nkind (Context) in N_Entry_Body + | N_Protected_Body + | N_Subprogram_Body + | N_Task_Body then -- Do not verify proper state refinement when the body is subject to -- pragma SPARK_Mode Off because this disables the requirement for @@ -4458,8 +4645,8 @@ package body Sem_Util is -- A library level [generic] package may declare a nested package - elsif Nkind_In (Context, N_Generic_Package_Declaration, - N_Package_Declaration) + elsif Nkind (Context) in + N_Generic_Package_Declaration | N_Package_Declaration and then Is_Main_Unit then Check_Package (Context); @@ -4512,7 +4699,7 @@ package body Sem_Util is -- For indexed and selected components, recursively check the prefix - if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then + if Nkind (Obj) in N_Indexed_Component | N_Selected_Component then return Enclosing_Protected_Type (Prefix (Obj)); -- The object does not denote a protected component @@ -4616,9 +4803,8 @@ package body Sem_Util is Constit_Id := Entity_Of (Constit); if Present (Constit_Id) - and then Ekind_In (Constit_Id, E_Abstract_State, - E_Constant, - E_Variable) + and then Ekind (Constit_Id) in + E_Abstract_State | E_Constant | E_Variable then Remove (States, Constit_Id); end if; @@ -4746,6 +4932,96 @@ package body Sem_Util is end if; end Check_Unused_Body_States; + ------------------------------------ + -- Check_Volatility_Compatibility -- + ------------------------------------ + + procedure Check_Volatility_Compatibility + (Id1, Id2 : Entity_Id; + Description_1, Description_2 : String; + Srcpos_Bearer : Node_Id) is + + begin + if SPARK_Mode /= On then + return; + end if; + + declare + AR1 : constant Boolean := Async_Readers_Enabled (Id1); + AW1 : constant Boolean := Async_Writers_Enabled (Id1); + ER1 : constant Boolean := Effective_Reads_Enabled (Id1); + EW1 : constant Boolean := Effective_Writes_Enabled (Id1); + AR2 : constant Boolean := Async_Readers_Enabled (Id2); + AW2 : constant Boolean := Async_Writers_Enabled (Id2); + ER2 : constant Boolean := Effective_Reads_Enabled (Id2); + EW2 : constant Boolean := Effective_Writes_Enabled (Id2); + + AR_Check_Failed : constant Boolean := AR1 and not AR2; + AW_Check_Failed : constant Boolean := AW1 and not AW2; + ER_Check_Failed : constant Boolean := ER1 and not ER2; + EW_Check_Failed : constant Boolean := EW1 and not EW2; + + package Failure_Description is + procedure Note_If_Failure + (Failed : Boolean; Aspect_Name : String); + -- If Failed is False, do nothing. + -- If Failed is True, add Aspect_Name to the failure description. + + function Failure_Text return String; + -- returns accumulated list of failing aspects + end Failure_Description; + + package body Failure_Description is + Description_Buffer : Bounded_String; + + --------------------- + -- Note_If_Failure -- + --------------------- + + procedure Note_If_Failure + (Failed : Boolean; Aspect_Name : String) is + begin + if Failed then + if Description_Buffer.Length /= 0 then + Append (Description_Buffer, ", "); + end if; + Append (Description_Buffer, Aspect_Name); + end if; + end Note_If_Failure; + + ------------------ + -- Failure_Text -- + ------------------ + + function Failure_Text return String is + begin + return +Description_Buffer; + end Failure_Text; + end Failure_Description; + + use Failure_Description; + begin + if AR_Check_Failed + or AW_Check_Failed + or ER_Check_Failed + or EW_Check_Failed + then + Note_If_Failure (AR_Check_Failed, "Async_Readers"); + Note_If_Failure (AW_Check_Failed, "Async_Writers"); + Note_If_Failure (ER_Check_Failed, "Effective_Reads"); + Note_If_Failure (EW_Check_Failed, "Effective_Writes"); + + Error_Msg_N + (Description_1 + & " and " + & Description_2 + & " are not compatible with respect to volatility due to " + & Failure_Text, + Srcpos_Bearer); + end if; + end; + end Check_Volatility_Compatibility; + ----------------- -- Choice_List -- ----------------- @@ -4800,7 +5076,7 @@ package body Sem_Util is elsif Ekind (Item_Id) = E_Abstract_State then Append_New_Elmt (Item_Id, States); - elsif Ekind_In (Item_Id, E_Constant, E_Variable) + elsif Ekind (Item_Id) in E_Constant | E_Variable and then Is_Visible_Object (Item_Id) then Append_New_Elmt (Item_Id, States); @@ -5587,7 +5863,14 @@ package body Sem_Util is -- will happen when something is evaluated if it never will be -- evaluated. - if not Is_Statically_Unevaluated (N) then + -- Suppress error reporting when checking that the expression of a + -- static expression function is a potentially static expression, + -- because we don't want additional errors being reported during the + -- preanalysis of the expression (see Analyze_Expression_Function). + + if not Is_Statically_Unevaluated (N) + and then not Checking_Potentially_Static_Expression + then if Present (Ent) then Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc); else @@ -5860,14 +6143,14 @@ package body Sem_Util is -- Current_Entity_In_Scope -- ----------------------------- - function Current_Entity_In_Scope (N : Node_Id) return Entity_Id 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; begin - E := Get_Name_Entity_Id (Chars (N)); + 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)) @@ -5878,6 +6161,15 @@ package body Sem_Util is return E; end Current_Entity_In_Scope; + ----------------------------- + -- Current_Entity_In_Scope -- + ----------------------------- + + function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is + begin + return Current_Entity_In_Scope (Chars (N)); + end Current_Entity_In_Scope; + ------------------- -- Current_Scope -- ------------------- @@ -6126,8 +6418,28 @@ package body Sem_Util is function Is_Renaming (N : Node_Id) return Boolean is begin - return - Is_Entity_Name (N) and then Present (Renamed_Entity (Entity (N))); + 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; ----------------------- @@ -6354,7 +6666,7 @@ package body Sem_Util is function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is begin if Is_Entity_Name (A1) then - if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) + if Nkind (A2) in N_Selected_Component | N_Indexed_Component and then not Is_Access_Type (Etype (A1)) then return Denotes_Same_Object (A1, Prefix (A2)) @@ -6366,9 +6678,9 @@ package body Sem_Util is elsif Is_Entity_Name (A2) then return Denotes_Same_Prefix (A1 => A2, A2 => A1); - elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice) + elsif Nkind (A1) in N_Selected_Component | N_Indexed_Component | N_Slice and then - Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice) + Nkind (A2) in N_Selected_Component | N_Indexed_Component | N_Slice then declare Root1, Root2 : Node_Id; @@ -6377,8 +6689,8 @@ package body Sem_Util is begin Root1 := Prefix (A1); while not Is_Entity_Name (Root1) loop - if not Nkind_In - (Root1, N_Selected_Component, N_Indexed_Component) + if Nkind (Root1) not in + N_Selected_Component | N_Indexed_Component then return False; else @@ -6390,8 +6702,8 @@ package body Sem_Util is Root2 := Prefix (A2); while not Is_Entity_Name (Root2) loop - if not Nkind_In (Root2, N_Selected_Component, - N_Indexed_Component) + if Nkind (Root2) not in + N_Selected_Component | N_Indexed_Component then return False; else @@ -6501,19 +6813,19 @@ package body Sem_Util is -- Start of processing for Designate_Same_Unit begin - if Nkind_In (K1, N_Identifier, N_Defining_Identifier) + if K1 in N_Identifier | N_Defining_Identifier and then - Nkind_In (K2, N_Identifier, N_Defining_Identifier) + K2 in N_Identifier | N_Defining_Identifier then return Chars (Name1) = Chars (Name2); - elsif Nkind_In (K1, N_Expanded_Name, - N_Selected_Component, - N_Defining_Program_Unit_Name) - and then - Nkind_In (K2, N_Expanded_Name, - N_Selected_Component, - N_Defining_Program_Unit_Name) + elsif K1 in N_Expanded_Name + | N_Selected_Component + | N_Defining_Program_Unit_Name + and then + K2 in N_Expanded_Name + | N_Selected_Component + | N_Defining_Program_Unit_Name then return (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2))) @@ -6609,7 +6921,7 @@ package body Sem_Util is end if; if (Is_Formal (E) - or else Ekind_In (E, E_Variable, E_Constant)) + or else Ekind (E) in E_Variable | E_Constant) and then Present (Get_Accessibility (E)) then return New_Occurrence_Of (Get_Accessibility (E), Loc); @@ -6619,7 +6931,7 @@ package body Sem_Util is -- Handle a constant-folded conditional expression by avoiding use of -- the original node. - if Nkind_In (Expr, N_Case_Expression, N_If_Expression) then + if Nkind (Expr) in N_Case_Expression | N_If_Expression then Expr := N; end if; @@ -6938,13 +7250,13 @@ package body Sem_Util is begin Par := Parent (N); while Present (Par) loop - if Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then + if Nkind (Par) in N_Package_Body | N_Subprogram_Body then Spec_Id := Corresponding_Spec (Par); if Present (Spec_Id) - and then Nkind_In (Unit_Declaration_Node (Spec_Id), - N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration) + and then Nkind (Unit_Declaration_Node (Spec_Id)) in + N_Generic_Package_Declaration | + N_Generic_Subprogram_Declaration then return Par; end if; @@ -6968,19 +7280,19 @@ package body Sem_Util is begin Par := Parent (N); while Present (Par) loop - if Nkind_In (Par, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration) + if Nkind (Par) in N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration then return Par; - elsif Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then + elsif Nkind (Par) in N_Package_Body | N_Subprogram_Body then Spec_Id := Corresponding_Spec (Par); if Present (Spec_Id) then Spec_Decl := Unit_Declaration_Node (Spec_Id); - if Nkind_In (Spec_Decl, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration) + if Nkind (Spec_Decl) in N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration then return Spec_Decl; end if; @@ -7050,9 +7362,8 @@ package body Sem_Util is elsif Dynamic_Scope = Empty then return Empty; - elsif Ekind_In (Dynamic_Scope, E_Generic_Package, - E_Package, - E_Package_Body) + elsif Ekind (Dynamic_Scope) in + E_Generic_Package | E_Package | E_Package_Body then return Dynamic_Scope; @@ -7101,10 +7412,10 @@ package body Sem_Util is elsif Ekind (Dyn_Scop) = E_Subprogram_Body then return Corresponding_Spec (Parent (Parent (Dyn_Scop))); - elsif Ekind_In (Dyn_Scop, E_Block, E_Loop, E_Return_Statement) then + elsif Ekind (Dyn_Scop) in E_Block | E_Loop | E_Return_Statement then return Enclosing_Subprogram (Dyn_Scop); - elsif Ekind_In (Dyn_Scop, E_Entry, E_Entry_Family) then + elsif Ekind (Dyn_Scop) in E_Entry | E_Entry_Family then -- For a task entry or entry family, return the enclosing subprogram -- of the task itself. @@ -7126,17 +7437,16 @@ package body Sem_Util is -- The scope may appear as a private type or as a private extension -- whose completion is a task or protected type. - elsif Ekind_In (Dyn_Scop, E_Limited_Private_Type, - E_Record_Type_With_Private) + elsif Ekind (Dyn_Scop) in + E_Limited_Private_Type | E_Record_Type_With_Private and then Present (Full_View (Dyn_Scop)) - and then Ekind_In (Full_View (Dyn_Scop), E_Task_Type, E_Protected_Type) + and then Ekind (Full_View (Dyn_Scop)) in E_Task_Type | E_Protected_Type then return Get_Task_Body_Procedure (Full_View (Dyn_Scop)); -- No body is generated if the protected operation is eliminated - elsif Convention (Dyn_Scop) = Convention_Protected - and then not Is_Eliminated (Dyn_Scop) + elsif not Is_Eliminated (Dyn_Scop) and then Present (Protected_Body_Subprogram (Dyn_Scop)) then return Protected_Body_Subprogram (Dyn_Scop); @@ -7188,11 +7498,11 @@ package body Sem_Util is -- Start of processing for End_Keyword_Location begin - if Nkind_In (N, N_Block_Statement, - N_Entry_Body, - N_Package_Body, - N_Subprogram_Body, - N_Task_Body) + if Nkind (N) in N_Block_Statement + | N_Entry_Body + | N_Package_Body + | N_Subprogram_Body + | N_Task_Body then Owner := Handled_Statement_Sequence (N); @@ -7202,13 +7512,12 @@ package body Sem_Util is elsif Nkind (N) = N_Protected_Body then Owner := N; - elsif Nkind_In (N, N_Protected_Type_Declaration, - N_Single_Protected_Declaration) + elsif Nkind (N) in N_Protected_Type_Declaration + | N_Single_Protected_Declaration then Owner := Protected_Definition (N); - elsif Nkind_In (N, N_Single_Task_Declaration, - N_Task_Type_Declaration) + elsif Nkind (N) in N_Single_Task_Declaration | N_Task_Type_Declaration then Owner := Task_Definition (N); @@ -7464,7 +7773,7 @@ package body Sem_Util is -- Avoid cascaded messages with duplicate components in -- derived types. - if Ekind_In (E, E_Component, E_Discriminant) then + if Ekind (E) in E_Component | E_Discriminant then return; end if; end if; @@ -7499,7 +7808,7 @@ package body Sem_Util is -- of inheriting components in a derived record definition. Preserve -- their Ekind and Etype. - if Ekind_In (Def_Id, E_Discriminant, E_Component) then + if Ekind (Def_Id) in E_Discriminant | E_Component then null; -- If a type is already set, leave it alone (happens when a type @@ -7522,7 +7831,7 @@ package body Sem_Util is -- Unless the Itype is for a record type with a corresponding remote -- type (what is that about, it was not commented ???) - if Ekind_In (Def_Id, E_Discriminant, E_Component) + if Ekind (Def_Id) in E_Discriminant | E_Component or else ((not Is_Record_Type (Def_Id) or else No (Corresponding_Remote_Type (Def_Id))) @@ -7536,52 +7845,6 @@ package body Sem_Util is Append_Entity (Def_Id, S); Set_Public_Status (Def_Id); - -- Declaring a homonym is not allowed in SPARK ... - - if Present (C) and then Restriction_Check_Required (SPARK_05) then - declare - Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id); - Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id); - Other_Scope : constant Node_Id := Enclosing_Dynamic_Scope (C); - - begin - -- ... unless the new declaration is in a subprogram, and the - -- visible declaration is a variable declaration or a parameter - -- specification outside that subprogram. - - if Present (Enclosing_Subp) - and then Nkind_In (Parent (C), N_Object_Declaration, - N_Parameter_Specification) - and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp) - then - null; - - -- ... or the new declaration is in a package, and the visible - -- declaration occurs outside that package. - - elsif Present (Enclosing_Pack) - and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack) - then - null; - - -- ... or the new declaration is a component declaration in a - -- record type definition. - - elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then - null; - - -- Don't issue error for non-source entities - - elsif Comes_From_Source (Def_Id) - and then Comes_From_Source (C) - then - Error_Msg_Sloc := Sloc (C); - Check_SPARK_05_Restriction - ("redeclaration of identifier &#", Def_Id); - end if; - end; - end if; - -- Warn if new entity hides an old one if Warn_On_Hiding and then Present (C) @@ -7920,8 +8183,7 @@ package body Sem_Util is elsif Comes_From_Source (Decl) or else - (Nkind_In (Decl, N_Subprogram_Body, - N_Subprogram_Declaration) + (Nkind (Decl) in N_Subprogram_Body | N_Subprogram_Declaration and then Is_Expression_Function (Defining_Entity (Decl))) then exit; @@ -7993,7 +8255,7 @@ package body Sem_Util is Call_Nam : Node_Id; begin - if Nkind_In (Context, N_Indexed_Component, N_Selected_Component) + if Nkind (Context) in N_Indexed_Component | N_Selected_Component and then N = Prefix (Context) then Find_Actual (Context, Formal, Call); @@ -8004,9 +8266,9 @@ package body Sem_Util is then Call := Parent (Context); - elsif Nkind_In (Context, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) + elsif Nkind (Context) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement then Call := Context; @@ -8020,9 +8282,9 @@ package body Sem_Util is -- we exclude overloaded calls, since we don't know enough to be sure -- of giving the right answer in this case. - if Nkind_In (Call, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) + if Nkind (Call) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement then Call_Nam := Name (Call); @@ -8066,8 +8328,8 @@ package body Sem_Util is return; else - Actual := Next_Actual (Actual); - Formal := Next_Formal (Formal); + Next_Actual (Actual); + Next_Formal (Formal); end if; end loop; end if; @@ -8422,7 +8684,7 @@ package body Sem_Util is 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 @@ -8448,8 +8710,7 @@ package body Sem_Util is -- Check for components - elsif - Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) + elsif Nkind (Expr) in N_Selected_Component | N_Indexed_Component then Expr := Prefix (Expr); Off := True; @@ -8800,7 +9061,7 @@ package body Sem_Util is -- Single global item declaration (only input items) - elsif Nkind_In (List, N_Expanded_Name, N_Identifier) then + elsif Nkind (List) in N_Expanded_Name | N_Identifier then if Global_Mode = Name_Input then return List; else @@ -8854,10 +9115,10 @@ package body Sem_Util is -- Start of processing for First_Global begin - pragma Assert (Nam_In (Global_Mode, Name_In_Out, - Name_Input, - Name_Output, - Name_Proof_In)); + pragma Assert (Global_Mode in Name_In_Out + | Name_Input + | Name_Output + | Name_Proof_In); -- Retrieve the suitable pragma Global or Refined_Global. In the second -- case, it can only be located on the body entity. @@ -8906,7 +9167,7 @@ package body Sem_Util is function Fix_Msg (Id : Entity_Id; Msg : String) return String is Is_Task : constant Boolean := - Ekind_In (Id, E_Task_Body, E_Task_Type) + Ekind (Id) in E_Task_Body | E_Task_Type or else Is_Single_Task_Object (Id); Msg_Last : constant Natural := Msg'Last; Msg_Index : Natural; @@ -8926,7 +9187,7 @@ package body Sem_Util is if Msg_Index <= Msg_Last - 10 and then Msg (Msg_Index .. Msg_Index + 9) = "subprogram" then - if Ekind_In (Id, E_Entry, E_Entry_Family) then + if Is_Entry (Id) then Res (Res_Index .. Res_Index + 4) := "entry"; Res_Index := Res_Index + 5; @@ -9946,6 +10207,16 @@ package body Sem_Util is (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is + pragma Assert + (Is_Type (Typ) + and then + Nam in Name_Element + | Name_First + | Name_Has_Element + | Name_Last + | Name_Next + | Name_Previous); + Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable); Assoc : Node_Id; @@ -9960,7 +10231,7 @@ package body Sem_Util is return Entity (Expression (Assoc)); end if; - Assoc := Next (Assoc); + Next (Assoc); end loop; return Empty; @@ -10181,6 +10452,7 @@ package body Sem_Util is begin R := N; while Is_Entity_Name (R) + and then Is_Object (Entity (R)) and then Present (Renamed_Object (Entity (R))) loop R := Renamed_Object (Entity (R)); @@ -10246,14 +10518,14 @@ package body Sem_Util is -- Strip the subprogram call loop - if Nkind_In (Subp, N_Explicit_Dereference, - N_Indexed_Component, - N_Selected_Component) + if Nkind (Subp) in N_Explicit_Dereference + | N_Indexed_Component + | N_Selected_Component then Subp := Prefix (Subp); - elsif Nkind_In (Subp, N_Type_Conversion, - N_Unchecked_Type_Conversion) + elsif Nkind (Subp) in N_Type_Conversion + | N_Unchecked_Type_Conversion then Subp := Expression (Subp); @@ -10337,7 +10609,7 @@ package body Sem_Util is (Typ : Entity_Id; Priv_Typ : out Entity_Id; Full_Typ : out Entity_Id; - Full_Base : out Entity_Id; + UFull_Typ : out Entity_Id; CRec_Typ : out Entity_Id) is IP_View : Entity_Id; @@ -10347,7 +10619,7 @@ package body Sem_Util is Priv_Typ := Empty; Full_Typ := Empty; - Full_Base := Empty; + UFull_Typ := Empty; CRec_Typ := Empty; -- The input type is the corresponding record type of a protected or a @@ -10356,10 +10628,9 @@ package body Sem_Util is if Ekind (Typ) = E_Record_Type and then Is_Concurrent_Record_Type (Typ) then - CRec_Typ := Typ; - Full_Typ := Corresponding_Concurrent_Type (CRec_Typ); - Full_Base := Base_Type (Full_Typ); - Priv_Typ := Incomplete_Or_Partial_View (Full_Typ); + CRec_Typ := Typ; + Full_Typ := Corresponding_Concurrent_Type (CRec_Typ); + Priv_Typ := Incomplete_Or_Partial_View (Full_Typ); -- Otherwise the input type denotes an arbitrary type @@ -10384,10 +10655,19 @@ package body Sem_Util is Full_Typ := Typ; end if; - if Present (Full_Typ) then - Full_Base := Base_Type (Full_Typ); + if Present (Full_Typ) and then Is_Private_Type (Full_Typ) then + UFull_Typ := Underlying_Full_View (Full_Typ); + + if Present (UFull_Typ) + and then Ekind (UFull_Typ) in E_Protected_Type | E_Task_Type + then + CRec_Typ := Corresponding_Record_Type (UFull_Typ); + end if; - if Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) then + else + if Present (Full_Typ) + and then Ekind (Full_Typ) in E_Protected_Type | E_Task_Type + then CRec_Typ := Corresponding_Record_Type (Full_Typ); end if; end if; @@ -10781,15 +11061,15 @@ package body Sem_Util is function Has_Declarations (N : Node_Id) return Boolean is begin - return Nkind_In (Nkind (N), N_Accept_Statement, - N_Block_Statement, - N_Compilation_Unit_Aux, - N_Entry_Body, - N_Package_Body, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body, - N_Package_Specification); + return Nkind (N) in N_Accept_Statement + | N_Block_Statement + | N_Compilation_Unit_Aux + | N_Entry_Body + | N_Package_Body + | N_Protected_Body + | N_Subprogram_Body + | N_Task_Body + | N_Package_Specification; end Has_Declarations; --------------------------------- @@ -10891,7 +11171,7 @@ package body Sem_Util is -- Inspect the return type of functions - if Ekind_In (Subp_Id, E_Function, E_Generic_Function) + if Ekind (Subp_Id) in E_Function | E_Generic_Function and then Is_Effectively_Volatile (Etype (Subp_Id)) then return True; @@ -10908,28 +11188,26 @@ package body Sem_Util is (Item_Id : Entity_Id; Property : Name_Id) return Boolean is - function Protected_Object_Has_Enabled_Property return Boolean; - -- Determine whether a protected object denoted by Item_Id has the - -- property enabled. + function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean; + -- Determine whether a protected type or variable denoted by Item_Id + -- has the property enabled. function State_Has_Enabled_Property return Boolean; -- Determine whether a state denoted by Item_Id has the property enabled - function Variable_Has_Enabled_Property return Boolean; - -- Determine whether a variable denoted by Item_Id has the property - -- enabled. - - ------------------------------------------- - -- Protected_Object_Has_Enabled_Property -- - ------------------------------------------- + function Type_Or_Variable_Has_Enabled_Property + (Item_Id : Entity_Id) return Boolean; + -- Determine whether type or variable denoted by Item_Id has the + -- property enabled. - function Protected_Object_Has_Enabled_Property return Boolean is - Constits : constant Elist_Id := Part_Of_Constituents (Item_Id); - Constit_Elmt : Elmt_Id; - Constit_Id : Entity_Id; + ----------------------------------------------------- + -- Protected_Type_Or_Variable_Has_Enabled_Property -- + ----------------------------------------------------- + function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean + is begin - -- Protected objects always have the properties Async_Readers and + -- Protected entities always have the properties Async_Readers and -- Async_Writers (SPARK RM 7.1.2(16)). if Property = Name_Async_Readers @@ -10941,21 +11219,30 @@ package body Sem_Util is -- properties Effective_Reads and Effective_Writes -- (SPARK RM 7.1.2(16)). - elsif Present (Constits) then - Constit_Elmt := First_Elmt (Constits); - while Present (Constit_Elmt) loop - Constit_Id := Node (Constit_Elmt); + elsif Is_Single_Protected_Object (Item_Id) then + declare + Constit_Elmt : Elmt_Id; + Constit_Id : Entity_Id; + Constits : constant Elist_Id + := Part_Of_Constituents (Item_Id); + begin + if Present (Constits) then + Constit_Elmt := First_Elmt (Constits); + while Present (Constit_Elmt) loop + Constit_Id := Node (Constit_Elmt); - if Has_Enabled_Property (Constit_Id, Property) then - return True; - end if; + if Has_Enabled_Property (Constit_Id, Property) then + return True; + end if; - Next_Elmt (Constit_Elmt); - end loop; + Next_Elmt (Constit_Elmt); + end loop; + end if; + end; end if; return False; - end Protected_Object_Has_Enabled_Property; + end Protected_Type_Or_Variable_Has_Enabled_Property; -------------------------------- -- State_Has_Enabled_Property -- @@ -11111,17 +11398,19 @@ package body Sem_Util is -- Synchronous (SPARK RM 7.1.4(9)). elsif Has_Synchronous then - return Nam_In (Property, Name_Async_Readers, Name_Async_Writers); + return Property in Name_Async_Readers | Name_Async_Writers; end if; return False; end State_Has_Enabled_Property; - ----------------------------------- - -- Variable_Has_Enabled_Property -- - ----------------------------------- + ------------------------------------------- + -- Type_Or_Variable_Has_Enabled_Property -- + ------------------------------------------- - function Variable_Has_Enabled_Property return Boolean is + function Type_Or_Variable_Has_Enabled_Property + (Item_Id : Entity_Id) return Boolean + is function Is_Enabled (Prag : Node_Id) return Boolean; -- Determine whether property pragma Prag (if present) denotes an -- enabled property. @@ -11169,7 +11458,11 @@ package body Sem_Util is EW : constant Node_Id := Get_Pragma (Item_Id, Pragma_Effective_Writes); - -- Start of processing for Variable_Has_Enabled_Property + Is_Derived_Type_With_Volatile_Parent_Type : constant Boolean := + Is_Derived_Type (Item_Id) + and then Is_Effectively_Volatile (Etype (Base_Type (Item_Id))); + + -- Start of processing for Type_Or_Variable_Has_Enabled_Property begin -- A non-effectively volatile object can never possess external @@ -11184,23 +11477,57 @@ package body Sem_Util is -- property is enabled when the flag evaluates to True or the flag is -- missing altogether. - elsif Property = Name_Async_Readers and then Is_Enabled (AR) then - return True; + elsif Property = Name_Async_Readers and then Present (AR) then + return Is_Enabled (AR); - elsif Property = Name_Async_Writers and then Is_Enabled (AW) then - return True; + elsif Property = Name_Async_Writers and then Present (AW) then + return Is_Enabled (AW); - elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then - return True; + elsif Property = Name_Effective_Reads and then Present (ER) then + return Is_Enabled (ER); - elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then - return True; + elsif Property = Name_Effective_Writes and then Present (EW) then + return Is_Enabled (EW); + + -- If other properties are set explicitly, then this one is set + -- implicitly to False, except in the case of a derived type + -- whose parent type is volatile (in that case, we will inherit + -- from the parent type, below). + + elsif (Present (AR) + or else Present (AW) + or else Present (ER) + or else Present (EW)) + and then not Is_Derived_Type_With_Volatile_Parent_Type + then + return False; + + -- For a private type, may need to look at the full view + + elsif Is_Private_Type (Item_Id) and then Present (Full_View (Item_Id)) + then + return Type_Or_Variable_Has_Enabled_Property (Full_View (Item_Id)); + + -- For a derived type whose parent type is volatile, the + -- property may be inherited (but ignore a non-volatile parent). + + elsif Is_Derived_Type_With_Volatile_Parent_Type then + return Type_Or_Variable_Has_Enabled_Property + (First_Subtype (Etype (Base_Type (Item_Id)))); + + -- If not specified explicitly for an object and the type + -- is effectively volatile, then take result from the type. + + elsif not Is_Type (Item_Id) + and then Is_Effectively_Volatile (Etype (Item_Id)) + then + return Has_Enabled_Property (Etype (Item_Id), Property); -- The implicit case lacks all property pragmas elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then if Is_Protected_Type (Etype (Item_Id)) then - return Protected_Object_Has_Enabled_Property; + return Protected_Type_Or_Variable_Has_Enabled_Property; else return True; end if; @@ -11208,7 +11535,7 @@ package body Sem_Util is else return False; end if; - end Variable_Has_Enabled_Property; + end Type_Or_Variable_Has_Enabled_Property; -- Start of processing for Has_Enabled_Property @@ -11220,15 +11547,19 @@ package body Sem_Util is return State_Has_Enabled_Property; elsif Ekind (Item_Id) = E_Variable then - return Variable_Has_Enabled_Property; + return Type_Or_Variable_Has_Enabled_Property (Item_Id); - -- By default, protected objects only have the properties Async_Readers - -- and Async_Writers. If they have Part_Of components, they also inherit - -- their properties Effective_Reads and Effective_Writes - -- (SPARK RM 7.1.2(16)). + -- Other objects can only inherit properties through their type. We + -- cannot call directly Type_Or_Variable_Has_Enabled_Property on + -- these as they don't have contracts attached, which is expected by + -- this function. - elsif Ekind (Item_Id) = E_Protected_Object then - return Protected_Object_Has_Enabled_Property; + elsif Is_Object (Item_Id) then + return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id)); + + elsif Is_Type (Item_Id) then + return Type_Or_Variable_Has_Enabled_Property + (Item_Id => First_Subtype (Item_Id)); -- Otherwise a property is enabled when the related item is effectively -- volatile. @@ -11286,17 +11617,16 @@ package body Sem_Util is -- Inspect all entities defined in the scope of the type, looking for -- uninitialized components. - Comp := First_Entity (Typ); + Comp := First_Component (Typ); while Present (Comp) loop - if Ekind (Comp) = E_Component - and then Comes_From_Source (Comp) + if Comes_From_Source (Comp) and then No (Expression (Parent (Comp))) and then not Has_Full_Default_Initialization (Etype (Comp)) then return False; end if; - Next_Entity (Comp); + Next_Component (Comp); end loop; -- Ensure that the parent type of a type extension is fully default @@ -11490,12 +11820,10 @@ package body Sem_Util is elsif Nkind (N) in N_Has_Entity then return Present (Entity (N)) - and then Ekind_In (Entity (N), E_Variable, - E_Constant, - E_Enumeration_Literal, - E_In_Parameter, - E_Out_Parameter, - E_In_Out_Parameter) + and then + Ekind (Entity (N)) in + E_Variable | E_Constant | E_Enumeration_Literal | + E_In_Parameter | E_Out_Parameter | E_In_Out_Parameter and then not Is_Volatile (Entity (N)); else @@ -11534,7 +11862,7 @@ package body Sem_Util is Node := First (L); loop - if Nkind (Node) /= N_Null_Statement then + if Nkind (Node) not in N_Null_Statement | N_Call_Marker then return True; end if; @@ -11547,6 +11875,104 @@ package body Sem_Util is end Has_Non_Null_Statements; ---------------------------------- + -- Is_Access_Subprogram_Wrapper -- + ---------------------------------- + + function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean is + Formal : constant Entity_Id := Last_Formal (E); + begin + return Present (Formal) + and then Ekind (Etype (Formal)) in Access_Subprogram_Kind + and then Access_Subprogram_Wrapper + (Directly_Designated_Type (Etype (Formal))) = E; + end Is_Access_Subprogram_Wrapper; + + --------------------------------- + -- Side_Effect_Free_Statements -- + --------------------------------- + + function Side_Effect_Free_Statements (L : List_Id) return Boolean is + Node : Node_Id; + + begin + if Is_Non_Empty_List (L) then + Node := First (L); + + loop + case Nkind (Node) is + when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error => + null; + when N_Object_Declaration => + if Present (Expression (Node)) + and then not Side_Effect_Free (Expression (Node)) + then + return False; + end if; + + when others => + return False; + end case; + + Next (Node); + exit when Node = Empty; + end loop; + end if; + + return True; + end Side_Effect_Free_Statements; + + --------------------------- + -- Side_Effect_Free_Loop -- + --------------------------- + + function Side_Effect_Free_Loop (N : Node_Id) return Boolean is + Scheme : Node_Id; + Spec : Node_Id; + Subt : Node_Id; + + begin + -- If this is not a loop (e.g. because the loop has been rewritten), + -- then return false. + + if Nkind (N) /= N_Loop_Statement then + return False; + end if; + + -- First check the statements + + if Side_Effect_Free_Statements (Statements (N)) then + + -- Then check the loop condition/indexes + + if Present (Iteration_Scheme (N)) then + Scheme := Iteration_Scheme (N); + + if Present (Condition (Scheme)) + or else Present (Iterator_Specification (Scheme)) + then + return False; + elsif Present (Loop_Parameter_Specification (Scheme)) then + Spec := Loop_Parameter_Specification (Scheme); + Subt := Discrete_Subtype_Definition (Spec); + + if Present (Subt) then + if Nkind (Subt) = N_Range then + return Side_Effect_Free (Low_Bound (Subt)) + and then Side_Effect_Free (High_Bound (Subt)); + else + -- subtype indication + + return True; + end if; + end if; + end if; + end if; + end if; + + return False; + end Side_Effect_Free_Loop; + + ---------------------------------- -- Has_Non_Trivial_Precondition -- ---------------------------------- @@ -11639,7 +12065,6 @@ package body Sem_Util is when N_Component_Definition | N_Formal_Object_Declaration - | N_Object_Renaming_Declaration => if Present (Subtype_Mark (N)) then return Null_Exclusion_Present (N); @@ -11647,6 +12072,15 @@ package body Sem_Util is return Null_Exclusion_Present (Access_Definition (N)); end if; + when N_Object_Renaming_Declaration => + if Present (Subtype_Mark (N)) then + return Null_Exclusion_Present (N); + elsif Present (Access_Definition (N)) then + return Null_Exclusion_Present (Access_Definition (N)); + else + return False; -- Case of no subtype in renaming (AI12-0275) + end if; + when N_Discriminant_Specification => if Nkind (Discriminant_Type (N)) = N_Access_Definition then return Null_Exclusion_Present (Discriminant_Type (N)); @@ -11663,7 +12097,8 @@ package body Sem_Util is when N_Parameter_Specification => if Nkind (Parameter_Type (N)) = N_Access_Definition then - return Null_Exclusion_Present (Parameter_Type (N)); + return Null_Exclusion_Present (Parameter_Type (N)) + or else Null_Exclusion_Present (N); else return Null_Exclusion_Present (N); end if; @@ -11975,14 +12410,10 @@ package body Sem_Util is function Has_Prefix (N : Node_Id) return Boolean is begin - return - Nkind_In (N, N_Attribute_Reference, - N_Expanded_Name, - N_Explicit_Dereference, - N_Indexed_Component, - N_Reference, - N_Selected_Component, - N_Slice); + return Nkind (N) in + N_Attribute_Reference | N_Expanded_Name | N_Explicit_Dereference | + N_Indexed_Component | N_Reference | N_Selected_Component | + N_Slice; end Has_Prefix; --------------------------- @@ -12046,6 +12477,147 @@ package body Sem_Util is end if; end Has_Private_Component; + -------------------------------- + -- Has_Relaxed_Initialization -- + -------------------------------- + + function Has_Relaxed_Initialization (E : Entity_Id) return Boolean is + + function Denotes_Relaxed_Parameter + (Expr : Node_Id; + Param : Entity_Id) + return Boolean; + -- Returns True iff expression Expr denotes a formal parameter or + -- function Param (through its attribute Result). + + ------------------------------- + -- Denotes_Relaxed_Parameter -- + ------------------------------- + + function Denotes_Relaxed_Parameter + (Expr : Node_Id; + Param : Entity_Id) return Boolean is + begin + if Nkind (Expr) in N_Identifier | N_Expanded_Name then + return Entity (Expr) = Param; + else + pragma Assert (Is_Attribute_Result (Expr)); + return Entity (Prefix (Expr)) = Param; + end if; + end Denotes_Relaxed_Parameter; + + -- Start of processing for Has_Relaxed_Initialization + + begin + -- When analyzing, we checked all syntax legality rules for the aspect + -- Relaxed_Initialization, but didn't store the property anywhere (e.g. + -- as an Einfo flag). To query the property we look directly at the AST, + -- but now without any syntactic checks. + + case Ekind (E) is + -- Abstract states have option Relaxed_Initialization + + when E_Abstract_State => + return Is_Relaxed_Initialization_State (E); + + -- Constants have this aspect attached directly; for deferred + -- constants, the aspect is attached to the partial view. + + when E_Constant => + return Has_Aspect (E, Aspect_Relaxed_Initialization); + + -- Variables have this aspect attached directly + + when E_Variable => + return Has_Aspect (E, Aspect_Relaxed_Initialization); + + -- Types have this aspect attached directly (though we only allow it + -- to be specified for the first subtype). For private types, the + -- aspect is attached to the partial view. + + when Type_Kind => + pragma Assert (Is_First_Subtype (E)); + return Has_Aspect (E, Aspect_Relaxed_Initialization); + + -- Formal parameters and functions have the Relaxed_Initialization + -- aspect attached to the subprogram entity and must be listed in + -- the aspect expression. + + when Formal_Kind + | E_Function + => + declare + Subp_Id : Entity_Id; + Aspect_Expr : Node_Id; + Param_Expr : Node_Id; + Assoc : Node_Id; + + begin + if Is_Formal (E) then + Subp_Id := Scope (E); + else + Subp_Id := E; + end if; + + if Has_Aspect (Subp_Id, Aspect_Relaxed_Initialization) then + Aspect_Expr := + Find_Value_Of_Aspect + (Subp_Id, Aspect_Relaxed_Initialization); + + -- Aspect expression is either an aggregate with an optional + -- Boolean expression (which defaults to True), e.g.: + -- + -- function F (X : Integer) return Integer + -- with Relaxed_Initialization => (X => True, F'Result); + + if Nkind (Aspect_Expr) = N_Aggregate then + + if Present (Component_Associations (Aspect_Expr)) then + Assoc := First (Component_Associations (Aspect_Expr)); + + while Present (Assoc) loop + if Denotes_Relaxed_Parameter + (First (Choices (Assoc)), E) + then + return + Is_True + (Static_Boolean (Expression (Assoc))); + end if; + + Next (Assoc); + end loop; + end if; + + Param_Expr := First (Expressions (Aspect_Expr)); + + while Present (Param_Expr) loop + if Denotes_Relaxed_Parameter (Param_Expr, E) then + return True; + end if; + + Next (Param_Expr); + end loop; + + return False; + + -- or it is a single identifier, e.g.: + -- + -- function F (X : Integer) return Integer + -- with Relaxed_Initialization => X; + + else + return Denotes_Relaxed_Parameter (Aspect_Expr, E); + end if; + else + return False; + end if; + end; + + when others => + raise Program_Error; + end case; + end Has_Relaxed_Initialization; + ---------------------- -- Has_Signed_Zeros -- ---------------------- @@ -12217,13 +12789,9 @@ package body Sem_Util is begin pragma Assert (Relaxed_RM_Semantics); - pragma Assert (Nkind_In (N, N_Null, - N_Op_Eq, - N_Op_Ge, - N_Op_Gt, - N_Op_Le, - N_Op_Lt, - N_Op_Ne)); + pragma Assert + (Nkind (N) in + N_Null | N_Op_Eq | N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt | N_Op_Ne); if Nkind (N) = N_Null then Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); @@ -12274,6 +12842,32 @@ package body Sem_Util is end if; end Has_Tagged_Component; + -------------------------------------------- + -- Has_Unconstrained_Access_Discriminants -- + -------------------------------------------- + + function Has_Unconstrained_Access_Discriminants + (Subtyp : Entity_Id) return Boolean + is + Discr : Entity_Id; + + begin + if Has_Discriminants (Subtyp) + and then not Is_Constrained (Subtyp) + then + Discr := First_Discriminant (Subtyp); + while Present (Discr) loop + if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then + return True; + end if; + + Next_Discriminant (Discr); + end loop; + end if; + + return False; + end Has_Unconstrained_Access_Discriminants; + ----------------------------- -- Has_Undefined_Reference -- ----------------------------- @@ -12336,7 +12930,7 @@ package body Sem_Util is return True; end if; - Comp := Next_Component (Comp); + Next_Component (Comp); end loop; end if; @@ -12402,6 +12996,32 @@ package body Sem_Util is return False; end Implements_Interface; + -------------------------------- + -- Implicitly_Designated_Type -- + -------------------------------- + + function Implicitly_Designated_Type (Typ : Entity_Id) return Entity_Id is + Desig : constant Entity_Id := Designated_Type (Typ); + + begin + -- An implicit dereference is a legal occurrence of an incomplete type + -- imported through a limited_with clause, if the full view is visible. + + if Is_Incomplete_Type (Desig) + and then From_Limited_With (Desig) + and then not From_Limited_With (Scope (Desig)) + and then + (Is_Immediately_Visible (Scope (Desig)) + or else + (Is_Child_Unit (Scope (Desig)) + and then Is_Visible_Lib_Unit (Scope (Desig)))) + then + return Available_View (Desig); + else + return Desig; + end if; + end Implicitly_Designated_Type; + ------------------------------------ -- In_Assertion_Expression_Pragma -- ------------------------------------ @@ -12519,7 +13139,7 @@ package body Sem_Util is begin S := Current_Scope; while Present (S) and then S /= Standard_Standard loop - if Ekind_In (S, E_Function, E_Procedure) + if Ekind (S) in E_Function | E_Procedure and then Is_Generic_Instance (S) then return True; @@ -12547,7 +13167,7 @@ package body Sem_Util is begin S := Current_Scope; while Present (S) and then S /= Standard_Standard loop - if Ekind_In (S, E_Function, E_Procedure) + if Ekind (S) in E_Function | E_Procedure and then Is_Generic_Instance (S) then return True; @@ -12751,15 +13371,15 @@ package body Sem_Util is if Nod = Cont then return True; - elsif Nkind_In (Nod, N_Accept_Statement, - N_Block_Statement, - N_Compilation_Unit, - N_Entry_Body, - N_Package_Body, - N_Package_Declaration, - N_Protected_Body, - N_Subprogram_Body, - N_Task_Body) + elsif Nkind (Nod) in N_Accept_Statement + | N_Block_Statement + | N_Compilation_Unit + | N_Entry_Body + | N_Package_Body + | N_Package_Declaration + | N_Protected_Body + | N_Subprogram_Body + | N_Task_Body then return False; @@ -12924,9 +13544,9 @@ package body Sem_Util is -- declaration hold the partial view and the full view is an -- itype. - elsif Nkind_In (Decl, N_Full_Type_Declaration, - N_Private_Extension_Declaration, - N_Private_Type_Declaration) + elsif Nkind (Decl) in N_Full_Type_Declaration + | N_Private_Extension_Declaration + | N_Private_Type_Declaration then Match := Defining_Identifier (Decl); end if; @@ -12974,7 +13594,7 @@ package body Sem_Util is begin if Present (Pkg) - and then Ekind_In (Pkg, E_Generic_Package, E_Package) + and then Is_Package_Or_Generic_Package (Pkg) then while Nkind (Pkg_Decl) /= N_Package_Specification loop Pkg_Decl := Parent (Pkg_Decl); @@ -13032,13 +13652,13 @@ package body Sem_Util is Ent : Entity_Id := First_Entity (Limited_View (Scope (Typ))); begin while Present (Ent) loop - if Ekind (Ent) in Incomplete_Kind + if Is_Incomplete_Type (Ent) and then Non_Limited_View (Ent) = Typ then return Ent; end if; - Ent := Next_Entity (Ent); + Next_Entity (Ent); end loop; end; end if; @@ -13099,6 +13719,38 @@ package body Sem_Util is return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound ((Ind)))); end Indexed_Component_Bit_Offset; + ----------------------------- + -- Inherit_Predicate_Flags -- + ----------------------------- + + procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is + begin + if Present (Predicate_Function (Subt)) then + return; + end if; + + Set_Has_Predicates (Subt, Has_Predicates (Par)); + Set_Has_Static_Predicate_Aspect + (Subt, Has_Static_Predicate_Aspect (Par)); + Set_Has_Dynamic_Predicate_Aspect + (Subt, Has_Dynamic_Predicate_Aspect (Par)); + + -- A named subtype does not inherit the predicate function of its + -- parent but an itype declared for a loop index needs the discrete + -- predicate information of its parent to execute the loop properly. + -- A non-discrete type may has a static predicate (for example True) + -- but has no static_discrete_predicate. + + if Is_Itype (Subt) and then Present (Predicate_Function (Par)) then + Set_Subprograms_For_Type (Subt, Subprograms_For_Type (Par)); + + if Has_Static_Predicate (Par) and then Is_Discrete_Type (Par) then + Set_Static_Discrete_Predicate + (Subt, Static_Discrete_Predicate (Par)); + end if; + end if; + end Inherit_Predicate_Flags; + ---------------------------- -- Inherit_Rep_Item_Chain -- ---------------------------- @@ -13265,7 +13917,7 @@ package body Sem_Util is procedure Insert_Explicit_Dereference (N : Node_Id) is New_Prefix : constant Node_Id := Relocate_Node (N); Ent : Entity_Id := Empty; - Pref : Node_Id; + Pref : Node_Id := Empty; I : Interp_Index; It : Interp; T : Entity_Id; @@ -13311,13 +13963,12 @@ package body Sem_Util is -- For a retrieval of a subcomponent of some composite object, -- retrieve the ultimate entity if there is one. - elsif Nkind_In (New_Prefix, N_Selected_Component, - N_Indexed_Component) + elsif Nkind (New_Prefix) in N_Selected_Component | N_Indexed_Component then Pref := Prefix (New_Prefix); while Present (Pref) - and then Nkind_In (Pref, N_Selected_Component, - N_Indexed_Component) + and then Nkind (Pref) in + N_Selected_Component | N_Indexed_Component loop Pref := Prefix (Pref); end loop; @@ -13366,7 +14017,7 @@ package body Sem_Util is Defining_Identifier (Decl)); end if; - Decl := Next (Decl); + Next (Decl); end loop; end Inspect_Deferred_Constant_Completion; @@ -13591,6 +14242,28 @@ package body Sem_Util is end if; end Invalid_Scalar_Value; + -------------------------------- + -- Is_Anonymous_Access_Actual -- + -------------------------------- + + function Is_Anonymous_Access_Actual (N : Node_Id) return Boolean is + Par : Node_Id; + begin + if Ekind (Etype (N)) /= E_Anonymous_Access_Type then + return False; + end if; + + Par := Parent (N); + while Present (Par) + and then Nkind (Par) in N_Case_Expression + | N_If_Expression + | N_Parameter_Association + loop + Par := Parent (Par); + end loop; + return Nkind (Par) in N_Subprogram_Call; + end Is_Anonymous_Access_Actual; + ----------------------------- -- Is_Actual_Out_Parameter -- ----------------------------- @@ -13603,6 +14276,18 @@ package body Sem_Util is return Present (Formal) and then Ekind (Formal) = E_Out_Parameter; end Is_Actual_Out_Parameter; + -------------------------------- + -- Is_Actual_In_Out_Parameter -- + -------------------------------- + + function Is_Actual_In_Out_Parameter (N : Node_Id) return Boolean is + Formal : Entity_Id; + Call : Node_Id; + begin + Find_Actual (N, Formal, Call); + return Present (Formal) and then Ekind (Formal) = E_In_Out_Parameter; + end Is_Actual_In_Out_Parameter; + ------------------------- -- Is_Actual_Parameter -- ------------------------- @@ -13688,10 +14373,17 @@ package body Sem_Util is and then Has_Aliased_Components (Designated_Type (Etype (Prefix (Obj))))); - elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then + elsif Nkind (Obj) in N_Unchecked_Type_Conversion | N_Type_Conversion then return Is_Tagged_Type (Etype (Obj)) and then Is_Aliased_View (Expression (Obj)); + -- Ada 202x AI12-0228 + + elsif Nkind (Obj) = N_Qualified_Expression + and then Ada_Version >= Ada_2012 + then + return Is_Aliased_View (Expression (Obj)); + elsif Nkind (Obj) = N_Explicit_Dereference then return Nkind (Original_Node (Obj)) /= N_Function_Call; @@ -13796,6 +14488,16 @@ package body Sem_Util is return Is_Atomic_Object (N) or else Is_Volatile_Full_Access_Object (N); end Is_Atomic_Or_VFA_Object; + ----------------------------- + -- Is_Attribute_Loop_Entry -- + ----------------------------- + + function Is_Attribute_Loop_Entry (N : Node_Id) return Boolean is + begin + return Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Loop_Entry; + end Is_Attribute_Loop_Entry; + ---------------------- -- Is_Attribute_Old -- ---------------------- @@ -13854,6 +14556,17 @@ package body Sem_Util is Is_RTE (Root_Type (Under), RO_WW_Super_String)); end Is_Bounded_String; + ------------------------------- + -- Is_By_Protected_Procedure -- + ------------------------------- + + function Is_By_Protected_Procedure (Id : Entity_Id) return Boolean is + begin + return Ekind (Id) = E_Procedure + and then Present (Get_Rep_Pragma (Id, Name_Implemented)) + and then Implementation_Kind (Id) = Name_By_Protected_Procedure; + end Is_By_Protected_Procedure; + --------------------- -- Is_CCT_Instance -- --------------------- @@ -13863,21 +14576,17 @@ package body Sem_Util is Context_Id : Entity_Id) return Boolean is begin - pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type)); + pragma Assert (Ekind (Ref_Id) in E_Protected_Type | E_Task_Type); if Is_Single_Task_Object (Context_Id) then return Scope_Within_Or_Same (Etype (Context_Id), Ref_Id); else - pragma Assert (Ekind_In (Context_Id, E_Entry, - E_Entry_Family, - E_Function, - E_Package, - E_Procedure, - E_Protected_Type, - E_Task_Type) - or else - Is_Record_Type (Context_Id)); + pragma Assert + (Ekind (Context_Id) in + E_Entry | E_Entry_Family | E_Function | E_Package | + E_Procedure | E_Protected_Type | E_Task_Type + or else Is_Record_Type (Context_Id)); return Scope_Within_Or_Same (Context_Id, Ref_Id); end if; end Is_CCT_Instance; @@ -14191,10 +14900,10 @@ package body Sem_Util is elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then return False; - elsif Nkind_In - (Nkind (Parent (Par)), N_Function_Call, - N_Procedure_Call_Statement, - N_Entry_Call_Statement) + elsif Nkind (Parent (Par)) in + N_Function_Call | + N_Procedure_Call_Statement | + N_Entry_Call_Statement then -- Check that the element is not part of an actual for an -- in-out parameter. @@ -14354,9 +15063,9 @@ package body Sem_Util is P := Parent (N); while Present (P) loop - if Nkind_In (P, N_Full_Type_Declaration, - N_Private_Type_Declaration, - N_Subtype_Declaration) + if Nkind (P) in N_Full_Type_Declaration + | N_Private_Type_Declaration + | N_Subtype_Declaration and then Comes_From_Source (P) and then Defining_Entity (P) = Typ then @@ -14388,6 +15097,59 @@ package body Sem_Util is return False; end Is_Current_Instance; + -------------------------------------------------- + -- Is_Current_Instance_Reference_In_Type_Aspect -- + -------------------------------------------------- + + function Is_Current_Instance_Reference_In_Type_Aspect + (N : Node_Id) return Boolean + is + begin + -- When a current_instance is referenced within an aspect_specification + -- of a type or subtype, it will show up as a reference to the formal + -- parameter of the aspect's associated subprogram rather than as a + -- reference to the type or subtype itself (in fact, the original name + -- is never even analyzed). We check for predicate, invariant, and + -- Default_Initial_Condition subprograms (in theory there could be + -- other cases added, in which case this function will need updating). + + if Is_Entity_Name (N) then + return Present (Entity (N)) + and then Ekind (Entity (N)) = E_In_Parameter + and then Ekind (Scope (Entity (N))) in E_Function | E_Procedure + and then + (Is_Predicate_Function (Scope (Entity (N))) + or else Is_Predicate_Function_M (Scope (Entity (N))) + or else Is_Invariant_Procedure (Scope (Entity (N))) + or else Is_Partial_Invariant_Procedure (Scope (Entity (N))) + or else Is_DIC_Procedure (Scope (Entity (N)))); + + else + case Nkind (N) is + when N_Indexed_Component + | N_Slice + => + return + Is_Current_Instance_Reference_In_Type_Aspect (Prefix (N)); + + when N_Selected_Component => + return + Is_Current_Instance_Reference_In_Type_Aspect (Prefix (N)); + + when N_Type_Conversion => + return Is_Current_Instance_Reference_In_Type_Aspect + (Expression (N)); + + when N_Qualified_Expression => + return Is_Current_Instance_Reference_In_Type_Aspect + (Expression (N)); + + when others => + return False; + end case; + end if; + end Is_Current_Instance_Reference_In_Type_Aspect; + -------------------- -- Is_Declaration -- -------------------- @@ -14531,13 +15293,14 @@ package body Sem_Util is begin -- Find the dereference node if any - while Nkind_In (Deref, N_Indexed_Component, - N_Selected_Component, - N_Slice) + while Nkind (Deref) in + N_Indexed_Component | N_Selected_Component | N_Slice loop Deref := Prefix (Deref); end loop; + Deref := Original_Node (Deref); + -- If the prefix is a qualified expression of a variable, then function -- Is_Variable will return False for that because a qualified expression -- denotes a constant view, so we need to get the name being qualified @@ -14555,9 +15318,11 @@ package body Sem_Util is if Is_Variable (Object) or else Is_Variable (Deref) - or else (Ada_Version >= Ada_2005 - and then (Nkind (Deref) = N_Explicit_Dereference - or else Is_Access_Type (Etype (Deref)))) + or else + (Ada_Version >= Ada_2005 + and then (Nkind (Deref) = N_Explicit_Dereference + or else (Present (Etype (Deref)) + and then Is_Access_Type (Etype (Deref))))) then if Nkind (Object) = N_Selected_Component then @@ -14565,8 +15330,8 @@ package body Sem_Util is -- False (it could be a function selector in a prefix form call -- occurring in an iterator specification). - if not Ekind_In (Entity (Selector_Name (Object)), E_Component, - E_Discriminant) + if Ekind (Entity (Selector_Name (Object))) not in + E_Component | E_Discriminant then return False; end if; @@ -14732,10 +15497,10 @@ package body Sem_Util is function Is_Dereferenced (N : Node_Id) return Boolean is P : constant Node_Id := Parent (N); begin - return Nkind_In (P, N_Selected_Component, - N_Explicit_Dereference, - N_Indexed_Component, - N_Slice) + return Nkind (P) in N_Selected_Component + | N_Explicit_Dereference + | N_Indexed_Component + | N_Slice and then Prefix (P) = N; end Is_Dereferenced; @@ -14867,22 +15632,24 @@ package body Sem_Util is -- effectively volatile. elsif Is_Array_Type (Id) then - declare - Anc : Entity_Id := Base_Type (Id); - begin - if Is_Private_Type (Anc) then - Anc := Full_View (Anc); - end if; + if Has_Volatile_Components (Id) then + return True; + else + declare + Anc : Entity_Id := Base_Type (Id); + begin + if Is_Private_Type (Anc) then + Anc := Full_View (Anc); + end if; - -- Test for presence of ancestor, as the full view of a private - -- type may be missing in case of error. + -- Test for presence of ancestor, as the full view of a + -- private type may be missing in case of error. - return - Has_Volatile_Components (Id) - or else - (Present (Anc) - and then Is_Effectively_Volatile (Component_Type (Anc))); - end; + return + Present (Anc) + and then Is_Effectively_Volatile (Component_Type (Anc)); + end; + end if; -- A protected type is always volatile @@ -14903,12 +15670,14 @@ package body Sem_Util is -- Otherwise Id denotes an object - else + else pragma Assert (Is_Object (Id)); -- A volatile object for which No_Caching is enabled is not -- effectively volatile. return - (Is_Volatile (Id) and then not No_Caching_Enabled (Id)) + (Is_Volatile (Id) + and then not + (Ekind (Id) = E_Variable and then No_Caching_Enabled (Id))) or else Has_Volatile_Components (Id) or else Is_Effectively_Volatile (Etype (Id)); end if; @@ -14921,9 +15690,10 @@ package body Sem_Util is function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is begin if Is_Entity_Name (N) then - return Is_Effectively_Volatile (Entity (N)); + return Is_Object (Entity (N)) + and then Is_Effectively_Volatile (Entity (N)); - elsif Nkind (N) = N_Indexed_Component then + elsif Nkind (N) in N_Indexed_Component | N_Slice then return Is_Effectively_Volatile_Object (Prefix (N)); elsif Nkind (N) = N_Selected_Component then @@ -14932,6 +15702,12 @@ package body Sem_Util is or else Is_Effectively_Volatile_Object (Selector_Name (N)); + elsif Nkind (N) in N_Qualified_Expression + | N_Unchecked_Type_Conversion + | N_Type_Conversion + then + return Is_Effectively_Volatile_Object (Expression (N)); + else return False; end if; @@ -14944,7 +15720,7 @@ package body Sem_Util is function Is_Entry_Body (Id : Entity_Id) return Boolean is begin return - Ekind_In (Id, E_Entry, E_Entry_Family) + Is_Entry (Id) and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Body; end Is_Entry_Body; @@ -14955,7 +15731,7 @@ package body Sem_Util is function Is_Entry_Declaration (Id : Entity_Id) return Boolean is begin return - Ekind_In (Id, E_Entry, E_Entry_Family) + Is_Entry (Id) and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Declaration; end Is_Entry_Declaration; @@ -14979,7 +15755,7 @@ package body Sem_Util is function Is_Expression_Function (Subp : Entity_Id) return Boolean is begin - if Ekind_In (Subp, E_Function, E_Subprogram_Body) then + if Ekind (Subp) in E_Function | E_Subprogram_Body then return Nkind (Original_Node (Unit_Declaration_Node (Subp))) = N_Expression_Function; @@ -15074,9 +15850,9 @@ package body Sem_Util is -- A qualified expression or a type conversion is an EVF expression when -- its operand is an EVF expression. - elsif Nkind_In (N, N_Qualified_Expression, - N_Unchecked_Type_Conversion, - N_Type_Conversion) + elsif Nkind (N) in N_Qualified_Expression + | N_Unchecked_Type_Conversion + | N_Type_Conversion then return Is_EVF_Expression (Expression (N)); @@ -15084,9 +15860,9 @@ package body Sem_Util is -- their prefix denotes an EVF expression. elsif Nkind (N) = N_Attribute_Reference - and then Nam_In (Attribute_Name (N), Name_Loop_Entry, - Name_Old, - Name_Update) + and then Attribute_Name (N) in Name_Loop_Entry + | Name_Old + | Name_Update then return Is_EVF_Expression (Prefix (N)); end if; @@ -15412,14 +16188,14 @@ package body Sem_Util is begin -- Package/subprogram body - if Nkind_In (Decl, N_Package_Body, N_Subprogram_Body) + if Nkind (Decl) in N_Package_Body | N_Subprogram_Body and then Present (Corresponding_Spec (Decl)) then Spec_Decl := Unit_Declaration_Node (Corresponding_Spec (Decl)); -- Package/subprogram body stub - elsif Nkind_In (Decl, N_Package_Body_Stub, N_Subprogram_Body_Stub) + elsif Nkind (Decl) in N_Package_Body_Stub | N_Subprogram_Body_Stub and then Present (Corresponding_Spec_Of_Stub (Decl)) then Spec_Decl := @@ -15437,8 +16213,8 @@ package body Sem_Util is -- calls. return - Nkind_In (Spec_Decl, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration); + Nkind (Spec_Decl) in N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration; end Is_Generic_Declaration_Or_Body; --------------------------- @@ -15560,7 +16336,7 @@ package body Sem_Util is and then not Is_Dispatching_Operation (Subp) and then Needs_Finalization (Etype (Subp)) and then not Is_Class_Wide_Type (Etype (Subp)) - and then not (Has_Invariants (Etype (Subp))) + and then not Has_Invariants (Etype (Subp)) and then Present (Subprogram_Body (Subp)) and then Was_Expression_Function (Subprogram_Body (Subp)) then @@ -15597,8 +16373,7 @@ package body Sem_Util is -- a predefined unit, i.e the one that declares iterator interfaces. return - Nam_In (Chars (Iter_Typ), Name_Forward_Iterator, - Name_Reversible_Iterator) + Chars (Iter_Typ) in Name_Forward_Iterator | Name_Reversible_Iterator and then In_Predefined_Unit (Root_Type (Iter_Typ)); end Denotes_Iterator; @@ -15674,7 +16449,7 @@ package body Sem_Util is -- Case of prefix of indexed or selected component or slice - elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice) + elsif Nkind (P) in N_Indexed_Component | N_Selected_Component | N_Slice and then N = Prefix (P) then -- Here we have the case where the parent P is N.Q or N(Q .. R). @@ -15752,7 +16527,7 @@ package body Sem_Util is Ent : constant Entity_Id := Entity (Expr); Sub : constant Entity_Id := Enclosing_Subprogram (Ent); begin - if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then + if Ekind (Ent) not in E_Variable | E_In_Out_Parameter then return False; else return Present (Sub) and then Sub = Current_Subprogram; @@ -15782,8 +16557,7 @@ package body Sem_Util is -- Attributes 'Input, 'Old and 'Result produce objects when N_Attribute_Reference => - return - Nam_In (Attribute_Name (N), Name_Input, Name_Old, Name_Result); + return Attribute_Name (N) in Name_Input | Name_Old | Name_Result; when N_Selected_Component => return @@ -16016,6 +16790,9 @@ package body Sem_Util is Visit (Discrete_Subtype_Definition (Nod)); + when N_Parameter_Association => + Visit (Explicit_Actual_Parameter (N)); + when N_Protected_Definition => -- End_Label is left out because it is not relevant for @@ -16181,6 +16958,21 @@ package body Sem_Util is Visit_List (Actions (Expr)); Visit (Expression (Expr)); + when N_Function_Call => + + -- Ada 2020 (AI12-0175): Calls to certain functions that are + -- essentially unchecked conversions are preelaborable. + + if Ada_Version >= Ada_2020 + and then Nkind (Expr) = N_Function_Call + and then Is_Entity_Name (Name (Expr)) + and then Is_Preelaborable_Function (Entity (Name (Expr))) + then + Visit_List (Parameter_Associations (Expr)); + else + raise Non_Preelaborable; + end if; + when N_If_Expression => Visit_List (Expressions (Expr)); @@ -16214,7 +17006,7 @@ package body Sem_Util is if Ekind (Id) = E_Discriminant then null; - elsif Ekind_In (Id, E_Constant, E_In_Parameter) + elsif Ekind (Id) in E_Constant | E_In_Parameter and then Present (Discriminal_Link (Id)) then null; @@ -16306,13 +17098,6 @@ package body Sem_Util is function Is_Object_Image (Prefix : Node_Id) return Boolean is begin - -- When the type of the prefix is not scalar, then the prefix is not - -- valid in any scenario. - - if not Is_Scalar_Type (Etype (Prefix)) then - return False; - end if; - -- Here we test for the case that the prefix is not a type and assume -- if it is not then it must be a named value or an object reference. -- This is because the parser always checks that prefixes of attributes @@ -16326,36 +17111,14 @@ package body Sem_Util is ------------------------- function Is_Object_Reference (N : Node_Id) return Boolean is - function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean; - -- Determine whether N is the name of an internally-generated renaming - - -------------------------------------- - -- Is_Internally_Generated_Renaming -- - -------------------------------------- - - function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is - P : Node_Id; - - begin - P := N; - while Present (P) loop - if Nkind (P) = N_Object_Renaming_Declaration then - return not Comes_From_Source (P); - elsif Is_List_Member (P) then - return False; - end if; - - P := Parent (P); - end loop; - - return False; - end Is_Internally_Generated_Renaming; - - -- Start of processing for Is_Object_Reference - begin + -- AI12-0068: Note that a current instance reference in a type or + -- subtype's aspect_specification is considered a value, not an object + -- (see RM 8.6(18/5)). + if Is_Entity_Name (N) then - return Present (Entity (N)) and then Is_Object (Entity (N)); + return Present (Entity (N)) and then Is_Object (Entity (N)) + and then not Is_Current_Instance_Reference_In_Type_Aspect (N); else case Nkind (N) is @@ -16372,20 +17135,20 @@ package body Sem_Util is -- Note that predefined operators are functions as well, and so -- are attributes that are (can be renamed as) functions. - when N_Binary_Op - | N_Function_Call - | N_Unary_Op + when N_Function_Call + | N_Op => return Etype (N) /= Standard_Void_Type; - -- Attributes references 'Loop_Entry, 'Old, and 'Result yield - -- objects, even though they are not functions. + -- Attributes references 'Loop_Entry, 'Old, 'Priority and 'Result + -- yield objects, even though they are not functions. when N_Attribute_Reference => return - Nam_In (Attribute_Name (N), Name_Loop_Entry, - Name_Old, - Name_Result) + Attribute_Name (N) in Name_Loop_Entry + | Name_Old + | Name_Priority + | Name_Result or else Is_Function_Attribute_Name (Attribute_Name (N)); when N_Selected_Component => @@ -16401,15 +17164,25 @@ package body Sem_Util is -- names. when N_Explicit_Dereference => - return not Nkind_In (Original_Node (N), N_Case_Expression, - N_If_Expression); + return Nkind (Original_Node (N)) not in + N_Case_Expression | N_If_Expression; -- A view conversion of a tagged object is an object reference when N_Type_Conversion => - return Is_Tagged_Type (Etype (Subtype_Mark (N))) - and then Is_Tagged_Type (Etype (Expression (N))) - and then Is_Object_Reference (Expression (N)); + if Ada_Version <= Ada_2012 then + -- A view conversion of a tagged object is an object + -- reference. + return Is_Tagged_Type (Etype (Subtype_Mark (N))) + and then Is_Tagged_Type (Etype (Expression (N))) + and then Is_Object_Reference (Expression (N)); + + else + -- AI12-0226: In Ada 202x a value conversion of an object is + -- an object. + + return Is_Object_Reference (Expression (N)); + end if; -- An unchecked type conversion is considered to be an object if -- the operand is an object (this construction arises only as a @@ -16418,25 +17191,31 @@ package body Sem_Util is when N_Unchecked_Type_Conversion => return True; - -- Allow string literals to act as objects as long as they appear - -- in internally-generated renamings. The expansion of iterators - -- may generate such renamings when the range involves a string - -- literal. - - when N_String_Literal => - return Is_Internally_Generated_Renaming (Parent (N)); - -- AI05-0003: In Ada 2012 a qualified expression is a name. -- This allows disambiguation of function calls and the use -- of aggregates in more contexts. when N_Qualified_Expression => - if Ada_Version < Ada_2012 then - return False; - else - return Is_Object_Reference (Expression (N)) - or else Nkind (Expression (N)) = N_Aggregate; - end if; + return Ada_Version >= Ada_2012 + and then Is_Object_Reference (Expression (N)); + + -- In Ada 95 an aggregate is an object reference + + when N_Aggregate => + return Ada_Version >= Ada_95; + + -- A string literal is not an object reference, but it might come + -- from rewriting of an object reference, e.g. from folding of an + -- aggregate. + + when N_String_Literal => + return Is_Rewrite_Substitution (N) + and then Is_Object_Reference (Original_Node (N)); + + -- AI12-0125: Target name represents a constant object + + when N_Target_Name => + return True; when others => return False; @@ -16470,10 +17249,9 @@ package body Sem_Util is -- check whether the context requires an access_to_variable type. elsif Nkind (AV) = N_Explicit_Dereference - and then Ada_Version >= Ada_2012 - and then Nkind (Original_Node (AV)) = N_Indexed_Component and then Present (Etype (Original_Node (AV))) and then Has_Implicit_Dereference (Etype (Original_Node (AV))) + and then Ada_Version >= Ada_2012 then return not Is_Access_Constant (Etype (Prefix (AV))); @@ -16486,7 +17264,7 @@ package body Sem_Util is -- expansion of a packed array aggregate). elsif Nkind (AV) = N_Unchecked_Type_Conversion then - if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then + if Nkind (Original_Node (AV)) in N_Function_Call | N_Aggregate then return False; elsif Comes_From_Source (AV) @@ -16531,28 +17309,7 @@ package body Sem_Util is -- but we still want to allow the conversion if it converts a variable). elsif Is_Rewrite_Substitution (AV) then - - -- In Ada 2012, the explicit dereference may be a rewritten call to a - -- Reference function. - - if Ada_Version >= Ada_2012 - and then Nkind (Original_Node (AV)) = N_Function_Call - and then - Has_Implicit_Dereference (Etype (Name (Original_Node (AV)))) - then - - -- Check that this is not a constant reference. - - return not Is_Access_Constant (Etype (Prefix (AV))); - - elsif Has_Implicit_Dereference (Etype (Original_Node (AV))) then - return - not Is_Access_Constant (Etype - (Get_Reference_Discriminant (Etype (Original_Node (AV))))); - - else - return Is_OK_Variable_For_Out_Formal (Original_Node (AV)); - end if; + return Is_OK_Variable_For_Out_Formal (Original_Node (AV)); -- All other non-variables are rejected @@ -16603,10 +17360,8 @@ package body Sem_Util is and then Is_Protected_Type (Etype (Pref)) and then Is_Entity_Name (Subp) and then Present (Entity (Subp)) - and then Ekind_In (Entity (Subp), E_Entry, - E_Entry_Family, - E_Function, - E_Procedure); + and then Ekind (Entity (Subp)) in + E_Entry | E_Entry_Family | E_Function | E_Procedure; else return False; end if; @@ -16651,7 +17406,7 @@ package body Sem_Util is Func_Id := Id; while Present (Func_Id) and then Func_Id /= Standard_Standard loop - if Ekind_In (Func_Id, E_Function, E_Generic_Function) then + if Ekind (Func_Id) in E_Function | E_Generic_Function then return Is_Volatile_Function (Func_Id); end if; @@ -16679,6 +17434,7 @@ package body Sem_Util is elsif Nkind (Context) = N_Object_Declaration and then Present (Expression (Context)) and then Expression (Context) = Obj_Ref + and then Nkind (Parent (Context)) /= N_Expression_With_Actions then Obj_Id := Defining_Entity (Context); @@ -16730,11 +17486,12 @@ package body Sem_Util is -- The volatile object appears as the prefix of a name occurring in a -- non-interfering context. - elsif Nkind_In (Context, N_Attribute_Reference, - N_Explicit_Dereference, - N_Indexed_Component, - N_Selected_Component, - N_Slice) + elsif Nkind (Context) in + N_Attribute_Reference | + N_Explicit_Dereference | + N_Indexed_Component | + N_Selected_Component | + N_Slice and then Prefix (Context) = Obj_Ref and then Is_OK_Volatile_Context (Context => Parent (Context), @@ -16748,25 +17505,26 @@ package body Sem_Util is elsif Nkind (Context) = N_Attribute_Reference and then Prefix (Context) = Obj_Ref - and then Nam_In (Attribute_Name (Context), Name_Address, - Name_Alignment, - Name_Component_Size, - Name_First, - Name_First_Bit, - Name_Last, - Name_Last_Bit, - Name_Length, - Name_Position, - Name_Size, - Name_Storage_Size) + and then Attribute_Name (Context) in Name_Address + | Name_Alignment + | Name_Component_Size + | Name_First + | Name_First_Bit + | Name_Last + | Name_Last_Bit + | Name_Length + | Name_Position + | Name_Size + | Name_Storage_Size then return True; -- The volatile object appears as the expression of a type conversion -- occurring in a non-interfering context. - elsif Nkind_In (Context, N_Type_Conversion, - N_Unchecked_Type_Conversion) + elsif Nkind (Context) in N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion and then Expression (Context) = Obj_Ref and then Is_OK_Volatile_Context (Context => Parent (Context), @@ -16832,7 +17590,7 @@ package body Sem_Util is is begin if Is_Scalar_Type (Typ) then - return False; + return Has_Default_Aspect (Base_Type (Typ)); elsif Is_Access_Type (Typ) then return Include_Implicit; @@ -16841,8 +17599,9 @@ package body Sem_Util is -- If component type is partially initialized, so is array type - if Is_Partially_Initialized_Type - (Component_Type (Typ), Include_Implicit) + if Has_Default_Aspect (Base_Type (Typ)) + or else Is_Partially_Initialized_Type + (Component_Type (Typ), Include_Implicit) then return True; @@ -16871,7 +17630,7 @@ package body Sem_Util is else declare - Ent : Entity_Id; + Comp : Entity_Id; Component_Present : Boolean := False; -- Set True if at least one component is present. If no @@ -16881,30 +17640,28 @@ package body Sem_Util is begin -- Loop through components - Ent := First_Entity (Typ); - while Present (Ent) loop - if Ekind (Ent) = E_Component then - Component_Present := True; + Comp := First_Component (Typ); + while Present (Comp) loop + Component_Present := True; - -- If a component has an initialization expression then - -- the enclosing record type is partially initialized + -- If a component has an initialization expression then the + -- enclosing record type is partially initialized - if Present (Parent (Ent)) - and then Present (Expression (Parent (Ent))) - then - return True; + if Present (Parent (Comp)) + and then Present (Expression (Parent (Comp))) + then + return True; - -- If a component is of a type which is itself partially - -- initialized, then the enclosing record type is also. + -- If a component is of a type which is itself partially + -- initialized, then the enclosing record type is also. - elsif Is_Partially_Initialized_Type - (Etype (Ent), Include_Implicit) - then - return True; - end if; + elsif Is_Partially_Initialized_Type + (Etype (Comp), Include_Implicit) + then + return True; end if; - Next_Entity (Ent); + Next_Component (Comp); end loop; -- No initialized components found. If we found any components @@ -17018,9 +17775,181 @@ package body Sem_Util is -------------------------------- function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is + function Has_Null_Others_Choice (Aggr : Node_Id) return Boolean; + -- Aggr is an array aggregate with static bounds and an others clause; + -- return True if the others choice of the given array aggregate does + -- not cover any component (i.e. is null). + + function Immediate_Context_Implies_Is_Potentially_Unevaluated + (Expr : Node_Id) return Boolean; + -- Return True if the *immediate* context of this expression tells us + -- that it is potentially unevaluated; return False if the *immediate* + -- context doesn't provide an answer to this question and we need to + -- keep looking. + + function Non_Static_Or_Null_Range (N : Node_Id) return Boolean; + -- Return True if the given range is nonstatic or null + + ---------------------------- + -- Has_Null_Others_Choice -- + ---------------------------- + + function Has_Null_Others_Choice (Aggr : Node_Id) return Boolean is + Idx : constant Node_Id := First_Index (Etype (Aggr)); + Hiv : constant Uint := Expr_Value (Type_High_Bound (Etype (Idx))); + Lov : constant Uint := Expr_Value (Type_Low_Bound (Etype (Idx))); + + begin + declare + Intervals : constant Interval_Lists.Discrete_Interval_List := + Interval_Lists.Aggregate_Intervals (Aggr); + + begin + -- The others choice is null if, after normalization, we + -- have a single interval covering the whole aggregate. + + return Intervals'Length = 1 + and then + Intervals (Intervals'First).Low = Lov + and then + Intervals (Intervals'First).High = Hiv; + end; + + -- If the aggregate is malformed (that is, indexes are not disjoint) + -- then no action is needed at this stage; the error will be reported + -- later by the frontend. + + exception + when Interval_Lists.Intervals_Error => + return False; + end Has_Null_Others_Choice; + + ---------------------------------------------------------- + -- Immediate_Context_Implies_Is_Potentially_Unevaluated -- + ---------------------------------------------------------- + + function Immediate_Context_Implies_Is_Potentially_Unevaluated + (Expr : Node_Id) return Boolean + is + Par : constant Node_Id := Parent (Expr); + + begin + if Nkind (Par) = N_If_Expression then + return Is_Elsif (Par) or else Expr /= First (Expressions (Par)); + + elsif Nkind (Par) = N_Case_Expression then + return Expr /= Expression (Par); + + elsif Nkind (Par) in N_And_Then | N_Or_Else then + return Expr = Right_Opnd (Par); + + elsif Nkind (Par) in N_In | N_Not_In then + + -- If the membership includes several alternatives, only the first + -- is definitely evaluated. + + if Present (Alternatives (Par)) then + return Expr /= First (Alternatives (Par)); + + -- If this is a range membership both bounds are evaluated + + else + return False; + end if; + + elsif Nkind (Par) = N_Quantified_Expression then + return Expr = Condition (Par); + + elsif Nkind (Par) = N_Aggregate + and then Present (Etype (Par)) + and then Etype (Par) /= Any_Composite + and then Is_Array_Type (Etype (Par)) + and then Nkind (Expr) = N_Component_Association + then + declare + Choice : Node_Id; + In_Others_Choice : Boolean := False; + + begin + -- The expression of an array_component_association is + -- potentially unevaluated if the associated choice is a + -- subtype_indication or range that defines a nonstatic or + -- null range. + + Choice := First (Choices (Expr)); + while Present (Choice) loop + if Nkind (Choice) = N_Range + and then Non_Static_Or_Null_Range (Choice) + then + return True; + + elsif Nkind (Choice) = N_Identifier + and then Present (Scalar_Range (Etype (Choice))) + and then + Non_Static_Or_Null_Range (Scalar_Range (Etype (Choice))) + then + return True; + + elsif Nkind (Choice) = N_Others_Choice then + In_Others_Choice := True; + end if; + + Next (Choice); + end loop; + + -- It is also potentially unevaluated if the associated choice + -- is an others choice and the applicable index constraint is + -- nonstatic or null. + + if In_Others_Choice then + if not Compile_Time_Known_Bounds (Etype (Par)) then + return True; + else + return Has_Null_Others_Choice (Par); + end if; + end if; + end; + + return False; + + else + return False; + end if; + end Immediate_Context_Implies_Is_Potentially_Unevaluated; + + ------------------------------ + -- Non_Static_Or_Null_Range -- + ------------------------------ + + function Non_Static_Or_Null_Range (N : Node_Id) return Boolean is + Low, High : Node_Id; + + begin + Get_Index_Bounds (N, Low, High); + + -- Check static bounds + + if not Compile_Time_Known_Value (Low) + or else not Compile_Time_Known_Value (High) + then + return True; + + -- Check null range + + elsif Expr_Value (High) < Expr_Value (Low) then + return True; + end if; + + return False; + end Non_Static_Or_Null_Range; + + -- Local variables + Par : Node_Id; Expr : Node_Id; + -- Start of processing for Is_Potentially_Unevaluated + begin Expr := N; Par := N; @@ -17049,22 +17978,27 @@ package body Sem_Util is -- conjunct in a postcondition) with a potentially unevaluated operand. Par := Parent (Expr); - while not Nkind_In (Par, N_And_Then, - N_Case_Expression, - N_If_Expression, - N_In, - N_Not_In, - N_Or_Else, - N_Quantified_Expression) + + while Present (Par) + and then Nkind (Par) /= N_Pragma_Argument_Association loop - Expr := Par; - Par := Parent (Par); + if Comes_From_Source (Par) + and then + Immediate_Context_Implies_Is_Potentially_Unevaluated (Expr) + then + return True; + + -- For component associations continue climbing; it may be part of + -- an array aggregate. + + elsif Nkind (Par) = N_Component_Association then + null; -- If the context is not an expression, or if is the result of -- expansion of an enclosing construct (such as another attribute) -- the predicate does not apply. - if Nkind (Par) = N_Case_Expression_Alternative then + elsif Nkind (Par) = N_Case_Expression_Alternative then null; elsif Nkind (Par) not in N_Subexpr @@ -17072,37 +18006,12 @@ package body Sem_Util is then return False; end if; - end loop; - - if Nkind (Par) = N_If_Expression then - return Is_Elsif (Par) or else Expr /= First (Expressions (Par)); - - elsif Nkind (Par) = N_Case_Expression then - return Expr /= Expression (Par); - - elsif Nkind_In (Par, N_And_Then, N_Or_Else) then - return Expr = Right_Opnd (Par); - - elsif Nkind_In (Par, N_In, N_Not_In) then - - -- If the membership includes several alternatives, only the first is - -- definitely evaluated. - - if Present (Alternatives (Par)) then - return Expr /= First (Alternatives (Par)); - -- If this is a range membership both bounds are evaluated - - else - return False; - end if; - - elsif Nkind (Par) = N_Quantified_Expression then - return Expr = Condition (Par); + Expr := Par; + Par := Parent (Par); + end loop; - else - return False; - end if; + return False; end Is_Potentially_Unevaluated; ----------------------------------------- @@ -17130,7 +18039,7 @@ package body Sem_Util is TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); - if Nam_In (Chars (E), Name_uAssign, Name_uSize) + if Chars (E) in Name_uAssign | Name_uSize or else (Chars (E) = Name_Op_Eq and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) @@ -17140,6 +18049,7 @@ package body Sem_Util is or else TSS_Name = TSS_Stream_Output or else TSS_Name = TSS_Stream_Read or else TSS_Name = TSS_Stream_Write + or else TSS_Name = TSS_Put_Image or else Is_Predefined_Interface_Primitive (E) then return True; @@ -17160,12 +18070,12 @@ package body Sem_Util is -- these primitives. return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion) - and then Nam_In (Chars (E), Name_uDisp_Asynchronous_Select, - Name_uDisp_Conditional_Select, - Name_uDisp_Get_Prim_Op_Kind, - Name_uDisp_Get_Task_Id, - Name_uDisp_Requeue, - Name_uDisp_Timed_Select); + and then Chars (E) in Name_uDisp_Asynchronous_Select + | Name_uDisp_Conditional_Select + | Name_uDisp_Get_Prim_Op_Kind + | Name_uDisp_Get_Task_Id + | Name_uDisp_Requeue + | Name_uDisp_Timed_Select; end Is_Predefined_Interface_Primitive; --------------------------------------- @@ -17193,7 +18103,7 @@ package body Sem_Util is TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len)); - if Nam_In (Chars (E), Name_uSize, Name_uAssign) + if Chars (E) in Name_uSize | Name_uAssign or else (Chars (E) = Name_Op_Eq and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) @@ -17323,7 +18233,7 @@ package body Sem_Util is begin -- Aggregates - if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then + if Nkind (N) in N_Aggregate | N_Extension_Aggregate then return Is_Preelaborable_Aggregate (N); -- Attributes are allowed in general, even if their prefix is a formal @@ -17348,7 +18258,7 @@ package body Sem_Util is and then Present (Entity (N)) and then (Ekind (Entity (N)) = E_Discriminant - or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter) + or else (Ekind (Entity (N)) in E_Constant | E_In_Parameter and then Present (Discriminal_Link (Entity (N))))) then return True; @@ -17358,6 +18268,30 @@ package body Sem_Util is elsif Nkind (N) = N_Null then return True; + -- Ada 2020 (AI12-0175): Calls to certain functions that are essentially + -- unchecked conversions are preelaborable. + + elsif Ada_Version >= Ada_2020 + and then Nkind (N) = N_Function_Call + and then Is_Entity_Name (Name (N)) + and then Is_Preelaborable_Function (Entity (Name (N))) + then + declare + A : Node_Id; + begin + A := First_Actual (N); + + while Present (A) loop + if not Is_Preelaborable_Construct (A) then + return False; + end if; + + Next_Actual (A); + end loop; + end; + + return True; + -- Otherwise the construct is not preelaborable else @@ -17365,6 +18299,50 @@ package body Sem_Util is end if; end Is_Preelaborable_Construct; + ------------------------------- + -- Is_Preelaborable_Function -- + ------------------------------- + + function Is_Preelaborable_Function (Id : Entity_Id) return Boolean is + SATAC : constant Rtsfind.RTU_Id := System_Address_To_Access_Conversions; + Scop : constant Entity_Id := Scope (Id); + + begin + -- Small optimization: every allowed function has convention Intrinsic + -- (see Analyze_Subprogram_Instantiation for the subtlety in the test). + + if not Is_Intrinsic_Subprogram (Id) + and then Convention (Id) /= Convention_Intrinsic + then + return False; + end if; + + -- An instance of Unchecked_Conversion + + if Is_Unchecked_Conversion_Instance (Id) then + return True; + end if; + + -- A function declared in System.Storage_Elements + + if Is_RTU (Scop, System_Storage_Elements) then + return True; + end if; + + -- The functions To_Pointer and To_Address declared in an instance of + -- System.Address_To_Access_Conversions (they are the only ones). + + if Ekind (Scop) = E_Package + and then Nkind (Parent (Scop)) = N_Package_Specification + and then Present (Generic_Parent (Parent (Scop))) + and then Is_RTU (Generic_Parent (Parent (Scop)), SATAC) + then + return True; + end if; + + return False; + end Is_Preelaborable_Function; + --------------------------------- -- Is_Protected_Self_Reference -- --------------------------------- @@ -17568,28 +18546,6 @@ package body Sem_Util is return False; end Is_Renamed_Entry; - ----------------------------- - -- Is_Renaming_Declaration -- - ----------------------------- - - function Is_Renaming_Declaration (N : Node_Id) return Boolean is - begin - case Nkind (N) is - when N_Exception_Renaming_Declaration - | N_Generic_Function_Renaming_Declaration - | N_Generic_Package_Renaming_Declaration - | N_Generic_Procedure_Renaming_Declaration - | N_Object_Renaming_Declaration - | N_Package_Renaming_Declaration - | N_Subprogram_Renaming_Declaration - => - return True; - - when others => - return False; - end case; - end Is_Renaming_Declaration; - ---------------------------- -- Is_Reversible_Iterator -- ---------------------------- @@ -17636,12 +18592,12 @@ package body Sem_Util is begin if not Is_List_Member (N) then declare - P : constant Node_Id := Parent (N); + P : constant Node_Id := Parent (N); begin - return Nkind_In (P, N_Expanded_Name, - N_Generic_Association, - N_Parameter_Association, - N_Selected_Component) + return Nkind (P) in N_Expanded_Name + | N_Generic_Association + | N_Parameter_Association + | N_Selected_Component and then Selector_Name (P) = N; end; @@ -17676,7 +18632,7 @@ package body Sem_Util is function Is_Single_Concurrent_Type (Id : Entity_Id) return Boolean is begin return - Ekind_In (Id, E_Protected_Type, E_Task_Type) + Ekind (Id) in E_Protected_Type | E_Task_Type and then Is_Single_Concurrent_Type_Declaration (Declaration_Node (Id)); end Is_Single_Concurrent_Type; @@ -17689,8 +18645,8 @@ package body Sem_Util is (N : Node_Id) return Boolean is begin - return Nkind_In (Original_Node (N), N_Single_Protected_Declaration, - N_Single_Task_Declaration); + return Nkind (Original_Node (N)) in + N_Single_Protected_Declaration | N_Single_Task_Declaration; end Is_Single_Concurrent_Type_Declaration; --------------------------------------------- @@ -17731,157 +18687,42 @@ package body Sem_Util is and then Is_Single_Concurrent_Type (Etype (Id)); end Is_Single_Task_Object; - ------------------------------------- - -- Is_SPARK_05_Initialization_Expr -- - ------------------------------------- - - function Is_SPARK_05_Initialization_Expr (N : Node_Id) return Boolean is - Is_Ok : Boolean; - Expr : Node_Id; - Comp_Assn : Node_Id; - Orig_N : constant Node_Id := Original_Node (N); + -------------------------------------- + -- Is_Special_Aliased_Formal_Access -- + -------------------------------------- + function Is_Special_Aliased_Formal_Access + (Exp : Node_Id; + Scop : Entity_Id) return Boolean is begin - Is_Ok := True; + -- Verify the expression is an access reference to 'Access within a + -- return statement as this is the only time an explicitly aliased + -- formal has different semantics. - if not Comes_From_Source (Orig_N) then - goto Done; + if Nkind (Exp) /= N_Attribute_Reference + or else Get_Attribute_Id (Attribute_Name (Exp)) /= Attribute_Access + or else Nkind (Parent (Exp)) /= N_Simple_Return_Statement + then + return False; end if; - pragma Assert (Nkind (Orig_N) in N_Subexpr); - - case Nkind (Orig_N) is - when N_Character_Literal - | N_Integer_Literal - | N_Real_Literal - | N_String_Literal - => - null; - - when N_Expanded_Name - | N_Identifier - => - if Is_Entity_Name (Orig_N) - and then Present (Entity (Orig_N)) -- needed in some cases - then - case Ekind (Entity (Orig_N)) is - when E_Constant - | E_Enumeration_Literal - | E_Named_Integer - | E_Named_Real - => - null; - - when others => - if Is_Type (Entity (Orig_N)) then - null; - else - Is_Ok := False; - end if; - end case; - end if; - - when N_Qualified_Expression - | N_Type_Conversion - => - Is_Ok := Is_SPARK_05_Initialization_Expr (Expression (Orig_N)); - - when N_Unary_Op => - Is_Ok := Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N)); - - when N_Binary_Op - | N_Membership_Test - | N_Short_Circuit - => - Is_Ok := Is_SPARK_05_Initialization_Expr (Left_Opnd (Orig_N)) - and then - Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N)); - - when N_Aggregate - | N_Extension_Aggregate - => - if Nkind (Orig_N) = N_Extension_Aggregate then - Is_Ok := - Is_SPARK_05_Initialization_Expr (Ancestor_Part (Orig_N)); - end if; - - Expr := First (Expressions (Orig_N)); - while Present (Expr) loop - if not Is_SPARK_05_Initialization_Expr (Expr) then - Is_Ok := False; - goto Done; - end if; - - Next (Expr); - end loop; - - Comp_Assn := First (Component_Associations (Orig_N)); - while Present (Comp_Assn) loop - Expr := Expression (Comp_Assn); - - -- Note: test for Present here needed for box assocation - - if Present (Expr) - and then not Is_SPARK_05_Initialization_Expr (Expr) - then - Is_Ok := False; - goto Done; - end if; - - Next (Comp_Assn); - end loop; - - when N_Attribute_Reference => - if Nkind (Prefix (Orig_N)) in N_Subexpr then - Is_Ok := Is_SPARK_05_Initialization_Expr (Prefix (Orig_N)); - end if; - - Expr := First (Expressions (Orig_N)); - while Present (Expr) loop - if not Is_SPARK_05_Initialization_Expr (Expr) then - Is_Ok := False; - goto Done; - end if; - - Next (Expr); - end loop; + -- Check if the prefix of the reference is indeed an explicitly aliased + -- formal parameter for the function Scop. Additionally, we must check + -- that Scop returns an anonymous access type, otherwise the special + -- rules dictating a need for a dynamic check are not in effect. - -- Selected components might be expanded named not yet resolved, so - -- default on the safe side. (Eg on sparklex.ads) - - when N_Selected_Component => - null; - - when others => - Is_Ok := False; - end case; - - <<Done>> - return Is_Ok; - end Is_SPARK_05_Initialization_Expr; - - ---------------------------------- - -- Is_SPARK_05_Object_Reference -- - ---------------------------------- - - function Is_SPARK_05_Object_Reference (N : Node_Id) return Boolean is - begin - if Is_Entity_Name (N) then - return Present (Entity (N)) - and then - (Ekind_In (Entity (N), E_Constant, E_Variable) - or else Ekind (Entity (N)) in Formal_Kind); - - else - case Nkind (N) is - when N_Selected_Component => - return Is_SPARK_05_Object_Reference (Prefix (N)); - - when others => - return False; - end case; - end if; - end Is_SPARK_05_Object_Reference; + declare + P_Ult : constant Node_Id := Ultimate_Prefix (Prefix (Exp)); + begin + return Is_Entity_Name (P_Ult) + and then Is_Aliased (Entity (P_Ult)) + and then Is_Formal (Entity (P_Ult)) + and then Scope (Entity (P_Ult)) = Scop + and then Ekind (Scop) in + E_Function | E_Operator | E_Subprogram_Type + and then Needs_Result_Accessibility_Level (Scop); + end; + end Is_Special_Aliased_Formal_Access; ----------------------------- -- Is_Specific_Tagged_Type -- @@ -17915,6 +18756,74 @@ package body Sem_Util is or else Nkind (N) = N_Procedure_Call_Statement; end Is_Statement; + ------------------------ + -- Is_Static_Function -- + ------------------------ + + function Is_Static_Function (Subp : Entity_Id) return Boolean is + begin + return Has_Aspect (Subp, Aspect_Static) + and then + (No (Find_Value_Of_Aspect (Subp, Aspect_Static)) + or else Is_True (Static_Boolean + (Find_Value_Of_Aspect (Subp, Aspect_Static)))); + end Is_Static_Function; + + ------------------------------ + -- Is_Static_Function_Call -- + ------------------------------ + + function Is_Static_Function_Call (Call : Node_Id) return Boolean is + function Has_All_Static_Actuals (Call : Node_Id) return Boolean; + -- Return whether all actual parameters of Call are static expressions + + ---------------------------- + -- Has_All_Static_Actuals -- + ---------------------------- + + function Has_All_Static_Actuals (Call : Node_Id) return Boolean is + Actual : Node_Id := First_Actual (Call); + String_Result : constant Boolean := + Is_String_Type (Etype (Entity (Name (Call)))); + + begin + while Present (Actual) loop + if not Is_Static_Expression (Actual) then + + -- ??? In the string-returning case we want to avoid a call + -- being made to Establish_Transient_Scope in Resolve_Call, + -- but at the point where that's tested for (which now includes + -- a call to test Is_Static_Function_Call), the actuals of the + -- call haven't been resolved, so expressions of the actuals + -- may not have been marked Is_Static_Expression yet, so we + -- force them to be resolved here, so we can tell if they're + -- static. Calling Resolve here is admittedly a kludge, and we + -- limit this call to string-returning cases. + + if String_Result then + Resolve (Actual); + end if; + + -- Test flag again in case it's now True due to above Resolve + + if not Is_Static_Expression (Actual) then + return False; + end if; + end if; + + Next_Actual (Actual); + end loop; + + return True; + end Has_All_Static_Actuals; + + begin + return Nkind (Call) = N_Function_Call + and then Is_Entity_Name (Name (Call)) + and then Is_Static_Function (Entity (Name (Call))) + and then Has_All_Static_Actuals (Call); + end Is_Static_Function_Call; + ---------------------------------------- -- Is_Subcomponent_Of_Atomic_Object -- ---------------------------------------- @@ -17925,7 +18834,7 @@ package body Sem_Util is begin R := Get_Referenced_Object (N); - while Nkind_In (R, N_Indexed_Component, N_Selected_Component, N_Slice) + while Nkind (R) in N_Indexed_Component | N_Selected_Component | N_Slice loop R := Get_Referenced_Object (Prefix (R)); @@ -18281,7 +19190,7 @@ package body Sem_Util is end if; end if; - Idx := Next_Index (Idx); + Next_Index (Idx); end loop; return False; @@ -18461,14 +19370,14 @@ package body Sem_Util is or else Is_Variable_Prefix (Original_Node (Prefix (N))); - -- in Ada 2012, the dereference may have been added for a type with - -- a declared implicit dereference aspect. Check that it is not an - -- access to constant. + -- Generalized indexing operations are rewritten as explicit + -- dereferences, and it is only during resolution that we can + -- check whether the context requires an access_to_variable type. elsif Nkind (N) = N_Explicit_Dereference and then Present (Etype (Orig_Node)) - and then Ada_Version >= Ada_2012 and then Has_Implicit_Dereference (Etype (Orig_Node)) + and then Ada_Version >= Ada_2012 then return not Is_Access_Constant (Etype (Prefix (N))); @@ -18567,6 +19476,31 @@ package body Sem_Util is end if; end Is_Variable; + ------------------------ + -- Is_View_Conversion -- + ------------------------ + + function Is_View_Conversion (N : Node_Id) return Boolean is + begin + if Nkind (N) = N_Type_Conversion + and then Nkind (Unqual_Conv (N)) = N_Identifier + then + if Is_Tagged_Type (Etype (N)) + and then Is_Tagged_Type (Etype (Unqual_Conv (N))) + then + return True; + + elsif Is_Actual_Parameter (N) + and then (Is_Actual_Out_Parameter (N) + or else Is_Actual_In_Out_Parameter (N)) + then + return True; + end if; + end if; + + return False; + end Is_View_Conversion; + --------------------------- -- Is_Visibly_Controlled -- --------------------------- @@ -18624,7 +19558,7 @@ package body Sem_Util is function Is_Volatile_Function (Func_Id : Entity_Id) return Boolean is begin - pragma Assert (Ekind_In (Func_Id, E_Function, E_Generic_Function)); + pragma Assert (Ekind (Func_Id) in E_Function | E_Generic_Function); -- A function declared within a protected type is volatile @@ -18755,8 +19689,8 @@ package body Sem_Util is begin pragma Assert (Is_Itype (Id)); return Present (Parent (Id)) - and then Nkind_In (Parent (Id), N_Full_Type_Declaration, - N_Subtype_Declaration) + and then Nkind (Parent (Id)) in + N_Full_Type_Declaration | N_Subtype_Declaration and then Defining_Entity (Parent (Id)) = Id; end Itype_Has_Declaration; @@ -19167,9 +20101,8 @@ package body Sem_Util is -- Obj := new ...'(new Coextension ...); if Nkind (Context_Nod) = N_Assignment_Statement then - Is_Dynamic := - Nkind_In (Expression (Context_Nod), N_Allocator, - N_Qualified_Expression); + Is_Dynamic := Nkind (Expression (Context_Nod)) in + N_Allocator | N_Qualified_Expression; -- An allocator that appears within the expression of a simple return -- statement is treated as a potentially dynamic coextension when the @@ -19179,10 +20112,8 @@ package body Sem_Util is -- return new ...'(new Coextension ...); elsif Nkind (Context_Nod) = N_Simple_Return_Statement then - Is_Dynamic := - Nkind_In (Expression (Context_Nod), N_Aggregate, - N_Allocator, - N_Qualified_Expression); + Is_Dynamic := Nkind (Expression (Context_Nod)) in + N_Aggregate | N_Allocator | N_Qualified_Expression; -- An alloctor that appears within the initialization expression of an -- object declaration is considered a potentially dynamic coextension @@ -19198,10 +20129,8 @@ package body Sem_Util is -- return Obj : ... := (new Coextension ...); elsif Nkind (Context_Nod) = N_Object_Declaration then - Is_Dynamic := - Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression) - or else - Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; + Is_Dynamic := Nkind (Root_Nod) in N_Allocator | N_Qualified_Expression + or else Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; -- This routine should not be called with constructs that cannot contain -- coextensions. @@ -19367,12 +20296,12 @@ package body Sem_Util is -- suppressed. As a result the elaboration checks of the call must -- be disabled in order to preserve this dependency. - if Nkind_In (N, N_Entry_Call_Statement, - N_Function_Call, - N_Function_Instantiation, - N_Package_Instantiation, - N_Procedure_Call_Statement, - N_Procedure_Instantiation) + if Nkind (N) in N_Entry_Call_Statement + | N_Function_Call + | N_Function_Instantiation + | N_Package_Instantiation + | N_Procedure_Call_Statement + | N_Procedure_Instantiation then Nam := Extract_Name (N); @@ -19451,16 +20380,16 @@ package body Sem_Util is -- Obtain the complimentary unit of the main unit - if Nkind_In (Main_Unit, N_Generic_Package_Declaration, - N_Generic_Subprogram_Declaration, - N_Package_Declaration, - N_Subprogram_Declaration) + if Nkind (Main_Unit) in N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration + | N_Package_Declaration + | N_Subprogram_Declaration then Aux_Id := Corresponding_Body (Main_Unit); - elsif Nkind_In (Main_Unit, N_Package_Body, - N_Subprogram_Body, - N_Subprogram_Renaming_Declaration) + elsif Nkind (Main_Unit) in N_Package_Body + | N_Subprogram_Body + | N_Subprogram_Renaming_Declaration then Aux_Id := Corresponding_Spec (Main_Unit); end if; @@ -19791,12 +20720,10 @@ package body Sem_Util is function Process (N : Node_Id) return Traverse_Result is begin - if Nkind_In (N, N_Procedure_Call_Statement, - N_Function_Call, - N_Raise_Statement, - N_Raise_Constraint_Error, - N_Raise_Program_Error, - N_Raise_Storage_Error) + if Nkind (N) in N_Procedure_Call_Statement + | N_Function_Call + | N_Raise_Statement + | N_Raise_xxx_Error then Result := True; return Abandon; @@ -19978,6 +20905,144 @@ package body Sem_Util is end if; end Needs_One_Actual; + -------------------------------------- + -- Needs_Result_Accessibility_Level -- + -------------------------------------- + + function Needs_Result_Accessibility_Level + (Func_Id : Entity_Id) return Boolean + is + Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); + + function Has_Unconstrained_Access_Discriminant_Component + (Comp_Typ : Entity_Id) return Boolean; + -- Returns True if any component of the type has an unconstrained access + -- discriminant. + + ----------------------------------------------------- + -- Has_Unconstrained_Access_Discriminant_Component -- + ----------------------------------------------------- + + function Has_Unconstrained_Access_Discriminant_Component + (Comp_Typ : Entity_Id) return Boolean + is + begin + if not Is_Limited_Type (Comp_Typ) then + return False; + + -- Only limited types can have access discriminants with + -- defaults. + + elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then + return True; + + elsif Is_Array_Type (Comp_Typ) then + return Has_Unconstrained_Access_Discriminant_Component + (Underlying_Type (Component_Type (Comp_Typ))); + + elsif Is_Record_Type (Comp_Typ) then + declare + Comp : Entity_Id; + + begin + Comp := First_Component (Comp_Typ); + while Present (Comp) loop + if Has_Unconstrained_Access_Discriminant_Component + (Underlying_Type (Etype (Comp))) + then + return True; + end if; + + Next_Component (Comp); + end loop; + end; + end if; + + return False; + end Has_Unconstrained_Access_Discriminant_Component; + + Disable_Coextension_Cases : constant Boolean := True; + -- Flag used to temporarily disable a "True" result for types with + -- access discriminants and related coextension cases. + + -- Start of processing for Needs_Result_Accessibility_Level + + begin + -- False if completion unavailable (how does this happen???) + + if not Present (Func_Typ) then + return False; + + -- False if not a function, also handle enum-lit renames case + + elsif Func_Typ = Standard_Void_Type + or else Is_Scalar_Type (Func_Typ) + then + return False; + + -- Handle a corner case, a cross-dialect subp renaming. For example, + -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when + -- an Ada 2005 (or earlier) unit references predefined run-time units. + + elsif Present (Alias (Func_Id)) then + + -- Unimplemented: a cross-dialect subp renaming which does not set + -- the Alias attribute (e.g., a rename of a dereference of an access + -- to subprogram value). ??? + + return Present (Extra_Accessibility_Of_Result (Alias (Func_Id))); + + -- Remaining cases require Ada 2012 mode + + elsif Ada_Version < Ada_2012 then + return False; + + -- Handle the situation where a result is an anonymous access type + -- RM 3.10.2 (10.3/3). + + elsif Ekind (Func_Typ) = E_Anonymous_Access_Type then + return True; + + -- The following cases are related to coextensions and do not fully + -- cover everything mentioned in RM 3.10.2 (12) ??? + + -- Temporarily disabled ??? + + elsif Disable_Coextension_Cases then + return False; + + -- In the case of, say, a null tagged record result type, the need for + -- this extra parameter might not be obvious so this function returns + -- True for all tagged types for compatibility reasons. + + -- A function with, say, a tagged null controlling result type might + -- be overridden by a primitive of an extension having an access + -- discriminant and the overrider and overridden must have compatible + -- calling conventions (including implicitly declared parameters). + + -- Similarly, values of one access-to-subprogram type might designate + -- both a primitive subprogram of a given type and a function which is, + -- for example, not a primitive subprogram of any type. Again, this + -- requires calling convention compatibility. It might be possible to + -- solve these issues by introducing wrappers, but that is not the + -- approach that was chosen. + + elsif Is_Tagged_Type (Func_Typ) then + return True; + + elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then + return True; + + elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then + return True; + + -- False for all other cases + + else + return False; + end if; + end Needs_Result_Accessibility_Level; + --------------------------------- -- Needs_Simple_Initialization -- --------------------------------- @@ -20087,9 +21152,9 @@ package body Sem_Util is -- subprogram call, and the caller requests this behavior. elsif not Calls_OK - and then Nkind_In (Par, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) + and then Nkind (Par) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement then return False; @@ -20120,12 +21185,6 @@ package body Sem_Util is if Legacy_Elaboration_Checks then return False; - -- No marker needs to be created for ASIS because ABE diagnostics and - -- checks are not performed in this mode. - - elsif ASIS_Mode then - return False; - -- No marker needs to be created when the reference is preanalyzed -- because the marker will be inserted in the wrong place. @@ -20134,7 +21193,7 @@ package body Sem_Util is -- Only references warrant a marker - elsif not Nkind_In (N, N_Expanded_Name, N_Identifier) then + elsif Nkind (N) not in N_Expanded_Name | N_Identifier then return False; -- Only source references warrant a marker @@ -20198,13 +21257,125 @@ package body Sem_Util is while Present (E) loop Append (New_Copy_Tree (E), NL); - E := Next (E); + Next (E); end loop; return NL; end if; end New_Copy_List_Tree; + ---------------------------- + -- New_Copy_Separate_List -- + ---------------------------- + + function New_Copy_Separate_List (List : List_Id) return List_Id is + begin + if List = No_List then + return No_List; + + else + declare + List_Copy : constant List_Id := New_List; + N : Node_Id := First (List); + + begin + while Present (N) loop + Append (New_Copy_Separate_Tree (N), List_Copy); + Next (N); + end loop; + + return List_Copy; + end; + end if; + end New_Copy_Separate_List; + + ---------------------------- + -- New_Copy_Separate_Tree -- + ---------------------------- + + function New_Copy_Separate_Tree (Source : Node_Id) return Node_Id is + function Search_Decl (N : Node_Id) return Traverse_Result; + -- Subtree visitor which collects declarations + + procedure Search_Declarations is new Traverse_Proc (Search_Decl); + -- Subtree visitor instantiation + + ----------------- + -- Search_Decl -- + ----------------- + + Decls : Elist_Id; + + function Search_Decl (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) in N_Declaration then + if No (Decls) then + Decls := New_Elmt_List; + end if; + + Append_Elmt (N, Decls); + end if; + + return OK; + end Search_Decl; + + -- Local variables + + Source_Copy : constant Node_Id := New_Copy_Tree (Source); + + -- Start of processing for New_Copy_Separate_Tree + + begin + Decls := No_Elist; + Search_Declarations (Source_Copy); + + -- Associate a new Entity with all the subtree declarations (keeping + -- their original name). + + if Present (Decls) then + declare + Elmt : Elmt_Id; + Decl : Node_Id; + New_E : Entity_Id; + + begin + Elmt := First_Elmt (Decls); + while Present (Elmt) loop + Decl := Node (Elmt); + New_E := Make_Defining_Identifier (Sloc (Decl), + New_Internal_Name ('P')); + + if Nkind (Decl) = N_Expression_Function then + Decl := Specification (Decl); + end if; + + if Nkind (Decl) in N_Function_Instantiation + | N_Function_Specification + | N_Generic_Function_Renaming_Declaration + | N_Generic_Package_Renaming_Declaration + | N_Generic_Procedure_Renaming_Declaration + | N_Package_Body + | N_Package_Instantiation + | N_Package_Renaming_Declaration + | N_Package_Specification + | N_Procedure_Instantiation + | N_Procedure_Specification + then + Set_Chars (New_E, Chars (Defining_Unit_Name (Decl))); + Set_Defining_Unit_Name (Decl, New_E); + else + Set_Chars (New_E, Chars (Defining_Identifier (Decl))); + Set_Defining_Identifier (Decl, New_E); + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + + return Source_Copy; + end New_Copy_Separate_Tree; + ------------------- -- New_Copy_Tree -- ------------------- @@ -20312,7 +21483,7 @@ package body Sem_Util is -- New_Id is the corresponding new entity generated during Phase 1. procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id); - pragma Inline (Add_New_Entity); + pragma Inline (Add_Pending_Itype); -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to -- value Itype. Assoc_Nod is the associated node of an itype. Itype is -- an itype. @@ -20633,6 +21804,65 @@ package body Sem_Util is New_Par : Node_Id := Empty; Semantic : Boolean := False) return Union_Id is + function Has_More_Ids (N : Node_Id) return Boolean; + -- Return True when N has attribute More_Ids set to True + + function Is_Syntactic_Node return Boolean; + -- Return True when Field is a syntactic node + + ------------------ + -- Has_More_Ids -- + ------------------ + + function Has_More_Ids (N : Node_Id) return Boolean is + begin + if Nkind (N) in N_Component_Declaration + | N_Discriminant_Specification + | N_Exception_Declaration + | N_Formal_Object_Declaration + | N_Number_Declaration + | N_Object_Declaration + | N_Parameter_Specification + | N_Use_Package_Clause + | N_Use_Type_Clause + then + return More_Ids (N); + else + return False; + end if; + end Has_More_Ids; + + ----------------------- + -- Is_Syntactic_Node -- + ----------------------- + + function Is_Syntactic_Node return Boolean is + Old_N : constant Node_Id := Node_Id (Field); + + begin + if Parent (Old_N) = Old_Par then + return True; + + elsif not Has_More_Ids (Old_Par) then + return False; + + -- Perform the check using the last last id in the syntactic chain + + else + declare + N : Node_Id := Old_Par; + + begin + while Present (N) and then More_Ids (N) loop + Next (N); + end loop; + + pragma Assert (Prev_Ids (N)); + return Parent (Old_N) = N; + end; + end if; + end Is_Syntactic_Node; + begin -- The field is empty @@ -20644,7 +21874,7 @@ package body Sem_Util is elsif Field in Node_Range then declare Old_N : constant Node_Id := Node_Id (Field); - Syntactic : constant Boolean := Parent (Old_N) = Old_Par; + Syntactic : constant Boolean := Is_Syntactic_Node; New_N : Node_Id; @@ -20835,9 +22065,9 @@ package body Sem_Util is -- Update the First/Next_Named_Association chain for a replicated -- call. - if Nkind_In (N, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) + if Nkind (N) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement then Update_Named_Associations (Old_Call => N, @@ -20872,6 +22102,11 @@ package body Sem_Util is Set_Chars (Result, Chars (Entity (Result))); end if; end if; + + if Has_Aspects (N) then + Set_Aspect_Specifications (Result, + Copy_List_With_Replacement (Aspect_Specifications (N))); + end if; end if; return Result; @@ -21254,12 +22489,9 @@ package body Sem_Util is -- an entity declaration that must be replaced when the expander is -- active if the expression has been preanalyzed or analyzed. - elsif not Ekind_In (Id, E_Block, - E_Constant, - E_Label, - E_Loop_Parameter, - E_Procedure, - E_Variable) + elsif Ekind (Id) not in + E_Block | E_Constant | E_Label | E_Loop_Parameter | + E_Procedure | E_Variable and then not Is_Type (Id) then return; @@ -21464,7 +22696,7 @@ package body Sem_Util is -- shared. Thus cloned_Subtype must be set to indicate the sharing. -- ??? What does this do? - if Ekind_In (Itype, E_Class_Wide_Subtype, E_Record_Subtype) then + if Ekind (Itype) in E_Class_Wide_Subtype | E_Record_Subtype then Set_Cloned_Subtype (New_Itype, Itype); end if; @@ -21552,9 +22784,9 @@ package body Sem_Util is EWA_Level := EWA_Level + 1; elsif EWA_Level > 0 - and then Nkind_In (N, N_Block_Statement, - N_Subprogram_Body, - N_Subprogram_Declaration) + and then Nkind (N) in N_Block_Statement + | N_Subprogram_Body + | N_Subprogram_Declaration then EWA_Inner_Scope_Level := EWA_Inner_Scope_Level + 1; end if; @@ -21580,9 +22812,9 @@ package body Sem_Util is Par_Nod => N); if EWA_Level > 0 - and then Nkind_In (N, N_Block_Statement, - N_Subprogram_Body, - N_Subprogram_Declaration) + and then Nkind (N) in N_Block_Statement + | N_Subprogram_Body + | N_Subprogram_Declaration then EWA_Inner_Scope_Level := EWA_Inner_Scope_Level - 1; @@ -21849,9 +23081,9 @@ package body Sem_Util is -- In case of a build-in-place call, the call will no longer be a -- call; it will have been rewritten. - if Nkind_In (Par, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) + if Nkind (Par) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement then return First_Named_Actual (Par); @@ -21939,36 +23171,34 @@ package body Sem_Util is Comp : Entity_Id; begin - Comp := First_Entity (Typ); + Comp := First_Component (Typ); while Present (Comp) loop -- Only look at E_Component entities. No need to look at -- E_Discriminant entities, and we must ignore internal -- subtypes generated for constrained components. - if Ekind (Comp) = E_Component then - declare - Comp_Type : constant Entity_Id := - Underlying_Type (Etype (Comp)); + declare + Comp_Type : constant Entity_Id := + Underlying_Type (Etype (Comp)); - begin - if Is_Record_Type (Comp_Type) - or else - Is_Protected_Type (Comp_Type) - then - if not Caller_Known_Size_Record (Comp_Type) then - return False; - end if; + begin + if Is_Record_Type (Comp_Type) + or else + Is_Protected_Type (Comp_Type) + then + if not Caller_Known_Size_Record (Comp_Type) then + return False; + end if; - elsif Is_Array_Type (Comp_Type) then - if Size_Depends_On_Discriminant (Comp_Type) then - return False; - end if; + elsif Is_Array_Type (Comp_Type) then + if Size_Depends_On_Discriminant (Comp_Type) then + return False; end if; - end; - end if; + end if; + end; - Next_Entity (Comp); + Next_Component (Comp); end loop; end; @@ -22015,41 +23245,39 @@ package body Sem_Util is Comp : Entity_Id; begin - Comp := First_Entity (Typ); + Comp := First_Component (Typ); while Present (Comp) loop - if Ekind (Comp) = E_Component then - declare - Comp_Type : constant Entity_Id := - Underlying_Type (Etype (Comp)); + declare + Comp_Type : constant Entity_Id := + Underlying_Type (Etype (Comp)); - Hi : Node_Id; - Indx : Node_Id; - Ityp : Entity_Id; + Hi : Node_Id; + Indx : Node_Id; + Ityp : Entity_Id; - begin - if Is_Array_Type (Comp_Type) then - Indx := First_Index (Comp_Type); - - while Present (Indx) loop - Ityp := Etype (Indx); - Hi := Type_High_Bound (Ityp); - - if Nkind (Hi) = N_Identifier - and then Ekind (Entity (Hi)) = E_Discriminant - and then Is_Large_Discrete_Type (Ityp) - and then Is_Large_Discrete_Type - (Etype (Entity (Hi))) - then - return True; - end if; + begin + if Is_Array_Type (Comp_Type) then + Indx := First_Index (Comp_Type); + + while Present (Indx) loop + Ityp := Etype (Indx); + Hi := Type_High_Bound (Ityp); + + if Nkind (Hi) = N_Identifier + and then Ekind (Entity (Hi)) = E_Discriminant + and then Is_Large_Discrete_Type (Ityp) + and then Is_Large_Discrete_Type + (Etype (Entity (Hi))) + then + return True; + end if; - Next_Index (Indx); - end loop; - end if; - end; - end if; + Next_Index (Indx); + end loop; + end if; + end; - Next_Entity (Comp); + Next_Component (Comp); end loop; end; end if; @@ -22134,6 +23362,7 @@ package body Sem_Util is ------------------------ function No_Caching_Enabled (Id : Entity_Id) return Boolean is + pragma Assert (Ekind (Id) = E_Variable); Prag : constant Node_Id := Get_Pragma (Id, Pragma_No_Caching); Arg1 : Node_Id; @@ -22167,7 +23396,7 @@ package body Sem_Util is function No_Heap_Finalization (Typ : Entity_Id) return Boolean is begin - if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) + if Ekind (Typ) in E_Access_Type | E_General_Access_Type and then Is_Library_Level_Entity (Typ) then -- A global No_Heap_Finalization pragma applies to all library-level @@ -22397,9 +23626,9 @@ package body Sem_Util is then if No (Actuals) and then - Nkind_In (Parent (N), N_Procedure_Call_Statement, - N_Function_Call, - N_Parameter_Association) + Nkind (Parent (N)) in N_Procedure_Call_Statement + | N_Function_Call + | N_Parameter_Association and then Ekind (S) /= E_Function then Set_Etype (N, Etype (S)); @@ -22551,15 +23780,13 @@ package body Sem_Util is end if; end; - elsif Nkind_In (Exp, N_Type_Conversion, - N_Unchecked_Type_Conversion) + elsif Nkind (Exp) in N_Type_Conversion | N_Unchecked_Type_Conversion then Exp := Expression (Exp); goto Continue; - elsif Nkind_In (Exp, N_Slice, - N_Indexed_Component, - N_Selected_Component) + elsif Nkind (Exp) in + N_Slice | N_Indexed_Component | N_Selected_Component then -- Special check, if the prefix is an access type, then return -- since we are modifying the thing pointed to, not the prefix. @@ -22620,7 +23847,7 @@ package body Sem_Util is -- Follow renaming chain - if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant) + if Ekind (Ent) in E_Variable | E_Constant and then Present (Renamed_Object (Ent)) then Exp := Renamed_Object (Ent); @@ -22643,8 +23870,8 @@ package body Sem_Util is -- a modification of the container. elsif Comes_From_Source (Original_Node (Exp)) - and then Nkind_In (Original_Node (Exp), N_Selected_Component, - N_Indexed_Component) + and then Nkind (Original_Node (Exp)) in + N_Selected_Component | N_Indexed_Component then Exp := Prefix (Original_Node (Exp)); goto Continue; @@ -22737,13 +23964,12 @@ package body Sem_Util is function Is_Null_Excluding_Def (Def : Node_Id) return Boolean is begin - return - Nkind_In (Def, N_Access_Definition, - N_Access_Function_Definition, - N_Access_Procedure_Definition, - N_Access_To_Object_Definition, - N_Component_Definition, - N_Derived_Type_Definition) + return Nkind (Def) in N_Access_Definition + | N_Access_Function_Definition + | N_Access_Procedure_Definition + | N_Access_To_Object_Definition + | N_Component_Definition + | N_Derived_Type_Definition and then Null_Exclusion_Present (Def); end Is_Null_Excluding_Def; @@ -22765,12 +23991,12 @@ package body Sem_Util is if Is_Imported (Id) or else Is_Exported (Id) then return Unknown; - elsif Nkind_In (Decl, N_Component_Declaration, - N_Discriminant_Specification, - N_Formal_Object_Declaration, - N_Object_Declaration, - N_Object_Renaming_Declaration, - N_Parameter_Specification) + elsif Nkind (Decl) in N_Component_Declaration + | N_Discriminant_Specification + | N_Formal_Object_Declaration + | N_Object_Declaration + | N_Object_Renaming_Declaration + | N_Parameter_Specification then -- A component declaration yields a non-null value when either -- its component definition or access definition carries a null @@ -22891,9 +24117,9 @@ package body Sem_Util is -- Taking the 'Access of something yields a non-null value elsif Nkind (N) = N_Attribute_Reference - and then Nam_In (Attribute_Name (N), Name_Access, - Name_Unchecked_Access, - Name_Unrestricted_Access) + and then Attribute_Name (N) in Name_Access + | Name_Unchecked_Access + | Name_Unrestricted_Access then return Is_Non_Null; @@ -22937,7 +24163,8 @@ package body Sem_Util is if Nkind (N) = N_Null then return Present (Typ) and then Is_Descendant_Of_Address (Typ); - elsif Nkind_In (N, N_Op_Eq, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt, N_Op_Ne) + elsif Nkind (N) in + N_Op_Eq | N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt | N_Op_Ne then declare L : constant Node_Id := Left_Opnd (N); @@ -23061,18 +24288,31 @@ package body Sem_Util is -- Local variables - E : Entity_Id; + E : Entity_Id; + Orig_Obj : Node_Id := Original_Node (Obj); + Orig_Pre : Node_Id; -- Start of processing for Object_Access_Level begin - if Nkind (Obj) = N_Defining_Identifier - or else Is_Entity_Name (Obj) + -- In the case of an expanded implicit dereference we swap the original + -- object to be the expanded conversion. + + if Nkind (Obj) = N_Explicit_Dereference + and then Nkind (Orig_Obj) /= N_Explicit_Dereference + then + Orig_Obj := Obj; + end if; + + -- Calculate the object node's accessibility level + + if Nkind (Orig_Obj) = N_Defining_Identifier + or else Is_Entity_Name (Orig_Obj) then - if Nkind (Obj) = N_Defining_Identifier then - E := Obj; + if Nkind (Orig_Obj) = N_Defining_Identifier then + E := Orig_Obj; else - E := Entity (Obj); + E := Entity (Orig_Obj); end if; if Is_Prival (E) then @@ -23085,7 +24325,7 @@ package body Sem_Util is -- than the level of any visible named access type (see 3.10.2(21)). if Is_Type (E) then - return Type_Access_Level (E) + 1; + return Type_Access_Level (E) + 1; elsif Present (Renamed_Object (E)) then return Object_Access_Level (Renamed_Object (E)); @@ -23102,31 +24342,27 @@ package body Sem_Util is then return Type_Access_Level (Scope (E)) + 1; - else - -- Aliased formals of functions take their access level from the - -- point of call, i.e. require a dynamic check. For static check - -- purposes, this is smaller than the level of the subprogram - -- itself. For procedures the aliased makes no difference. - - if Is_Formal (E) - and then Is_Aliased (E) - and then Ekind (Scope (E)) = E_Function - then - return Type_Access_Level (Etype (E)); + -- An object of a named access type gets its level from its + -- associated type. - else - return Scope_Depth (Enclosing_Dynamic_Scope (E)); - end if; + elsif Is_Named_Access_Type (Etype (E)) then + return Type_Access_Level (Etype (E)); + + else + return Scope_Depth (Enclosing_Dynamic_Scope (E)); end if; - elsif Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then - if Is_Access_Type (Etype (Prefix (Obj))) then - return Type_Access_Level (Etype (Prefix (Obj))); + elsif Nkind (Orig_Obj) in N_Indexed_Component | N_Selected_Component then + Orig_Pre := Original_Node (Prefix (Orig_Obj)); + + if Is_Access_Type (Etype (Orig_Pre)) then + return Type_Access_Level (Etype (Orig_Pre)); else - return Object_Access_Level (Prefix (Obj)); + return Object_Access_Level (Prefix (Orig_Obj)); end if; - elsif Nkind (Obj) = N_Explicit_Dereference then + elsif Nkind (Orig_Obj) = N_Explicit_Dereference then + Orig_Pre := Original_Node (Prefix (Orig_Obj)); -- If the prefix is a selected access discriminant then we make a -- recursive call on the prefix, which will in turn check the level @@ -23138,46 +24374,47 @@ package body Sem_Util is -- otherwise expansion will already have transformed the prefix into -- a temporary. - if Nkind (Prefix (Obj)) = N_Selected_Component - and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type + if Nkind (Orig_Pre) = N_Selected_Component + and then Ekind (Etype (Orig_Pre)) = E_Anonymous_Access_Type and then - Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant + Ekind (Entity (Selector_Name (Orig_Pre))) = E_Discriminant and then (not Has_Implicit_Dereference - (Entity (Selector_Name (Prefix (Obj)))) + (Entity (Selector_Name (Orig_Pre))) or else Nkind (Parent (Obj)) /= N_Selected_Component) then - return Object_Access_Level (Prefix (Obj)); + return Object_Access_Level (Prefix (Orig_Obj)); -- Detect an interface conversion in the context of a dispatching -- call. Use the original form of the conversion to find the access -- level of the operand. - elsif Is_Interface (Etype (Obj)) - and then Is_Interface_Conversion (Prefix (Obj)) - and then Nkind (Original_Node (Obj)) = N_Type_Conversion + elsif Is_Interface (Etype (Orig_Obj)) + and then Is_Interface_Conversion (Orig_Pre) + and then Nkind (Orig_Obj) = N_Type_Conversion then - return Object_Access_Level (Original_Node (Obj)); + return Object_Access_Level (Orig_Obj); - elsif not Comes_From_Source (Obj) then + elsif not Comes_From_Source (Orig_Obj) then declare - Ref : constant Node_Id := Reference_To (Obj); + Ref : constant Node_Id := Reference_To (Orig_Obj); begin if Present (Ref) then return Object_Access_Level (Ref); else - return Type_Access_Level (Etype (Prefix (Obj))); + return Type_Access_Level (Etype (Prefix (Orig_Obj))); end if; end; else - return Type_Access_Level (Etype (Prefix (Obj))); + return Type_Access_Level (Etype (Prefix (Orig_Obj))); end if; - elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then - return Object_Access_Level (Expression (Obj)); + elsif Nkind (Orig_Obj) in N_Type_Conversion | N_Unchecked_Type_Conversion + then + return Object_Access_Level (Expression (Orig_Obj)); - elsif Nkind (Obj) = N_Function_Call then + elsif Nkind (Orig_Obj) = N_Function_Call then -- Function results are objects, so we get either the access level of -- the function or, in the case of an indirect call, the level of the @@ -23188,10 +24425,10 @@ package body Sem_Util is -- compiled with -gnat95. ???) if Ada_Version < Ada_2005 then - if Is_Entity_Name (Name (Obj)) then - return Subprogram_Access_Level (Entity (Name (Obj))); + if Is_Entity_Name (Name (Orig_Obj)) then + return Subprogram_Access_Level (Entity (Name (Orig_Obj))); else - return Type_Access_Level (Etype (Prefix (Name (Obj)))); + return Type_Access_Level (Etype (Prefix (Name (Orig_Obj)))); end if; -- For Ada 2005, the level of the result object of a function call is @@ -23291,6 +24528,9 @@ package body Sem_Util is -- Start of processing for Return_Master_Scope_Depth_Of_Call begin + -- Expanded code may have clobbered the scoping data from the + -- original object node - so use the expanded one. + return Innermost_Master_Scope_Depth (Obj); end Return_Master_Scope_Depth_Of_Call; end if; @@ -23298,15 +24538,34 @@ package body Sem_Util is -- For convenience we handle qualified expressions, even though they -- aren't technically object names. - elsif Nkind (Obj) = N_Qualified_Expression then - return Object_Access_Level (Expression (Obj)); + elsif Nkind (Orig_Obj) = N_Qualified_Expression then + return Object_Access_Level (Expression (Orig_Obj)); -- Ditto for aggregates. They have the level of the temporary that -- will hold their value. - elsif Nkind (Obj) = N_Aggregate then + elsif Nkind (Orig_Obj) = N_Aggregate then + return Object_Access_Level (Current_Scope); + + -- Treat an Old/Loop_Entry attribute reference like an aggregate. + -- AARM 6.1.1(27.d) says "... the implicit constant declaration + -- defines the accessibility level of X'Old", so that is what + -- we are trying to implement here. + + elsif Nkind (Orig_Obj) = N_Attribute_Reference + and then Attribute_Name (Orig_Obj) in Name_Old | Name_Loop_Entry + then return Object_Access_Level (Current_Scope); + -- Move up the attribute reference when we encounter a 'Access variation + + elsif Nkind (Orig_Obj) = N_Attribute_Reference + and then Attribute_Name (Orig_Obj) in Name_Access + | Name_Unchecked_Access + | Name_Unrestricted_Access + then + return Object_Access_Level (Prefix (Orig_Obj)); + -- Otherwise return the scope level of Standard. (If there are cases -- that fall through to this point they will be treated as having -- global accessibility for now. ???) @@ -23424,7 +24683,7 @@ package body Sem_Util is Item_Nam : Name_Id; begin - pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma)); + pragma Assert (Nkind (N) in N_Aspect_Specification | N_Pragma); Item := N; @@ -23463,8 +24722,7 @@ package body Sem_Util is elsif Item_Nam = Name_Pre then Item_Nam := Name_uPre; - elsif Nam_In (Item_Nam, Name_Type_Invariant, - Name_Type_Invariant_Class) + elsif Item_Nam in Name_Type_Invariant | Name_Type_Invariant_Class then Item_Nam := Name_uType_Invariant; @@ -23572,7 +24830,7 @@ package body Sem_Util is -- The current Check_Policy pragma matches the requested policy or -- appears in the single argument form (Assertion, policy_id). - if Nam_In (Chars (Arg1), Name_Assertion, Policy) then + if Chars (Arg1) in Name_Assertion | Policy then return Chars (Arg2); end if; @@ -23619,7 +24877,7 @@ package body Sem_Util is -- assertions, unless they are disabled. Force Name_Check on -- ignored assertions. - if Nam_In (Kind, Name_Ignore, Name_Off) + if Kind in Name_Ignore | Name_Off and then (CodePeer_Mode or GNATprove_Mode) then Kind := Name_Check; @@ -23628,6 +24886,17 @@ package body Sem_Util is return Kind; end Policy_In_Effect; + ----------------------- + -- Predicate_Enabled -- + ----------------------- + + function Predicate_Enabled (Typ : Entity_Id) return Boolean is + begin + return Present (Predicate_Function (Typ)) + and then not Predicates_Ignored (Typ) + and then not Predicate_Checks_Suppressed (Empty); + end Predicate_Enabled; + ---------------------------------- -- Predicate_Tests_On_Arguments -- ---------------------------------- @@ -23966,19 +25235,6 @@ package body Sem_Util is Get_Decoded_Name_String (Chars (Endl)); Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len)); - - else - -- In SPARK mode, no missing label is allowed for packages and - -- subprogram bodies. Detect those cases by testing whether - -- Process_End_Label was called for a body (Typ = 't') or a package. - - if Restriction_Check_Required (SPARK_05) - and then (Typ = 't' or else Ekind (Ent) = E_Package) - then - Error_Msg_Node_1 := Endl; - Check_SPARK_05_Restriction - ("`END &` required", Endl, Force => True); - end if; end if; -- Now generate the e/t reference @@ -24046,13 +25302,11 @@ package body Sem_Util is -- The setting of the attributes is intentionally conservative. This -- prevents accidental clobbering of enabled attributes. - if Has_Inherited_DIC (From_Typ) - and then not Has_Inherited_DIC (Typ) - then + if Has_Inherited_DIC (From_Typ) then Set_Has_Inherited_DIC (Typ); end if; - if Has_Own_DIC (From_Typ) and then not Has_Own_DIC (Typ) then + if Has_Own_DIC (From_Typ) then Set_Has_Own_DIC (Typ); end if; @@ -24090,21 +25344,15 @@ package body Sem_Util is -- The setting of the attributes is intentionally conservative. This -- prevents accidental clobbering of enabled attributes. - if Has_Inheritable_Invariants (From_Typ) - and then not Has_Inheritable_Invariants (Typ) - then + if Has_Inheritable_Invariants (From_Typ) then Set_Has_Inheritable_Invariants (Typ); end if; - if Has_Inherited_Invariants (From_Typ) - and then not Has_Inherited_Invariants (Typ) - then + if Has_Inherited_Invariants (From_Typ) then Set_Has_Inherited_Invariants (Typ); end if; - if Has_Own_Invariants (From_Typ) - and then not Has_Own_Invariants (Typ) - then + if Has_Own_Invariants (From_Typ) then Set_Has_Own_Invariants (Typ); end if; @@ -24119,6 +25367,48 @@ package body Sem_Util is end if; end Propagate_Invariant_Attributes; + ------------------------------------ + -- Propagate_Predicate_Attributes -- + ------------------------------------ + + procedure Propagate_Predicate_Attributes + (Typ : Entity_Id; + From_Typ : Entity_Id) + is + Pred_Func : Entity_Id; + Pred_Func_M : Entity_Id; + + begin + if Present (Typ) and then Present (From_Typ) then + pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); + + -- Nothing to do if both the source and the destination denote the + -- same type. + + if From_Typ = Typ then + return; + end if; + + Pred_Func := Predicate_Function (From_Typ); + Pred_Func_M := Predicate_Function_M (From_Typ); + + -- The setting of the attributes is intentionally conservative. This + -- prevents accidental clobbering of enabled attributes. + + if Has_Predicates (From_Typ) then + Set_Has_Predicates (Typ); + end if; + + if Present (Pred_Func) and then No (Predicate_Function (Typ)) then + Set_Predicate_Function (Typ, Pred_Func); + end if; + + if Present (Pred_Func_M) and then No (Predicate_Function_M (Typ)) then + Set_Predicate_Function_M (Typ, Pred_Func_M); + end if; + end if; + end Propagate_Predicate_Attributes; + --------------------------------------- -- Record_Possible_Part_Of_Reference -- --------------------------------------- @@ -24316,7 +25606,7 @@ package body Sem_Util is -- The entity denotes a primitive subprogram. Remove it from the list of -- primitives of the associated controlling type. - if Ekind_In (Id, E_Function, E_Procedure) and then Is_Primitive (Id) then + if Ekind (Id) in E_Function | E_Procedure and then Is_Primitive (Id) then Formal := First_Formal (Id); while Present (Formal) loop if Is_Controlling_Formal (Formal) then @@ -24369,11 +25659,64 @@ package body Sem_Util is function Requires_Transient_Scope (Id : Entity_Id) return Boolean is Old_Result : constant Boolean := Old_Requires_Transient_Scope (Id); + procedure Ensure_Minimum_Decoration (Typ : Entity_Id); + -- If Typ is not frozen then add to Typ the minimum decoration required + -- by Requires_Transient_Scope to reliably provide its functionality; + -- otherwise no action is performed. + + ------------------------------- + -- Ensure_Minimum_Decoration -- + ------------------------------- + + procedure Ensure_Minimum_Decoration (Typ : Entity_Id) is + begin + -- 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) + and then (Is_Record_Type (Typ) + or else Is_Concurrent_Type (Typ) + or else Is_Incomplete_Or_Private_Type (Typ)) + and then not Is_Class_Wide_Equivalent_Type (Typ) + then + declare + Comp : Entity_Id; + + begin + Comp := First_Component (Typ); + while Present (Comp) loop + if Has_Controlled_Component (Etype (Comp)) + or else + (Chars (Comp) /= Name_uParent + and then Is_Controlled (Etype (Comp))) + or else + (Is_Protected_Type (Etype (Comp)) + and then + Present (Corresponding_Record_Type (Etype (Comp))) + and then + Has_Controlled_Component + (Corresponding_Record_Type (Etype (Comp)))) + then + Set_Has_Controlled_Component (Typ); + exit; + end if; + + Next_Component (Comp); + end loop; + end; + end if; + end Ensure_Minimum_Decoration; + + -- Start of processing for Requires_Transient_Scope + begin if Debug_Flag_QQ then return Old_Result; end if; + Ensure_Minimum_Decoration (Id); + declare New_Result : constant Boolean := New_Requires_Transient_Scope (Id); @@ -24500,23 +25843,25 @@ package body Sem_Util is is begin -- The only entities for which we track constant values are variables - -- which are not renamings, constants, out parameters, and in out - -- parameters, so check if we have this case. + -- which 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 -- fact this routine is used for other purposes than simply capturing - -- the value. In particular, the setting of Known[_Non]_Null. + -- the value. In particular, the setting of Known[_Non]_Null and + -- Is_Known_Valid. if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent))) - or else - Ekind_In (Ent, E_Constant, E_Out_Parameter, E_In_Out_Parameter) + or else + Ekind (Ent) = E_Constant + or else + Is_Formal (Ent) then null; - -- For conditionals, we also allow loop parameters and all formals, - -- including in parameters. + -- For conditionals, we also allow loop parameters - elsif Cond and then Ekind_In (Ent, E_Loop_Parameter, E_In_Parameter) then + elsif Cond and then Ekind (Ent) = E_Loop_Parameter then null; -- For all other cases, not just unsafe, but impossible to capture @@ -24556,7 +25901,7 @@ package body Sem_Util is while R_Scope /= Standard_Standard loop exit when R_Scope = E_Scope; - if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then + if Ekind (R_Scope) not in E_Package | E_Block | E_Loop then return False; else R_Scope := Scope (R_Scope); @@ -24670,7 +26015,7 @@ package body Sem_Util is EN2 : constant Entity_Id := Entity (N2); begin if Present (EN1) and then Present (EN2) - and then (Ekind_In (EN1, E_Variable, E_Constant) + and then (Ekind (EN1) in E_Variable | E_Constant or else Is_Formal (EN1)) and then EN1 = EN2 then @@ -24960,8 +26305,8 @@ package body Sem_Util is Typ : constant Entity_Id := Etype (E); begin - if Ekind_In (Typ, E_Anonymous_Access_Type, - E_Anonymous_Access_Subprogram_Type) + 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); @@ -25099,7 +26444,7 @@ package body Sem_Util is begin while Present (Indx) loop Set_Debug_Info_Needed_If_Not_Set (Etype (Indx)); - Indx := Next_Index (Indx); + Next_Index (Indx); end loop; end; @@ -25166,6 +26511,17 @@ package body Sem_Util is end if; end Set_Debug_Info_Needed; + -------------------------------- + -- Set_Debug_Info_Defining_Id -- + -------------------------------- + + procedure Set_Debug_Info_Defining_Id (N : Node_Id) is + begin + if Comes_From_Source (Defining_Identifier (N)) then + Set_Debug_Info_Needed (Defining_Identifier (N)); + end if; + end Set_Debug_Info_Defining_Id; + ---------------------------- -- Set_Entity_With_Checks -- ---------------------------- @@ -25279,7 +26635,7 @@ package body Sem_Util is or else (Present (Scope (Val)) and then Is_Implementation_Defined (Scope (Val)))) - and then not (Ekind_In (Val, E_Package, E_Generic_Package) + and then not (Is_Package_Or_Generic_Package (Val) and then Is_Library_Level_Entity (Val)) then Check_Restriction (No_Implementation_Identifiers, Post_Node); @@ -25418,8 +26774,8 @@ package body Sem_Util is if No (N) then return False; - elsif Nkind_In (N, N_Handled_Sequence_Of_Statements, - N_If_Statement) + elsif Nkind (N) in + N_Handled_Sequence_Of_Statements | N_If_Statement then return True; end if; @@ -25445,8 +26801,8 @@ package body Sem_Util is -- never needs to be made public and furthermore, making it public can -- cause back end problems. - elsif Nkind_In (Parent (Id), N_Object_Declaration, - N_Function_Specification) + elsif Nkind (Parent (Id)) in + N_Object_Declaration | N_Function_Specification and then Within_HSS_Or_If (Id) then return; @@ -25478,7 +26834,7 @@ package body Sem_Util is begin -- Deal with indexed or selected component where prefix is modified - if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then + if Nkind (N) in N_Indexed_Component | N_Selected_Component then Pref := Prefix (N); -- If prefix is access type, then it is the designated object that is @@ -25643,6 +26999,34 @@ package body Sem_Util is end if; end Static_Integer; + ------------------------------- + -- Statically_Denotes_Entity -- + ------------------------------- + function Statically_Denotes_Entity (N : Node_Id) return Boolean is + E : Entity_Id; + begin + if not Is_Entity_Name (N) then + return False; + else + E := Entity (N); + end if; + + return + Nkind (Parent (E)) /= N_Object_Renaming_Declaration + or else Is_Prival (E) + or else Statically_Denotes_Entity (Renamed_Object (E)); + end Statically_Denotes_Entity; + + ------------------------------- + -- Statically_Denotes_Object -- + ------------------------------- + + function Statically_Denotes_Object (N : Node_Id) return Boolean is + begin + return Statically_Denotes_Entity (N) + and then Is_Object_Reference (N); + end Statically_Denotes_Object; + -------------------------- -- Statically_Different -- -------------------------- @@ -25658,6 +27042,162 @@ package body Sem_Util is and then not Is_Formal (Entity (R2)); end Statically_Different; + ----------------------------- + -- Statically_Names_Object -- + ----------------------------- + + function Statically_Names_Object (N : Node_Id) return Boolean is + begin + if Statically_Denotes_Object (N) then + return True; + elsif Is_Entity_Name (N) then + declare + E : constant Entity_Id := Entity (N); + begin + return Nkind (Parent (E)) = N_Object_Renaming_Declaration + and then Statically_Names_Object (Renamed_Object (E)); + end; + end if; + + case Nkind (N) is + when N_Indexed_Component => + if Is_Access_Type (Etype (Prefix (N))) then + -- treat implicit dereference same as explicit + return False; + end if; + + if not Is_Constrained (Etype (Prefix (N))) then + return False; + end if; + + declare + Indx : Node_Id := First_Index (Etype (Prefix (N))); + Expr : Node_Id := First (Expressions (N)); + Index_Subtype : Node_Id; + begin + loop + Index_Subtype := Etype (Indx); + + if not Is_Static_Subtype (Index_Subtype) then + return False; + end if; + if not Is_OK_Static_Expression (Expr) then + return False; + end if; + + declare + Index_Value : constant Uint := Expr_Value (Expr); + Low_Value : constant Uint := + Expr_Value (Type_Low_Bound (Index_Subtype)); + High_Value : constant Uint := + Expr_Value (Type_High_Bound (Index_Subtype)); + begin + if (Index_Value < Low_Value) + or (Index_Value > High_Value) + then + return False; + end if; + end; + + Next_Index (Indx); + Expr := Next (Expr); + pragma Assert ((Present (Indx) = Present (Expr)) + or else (Serious_Errors_Detected > 0)); + exit when not (Present (Indx) and Present (Expr)); + end loop; + end; + + when N_Selected_Component => + if Is_Access_Type (Etype (Prefix (N))) then + -- treat implicit dereference same as explicit + return False; + end if; + + if Ekind (Entity (Selector_Name (N))) not in + E_Component | E_Discriminant + then + return False; + end if; + + declare + Comp : constant Entity_Id := + Original_Record_Component (Entity (Selector_Name (N))); + begin + -- AI12-0373 confirms that we should not call + -- Has_Discriminant_Dependent_Constraint here which would be + -- too strong. + + if Is_Declared_Within_Variant (Comp) then + return False; + end if; + end; + + when others => -- includes N_Slice, N_Explicit_Dereference + return False; + end case; + + pragma Assert (Present (Prefix (N))); + + return Statically_Names_Object (Prefix (N)); + end Statically_Names_Object; + + --------------------------------- + -- String_From_Numeric_Literal -- + --------------------------------- + + function String_From_Numeric_Literal (N : Node_Id) return String_Id is + Loc : constant Source_Ptr := Sloc (N); + Sbuffer : constant Source_Buffer_Ptr := + Source_Text (Get_Source_File_Index (Loc)); + Src_Ptr : Source_Ptr := Loc; + + C : Character := Sbuffer (Src_Ptr); + -- Current source program character + + function Belongs_To_Numeric_Literal (C : Character) return Boolean; + -- Return True if C belongs to the numeric literal + + -------------------------------- + -- Belongs_To_Numeric_Literal -- + -------------------------------- + + function Belongs_To_Numeric_Literal (C : Character) return Boolean is + begin + case C is + when '0' .. '9' + | '_' | '.' | 'e' | '#' | 'A' | 'B' | 'C' | 'D' | 'E' | 'F' + => + return True; + + -- Make sure '+' or '-' is part of an exponent + + when '+' | '-' => + declare + Prev_C : constant Character := Sbuffer (Src_Ptr - 1); + begin + return Prev_C = 'e' or else Prev_C = 'E'; + end; + + -- Other characters cannot belong to a numeric literal + + when others => + return False; + end case; + end Belongs_To_Numeric_Literal; + + -- Start of processing for String_From_Numeric_Literal + + begin + Start_String; + while Belongs_To_Numeric_Literal (C) loop + Store_String_Char (C); + Src_Ptr := Src_Ptr + 1; + C := Sbuffer (Src_Ptr); + end loop; + + return End_String; + end String_From_Numeric_Literal; + -------------------------------------- -- Subject_To_Loop_Entry_Attributes -- -------------------------------------- @@ -25672,7 +27212,7 @@ package body Sem_Util is -- 'Loop_Entry attribute into a conditional block. Infinite loops lack -- the conditional part. - if Nkind_In (Stmt, N_Block_Statement, N_If_Statement) + if Nkind (Stmt) in N_Block_Statement | N_If_Statement and then Nkind (Original_Node (N)) = N_Loop_Statement then Stmt := Original_Node (N); @@ -26334,10 +27874,10 @@ package body Sem_Util is begin Pref := N; - while Nkind_In (Pref, N_Explicit_Dereference, - N_Indexed_Component, - N_Selected_Component, - N_Slice) + while Nkind (Pref) in N_Explicit_Dereference + | N_Indexed_Component + | N_Selected_Component + | N_Slice loop Pref := Prefix (Pref); end loop; @@ -26808,9 +28348,9 @@ package body Sem_Util is -- Recurse to handle unlikely case of multiple levels of qualification -- and/or conversion. - if Nkind_In (Expr, N_Qualified_Expression, - N_Type_Conversion, - N_Unchecked_Type_Conversion) + if Nkind (Expr) in N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion then return Unqual_Conv (Expression (Expr)); @@ -26964,9 +28504,9 @@ package body Sem_Util is Par := N; while Present (Par) loop - if Nkind_In (Par, N_Entry_Call_Statement, - N_Function_Call, - N_Procedure_Call_Statement) + if Nkind (Par) in N_Entry_Call_Statement + | N_Function_Call + | N_Procedure_Call_Statement then return True; @@ -27040,8 +28580,8 @@ package body Sem_Util is if No (E) then return False; - elsif not Ekind_In (E, E_Discriminant, E_Component) - or else Nam_In (Chars (E), Name_uTag, Name_uParent) + elsif Ekind (E) not in E_Discriminant | E_Component + or else Chars (E) in Name_uTag | Name_uParent then Next_Entity (E); @@ -27096,12 +28636,12 @@ package body Sem_Util is then return; - -- In an instance, there is an ongoing problem with completion of + -- In an instance, there is an ongoing problem with completion of -- types derived from private types. Their structure is what Gigi - -- expects, but the Etype is the parent type rather than the - -- derived private type itself. Do not flag error in this case. The - -- private completion is an entity without a parent, like an Itype. - -- Similarly, full and partial views may be incorrect in the instance. + -- expects, but the Etype is the parent type rather than the derived + -- private type itself. Do not flag error in this case. The private + -- completion is an entity without a parent, like an Itype. Similarly, + -- full and partial views may be incorrect in the instance. -- There is no simple way to insure that it is consistent ??? -- A similar view discrepancy can happen in an inlined body, for the @@ -27195,7 +28735,7 @@ package body Sem_Util is elsif Is_Integer_Type (Expec_Type) and then Is_RTE (Found_Type, RE_Address) - and then Nkind_In (Parent (Expr), N_Op_Add, N_Op_Subtract) + and then Nkind (Parent (Expr)) in N_Op_Add | N_Op_Subtract and then Expr = Left_Opnd (Parent (Expr)) and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr)))) then @@ -27285,7 +28825,7 @@ package body Sem_Util is Error_Msg_N ("\\found package name!", Expr); elsif Is_Entity_Name (Expr) - and then Ekind_In (Entity (Expr), E_Procedure, E_Generic_Procedure) + and then Ekind (Entity (Expr)) in E_Procedure | E_Generic_Procedure then if Ekind (Expec_Type) = E_Access_Subprogram_Type then Error_Msg_N @@ -27333,7 +28873,7 @@ package body Sem_Util is if Expec_Type = Standard_Boolean and then Is_Modular_Integer_Type (Found_Type) - and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor) + and then Nkind (Parent (Expr)) in N_Op_And | N_Op_Or | N_Op_Xor and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare then declare @@ -27472,7 +29012,7 @@ package body Sem_Util is begin -- Integer and real literals are of a universal type - if Nkind_In (N, N_Integer_Literal, N_Real_Literal) then + if Nkind (N) in N_Integer_Literal | N_Real_Literal then return True; -- The values of certain attributes are of a universal type @@ -27490,26 +29030,113 @@ package body Sem_Util is package body Interval_Lists is + procedure Check_Consistency (Intervals : Discrete_Interval_List); + -- Check that list is sorted, lacks null intervals, and has gaps + -- between intervals. + + function Chosen_Interval (Choice : Node_Id) return Discrete_Interval; + -- Given an element of a Discrete_Choices list, a + -- Static_Discrete_Predicate list, or an Others_Discrete_Choices + -- list (but not an N_Others_Choice node) return the corresponding + -- interval. If an element that does not represent a single + -- contiguous interval due to a static predicate (or which + -- represents a single contiguous interval whose bounds depend on + -- a static predicate) is encountered, then that is an error on the + -- part of whoever built the list in question. + function In_Interval (Value : Uint; Interval : Discrete_Interval) return Boolean; -- Does the given value lie within the given interval? - ----------------- - -- In_Interval -- - ----------------- - function In_Interval - (Value : Uint; Interval : Discrete_Interval) return Boolean is + procedure Normalize_Interval_List + (List : in out Discrete_Interval_List; Last : out Nat); + -- Perform sorting and merging as required by Check_Consistency. + + ------------------------- + -- Aggregate_Intervals -- + ------------------------- + + function Aggregate_Intervals (N : Node_Id) return Discrete_Interval_List + is + pragma Assert (Nkind (N) = N_Aggregate + and then Is_Array_Type (Etype (N))); + + function Unmerged_Intervals_Count return Nat; + -- Count the number of intervals given in the aggregate N; the others + -- choice (if present) is not taken into account. + + function Unmerged_Intervals_Count return Nat is + Count : Nat := 0; + Choice : Node_Id; + Comp : Node_Id; + begin + Comp := First (Component_Associations (N)); + while Present (Comp) loop + Choice := First (Choices (Comp)); + + while Present (Choice) loop + if Nkind (Choice) /= N_Others_Choice then + Count := Count + 1; + end if; + + Next (Choice); + end loop; + + Next (Comp); + end loop; + + return Count; + end Unmerged_Intervals_Count; + + -- Local variables + + Comp : Node_Id; + Max_I : constant Nat := Unmerged_Intervals_Count; + Intervals : Discrete_Interval_List (1 .. Max_I); + Num_I : Nat := 0; + + -- Start of processing for Aggregate_Intervals + begin - return Value >= Interval.Low and then Value <= Interval.High; - end In_Interval; + -- No action needed if there are no intervals - procedure Check_Consistency (Intervals : Discrete_Interval_List); - -- Check that list is sorted, lacks null intervals, and has gaps - -- between intervals. + if Max_I = 0 then + return Intervals; + end if; + + -- Internally store all the unsorted intervals + + Comp := First (Component_Associations (N)); + while Present (Comp) loop + declare + Choice_Intervals : constant Discrete_Interval_List + := Choice_List_Intervals (Choices (Comp)); + begin + for J in Choice_Intervals'Range loop + Num_I := Num_I + 1; + Intervals (Num_I) := Choice_Intervals (J); + end loop; + end; + + Next (Comp); + end loop; + + -- Normalize the lists sorting and merging the intervals + + declare + Aggr_Intervals : Discrete_Interval_List (1 .. Num_I) + := Intervals (1 .. Num_I); + begin + Normalize_Interval_List (Aggr_Intervals, Num_I); + Check_Consistency (Aggr_Intervals (1 .. Num_I)); + return Aggr_Intervals (1 .. Num_I); + end; + end Aggregate_Intervals; ------------------------ -- Check_Consistency -- ------------------------ + procedure Check_Consistency (Intervals : Discrete_Interval_List) is begin if Serious_Errors_Detected > 0 then @@ -27530,19 +29157,79 @@ package body Sem_Util is end loop; end Check_Consistency; - function Chosen_Interval (Choice : Node_Id) return Discrete_Interval; - -- Given an element of a Discrete_Choices list, a - -- Static_Discrete_Predicate list, or an Others_Discrete_Choices - -- list (but not an N_Others_Choice node) return the corresponding - -- interval. If an element that does not represent a single - -- contiguous interval due to a static predicate (or which - -- represents a single contiguous interval whose bounds depend on - -- a static predicate) is encountered, then that is an error on the - -- part of whoever built the list in question. + --------------------------- + -- Choice_List_Intervals -- + --------------------------- + + function Choice_List_Intervals + (Discrete_Choices : List_Id) return Discrete_Interval_List + is + function Unmerged_Choice_Count return Nat; + -- The number of intervals before adjacent intervals are merged. + + --------------------------- + -- Unmerged_Choice_Count -- + --------------------------- + + function Unmerged_Choice_Count return Nat is + Choice : Node_Id := First (Discrete_Choices); + Count : Nat := 0; + begin + while Present (Choice) loop + -- Non-contiguous choices involving static predicates + -- have already been normalized away. + + if Nkind (Choice) = N_Others_Choice then + Count := + Count + List_Length (Others_Discrete_Choices (Choice)); + else + Count := Count + 1; -- an ordinary expression or range + end if; + + Next (Choice); + end loop; + return Count; + end Unmerged_Choice_Count; + + -- Local variables + + Choice : Node_Id := First (Discrete_Choices); + Result : Discrete_Interval_List (1 .. Unmerged_Choice_Count); + Count : Nat := 0; + + -- Start of processing for Choice_List_Intervals + + begin + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + declare + Others_Choice : Node_Id + := First (Others_Discrete_Choices (Choice)); + begin + while Present (Others_Choice) loop + Count := Count + 1; + Result (Count) := Chosen_Interval (Others_Choice); + Next (Others_Choice); + end loop; + end; + else + Count := Count + 1; + Result (Count) := Chosen_Interval (Choice); + end if; + + Next (Choice); + end loop; + + pragma Assert (Count = Result'Last); + Normalize_Interval_List (Result, Count); + Check_Consistency (Result (1 .. Count)); + return Result (1 .. Count); + end Choice_List_Intervals; --------------------- -- Chosen_Interval -- --------------------- + function Chosen_Interval (Choice : Node_Id) return Discrete_Interval is begin case Nkind (Choice) is @@ -27575,97 +29262,105 @@ package body Sem_Util is end case; end Chosen_Interval; - -------------------- - -- Type_Intervals -- - -------------------- - function Type_Intervals - (Typ : Entity_Id) return Discrete_Interval_List + ----------------- + -- In_Interval -- + ----------------- + + function In_Interval + (Value : Uint; Interval : Discrete_Interval) return Boolean is + begin + return Value >= Interval.Low and then Value <= Interval.High; + end In_Interval; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset + (Subset, Of_Set : Discrete_Interval_List) return Boolean is + -- Returns True iff for each interval of Subset we can find + -- a single interval of Of_Set which contains the Subset interval. begin - if Has_Static_Predicate (Typ) then - declare - -- No sorting or merging needed - SDP_List : constant List_Id := Static_Discrete_Predicate (Typ); - Range_Or_Expr : Node_Id := First (SDP_List); - Result : - Discrete_Interval_List (1 .. List_Length (SDP_List)); - begin - for Idx in Result'Range loop - Result (Idx) := Chosen_Interval (Range_Or_Expr); - Range_Or_Expr := Next (Range_Or_Expr); + if Of_Set'Length = 0 then + return Subset'Length = 0; + end if; + + declare + Set_Index : Pos range Of_Set'Range := Of_Set'First; + + begin + for Ss_Idx in Subset'Range loop + while not In_Interval + (Value => Subset (Ss_Idx).Low, + Interval => Of_Set (Set_Index)) + loop + if Set_Index = Of_Set'Last then + return False; + end if; + + Set_Index := Set_Index + 1; end loop; - pragma Assert (not Present (Range_Or_Expr)); - Check_Consistency (Result); - return Result; - end; - else - declare - Low : constant Uint := Expr_Value (Type_Low_Bound (Typ)); - High : constant Uint := Expr_Value (Type_High_Bound (Typ)); - begin - if Low > High then - declare - Null_Array : Discrete_Interval_List (1 .. 0); - begin - return Null_Array; - end; - else - return (1 => (Low => Low, High => High)); + + if not In_Interval + (Value => Subset (Ss_Idx).High, + Interval => Of_Set (Set_Index)) + then + return False; end if; - end; - end if; - end Type_Intervals; + end loop; + end; - procedure Normalize_Interval_List - (List : in out Discrete_Interval_List; Last : out Nat); - -- Perform sorting and merging as required by Check_Consistency. + return True; + end Is_Subset; ----------------------------- -- Normalize_Interval_List -- ----------------------------- + procedure Normalize_Interval_List - (List : in out Discrete_Interval_List; Last : out Nat) is + (List : in out Discrete_Interval_List; Last : out Nat) + is + Temp_0 : Discrete_Interval := (others => Uint_0); + -- Cope with Heap_Sort_G idiosyncrasies. - procedure Move_Interval (From, To : Natural); - -- Copy interval from one location to another + function Is_Null (Idx : Pos) return Boolean; + -- True iff List (Idx) defines a null range function Lt_Interval (Idx1, Idx2 : Natural) return Boolean; -- Compare two list elements - Temp_0 : Discrete_Interval := (others => Uint_0); - -- cope with Heap_Sort_G idiosyncrasies. + procedure Merge_Intervals (Null_Interval_Count : out Nat); + -- Merge contiguous ranges by replacing one with merged range and + -- the other with a null value. Return a count of the null intervals, + -- both preexisting and those introduced by merging. + + procedure Move_Interval (From, To : Natural); + -- Copy interval from one location to another function Read_Interval (From : Natural) return Discrete_Interval; -- Normal array indexing unless From = 0 - ------------------- - -- Read_Interval -- - ------------------- - function Read_Interval (From : Natural) return Discrete_Interval is - begin - if From = 0 then - return Temp_0; - else - return List (Pos (From)); - end if; - end Read_Interval; + ---------------------- + -- Interval_Sorting -- + ---------------------- - ------------------- - -- Move_Interval -- - ------------------- - procedure Move_Interval (From, To : Natural) is - Rhs : constant Discrete_Interval := Read_Interval (From); + package Interval_Sorting is + new Gnat.Heap_Sort_G (Move_Interval, Lt_Interval); + + ------------- + -- Is_Null -- + ------------- + + function Is_Null (Idx : Pos) return Boolean is begin - if To = 0 then - Temp_0 := Rhs; - else - List (Pos (To)) := Rhs; - end if; - end Move_Interval; + return List (Idx).Low > List (Idx).High; + end Is_Null; ----------------- -- Lt_Interval -- ----------------- + function Lt_Interval (Idx1, Idx2 : Natural) return Boolean is Elem1 : constant Discrete_Interval := Read_Interval (Idx1); Elem2 : constant Discrete_Interval := Read_Interval (Idx2); @@ -27675,33 +29370,19 @@ package body Sem_Util is if Null_1 /= Null_2 then -- So that sorting moves null intervals to high end return Null_2; + elsif Elem1.Low /= Elem2.Low then return Elem1.Low < Elem2.Low; + else return Elem1.High < Elem2.High; end if; end Lt_Interval; - package Interval_Sorting is - new Gnat.Heap_Sort_G (Move_Interval, Lt_Interval); - - function Is_Null (Idx : Pos) return Boolean; - -- True iff List (Idx) defines a null range - - function Is_Null (Idx : Pos) return Boolean is - begin - return List (Idx).Low > List (Idx).High; - end Is_Null; - - procedure Merge_Intervals (Null_Interval_Count : out Nat); - -- Merge contiguous ranges by replacing one with merged range - -- and the other with a null value. Return a count of the - -- null intervals, both preexisting and those introduced by - -- merging. - --------------------- -- Merge_Intervals -- --------------------- + procedure Merge_Intervals (Null_Interval_Count : out Nat) is Not_Null : Pos range List'Range; -- Index of the most recently examined non-null interval @@ -27717,30 +29398,74 @@ package body Sem_Util is Null_Interval_Count := 0; Not_Null := List'First; + for Idx in List'First + 1 .. List'Last loop if Is_Null (Idx) then + -- all remaining elements are null + Null_Interval_Count := Null_Interval_Count + List (Idx .. List'Last)'Length; return; + elsif List (Idx).Low = List (Not_Null).High + 1 then + -- Merge the two intervals into one; discard the other + List (Not_Null).High := List (Idx).High; List (Idx) := Null_Interval; Null_Interval_Count := Null_Interval_Count + 1; + else + if List (Idx).Low <= List (Not_Null).High then + raise Intervals_Error; + end if; + pragma Assert (List (Idx).Low > List (Not_Null).High); Not_Null := Idx; end if; end loop; end Merge_Intervals; + + ------------------- + -- Move_Interval -- + ------------------- + + procedure Move_Interval (From, To : Natural) is + Rhs : constant Discrete_Interval := Read_Interval (From); + begin + if To = 0 then + Temp_0 := Rhs; + else + List (Pos (To)) := Rhs; + end if; + end Move_Interval; + + ------------------- + -- Read_Interval -- + ------------------- + + function Read_Interval (From : Natural) return Discrete_Interval is + begin + if From = 0 then + return Temp_0; + else + return List (Pos (From)); + end if; + end Read_Interval; + + -- Start of processing for Normalize_Interval_Lists + begin Interval_Sorting.Sort (Natural (List'Last)); + declare Null_Interval_Count : Nat; + begin Merge_Intervals (Null_Interval_Count); Last := List'Last - Null_Interval_Count; + if Null_Interval_Count /= 0 then -- Move null intervals introduced during merging to high end Interval_Sorting.Sort (Natural (List'Last)); @@ -27748,104 +29473,47 @@ package body Sem_Util is end; end Normalize_Interval_List; - --------------------------- - -- Choice_List_Intervals -- - --------------------------- - function Choice_List_Intervals - (Discrete_Choices : List_Id) return Discrete_Interval_List - is - function Unmerged_Choice_Count return Nat; - -- The number of intervals before adjacent intervals are merged. - - --------------------------- - -- Unmerged_Choice_Count -- - --------------------------- - function Unmerged_Choice_Count return Nat is - Choice : Node_Id := First (Discrete_Choices); - Count : Nat := 0; - begin - while Present (Choice) loop - -- Non-contiguous choices involving static predicates - -- have already been normalized away. - - if Nkind (Choice) = N_Others_Choice then - Count := - Count + List_Length (Others_Discrete_Choices (Choice)); - else - Count := Count + 1; -- an ordinary expression or range - end if; - - Choice := Next (Choice); - end loop; - return Count; - end Unmerged_Choice_Count; - - Choice : Node_Id := First (Discrete_Choices); - Result : Discrete_Interval_List (1 .. Unmerged_Choice_Count); - Count : Nat := 0; - begin - while Present (Choice) loop - if Nkind (Choice) = N_Others_Choice then - declare - Others_Choice : Node_Id - := First (Others_Discrete_Choices (Choice)); - begin - while Present (Others_Choice) loop - Count := Count + 1; - Result (Count) := Chosen_Interval (Others_Choice); - Others_Choice := Next (Others_Choice); - end loop; - end; - else - Count := Count + 1; - Result (Count) := Chosen_Interval (Choice); - end if; - Choice := Next (Choice); - end loop; - pragma Assert (Count = Result'Last); - Normalize_Interval_List (Result, Count); - Check_Consistency (Result (1 .. Count)); - return Result (1 .. Count); - end Choice_List_Intervals; + -------------------- + -- Type_Intervals -- + -------------------- - --------------- - -- Is_Subset -- - --------------- - function Is_Subset - (Subset, Of_Set : Discrete_Interval_List) return Boolean + function Type_Intervals (Typ : Entity_Id) return Discrete_Interval_List is - -- Returns True iff for each interval of Subset we can find - -- a single interval of Of_Set which contains the Subset interval. begin - if Of_Set'Length = 0 then - return Subset'Length = 0; - end if; + if Has_Static_Predicate (Typ) then + declare + -- No sorting or merging needed + SDP_List : constant List_Id := Static_Discrete_Predicate (Typ); + Range_Or_Expr : Node_Id := First (SDP_List); + Result : Discrete_Interval_List (1 .. List_Length (SDP_List)); - declare - Set_Index : Pos range Of_Set'Range := Of_Set'First; - begin - for Ss_Idx in Subset'Range loop - while not In_Interval - (Value => Subset (Ss_Idx).Low, - Interval => Of_Set (Set_Index)) - loop - if Set_Index = Of_Set'Last then - return False; - end if; - Set_Index := Set_Index + 1; + begin + for Idx in Result'Range loop + Result (Idx) := Chosen_Interval (Range_Or_Expr); + Next (Range_Or_Expr); end loop; - if not In_Interval - (Value => Subset (Ss_Idx).High, - Interval => Of_Set (Set_Index)) - then - return False; + pragma Assert (not Present (Range_Or_Expr)); + Check_Consistency (Result); + return Result; + end; + else + declare + Low : constant Uint := Expr_Value (Type_Low_Bound (Typ)); + High : constant Uint := Expr_Value (Type_High_Bound (Typ)); + begin + if Low > High then + declare + Null_Array : Discrete_Interval_List (1 .. 0); + begin + return Null_Array; + end; + else + return (1 => (Low => Low, High => High)); end if; - end loop; - end; - - return True; - end Is_Subset; + end; + end if; + end Type_Intervals; end Interval_Lists; |