diff options
| author | Pierre-Marie de Rodat <derodat@adacore.com> | 2017-10-09 19:43:32 +0000 |
|---|---|---|
| committer | Pierre-Marie de Rodat <derodat@adacore.com> | 2017-10-09 19:43:32 +0000 |
| commit | b734099589eb5d269444f01a22fafb5e36fecde0 (patch) | |
| tree | a6451c66b3e38255388c71e8bb58bdd1b0af5035 /gcc | |
| parent | c2a6f53350122593537652da08afbaf2ff99d877 (diff) | |
2017-10-09 Bob Duff <duff@adacore.com>
* exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): Use
Defining_Identifier (Obj_Decl) in two places, because it might have
changed.
* exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Deal with cases
involving 'Input on (not visibly) derived types.
2017-10-09 Hristian Kirtchev <kirtchev@adacore.com>
* atree.adb: Add new soft link Rewriting_Proc.
(Rewrite): Invoke the subprogram attached to the rewriting soft link.
(Set_Rewriting_Proc): New routine.
* attree.ads: Add new access-to-subprogram type Rewrite_Proc.
(Set_Rewriting_Proc): New routine.
* checks.adb (Install_Primitive_Elaboration_Check): Use 'E' character
for *E*laboration flag to maintain consistency with other elaboration
flag generating subprograms.
* debug.adb: Document the new usage of flag -gnatdL.
* einfo.adb: Node19 is now used as Receiving_Entry. Node39 is now used
as Protected_Subprogram. Flag148 is now used as
Is_Elaboration_Checks_OK_Id. Flag302 is now used as
Is_Initial_Condition_Procedure.
(Is_Elaboration_Checks_OK_Id): New routine.
(Is_Initial_Condition_Procedure): New routine.
(Protected_Subprogram): New routine.
(Receiving_Entry): New routine.
(SPARK_Pragma): Update assertion.
(SPARK_Pragma_Inherited): Update assertion.
(Suppress_Elaboration_Warnings): Removed.
(Set_Is_Elaboration_Checks_OK_Id): New routine.
(Set_Is_Initial_Condition_Procedure): New routine.
(Set_Protected_Subprogram): New routine.
(Set_Receiving_Entry): New routine.
(Set_SPARK_Pragma): Update assertion.
(Set_SPARK_Pragma_Inherited): Update assertion.
(Write_Entity_Flags): Update the output for Flag148 and Flag302.
(Write_Field19_Name): Add output for Receiving_Entry.
(Write_Field39_Name): Add output for Protected_Subprogram.
(Write_Field40_Name): Update the output for SPARK_Pragma.
* einfo.ads: New attributes Is_Elaboration_Checks_OK_Id,
Is_Initial_Condition_Procedure, Protected_Subprogram, Receiving_Entry.
Remove attribute Suppress_Elaboration_Warnings. Update the stricture
of various entities.
(Is_Elaboration_Checks_OK_Id): New routine along with pragma Inline.
(Is_Initial_Condition_Procedure): New routine along with pragma Inline.
(Protected_Subprogram): New routine along with pragma Inline.
(Receiving_Entry): New routine along with pragma Inline.
(Suppress_Elaboration_Warnings): Removed.
(Set_Is_Elaboration_Checks_OK_Id): New routine along with pragma
Inline.
(Set_Is_Initial_Condition_Procedure): New routine along with pragma
Inline.
(Set_Protected_Subprogram): New routine along with pragma Inline.
(Set_Receiving_Entry): New routine along with pragma Inline.
(Set_Suppress_Elaboration_Warnings): Removed.
* exp_ch3.adb (Build_Init_Procedure): Use name _Finalizer to maintain
consistency with other finalizer generating subprograms.
(Default_Initialize_Object): Mark the block which wraps the call to
finalize as being part of initialization.
* exp_ch7.adb (Expand_N_Package_Declaration): Directly expand pragma
Initial_Condition.
(Expand_N_Package_Body): Directly expand pragma Initial_Condition.
(Next_Suitable_Statement): Update the comment on usage. Skip over call
markers generated by the ABE mechanism.
* exp_ch9.adb (Activation_Call_Loc): New routine.
(Add_Accept): Link the accept procedure to the original entry.
(Build_Protected_Sub_Specification): Link the protected or unprotected
version to the original subprogram.
(Build_Task_Activation_Call): Code cleanup. Use a source location which
is very close to the "begin" or "end" keywords when generating the
activation call.
* exp_prag.adb (Expand_Pragma_Initial_Condition): Reimplemented.
* exp_spark.adb (Expand_SPARK): Use Expand_SPARK_N_Loop_Statement to
process loops.
(Expand_SPARK_N_Loop_Statement): New routine.
(Expand_SPARK_N_Object_Declaration): Code cleanup. Partially insert the
call to the Default_Initial_Condition procedure.
(Expand_SPARK_Op_Ne): Renamed to Expand_SPARK_N_Op_Ne.
* exp_util.adb (Build_DIC_Procedure_Body): Capture the SPARK_Mode in
effect.
(Build_DIC_Procedure_Declaration): Capture the SPARK_Mode in effect.
(Insert_Actions): Add processing for N_Call_Marker.
(Kill_Dead_Code): Explicitly kill an elaboration scenario.
* exp_util.ads (Make_Invariant_Call): Update the comment on usage.
* frontend.adb: Initialize Sem_Elab. Process all saved top level
elaboration scenarios for ABE issues.
* gcc-interface/trans.c (gnat_to_gnu): Add processing for N_Call_Marker
nodes.
* lib.adb (Earlier_In_Extended_Unit): New variant.
* sem.adb (Analyze): Ignore N_Call_Marker nodes.
(Preanalysis_Active): New routine.
* sem.ads (Preanalysis_Active): New routine.
* sem_attr.adb (Analyze_Access_Attribute): Save certain
elaboration-related attributes. Save the scenario for ABE processing.
* sem_ch3.adb (Analyze_Object_Declaration): Save the SPARK mode in
effect. Save certain elaboration-related attributes.
* sem_ch5.adb (Analyze_Assignment): Save certain elaboration-related
attributes. Save the scenario for ABE processing.
* sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): Save the SPARK
mode in effect. Save certain elaboration-related attributes.
(Analyze_Subprogram_Body_Helper): Skip N_Call_Marker nodes when
locating the first real statement.
(Analyze_Subprogram_Declaration): Save the SPARK mode in effect. Save
certain elaboration-related attributes.
* sem_ch7.adb (Analyze_Package_Declaration): Do not suppress
elaboration warnings.
* sem_ch8.adb (Attribute_Renaming): Mark a subprogram body which was
generated for purposes of wrapping an attribute used as a generic
actual.
(Find_Direct_Name): Save certain elaboration-related attributes. Save
the scenario for ABE processing.
(Find_Expanded_Name): Save certain elaboration-related attributes. Save
the scenario for ABE processing.
* sem_ch9.adb (Analyze_Entry_Declaration): Save certain
elaboration-related attributes.
(Analyze_Requeue): Save certain elaboration-related attributes. Save
the scenario for ABE processing.
(Analyze_Single_Task_Declaration): Save certain elaboration-related
attributes.
(Analyze_Task_Type_Declaration): Save certain elaboration-related
attributes.
* sem_ch12.adb (Analyze_Generic_Package_Declaration): Save certain
elaboration-related attributes.
(Analyze_Generic_Subprogram_Declaration): Save the SPARK mode in
effect. Save certain elaboration-related attributes.
(Analyze_Package_Instantiation): Save certain elaboration-related
attributes. Save the scenario for ABE processing. Create completing
bodies in case the instantiation results in a guaranteed ABE.
(Analyze_Subprogram_Instantiation): Save certain elaboration-related
attributes Save the scenario for ABE processing. Create a completing
body in case the instantiation results in a guaranteed ABE.
(Provide_Completing_Bodies): New routine.
* sem_elab.ads: Brand new implementation.
* sem_prag.adb (Analyze_Pragma, cases Elaborate, Elaborate_All,
Elaborate_Body): Do not suppress elaboration warnings.
* sem_res.adb (Make_Call_Into_Operator): Set the parent field of the
operator.
(Resolve_Call): Save certain elaboration-related attributes. Save the
scenario for ABE processing.
(Resolve_Entity_Name): Do not perform any ABE processing here.
(Resolve_Entry_Call): Inherit certain attributes from the original call.
* sem_util.adb (Begin_Keyword_Location): New routine.
(Defining_Entity): Update the parameter profile. Add processing for
concurrent subunits that are rewritten as null statements.
(End_Keyword_Location): New routine.
(Find_Enclosing_Scope): New routine.
(In_Instance_Visible_Part): Code cleanup.
(In_Subtree): Update the parameter profile. Add new version.
(Is_Preelaborable_Aggregate): New routine.
(Is_Preelaborable_Construct): New routine.
(Mark_Elaboration_Attributes): New routine.
(Scope_Within): Update the parameter profile.
(Scope_Within_Or_Same): Update the parameter profile.
* sem_util.ads (Begin_Keyword_Location): New routine.
(Defining_Entity): Update the parameter profile and the comment on
usage.
(End_Keyword_Location): New routine.
(Find_Enclosing_Scope): New routine.
(In_Instance_Visible_Part): Update the parameter profile.
(In_Subtree): Update the parameter profile. Add new version.
(Is_Preelaborable_Aggregate): New routine.
(Is_Preelaborable_Construct): New routine.
(Mark_Elaboration_Attributes): New routine.
(Scope_Within): Update the parameter profile and the comment on usage.
(Scope_Within_Or_Same): Update the parameter profile and the comment on
usage.
* sem_warn.adb (Check_Infinite_Loop_Warning): Use Has_Condition_Actions
to determine whether a loop has meaningful condition actions.
(Has_Condition_Actions): New routine.
* sinfo.adb (ABE_Is_Certain): Removed.
(Is_Declaration_Level_Node): New routine.
(Is_Dispatching_Call): New routine.
(Is_Elaboration_Checks_OK_Node): New routine.
(Is_Initialization_Block): New routine.
(Is_Known_Guaranteed_ABE): New routine.
(Is_Recorded_Scenario): New routine.
(Is_Source_Call): New routine.
(Is_SPARK_Mode_On_Node): New routine.
(No_Elaboration_Check): Removed.
(Target): New routine.
(Was_Attribute_Reference): New routine.
(Set_ABE_Is_Certain): Removed.
(Set_Is_Declaration_Level_Node): New routine.
(Set_Is_Dispatching_Call): New routine.
(Set_Is_Elaboration_Checks_OK_Node): New routine.
(Set_Is_Initialization_Block): New routine.
(Set_Is_Known_Guaranteed_ABE): New routine.
(Set_Is_Recorded_Scenario): New routine.
(Set_Is_Source_Call): New routine.
(Set_Is_SPARK_Mode_On_Node): New routine.
(Set_No_Elaboration_Check): Removed.
(Set_Target): New routine.
(Set_Was_Attribute_Reference): New routine.
* sinfo.ads: Remove attribute ABE_Is_Certain. Attribute
Do_Discriminant_Check now utilizes Flag3. Attribute
No_Side_Effect_Removal now utilizes Flag17. Add new node
N_Call_Marker. Update the structure of various nodes.
(ABE_Is_Certain): Removed along with pragma Inline.
(Is_Declaration_Level_Node): New routine along with pragma Inline.
(Is_Dispatching_Call): New routine along with pragma Inline.
(Is_Elaboration_Checks_OK_Node): New routine along with pragma Inline.
(Is_Initialization_Block): New routine along with pragma Inline.
(Is_Known_Guaranteed_ABE): New routine along with pragma Inline.
(Is_Recorded_Scenario): New routine along with pragma Inline.
(Is_Source_Call): New routine along with pragma Inline.
(Is_SPARK_Mode_On_Node): New routine along with pragma Inline.
(No_Elaboration_Check): Removed along with pragma Inline.
(Target): New routine along with pragma Inline.
(Was_Attribute_Reference): New routine along with pragma Inline.
(Set_ABE_Is_Certain): Removed along with pragma Inline.
(Set_Is_Declaration_Level_Node): New routine along with pragma Inline.
(Set_Is_Dispatching_Call): New routine along with pragma Inline.
(Set_Is_Elaboration_Checks_OK_Node): New routine along with pragma
Inline.
(Set_Is_Initialization_Block): New routine along with pragma Inline.
(Set_Is_Known_Guaranteed_ABE): New routine along with pragma Inline.
(Set_Is_Recorded_Scenario): New routine along with pragma Inline.
(Set_Is_Source_Call): New routine along with pragma Inline.
(Set_Is_SPARK_Mode_On_Node): New routine along with pragma Inline.
(Set_No_Elaboration_Check): Removed along with pragma Inline.
(Set_Target): New routine along with pragma Inline.
(Set_Was_Attribute_Reference): New routine along with pragma Inline.
* sprint.adb (Sprint_Node_Actual): Add an entry for N_Call_Marker.
git-svn-id: https://gcc.gnu.org/svn/gcc/trunk@253559 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
43 files changed, 13121 insertions, 7108 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8b83270f5f3..85825d060f0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,230 @@ 2017-10-09 Bob Duff <duff@adacore.com> + * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): Use + Defining_Identifier (Obj_Decl) in two places, because it might have + changed. + * exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Deal with cases + involving 'Input on (not visibly) derived types. + +2017-10-09 Hristian Kirtchev <kirtchev@adacore.com> + + * atree.adb: Add new soft link Rewriting_Proc. + (Rewrite): Invoke the subprogram attached to the rewriting soft link. + (Set_Rewriting_Proc): New routine. + * attree.ads: Add new access-to-subprogram type Rewrite_Proc. + (Set_Rewriting_Proc): New routine. + * checks.adb (Install_Primitive_Elaboration_Check): Use 'E' character + for *E*laboration flag to maintain consistency with other elaboration + flag generating subprograms. + * debug.adb: Document the new usage of flag -gnatdL. + * einfo.adb: Node19 is now used as Receiving_Entry. Node39 is now used + as Protected_Subprogram. Flag148 is now used as + Is_Elaboration_Checks_OK_Id. Flag302 is now used as + Is_Initial_Condition_Procedure. + (Is_Elaboration_Checks_OK_Id): New routine. + (Is_Initial_Condition_Procedure): New routine. + (Protected_Subprogram): New routine. + (Receiving_Entry): New routine. + (SPARK_Pragma): Update assertion. + (SPARK_Pragma_Inherited): Update assertion. + (Suppress_Elaboration_Warnings): Removed. + (Set_Is_Elaboration_Checks_OK_Id): New routine. + (Set_Is_Initial_Condition_Procedure): New routine. + (Set_Protected_Subprogram): New routine. + (Set_Receiving_Entry): New routine. + (Set_SPARK_Pragma): Update assertion. + (Set_SPARK_Pragma_Inherited): Update assertion. + (Write_Entity_Flags): Update the output for Flag148 and Flag302. + (Write_Field19_Name): Add output for Receiving_Entry. + (Write_Field39_Name): Add output for Protected_Subprogram. + (Write_Field40_Name): Update the output for SPARK_Pragma. + * einfo.ads: New attributes Is_Elaboration_Checks_OK_Id, + Is_Initial_Condition_Procedure, Protected_Subprogram, Receiving_Entry. + Remove attribute Suppress_Elaboration_Warnings. Update the stricture + of various entities. + (Is_Elaboration_Checks_OK_Id): New routine along with pragma Inline. + (Is_Initial_Condition_Procedure): New routine along with pragma Inline. + (Protected_Subprogram): New routine along with pragma Inline. + (Receiving_Entry): New routine along with pragma Inline. + (Suppress_Elaboration_Warnings): Removed. + (Set_Is_Elaboration_Checks_OK_Id): New routine along with pragma + Inline. + (Set_Is_Initial_Condition_Procedure): New routine along with pragma + Inline. + (Set_Protected_Subprogram): New routine along with pragma Inline. + (Set_Receiving_Entry): New routine along with pragma Inline. + (Set_Suppress_Elaboration_Warnings): Removed. + * exp_ch3.adb (Build_Init_Procedure): Use name _Finalizer to maintain + consistency with other finalizer generating subprograms. + (Default_Initialize_Object): Mark the block which wraps the call to + finalize as being part of initialization. + * exp_ch7.adb (Expand_N_Package_Declaration): Directly expand pragma + Initial_Condition. + (Expand_N_Package_Body): Directly expand pragma Initial_Condition. + (Next_Suitable_Statement): Update the comment on usage. Skip over call + markers generated by the ABE mechanism. + * exp_ch9.adb (Activation_Call_Loc): New routine. + (Add_Accept): Link the accept procedure to the original entry. + (Build_Protected_Sub_Specification): Link the protected or unprotected + version to the original subprogram. + (Build_Task_Activation_Call): Code cleanup. Use a source location which + is very close to the "begin" or "end" keywords when generating the + activation call. + * exp_prag.adb (Expand_Pragma_Initial_Condition): Reimplemented. + * exp_spark.adb (Expand_SPARK): Use Expand_SPARK_N_Loop_Statement to + process loops. + (Expand_SPARK_N_Loop_Statement): New routine. + (Expand_SPARK_N_Object_Declaration): Code cleanup. Partially insert the + call to the Default_Initial_Condition procedure. + (Expand_SPARK_Op_Ne): Renamed to Expand_SPARK_N_Op_Ne. + * exp_util.adb (Build_DIC_Procedure_Body): Capture the SPARK_Mode in + effect. + (Build_DIC_Procedure_Declaration): Capture the SPARK_Mode in effect. + (Insert_Actions): Add processing for N_Call_Marker. + (Kill_Dead_Code): Explicitly kill an elaboration scenario. + * exp_util.ads (Make_Invariant_Call): Update the comment on usage. + * frontend.adb: Initialize Sem_Elab. Process all saved top level + elaboration scenarios for ABE issues. + * gcc-interface/trans.c (gnat_to_gnu): Add processing for N_Call_Marker + nodes. + * lib.adb (Earlier_In_Extended_Unit): New variant. + * sem.adb (Analyze): Ignore N_Call_Marker nodes. + (Preanalysis_Active): New routine. + * sem.ads (Preanalysis_Active): New routine. + * sem_attr.adb (Analyze_Access_Attribute): Save certain + elaboration-related attributes. Save the scenario for ABE processing. + * sem_ch3.adb (Analyze_Object_Declaration): Save the SPARK mode in + effect. Save certain elaboration-related attributes. + * sem_ch5.adb (Analyze_Assignment): Save certain elaboration-related + attributes. Save the scenario for ABE processing. + * sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): Save the SPARK + mode in effect. Save certain elaboration-related attributes. + (Analyze_Subprogram_Body_Helper): Skip N_Call_Marker nodes when + locating the first real statement. + (Analyze_Subprogram_Declaration): Save the SPARK mode in effect. Save + certain elaboration-related attributes. + * sem_ch7.adb (Analyze_Package_Declaration): Do not suppress + elaboration warnings. + * sem_ch8.adb (Attribute_Renaming): Mark a subprogram body which was + generated for purposes of wrapping an attribute used as a generic + actual. + (Find_Direct_Name): Save certain elaboration-related attributes. Save + the scenario for ABE processing. + (Find_Expanded_Name): Save certain elaboration-related attributes. Save + the scenario for ABE processing. + * sem_ch9.adb (Analyze_Entry_Declaration): Save certain + elaboration-related attributes. + (Analyze_Requeue): Save certain elaboration-related attributes. Save + the scenario for ABE processing. + (Analyze_Single_Task_Declaration): Save certain elaboration-related + attributes. + (Analyze_Task_Type_Declaration): Save certain elaboration-related + attributes. + * sem_ch12.adb (Analyze_Generic_Package_Declaration): Save certain + elaboration-related attributes. + (Analyze_Generic_Subprogram_Declaration): Save the SPARK mode in + effect. Save certain elaboration-related attributes. + (Analyze_Package_Instantiation): Save certain elaboration-related + attributes. Save the scenario for ABE processing. Create completing + bodies in case the instantiation results in a guaranteed ABE. + (Analyze_Subprogram_Instantiation): Save certain elaboration-related + attributes Save the scenario for ABE processing. Create a completing + body in case the instantiation results in a guaranteed ABE. + (Provide_Completing_Bodies): New routine. + * sem_elab.ads: Brand new implementation. + * sem_prag.adb (Analyze_Pragma, cases Elaborate, Elaborate_All, + Elaborate_Body): Do not suppress elaboration warnings. + * sem_res.adb (Make_Call_Into_Operator): Set the parent field of the + operator. + (Resolve_Call): Save certain elaboration-related attributes. Save the + scenario for ABE processing. + (Resolve_Entity_Name): Do not perform any ABE processing here. + (Resolve_Entry_Call): Inherit certain attributes from the original call. + * sem_util.adb (Begin_Keyword_Location): New routine. + (Defining_Entity): Update the parameter profile. Add processing for + concurrent subunits that are rewritten as null statements. + (End_Keyword_Location): New routine. + (Find_Enclosing_Scope): New routine. + (In_Instance_Visible_Part): Code cleanup. + (In_Subtree): Update the parameter profile. Add new version. + (Is_Preelaborable_Aggregate): New routine. + (Is_Preelaborable_Construct): New routine. + (Mark_Elaboration_Attributes): New routine. + (Scope_Within): Update the parameter profile. + (Scope_Within_Or_Same): Update the parameter profile. + * sem_util.ads (Begin_Keyword_Location): New routine. + (Defining_Entity): Update the parameter profile and the comment on + usage. + (End_Keyword_Location): New routine. + (Find_Enclosing_Scope): New routine. + (In_Instance_Visible_Part): Update the parameter profile. + (In_Subtree): Update the parameter profile. Add new version. + (Is_Preelaborable_Aggregate): New routine. + (Is_Preelaborable_Construct): New routine. + (Mark_Elaboration_Attributes): New routine. + (Scope_Within): Update the parameter profile and the comment on usage. + (Scope_Within_Or_Same): Update the parameter profile and the comment on + usage. + * sem_warn.adb (Check_Infinite_Loop_Warning): Use Has_Condition_Actions + to determine whether a loop has meaningful condition actions. + (Has_Condition_Actions): New routine. + * sinfo.adb (ABE_Is_Certain): Removed. + (Is_Declaration_Level_Node): New routine. + (Is_Dispatching_Call): New routine. + (Is_Elaboration_Checks_OK_Node): New routine. + (Is_Initialization_Block): New routine. + (Is_Known_Guaranteed_ABE): New routine. + (Is_Recorded_Scenario): New routine. + (Is_Source_Call): New routine. + (Is_SPARK_Mode_On_Node): New routine. + (No_Elaboration_Check): Removed. + (Target): New routine. + (Was_Attribute_Reference): New routine. + (Set_ABE_Is_Certain): Removed. + (Set_Is_Declaration_Level_Node): New routine. + (Set_Is_Dispatching_Call): New routine. + (Set_Is_Elaboration_Checks_OK_Node): New routine. + (Set_Is_Initialization_Block): New routine. + (Set_Is_Known_Guaranteed_ABE): New routine. + (Set_Is_Recorded_Scenario): New routine. + (Set_Is_Source_Call): New routine. + (Set_Is_SPARK_Mode_On_Node): New routine. + (Set_No_Elaboration_Check): Removed. + (Set_Target): New routine. + (Set_Was_Attribute_Reference): New routine. + * sinfo.ads: Remove attribute ABE_Is_Certain. Attribute + Do_Discriminant_Check now utilizes Flag3. Attribute + No_Side_Effect_Removal now utilizes Flag17. Add new node + N_Call_Marker. Update the structure of various nodes. + (ABE_Is_Certain): Removed along with pragma Inline. + (Is_Declaration_Level_Node): New routine along with pragma Inline. + (Is_Dispatching_Call): New routine along with pragma Inline. + (Is_Elaboration_Checks_OK_Node): New routine along with pragma Inline. + (Is_Initialization_Block): New routine along with pragma Inline. + (Is_Known_Guaranteed_ABE): New routine along with pragma Inline. + (Is_Recorded_Scenario): New routine along with pragma Inline. + (Is_Source_Call): New routine along with pragma Inline. + (Is_SPARK_Mode_On_Node): New routine along with pragma Inline. + (No_Elaboration_Check): Removed along with pragma Inline. + (Target): New routine along with pragma Inline. + (Was_Attribute_Reference): New routine along with pragma Inline. + (Set_ABE_Is_Certain): Removed along with pragma Inline. + (Set_Is_Declaration_Level_Node): New routine along with pragma Inline. + (Set_Is_Dispatching_Call): New routine along with pragma Inline. + (Set_Is_Elaboration_Checks_OK_Node): New routine along with pragma + Inline. + (Set_Is_Initialization_Block): New routine along with pragma Inline. + (Set_Is_Known_Guaranteed_ABE): New routine along with pragma Inline. + (Set_Is_Recorded_Scenario): New routine along with pragma Inline. + (Set_Is_Source_Call): New routine along with pragma Inline. + (Set_Is_SPARK_Mode_On_Node): New routine along with pragma Inline. + (Set_No_Elaboration_Check): Removed along with pragma Inline. + (Set_Target): New routine along with pragma Inline. + (Set_Was_Attribute_Reference): New routine along with pragma Inline. + * sprint.adb (Sprint_Node_Actual): Add an entry for N_Call_Marker. + +2017-10-09 Bob Duff <duff@adacore.com> + * exp_ch7.adb (Create_Finalizer): Suppress checks within the finalizer. 2017-10-09 Bob Duff <duff@adacore.com> diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 2519774fcdd..f5a00991768 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -56,6 +56,9 @@ package body Atree is Reporting_Proc : Report_Proc := null; -- Record argument to last call to Set_Reporting_Proc + Rewriting_Proc : Rewrite_Proc := null; + -- This soft link captures the procedure invoked during a node rewrite + --------------- -- Debugging -- --------------- @@ -1306,16 +1309,6 @@ package body Atree is Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6, V7, V8, V9, V10, V11); end Ekind_In; - ------------------------ - -- Set_Reporting_Proc -- - ------------------------ - - procedure Set_Reporting_Proc (P : Report_Proc) is - begin - pragma Assert (Reporting_Proc = null); - Reporting_Proc := P; - end Set_Reporting_Proc; - ------------------ -- Error_Posted -- ------------------ @@ -2253,6 +2246,12 @@ package body Atree is if Reporting_Proc /= null then Reporting_Proc.all (Target => Old_Node, Source => New_Node); end if; + + -- Invoke the rewriting procedure (if available) + + if Rewriting_Proc /= null then + Rewriting_Proc.all (Target => Old_Node, Source => New_Node); + end if; end Rewrite; ------------------ @@ -2390,6 +2389,16 @@ package body Atree is Nodes.Table (N).Link := Union_Id (Val); end Set_Parent; + ------------------------ + -- Set_Reporting_Proc -- + ------------------------ + + procedure Set_Reporting_Proc (Proc : Report_Proc) is + begin + pragma Assert (Reporting_Proc = null); + Reporting_Proc := Proc; + end Set_Reporting_Proc; + -------------- -- Set_Sloc -- -------------- @@ -2400,6 +2409,16 @@ package body Atree is Nodes.Table (N).Sloc := Val; end Set_Sloc; + ------------------------ + -- Set_Rewriting_Proc -- + ------------------------ + + procedure Set_Rewriting_Proc (Proc : Rewrite_Proc) is + begin + pragma Assert (Rewriting_Proc = null); + Rewriting_Proc := Proc; + end Set_Rewriting_Proc; + ---------- -- Sloc -- ---------- diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 5ed81e68531..bf0da1604ea 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -572,10 +572,15 @@ package Atree is type Report_Proc is access procedure (Target : Node_Id; Source : Node_Id); - procedure Set_Reporting_Proc (P : Report_Proc); + procedure Set_Reporting_Proc (Proc : Report_Proc); -- Register a procedure that is invoked when a node is allocated, replaced -- or rewritten. + type Rewrite_Proc is access procedure (Target : Node_Id; Source : Node_Id); + + procedure Set_Rewriting_Proc (Proc : Rewrite_Proc); + -- Register a procedure that is invoked when a node is rewritten + type Traverse_Result is (Abandon, OK, OK_Orig, Skip); -- This is the type of the result returned by the Process function passed -- to Traverse_Func and Traverse_Proc. See below for details. @@ -4231,25 +4236,26 @@ package Atree is -- for extending components are completely unused. type Flags_Byte is record - Flag0 : Boolean; + Flag0 : Boolean; -- Note: we don't use Flag0 at the moment. To put Flag0 into use -- requires some awkward work in Treeprs (treeprs.adt), so for the -- moment we don't use it. - Flag1 : Boolean; - Flag2 : Boolean; - Flag3 : Boolean; + Flag1 : Boolean; + Flag2 : Boolean; + Flag3 : Boolean; -- These flags are used in the usual manner in Sinfo and Einfo - Is_Ignored_Ghost_Node : Boolean; - -- Flag denoting whether the node is subject to pragma Ghost with - -- policy Ignore. The name of the flag should be Flag4, however this - -- requires changing the names of all remaining 300+ flags. + -- The flags listed below use explicit names because following the + -- FlagXXX convention would mean reshuffling of over 300+ flags. Check_Actuals : Boolean; -- Flag set to indicate that the marked node is subject to the check - -- for writable actuals. See xxx for more details. Again it would be - -- more uniform to use some Flagx here, but that would be disruptive. + -- for writable actuals. + + Is_Ignored_Ghost_Node : Boolean; + -- Flag denoting whether the node is subject to pragma Ghost with + -- policy Ignore. Spare2 : Boolean; Spare3 : Boolean; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 8a542ad34dd..a99da08c733 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -5398,8 +5398,10 @@ package body Checks is elsif Checks_May_Be_Suppressed (E) then if Is_Check_Suppressed (E, Elaboration_Check) then return True; + elsif Dynamic_Elaboration_Checks then return Is_Check_Suppressed (E, All_Checks); + else return False; end if; @@ -5408,8 +5410,10 @@ package body Checks is if Scope_Suppress.Suppress (Elaboration_Check) then return True; + elsif Dynamic_Elaboration_Checks then return Scope_Suppress.Suppress (All_Checks); + else return False; end if; @@ -7927,7 +7931,7 @@ package body Checks is Flag_Id := Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Subp_Id), 'F', -1)); + Chars => New_External_Name (Chars (Subp_Id), 'E', -1)); Set_Is_Frozen (Flag_Id); -- Insert the declaration of the elaboration flag in front of the @@ -7936,7 +7940,7 @@ package body Checks is Push_Scope (Scope (Subp_Id)); -- Generate: - -- F : Boolean := False; + -- E : Boolean := False; Insert_Action (Subp_Decl, Make_Object_Declaration (Loc, @@ -7986,7 +7990,7 @@ package body Checks is end if; -- Generate: - -- F := True; + -- E := True; Insert_After_And_Analyze (Set_Ins, Make_Assignment_Statement (Loc, @@ -8060,12 +8064,14 @@ package body Checks is -- since it clearly was not overridden at any point). For a predefined -- check, we test the specific flag. For a user defined check, we check -- the All_Checks flag. The Overflow flag requires special handling to - -- deal with the General vs Assertion case + -- deal with the General vs Assertion case. if C = Overflow_Check then return Overflow_Checks_Suppressed (Empty); + elsif C in Predefined_Check_Id then return Scope_Suppress.Suppress (C); + else return Scope_Suppress.Suppress (All_Checks); end if; diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 25d08399220..4e747203394 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -75,7 +75,7 @@ package body Debug is -- dI Inhibit internal name numbering in gnatG listing -- dJ Prepend subprogram name in messages -- dK Kill all error messages - -- dL Output trace information on elaboration checking + -- dL Ignore external calls from instances for elaboration -- dM Assume all variables are modified (no current values) -- dN No file name information in exception messages -- dO Output immediate error messages @@ -414,10 +414,9 @@ package body Debug is -- of all error messages. It is used in regression tests where the -- error messages are target dependent and irrelevant. - -- dL Output trace information on elaboration checking. This debug - -- switch causes output to be generated showing each call or - -- instantiation as it is checked, and the progress of the recursive - -- trace through elaboration calls at compile time. + -- dL The compiler ignores calls in instances and invoke subprograms + -- which are external to the instance for the static elaboration + -- model. This switch is orthogonal to d.G. -- dM Assume all variables have been modified, and ignore current value -- indications. This debug flag disconnects the tracking of constant @@ -664,7 +663,8 @@ package body Debug is -- d.G Previously the compiler ignored calls via generic formal parameters -- when doing the analysis for the static elaboration model. This is -- now fixed, but we provide this debug flag to revert to the previous - -- situation of ignoring such calls to aid in transition. + -- situation of ignoring such calls to aid in transition. This switch + -- is orthogonal to dL. -- d.H Sets ASIS_GNSA_Mode to True. This signals the front end to suppress -- the call to gigi in ASIS_Mode. diff --git a/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst b/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst index 688dd9961bc..d943c716d3f 100644 --- a/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst @@ -17,1855 +17,1760 @@ Elaboration Order Handling in GNAT .. index:: Order of elaboration .. index:: Elaboration control -This appendix describes the handling of elaboration code in Ada and -in GNAT, and discusses how the order of elaboration of program units can -be controlled in GNAT, either automatically or with explicit programming -features. +This appendix describes the handling of elaboration code in Ada and GNAT, and +discusses how the order of elaboration of program units can be controlled in +GNAT, either automatically or with explicit programming features. .. _Elaboration_Code: Elaboration Code ================ -Ada provides rather general mechanisms for executing code at elaboration -time, that is to say before the main program starts executing. Such code arises -in three contexts: +Ada defines the term *execution* as the process by which a construct achieves +its run-time effect. This process is also referred to as **elaboration** for +declarations and *evaluation* for expressions. -* *Initializers for variables* +The execution model in Ada allows for certain sections of an Ada program to be +executed prior to execution of the program itself, primarily with the intent of +initializing data. These sections are referred to as **elaboration code**. +Elaboration code is executed as follows: - Variables declared at the library level, in package specs or bodies, can - require initialization that is performed at elaboration time, as in: +* All partitions of an Ada program are executed in parallel with one another, + possibly in a separate address space, and possibly on a separate computer. - .. code-block:: ada +* The execution of a partition involves running the environment task for that + partition. - Sqrt_Half : Float := Sqrt (0.5); +* The environment task executes all elaboration code (if available) for all + units within that partition. This code is said to be executed at + **elaboration time**. -* *Package initialization code* +* The environment task executes the Ada program (if available) for that + partition. - Code in a ``begin`` ... `` end`` section at the outer level of a package body is - executed as part of the package body elaboration code. +In addition to the Ada terminology, this appendix defines the following terms: -* *Library level task allocators* +* *Scenario* - Tasks that are declared using task allocators at the library level - start executing immediately and hence can execute at elaboration time. + A construct that is elaborated or executed by elaboration code is referred to + as an *elaboration scenario* or simply a **scenario**. GNAT recognizes the + following scenarios: -Subprogram calls are possible in any of these contexts, which means that -any arbitrary part of the program may be executed as part of the elaboration -code. It is even possible to write a program which does all its work at -elaboration time, with a null main program, although stylistically this -would usually be considered an inappropriate way to structure -a program. + - ``'Access`` of entries, operators, and subprograms -An important concern arises in the context of elaboration code: -we have to be sure that it is executed in an appropriate order. What we -have is a series of elaboration code sections, potentially one section -for each unit in the program. It is important that these execute -in the correct order. Correctness here means that, taking the above -example of the declaration of ``Sqrt_Half``, -if some other piece of -elaboration code references ``Sqrt_Half``, -then it must run after the -section of elaboration code that contains the declaration of -``Sqrt_Half``. + - Activation of tasks -There would never be any order of elaboration problem if we made a rule -that whenever you |with| a unit, you must elaborate both the spec and body -of that unit before elaborating the unit doing the |withing|: + - Calls to entries, operators, and subprograms -.. code-block:: ada + - Instantiations of generic templates - with Unit_1; - package Unit_2 is ... +* *Target* -would require that both the body and spec of ``Unit_1`` be elaborated -before the spec of ``Unit_2``. However, a rule like that would be far too -restrictive. In particular, it would make it impossible to have routines -in separate packages that were mutually recursive. + A construct elaborated by a scenario is referred to as *elaboration target* + or simply **target**. GNAT recognizes the following targets: -You might think that a clever enough compiler could look at the actual -elaboration code and determine an appropriate correct order of elaboration, -but in the general case, this is not possible. Consider the following -example. + - For ``'Access`` of entries, operators, and subprograms, the target is the + entry, operator, or subprogram being aliased. -In the body of ``Unit_1``, we have a procedure ``Func_1`` -that references -the variable ``Sqrt_1``, which is declared in the elaboration code -of the body of ``Unit_1``: + - For activation of tasks, the target is the task body -.. code-block:: ada + - For calls to entries, operators, and subprograms, the target is the entry, + operator, or subprogram being invoked. - Sqrt_1 : Float := Sqrt (0.1); + - For instantiations of generic templates, the target is the generic template + being instantiated. -The elaboration code of the body of ``Unit_1`` also contains: +Elaboration code may appear in two distinct contexts: -.. code-block:: ada +* *Library level* - if expression_1 = 1 then - Q := Unit_2.Func_2; - end if; + A scenario appears at the library level when it is encapsulated by a package + [body] compilation unit, ignoring any other package [body] declarations in + between. -``Unit_2`` is exactly parallel, -it has a procedure ``Func_2`` that references -the variable ``Sqrt_2``, which is declared in the elaboration code of -the body ``Unit_2``: + :: -.. code-block:: ada + with Server; + package Client is + procedure Proc; - Sqrt_2 : Float := Sqrt (0.1); + package Nested is + Val : ... := Server.Func; + end Nested; + end Client; -The elaboration code of the body of ``Unit_2`` also contains: + In the example above, the call to ``Server.Func`` is an elaboration scenario + because it appears at the library level of package ``Client``. Note that the + declaration of package ``Nested`` is ignored according to the definition + given above. As a result, the call to ``Server.Func`` will be executed when + the spec of unit ``Client`` is elaborated. -.. code-block:: ada +* *Package body statements* - if expression_2 = 2 then - Q := Unit_1.Func_1; - end if; + A scenario appears within the statement sequence of a package body when it is + bounded by the region starting from the ``begin`` keyword of the package body + and ending at the ``end`` keyword of the package body. -Now the question is, which of the following orders of elaboration is -acceptable: + :: + + package body Client is + procedure Proc is + begin + ... + end Proc; + begin + Proc; + end Client; + + In the example above, the call to ``Proc`` is an elaboration scenario because + it appears within the statement sequence of package body ``Client``. As a + result, the call to ``Proc`` will be executed when the body of ``Client`` is + elaborated. + +.. _Elaboration_Order: + +Elaboration Order +================= + +The sequence by which the elaboration code of all units within a partition is +executed is referred to as **elaboration order**. The elaboration order depends +on the following factors: + +* |withed| units + +* purity of units + +* preelaborability of units + +* presence of elaboration control pragmas + +A program may have several elaboration orders depending on its structure. + +:: + + package Server is + function Func (Index : Integer) return Integer; + end Server; + +:: + + package body Server is + Results : array (1 .. 5) of Integer := (1, 2, 3, 4, 5); + + function Func (Index : Integer) return Integer is + begin + return Results (Index); + end Func; + end Server; + +:: + + with Server; + package Client is + Val : constant Integer := Server.Func (3); + end Client; :: - Spec of Unit_1 - Spec of Unit_2 - Body of Unit_1 - Body of Unit_2 + with Client; + procedure Main is begin null; end Main; -or +The following elaboration order exhibits a fundamental problem referred to as +*access-before-elaboration* or simply **ABE**. :: - Spec of Unit_2 - Spec of Unit_1 - Body of Unit_2 - Body of Unit_1 - -If you carefully analyze the flow here, you will see that you cannot tell -at compile time the answer to this question. -If ``expression_1`` is not equal to 1, -and ``expression_2`` is not equal to 2, -then either order is acceptable, because neither of the function calls is -executed. If both tests evaluate to true, then neither order is acceptable -and in fact there is no correct order. - -If one of the two expressions is true, and the other is false, then one -of the above orders is correct, and the other is incorrect. For example, -if ``expression_1`` /= 1 and ``expression_2`` = 2, -then the call to ``Func_1`` -will occur, but not the call to ``Func_2.`` -This means that it is essential -to elaborate the body of ``Unit_1`` before -the body of ``Unit_2``, so the first -order of elaboration is correct and the second is wrong. - -By making ``expression_1`` and ``expression_2`` -depend on input data, or perhaps -the time of day, we can make it impossible for the compiler or binder -to figure out which of these expressions will be true, and hence it -is impossible to guarantee a safe order of elaboration at run time. + spec of Server + spec of Client + body of Server + body of Main + +The elaboration of ``Server``'s spec materializes function ``Func``, making it +callable. The elaboration of ``Client``'s spec elaborates the declaration of +``Val``. This invokes function ``Server.Func``, however the body of +``Server.Func`` has not been elaborated yet because ``Server``'s body comes +after ``Client``'s spec in the elaboration order. As a result, the value of +constant ``Val`` is now undefined. + +Without any guarantees from the language, an undetected ABE problem may hinder +proper initialization of data, which in turn may lead to undefined behavior at +run time. To prevent such ABE problems, Ada employs dynamic checks in the same +vein as index or null exclusion checks. A failed ABE check raises exception +``Program_Error``. + +The following elaboration order avoids the ABE problem and the program can be +successfully elaborated. + +:: + + spec of Server + body of Server + spec of Client + body of Main + +Ada states that a total elaboration order must exist, but it does not define +what this order is. A compiler is thus tasked with choosing a suitable +elaboration order which satisfies the dependencies imposed by |with| clauses, +unit categorization, and elaboration control pragmas. Ideally an order which +avoids ABE problems should be chosen, however a compiler may not always find +such an order due to complications with respect to control and data flow. .. _Checking_the_Elaboration_Order: Checking the Elaboration Order ============================== -In some languages that involve the same kind of elaboration problems, -e.g., Java and C++, the programmer needs to take these -ordering problems into account, and it is common to -write a program in which an incorrect elaboration order gives -surprising results, because it references variables before they -are initialized. -Ada is designed to be a safe language, and a programmer-beware approach is -clearly not sufficient. Consequently, the language provides three lines -of defense: +To avoid placing the entire elaboration order burden on the programmer, Ada +provides three lines of defense: + +* *Static semantics* + + Static semantic rules restrict the possible choice of elaboration order. For + instance, if unit Client |withs| unit Server, then the spec of Server is + always elaborated prior to Client. The same principle applies to child units + - the spec of a parent unit is always elaborated prior to the child unit. + +* *Dynamic semantics* -* *Standard rules* + Dynamic checks are performed at run time, to ensure that a target is + elaborated prior to a scenario that executes it, thus avoiding ABE problems. + A failed run-time check raises exception ``Program_Error``. The following + restrictions apply: - Some standard rules restrict the possible choice of elaboration - order. In particular, if you |with| a unit, then its spec is always - elaborated before the unit doing the |with|. Similarly, a parent - spec is always elaborated before the child spec, and finally - a spec is always elaborated before its corresponding body. + - *Restrictions on calls* -.. index:: Elaboration checks -.. index:: Checks, elaboration + An entry, operator, or subprogram can be called from elaboration code only + when the corresponding body has been elaborated. -* *Dynamic elaboration checks* + - *Restrictions on instantiations* - Dynamic checks are made at run time, so that if some entity is accessed - before it is elaborated (typically by means of a subprogram call) - then the exception (``Program_Error``) is raised. + A generic unit can be instantiated by elaboration code only when the + corresponding body has been elaborated. + + - *Restrictions on task activation* + + A task can be activated by elaboration code only when the body of the + associated task type has been elaborated. + + The restrictions above can be summarized by the following rule: + + *If a target has a body, then this body must be elaborated prior to the + execution of the scenario that invokes, instantiates, or activates the + target.* * *Elaboration control* - Facilities are provided for the programmer to specify the desired order - of elaboration. - -Let's look at these facilities in more detail. First, the rules for -dynamic checking. One possible rule would be simply to say that the -exception is raised if you access a variable which has not yet been -elaborated. The trouble with this approach is that it could require -expensive checks on every variable reference. Instead Ada has two -rules which are a little more restrictive, but easier to check, and -easier to state: - -* *Restrictions on calls* - - A subprogram can only be called at elaboration time if its body - has been elaborated. The rules for elaboration given above guarantee - that the spec of the subprogram has been elaborated before the - call, but not the body. If this rule is violated, then the - exception ``Program_Error`` is raised. - -* *Restrictions on instantiations* - - A generic unit can only be instantiated if the body of the generic - unit has been elaborated. Again, the rules for elaboration given above - guarantee that the spec of the generic unit has been elaborated - before the instantiation, but not the body. If this rule is - violated, then the exception ``Program_Error`` is raised. - -The idea is that if the body has been elaborated, then any variables -it references must have been elaborated; by checking for the body being -elaborated we guarantee that none of its references causes any -trouble. As we noted above, this is a little too restrictive, because a -subprogram that has no non-local references in its body may in fact be safe -to call. However, it really would be unsafe to rely on this, because -it would mean that the caller was aware of details of the implementation -in the body. This goes against the basic tenets of Ada. - -A plausible implementation can be described as follows. -A Boolean variable is associated with each subprogram -and each generic unit. This variable is initialized to False, and is set to -True at the point body is elaborated. Every call or instantiation checks the -variable, and raises ``Program_Error`` if the variable is False. - -Note that one might think that it would be good enough to have one Boolean -variable for each package, but that would not deal with cases of trying -to call a body in the same package as the call -that has not been elaborated yet. -Of course a compiler may be able to do enough analysis to optimize away -some of the Boolean variables as unnecessary, and GNAT indeed -does such optimizations, but still the easiest conceptual model is to -think of there being one variable per subprogram. - -.. _Controlling_the_Elaboration_Order: - -Controlling the Elaboration Order -================================= + Pragmas are provided for the programmer to specify the desired elaboration + order. -In the previous section we discussed the rules in Ada which ensure -that ``Program_Error`` is raised if an incorrect elaboration order is -chosen. This prevents erroneous executions, but we need mechanisms to -specify a correct execution and avoid the exception altogether. -To achieve this, Ada provides a number of features for controlling -the order of elaboration. We discuss these features in this section. +.. _Controlling_the_Elaboration_Order_in_Ada: -First, there are several ways of indicating to the compiler that a given -unit has no elaboration problems: +Controlling the Elaboration Order in Ada +======================================== -* *packages that do not require a body* +Ada provides several idioms and pragmas to aid the programmer with specifying +the desired elaboration order and avoiding ABE problems altogether. - A library package that does not require a body does not permit - a body (this rule was introduced in Ada 95). - Thus if we have a such a package, as in: +* *Packages without a body* - .. code-block:: ada + A library package which does not require a completing body does not suffer + from ABE problems. - package Definitions is - generic - type m is new integer; - package Subp is - type a is array (1 .. 10) of m; - type b is array (1 .. 20) of m; - end Subp; - end Definitions; + :: + + package Pack is + generic + type Element is private; + package Containers is + type Element_Array is array (1 .. 10) of Element; + end Containers; + end Pack; - A package that |withs| ``Definitions`` may safely instantiate - ``Definitions.Subp`` because the compiler can determine that there - definitely is no package body to worry about in this case + In the example above, package ``Pack`` does not require a body because it + does not contain any constructs which require completion in a body. As a + result, generic ``Pack.Containers`` can be instantiated without encountering + any ABE problems. .. index:: pragma Pure * *pragma Pure* - This pragma places sufficient restrictions on a unit to guarantee that - no call to any subprogram in the unit can result in an - elaboration problem. This means that the compiler does not need - to worry about the point of elaboration of such units, and in - particular, does not need to check any calls to any subprograms - in this unit. + Pragma ``Pure`` places sufficient restrictions on a unit to guarantee that no + scenario within the unit can result in an ABE problem. .. index:: pragma Preelaborate * *pragma Preelaborate* - This pragma places slightly less stringent restrictions on a unit than - does pragma Pure, - but these restrictions are still sufficient to ensure that there - are no elaboration problems with any calls to the unit. + Pragma ``Preelaborate`` is slightly less restrictive than pragma ``Pure``, + but still strong enough to prevent ABE problems within a unit. .. index:: pragma Elaborate_Body * *pragma Elaborate_Body* - This pragma requires that the body of a unit be elaborated immediately - after its spec. Suppose a unit ``A`` has such a pragma, - and unit ``B`` does - a |with| of unit ``A``. Recall that the standard rules require - the spec of unit ``A`` - to be elaborated before the |withing| unit; given the pragma in - ``A``, we also know that the body of ``A`` - will be elaborated before ``B``, so - that calls to ``A`` are safe and do not need a check. - - Note that, unlike pragma ``Pure`` and pragma ``Preelaborate``, - the use of ``Elaborate_Body`` does not guarantee that the program is - free of elaboration problems, because it may not be possible - to satisfy the requested elaboration order. - Let's go back to the example with ``Unit_1`` and ``Unit_2``. - If a programmer marks ``Unit_1`` as ``Elaborate_Body``, - and not ``Unit_2,`` then the order of - elaboration will be:: - - Spec of Unit_2 - Spec of Unit_1 - Body of Unit_1 - Body of Unit_2 - - Now that means that the call to ``Func_1`` in ``Unit_2`` - need not be checked, - it must be safe. But the call to ``Func_2`` in - ``Unit_1`` may still fail if - ``Expression_1`` is equal to 1, - and the programmer must still take - responsibility for this not being the case. - - If all units carry a pragma ``Elaborate_Body``, then all problems are - eliminated, except for calls entirely within a body, which are - in any case fully under programmer control. However, using the pragma - everywhere is not always possible. - In particular, for our ``Unit_1``/`Unit_2` example, if - we marked both of them as having pragma ``Elaborate_Body``, then - clearly there would be no possible elaboration order. - -The above pragmas allow a server to guarantee safe use by clients, and -clearly this is the preferable approach. Consequently a good rule -is to mark units as ``Pure`` or ``Preelaborate`` if possible, -and if this is not possible, -mark them as ``Elaborate_Body`` if possible. -As we have seen, there are situations where neither of these -three pragmas can be used. -So we also provide methods for clients to control the -order of elaboration of the servers on which they depend: - -.. index:: pragma Elaborate - -* *pragma Elaborate (unit)* - - This pragma is placed in the context clause, after a |with| clause, - and it requires that the body of the named unit be elaborated before - the unit in which the pragma occurs. The idea is to use this pragma - if the current unit calls at elaboration time, directly or indirectly, - some subprogram in the named unit. - - -.. index:: pragma Elaborate_All - -* *pragma Elaborate_All (unit)* - - This is a stronger version of the Elaborate pragma. Consider the - following example:: - - Unit A |withs| unit B and calls B.Func in elab code - Unit B |withs| unit C, and B.Func calls C.Func - - - Now if we put a pragma ``Elaborate (B)`` - in unit ``A``, this ensures that the - body of ``B`` is elaborated before the call, but not the - body of ``C``, so - the call to ``C.Func`` could still cause ``Program_Error`` to - be raised. - - The effect of a pragma ``Elaborate_All`` is stronger, it requires - not only that the body of the named unit be elaborated before the - unit doing the |with|, but also the bodies of all units that the - named unit uses, following |with| links transitively. For example, - if we put a pragma ``Elaborate_All (B)`` in unit ``A``, - then it requires not only that the body of ``B`` be elaborated before ``A``, - but also the body of ``C``, because ``B`` |withs| ``C``. - -We are now in a position to give a usage rule in Ada for avoiding -elaboration problems, at least if dynamic dispatching and access to -subprogram values are not used. We will handle these cases separately -later. - -The rule is simple: - -*If a unit has elaboration code that can directly or -indirectly make a call to a subprogram in a |withed| unit, or instantiate -a generic package in a |withed| unit, -then if the |withed| unit does not have -pragma ``Pure`` or ``Preelaborate``, then the client should have -a pragma ``Elaborate_All``for the |withed| unit.** - -By following this rule a client is -assured that calls can be made without risk of an exception. - -For generic subprogram instantiations, the rule can be relaxed to -require only a pragma ``Elaborate`` since elaborating the body -of a subprogram cannot cause any transitive elaboration (we are -not calling the subprogram in this case, just elaborating its -declaration). - -If this rule is not followed, then a program may be in one of four -states: - -* *No order exists* - - No order of elaboration exists which follows the rules, taking into - account any ``Elaborate``, ``Elaborate_All``, - or ``Elaborate_Body`` pragmas. In - this case, an Ada compiler must diagnose the situation at bind - time, and refuse to build an executable program. - -* *One or more orders exist, all incorrect* + Pragma ``Elaborate_Body`` requires that the body of a unit is elaborated + immediately after its spec. This restriction guarantees that no client + scenario can execute a server target before the target body has been + elaborated because the spec and body are effectively "glued" together. - One or more acceptable elaboration orders exist, and all of them - generate an elaboration order problem. In this case, the binder - can build an executable program, but ``Program_Error`` will be raised - when the program is run. + :: -* *Several orders exist, some right, some incorrect* + package Server is + pragma Elaborate_Body; - One or more acceptable elaboration orders exists, and some of them - work, and some do not. The programmer has not controlled - the order of elaboration, so the binder may or may not pick one of - the correct orders, and the program may or may not raise an - exception when it is run. This is the worst case, because it means - that the program may fail when moved to another compiler, or even - another version of the same compiler. + function Func return Integer; + end Server; -* *One or more orders exists, all correct* + :: - One ore more acceptable elaboration orders exist, and all of them - work. In this case the program runs successfully. This state of - affairs can be guaranteed by following the rule we gave above, but - may be true even if the rule is not followed. + package body Server is + function Func return Integer is + begin + ... + end Func; + end Server; -Note that one additional advantage of following our rules on the use -of ``Elaborate`` and ``Elaborate_All`` -is that the program continues to stay in the ideal (all orders OK) state -even if maintenance -changes some bodies of some units. Conversely, if a program that does -not follow this rule happens to be safe at some point, this state of affairs -may deteriorate silently as a result of maintenance changes. + :: -You may have noticed that the above discussion did not mention -the use of ``Elaborate_Body``. This was a deliberate omission. If you -|with| an ``Elaborate_Body`` unit, it still may be the case that -code in the body makes calls to some other unit, so it is still necessary -to use ``Elaborate_All`` on such units. + with Server; + package Client is + Val : constant Integer := Server.Func; + end Client; + In the example above, pragma ``Elaborate_Body`` guarantees the following + elaboration order: -.. _Controlling_Elaboration_in_GNAT_-_Internal_Calls: + :: -Controlling Elaboration in GNAT - Internal Calls -================================================ + spec of Server + body of Server + spec of Client -In the case of internal calls, i.e., calls within a single package, the -programmer has full control over the order of elaboration, and it is up -to the programmer to elaborate declarations in an appropriate order. For -example writing: + because the spec of ``Server`` must be elaborated prior to ``Client`` by + virtue of the |with| clause, and in addition the body of ``Server`` must be + elaborated immediately after the spec of ``Server``. -.. code-block:: ada + Removing pragma ``Elaborate_Body`` could result in the following incorrect + elaboration order: - function One return Float; - - Q : Float := One; + :: - function One return Float is - begin - return 1.0; - end One; - -will obviously raise ``Program_Error`` at run time, because function -One will be called before its body is elaborated. In this case GNAT will -generate a warning that the call will raise ``Program_Error``:: - - 1. procedure y is - 2. function One return Float; - 3. - 4. Q : Float := One; - | - >>> warning: cannot call "One" before body is elaborated - >>> warning: Program_Error will be raised at run time - - 5. - 6. function One return Float is - 7. begin - 8. return 1.0; - 9. end One; - 10. - 11. begin - 12. null; - 13. end; - - -Note that in this particular case, it is likely that the call is safe, because -the function ``One`` does not access any global variables. -Nevertheless in Ada, we do not want the validity of the check to depend on -the contents of the body (think about the separate compilation case), so this -is still wrong, as we discussed in the previous sections. - -The error is easily corrected by rearranging the declarations so that the -body of ``One`` appears before the declaration containing the call -(note that in Ada 95 as well as later versions of the Ada standard, -declarations can appear in any order, so there is no restriction that -would prevent this reordering, and if we write: - -.. code-block:: ada - - function One return Float; - - function One return Float is - begin - return 1.0; - end One; - - Q : Float := One; - -then all is well, no warning is generated, and no -``Program_Error`` exception -will be raised. -Things are more complicated when a chain of subprograms is executed: - -.. code-block:: ada - - function A return Integer; - function B return Integer; - function C return Integer; - - function B return Integer is begin return A; end; - function C return Integer is begin return B; end; - - X : Integer := C; - - function A return Integer is begin return 1; end; - -Now the call to ``C`` -at elaboration time in the declaration of ``X`` is correct, because -the body of ``C`` is already elaborated, -and the call to ``B`` within the body of -``C`` is correct, but the call -to ``A`` within the body of ``B`` is incorrect, because the body -of ``A`` has not been elaborated, so ``Program_Error`` -will be raised on the call to ``A``. -In this case GNAT will generate a -warning that ``Program_Error`` may be -raised at the point of the call. Let's look at the warning:: - - 1. procedure x is - 2. function A return Integer; - 3. function B return Integer; - 4. function C return Integer; - 5. - 6. function B return Integer is begin return A; end; - | - >>> warning: call to "A" before body is elaborated may - raise Program_Error - >>> warning: "B" called at line 7 - >>> warning: "C" called at line 9 - - 7. function C return Integer is begin return B; end; - 8. - 9. X : Integer := C; - 10. - 11. function A return Integer is begin return 1; end; - 12. - 13. begin - 14. null; - 15. end; - - -Note that the message here says 'may raise', instead of the direct case, -where the message says 'will be raised'. That's because whether -``A`` is -actually called depends in general on run-time flow of control. -For example, if the body of ``B`` said - -.. code-block:: ada - - function B return Integer is - begin - if some-condition-depending-on-input-data then - return A; - else - return 1; - end if; - end B; - -then we could not know until run time whether the incorrect call to A would -actually occur, so ``Program_Error`` might -or might not be raised. It is possible for a compiler to -do a better job of analyzing bodies, to -determine whether or not ``Program_Error`` -might be raised, but it certainly -couldn't do a perfect job (that would require solving the halting problem -and is provably impossible), and because this is a warning anyway, it does -not seem worth the effort to do the analysis. Cases in which it -would be relevant are rare. - -In practice, warnings of either of the forms given -above will usually correspond to -real errors, and should be examined carefully and eliminated. -In the rare case where a warning is bogus, it can be suppressed by any of -the following methods: - -* Compile with the :switch:`-gnatws` switch set - -* Suppress ``Elaboration_Check`` for the called subprogram - -* Use pragma ``Warnings_Off`` to turn warnings off for the call - -For the internal elaboration check case, -GNAT by default generates the -necessary run-time checks to ensure -that ``Program_Error`` is raised if any -call fails an elaboration check. Of course this can only happen if a -warning has been issued as described above. The use of pragma -``Suppress (Elaboration_Check)`` may (but is not guaranteed to) suppress -some of these checks, meaning that it may be possible (but is not -guaranteed) for a program to be able to call a subprogram whose body -is not yet elaborated, without raising a ``Program_Error`` exception. - - -.. _Controlling_Elaboration_in_GNAT_-_External_Calls: - -Controlling Elaboration in GNAT - External Calls -================================================ - -The previous section discussed the case in which the execution of a -particular thread of elaboration code occurred entirely within a -single unit. This is the easy case to handle, because a programmer -has direct and total control over the order of elaboration, and -furthermore, checks need only be generated in cases which are rare -and which the compiler can easily detect. -The situation is more complex when separate compilation is taken into account. -Consider the following: - -.. code-block:: ada - - package Math is - function Sqrt (Arg : Float) return Float; - end Math; - - package body Math is - function Sqrt (Arg : Float) return Float is - begin - ... - end Sqrt; - end Math; - - with Math; - package Stuff is - X : Float := Math.Sqrt (0.5); - end Stuff; - - with Stuff; - procedure Main is - begin - ... - end Main; - -where ``Main`` is the main program. When this program is executed, the -elaboration code must first be executed, and one of the jobs of the -binder is to determine the order in which the units of a program are -to be elaborated. In this case we have four units: the spec and body -of ``Math``, -the spec of ``Stuff`` and the body of ``Main``). -In what order should the four separate sections of elaboration code -be executed? - -There are some restrictions in the order of elaboration that the binder -can choose. In particular, if unit U has a |with| -for a package ``X``, then you -are assured that the spec of ``X`` -is elaborated before U , but you are -not assured that the body of ``X`` -is elaborated before U. -This means that in the above case, the binder is allowed to choose the -order:: + spec of Server + spec of Client + body of Server + + where ``Client`` invokes ``Server.Func``, but the body of ``Server.Func`` has + not been elaborated yet. + +The pragmas outlined above allow a server unit to guarantee safe elaboration +use by client units. Thus it is a good rule to mark units as ``Pure`` or +``Preelaborate``, and if this is not possible, mark them as ``Elaborate_Body``. + +There are however situations where ``Pure``, ``Preelaborate``, and +``Elaborate_Body`` are not applicable. Ada provides another set of pragmas for +use by client units to help ensure the elaboration safety of server units they +depend on. + +.. index:: pragma Elaborate (Unit) + +* *pragma Elaborate (Unit)* + + Pragma ``Elaborate`` can be placed in the context clauses of a unit, after a + |with| clause. It guarantees that both the spec and body of its argument will + be elaborated prior to the unit with the pragma. Note that other unrelated + units may be elaborated in between the spec and the body. + + :: + + package Server is + function Func return Integer; + end Server; + + :: + + package body Server is + function Func return Integer is + begin + ... + end Func; + end Server; + + :: + + with Server; + pragma Elaborate (Server); + package Client is + Val : constant Integer := Server.Func; + end Client; + + In the example above, pragma ``Elaborate`` guarantees the following + elaboration order: + + :: + + spec of Server + body of Server + spec of Client + + Removing pragma ``Elaborate`` could result in the following incorrect + elaboration order: + + :: + + spec of Server + spec of Client + body of Server + + where ``Client`` invokes ``Server.Func``, but the body of ``Server.Func`` + has not been elaborated yet. + +.. index:: pragma Elaborate_All (Unit) + +* *pragma Elaborate_All (Unit)* + + Pragma ``Elaborate_All`` is placed in the context clauses of a unit, after + a |with| clause. It guarantees that both the spec and body of its argument + will be elaborated prior to the unit with the pragma, as well as all units + |withed| by the spec and body of the argument, recursively. Note that other + unrelated units may be elaborated in between the spec and the body. + + :: + + package Math is + function Factorial (Val : Natural) return Natural; + end Math; + + :: + + package body Math is + function Factorial (Val : Natural) return Natural is + begin + ...; + end Factorial; + end Math; + + :: + + package Computer is + type Operation_Kind is (None, Op_Factorial); + + function Compute + (Val : Natural; + Op : Operation_Kind) return Natural; + end Computer; + + :: + + with Math; + package body Computer is + function Compute + (Val : Natural; + Op : Operation_Kind) return Natural + is + if Op = Op_Factorial then + return Math.Factorial (Val); + end if; + + return 0; + end Compute; + end Computer; + + :: + + with Computer; + pragma Elaborate_All (Computer); + package Client is + Val : constant Natural := + Computer.Compute (123, Computer.Op_Factorial); + end Client; + + In the example above, pragma ``Elaborate_All`` can result in the following + elaboration order: + + :: spec of Math - spec of Stuff body of Math - body of Main - -but that's not good, because now the call to ``Math.Sqrt`` -that happens during -the elaboration of the ``Stuff`` -spec happens before the body of ``Math.Sqrt`` is -elaborated, and hence causes ``Program_Error`` exception to be raised. -At first glance, one might say that the binder is misbehaving, because -obviously you want to elaborate the body of something you |with| first, but -that is not a general rule that can be followed in all cases. Consider - -.. code-block:: ada - - package X is ... - - package Y is ... - - with X; - package body Y is ... - - with Y; - package body X is ... - -This is a common arrangement, and, apart from the order of elaboration -problems that might arise in connection with elaboration code, this works fine. -A rule that says that you must first elaborate the body of anything you -|with| cannot work in this case: -the body of ``X`` |withs| ``Y``, -which means you would have to -elaborate the body of ``Y`` first, but that |withs| ``X``, -which means -you have to elaborate the body of ``X`` first, but ... and we have a -loop that cannot be broken. - -It is true that the binder can in many cases guess an order of elaboration -that is unlikely to cause a ``Program_Error`` -exception to be raised, and it tries to do so (in the -above example of ``Math/Stuff/Spec``, the GNAT binder will -by default -elaborate the body of ``Math`` right after its spec, so all will be well). - -However, a program that blindly relies on the binder to be helpful can -get into trouble, as we discussed in the previous sections, so GNAT -provides a number of facilities for assisting the programmer in -developing programs that are robust with respect to elaboration order. - - -.. _Default_Behavior_in_GNAT_-_Ensuring_Safety: - -Default Behavior in GNAT - Ensuring Safety -========================================== - -The default behavior in GNAT ensures elaboration safety. In its -default mode GNAT implements the -rule we previously described as the right approach. Let's restate it: - -*If a unit has elaboration code that can directly or indirectly make a -call to a subprogram in a |withed| unit, or instantiate a generic -package in a |withed| unit, then if the |withed| unit -does not have pragma ``Pure`` or ``Preelaborate``, then the client should have an -``Elaborate_All`` pragma for the |withed| unit.* - -*In the case of instantiating a generic subprogram, it is always -sufficient to have only an ``Elaborate`` pragma for the -|withed| unit.* - -By following this rule a client is assured that calls and instantiations -can be made without risk of an exception. - -In this mode GNAT traces all calls that are potentially made from -elaboration code, and puts in any missing implicit ``Elaborate`` -and ``Elaborate_All`` pragmas. -The advantage of this approach is that no elaboration problems -are possible if the binder can find an elaboration order that is -consistent with these implicit ``Elaborate`` and -``Elaborate_All`` pragmas. The -disadvantage of this approach is that no such order may exist. - -If the binder does not generate any diagnostics, then it means that it has -found an elaboration order that is guaranteed to be safe. However, the binder -may still be relying on implicitly generated ``Elaborate`` and -``Elaborate_All`` pragmas so portability to other compilers than GNAT is not -guaranteed. - -If it is important to guarantee portability, then the compilations should -use the :switch:`-gnatel` -(info messages for elaboration pragmas) switch. This will cause info messages -to be generated indicating the missing ``Elaborate`` and -``Elaborate_All`` pragmas. -Consider the following source program: - -.. code-block:: ada - - with k; - package j is - m : integer := k.r; - end; - -where it is clear that there -should be a pragma ``Elaborate_All`` -for unit ``k``. An implicit pragma will be generated, and it is -likely that the binder will be able to honor it. However, if you want -to port this program to some other Ada compiler than GNAT. -it is safer to include the pragma explicitly in the source. If this -unit is compiled with the :switch:`-gnatel` -switch, then the compiler outputs an information message:: - - 1. with k; - 2. package j is - 3. m : integer := k.r; - | - >>> info: call to "r" may raise Program_Error - >>> info: missing pragma Elaborate_All for "k" - - 4. end; - -and these messages can be used as a guide for supplying manually -the missing pragmas. It is usually a bad idea to use this -option during development. That's because it will tell you when -you need to put in a pragma, but cannot tell you when it is time -to take it out. So the use of pragma ``Elaborate_All`` may lead to -unnecessary dependencies and even false circularities. - -This default mode is more restrictive than the Ada Reference -Manual, and it is possible to construct programs which will compile -using the dynamic model described there, but will run into a -circularity using the safer static model we have described. - -Of course any Ada compiler must be able to operate in a mode -consistent with the requirements of the Ada Reference Manual, -and in particular must have the capability of implementing the -standard dynamic model of elaboration with run-time checks. - -In GNAT, this standard mode can be achieved either by the use of -the :switch:`-gnatE` switch on the compiler (``gcc`` or -``gnatmake``) command, or by the use of the configuration pragma: - -.. code-block:: ada - - pragma Elaboration_Checks (DYNAMIC); - -Either approach will cause the unit affected to be compiled using the -standard dynamic run-time elaboration checks described in the Ada -Reference Manual. The static model is generally preferable, since it -is clearly safer to rely on compile and link time checks rather than -run-time checks. However, in the case of legacy code, it may be -difficult to meet the requirements of the static model. This -issue is further discussed in -:ref:`What_to_Do_If_the_Default_Elaboration_Behavior_Fails`. - -Note that the static model provides a strict subset of the allowed -behavior and programs of the Ada Reference Manual, so if you do -adhere to the static model and no circularities exist, -then you are assured that your program will -work using the dynamic model, providing that you remove any -pragma Elaborate statements from the source. - - -.. _Treatment_of_Pragma_Elaborate: - -Treatment of Pragma Elaborate -============================= - -.. index:: Pragma Elaborate - -The use of ``pragma Elaborate`` -should generally be avoided in Ada 95 and Ada 2005 programs, -since there is no guarantee that transitive calls -will be properly handled. Indeed at one point, this pragma was placed -in Annex J (Obsolescent Features), on the grounds that it is never useful. - -Now that's a bit restrictive. In practice, the case in which -``pragma Elaborate`` is useful is when the caller knows that there -are no transitive calls, or that the called unit contains all necessary -transitive ``pragma Elaborate`` statements, and legacy code often -contains such uses. - -Strictly speaking the static mode in GNAT should ignore such pragmas, -since there is no assurance at compile time that the necessary safety -conditions are met. In practice, this would cause GNAT to be incompatible -with correctly written Ada 83 code that had all necessary -``pragma Elaborate`` statements in place. Consequently, we made the -decision that GNAT in its default mode will believe that if it encounters -a ``pragma Elaborate`` then the programmer knows what they are doing, -and it will trust that no elaboration errors can occur. - -The result of this decision is two-fold. First to be safe using the -static mode, you should remove all ``pragma Elaborate`` statements. -Second, when fixing circularities in existing code, you can selectively -use ``pragma Elaborate`` statements to convince the static mode of -GNAT that it need not generate an implicit ``pragma Elaborate_All`` -statement. - -When using the static mode with :switch:`-gnatwl`, any use of -``pragma Elaborate`` will generate a warning about possible -problems. - - -.. _Elaboration_Issues_for_Library_Tasks: - -Elaboration Issues for Library Tasks -==================================== - -.. index:: Library tasks, elaboration issues - -.. index:: Elaboration of library tasks - -In this section we examine special elaboration issues that arise for -programs that declare library level tasks. - -Generally the model of execution of an Ada program is that all units are -elaborated, and then execution of the program starts. However, the -declaration of library tasks definitely does not fit this model. The -reason for this is that library tasks start as soon as they are declared -(more precisely, as soon as the statement part of the enclosing package -body is reached), that is to say before elaboration -of the program is complete. This means that if such a task calls a -subprogram, or an entry in another task, the callee may or may not be -elaborated yet, and in the standard -Reference Manual model of dynamic elaboration checks, you can even -get timing dependent Program_Error exceptions, since there can be -a race between the elaboration code and the task code. - -The static model of elaboration in GNAT seeks to avoid all such -dynamic behavior, by being conservative, and the conservative -approach in this particular case is to assume that all the code -in a task body is potentially executed at elaboration time if -a task is declared at the library level. - -This can definitely result in unexpected circularities. Consider -the following example - -.. code-block:: ada - - package Decls is - task Lib_Task is - entry Start; - end Lib_Task; + spec of Computer + body of Computer + spec of Client - type My_Int is new Integer; + Note that there are several allowable suborders for the specs and bodies of + ``Math`` and ``Computer``, but the point is that these specs and bodies will + be elaborated prior to ``Client``. - function Ident (M : My_Int) return My_Int; - end Decls; + Removing pragma ``Elaborate_All`` could result in the following incorrect + elaboration order - with Utils; - package body Decls is - task body Lib_Task is - begin - accept Start; - Utils.Put_Val (2); - end Lib_Task; + :: - function Ident (M : My_Int) return My_Int is + spec of Math + spec of Computer + body of Computer + spec of Client + body of Math + + where ``Client`` invokes ``Computer.Compute``, which in turn invokes + ``Math.Factorial``, but the body of ``Math.Factorial`` has not been + elaborated yet. + +All pragmas shown above can be summarized by the following rule: + +*If a client unit elaborates a server target directly or indirectly, then if +the server unit requires a body and does not have pragma Pure, Preelaborate, +or Elaborate_Body, then the client unit should have pragma Elaborate or +Elaborate_All for the server unit.* + +If the rule outlined above is not followed, then a program may fall in one of +the following states: + +* *No elaboration order exists* + + In this case a compiler must diagnose the situation, and refuse to build an + executable program. + +* *One or more incorrect elaboration orders exist* + + In this case a compiler can build an executable program, but + ``Program_Error`` will be raised when the program is run. + +* *Several elaboration orders exist, some correct, some incorrect* + + In this case the programmer has not controlled the elaboration order. As a + result, a compiler may or may not pick one of the correct orders, and the + program may or may not raise ``Program_Error`` when it is run. This is the + worst possible state because the program may fail on another compiler, or + even another version of the same compiler. + +* *One or more correct orders exist* + + In this case a compiler can build an executable program, and the program is + run successfully. This state may be guaranteed by following the outlined + rules, or may be the result of good program architecture. + +Note that one additional advantage of using ``Elaborate`` and ``Elaborate_All`` +is that the program continues to stay in the last state (one or more correct +orders exist) even if maintenance changes the bodies of targets. + +.. _Controlling_the_Elaboration_Order_in_GNAT: + +Controlling the Elaboration Order in GNAT +========================================= + +In addition to Ada semantics and rules synthesized from them, GNAT offers +three elaboration models to aid the programmer with specifying the correct +elaboration order and to diagnose elaboration problems. + +.. index:: Dynamic elaboration model + +* *Dynamic elaboration model* + + This is the most permissive of the three elaboration models. When the + dynamic model is in effect, GNAT assumes that all code within all units in + a partition is elaboration code. GNAT performs very few diagnostics and + generates run-time checks to verify the elaboration order of a program. This + behavior is identical to that specified by the Ada Reference Manual. The + dynamic model is enabled with compilation switch :switch:`-gnatE`. + +.. index:: Static elaboration model + +* *Static elaboration model* + + This is the middle ground of the three models. When the static model is in + effect, GNAT performs extensive diagnostics on a unit-by-unit basis for all + scenarios that elaborate or execute internal targets. GNAT also generates + run-time checks for all external targets and for all scenarios that may + exhibit ABE problems. Finally, GNAT installs implicit ``Elaborate`` and + ``Elaborate_All`` pragmas for server units based on the dependencies of + client units. The static model is the default model in GNAT. + +.. index:: SPARK elaboration model + +* *SPARK elaboration model* + + This is the most conservative of the three models and enforces the SPARK + rules of elaboration as defined in the SPARK Reference Manual, section 7.7. + The SPARK model is in effect only when a scenario and a target reside in a + region subject to SPARK_Mode On, otherwise the dynamic or static model is in + effect. + +.. _Common_Elaboration_Model_Traits": + +Common Elaboration-model Traits +=============================== + +All three GNAT models are able to detect elaboration problems related to +dispatching calls and a particular kind of ABE referred to as *guaranteed ABE*. + +* *Dispatching calls* + + GNAT installs run-time checks for each primitive subprogram of each tagged + type defined in a partition on the assumption that a dispatching call + invoked at elaboration time will execute one of these primitives. As a + result, a dispatching call that executes a primitive whose body has not + been elaborated yet will raise exception ``Program_Error`` at run time. The + checks can be suppressed using pragma ``Suppress (Elaboration_Check)``. + +* *Guaranteed ABE* + + A guaranteed ABE arises when the body of a target is not elaborated early + enough, and causes all scenarios that directly execute the target to fail. + + :: + + package body Guaranteed_ABE is + function ABE return Integer; + + Val : constant Integer := ABE; + + function ABE return Integer is begin - return M; - end Ident; - end Decls; + ... + end ABE; + end Guaranteed_ABE; + + In the example above, the elaboration of ``Guaranteed_ABE``'s body elaborates + the declaration of ``Val``. This invokes function ``ABE``, however the body + of ``ABE`` has not been elaborated yet. GNAT emits similar diagnostics in all + three models: + + :: + + 1. package body Guaranteed_ABE is + 2. function ABE return Integer; + 3. + 4. Val : constant Integer := ABE; + | + >>> warning: cannot call "ABE" before body seen + >>> warning: Program_Error will be raised at run time + + 5. + 6. function ABE return Integer is + 7. begin + 8. ... + 9. end ABE; + 10. end Guaranteed_ABE; + +Note that GNAT emits warnings rather than hard errors whenever it encounters an +elaboration problem. This is because the elaboration model in effect may be too +conservative, or a particular scenario may not be elaborated or executed due to +data and control flow. The warnings can be suppressed with compiler switch +:switch:`-gnatws`. + +.. _Dynamic_Elaboration_Model_in_GNAT: + +Dynamic Elaboration Model in GNAT +================================= - with Decls; - package Utils is - procedure Put_Val (Arg : Decls.My_Int); - end Utils; +The dynamic model assumes that all code within all units in a partition is +elaboration code. As a result, run-time checks are installed for each scenario +regardless of whether the target is internal or external. The checks can be +suppressed using pragma ``Suppress (Elaboration_Check)``. This behavior is +identical to that specified by the Ada Reference Manual. The following example +showcases run-time checks installed by GNAT to verify the elaboration state of +package ``Dynamic_Model``. - with Text_IO; - package body Utils is - procedure Put_Val (Arg : Decls.My_Int) is +:: + + with Server; + package body Dynamic_Model is + procedure API is + begin + ... + end API; + + <check that the body of Server.Gen is elaborated> + package Inst is new Server.Gen; + + T : Server.Task_Type; + + begin + <check that the body of Server.Task_Type is elaborated> + + <check that the body of Server.Proc is elaborated> + Server.Proc; + end Dynamic_Model; + +The checks verify that the body of a target has been successfully elaborated +before a scenario activates, calls, or instantiates a target. + +Note that no scenario within package ``Dynamic_Model`` calls procedure ``API``. +In fact, procedure ``API`` may not be invoked by elaboration code within the +partition, however the dynamic model assumes that this can happen. + +The dynamic model emits very few diagnostics, but can make suggestions on +missing ``Elaborate`` and ``Elaborate_All`` pragmas for library-level +scenarios. This information is available when compiler switch :switch:`-gnatel` +is in effect. + +:: + + 1. with Server; + 2. package body Dynamic_Model is + 3. Val : constant Integer := Server.Func; + | + >>> info: call to "Func" during elaboration + >>> info: missing pragma "Elaborate_All" for unit "Server" + + 4. end Dynamic_Model; + +.. _Static_Elaboration_Model_in_GNAT: + +Static Elaboration Model in GNAT +================================ + +In contrast to the dynamic model, the static model is more precise in its +analysis of elaboration code. The model makes a clear distinction between +internal and external targets, and resorts to different diagnostics and +run-time checks based on the nature of the target. + +* *Internal targets* + + The static model performs extensive diagnostics on scenarios which elaborate + or execute internal targets. The warnings resulting from these diagnostics + are enabled by default, but can be suppressed using compiler switch + :switch:`-gnatws`. + + :: + + 1. package body Static_Model is + 2. generic + 3. with function Func return Integer; + 4. package Gen is + 5. Val : constant Integer := Func; + 6. end Gen; + 7. + 8. function ABE return Integer; + 9. + 10. function Cause_ABE return Boolean is + 11. package Inst is new Gen (ABE); + | + >>> warning: in instantiation at line 5 + >>> warning: cannot call "ABE" before body seen + >>> warning: Program_Error may be raised at run time + >>> warning: body of unit "Static_Model" elaborated + >>> warning: function "Cause_ABE" called at line 16 + >>> warning: function "ABE" called at line 5, instance at line 11 + + 12. begin + 13. ... + 14. end Cause_ABE; + 15. + 16. Val : constant Boolean := Cause_ABE; + 17. + 18. function ABE return Integer is + 19. begin + 20. ... + 21. end ABE; + 22. end Static_Model; + + The example above illustrates an ABE problem within package ``Static_Model``, + which is hidden by several layers of indirection. The elaboration of package + body ``Static_Model`` elaborates the declaration of ``Val``. This invokes + function ``Cause_ABE``, which instantiates generic unit ``Gen`` as ``Inst``. + The elaboration of ``Inst`` invokes function ``ABE``, however the body of + ``ABE`` has not been elaborated yet. + +* *External targets* + + The static model installs run-time checks to verify the elaboration status + of server targets only when the scenario that elaborates or executes that + target is part of the elaboration code of the client unit. The checks can be + suppressed using pragma ``Suppress (Elaboration_Check)``. + + :: + + with Server; + package body Static_Model is + generic + with function Func return Integer; + package Gen is + Val : constant Integer := Func; + end Gen; + + function Call_Func return Boolean is + <check that the body of Server.Func is elaborated> + package Inst is new Gen (Server.Func); begin - Text_IO.Put_Line (Decls.My_Int'Image (Decls.Ident (Arg))); - end Put_Val; - end Utils; + ... + end Call_Func; + + Val : constant Boolean := Call_Func; + end Static_Model; + + In the example above, the elaboration of package body ``Static_Model`` + elaborates the declaration of ``Val``. This invokes function ``Call_Func``, + which instantiates generic unit ``Gen`` as ``Inst``. The elaboration of + ``Inst`` invokes function ``Server.Func``. Since ``Server.Func`` is an + external target, GNAT installs a run-time check to verify that its body has + been elaborated. + + In addition to checks, the static model installs implicit ``Elaborate`` and + ``Elaborate_All`` pragmas to guarantee safe elaboration use of server units. + This information is available when compiler switch :switch:`-gnatel` is in + effect. + + :: + + 1. with Server; + 2. package body Static_Model is + 3. generic + 4. with function Func return Integer; + 5. package Gen is + 6. Val : constant Integer := Func; + 7. end Gen; + 8. + 9. function Call_Func return Boolean is + 10. package Inst is new Gen (Server.Func); + | + >>> info: instantiation of "Gen" during elaboration + >>> info: in instantiation at line 6 + >>> info: call to "Func" during elaboration + >>> info: in instantiation at line 6 + >>> info: implicit pragma "Elaborate_All" generated for unit "Server" + >>> info: body of unit "Static_Model" elaborated + >>> info: function "Call_Func" called at line 15 + >>> info: function "Func" called at line 6, instance at line 10 + + 11. begin + 12. ... + 13. end Call_Func; + 14. + 15. Val : constant Boolean := Call_Func; + | + >>> info: call to "Call_Func" during elaboration + + 16. end Static_Model; + + In the example above, the elaboration of package body ``Static_Model`` + elaborates the declaration of ``Val``. This invokes function ``Call_Func``, + which instantiates generic unit ``Gen`` as ``Inst``. The elaboration of + ``Inst`` invokes function ``Server.Func``. Since ``Server.Func`` is an + external target, GNAT installs an implicit ``Elaborate_All`` pragma for unit + ``Server``. The pragma guarantees that both the spec and body of ``Server``, + along with any additional dependencies that ``Server`` may require, are + elaborated prior to the body of ``Static_Model``. + +.. _SPARK_Elaboration_Model_in_GNAT: + +SPARK Elaboration Model in GNAT +=============================== + +The SPARK model is identical to the static model in its handling of internal +targets. The SPARK model, however, requires explicit ``Elaborate`` or +``Elaborate_All`` pragmas to be present in the program when a target is +external, and emits hard errors instead of warnings: + +:: + + 1. with Server; + 2. package body SPARK_Model with SPARK_Mode is + 3. Val : constant Integer := Server.Func; + | + >>> call to "Func" during elaboration in SPARK + >>> unit "SPARK_Model" requires pragma "Elaborate_All" for "Server" + >>> body of unit "SPARK_Model" elaborated + >>> function "Func" called at line 3 + + 4. end SPARK_Model; + +.. _Mixing_Elaboration_Models: + +Mixing Elaboration Models +========================= + +It is possible to mix units compiled with a different elaboration model, +however the following rules must be observed: + +* A client unit compiled with the dynamic model can only |with| a server unit + that meets at least one of the following criteria: + + - The server unit is compiled with the dynamic model. + + - The server unit is a GNAT implementation unit from the Ada, GNAT, + Interfaces, or System hierarchies. + + - The server unit has pragma ``Pure`` or ``Preelaborate``. + + - The client unit has an explicit ``Elaborate_All`` pragma for the server + unit. + +These rules ensure that elaboration checks are not omitted. If the rules are +violated, the binder emits a warning: + +:: + + warning: "x.ads" has dynamic elaboration checks and with's + warning: "y.ads" which has static elaboration checks + +The warnings can be suppressed by binder switch :switch:`-ws`. - with Decls; - procedure Main is +.. _Elaboration_Circularities: + +Elaboration Circularities +========================= + +If the binder cannot find an acceptable elaboration order, it outputs detailed +diagnostics describing an **elaboration circularity**. + +:: + + package Server is + function Func return Integer; + end Server; + +:: + + with Client; + package body Server is + function Func return Integer is + begin + ... + end Func; + end Server; + +:: + + with Server; + package Client is + Val : constant Integer := Server.Func; + end Client; + +:: + + with Client; + procedure Main is begin null; end Main; + +:: + + error: elaboration circularity detected + info: "server (body)" must be elaborated before "client (spec)" + info: reason: implicit Elaborate_All in unit "client (spec)" + info: recompile "client (spec)" with -gnatel for full details + info: "server (body)" + info: must be elaborated along with its spec: + info: "server (spec)" + info: which is withed by: + info: "client (spec)" + info: "client (spec)" must be elaborated before "server (body)" + info: reason: with clause + +In the example above, ``Client`` must be elaborated prior to ``Main`` by virtue +of a |with| clause. The elaboration of ``Client`` invokes ``Server.Func``, and +static model generates an implicit ``Elaborate_All`` pragma for ``Server``. The +pragma implies that both the spec and body of ``Server``, along with any units +they |with|, must be elaborated prior to ``Client``. However, ``Server``'s body +|withs| ``Client``, implying that ``Client`` must be elaborated prior to +``Server``. The end result is that ``Client`` must be elaborated prior to +``Client``, and this leads to a circularity. + +.. _Resolving_Elaboration_Circularities: + +Resolving Elaboration Circularities +=================================== + +When faced with an elaboration circularity, a programmer has several options +available. + +* *Fix the program* + + The most desirable option from the point of view of long-term maintenance + is to rearrange the program so that the elaboration problems are avoided. + One useful technique is to place the elaboration code into separate child + packages. Another is to move some of the initialization code to explicitly + invoked subprograms, where the program controls the order of initialization + explicitly. Although this is the most desirable option, it may be impractical + and involve too much modification, especially in the case of complex legacy + code. + +* *Switch to more permissive elaboration model* + + If the compilation was performed using the static model, enable the dynamic + model with compilation switch :switch:`-gnatE`. GNAT will no longer generate + implicit ``Elaborate`` and ``Elaborate_All`` pragmas, resulting in a behavior + identical to that specified by the Ada Reference Manual. The binder will + generate an executable program that may or may not raise ``Program_Error``, + and it is the programmer's responsibility to ensure that it does not raise + ``Program_Error``. + +* *Suppress all elaboration checks* + + The drawback of run-time checks is that they generate overhead at run time, + both in space and time. If the programmer is absolutely sure that a program + will not raise an elaboration-related ``Program_Error``, then using the + pragma ``Suppress (Elaboration_Check)`` globally (as a configuration pragma) + will eliminate all run-time checks. + +* *Suppress elaboration checks selectively* + + If a scenario cannot possibly lead to an elaboration ``Program_Error``, + and the binder nevertheless complains about implicit ``Elaborate`` and + ``Elaborate_All`` pragmas that lead to elaboration circularities, it + is possible to suppress the generation of implicit ``Elaborate`` and + ``Elaborate_All`` pragmas, as well as run-time checks. Clearly this can + be unsafe, and it is the responsibility of the programmer to make sure + that the resulting program has no elaboration anomalies. Pragma + ``Suppress (Elaboration_Check)`` can be used with different levels of + granularity to achieve these effects. + + - *Target suppression* + + When the pragma is placed in a declarative part, without a second argument + naming an entity, it will suppress implicit ``Elaborate`` and + ``Elaborate_All`` pragma generation, as well as run-time checks, on all + targets within the region. + + :: + + package Range_Suppress is + pragma Suppress (Elaboration_Check); + + function Func return Integer; + + generic + procedure Gen; + + pragma Unsuppress (Elaboration_Check); + + task type Tsk; + end Range_Suppress; + + In the example above, a pair of Suppress/Unsuppress pragmas define a region + of suppression within package ``Range_Suppress``. As a result, no implicit + ``Elaborate`` and ``Elaborate_All`` pragmas, nor any run-time checks, will + be generated by callers of ``Func`` and instantiators of ``Gen``. Note that + task type ``Tsk`` is not within this region. + + An alternative to the region-based suppression is to use multiple + ``Suppress`` pragmas with arguments naming specific entities for which + elaboration checks should be suppressed: + + :: + + package Range_Suppress is + function Func return Integer; + pragma Suppress (Elaboration_Check, Func); + + generic + procedure Gen; + pragma Suppress (Elaboration_Check, Gen); + + task type Tsk; + end Range_Suppress; + + - *Scenario suppression* + + When the pragma ``Suppress`` is placed in a declarative or statement + part, without an entity argument, it will suppress implicit ``Elaborate`` + and ``Elaborate_All`` pragma generation, as well as run-time checks, on + all scenarios within the region. + + :: + + with Server; + package body Range_Suppress is + pragma Suppress (Elaboration_Check); + + function Func return Integer is + begin + return Server.Func; + end Func; + + procedure Gen is + begin + Server.Proc; + end Gen; + + pragma Unsuppress (Elaboration_Check); + + task body Tsk is + begin + Server.Proc; + end Tsk; + end Range_Suppress; + + In the example above, a pair of Suppress/Unsuppress pragmas define a region + of suppression within package body ``Range_Suppress``. As a result, the + calls to ``Server.Func`` in ``Func`` and ``Server.Proc`` in ``Gen`` will + not generate any implicit ``Elaborate`` and ``Elaborate_All`` pragmas or + run-time checks. + +.. _Resolving_Task_Issues: + +Resolving Task Issues +===================== + +The model of execution in Ada dictates that elaboration must first take place, +and only then can the main program be started. Tasks which are activated during +elaboration violate this model and may lead to serious concurrent problems at +elaboration time. + +A task can be activated in two different ways: + +* The task is created by an allocator in which case it is activated immediately + after the allocator is evaluated. + +* The task is declared at the library level or within some nested master in + which case it is activated before starting execution of the statement + sequence of the master defining the task. + +Since the elaboration of a partition is performed by the environment task +servicing that partition, any tasks activated during elaboration may be in +a race with the environment task, and lead to unpredictable state and behavior. +The static model seeks to avoid such interactions by assuming that all code in +the task body is executed at elaboration time, if the task was activated by +elaboration code. + +:: + + package Decls is + task Lib_Task is + entry Start; + end Lib_Task; + + type My_Int is new Integer; + + function Ident (M : My_Int) return My_Int; + end Decls; + +:: + + with Utils; + package body Decls is + task body Lib_Task is + begin + accept Start; + Utils.Put_Val (2); + end Lib_Task; + + function Ident (M : My_Int) return My_Int is + begin + return M; + end Ident; + end Decls; + +:: + + with Decls; + package Utils is + procedure Put_Val (Arg : Decls.My_Int); + end Utils; + +:: + + with Ada.Text_IO; use Ada.Text_IO; + package body Utils is + procedure Put_Val (Arg : Decls.My_Int) is begin - Decls.Lib_Task.Start; - end; - -If the above example is compiled in the default static elaboration -mode, then a circularity occurs. The circularity comes from the call -``Utils.Put_Val`` in the task body of ``Decls.Lib_Task``. Since -this call occurs in elaboration code, we need an implicit pragma -``Elaborate_All`` for ``Utils``. This means that not only must -the spec and body of ``Utils`` be elaborated before the body -of ``Decls``, but also the spec and body of any unit that is -|withed| by the body of ``Utils`` must also be elaborated before -the body of ``Decls``. This is the transitive implication of -pragma ``Elaborate_All`` and it makes sense, because in general -the body of ``Put_Val`` might have a call to something in a -|withed| unit. - -In this case, the body of Utils (actually its spec) |withs| -``Decls``. Unfortunately this means that the body of ``Decls`` -must be elaborated before itself, in case there is a call from the -body of ``Utils``. - -Here is the exact chain of events we are worrying about: - -* In the body of ``Decls`` a call is made from within the body of a library - task to a subprogram in the package ``Utils``. Since this call may - occur at elaboration time (given that the task is activated at elaboration - time), we have to assume the worst, i.e., that the - call does happen at elaboration time. - -* This means that the body and spec of ``Util`` must be elaborated before - the body of ``Decls`` so that this call does not cause an access before - elaboration. - -* Within the body of ``Util``, specifically within the body of - ``Util.Put_Val`` there may be calls to any unit |withed| - by this package. - -* One such |withed| package is package ``Decls``, so there - might be a call to a subprogram in ``Decls`` in ``Put_Val``. - In fact there is such a call in this example, but we would have to - assume that there was such a call even if it were not there, since - we are not supposed to write the body of ``Decls`` knowing what - is in the body of ``Utils``; certainly in the case of the - static elaboration model, the compiler does not know what is in - other bodies and must assume the worst. - -* This means that the spec and body of ``Decls`` must also be - elaborated before we elaborate the unit containing the call, but - that unit is ``Decls``! This means that the body of ``Decls`` - must be elaborated before itself, and that's a circularity. - -Indeed, if you add an explicit pragma ``Elaborate_All`` for ``Utils`` in -the body of ``Decls`` you will get a true Ada Reference Manual -circularity that makes the program illegal. - -In practice, we have found that problems with the static model of -elaboration in existing code often arise from library tasks, so -we must address this particular situation. - -Note that if we compile and run the program above, using the dynamic model of -elaboration (that is to say use the :switch:`-gnatE` switch), -then it compiles, binds, -links, and runs, printing the expected result of 2. Therefore in some sense -the circularity here is only apparent, and we need to capture -the properties of this program that distinguish it from other library-level -tasks that have real elaboration problems. - -We have four possible answers to this question: - - -* Use the dynamic model of elaboration. - - If we use the :switch:`-gnatE` switch, then as noted above, the program works. - Why is this? If we examine the task body, it is apparent that the task cannot - proceed past the - ``accept`` statement until after elaboration has been completed, because - the corresponding entry call comes from the main program, not earlier. - This is why the dynamic model works here. But that's really giving - up on a precise analysis, and we prefer to take this approach only if we cannot - solve the - problem in any other manner. So let us examine two ways to reorganize - the program to avoid the potential elaboration problem. - -* Split library tasks into separate packages. - - Write separate packages, so that library tasks are isolated from - other declarations as much as possible. Let us look at a variation on - the above program. - - - .. code-block:: ada - - package Decls1 is + Put_Line (Arg'Img); + end Put_Val; + end Utils; + +:: + + with Decls; + procedure Main is + begin + Decls.Lib_Task.Start; + end Main; + +When the above example is compiled with the static model, an elaboration +circularity arises: + +:: + + error: elaboration circularity detected + info: "decls (body)" must be elaborated before "decls (body)" + info: reason: implicit Elaborate_All in unit "decls (body)" + info: recompile "decls (body)" with -gnatel for full details + info: "decls (body)" + info: must be elaborated along with its spec: + info: "decls (spec)" + info: which is withed by: + info: "utils (spec)" + info: which is withed by: + info: "decls (body)" + +In the above example, ``Decls`` must be elaborated prior to ``Main`` by virtue +of a with clause. The elaboration of ``Decls`` activates task ``Lib_Task``. The +static model conservatibely assumes that all code within the body of +``Lib_Task`` is executed, and generates an implicit ``Elaborate_All`` pragma +for ``Units`` due to the call to ``Utils.Put_Val``. The pragma implies that +both the spec and body of ``Utils``, along with any units they |with|, +must be elaborated prior to ``Decls``. However, ``Utils``'s spec |withs| +``Decls``, implying that ``Decls`` must be elaborated before ``Utils``. The end +result is that ``Utils`` must be elaborated prior to ``Utils``, and this +leads to a circularity. + +In reality, the example above will not exhibit an ABE problem at run time. +When the body of task ``Lib_Task`` is activated, execution will wait for entry +``Start`` to be accepted, and the call to ``Utils.Put_Val`` will not take place +at elaboration time. Task ``Lib_Task`` will resume its execution after the main +program is executed because ``Main`` performs a rendezvous with +``Lib_Task.Start``, and at that point all units have already been elaborated. +As a result, the static model may seem overly conservative, partly because it +does not take control and data flow into account. + +When faced with a task elaboration circularity, a programmer has several +options available: + +* *Use the dynamic model* + + The dynamic model does not generate implicit ``Elaborate`` and + ``Elaborate_All`` pragmas. Instead, it will install checks prior to every + call in the example above, thus verifying the successful elaboration of + ``Utils.Put_Val`` in case the call to it takes place at elaboration time. + The dynamic model is enabled with compiler switch :switch:`-gnatE`. + +* *Isolate the tasks* + + Relocating tasks in their own separate package could decouple them from + dependencies that would otherwise cause an elaboration circularity. The + example above can be rewritten as follows: + + :: + + package Decls1 is -- new task Lib_Task is entry Start; end Lib_Task; - end Decls1; + end Decls1; + + :: - with Utils; - package body Decls1 is + with Utils; + package body Decls1 is -- new task body Lib_Task is begin accept Start; Utils.Put_Val (2); end Lib_Task; - end Decls1; + end Decls1; - package Decls2 is + :: + + package Decls2 is -- new type My_Int is new Integer; function Ident (M : My_Int) return My_Int; - end Decls2; + end Decls2; + + :: - with Utils; - package body Decls2 is + with Utils; + package body Decls2 is -- new function Ident (M : My_Int) return My_Int is begin return M; end Ident; - end Decls2; + end Decls2; + + :: - with Decls2; - package Utils is + with Decls2; + package Utils is procedure Put_Val (Arg : Decls2.My_Int); - end Utils; + end Utils; - with Text_IO; - package body Utils is + :: + + with Ada.Text_IO; use Ada.Text_IO; + package body Utils is procedure Put_Val (Arg : Decls2.My_Int) is begin - Text_IO.Put_Line (Decls2.My_Int'Image (Decls2.Ident (Arg))); + Put_Line (Arg'Img); end Put_Val; - end Utils; - - with Decls1; - procedure Main is - begin - Decls1.Lib_Task.Start; - end; + end Utils; + :: - All we have done is to split ``Decls`` into two packages, one - containing the library task, and one containing everything else. Now - there is no cycle, and the program compiles, binds, links and executes - using the default static model of elaboration. - -* Declare separate task types. + with Decls1; + procedure Main is + begin + Decls1.Lib_Task.Start; + end Main; + +* *Declare the tasks* - A significant part of the problem arises because of the use of the - single task declaration form. This means that the elaboration of - the task type, and the elaboration of the task itself (i.e., the - creation of the task) happen at the same time. A good rule - of style in Ada is to always create explicit task types. By - following the additional step of placing task objects in separate - packages from the task type declaration, many elaboration problems - are avoided. Here is another modified example of the example program: + The original example uses a single task declaration for ``Lib_Task``. An + explicit task type declaration and a properly placed task object could avoid + the dependencies that would otherwise cause an elaboration circularity. The + example can be rewritten as follows: - .. code-block:: ada + :: - package Decls is - task type Lib_Task_Type is + package Decls is + task type Lib_Task is -- new entry Start; - end Lib_Task_Type; + end Lib_Task; type My_Int is new Integer; function Ident (M : My_Int) return My_Int; - end Decls; + end Decls; - with Utils; - package body Decls is - task body Lib_Task_Type is + :: + + with Utils; + package body Decls is + task body Lib_Task is begin accept Start; Utils.Put_Val (2); - end Lib_Task_Type; + end Lib_Task; function Ident (M : My_Int) return My_Int is begin return M; end Ident; - end Decls; + end Decls; - with Decls; - package Utils is + :: + + with Decls; + package Utils is procedure Put_Val (Arg : Decls.My_Int); - end Utils; + end Utils; + + :: - with Text_IO; - package body Utils is + with Ada.Text_IO; use Ada.Text_IO; + package body Utils is procedure Put_Val (Arg : Decls.My_Int) is begin - Text_IO.Put_Line (Decls.My_Int'Image (Decls.Ident (Arg))); + Put_Line (Arg'Img); end Put_Val; - end Utils; + end Utils; - with Decls; - package Declst is - Lib_Task : Decls.Lib_Task_Type; - end Declst; + :: - with Declst; - procedure Main is - begin - Declst.Lib_Task.Start; - end; - - - What we have done here is to replace the ``task`` declaration in - package ``Decls`` with a ``task type`` declaration. Then we - introduce a separate package ``Declst`` to contain the actual - task object. This separates the elaboration issues for - the ``task type`` - declaration, which causes no trouble, from the elaboration issues - of the task object, which is also unproblematic, since it is now independent - of the elaboration of ``Utils``. - This separation of concerns also corresponds to - a generally sound engineering principle of separating declarations - from instances. This version of the program also compiles, binds, links, - and executes, generating the expected output. - -.. index:: No_Entry_Calls_In_Elaboration_Code restriction - -* Use No_Entry_Calls_In_Elaboration_Code restriction. - - The previous two approaches described how a program can be restructured - to avoid the special problems caused by library task bodies. in practice, - however, such restructuring may be difficult to apply to existing legacy code, - so we must consider solutions that do not require massive rewriting. - - Let us consider more carefully why our original sample program works - under the dynamic model of elaboration. The reason is that the code - in the task body blocks immediately on the ``accept`` - statement. Now of course there is nothing to prohibit elaboration - code from making entry calls (for example from another library level task), - so we cannot tell in isolation that - the task will not execute the accept statement during elaboration. - - However, in practice it is very unusual to see elaboration code - make any entry calls, and the pattern of tasks starting - at elaboration time and then immediately blocking on ``accept`` or - ``select`` statements is very common. What this means is that - the compiler is being too pessimistic when it analyzes the - whole package body as though it might be executed at elaboration - time. - - If we know that the elaboration code contains no entry calls, (a very safe - assumption most of the time, that could almost be made the default - behavior), then we can compile all units of the program under control - of the following configuration pragma: - - .. code-block:: ada - - pragma Restrictions (No_Entry_Calls_In_Elaboration_Code); - - This pragma can be placed in the :file:`gnat.adc` file in the usual - manner. If we take our original unmodified program and compile it - in the presence of a :file:`gnat.adc` containing the above pragma, - then once again, we can compile, bind, link, and execute, obtaining - the expected result. In the presence of this pragma, the compiler does - not trace calls in a task body, that appear after the first ``accept`` - or ``select`` statement, and therefore does not report a potential - circularity in the original program. - - The compiler will check to the extent it can that the above - restriction is not violated, but it is not always possible to do a - complete check at compile time, so it is important to use this - pragma only if the stated restriction is in fact met, that is to say - no task receives an entry call before elaboration of all units is completed. + with Decls; + package Obj_Decls is -- new + Task_Obj : Decls.Lib_Task; + end Obj_Decls; + :: -.. _Mixing_Elaboration_Models: + with Obj_Decls; + procedure Main is + begin + Obj_Decls.Task_Obj.Start; -- new + end Main; -Mixing Elaboration Models -========================= +* *Use restriction No_Entry_Calls_In_Elaboration_Code* -So far, we have assumed that the entire program is either compiled -using the dynamic model or static model, ensuring consistency. It -is possible to mix the two models, but rules have to be followed -if this mixing is done to ensure that elaboration checks are not -omitted. + The issue exhibited in the original example under this section revolves + around the body of ``Lib_Task`` blocking on an accept statement. There is + no rule to prevent elaboration code from performing entry calls, however in + practice this is highly unusual. In addition, the pattern of starting tasks + at elaboration time and then immediately blocking on accept or select + statements is quite common. -The basic rule is that -**a unit compiled with the static model cannot -be |withed| by a unit compiled with the dynamic model**. -The reason for this is that in the static model, a unit assumes that -its clients guarantee to use (the equivalent of) pragma -``Elaborate_All`` so that no elaboration checks are required -in inner subprograms, and this assumption is violated if the -client is compiled with dynamic checks. + If a programmer knows that elaboration code will not perform any entry + calls, then the programmer can indicate that the static model should not + process the remainder of a task body once an accept or select statement has + been encountered. This behavior can be specified by a configuration pragma: -The precise rule is as follows. A unit that is compiled with dynamic -checks can only |with| a unit that meets at least one of the -following criteria: + :: + pragma Restrictions (No_Entry_Calls_In_Elaboration_Code); -* The |withed| unit is itself compiled with dynamic elaboration - checks (that is with the :switch:`-gnatE` switch. + In addition to the change in behavior with respect to task bodies, the + static model will verify that no entry calls take place at elaboration time. -* The |withed| unit is an internal GNAT implementation unit from - the System, Interfaces, Ada, or GNAT hierarchies. +.. _Elaboration_Related_Compiler_Switches: -* The |withed| unit has pragma Preelaborate or pragma Pure. +Elaboration-related Compiler Switches +===================================== -* The |withing| unit (that is the client) has an explicit pragma - ``Elaborate_All`` for the |withed| unit. +GNAT has several switches that affect the elaboration model and consequently +the elaboration order chosen by the binder. +.. index:: -gnatdE (gnat) -If this rule is violated, that is if a unit with dynamic elaboration -checks |withs| a unit that does not meet one of the above four -criteria, then the binder (``gnatbind``) will issue a warning -similar to that in the following example:: +:switch:`-gnatdE` + Elaboration checks on predefined units - warning: "x.ads" has dynamic elaboration checks and with's - warning: "y.ads" which has static elaboration checks + When this switch is in effect, GNAT will consider scenarios and targets that + come from the Ada, GNAT, Interfaces, and System hierarchies. This switch is + useful when a programmer has defined a custom grandchild of those packages. -These warnings indicate that the rule has been violated, and that as a result -elaboration checks may be missed in the resulting executable file. -This warning may be suppressed using the :switch:`-ws` binder switch -in the usual manner. +.. index:: -gnatd.G (gnat) -One useful application of this mixing rule is in the case of a subsystem -which does not itself |with| units from the remainder of the -application. In this case, the entire subsystem can be compiled with -dynamic checks to resolve a circularity in the subsystem, while -allowing the main application that uses this subsystem to be compiled -using the more reliable default static model. +:switch:`-gnatd.G` + Ignore calls through generic formal parameters for elaboration + When this switch is in effect, GNAT will ignore calls that invoke generic + actual entries, operators, or subprograms via generic formal subprograms. As + a result, GNAT will not generate implicit ``Elaborate`` and ``Elaborate_All`` + pragmas, and run-time checks for such calls. Note that this switch does not + overlap with :switch:`-gnatdL`. -.. _What_to_Do_If_the_Default_Elaboration_Behavior_Fails: + :: -What to Do If the Default Elaboration Behavior Fails -==================================================== + package body Ignore_Calls is + function ABE return Integer; -If the binder cannot find an acceptable order, it outputs detailed -diagnostics. For example:: + generic + with function Gen_Formal return Integer; + package Gen is + Val : constant Integer := Gen_Formal; + end Gen; - error: elaboration circularity detected - info: "proc (body)" must be elaborated before "pack (body)" - info: reason: Elaborate_All probably needed in unit "pack (body)" - info: recompile "pack (body)" with -gnatel - info: for full details - info: "proc (body)" - info: is needed by its spec: - info: "proc (spec)" - info: which is withed by: - info: "pack (body)" - info: "pack (body)" must be elaborated before "proc (body)" - info: reason: pragma Elaborate in unit "proc (body)" + package Inst is new Gen (ABE); -In this case we have a cycle that the binder cannot break. On the one -hand, there is an explicit pragma Elaborate in ``proc`` for -``pack``. This means that the body of ``pack`` must be elaborated -before the body of ``proc``. On the other hand, there is elaboration -code in ``pack`` that calls a subprogram in ``proc``. This means -that for maximum safety, there should really be a pragma -Elaborate_All in ``pack`` for ``proc`` which would require that -the body of ``proc`` be elaborated before the body of -``pack``. Clearly both requirements cannot be satisfied. -Faced with a circularity of this kind, you have three different options. + function ABE return Integer is + begin + ... + end ABE; + end Ignore_Calls; + In the example above, the call to function ``ABE`` will be ignored because it + occurs during the elaboration of instance ``Inst``, through a call to generic + formal subprogram ``Gen_Formal``. -* *Fix the program* +.. index:: -gnatdL (gnat) - The most desirable option from the point of view of long-term maintenance - is to rearrange the program so that the elaboration problems are avoided. - One useful technique is to place the elaboration code into separate - child packages. Another is to move some of the initialization code to - explicitly called subprograms, where the program controls the order - of initialization explicitly. Although this is the most desirable option, - it may be impractical and involve too much modification, especially in - the case of complex legacy code. - -* *Perform dynamic checks* - - If the compilations are done using the :switch:`-gnatE` - (dynamic elaboration check) switch, then GNAT behaves in a quite different - manner. Dynamic checks are generated for all calls that could possibly result - in raising an exception. With this switch, the compiler does not generate - implicit ``Elaborate`` or ``Elaborate_All`` pragmas. The behavior then is - exactly as specified in the :title:`Ada Reference Manual`. - The binder will generate - an executable program that may or may not raise ``Program_Error``, and then - it is the programmer's job to ensure that it does not raise an exception. Note - that it is important to compile all units with the switch, it cannot be used - selectively. - -* *Suppress checks* - - The drawback of dynamic checks is that they generate a - significant overhead at run time, both in space and time. If you - are absolutely sure that your program cannot raise any elaboration - exceptions, and you still want to use the dynamic elaboration model, - then you can use the configuration pragma - ``Suppress (Elaboration_Check)`` to suppress all such checks. For - example this pragma could be placed in the :file:`gnat.adc` file. - -* *Suppress checks selectively* - - When you know that certain calls or instantiations in elaboration code cannot - possibly lead to an elaboration error, and the binder nevertheless complains - about implicit ``Elaborate`` and ``Elaborate_All`` pragmas that lead to - elaboration circularities, it is possible to remove those warnings locally and - obtain a program that will bind. Clearly this can be unsafe, and it is the - responsibility of the programmer to make sure that the resulting program has no - elaboration anomalies. The pragma ``Suppress (Elaboration_Check)`` can be - used with different granularity to suppress warnings and break elaboration - circularities: - - * Place the pragma that names the called subprogram in the declarative part - that contains the call. - - * Place the pragma in the declarative part, without naming an entity. This - disables warnings on all calls in the corresponding declarative region. - - * Place the pragma in the package spec that declares the called subprogram, - and name the subprogram. This disables warnings on all elaboration calls to - that subprogram. - - * Place the pragma in the package spec that declares the called subprogram, - without naming any entity. This disables warnings on all elaboration calls to - all subprograms declared in this spec. - - * Use Pragma Elaborate. - - As previously described in section :ref:`Treatment_of_Pragma_Elaborate`, - GNAT in static mode assumes that a ``pragma`` Elaborate indicates correctly - that no elaboration checks are required on calls to the designated unit. - There may be cases in which the caller knows that no transitive calls - can occur, so that a ``pragma Elaborate`` will be sufficient in a - case where ``pragma Elaborate_All`` would cause a circularity. - - These five cases are listed in order of decreasing safety, and therefore - require increasing programmer care in their application. Consider the - following program: - - .. code-block:: ada - - package Pack1 is - function F1 return Integer; - X1 : Integer; - end Pack1; - - package Pack2 is - function F2 return Integer; - function Pure (x : integer) return integer; - -- pragma Suppress (Elaboration_Check, On => Pure); -- (3) - -- pragma Suppress (Elaboration_Check); -- (4) - end Pack2; - - with Pack2; - package body Pack1 is - function F1 return Integer is - begin - return 100; - end F1; - Val : integer := Pack2.Pure (11); -- Elab. call (1) +:switch:`-gnatdL` + Ignore external calls from instances for elaboration + + When this switch is in effect, GNAT will ignore calls that originate from + within an instance and directly target an entry, operator, or subprogram + defined outside the instance. As a result, GNAT will not generate implicit + ``Elaborate`` and ``Elaborate_All`` pragmas, and run-time checks for such + calls. Note that this switch does not overlap with :switch:`-gnatd.G`. + + :: + + package body Ignore_Calls is + function ABE return Integer; + + generic + package Gen is + Val : constant Integer := ABE; + end Gen; + + package Inst is new Gen; + + function ABE return Integer is begin - declare - -- pragma Suppress(Elaboration_Check, Pack2.F2); -- (1) - -- pragma Suppress(Elaboration_Check); -- (2) - begin - X1 := Pack2.F2 + 1; -- Elab. call (2) - end; - end Pack1; + ... + end ABE; + end Ignore_Calls; - with Pack1; - package body Pack2 is - function F2 return Integer is - begin - return Pack1.F1; - end F2; - function Pure (x : integer) return integer is - begin - return x ** 3 - 3 * x; - end; - end Pack2; + In the example above, the call to function ``ABE`` will be ignored because it + originates from within an instance and targets a subprogram defined outside + the instance. + +.. index:: -gnatd.o (gnat) + +:switch:`-gnatd.o` + Conservative elaboration order for indirect calls + + When this switch is in effect, GNAT will treat ``'Access`` of an entry, + operator, or subprogram as an immediate call to that target. As a result, + GNAT will generate implicit ``Elaborate`` and ``Elaborate_All`` pragmas as + well as run-time checks for such attribute references. + + :: - with Pack1, Ada.Text_IO; - procedure Proc3 is + 1. package body Attribute_Call is + 2. function Func return Integer; + 3. type Func_Ptr is access function return Integer; + 4. + 5. Ptr : constant Func_Ptr := Func'Access; + | + >>> warning: cannot call "Func" before body seen + >>> warning: Program_Error may be raised at run time + >>> warning: body of unit "Attribute_Call" elaborated + >>> warning: "Access" of "Func" taken at line 5 + >>> warning: function "Func" called at line 5 + + 6. + 7. function Func return Integer is + 8. begin + 9. ... + 10. end Func; + 11. end Attribute_Call; + + In the example above, the elaboration of declaration ``Ptr`` is assigned + ``Func'Access`` before the body of ``Func`` has been elaborated. + +.. index:: -gnatd.U (gnat) + +:switch:`-gnatd.U` + Ignore indirect calls for static elaboration + + When this switch is in effect, GNAT will ignore ``'Access`` of an entry, + operator, or subprogram when the static model is in effect. + +.. index:: -gnatd.y (gnat) + +:switch:`-gnatd.y` + Disable implicit pragma Elaborate[_All] on task bodies + + When this switch is in effect, GNAT will not generate ``Elaborate`` and + ``Elaborate_All`` pragmas if the need for the pragma came directly or + indirectly from a task body. + + :: + + with Server; + package body Disable_Task is + task T; + + task body T is begin - Ada.Text_IO.Put_Line(Pack1.X1'Img); -- 101 - end Proc3; - - In the absence of any pragmas, an attempt to bind this program produces - the following diagnostics:: - - error: elaboration circularity detected - info: "pack1 (body)" must be elaborated before "pack1 (body)" - info: reason: Elaborate_All probably needed in unit "pack1 (body)" - info: recompile "pack1 (body)" with -gnatel for full details - info: "pack1 (body)" - info: must be elaborated along with its spec: - info: "pack1 (spec)" - info: which is withed by: - info: "pack2 (body)" - info: which must be elaborated along with its spec: - info: "pack2 (spec)" - info: which is withed by: - info: "pack1 (body)" - - The sources of the circularity are the two calls to ``Pack2.Pure`` and - ``Pack2.F2`` in the body of ``Pack1``. We can see that the call to - F2 is safe, even though F2 calls F1, because the call appears after the - elaboration of the body of F1. Therefore the pragma (1) is safe, and will - remove the warning on the call. It is also possible to use pragma (2) - because there are no other potentially unsafe calls in the block. - - The call to ``Pure`` is safe because this function does not depend on the - state of ``Pack2``. Therefore any call to this function is safe, and it - is correct to place pragma (3) in the corresponding package spec. - - Finally, we could place pragma (4) in the spec of ``Pack2`` to disable - warnings on all calls to functions declared therein. Note that this is not - necessarily safe, and requires more detailed examination of the subprogram - bodies involved. In particular, a call to ``F2`` requires that ``F1`` - be already elaborated. - -It is hard to generalize on which of these four approaches should be -taken. Obviously if it is possible to fix the program so that the default -treatment works, this is preferable, but this may not always be practical. -It is certainly simple enough to use :switch:`-gnatE` -but the danger in this case is that, even if the GNAT binder -finds a correct elaboration order, it may not always do so, -and certainly a binder from another Ada compiler might not. A -combination of testing and analysis (for which the -information messages generated with the :switch:`-gnatel` -switch can be useful) must be used to ensure that the program is free -of errors. One switch that is useful in this testing is the -:switch:`-p` (pessimistic elaboration order) switch for ``gnatbind``. -Normally the binder tries to find an order that has the best chance -of avoiding elaboration problems. However, if this switch is used, the binder -plays a devil's advocate role, and tries to choose the order that -has the best chance of failing. If your program works even with this -switch, then it has a better chance of being error free, but this is still -not a guarantee. - -For an example of this approach in action, consider the C-tests (executable -tests) from the ACATS suite. If these are compiled and run with the default -treatment, then all but one of them succeed without generating any error -diagnostics from the binder. However, there is one test that fails, and -this is not surprising, because the whole point of this test is to ensure -that the compiler can handle cases where it is impossible to determine -a correct order statically, and it checks that an exception is indeed -raised at run time. - -This one test must be compiled and run using the :switch:`-gnatE` -switch, and then it passes. Alternatively, the entire suite can -be run using this switch. It is never wrong to run with the dynamic -elaboration switch if your code is correct, and we assume that the -C-tests are indeed correct (it is less efficient, but efficiency is -not a factor in running the ACATS tests.) - - -.. _Elaboration_for_Indirect_Calls: - -Elaboration for Indirect Calls -============================== + Server.Proc; + end T; + end Disable_Task; + + In the example above, the activation of single task ``T`` invokes + ``Server.Proc``, which implies that ``Server`` requires ``Elaborate_All``, + however GNAT will not generate the pragma. + +.. index:: -gnatE (gnat) + +:switch:`-gnatE` + Dynamic elaboration checking mode enabled + + When this switch is in effect, GNAT activates the dynamic elaboration model. + +.. index:: -gnatel (gnat) + +:switch:`-gnatel` + Turn on info messages on generated Elaborate[_All] pragmas + + When this switch is in effect, GNAT will emit the following supplementary + information depending on the elaboration model in effect. + + - *Dynamic model* + + GNAT will indicate missing ``Elaborate`` and ``Elaborate_All`` pragmas for + all library-level scenarios within the partition. -.. index:: Dispatching calls -.. index:: Indirect calls + - *Static model* -In rare cases, the static elaboration model fails to prevent -dispatching calls to not-yet-elaborated subprograms. In such cases, we -fall back to run-time checks; premature calls to any primitive -operation of a tagged type before the body of the operation has been -elaborated will raise ``Program_Error``. + GNAT will indicate all scenarios executed during elaboration. In addition, + it will provide detailed traceback when an implicit ``Elaborate`` or + ``Elaborate_All`` pragma is generated. -Access-to-subprogram types, however, are handled conservatively in many -cases. This was not true in earlier versions of the compiler; you can use -the :switch:`-gnatd.U` debug switch to revert to the old behavior if the new -conservative behavior causes elaboration cycles. Here, 'conservative' means -that if you do ``P'Access`` during elaboration, the compiler will normally -assume that you might call ``P`` indirectly during elaboration, so it adds an -implicit ``pragma Elaborate_All`` on the library unit containing ``P``. The -:switch:`-gnatd.U` switch is safe if you know there are no such calls. If the -program worked before, it will continue to work with :switch:`-gnatd.U`. But beware -that code modifications such as adding an indirect call can cause erroneous -behavior in the presence of :switch:`-gnatd.U`. + - *SPARK model* -These implicit Elaborate_All pragmas are not added in all cases, because -they cause elaboration cycles in certain common code patterns. If you want -even more conservative handling of P'Access, you can use the :switch:`-gnatd.o` -switch. + GNAT will indicate how an elaboration requirement is met by the context of + a unit. -See :file:`debug.adb` for documentation on the :switch:`-gnatd...` debug switches. + :: + 1. with Server; pragma Elaborate_All (Server); + 2. package Client with SPARK_Mode is + 3. Val : constant Integer := Server.Func; + | + >>> info: call to "Func" during elaboration in SPARK + >>> info: "Elaborate_All" requirement for unit "Server" met by pragma at line 1 + + 4. end Client; + +.. index:: -gnatw.f (gnat) + +:switch:`-gnatw.f` + Turn on warnings for suspicious Subp'Access + + When this switch is in effect, GNAT will treat ``'Access`` of an entry, + operator, or subprogram as a potential call to the target and issue warnings: + + :: + + 1. package body Attribute_Call is + 2. function Func return Integer; + 3. type Func_Ptr is access function return Integer; + 4. + 5. Ptr : constant Func_Ptr := Func'Access; + | + >>> warning: "Access" attribute of "Func" before body seen + >>> warning: possible Program_Error on later references + >>> warning: body of unit "Attribute_Call" elaborated + >>> warning: "Access" of "Func" taken at line 5 + + 6. + 7. function Func return Integer is + 8. begin + 9. ... + 10. end Func; + 11. end Attribute_Call; + + In the example above, the elaboration of declaration ``Ptr`` is assigned + ``Func'Access`` before the body of ``Func`` has been elaborated. .. _Summary_of_Procedures_for_Elaboration_Control: Summary of Procedures for Elaboration Control ============================================= -.. index:: Elaboration control +A programmer should first compile the program with the default options, using +none of the binder or compiler switches. If the binder succeeds in finding an +elaboration order, then apart from possible cases involing dispatching calls +and access-to-subprogram types, the program is free of elaboration errors. +If it is important for the program to be portable to compilers other than GNAT, +then the programmer should use compilation switch :switch:`-gnatel` and +consider the messages about missing or implicitly created ``Elaborate`` and +``Elaborate_All`` pragmas. -First, compile your program with the default options, using none of -the special elaboration-control switches. If the binder successfully -binds your program, then you can be confident that, apart from issues -raised by the use of access-to-subprogram types and dynamic dispatching, -the program is free of elaboration errors. If it is important that the -program be portable to other compilers than GNAT, then use the -:switch:`-gnatel` -switch to generate messages about missing ``Elaborate`` or -``Elaborate_All`` pragmas, and supply the missing pragmas. - -If the program fails to bind using the default static elaboration -handling, then you can fix the program to eliminate the binder -message, or recompile the entire program with the -:switch:`-gnatE` switch to generate dynamic elaboration checks, -and, if you are sure there really are no elaboration problems, -use a global pragma ``Suppress (Elaboration_Check)``. - - -.. _Other_Elaboration_Order_Considerations: - -Other Elaboration Order Considerations -====================================== - -This section has been entirely concerned with the issue of finding a valid -elaboration order, as defined by the Ada Reference Manual. In a case -where several elaboration orders are valid, the task is to find one -of the possible valid elaboration orders (and the static model in GNAT -will ensure that this is achieved). - -The purpose of the elaboration rules in the Ada Reference Manual is to -make sure that no entity is accessed before it has been elaborated. For -a subprogram, this means that the spec and body must have been elaborated -before the subprogram is called. For an object, this means that the object -must have been elaborated before its value is read or written. A violation -of either of these two requirements is an access before elaboration order, -and this section has been all about avoiding such errors. - -In the case where more than one order of elaboration is possible, in the -sense that access before elaboration errors are avoided, then any one of -the orders is 'correct' in the sense that it meets the requirements of -the Ada Reference Manual, and no such error occurs. - -However, it may be the case for a given program, that there are -constraints on the order of elaboration that come not from consideration -of avoiding elaboration errors, but rather from extra-lingual logic -requirements. Consider this example: - -.. code-block:: ada - - with Init_Constants; - package Constants is - X : Integer := 0; - Y : Integer := 0; - end Constants; - - package Init_Constants is - procedure P; --* require a body* - end Init_Constants; - - with Constants; - package body Init_Constants is - procedure P is begin null; end; - begin - Constants.X := 3; - Constants.Y := 4; - end Init_Constants; +If the binder reports an elaboration circularity, the programmer has several +options: - with Constants; - package Calc is - Z : Integer := Constants.X + Constants.Y; - end Calc; +* Ensure that warnings are enabled. This will allow the static model to output + trace information of elaboration issues. The trace information could shed + light on previously unforeseen dependencies, as well as their origins. - with Calc; - with Text_IO; use Text_IO; - procedure Main is - begin - Put_Line (Calc.Z'Img); - end Main; +* Use switch :switch:`-gnatel` to obtain messages on generated implicit + ``Elaborate`` and ``Elaborate_All`` pragmas. The trace information could + indicate why a server unit must be elaborated prior to a client unit. + +* If the warnings produced by the static model indicate that a task is + involved, consider the options in the section on resolving task issues as + well as compiler switch :switch:`-gnatd.y`. -In this example, there is more than one valid order of elaboration. For -example both the following are correct orders:: +* If the warnings produced by the static model indicate that an generic + instantiations are involved, consider using compiler switches + :switch:`-gnatd.G` and :switch:`-gnatdL`. - Init_Constants spec - Constants spec - Calc spec - Init_Constants body - Main body +* If none of the steps outlined above resolve the circularity, recompile the + program using the dynamic model by using compiler switch :switch:`-gnatE`. -and +.. _Inspecting_the_Chosen_Elaboration_Order: + +Inspecting the Chosen Elaboration Order +======================================= + +To see the elaboration order chosen by the binder, inspect the contents of file +`b~xxx.adb`. On certain targets, this file appears as `b_xxx.adb`. The +elaboration order appears as a sequence of calls to ``Elab_Body`` and +``Elab_Spec``, interspersed with assignments to `Exxx` which indicates that a +particular unit is elaborated. For example: :: - Init_Constants spec - Constants spec - Init_Constants body - Calc spec - Main body - -There is no language rule to prefer one or the other, both are correct -from an order of elaboration point of view. But the programmatic effects -of the two orders are very different. In the first, the elaboration routine -of ``Calc`` initializes ``Z`` to zero, and then the main program -runs with this value of zero. But in the second order, the elaboration -routine of ``Calc`` runs after the body of Init_Constants has set -``X`` and ``Y`` and thus ``Z`` is set to 7 before ``Main`` runs. - -One could perhaps by applying pretty clever non-artificial intelligence -to the situation guess that it is more likely that the second order of -elaboration is the one desired, but there is no formal linguistic reason -to prefer one over the other. In fact in this particular case, GNAT will -prefer the second order, because of the rule that bodies are elaborated -as soon as possible, but it's just luck that this is what was wanted -(if indeed the second order was preferred). - -If the program cares about the order of elaboration routines in a case like -this, it is important to specify the order required. In this particular -case, that could have been achieved by adding to the spec of Calc: - -.. code-block:: ada - - pragma Elaborate_All (Constants); - -which requires that the body (if any) and spec of ``Constants``, -as well as the body and spec of any unit |withed| by -``Constants`` be elaborated before ``Calc`` is elaborated. - -Clearly no automatic method can always guess which alternative you require, -and if you are working with legacy code that had constraints of this kind -which were not properly specified by adding ``Elaborate`` or -``Elaborate_All`` pragmas, then indeed it is possible that two different -compilers can choose different orders. - -However, GNAT does attempt to diagnose the common situation where there -are uninitialized variables in the visible part of a package spec, and the -corresponding package body has an elaboration block that directly or -indirectly initializes one or more of these variables. This is the situation -in which a pragma Elaborate_Body is usually desirable, and GNAT will generate -a warning that suggests this addition if it detects this situation. - -The ``gnatbind` :switch:`-p` switch may be useful in smoking -out problems. This switch causes bodies to be elaborated as late as possible -instead of as early as possible. In the example above, it would have forced -the choice of the first elaboration order. If you get different results -when using this switch, and particularly if one set of results is right, -and one is wrong as far as you are concerned, it shows that you have some -missing ``Elaborate`` pragmas. For the example above, we have the -following output: - -.. code-block:: sh - - $ gnatmake -f -q main - $ main - 7 - $ gnatmake -f -q main -bargs -p - $ main - 0 - -It is of course quite unlikely that both these results are correct, so -it is up to you in a case like this to investigate the source of the -difference, by looking at the two elaboration orders that are chosen, -and figuring out which is correct, and then adding the necessary -``Elaborate`` or ``Elaborate_All`` pragmas to ensure the desired order. - - -.. _Determining_the_Chosen_Elaboration_Order: - -Determining the Chosen Elaboration Order -======================================== + System.Soft_Links'Elab_Body; + E14 := True; + System.Secondary_Stack'Elab_Body; + E18 := True; + System.Exception_Table'Elab_Body; + E24 := True; + Ada.Io_Exceptions'Elab_Spec; + E67 := True; + Ada.Tags'Elab_Spec; + Ada.Streams'Elab_Spec; + E43 := True; + Interfaces.C'Elab_Spec; + E69 := True; + System.Finalization_Root'Elab_Spec; + E60 := True; + System.Os_Lib'Elab_Body; + E71 := True; + System.Finalization_Implementation'Elab_Spec; + System.Finalization_Implementation'Elab_Body; + E62 := True; + Ada.Finalization'Elab_Spec; + E58 := True; + Ada.Finalization.List_Controller'Elab_Spec; + E76 := True; + System.File_Control_Block'Elab_Spec; + E74 := True; + System.File_Io'Elab_Body; + E56 := True; + Ada.Tags'Elab_Body; + E45 := True; + Ada.Text_Io'Elab_Spec; + Ada.Text_Io'Elab_Body; + E07 := True; + +Note also binder switch :switch:`-l`, which outputs the chosen elaboration +order and provides a more readable form of the above: + +:: -To see the elaboration order that the binder chooses, you can look at -the last part of the file:`b~xxx.adb` binder output file. Here is an example:: - - System.Soft_Links'Elab_Body; - E14 := True; - System.Secondary_Stack'Elab_Body; - E18 := True; - System.Exception_Table'Elab_Body; - E24 := True; - Ada.Io_Exceptions'Elab_Spec; - E67 := True; - Ada.Tags'Elab_Spec; - Ada.Streams'Elab_Spec; - E43 := True; - Interfaces.C'Elab_Spec; - E69 := True; - System.Finalization_Root'Elab_Spec; - E60 := True; - System.Os_Lib'Elab_Body; - E71 := True; - System.Finalization_Implementation'Elab_Spec; - System.Finalization_Implementation'Elab_Body; - E62 := True; - Ada.Finalization'Elab_Spec; - E58 := True; - Ada.Finalization.List_Controller'Elab_Spec; - E76 := True; - System.File_Control_Block'Elab_Spec; - E74 := True; - System.File_Io'Elab_Body; - E56 := True; - Ada.Tags'Elab_Body; - E45 := True; - Ada.Text_Io'Elab_Spec; - Ada.Text_Io'Elab_Body; - E07 := True; - -Here Elab_Spec elaborates the spec -and Elab_Body elaborates the body. The assignments to the :samp:`E{xx}` flags -flag that the corresponding body is now elaborated. - -You can also ask the binder to generate a more -readable list of the elaboration order using the -:switch:`-l` switch when invoking the binder. Here is -an example of the output generated by this switch:: - - ada (spec) - interfaces (spec) - system (spec) - system.case_util (spec) - system.case_util (body) - system.concat_2 (spec) - system.concat_2 (body) - system.concat_3 (spec) - system.concat_3 (body) - system.htable (spec) - system.parameters (spec) - system.parameters (body) - system.crtl (spec) - interfaces.c_streams (spec) - interfaces.c_streams (body) - system.restrictions (spec) - system.restrictions (body) - system.standard_library (spec) - system.exceptions (spec) - system.exceptions (body) - system.storage_elements (spec) - system.storage_elements (body) - system.secondary_stack (spec) - system.stack_checking (spec) - system.stack_checking (body) - system.string_hash (spec) - system.string_hash (body) - system.htable (body) - system.strings (spec) - system.strings (body) - system.traceback (spec) - system.traceback (body) - system.traceback_entries (spec) - system.traceback_entries (body) - ada.exceptions (spec) - ada.exceptions.last_chance_handler (spec) - system.soft_links (spec) - system.soft_links (body) - ada.exceptions.last_chance_handler (body) - system.secondary_stack (body) - system.exception_table (spec) - system.exception_table (body) - ada.io_exceptions (spec) - ada.tags (spec) - ada.streams (spec) - interfaces.c (spec) - interfaces.c (body) - system.finalization_root (spec) - system.finalization_root (body) - system.memory (spec) - system.memory (body) - system.standard_library (body) - system.os_lib (spec) - system.os_lib (body) - system.unsigned_types (spec) - system.stream_attributes (spec) - system.stream_attributes (body) - system.finalization_implementation (spec) - system.finalization_implementation (body) - ada.finalization (spec) - ada.finalization (body) - ada.finalization.list_controller (spec) - ada.finalization.list_controller (body) - system.file_control_block (spec) - system.file_io (spec) - system.file_io (body) - system.val_uns (spec) - system.val_util (spec) - system.val_util (body) - system.val_uns (body) - system.wch_con (spec) - system.wch_con (body) - system.wch_cnv (spec) - system.wch_jis (spec) - system.wch_jis (body) - system.wch_cnv (body) - system.wch_stw (spec) - system.wch_stw (body) - ada.tags (body) - ada.exceptions (body) - ada.text_io (spec) - ada.text_io (body) - text_io (spec) - gdbstr (body) + ada (spec) + interfaces (spec) + system (spec) + system.case_util (spec) + system.case_util (body) + system.concat_2 (spec) + system.concat_2 (body) + system.concat_3 (spec) + system.concat_3 (body) + system.htable (spec) + system.parameters (spec) + system.parameters (body) + system.crtl (spec) + interfaces.c_streams (spec) + interfaces.c_streams (body) + system.restrictions (spec) + system.restrictions (body) + system.standard_library (spec) + system.exceptions (spec) + system.exceptions (body) + system.storage_elements (spec) + system.storage_elements (body) + system.secondary_stack (spec) + system.stack_checking (spec) + system.stack_checking (body) + system.string_hash (spec) + system.string_hash (body) + system.htable (body) + system.strings (spec) + system.strings (body) + system.traceback (spec) + system.traceback (body) + system.traceback_entries (spec) + system.traceback_entries (body) + ada.exceptions (spec) + ada.exceptions.last_chance_handler (spec) + system.soft_links (spec) + system.soft_links (body) + ada.exceptions.last_chance_handler (body) + system.secondary_stack (body) + system.exception_table (spec) + system.exception_table (body) + ada.io_exceptions (spec) + ada.tags (spec) + ada.streams (spec) + interfaces.c (spec) + interfaces.c (body) + system.finalization_root (spec) + system.finalization_root (body) + system.memory (spec) + system.memory (body) + system.standard_library (body) + system.os_lib (spec) + system.os_lib (body) + system.unsigned_types (spec) + system.stream_attributes (spec) + system.stream_attributes (body) + system.finalization_implementation (spec) + system.finalization_implementation (body) + ada.finalization (spec) + ada.finalization (body) + ada.finalization.list_controller (spec) + ada.finalization.list_controller (body) + system.file_control_block (spec) + system.file_io (spec) + system.file_io (body) + system.val_uns (spec) + system.val_util (spec) + system.val_util (body) + system.val_uns (body) + system.wch_con (spec) + system.wch_con (body) + system.wch_cnv (spec) + system.wch_jis (spec) + system.wch_jis (body) + system.wch_cnv (body) + system.wch_stw (spec) + system.wch_stw (body) + ada.tags (body) + ada.exceptions (body) + ada.text_io (spec) + ada.text_io (body) + text_io (spec) + gdbstr (body) diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index e947cba2088..01d64f3aff5 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -170,6 +170,7 @@ package body Einfo is -- Extra_Accessibility_Of_Result Node19 -- Non_Limited_View Node19 -- Parent_Subtype Node19 + -- Receiving_Entry Node19 -- Size_Check_Code Node19 -- Spec_Entity Node19 -- Underlying_Full_View Node19 @@ -275,6 +276,9 @@ package body Einfo is -- Validated_Object Node36 -- Class_Wide_Clone Node38 + + -- Protected_Subprogram Node39 + -- SPARK_Pragma Node40 -- Original_Protected_Subprogram Node41 @@ -449,7 +453,7 @@ package body Einfo is -- Strict_Alignment Flag145 -- Is_Abstract_Type Flag146 -- Needs_Debug_Info Flag147 - -- Suppress_Elaboration_Warnings Flag148 + -- Is_Elaboration_Checks_OK_Id Flag148 -- Is_Compilation_Unit Flag149 -- Has_Pragma_Elaborate_Body Flag150 @@ -619,7 +623,8 @@ package body Einfo is -- Has_Private_Extension Flag300 -- Ignore_SPARK_Mode_Pragmas Flag301 - -- (unused) Flag302 + -- Is_Initial_Condition_Procedure Flag302 + -- (unused) Flag303 -- (unused) Flag304 -- (unused) Flag305 @@ -2237,6 +2242,17 @@ package body Einfo is return Flag6 (Id); end Is_Dispatching_Operation; + function Is_Elaboration_Checks_OK_Id (Id : E) return B is + begin + pragma Assert + (Ekind_In (Id, E_Constant, E_Variable) + or else Is_Entry (Id) + or else Is_Generic_Unit (Id) + or else Is_Subprogram (Id) + or else Is_Task_Type (Id)); + return Flag148 (Id); + end Is_Elaboration_Checks_OK_Id; + function Is_Eliminated (Id : E) return B is begin return Flag124 (Id); @@ -2364,6 +2380,12 @@ package body Einfo is return Flag268 (Id); end Is_Independent; + function Is_Initial_Condition_Procedure (Id : E) return B is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + return Flag302 (Id); + end Is_Initial_Condition_Procedure; + function Is_Inlined (Id : E) return B is begin return Flag11 (Id); @@ -2371,7 +2393,7 @@ package body Einfo is function Is_Inlined_Always (Id : E) return B is begin - pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); return Flag1 (Id); end Is_Inlined_Always; @@ -3084,10 +3106,18 @@ package body Einfo is return Node22 (Id); end Protected_Formal; + function Protected_Subprogram (Id : E) return N is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + return Node39 (Id); + end Protected_Subprogram; + function Protection_Object (Id : E) return E is begin - pragma Assert - (Ekind_In (Id, E_Entry, E_Entry_Family, E_Function, E_Procedure)); + pragma Assert (Ekind_In (Id, E_Entry, + E_Entry_Family, + E_Function, + E_Procedure)); return Node23 (Id); end Protection_Object; @@ -3096,6 +3126,12 @@ package body Einfo is return Flag49 (Id); end Reachable; + function Receiving_Entry (Id : E) return E is + begin + pragma Assert (Ekind (Id) = E_Procedure); + return Node19 (Id); + end Receiving_Entry; + function Referenced (Id : E) return B is begin return Flag156 (Id); @@ -3306,6 +3342,9 @@ package body Einfo is E_Task_Body, E_Task_Type) or else + Ekind_In (Id, E_Constant, -- object variants + E_Variable) + or else Ekind_In (Id, E_Entry, -- overloadable variants E_Entry_Family, E_Function, @@ -3319,7 +3358,7 @@ package body Einfo is E_Package, E_Package_Body) or else - Ekind (Id) = E_Variable); -- variable + Ekind (Id) = E_Void); -- special purpose return Node40 (Id); end SPARK_Pragma; @@ -3330,7 +3369,10 @@ package body Einfo is E_Protected_Type, E_Task_Body, E_Task_Type) - or else + or else + Ekind_In (Id, E_Constant, -- object variants + E_Variable) + or else Ekind_In (Id, E_Entry, -- overloadable variants E_Entry_Family, E_Function, @@ -3344,7 +3386,7 @@ package body Einfo is E_Package, E_Package_Body) or else - Ekind (Id) = E_Variable); -- variable + Ekind (Id) = E_Void); -- special purpose return Flag265 (Id); end SPARK_Pragma_Inherited; @@ -3444,11 +3486,6 @@ package body Einfo is return Uint24 (Id); end Subps_Index; - function Suppress_Elaboration_Warnings (Id : E) return B is - begin - return Flag148 (Id); - end Suppress_Elaboration_Warnings; - function Suppress_Initialization (Id : E) return B is begin pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Variable); @@ -5397,6 +5434,17 @@ package body Einfo is Set_Flag6 (Id, V); end Set_Is_Dispatching_Operation; + procedure Set_Is_Elaboration_Checks_OK_Id (Id : E; V : B := True) is + begin + pragma Assert + (Ekind_In (Id, E_Constant, E_Variable) + or else Is_Entry (Id) + or else Is_Generic_Unit (Id) + or else Is_Subprogram (Id) + or else Is_Task_Type (Id)); + Set_Flag148 (Id, V); + end Set_Is_Elaboration_Checks_OK_Id; + procedure Set_Is_Eliminated (Id : E; V : B := True) is begin Set_Flag124 (Id, V); @@ -5526,6 +5574,12 @@ package body Einfo is Set_Flag268 (Id, V); end Set_Is_Independent; + procedure Set_Is_Initial_Condition_Procedure (Id : E; V : B := True) is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + Set_Flag302 (Id, V); + end Set_Is_Initial_Condition_Procedure; + procedure Set_Is_Inlined (Id : E; V : B := True) is begin Set_Flag11 (Id, V); @@ -5533,7 +5587,7 @@ package body Einfo is procedure Set_Is_Inlined_Always (Id : E; V : B := True) is begin - pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); Set_Flag1 (Id, V); end Set_Is_Inlined_Always; @@ -6264,6 +6318,12 @@ package body Einfo is Set_Node22 (Id, V); end Set_Protected_Formal; + procedure Set_Protected_Subprogram (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + Set_Node39 (Id, V); + end Set_Protected_Subprogram; + procedure Set_Protection_Object (Id : E; V : E) is begin pragma Assert (Ekind_In (Id, E_Entry, @@ -6278,6 +6338,12 @@ package body Einfo is Set_Flag49 (Id, V); end Set_Reachable; + procedure Set_Receiving_Entry (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Procedure); + Set_Node19 (Id, V); + end Set_Receiving_Entry; + procedure Set_Referenced (Id : E; V : B := True) is begin Set_Flag156 (Id, V); @@ -6491,7 +6557,10 @@ package body Einfo is E_Protected_Type, E_Task_Body, E_Task_Type) - or else + or else + Ekind_In (Id, E_Constant, -- object variants + E_Variable) + or else Ekind_In (Id, E_Entry, -- overloadable variants E_Entry_Family, E_Function, @@ -6505,7 +6574,7 @@ package body Einfo is E_Package, E_Package_Body) or else - Ekind (Id) = E_Variable); -- variable + Ekind (Id) = E_Void); -- special purpose Set_Node40 (Id, V); end Set_SPARK_Pragma; @@ -6516,7 +6585,10 @@ package body Einfo is E_Protected_Type, E_Task_Body, E_Task_Type) - or else + or else + Ekind_In (Id, E_Constant, -- object variants + E_Variable) + or else Ekind_In (Id, E_Entry, -- overloadable variants E_Entry_Family, E_Function, @@ -6530,7 +6602,7 @@ package body Einfo is E_Package, E_Package_Body) or else - Ekind (Id) = E_Variable); -- variable + Ekind (Id) = E_Void); -- special purpose Set_Flag265 (Id, V); end Set_SPARK_Pragma_Inherited; @@ -6639,11 +6711,6 @@ package body Einfo is Set_Uint24 (Id, V); end Set_Subps_Index; - procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True) is - begin - Set_Flag148 (Id, V); - end Set_Suppress_Elaboration_Warnings; - procedure Set_Suppress_Initialization (Id : E; V : B := True) is begin pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Variable); @@ -9562,6 +9629,7 @@ package body Einfo is W ("Is_Discriminant_Check_Function", Flag264 (Id)); W ("Is_Dispatch_Table_Entity", Flag234 (Id)); W ("Is_Dispatching_Operation", Flag6 (Id)); + W ("Is_Elaboration_Checks_OK_Id", Flag148 (Id)); W ("Is_Eliminated", Flag124 (Id)); W ("Is_Entry_Formal", Flag52 (Id)); W ("Is_Exception_Handler", Flag286 (Id)); @@ -9584,6 +9652,7 @@ package body Einfo is W ("Is_Implementation_Defined", Flag254 (Id)); W ("Is_Imported", Flag24 (Id)); W ("Is_Independent", Flag268 (Id)); + W ("Is_Initial_Condition_Procedure", Flag302 (Id)); W ("Is_Inlined", Flag11 (Id)); W ("Is_Inlined_Always", Flag1 (Id)); W ("Is_Instantiated", Flag126 (Id)); @@ -9696,7 +9765,6 @@ package body Einfo is W ("Static_Elaboration_Desired", Flag77 (Id)); W ("Stores_Attribute_Old_Prefix", Flag270 (Id)); W ("Strict_Alignment", Flag145 (Id)); - W ("Suppress_Elaboration_Warnings", Flag148 (Id)); W ("Suppress_Initialization", Flag105 (Id)); W ("Suppress_Style_Checks", Flag165 (Id)); W ("Suppress_Value_Tracking_On_Call", Flag217 (Id)); @@ -10399,6 +10467,9 @@ package body Einfo is when E_Record_Type => Write_Str ("Parent_Subtype"); + when E_Procedure => + Write_Str ("Receiving_Entry"); + when E_Constant | E_Variable => @@ -11089,6 +11160,11 @@ package body Einfo is procedure Write_Field39_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Function + | E_Procedure + => + Write_Str ("Protected_Subprogram"); + when others => Write_Str ("Field39??"); end case; @@ -11101,7 +11177,8 @@ package body Einfo is procedure Write_Field40_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Entry + when E_Constant + | E_Entry | E_Entry_Family | E_Function | E_Generic_Function @@ -11117,6 +11194,7 @@ package body Einfo is | E_Task_Body | E_Task_Type | E_Variable + | E_Void => Write_Str ("SPARK_Pragma"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 13bf62019d7..7ad4cfa88af 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2198,13 +2198,6 @@ package Einfo is -- Rep_Item chain mechanism, because a single pragma Import can apply -- to multiple subprogram entities). --- Incomplete_Actuals (Elist24) --- Defined on package entities that are instances. Indicates the actuals --- types in the instantiation that are limited views. If this list is --- not empty, the instantiation, which appears in a package declaration, --- is relocated to the corresponding package body, which must have a --- corresponding nonlimited with_clause. - -- In_Package_Body (Flag48) -- Defined in package entities. Set on the entity that denotes the -- package (the defining occurrence of the package declaration) while @@ -2218,6 +2211,13 @@ package Einfo is -- the end of the package declaration. For objects it indicates that the -- declaration of the object occurs in the private part of a package. +-- Incomplete_Actuals (Elist24) +-- Defined on package entities that are instances. Indicates the actuals +-- types in the instantiation that are limited views. If this list is +-- not empty, the instantiation, which appears in a package declaration, +-- is relocated to the corresponding package body, which must have a +-- corresponding nonlimited with_clause. + -- Initialization_Statements (Node28) -- Defined in constants and variables. For a composite object initialized -- initialized with an aggregate that has been converted to a sequence @@ -2504,13 +2504,19 @@ package Einfo is -- Is_Dynamic_Scope (synthesized) -- Applies to all Entities. Returns True if the entity is a dynamic --- scope (i.e. a block, subprogram, task_type, entry --- or extended return statement). +-- scope (i.e. a block, subprogram, task_type, entry or extended return +-- statement). + +-- Is_Elaboration_Checks_OK_Id (Flag148) +-- Defined in elaboration targets (see terminology in Sem_Elab). Set when +-- the target appears in a region which is subject to elabled elaboration +-- checks. Such targets are allowed to generate run-time conditional ABE +-- checks or guaranteed ABE failures. -- Is_Elementary_Type (synthesized) --- Applies to all entities, true for all elementary types and --- subtypes. Either Is_Composite_Type or Is_Elementary_Type (but --- not both) is true of any type. +-- Applies to all entities, true for all elementary types and subtypes. +-- Either Is_Composite_Type or Is_Elementary_Type (but not both) is true +-- of any type. -- Is_Eliminated (Flag124) -- Defined in type entities, subprogram entities, and object entities. @@ -2703,6 +2709,10 @@ package Einfo is -- and incomplete types, this flag is set in both the partial view and -- the full view. +-- Is_Initial_Condition_Procedure (Flag302) +-- Defined in functions and procedures. Set for a generated procedure +-- which verifies the assumption of pragma Initial_Condition at run time. + -- Is_Inlined (Flag11) -- Defined in all entities. Set for functions and procedures which are -- to be inlined. For subprograms created during expansion, this flag @@ -3958,6 +3968,11 @@ package Einfo is -- formal parameter in the unprotected version of the operation that -- is created during expansion. +-- Protected_Subprogram (Node39) +-- Defined in functions and procedures. Set for the pair of subprograms +-- which emulate the runtime semantics of a protected subprogram. Denotes +-- the entity of the origial protected subprogram. + -- Protection_Object (Node23) -- Applies to protected entries, entry families and subprograms. Denotes -- the entity which is used to rename the _object component of protected @@ -3967,6 +3982,11 @@ package Einfo is -- Defined in labels. The flag is set over the range of statements in -- which a goto to that label is legal. +-- Receiving_Entry (Node19) +-- Defined in procedures. Set for an internally generated procedure which +-- wraps the original statements of an accept alternative. Designates the +-- entity of the task entry being accepted. + -- Referenced (Flag156) -- Defined in all entities. Set if the entity is referenced, except for -- the case of an appearance of a simple variable that is not a renaming @@ -4038,10 +4058,10 @@ package Einfo is -- in a Relative_Deadline pragma for a task type. -- Renamed_Entity (Node18) --- Defined in exceptions, packages, subprograms, and generic units. Set --- for entities that are defined by a renaming declaration. Denotes the --- renamed entity, or transitively the ultimate renamed entity if --- there is a chain of renaming declarations. Empty if no renaming. +-- Defined in exception, generic unit, package, and subprogram entities. +-- Set when the entity is defined by a renaming declaration. Denotes the +-- renamed entity, or transitively the ultimate renamed entity if there +-- is a chain of renaming declarations. Empty if no renaming. -- Renamed_In_Spec (Flag231) -- Defined in package entities. If a package renaming occurs within @@ -4256,20 +4276,20 @@ package Einfo is -- inherited, rather than a local one. -- SPARK_Pragma (Node40) --- Present in concurrent type, entry, operator, [generic] package, --- package body, [generic] subprogram, subprogram body and variable --- entities. Points to the N_Pragma node that applies to the initial --- declaration or body. This is either set by a local SPARK_Mode pragma --- or is inherited from the context (from an outer scope for the spec --- case or from the spec for the body case). In the case where it is --- inherited the flag SPARK_Pragma_Inherited is set. Empty if no +-- Present in concurrent type, constant, entry, operator, [generic] +-- package, package body, [generic] subprogram, subprogram body and +-- variable entities. Points to the N_Pragma node that applies to the +-- initial declaration or body. This is either set by a local SPARK_Mode +-- pragma or is inherited from the context (from an outer scope for the +-- spec case or from the spec for the body case). In the case where it +-- is inherited the flag SPARK_Pragma_Inherited is set. Empty if no -- SPARK_Mode pragma is applicable. -- SPARK_Pragma_Inherited (Flag265) --- Present in concurrent type, entry, operator, [generic] package, --- package body, [generic] subprogram, subprogram body and variable --- entities. Set if the SPARK_Pragma attribute points to a pragma that is --- inherited, rather than a local one. +-- Present in concurrent type, constant, entry, operator, [generic] +-- package, package body, [generic] subprogram, subprogram body and +-- variable entities. Set if the SPARK_Pragma attribute points to a +-- pragma that is inherited, rather than a local one. -- Spec_Entity (Node19) -- Defined in package body entities. Points to corresponding package @@ -4395,17 +4415,6 @@ package Einfo is -- for the outer level subprogram, this is the starting index in the Subp -- table for the entries for this subprogram. --- Suppress_Elaboration_Warnings (Flag148) --- Defined in all entities, can be set only for subprogram entities and --- for variables. If this flag is set then Sem_Elab will not generate --- elaboration warnings for the subprogram or variable. Suppression of --- such warnings is automatic for subprograms for which elaboration --- checks are suppressed (without the need to set this flag), but the --- flag is also set for various internal entities (such as init procs) --- which are known not to generate any possible access before --- elaboration, and it is set on variables when a warning is given to --- avoid multiple elaboration warnings for the same variable. - -- Suppress_Initialization (Flag105) -- Defined in all variable, type and subtype entities. If set for a base -- type, then the generation of initialization procedures is suppressed @@ -5565,7 +5574,6 @@ package Einfo is -- Referenced (Flag156) -- Referenced_As_LHS (Flag36) -- Referenced_As_Out_Parameter (Flag227) - -- Suppress_Elaboration_Warnings (Flag148) -- Suppress_Style_Checks (Flag165) -- Suppress_Value_Tracking_On_Call (Flag217) -- Used_As_Generic_Actual (Flag222) @@ -5869,6 +5877,7 @@ package Einfo is -- Encapsulating_State (Node32) (constants only) -- Linker_Section_Pragma (Node33) -- Contract (Node34) (constants only) + -- SPARK_Pragma (Node40) (constants only) -- Has_Alignment_Clause (Flag46) -- Has_Atomic_Components (Flag86) -- Has_Biased_Representation (Flag139) @@ -5878,6 +5887,7 @@ package Einfo is -- Has_Thunks (Flag228) (constants only) -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) + -- Is_Elaboration_Checks_OK_Id (Flag148) (constants only) -- Is_Eliminated (Flag124) -- Is_Finalized_Transient (Flag252) -- Is_Ignored_Transient (Flag295) @@ -5889,6 +5899,7 @@ package Einfo is -- Is_Volatile_Full_Access (Flag285) -- Optimize_Alignment_Space (Flag241) (constants only) -- Optimize_Alignment_Time (Flag242) (constants only) + -- SPARK_Pragma_Inherited (Flag265) (constants only) -- Stores_Attribute_Old_Prefix (Flag270) (constants only) -- Treat_As_Volatile (Flag41) -- Address_Clause (synth) @@ -5953,6 +5964,7 @@ package Einfo is -- Entry_Accepted (Flag152) -- Has_Expanded_Contract (Flag240) -- Ignore_SPARK_Mode_Pragmas (Flag301) + -- Is_Elaboration_Checks_OK_Id (Flag148) -- Is_Entry_Wrapper (Flag297) -- Needs_No_Actuals (Flag22) -- Sec_Stack_Needed_For_Return (Flag167) @@ -6065,6 +6077,7 @@ package Einfo is -- Contract (Node34) -- Import_Pragma (Node35) (non-generic case only) -- Class_Wide_Clone (Node38) + -- Protected_Subprogram (Node39) (non-generic case only) -- SPARK_Pragma (Node40) -- Original_Protected_Subprogram (Node41) -- Body_Needed_For_SAL (Flag40) @@ -6090,9 +6103,11 @@ package Einfo is -- Is_DIC_Procedure (Flag132) (non-generic case only) -- Is_Discrim_SO_Function (Flag176) -- Is_Discriminant_Check_Function (Flag264) + -- Is_Elaboration_Checks_OK_Id (Flag148) -- Is_Eliminated (Flag124) -- Is_Generic_Actual_Subprogram (Flag274) (non-generic case only) -- Is_Hidden_Non_Overridden_Subpgm (Flag2) (non-generic case only) + -- Is_Initial_Condition_Procedure (Flag302) (non-generic case only) -- Is_Inlined_Always (Flag1) (non-generic case only) -- Is_Instantiated (Flag126) (generic case only) -- Is_Intrinsic_Subprogram (Flag64) @@ -6238,6 +6253,7 @@ package Einfo is -- Default_Expressions_Processed (Flag108) -- Has_Nested_Subprogram (Flag282) -- Ignore_SPARK_Mode_Pragmas (Flag301) + -- Is_Elaboration_Checks_OK_Id (Flag148) -- Is_Intrinsic_Subprogram (Flag64) -- Is_Machine_Code_Subprogram (Flag137) -- Is_Primitive (Flag218) @@ -6304,6 +6320,7 @@ package Einfo is -- Ignore_SPARK_Mode_Pragmas (Flag301) -- In_Package_Body (Flag48) -- In_Use (Flag8) + -- Is_Elaboration_Checks_OK_Id (Flag148) -- Is_Instantiated (Flag126) -- Is_Private_Descendant (Flag53) -- Is_Visible_Lib_Unit (Flag116) @@ -6362,6 +6379,7 @@ package Einfo is -- First_Entity (Node17) -- Alias (Node18) (non-generic case only) -- Renamed_Entity (Node18) (generic case only) + -- Receiving_Entry (Node19) (non-generic case only) -- Last_Entity (Node20) -- Interface_Name (Node21) -- Scope_Depth_Value (Uint22) @@ -6381,6 +6399,7 @@ package Einfo is -- Contract (Node34) -- Import_Pragma (Node35) (non-generic case only) -- Class_Wide_Clone (Node38) + -- Protected_Subprogram (Node39) (non-generic case only) -- SPARK_Pragma (Node40) -- Original_Protected_Subprogram (Node41) -- Body_Needed_For_SAL (Flag40) @@ -6403,9 +6422,11 @@ package Einfo is -- Is_Called (Flag102) (non-generic case only) -- Is_Constructor (Flag76) -- Is_DIC_Procedure (Flag132) (non-generic case only) + -- Is_Elaboration_Checks_OK_Id (Flag148) -- Is_Eliminated (Flag124) -- Is_Generic_Actual_Subprogram (Flag274) (non-generic case only) -- Is_Hidden_Non_Overridden_Subpgm (Flag2) (non-generic case only) + -- Is_Initial_Condition_Procedure (Flag302) (non-generic case only) -- Is_Inlined_Always (Flag1) (non-generic case only) -- Is_Instantiated (Flag126) (generic case only) -- Is_Interrupt_Handler (Flag89) @@ -6614,6 +6635,7 @@ package Einfo is -- Has_Master_Entity (Flag21) -- Has_Storage_Size_Clause (Flag23) (base type only) -- Ignore_SPARK_Mode_Pragmas (Flag301) + -- Is_Elaboration_Checks_OK_Id (Flag148) -- SPARK_Aux_Pragma_Inherited (Flag266) -- SPARK_Pragma_Inherited (Flag265) -- First_Component (synth) @@ -6662,6 +6684,7 @@ package Einfo is -- Has_Size_Clause (Flag29) -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) + -- Is_Elaboration_Checks_OK_Id (Flag148) -- Is_Eliminated (Flag124) -- Is_Finalized_Transient (Flag252) -- Is_Ignored_Transient (Flag295) @@ -7179,6 +7202,7 @@ package Einfo is function Is_Discriminant_Check_Function (Id : E) return B; function Is_Dispatch_Table_Entity (Id : E) return B; function Is_Dispatching_Operation (Id : E) return B; + function Is_Elaboration_Checks_OK_Id (Id : E) return B; function Is_Eliminated (Id : E) return B; function Is_Entry_Formal (Id : E) return B; function Is_Entry_Wrapper (Id : E) return B; @@ -7198,6 +7222,7 @@ package Einfo is function Is_Implementation_Defined (Id : E) return B; function Is_Imported (Id : E) return B; function Is_Independent (Id : E) return B; + function Is_Initial_Condition_Procedure (Id : E) return B; function Is_Inlined (Id : E) return B; function Is_Inlined_Always (Id : E) return B; function Is_Instantiated (Id : E) return B; @@ -7322,8 +7347,10 @@ package Einfo is function Private_View (Id : E) return N; function Protected_Body_Subprogram (Id : E) return E; function Protected_Formal (Id : E) return E; + function Protected_Subprogram (Id : E) return N; function Protection_Object (Id : E) return E; function Reachable (Id : E) return B; + function Receiving_Entry (Id : E) return E; function Referenced (Id : E) return B; function Referenced_As_LHS (Id : E) return B; function Referenced_As_Out_Parameter (Id : E) return B; @@ -7376,7 +7403,6 @@ package Einfo is function String_Literal_Low_Bound (Id : E) return N; function Subprograms_For_Type (Id : E) return L; function Subps_Index (Id : E) return U; - function Suppress_Elaboration_Warnings (Id : E) return B; function Suppress_Initialization (Id : E) return B; function Suppress_Style_Checks (Id : E) return B; function Suppress_Value_Tracking_On_Call (Id : E) return B; @@ -7868,6 +7894,7 @@ package Einfo is procedure Set_Is_Discriminant_Check_Function (Id : E; V : B := True); procedure Set_Is_Dispatch_Table_Entity (Id : E; V : B := True); procedure Set_Is_Dispatching_Operation (Id : E; V : B := True); + procedure Set_Is_Elaboration_Checks_OK_Id (Id : E; V : B := True); procedure Set_Is_Eliminated (Id : E; V : B := True); procedure Set_Is_Entry_Formal (Id : E; V : B := True); procedure Set_Is_Entry_Wrapper (Id : E; V : B := True); @@ -7891,6 +7918,7 @@ package Einfo is procedure Set_Is_Implementation_Defined (Id : E; V : B := True); procedure Set_Is_Imported (Id : E; V : B := True); procedure Set_Is_Independent (Id : E; V : B := True); + procedure Set_Is_Initial_Condition_Procedure (Id : E; V : B := True); procedure Set_Is_Inlined (Id : E; V : B := True); procedure Set_Is_Inlined_Always (Id : E; V : B := True); procedure Set_Is_Instantiated (Id : E; V : B := True); @@ -8015,8 +8043,10 @@ package Einfo is procedure Set_Private_View (Id : E; V : N); procedure Set_Protected_Body_Subprogram (Id : E; V : E); procedure Set_Protected_Formal (Id : E; V : E); + procedure Set_Protected_Subprogram (Id : E; V : N); procedure Set_Protection_Object (Id : E; V : E); procedure Set_Reachable (Id : E; V : B := True); + procedure Set_Receiving_Entry (Id : E; V : E); procedure Set_Referenced (Id : E; V : B := True); procedure Set_Referenced_As_LHS (Id : E; V : B := True); procedure Set_Referenced_As_Out_Parameter (Id : E; V : B := True); @@ -8069,7 +8099,6 @@ package Einfo is procedure Set_String_Literal_Low_Bound (Id : E; V : N); procedure Set_Subprograms_For_Type (Id : E; V : L); procedure Set_Subps_Index (Id : E; V : U); - procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True); procedure Set_Suppress_Initialization (Id : E; V : B := True); procedure Set_Suppress_Style_Checks (Id : E; V : B := True); procedure Set_Suppress_Value_Tracking_On_Call (Id : E; V : B := True); @@ -8690,6 +8719,7 @@ package Einfo is pragma Inline (Is_Discriminant_Check_Function); pragma Inline (Is_Dispatch_Table_Entity); pragma Inline (Is_Dispatching_Operation); + pragma Inline (Is_Elaboration_Checks_OK_Id); pragma Inline (Is_Elementary_Type); pragma Inline (Is_Eliminated); pragma Inline (Is_Entry); @@ -8725,6 +8755,7 @@ package Einfo is pragma Inline (Is_Incomplete_Or_Private_Type); pragma Inline (Is_Incomplete_Type); pragma Inline (Is_Independent); + pragma Inline (Is_Initial_Condition_Procedure); pragma Inline (Is_Inlined); pragma Inline (Is_Inlined_Always); pragma Inline (Is_Instantiated); @@ -8868,8 +8899,10 @@ package Einfo is pragma Inline (Private_View); pragma Inline (Protected_Body_Subprogram); pragma Inline (Protected_Formal); + pragma Inline (Protected_Subprogram); pragma Inline (Protection_Object); pragma Inline (Reachable); + pragma Inline (Receiving_Entry); pragma Inline (Referenced); pragma Inline (Referenced_As_LHS); pragma Inline (Referenced_As_Out_Parameter); @@ -8922,7 +8955,6 @@ package Einfo is pragma Inline (String_Literal_Low_Bound); pragma Inline (Subprograms_For_Type); pragma Inline (Subps_Index); - pragma Inline (Suppress_Elaboration_Warnings); pragma Inline (Suppress_Initialization); pragma Inline (Suppress_Style_Checks); pragma Inline (Suppress_Value_Tracking_On_Call); @@ -9200,6 +9232,7 @@ package Einfo is pragma Inline (Set_Is_Discriminant_Check_Function); pragma Inline (Set_Is_Dispatch_Table_Entity); pragma Inline (Set_Is_Dispatching_Operation); + pragma Inline (Set_Is_Elaboration_Checks_OK_Id); pragma Inline (Set_Is_Eliminated); pragma Inline (Set_Is_Entry_Formal); pragma Inline (Set_Is_Entry_Wrapper); @@ -9223,6 +9256,7 @@ package Einfo is pragma Inline (Set_Is_Implementation_Defined); pragma Inline (Set_Is_Imported); pragma Inline (Set_Is_Independent); + pragma Inline (Set_Is_Initial_Condition_Procedure); pragma Inline (Set_Is_Inlined); pragma Inline (Set_Is_Inlined_Always); pragma Inline (Set_Is_Instantiated); @@ -9348,8 +9382,10 @@ package Einfo is pragma Inline (Set_Private_View); pragma Inline (Set_Protected_Body_Subprogram); pragma Inline (Set_Protected_Formal); + pragma Inline (Set_Protected_Subprogram); pragma Inline (Set_Protection_Object); pragma Inline (Set_Reachable); + pragma Inline (Set_Receiving_Entry); pragma Inline (Set_Referenced); pragma Inline (Set_Referenced_As_LHS); pragma Inline (Set_Referenced_As_Out_Parameter); @@ -9402,7 +9438,6 @@ package Einfo is pragma Inline (Set_String_Literal_Low_Bound); pragma Inline (Set_Subprograms_For_Type); pragma Inline (Set_Subps_Index); - pragma Inline (Set_Suppress_Elaboration_Warnings); pragma Inline (Set_Suppress_Initialization); pragma Inline (Set_Suppress_Style_Checks); pragma Inline (Set_Suppress_Value_Tracking_On_Call); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 8cc9cfd94e3..84a07db47c1 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2721,36 +2721,30 @@ package body Exp_Ch3 is and then not Restriction_Active (No_Exception_Propagation) then declare - DF_Call : Node_Id; - DF_Id : Entity_Id; + DF_Id : Entity_Id; begin -- Create a local version of Deep_Finalize which has indication -- of partial initialization state. - DF_Id := Make_Temporary (Loc, 'F'); + DF_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Name_uFinalizer)); Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id)); - DF_Call := - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (DF_Id, Loc), - Parameter_Associations => New_List ( - Make_Identifier (Loc, Name_uInit), - New_Occurrence_Of (Standard_False, Loc))); - - -- Do not emit warnings related to the elaboration order when a - -- controlled object is declared before the body of Finalize is - -- seen. - - Set_No_Elaboration_Check (DF_Call); - Set_Exception_Handlers (Handled_Stmt_Node, New_List ( Make_Exception_Handler (Loc, Exception_Choices => New_List ( Make_Others_Choice (Loc)), Statements => New_List ( - DF_Call, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (DF_Id, Loc), + Parameter_Associations => New_List ( + Make_Identifier (Loc, Name_uInit), + New_Occurrence_Of (Standard_False, Loc))), + Make_Raise_Statement (Loc))))); end; else @@ -5814,6 +5808,7 @@ package body Exp_Ch3 is Aggr_Init : Node_Id; Comp_Init : List_Id := No_List; + Fin_Block : Node_Id; Fin_Call : Node_Id; Init_Stmts : List_Id := No_List; Obj_Init : Node_Id := Empty; @@ -5956,14 +5951,7 @@ package body Exp_Ch3 is Skip_Self => True); if Present (Fin_Call) then - - -- Do not emit warnings related to the elaboration order when a - -- controlled object is declared before the body of Finalize is - -- seen. - - Set_No_Elaboration_Check (Fin_Call); - - Append_To (Init_Stmts, + Fin_Block := Make_Block_Statement (Loc, Declarations => No_List, @@ -5978,7 +5966,14 @@ package body Exp_Ch3 is Statements => New_List ( Fin_Call, - Make_Raise_Statement (Loc))))))); + Make_Raise_Statement (Loc)))))); + + -- Signal the ABE mechanism that the block carries out + -- initialization actions. + + Set_Is_Initialization_Block (Fin_Block); + + Append_To (Init_Stmts, Fin_Block); end if; -- Otherwise finalization is not required, the initialization calls diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index beb0291536d..5ac2717fa59 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -7714,7 +7714,7 @@ package body Exp_Ch6 is Function_Call : Node_Id) is Acc_Type : constant Entity_Id := Etype (Allocator); - Loc : Source_Ptr; + Loc : constant Source_Ptr := Sloc (Function_Call); Func_Call : Node_Id := Function_Call; Ref_Func_Call : Node_Id; Function_Id : Entity_Id; @@ -7744,8 +7744,6 @@ package body Exp_Ch6 is pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call)); Set_Is_Expanded_Build_In_Place_Call (Func_Call); - Loc := Sloc (Function_Call); - if Is_Entity_Name (Name (Func_Call)) then Function_Id := Entity (Name (Func_Call)); @@ -7801,10 +7799,17 @@ package body Exp_Ch6 is Rewrite (Allocator, New_Allocator); -- Initial value of the temp is the result of the uninitialized - -- allocator + -- allocator. Unchecked_Convert is needed for T'Input where T is + -- derived from a controlled type. Temp_Init := Relocate_Node (Allocator); + if Nkind_In + (Function_Call, N_Type_Conversion, N_Unchecked_Type_Conversion) + then + Temp_Init := Unchecked_Convert_To (Acc_Type, Temp_Init); + end if; + -- Indicate that caller allocates, and pass in the return object Alloc_Form := Caller_Allocation; @@ -7869,6 +7874,15 @@ package body Exp_Ch6 is Rewrite (Ref_Func_Call, OK_Convert_To (Acc_Type, Ref_Func_Call)); + + -- If the types are incompatible, we need an unchecked conversion. Note + -- that the full types will be compatible, but the types not visibly + -- compatible. + + elsif Nkind_In + (Function_Call, N_Type_Conversion, N_Unchecked_Type_Conversion) + then + Ref_Func_Call := Unchecked_Convert_To (Acc_Type, Ref_Func_Call); end if; declare @@ -7880,7 +7894,8 @@ package body Exp_Ch6 is -- caller-allocates case, this is overwriting the temp with its -- initial value, which has no effect. In the callee-allocates case, -- this is setting the temp to point to the object allocated by the - -- callee. + -- callee. Unchecked_Convert is needed for T'Input where T is derived + -- from a controlled type. Actions : List_Id; -- Actions to be inserted. If there are no tasks, this is just the @@ -7940,7 +7955,7 @@ package body Exp_Ch6 is procedure Make_Build_In_Place_Call_In_Anonymous_Context (Function_Call : Node_Id) is - Loc : Source_Ptr; + Loc : constant Source_Ptr := Sloc (Function_Call); Func_Call : constant Node_Id := Unqual_Conv (Function_Call); Function_Id : Entity_Id; Result_Subt : Entity_Id; @@ -7962,8 +7977,6 @@ package body Exp_Ch6 is Set_Is_Expanded_Build_In_Place_Call (Func_Call); - Loc := Sloc (Function_Call); - if Is_Entity_Name (Name (Func_Call)) then Function_Id := Entity (Name (Func_Call)); @@ -8535,7 +8548,10 @@ package body Exp_Ch6 is New_Occurrence_Of (Designated_Type, Obj_Loc), Name => Call_Deref)); - Set_Renamed_Object (Obj_Def_Id, Call_Deref); + -- At this point, Defining_Identifier (Obj_Decl) is no longer equal + -- to Obj_Def_Id. + + Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref); -- If the original entity comes from source, then mark the new -- entity as needing debug information, even though it's defined @@ -8544,7 +8560,7 @@ package body Exp_Ch6 is -- Debug_Renaming_Declaration is called during analysis. if Comes_From_Source (Obj_Def_Id) then - Set_Debug_Info_Needed (Obj_Def_Id); + Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl)); end if; Analyze (Obj_Decl); diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index f5fa9a50d37..713ba58b72b 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -2605,8 +2605,8 @@ package body Exp_Ch7 is -- procedures of types Init_Typ or Obj_Typ. function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id; - -- Given a statement which is part of a list, return the next - -- statement while skipping over dynamic elab checks. + -- Obtain the next statement which follows list member Stmt while + -- ignoring artifacts related to access-before-elaboration checks. ----------------------------- -- Find_Last_Init_In_Block -- @@ -2725,16 +2725,22 @@ package body Exp_Ch7 is ----------------------------- function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is - Result : Node_Id := Next (Stmt); + Result : Node_Id; begin - -- Skip over access-before-elaboration checks + -- Skip call markers and Program_Error raises installed by the + -- ABE mechanism. + + Result := Next (Stmt); + while Present (Result) loop + if not Nkind_In (Result, N_Call_Marker, + N_Raise_Program_Error) + then + exit; + end if; - if Dynamic_Elaboration_Checks - and then Nkind (Result) = N_Raise_Program_Error - then Result := Next (Result); - end if; + end loop; return Result; end Next_Suitable_Statement; @@ -4463,7 +4469,7 @@ package body Exp_Ch7 is -- This is done only for non-generic packages if Ekind (Spec_Id) = E_Package then - Push_Scope (Corresponding_Spec (N)); + Push_Scope (Spec_Id); -- Build dispatch tables of library level tagged types @@ -4475,18 +4481,15 @@ package body Exp_Ch7 is Build_Task_Activation_Call (N); - -- When the package is subject to pragma Initial_Condition, the - -- assertion expression must be verified at the end of the body - -- statements. + -- Verify the run-time semantics of pragma Initial_Condition at the + -- end of the body statements. - if Present (Get_Pragma (Spec_Id, Pragma_Initial_Condition)) then - Expand_Pragma_Initial_Condition (N); - end if; + Expand_Pragma_Initial_Condition (Spec_Id, N); Pop_Scope; end if; - Set_Elaboration_Flag (N, Corresponding_Spec (N)); + Set_Elaboration_Flag (N, Spec_Id); Set_In_Package_Body (Spec_Id, False); -- Set to encode entity names in package body before gigi is called @@ -4601,14 +4604,10 @@ package body Exp_Ch7 is Build_Task_Activation_Call (N); end if; - -- When the package is subject to pragma Initial_Condition and lacks - -- a body, the assertion expression must be verified at the end of - -- the visible declarations. Otherwise the check is performed at the - -- end of the body statements (see Expand_N_Package_Body). + -- Verify the run-time semantics of pragma Initial_Condition at the + -- end of the private declarations when the package lacks a body. - if Present (Get_Pragma (Id, Pragma_Initial_Condition)) then - Expand_Pragma_Initial_Condition (N); - end if; + Expand_Pragma_Initial_Condition (Id, N); Pop_Scope; end if; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 37399adf98b..17687c05c56 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -52,7 +52,6 @@ with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Ch9; use Sem_Ch9; with Sem_Ch11; use Sem_Ch11; -with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; @@ -3841,6 +3840,12 @@ package body Exp_Ch9 is Set_Original_Protected_Subprogram (New_Id, Def_Id); end if; + -- Link the protected or unprotected version to the original subprogram + -- it emulates. + + Set_Ekind (New_Id, Ekind (Def_Id)); + Set_Protected_Subprogram (New_Id, Def_Id); + -- The unprotected operation carries the user code, and debugging -- information must be generated for it, even though this spec does -- not come from source. It is also convenient to allow gdb to step @@ -4751,11 +4756,39 @@ package body Exp_Ch9 is -------------------------------- procedure Build_Task_Activation_Call (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); + function Activation_Call_Loc return Source_Ptr; + -- Find a suitable source location for the activation call + + ------------------------- + -- Activation_Call_Loc -- + ------------------------- + + function Activation_Call_Loc return Source_Ptr is + begin + -- The activation call must carry the location of the "end" keyword + -- when the context is a package declaration. + + if Nkind (N) = N_Package_Declaration then + return End_Keyword_Location (N); + + -- Otherwise the activation call must carry the location of the + -- "begin" keyword. + + else + return Begin_Keyword_Location (N); + end if; + end Activation_Call_Loc; + + -- Local variables + Chain : Entity_Id; Call : Node_Id; + Loc : Source_Ptr; Name : Node_Id; - P : Node_Id; + Owner : Node_Id; + Stmt : Node_Id; + + -- Start of processing for Build_Task_Activation_Call begin -- For sequential elaboration policy, all the tasks will be activated at @@ -4763,105 +4796,107 @@ package body Exp_Ch9 is if Partition_Elaboration_Policy = 'S' then return; - end if; - -- Get the activation chain entity. Except in the case of a package - -- body, this is in the node that was passed. For a package body, we - -- have to find the corresponding package declaration node. + -- Do not create an activation call for a package spec if the package + -- has a completing body. The activation call will be inserted after + -- the "begin" of the body. - if Nkind (N) = N_Package_Body then - P := Corresponding_Spec (N); - loop - P := Parent (P); - exit when Nkind (P) = N_Package_Declaration; - end loop; + elsif Nkind (N) = N_Package_Declaration + and then Present (Corresponding_Body (N)) + then + return; + end if; - Chain := Activation_Chain_Entity (P); + -- Obtain the activation chain entity. Block statements, entry bodies, + -- subprogram bodies, and task bodies keep the entity in their nodes. + -- Package bodies on the other hand store it in the declaration of the + -- corresponding package spec. - else - Chain := Activation_Chain_Entity (N); + Owner := N; + + if Nkind (Owner) = N_Package_Body then + Owner := Unit_Declaration_Node (Corresponding_Spec (Owner)); end if; - if Present (Chain) then - if Restricted_Profile then - Name := New_Occurrence_Of - (RTE (RE_Activate_Restricted_Tasks), Loc); - else - Name := New_Occurrence_Of - (RTE (RE_Activate_Tasks), Loc); - end if; + Chain := Activation_Chain_Entity (Owner); - Call := - Make_Procedure_Call_Statement (Loc, - Name => Name, - Parameter_Associations => - New_List (Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Chain, Loc), - Attribute_Name => Name_Unchecked_Access))); + -- Nothing to do when there are no tasks to activate. This is indicated + -- by a missing activation chain entity. - if Nkind (N) = N_Package_Declaration then - if Present (Corresponding_Body (N)) then - null; + if No (Chain) then + return; + end if; - elsif Present (Private_Declarations (Specification (N))) then - Append (Call, Private_Declarations (Specification (N))); + -- The location of the activation call must be as close as possible to + -- the intended semantic location of the activation because the ABE + -- mechanism relies heavily on accurate locations. - else - Append (Call, Visible_Declarations (Specification (N))); - end if; + Loc := Activation_Call_Loc; - else - if Present (Handled_Statement_Sequence (N)) then + if Restricted_Profile then + Name := New_Occurrence_Of (RTE (RE_Activate_Restricted_Tasks), Loc); + else + Name := New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc); + end if; - -- The call goes at the start of the statement sequence after - -- the start of exception range label if one is present. + Call := + Make_Procedure_Call_Statement (Loc, + Name => Name, + Parameter_Associations => + New_List (Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Chain, Loc), + Attribute_Name => Name_Unchecked_Access))); - declare - Stm : Node_Id; + if Nkind (N) = N_Package_Declaration then + if Present (Private_Declarations (Specification (N))) then + Append (Call, Private_Declarations (Specification (N))); + else + Append (Call, Visible_Declarations (Specification (N))); + end if; - begin - Stm := First (Statements (Handled_Statement_Sequence (N))); + else + -- The call goes at the start of the statement sequence after the + -- start of exception range label if one is present. - -- A special case, skip exception range label if one is - -- present (from front end zcx processing). + if Present (Handled_Statement_Sequence (N)) then + Stmt := First (Statements (Handled_Statement_Sequence (N))); - if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then - Next (Stm); - end if; + -- A special case, skip exception range label if one is present + -- (from front end zcx processing). - -- Another special case, if the first statement is a block - -- from optimization of a local raise to a goto, then the - -- call goes inside this block. + if Nkind (Stmt) = N_Label and then Exception_Junk (Stmt) then + Next (Stmt); + end if; - if Nkind (Stm) = N_Block_Statement - and then Exception_Junk (Stm) - then - Stm := - First (Statements (Handled_Statement_Sequence (Stm))); - end if; + -- Another special case, if the first statement is a block from + -- optimization of a local raise to a goto, then the call goes + -- inside this block. - -- Insertion point is after any exception label pushes, - -- since we want it covered by any local handlers. + if Nkind (Stmt) = N_Block_Statement + and then Exception_Junk (Stmt) + then + Stmt := First (Statements (Handled_Statement_Sequence (Stmt))); + end if; - while Nkind (Stm) in N_Push_xxx_Label loop - Next (Stm); - end loop; + -- Insertion point is after any exception label pushes, since we + -- want it covered by any local handlers. - -- Now we have the proper insertion point + while Nkind (Stmt) in N_Push_xxx_Label loop + Next (Stmt); + end loop; - Insert_Before (Stm, Call); - end; + -- Now we have the proper insertion point - else - Set_Handled_Statement_Sequence (N, - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Call))); - end if; - end if; + Insert_Before (Stmt, Call); - Analyze (Call); - Check_Task_Activation (N); + else + Set_Handled_Statement_Sequence (N, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Call))); + end if; end if; + + Analyze (Call); end Build_Task_Activation_Call; ------------------------------- @@ -10527,6 +10562,11 @@ package body Exp_Ch9 is Make_Defining_Identifier (Eloc, New_External_Name (Chars (Ename), 'A', Num_Accept)); + -- Link the acceptor to the original receiving entry + + Set_Ekind (PB_Ent, E_Procedure); + Set_Receiving_Entry (PB_Ent, Eent); + if Comes_From_Source (Alt) then Set_Debug_Info_Needed (PB_Ent); end if; diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 57f60cd90eb..dfed6af66a7 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -42,6 +42,7 @@ with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; with Sem_Ch8; use Sem_Ch8; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; @@ -1447,82 +1448,287 @@ package body Exp_Prag is -- Expand_Pragma_Initial_Condition -- ------------------------------------- - procedure Expand_Pragma_Initial_Condition (Spec_Or_Body : Node_Id) is - Loc : constant Source_Ptr := Sloc (Spec_Or_Body); + procedure Expand_Pragma_Initial_Condition + (Pack_Id : Entity_Id; + N : Node_Id) + is + procedure Extract_Package_Body_Lists + (Pack_Body : Node_Id; + Body_List : out List_Id; + Call_List : out List_Id; + Spec_List : out List_Id); + -- Obtain the various declarative and statement lists of package body + -- Pack_Body needed to insert the initial condition procedure and the + -- call to it. The lists are as follows: + -- + -- * Body_List - used to insert the initial condition procedure body + -- + -- * Call_List - used to insert the call to the initial condition + -- procedure. + -- + -- * Spec_List - used to insert the initial condition procedure spec + + procedure Extract_Package_Declaration_Lists + (Pack_Decl : Node_Id; + Body_List : out List_Id; + Call_List : out List_Id; + Spec_List : out List_Id); + -- Obtain the various declarative lists of package declaration Pack_Decl + -- needed to insert the initial condition procedure and the call to it. + -- The lists are as follows: + -- + -- * Body_List - used to insert the initial condition procedure body + -- + -- * Call_List - used to insert the call to the initial condition + -- procedure. + -- + -- * Spec_List - used to insert the initial condition procedure spec + + -------------------------------- + -- Extract_Package_Body_Lists -- + -------------------------------- + + procedure Extract_Package_Body_Lists + (Pack_Body : Node_Id; + Body_List : out List_Id; + Call_List : out List_Id; + Spec_List : out List_Id) + is + Pack_Spec : constant Entity_Id := Corresponding_Spec (Pack_Body); - Check : Node_Id; - Expr : Node_Id; - Init_Cond : Node_Id; - List : List_Id; - Pack_Id : Entity_Id; + Dummy_1 : List_Id; + Dummy_2 : List_Id; + HSS : Node_Id; - begin - if Nkind (Spec_Or_Body) = N_Package_Body then - Pack_Id := Corresponding_Spec (Spec_Or_Body); + begin + pragma Assert (Present (Pack_Spec)); - if Present (Handled_Statement_Sequence (Spec_Or_Body)) then - List := Statements (Handled_Statement_Sequence (Spec_Or_Body)); + -- The different parts of the invariant procedure are inserted as + -- follows: - -- The package body lacks statements, create an empty list + -- package Pack is package body Pack is + -- <IC spec> <IC body> + -- private begin + -- ... <IC call> + -- end Pack; end Pack; - else - List := New_List; + -- The initial condition procedure spec is inserted in the visible + -- declaration of the corresponding package spec. + + Extract_Package_Declaration_Lists + (Pack_Decl => Unit_Declaration_Node (Pack_Spec), + Body_List => Dummy_1, + Call_List => Dummy_2, + Spec_List => Spec_List); + + -- The initial condition procedure body is added to the declarations + -- of the package body. + + Body_List := Declarations (Pack_Body); - Set_Handled_Statement_Sequence (Spec_Or_Body, - Make_Handled_Sequence_Of_Statements (Loc, Statements => List)); + if No (Body_List) then + Body_List := New_List; + Set_Declarations (Pack_Body, Body_List); end if; - elsif Nkind (Spec_Or_Body) = N_Package_Declaration then - Pack_Id := Defining_Entity (Spec_Or_Body); + -- The call to the initial condition procedure is inserted in the + -- statements of the package body. - if Present (Visible_Declarations (Specification (Spec_Or_Body))) then - List := Visible_Declarations (Specification (Spec_Or_Body)); + HSS := Handled_Statement_Sequence (Pack_Body); - -- The package lacks visible declarations, create an empty list + if No (HSS) then + HSS := + Make_Handled_Sequence_Of_Statements (Sloc (Pack_Body), + Statements => New_List); + Set_Handled_Statement_Sequence (Pack_Body, HSS); + end if; - else - List := New_List; + Call_List := Statements (HSS); + end Extract_Package_Body_Lists; + + --------------------------------------- + -- Extract_Package_Declaration_Lists -- + --------------------------------------- + + procedure Extract_Package_Declaration_Lists + (Pack_Decl : Node_Id; + Body_List : out List_Id; + Call_List : out List_Id; + Spec_List : out List_Id) + is + Pack_Spec : constant Node_Id := Specification (Pack_Decl); + + begin + -- The different parts of the invariant procedure are inserted as + -- follows: - Set_Visible_Declarations (Specification (Spec_Or_Body), List); + -- package Pack is + -- <IC spec> + -- <IC body> + -- private + -- <IC call> + -- end Pack; + + -- The initial condition procedure spec and body are inserted in the + -- visible declarations of the package spec. + + Body_List := Visible_Declarations (Pack_Spec); + + if No (Body_List) then + Body_List := New_List; + Set_Visible_Declarations (Pack_Spec, Body_List); + end if; + + Spec_List := Body_List; + + -- The call to the initial procedure is inserted in the private + -- declarations of the package spec. + + Call_List := Private_Declarations (Pack_Spec); + + if No (Call_List) then + Call_List := New_List; + Set_Private_Declarations (Pack_Spec, Call_List); end if; + end Extract_Package_Declaration_Lists; + + -- Local variables + + IC_Prag : constant Node_Id := + Get_Pragma (Pack_Id, Pragma_Initial_Condition); + + Body_List : List_Id; + Call : Node_Id; + Call_List : List_Id; + Call_Loc : Source_Ptr; + Expr : Node_Id; + Loc : Source_Ptr; + Proc_Body : Node_Id; + Proc_Body_Id : Entity_Id; + Proc_Decl : Node_Id; + Proc_Id : Entity_Id; + Spec_List : List_Id; + + -- Start of processing for Expand_Pragma_Initial_Condition + + begin + -- Nothing to do when the package is not subject to an Initial_Condition + -- pragma. + + if No (IC_Prag) then + return; + end if; + + Expr := Get_Pragma_Arg (First (Pragma_Argument_Associations (IC_Prag))); + Loc := Sloc (IC_Prag); + + -- Nothing to do when the pragma or its argument are illegal because + -- there is no valid expression to check. + + if Error_Posted (IC_Prag) or else Error_Posted (Expr) then + return; + end if; + + -- Obtain the various lists of the context where the individual pieces + -- of the initial condition procedure are to be inserted. + + if Nkind (N) = N_Package_Body then + Extract_Package_Body_Lists + (Pack_Body => N, + Body_List => Body_List, + Call_List => Call_List, + Spec_List => Spec_List); + + elsif Nkind (N) = N_Package_Declaration then + Extract_Package_Declaration_Lists + (Pack_Decl => N, + Body_List => Body_List, + Call_List => Call_List, + Spec_List => Spec_List); -- This routine should not be used on anything other than packages else - raise Program_Error; + pragma Assert (False); + return; end if; - Init_Cond := Get_Pragma (Pack_Id, Pragma_Initial_Condition); + Proc_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Pack_Id), "Initial_Condition")); - -- The caller should check whether the package is subject to pragma - -- Initial_Condition. + Set_Ekind (Proc_Id, E_Procedure); + Set_Is_Initial_Condition_Procedure (Proc_Id); - pragma Assert (Present (Init_Cond)); + -- Generate: + -- procedure <Pack_Id>Initial_Condition; - Expr := - Get_Pragma_Arg (First (Pragma_Argument_Associations (Init_Cond))); + Proc_Decl := + Make_Subprogram_Declaration (Loc, + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Id)); - -- The assertion expression was found to be illegal, do not generate the - -- runtime check as it will repeat the illegality. + Append_To (Spec_List, Proc_Decl); - if Error_Posted (Init_Cond) or else Error_Posted (Expr) then - return; + -- The initial condition procedure requires debug info when initial + -- condition is subject to Source Coverage Obligations. + + if Generate_SCO then + Set_Needs_Debug_Info (Proc_Id); end if; -- Generate: - -- pragma Check (Initial_Condition, <Expr>); + -- procedure <Pack_Id>Initial_Condition is + -- begin + -- pragma Check (Initial_Condition, <Expr>); + -- end <Pack_Id>Initial_Condition; + + Proc_Body := + Make_Subprogram_Body (Loc, + Specification => + Copy_Subprogram_Spec (Specification (Proc_Decl)), + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Pragma (Loc, + Chars => Name_Check, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Identifier (Loc, Name_Initial_Condition)), + Make_Pragma_Argument_Association (Loc, + Expression => New_Copy_Tree (Expr))))))); - Check := - Make_Pragma (Loc, - Chars => Name_Check, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_Initial_Condition)), - Make_Pragma_Argument_Association (Loc, - Expression => New_Copy_Tree (Expr)))); + Append_To (Body_List, Proc_Body); + + -- The initial condition procedure requires debug info when initial + -- condition is subject to Source Coverage Obligations. + + Proc_Body_Id := Defining_Entity (Proc_Body); + + if Generate_SCO then + Set_Needs_Debug_Info (Proc_Body_Id); + end if; + + -- The location of the initial condition procedure call must be as close + -- as possible to the intended semantic location of the check because + -- the ABE mechanism relies heavily on accurate locations. + + Call_Loc := End_Keyword_Location (N); + + -- Generate: + -- <Pack_Id>Initial_Condition; + + Call := + Make_Procedure_Call_Statement (Call_Loc, + Name => New_Occurrence_Of (Proc_Id, Call_Loc)); + + Append_To (Call_List, Call); - Append_To (List, Check); - Analyze (Check); + Analyze (Proc_Decl); + Analyze (Proc_Body); + Analyze (Call); end Expand_Pragma_Initial_Condition; ------------------------------------ diff --git a/gcc/ada/exp_prag.ads b/gcc/ada/exp_prag.ads index 48d1c2f6b54..9e5f042c181 100644 --- a/gcc/ada/exp_prag.ads +++ b/gcc/ada/exp_prag.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -42,15 +42,11 @@ package Exp_Prag is -- Subp_Id's body. All generated code is added to list Stmts. If Stmts is -- No_List on entry, a new list is created. - procedure Expand_Pragma_Initial_Condition (Spec_Or_Body : Node_Id); - -- Generate a runtime check needed to verify the assumption of introduced - -- by pragma Initial_Condition. Spec_Or_Body denotes the spec or body of - -- the package where the pragma appears. The check is inserted according - -- to the following precedence rules: - -- 1) If the package has a body with a statement sequence, the check is - -- inserted at the end of the statments. - -- 2) If the package has a body, the check is inserted at the end of the - -- body declarations. - -- 3) The check is inserted at the end of the visible declarations. + procedure Expand_Pragma_Initial_Condition + (Pack_Id : Entity_Id; + N : Node_Id); + -- Verify the run-time semantics of pragma Initial_Condition when it + -- applies to package Pack_Id. N denotes the related package spec or + -- body. end Exp_Prag; diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index 811033e9d5b..9383c1c65e6 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -61,13 +61,16 @@ package body Exp_SPARK is procedure Expand_SPARK_Indexed_Component (N : Node_Id); -- Insert explicit dereference if required + procedure Expand_SPARK_N_Loop_Statement (N : Node_Id); + -- Perform loop statement-specific expansion + procedure Expand_SPARK_N_Object_Declaration (N : Node_Id); -- Perform object-declaration-specific expansion procedure Expand_SPARK_N_Object_Renaming_Declaration (N : Node_Id); -- Perform name evaluation for a renamed object - procedure Expand_SPARK_Op_Ne (N : Node_Id); + procedure Expand_SPARK_N_Op_Ne (N : Node_Id); -- Rewrite operator /= based on operator = when defined explicitly procedure Expand_SPARK_Selected_Component (N : Node_Id); @@ -118,17 +121,7 @@ package body Exp_SPARK is -- dealt with specially in GNATprove. when N_Loop_Statement => - declare - Scheme : constant Node_Id := Iteration_Scheme (N); - begin - if Present (Scheme) - and then Present (Iterator_Specification (Scheme)) - and then - Is_Iterator_Over_Array (Iterator_Specification (Scheme)) - then - Expand_Iterator_Loop_Over_Array (N); - end if; - end; + Expand_SPARK_N_Loop_Statement (N); when N_Object_Declaration => Expand_SPARK_N_Object_Declaration (N); @@ -137,7 +130,7 @@ package body Exp_SPARK is Expand_SPARK_N_Object_Renaming_Declaration (N); when N_Op_Ne => - Expand_SPARK_Op_Ne (N); + Expand_SPARK_N_Op_Ne (N); when N_Freeze_Entity => if Is_Type (Entity (N)) then @@ -157,6 +150,21 @@ package body Exp_SPARK is end case; end Expand_SPARK; + ------------------------------ + -- Expand_SPARK_Freeze_Type -- + ------------------------------ + + procedure Expand_SPARK_Freeze_Type (E : Entity_Id) is + begin + -- When a DIC is inherited by a tagged type, it may need to be + -- specialized to the descendant type, hence build a separate DIC + -- procedure for it as done during regular expansion for compilation. + + if Has_DIC (E) and then Is_Tagged_Type (E) then + Build_DIC_Procedure_Body (E, For_Freeze => True); + end if; + end Expand_SPARK_Freeze_Type; + ---------------------------------------- -- Expand_SPARK_N_Attribute_Reference -- ---------------------------------------- @@ -261,20 +269,28 @@ package body Exp_SPARK is end if; end Expand_SPARK_N_Attribute_Reference; - ------------------------------ - -- Expand_SPARK_Freeze_Type -- - ------------------------------ + ----------------------------------- + -- Expand_SPARK_N_Loop_Statement -- + ----------------------------------- - procedure Expand_SPARK_Freeze_Type (E : Entity_Id) is - begin - -- When a DIC is inherited by a tagged type, it may need to be - -- specialized to the descendant type, hence build a separate DIC - -- procedure for it as done during regular expansion for compilation. + procedure Expand_SPARK_N_Loop_Statement (N : Node_Id) is + Scheme : constant Node_Id := Iteration_Scheme (N); - if Has_DIC (E) and then Is_Tagged_Type (E) then - Build_DIC_Procedure_Body (E, For_Freeze => True); + begin + -- Loop iterations over arrays need to be expanded, to avoid getting + -- two names referring to the same object in memory (the array and the + -- iterator) in GNATprove, especially since both can be written (thus + -- possibly leading to interferences due to aliasing). No such problem + -- arises with quantified expressions over arrays, which are dealt with + -- specially in GNATprove. + + if Present (Scheme) + and then Present (Iterator_Specification (Scheme)) + and then Is_Iterator_Over_Array (Iterator_Specification (Scheme)) + then + Expand_Iterator_Loop_Over_Array (N); end if; - end Expand_SPARK_Freeze_Type; + end Expand_SPARK_N_Loop_Statement; ------------------------------------ -- Expand_SPARK_Indexed_Component -- @@ -295,9 +311,11 @@ package body Exp_SPARK is --------------------------------------- procedure Expand_SPARK_N_Object_Declaration (N : Node_Id) is - Def_Id : constant Entity_Id := Defining_Identifier (N); Loc : constant Source_Ptr := Sloc (N); - Typ : constant Entity_Id := Etype (Def_Id); + Obj_Id : constant Entity_Id := Defining_Identifier (N); + Typ : constant Entity_Id := Etype (Obj_Id); + + Call : Node_Id; begin -- If the object declaration denotes a variable without initialization @@ -305,12 +323,19 @@ package body Exp_SPARK is -- and analyze a dummy call to the DIC procedure of the type in order -- to detect potential elaboration issues. - if Comes_From_Source (Def_Id) + if Comes_From_Source (Obj_Id) + and then Ekind (Obj_Id) = E_Variable and then Has_DIC (Typ) and then Present (DIC_Procedure (Typ)) and then not Has_Init_Expression (N) then - Analyze (Build_DIC_Call (Loc, Def_Id, Typ)); + Call := Build_DIC_Call (Loc, Obj_Id, Typ); + + -- Partially insert the call into the tree by setting its parent + -- pointer. + + Set_Parent (Call, N); + Analyze (Call); end if; end Expand_SPARK_N_Object_Declaration; @@ -370,11 +395,11 @@ package body Exp_SPARK is end if; end Expand_SPARK_N_Object_Renaming_Declaration; - ------------------------ - -- Expand_SPARK_Op_Ne -- - ------------------------ + -------------------------- + -- Expand_SPARK_N_Op_Ne -- + -------------------------- - procedure Expand_SPARK_Op_Ne (N : Node_Id) is + procedure Expand_SPARK_N_Op_Ne (N : Node_Id) is Typ : constant Entity_Id := Etype (Left_Opnd (N)); begin @@ -388,7 +413,7 @@ package body Exp_SPARK is else Exp_Ch4.Expand_N_Op_Ne (N); end if; - end Expand_SPARK_Op_Ne; + end Expand_SPARK_N_Op_Ne; ------------------------------------- -- Expand_SPARK_Potential_Renaming -- diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 1d64a3add34..def22631384 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -52,6 +52,7 @@ with Sem_Ch8; use Sem_Ch8; with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; with Sem_Disp; use Sem_Disp; +with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; @@ -1763,9 +1764,12 @@ package body Exp_Util is -- Perform minor decoration in case the body is not analyzed - Set_Ekind (Proc_Body_Id, E_Subprogram_Body); - Set_Etype (Proc_Body_Id, Standard_Void_Type); - Set_Scope (Proc_Body_Id, Current_Scope); + Set_Ekind (Proc_Body_Id, E_Subprogram_Body); + Set_Etype (Proc_Body_Id, Standard_Void_Type); + Set_Scope (Proc_Body_Id, Current_Scope); + Set_SPARK_Pragma (Proc_Body_Id, SPARK_Pragma (Proc_Id)); + Set_SPARK_Pragma_Inherited + (Proc_Body_Id, SPARK_Pragma_Inherited (Proc_Id)); -- Link both spec and body to avoid generating duplicates @@ -1905,17 +1909,19 @@ package body Exp_Util is -- Perform minor decoration in case the declaration is not analyzed - Set_Ekind (Proc_Id, E_Procedure); - Set_Etype (Proc_Id, Standard_Void_Type); - Set_Scope (Proc_Id, Current_Scope); + Set_Ekind (Proc_Id, E_Procedure); + Set_Etype (Proc_Id, Standard_Void_Type); + Set_Is_DIC_Procedure (Proc_Id); + Set_Scope (Proc_Id, Current_Scope); + Set_SPARK_Pragma (Proc_Id, SPARK_Mode_Pragma); + Set_SPARK_Pragma_Inherited (Proc_Id); - Set_Is_DIC_Procedure (Proc_Id); Set_DIC_Procedure (Work_Typ, Proc_Id); -- The DIC procedure requires debug info when the assertion expression -- is subject to Source Coverage Obligations. - if Opt.Generate_SCO then + if Generate_SCO then Set_Needs_Debug_Info (Proc_Id); end if; @@ -3387,7 +3393,7 @@ package body Exp_Util is -- The invariant procedure requires debug info when the invariants are -- subject to Source Coverage Obligations. - if Opt.Generate_SCO then + if Generate_SCO then Set_Needs_Debug_Info (Proc_Id); end if; @@ -7232,7 +7238,7 @@ package body Exp_Util is null; end if; - -- Another special case, an attribute denoting a procedure call + -- Special case: an attribute denoting a procedure call when N_Attribute_Reference => if Is_Procedure_Attribute_Name (Attribute_Name (P)) then @@ -7250,6 +7256,14 @@ package body Exp_Util is null; end if; + -- Special case: a call marker + + when N_Call_Marker => + if Is_List_Member (P) then + Insert_List_Before_And_Analyze (P, Ins_Actions); + return; + end if; + -- A contract node should not belong to the tree when N_Contract => @@ -8834,6 +8848,11 @@ package body Exp_Util is if Present (N) then Remove_Warning_Messages (N); + -- Update the internal structures of the ABE mechanism in case the + -- dead node is an elaboration scenario. + + Kill_Elaboration_Scenario (N); + -- Generate warning if appropriate if W then @@ -9190,43 +9209,42 @@ package body Exp_Util is Lo : constant Node_Id := New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ)); Index : constant Entity_Id := Etype (Lo); - - Hi : Node_Id; Length_Expr : constant Node_Id := Make_Op_Subtract (Loc, - Left_Opnd => + Left_Opnd => Make_Integer_Literal (Loc, Intval => String_Literal_Length (Literal_Typ)), - Right_Opnd => - Make_Integer_Literal (Loc, 1)); + Right_Opnd => Make_Integer_Literal (Loc, 1)); + + Hi : Node_Id; begin Set_Analyzed (Lo, False); - if Is_Integer_Type (Index) then - Hi := - Make_Op_Add (Loc, - Left_Opnd => New_Copy_Tree (Lo), - Right_Opnd => Length_Expr); - else - Hi := - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Val, - Prefix => New_Occurrence_Of (Index, Loc), - Expressions => New_List ( - Make_Op_Add (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Pos, - Prefix => New_Occurrence_Of (Index, Loc), - Expressions => New_List (New_Copy_Tree (Lo))), - Right_Opnd => Length_Expr))); - end if; + if Is_Integer_Type (Index) then + Hi := + Make_Op_Add (Loc, + Left_Opnd => New_Copy_Tree (Lo), + Right_Opnd => Length_Expr); + else + Hi := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Val, + Prefix => New_Occurrence_Of (Index, Loc), + Expressions => New_List ( + Make_Op_Add (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Pos, + Prefix => New_Occurrence_Of (Index, Loc), + Expressions => New_List (New_Copy_Tree (Lo))), + Right_Opnd => Length_Expr))); + end if; - return - Make_Range (Loc, - Low_Bound => Lo, - High_Bound => Hi); + return + Make_Range (Loc, + Low_Bound => Lo, + High_Bound => Hi); end Make_Literal_Range; -------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 99500584dd8..3fab6dd7b69 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -856,11 +856,8 @@ package Exp_Util is -- False means that it is not known if the value is positive or negative. function Make_Invariant_Call (Expr : Node_Id) return Node_Id; - -- Expr is an object of a type which Has_Invariants set (and which thus - -- also has an Invariant_Procedure set). If invariants are enabled, this - -- function returns a call to the Invariant procedure passing Expr as the - -- argument, and returns it unanalyzed. If invariants are not enabled, - -- returns a null statement. + -- Generate a call to the Invariant_Procedure associated with the type of + -- expression Expr. Expr is passed as an actual parameter in the call. function Make_Predicate_Call (Typ : Entity_Id; diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index bb28eae1192..b19da897332 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -87,6 +87,7 @@ begin Checks.Initialize; Sem_Warn.Initialize; Prep.Initialize; + Sem_Elab.Initialize; if Generate_SCIL then SCIL_LL.Initialize; @@ -422,8 +423,9 @@ begin Instantiate_Bodies; end if; - -- Analyze inlined bodies and check elaboration rules in GNATprove - -- mode as well as during compilation. + -- Analyze all inlined bodies, check access-before-elaboration + -- rules, and remove ignored Ghost code when generating code or + -- compiling for GNATprove. if Operating_Mode = Generate_Code or else GNATprove_Mode then if Inline_Processing_Required then @@ -437,12 +439,24 @@ begin Collect_Garbage_Entities; end if; - Check_Elab_Calls; + -- Examine all top level scenarios collected during analysis + -- and resolution. Diagnose conditional and guaranteed ABEs, + -- install run-time checks to catch ABEs, and guarantee the + -- prior elaboration of external units. + + Check_Elaboration_Scenarios; -- Remove any ignored Ghost code as it must not appear in the -- executable. Remove_Ignored_Ghost_Code; + + -- Otherwise check the access-before-elaboration rules even when + -- previous errors were detected or the compilation is verifying + -- semantics. + + else + Check_Elaboration_Scenarios; end if; -- At this stage we can unnest subprogram bodies if required diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 18bf0713b2b..a7579378cca 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -7688,6 +7688,15 @@ gnat_to_gnu (Node_Id gnat_node) /* Added Nodes */ /****************/ + /* Call markers are created by the ABE mechanism to capture the target of + a call along with other elaboration-related attributes which are either + unavailable of expensive to recompute. Call markers do not have static + and runtime semantics, and should be ignored. */ + + case N_Call_Marker: + gnu_result = alloc_stmt_list (); + break; + case N_Expression_With_Actions: /* This construct doesn't define a scope so we don't push a binding level around the statement list, but we wrap it in a SAVE_EXPR to diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 49abd462265..a39c2572be0 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Sep 29, 2017 +GNAT User's Guide for Native Platforms , Oct 09, 2017 AdaCore @@ -529,19 +529,21 @@ Mac OS Topics Elaboration Order Handling in GNAT * Elaboration Code:: +* Elaboration Order:: * Checking the Elaboration Order:: -* Controlling the Elaboration Order:: -* Controlling Elaboration in GNAT - Internal Calls:: -* Controlling Elaboration in GNAT - External Calls:: -* Default Behavior in GNAT - Ensuring Safety:: -* Treatment of Pragma Elaborate:: -* Elaboration Issues for Library Tasks:: +* Controlling the Elaboration Order in Ada:: +* Controlling the Elaboration Order in GNAT:: +* Common Elaboration-model Traits:: +* Dynamic Elaboration Model in GNAT:: +* Static Elaboration Model in GNAT:: +* SPARK Elaboration Model in GNAT:: * Mixing Elaboration Models:: -* What to Do If the Default Elaboration Behavior Fails:: -* Elaboration for Indirect Calls:: +* Elaboration Circularities:: +* Resolving Elaboration Circularities:: +* Resolving Task Issues:: +* Elaboration-related Compiler Switches:: * Summary of Procedures for Elaboration Control:: -* Other Elaboration Order Considerations:: -* Determining the Chosen Elaboration Order:: +* Inspecting the Chosen Elaboration Order:: Inline Assembler @@ -27013,322 +27015,361 @@ elaboration code in your own application). @geindex Elaboration control -This appendix describes the handling of elaboration code in Ada and -in GNAT, and discusses how the order of elaboration of program units can -be controlled in GNAT, either automatically or with explicit programming -features. +This appendix describes the handling of elaboration code in Ada and GNAT, and +discusses how the order of elaboration of program units can be controlled in +GNAT, either automatically or with explicit programming features. @menu * Elaboration Code:: +* Elaboration Order:: * Checking the Elaboration Order:: -* Controlling the Elaboration Order:: -* Controlling Elaboration in GNAT - Internal Calls:: -* Controlling Elaboration in GNAT - External Calls:: -* Default Behavior in GNAT - Ensuring Safety:: -* Treatment of Pragma Elaborate:: -* Elaboration Issues for Library Tasks:: +* Controlling the Elaboration Order in Ada:: +* Controlling the Elaboration Order in GNAT:: +* Common Elaboration-model Traits:: +* Dynamic Elaboration Model in GNAT:: +* Static Elaboration Model in GNAT:: +* SPARK Elaboration Model in GNAT:: * Mixing Elaboration Models:: -* What to Do If the Default Elaboration Behavior Fails:: -* Elaboration for Indirect Calls:: +* Elaboration Circularities:: +* Resolving Elaboration Circularities:: +* Resolving Task Issues:: +* Elaboration-related Compiler Switches:: * Summary of Procedures for Elaboration Control:: -* Other Elaboration Order Considerations:: -* Determining the Chosen Elaboration Order:: +* Inspecting the Chosen Elaboration Order:: @end menu -@node Elaboration Code,Checking the Elaboration Order,,Elaboration Order Handling in GNAT +@node Elaboration Code,Elaboration Order,,Elaboration Order Handling in GNAT @anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-code}@anchor{22e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id2}@anchor{22f} @section Elaboration Code -Ada provides rather general mechanisms for executing code at elaboration -time, that is to say before the main program starts executing. Such code arises -in three contexts: +Ada defines the term @emph{execution} as the process by which a construct achieves +its run-time effect. This process is also referred to as @strong{elaboration} for +declarations and @emph{evaluation} for expressions. + +The execution model in Ada allows for certain sections of an Ada program to be +executed prior to execution of the program itself, primarily with the intent of +initializing data. These sections are referred to as @strong{elaboration code}. +Elaboration code is executed as follows: @itemize * @item -@emph{Initializers for variables} +All partitions of an Ada program are executed in parallel with one another, +possibly in a separate address space, and possibly on a separate computer. -Variables declared at the library level, in package specs or bodies, can -require initialization that is performed at elaboration time, as in: +@item +The execution of a partition involves running the environment task for that +partition. -@example -Sqrt_Half : Float := Sqrt (0.5); -@end example +@item +The environment task executes all elaboration code (if available) for all +units within that partition. This code is said to be executed at +@strong{elaboration time}. + +@item +The environment task executes the Ada program (if available) for that +partition. +@end itemize + +In addition to the Ada terminology, this appendix defines the following terms: + + +@itemize * @item -@emph{Package initialization code} +@emph{Scenario} -Code in a @code{begin} ... `@w{`} end`@w{`} section at the outer level of a package body is -executed as part of the package body elaboration code. +A construct that is elaborated or executed by elaboration code is referred to +as an @emph{elaboration scenario} or simply a @strong{scenario}. GNAT recognizes the +following scenarios: + + +@itemize - + +@item +@code{'Access} of entries, operators, and subprograms @item -@emph{Library level task allocators} +Activation of tasks -Tasks that are declared using task allocators at the library level -start executing immediately and hence can execute at elaboration time. +@item +Calls to entries, operators, and subprograms + +@item +Instantiations of generic templates +@end itemize + +@item +@emph{Target} + +A construct elaborated by a scenario is referred to as @emph{elaboration target} +or simply @strong{target}. GNAT recognizes the following targets: + + +@itemize - + +@item +For @code{'Access} of entries, operators, and subprograms, the target is the +entry, operator, or subprogram being aliased. + +@item +For activation of tasks, the target is the task body + +@item +For calls to entries, operators, and subprograms, the target is the entry, +operator, or subprogram being invoked. + +@item +For instantiations of generic templates, the target is the generic template +being instantiated. @end itemize +@end itemize + +Elaboration code may appear in two distinct contexts: -Subprogram calls are possible in any of these contexts, which means that -any arbitrary part of the program may be executed as part of the elaboration -code. It is even possible to write a program which does all its work at -elaboration time, with a null main program, although stylistically this -would usually be considered an inappropriate way to structure -a program. -An important concern arises in the context of elaboration code: -we have to be sure that it is executed in an appropriate order. What we -have is a series of elaboration code sections, potentially one section -for each unit in the program. It is important that these execute -in the correct order. Correctness here means that, taking the above -example of the declaration of @code{Sqrt_Half}, -if some other piece of -elaboration code references @code{Sqrt_Half}, -then it must run after the -section of elaboration code that contains the declaration of -@code{Sqrt_Half}. +@itemize * + +@item +@emph{Library level} -There would never be any order of elaboration problem if we made a rule -that whenever you @emph{with} a unit, you must elaborate both the spec and body -of that unit before elaborating the unit doing the @emph{with}ing: +A scenario appears at the library level when it is encapsulated by a package +[body] compilation unit, ignoring any other package [body] declarations in +between. @example -with Unit_1; -package Unit_2 is ... +with Server; +package Client is + procedure Proc; + + package Nested is + Val : ... := Server.Func; + end Nested; +end Client; @end example -would require that both the body and spec of @code{Unit_1} be elaborated -before the spec of @code{Unit_2}. However, a rule like that would be far too -restrictive. In particular, it would make it impossible to have routines -in separate packages that were mutually recursive. +In the example above, the call to @code{Server.Func} is an elaboration scenario +because it appears at the library level of package @code{Client}. Note that the +declaration of package @code{Nested} is ignored according to the definition +given above. As a result, the call to @code{Server.Func} will be executed when +the spec of unit @code{Client} is elaborated. -You might think that a clever enough compiler could look at the actual -elaboration code and determine an appropriate correct order of elaboration, -but in the general case, this is not possible. Consider the following -example. +@item +@emph{Package body statements} -In the body of @code{Unit_1}, we have a procedure @code{Func_1} -that references -the variable @code{Sqrt_1}, which is declared in the elaboration code -of the body of @code{Unit_1}: +A scenario appears within the statement sequence of a package body when it is +bounded by the region starting from the @code{begin} keyword of the package body +and ending at the @code{end} keyword of the package body. @example -Sqrt_1 : Float := Sqrt (0.1); +package body Client is + procedure Proc is + begin + ... + end Proc; +begin + Proc; +end Client; @end example -The elaboration code of the body of @code{Unit_1} also contains: +In the example above, the call to @code{Proc} is an elaboration scenario because +it appears within the statement sequence of package body @code{Client}. As a +result, the call to @code{Proc} will be executed when the body of @code{Client} is +elaborated. +@end itemize + +@node Elaboration Order,Checking the Elaboration Order,Elaboration Code,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order}@anchor{230}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{231} +@section Elaboration Order + + +The sequence by which the elaboration code of all units within a partition is +executed is referred to as @strong{elaboration order}. The elaboration order depends +on the following factors: + + +@itemize * + +@item +@emph{with}ed units + +@item +purity of units + +@item +preelaborability of units + +@item +presence of elaboration control pragmas +@end itemize + +A program may have several elaboration orders depending on its structure. @example -if expression_1 = 1 then - Q := Unit_2.Func_2; -end if; +package Server is + function Func (Index : Integer) return Integer; +end Server; @end example -@code{Unit_2} is exactly parallel, -it has a procedure @code{Func_2} that references -the variable @code{Sqrt_2}, which is declared in the elaboration code of -the body @code{Unit_2}: - @example -Sqrt_2 : Float := Sqrt (0.1); +package body Server is + Results : array (1 .. 5) of Integer := (1, 2, 3, 4, 5); + + function Func (Index : Integer) return Integer is + begin + return Results (Index); + end Func; +end Server; @end example -The elaboration code of the body of @code{Unit_2} also contains: +@example +with Server; +package Client is + Val : constant Integer := Server.Func (3); +end Client; +@end example @example -if expression_2 = 2 then - Q := Unit_1.Func_1; -end if; +with Client; +procedure Main is begin null; end Main; @end example -Now the question is, which of the following orders of elaboration is -acceptable: +The following elaboration order exhibits a fundamental problem referred to as +@emph{access-before-elaboration} or simply @strong{ABE}. @example -Spec of Unit_1 -Spec of Unit_2 -Body of Unit_1 -Body of Unit_2 +spec of Server +spec of Client +body of Server +body of Main @end example -or +The elaboration of @code{Server}'s spec materializes function @code{Func}, making it +callable. The elaboration of @code{Client}'s spec elaborates the declaration of +@code{Val}. This invokes function @code{Server.Func}, however the body of +@code{Server.Func} has not been elaborated yet because @code{Server}'s body comes +after @code{Client}'s spec in the elaboration order. As a result, the value of +constant @code{Val} is now undefined. + +Without any guarantees from the language, an undetected ABE problem may hinder +proper initialization of data, which in turn may lead to undefined behavior at +run time. To prevent such ABE problems, Ada employs dynamic checks in the same +vein as index or null exclusion checks. A failed ABE check raises exception +@code{Program_Error}. + +The following elaboration order avoids the ABE problem and the program can be +successfully elaborated. @example -Spec of Unit_2 -Spec of Unit_1 -Body of Unit_2 -Body of Unit_1 -@end example - -If you carefully analyze the flow here, you will see that you cannot tell -at compile time the answer to this question. -If @code{expression_1} is not equal to 1, -and @code{expression_2} is not equal to 2, -then either order is acceptable, because neither of the function calls is -executed. If both tests evaluate to true, then neither order is acceptable -and in fact there is no correct order. - -If one of the two expressions is true, and the other is false, then one -of the above orders is correct, and the other is incorrect. For example, -if @code{expression_1} /= 1 and @code{expression_2} = 2, -then the call to @code{Func_1} -will occur, but not the call to @code{Func_2.} -This means that it is essential -to elaborate the body of @code{Unit_1} before -the body of @code{Unit_2}, so the first -order of elaboration is correct and the second is wrong. - -By making @code{expression_1} and @code{expression_2} -depend on input data, or perhaps -the time of day, we can make it impossible for the compiler or binder -to figure out which of these expressions will be true, and hence it -is impossible to guarantee a safe order of elaboration at run time. - -@node Checking the Elaboration Order,Controlling the Elaboration Order,Elaboration Code,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{230}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{231} +spec of Server +body of Server +spec of Client +body of Main +@end example + +Ada states that a total elaboration order must exist, but it does not define +what this order is. A compiler is thus tasked with choosing a suitable +elaboration order which satisfies the dependencies imposed by @emph{with} clauses, +unit categorization, and elaboration control pragmas. Ideally an order which +avoids ABE problems should be chosen, however a compiler may not always find +such an order due to complications with respect to control and data flow. + +@node Checking the Elaboration Order,Controlling the Elaboration Order in Ada,Elaboration Order,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{232}@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{233} @section Checking the Elaboration Order -In some languages that involve the same kind of elaboration problems, -e.g., Java and C++, the programmer needs to take these -ordering problems into account, and it is common to -write a program in which an incorrect elaboration order gives -surprising results, because it references variables before they -are initialized. -Ada is designed to be a safe language, and a programmer-beware approach is -clearly not sufficient. Consequently, the language provides three lines -of defense: +To avoid placing the entire elaboration order burden on the programmer, Ada +provides three lines of defense: @itemize * @item -@emph{Standard rules} +@emph{Static semantics} -Some standard rules restrict the possible choice of elaboration -order. In particular, if you @emph{with} a unit, then its spec is always -elaborated before the unit doing the @emph{with}. Similarly, a parent -spec is always elaborated before the child spec, and finally -a spec is always elaborated before its corresponding body. -@end itemize +Static semantic rules restrict the possible choice of elaboration order. For +instance, if unit Client @emph{with}s unit Server, then the spec of Server is +always elaborated prior to Client. The same principle applies to child units +- the spec of a parent unit is always elaborated prior to the child unit. -@geindex Elaboration checks +@item +@emph{Dynamic semantics} -@geindex Checks -@geindex elaboration +Dynamic checks are performed at run time, to ensure that a target is +elaborated prior to a scenario that executes it, thus avoiding ABE problems. +A failed run-time check raises exception @code{Program_Error}. The following +restrictions apply: -@itemize * +@itemize - @item -@emph{Dynamic elaboration checks} +@emph{Restrictions on calls} -Dynamic checks are made at run time, so that if some entity is accessed -before it is elaborated (typically by means of a subprogram call) -then the exception (@code{Program_Error}) is raised. +An entry, operator, or subprogram can be called from elaboration code only +when the corresponding body has been elaborated. @item -@emph{Elaboration control} - -Facilities are provided for the programmer to specify the desired order -of elaboration. -@end itemize +@emph{Restrictions on instantiations} -Let's look at these facilities in more detail. First, the rules for -dynamic checking. One possible rule would be simply to say that the -exception is raised if you access a variable which has not yet been -elaborated. The trouble with this approach is that it could require -expensive checks on every variable reference. Instead Ada has two -rules which are a little more restrictive, but easier to check, and -easier to state: +A generic unit can be instantiated by elaboration code only when the +corresponding body has been elaborated. +@item +@emph{Restrictions on task activation} -@itemize * +A task can be activated by elaboration code only when the body of the +associated task type has been elaborated. +@end itemize -@item -@emph{Restrictions on calls} +The restrictions above can be summarized by the following rule: -A subprogram can only be called at elaboration time if its body -has been elaborated. The rules for elaboration given above guarantee -that the spec of the subprogram has been elaborated before the -call, but not the body. If this rule is violated, then the -exception @code{Program_Error} is raised. +@emph{If a target has a body, then this body must be elaborated prior to the +execution of the scenario that invokes, instantiates, or activates the +target.} @item -@emph{Restrictions on instantiations} +@emph{Elaboration control} -A generic unit can only be instantiated if the body of the generic -unit has been elaborated. Again, the rules for elaboration given above -guarantee that the spec of the generic unit has been elaborated -before the instantiation, but not the body. If this rule is -violated, then the exception @code{Program_Error} is raised. +Pragmas are provided for the programmer to specify the desired elaboration +order. @end itemize -The idea is that if the body has been elaborated, then any variables -it references must have been elaborated; by checking for the body being -elaborated we guarantee that none of its references causes any -trouble. As we noted above, this is a little too restrictive, because a -subprogram that has no non-local references in its body may in fact be safe -to call. However, it really would be unsafe to rely on this, because -it would mean that the caller was aware of details of the implementation -in the body. This goes against the basic tenets of Ada. - -A plausible implementation can be described as follows. -A Boolean variable is associated with each subprogram -and each generic unit. This variable is initialized to False, and is set to -True at the point body is elaborated. Every call or instantiation checks the -variable, and raises @code{Program_Error} if the variable is False. - -Note that one might think that it would be good enough to have one Boolean -variable for each package, but that would not deal with cases of trying -to call a body in the same package as the call -that has not been elaborated yet. -Of course a compiler may be able to do enough analysis to optimize away -some of the Boolean variables as unnecessary, and GNAT indeed -does such optimizations, but still the easiest conceptual model is to -think of there being one variable per subprogram. - -@node Controlling the Elaboration Order,Controlling Elaboration in GNAT - Internal Calls,Checking the Elaboration Order,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{232}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order}@anchor{233} -@section Controlling the Elaboration Order - - -In the previous section we discussed the rules in Ada which ensure -that @code{Program_Error} is raised if an incorrect elaboration order is -chosen. This prevents erroneous executions, but we need mechanisms to -specify a correct execution and avoid the exception altogether. -To achieve this, Ada provides a number of features for controlling -the order of elaboration. We discuss these features in this section. - -First, there are several ways of indicating to the compiler that a given -unit has no elaboration problems: +@node Controlling the Elaboration Order in Ada,Controlling the Elaboration Order in GNAT,Checking the Elaboration Order,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-ada}@anchor{234}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{235} +@section Controlling the Elaboration Order in Ada + + +Ada provides several idioms and pragmas to aid the programmer with specifying +the desired elaboration order and avoiding ABE problems altogether. @itemize * @item -@emph{packages that do not require a body} +@emph{Packages without a body} -A library package that does not require a body does not permit -a body (this rule was introduced in Ada 95). -Thus if we have a such a package, as in: +A library package which does not require a completing body does not suffer +from ABE problems. @example -package Definitions is +package Pack is generic - type m is new integer; - package Subp is - type a is array (1 .. 10) of m; - type b is array (1 .. 20) of m; - end Subp; -end Definitions; + type Element is private; + package Containers is + type Element_Array is array (1 .. 10) of Element; + end Containers; +end Pack; @end example -A package that @emph{with}s @code{Definitions} may safely instantiate -@code{Definitions.Subp} because the compiler can determine that there -definitely is no package body to worry about in this case +In the example above, package @code{Pack} does not require a body because it +does not contain any constructs which require completion in a body. As a +result, generic @code{Pack.Containers} can be instantiated without encountering +any ABE problems. @end itemize @geindex pragma Pure @@ -27339,12 +27380,8 @@ definitely is no package body to worry about in this case @item @emph{pragma Pure} -This pragma places sufficient restrictions on a unit to guarantee that -no call to any subprogram in the unit can result in an -elaboration problem. This means that the compiler does not need -to worry about the point of elaboration of such units, and in -particular, does not need to check any calls to any subprograms -in this unit. +Pragma @code{Pure} places sufficient restrictions on a unit to guarantee that no +scenario within the unit can result in an ABE problem. @end itemize @geindex pragma Preelaborate @@ -27355,10 +27392,8 @@ in this unit. @item @emph{pragma Preelaborate} -This pragma places slightly less stringent restrictions on a unit than -does pragma Pure, -but these restrictions are still sufficient to ensure that there -are no elaboration problems with any calls to the unit. +Pragma @code{Preelaborate} is slightly less restrictive than pragma @code{Pure}, +but still strong enough to prevent ABE problems within a unit. @end itemize @geindex pragma Elaborate_Body @@ -27369,1509 +27404,1493 @@ are no elaboration problems with any calls to the unit. @item @emph{pragma Elaborate_Body} -This pragma requires that the body of a unit be elaborated immediately -after its spec. Suppose a unit @code{A} has such a pragma, -and unit @code{B} does -a @emph{with} of unit @code{A}. Recall that the standard rules require -the spec of unit @code{A} -to be elaborated before the @emph{with}ing unit; given the pragma in -@code{A}, we also know that the body of @code{A} -will be elaborated before @code{B}, so -that calls to @code{A} are safe and do not need a check. - -Note that, unlike pragma @code{Pure} and pragma @code{Preelaborate}, -the use of @code{Elaborate_Body} does not guarantee that the program is -free of elaboration problems, because it may not be possible -to satisfy the requested elaboration order. -Let's go back to the example with @code{Unit_1} and @code{Unit_2}. -If a programmer marks @code{Unit_1} as @code{Elaborate_Body}, -and not @code{Unit_2,} then the order of -elaboration will be: - -@example -Spec of Unit_2 -Spec of Unit_1 -Body of Unit_1 -Body of Unit_2 -@end example - -Now that means that the call to @code{Func_1} in @code{Unit_2} -need not be checked, -it must be safe. But the call to @code{Func_2} in -@code{Unit_1} may still fail if -@code{Expression_1} is equal to 1, -and the programmer must still take -responsibility for this not being the case. - -If all units carry a pragma @code{Elaborate_Body}, then all problems are -eliminated, except for calls entirely within a body, which are -in any case fully under programmer control. However, using the pragma -everywhere is not always possible. -In particular, for our @code{Unit_1}/@cite{Unit_2} example, if -we marked both of them as having pragma @code{Elaborate_Body}, then -clearly there would be no possible elaboration order. +Pragma @code{Elaborate_Body} requires that the body of a unit is elaborated +immediately after its spec. This restriction guarantees that no client +scenario can execute a server target before the target body has been +elaborated because the spec and body are effectively "glued" together. + +@example +package Server is + pragma Elaborate_Body; + + function Func return Integer; +end Server; +@end example + +@example +package body Server is + function Func return Integer is + begin + ... + end Func; +end Server; +@end example + +@example +with Server; +package Client is + Val : constant Integer := Server.Func; +end Client; +@end example + +In the example above, pragma @code{Elaborate_Body} guarantees the following +elaboration order: + +@example +spec of Server +body of Server +spec of Client +@end example + +because the spec of @code{Server} must be elaborated prior to @code{Client} by +virtue of the @emph{with} clause, and in addition the body of @code{Server} must be +elaborated immediately after the spec of @code{Server}. + +Removing pragma @code{Elaborate_Body} could result in the following incorrect +elaboration order: + +@example +spec of Server +spec of Client +body of Server +@end example + +where @code{Client} invokes @code{Server.Func}, but the body of @code{Server.Func} has +not been elaborated yet. @end itemize -The above pragmas allow a server to guarantee safe use by clients, and -clearly this is the preferable approach. Consequently a good rule -is to mark units as @code{Pure} or @code{Preelaborate} if possible, -and if this is not possible, -mark them as @code{Elaborate_Body} if possible. -As we have seen, there are situations where neither of these -three pragmas can be used. -So we also provide methods for clients to control the -order of elaboration of the servers on which they depend: +The pragmas outlined above allow a server unit to guarantee safe elaboration +use by client units. Thus it is a good rule to mark units as @code{Pure} or +@code{Preelaborate}, and if this is not possible, mark them as @code{Elaborate_Body}. + +There are however situations where @code{Pure}, @code{Preelaborate}, and +@code{Elaborate_Body} are not applicable. Ada provides another set of pragmas for +use by client units to help ensure the elaboration safety of server units they +depend on. -@geindex pragma Elaborate +@geindex pragma Elaborate (Unit) @itemize * @item -@emph{pragma Elaborate (unit)} +@emph{pragma Elaborate (Unit)} -This pragma is placed in the context clause, after a @emph{with} clause, -and it requires that the body of the named unit be elaborated before -the unit in which the pragma occurs. The idea is to use this pragma -if the current unit calls at elaboration time, directly or indirectly, -some subprogram in the named unit. +Pragma @code{Elaborate} can be placed in the context clauses of a unit, after a +@emph{with} clause. It guarantees that both the spec and body of its argument will +be elaborated prior to the unit with the pragma. Note that other unrelated +units may be elaborated in between the spec and the body. + +@example +package Server is + function Func return Integer; +end Server; +@end example + +@example +package body Server is + function Func return Integer is + begin + ... + end Func; +end Server; +@end example + +@example +with Server; +pragma Elaborate (Server); +package Client is + Val : constant Integer := Server.Func; +end Client; +@end example + +In the example above, pragma @code{Elaborate} guarantees the following +elaboration order: + +@example +spec of Server +body of Server +spec of Client +@end example + +Removing pragma @code{Elaborate} could result in the following incorrect +elaboration order: + +@example +spec of Server +spec of Client +body of Server +@end example + +where @code{Client} invokes @code{Server.Func}, but the body of @code{Server.Func} +has not been elaborated yet. @end itemize -@geindex pragma Elaborate_All +@geindex pragma Elaborate_All (Unit) @itemize * @item -@emph{pragma Elaborate_All (unit)} +@emph{pragma Elaborate_All (Unit)} -This is a stronger version of the Elaborate pragma. Consider the -following example: +Pragma @code{Elaborate_All} is placed in the context clauses of a unit, after +a @emph{with} clause. It guarantees that both the spec and body of its argument +will be elaborated prior to the unit with the pragma, as well as all units +@emph{with}ed by the spec and body of the argument, recursively. Note that other +unrelated units may be elaborated in between the spec and the body. @example -Unit A |withs| unit B and calls B.Func in elab code -Unit B |withs| unit C, and B.Func calls C.Func +package Math is + function Factorial (Val : Natural) return Natural; +end Math; +@end example + +@example +package body Math is + function Factorial (Val : Natural) return Natural is + begin + ...; + end Factorial; +end Math; @end example -Now if we put a pragma @code{Elaborate (B)} -in unit @code{A}, this ensures that the -body of @code{B} is elaborated before the call, but not the -body of @code{C}, so -the call to @code{C.Func} could still cause @code{Program_Error} to -be raised. +@example +package Computer is + type Operation_Kind is (None, Op_Factorial); -The effect of a pragma @code{Elaborate_All} is stronger, it requires -not only that the body of the named unit be elaborated before the -unit doing the @emph{with}, but also the bodies of all units that the -named unit uses, following @emph{with} links transitively. For example, -if we put a pragma @code{Elaborate_All (B)} in unit @code{A}, -then it requires not only that the body of @code{B} be elaborated before @code{A}, -but also the body of @code{C}, because @code{B} @emph{with}s @code{C}. -@end itemize + function Compute + (Val : Natural; + Op : Operation_Kind) return Natural; +end Computer; +@end example -We are now in a position to give a usage rule in Ada for avoiding -elaboration problems, at least if dynamic dispatching and access to -subprogram values are not used. We will handle these cases separately -later. +@example +with Math; +package body Computer is + function Compute + (Val : Natural; + Op : Operation_Kind) return Natural + is + if Op = Op_Factorial then + return Math.Factorial (Val); + end if; -The rule is simple: + return 0; + end Compute; +end Computer; +@end example -@emph{If a unit has elaboration code that can directly or -indirectly make a call to a subprogram in a |withed| unit, or instantiate -a generic package in a |withed| unit, -then if the |withed| unit does not have -pragma `@w{`}Pure`@w{`} or `@w{`}Preelaborate`@w{`}, then the client should have -a pragma `@w{`}Elaborate_All`@w{`}for the |withed| unit.*} +@example +with Computer; +pragma Elaborate_All (Computer); +package Client is + Val : constant Natural := + Computer.Compute (123, Computer.Op_Factorial); +end Client; +@end example + +In the example above, pragma @code{Elaborate_All} can result in the following +elaboration order: + +@example +spec of Math +body of Math +spec of Computer +body of Computer +spec of Client +@end example + +Note that there are several allowable suborders for the specs and bodies of +@code{Math} and @code{Computer}, but the point is that these specs and bodies will +be elaborated prior to @code{Client}. + +Removing pragma @code{Elaborate_All} could result in the following incorrect +elaboration order + +@example +spec of Math +spec of Computer +body of Computer +spec of Client +body of Math +@end example + +where @code{Client} invokes @code{Computer.Compute}, which in turn invokes +@code{Math.Factorial}, but the body of @code{Math.Factorial} has not been +elaborated yet. +@end itemize -By following this rule a client is -assured that calls can be made without risk of an exception. +All pragmas shown above can be summarized by the following rule: -For generic subprogram instantiations, the rule can be relaxed to -require only a pragma @code{Elaborate} since elaborating the body -of a subprogram cannot cause any transitive elaboration (we are -not calling the subprogram in this case, just elaborating its -declaration). +@emph{If a client unit elaborates a server target directly or indirectly, then if +the server unit requires a body and does not have pragma Pure, Preelaborate, +or Elaborate_Body, then the client unit should have pragma Elaborate or +Elaborate_All for the server unit.} -If this rule is not followed, then a program may be in one of four -states: +If the rule outlined above is not followed, then a program may fall in one of +the following states: @itemize * @item -@emph{No order exists} +@emph{No elaboration order exists} -No order of elaboration exists which follows the rules, taking into -account any @code{Elaborate}, @code{Elaborate_All}, -or @code{Elaborate_Body} pragmas. In -this case, an Ada compiler must diagnose the situation at bind -time, and refuse to build an executable program. +In this case a compiler must diagnose the situation, and refuse to build an +executable program. @item -@emph{One or more orders exist, all incorrect} +@emph{One or more incorrect elaboration orders exist} -One or more acceptable elaboration orders exist, and all of them -generate an elaboration order problem. In this case, the binder -can build an executable program, but @code{Program_Error} will be raised -when the program is run. +In this case a compiler can build an executable program, but +@code{Program_Error} will be raised when the program is run. @item -@emph{Several orders exist, some right, some incorrect} +@emph{Several elaboration orders exist, some correct, some incorrect} -One or more acceptable elaboration orders exists, and some of them -work, and some do not. The programmer has not controlled -the order of elaboration, so the binder may or may not pick one of -the correct orders, and the program may or may not raise an -exception when it is run. This is the worst case, because it means -that the program may fail when moved to another compiler, or even -another version of the same compiler. +In this case the programmer has not controlled the elaboration order. As a +result, a compiler may or may not pick one of the correct orders, and the +program may or may not raise @code{Program_Error} when it is run. This is the +worst possible state because the program may fail on another compiler, or +even another version of the same compiler. @item -@emph{One or more orders exists, all correct} +@emph{One or more correct orders exist} -One ore more acceptable elaboration orders exist, and all of them -work. In this case the program runs successfully. This state of -affairs can be guaranteed by following the rule we gave above, but -may be true even if the rule is not followed. +In this case a compiler can build an executable program, and the program is +run successfully. This state may be guaranteed by following the outlined +rules, or may be the result of good program architecture. @end itemize -Note that one additional advantage of following our rules on the use -of @code{Elaborate} and @code{Elaborate_All} -is that the program continues to stay in the ideal (all orders OK) state -even if maintenance -changes some bodies of some units. Conversely, if a program that does -not follow this rule happens to be safe at some point, this state of affairs -may deteriorate silently as a result of maintenance changes. +Note that one additional advantage of using @code{Elaborate} and @code{Elaborate_All} +is that the program continues to stay in the last state (one or more correct +orders exist) even if maintenance changes the bodies of targets. -You may have noticed that the above discussion did not mention -the use of @code{Elaborate_Body}. This was a deliberate omission. If you -@emph{with} an @code{Elaborate_Body} unit, it still may be the case that -code in the body makes calls to some other unit, so it is still necessary -to use @code{Elaborate_All} on such units. +@node Controlling the Elaboration Order in GNAT,Common Elaboration-model Traits,Controlling the Elaboration Order in Ada,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{236}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-gnat}@anchor{237} +@section Controlling the Elaboration Order in GNAT -@node Controlling Elaboration in GNAT - Internal Calls,Controlling Elaboration in GNAT - External Calls,Controlling the Elaboration Order,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{234}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-elaboration-in-gnat-internal-calls}@anchor{235} -@section Controlling Elaboration in GNAT - Internal Calls +In addition to Ada semantics and rules synthesized from them, GNAT offers +three elaboration models to aid the programmer with specifying the correct +elaboration order and to diagnose elaboration problems. + +@geindex Dynamic elaboration model + + +@itemize * + +@item +@emph{Dynamic elaboration model} + +This is the most permissive of the three elaboration models. When the +dynamic model is in effect, GNAT assumes that all code within all units in +a partition is elaboration code. GNAT performs very few diagnostics and +generates run-time checks to verify the elaboration order of a program. This +behavior is identical to that specified by the Ada Reference Manual. The +dynamic model is enabled with compilation switch @code{-gnatE}. +@end itemize + +@geindex Static elaboration model + + +@itemize * + +@item +@emph{Static elaboration model} + +This is the middle ground of the three models. When the static model is in +effect, GNAT performs extensive diagnostics on a unit-by-unit basis for all +scenarios that elaborate or execute internal targets. GNAT also generates +run-time checks for all external targets and for all scenarios that may +exhibit ABE problems. Finally, GNAT installs implicit @code{Elaborate} and +@code{Elaborate_All} pragmas for server units based on the dependencies of +client units. The static model is the default model in GNAT. +@end itemize + +@geindex SPARK elaboration model + + +@itemize * + +@item +@emph{SPARK elaboration model} + +This is the most conservative of the three models and enforces the SPARK +rules of elaboration as defined in the SPARK Reference Manual, section 7.7. +The SPARK model is in effect only when a scenario and a target reside in a +region subject to SPARK_Mode On, otherwise the dynamic or static model is in +effect. +@end itemize + +@node Common Elaboration-model Traits,Dynamic Elaboration Model in GNAT,Controlling the Elaboration Order in GNAT,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat common-elaboration-model-traits}@anchor{238}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{239} +@section Common Elaboration-model Traits + + +All three GNAT models are able to detect elaboration problems related to +dispatching calls and a particular kind of ABE referred to as @emph{guaranteed ABE}. + + +@itemize * + +@item +@emph{Dispatching calls} + +GNAT installs run-time checks for each primitive subprogram of each tagged +type defined in a partition on the assumption that a dispatching call +invoked at elaboration time will execute one of these primitives. As a +result, a dispatching call that executes a primitive whose body has not +been elaborated yet will raise exception @code{Program_Error} at run time. The +checks can be suppressed using pragma @code{Suppress (Elaboration_Check)}. + +@item +@emph{Guaranteed ABE} -In the case of internal calls, i.e., calls within a single package, the -programmer has full control over the order of elaboration, and it is up -to the programmer to elaborate declarations in an appropriate order. For -example writing: +A guaranteed ABE arises when the body of a target is not elaborated early +enough, and causes all scenarios that directly execute the target to fail. @example -function One return Float; +package body Guaranteed_ABE is + function ABE return Integer; -Q : Float := One; + Val : constant Integer := ABE; -function One return Float is -begin - return 1.0; -end One; + function ABE return Integer is + begin + ... + end ABE; +end Guaranteed_ABE; @end example -will obviously raise @code{Program_Error} at run time, because function -One will be called before its body is elaborated. In this case GNAT will -generate a warning that the call will raise @code{Program_Error}: +In the example above, the elaboration of @code{Guaranteed_ABE}'s body elaborates +the declaration of @code{Val}. This invokes function @code{ABE}, however the body +of @code{ABE} has not been elaborated yet. GNAT emits similar diagnostics in all +three models: @example - 1. procedure y is - 2. function One return Float; - 3. - 4. Q : Float := One; - | - >>> warning: cannot call "One" before body is elaborated - >>> warning: Program_Error will be raised at run time +1. package body Guaranteed_ABE is +2. function ABE return Integer; +3. +4. Val : constant Integer := ABE; + | + >>> warning: cannot call "ABE" before body seen + >>> warning: Program_Error will be raised at run time - 5. - 6. function One return Float is - 7. begin - 8. return 1.0; - 9. end One; -10. -11. begin -12. null; -13. end; +5. +6. function ABE return Integer is +7. begin +8. ... +9. end ABE; +10. end Guaranteed_ABE; @end example +@end itemize -Note that in this particular case, it is likely that the call is safe, because -the function @code{One} does not access any global variables. -Nevertheless in Ada, we do not want the validity of the check to depend on -the contents of the body (think about the separate compilation case), so this -is still wrong, as we discussed in the previous sections. +Note that GNAT emits warnings rather than hard errors whenever it encounters an +elaboration problem. This is because the elaboration model in effect may be too +conservative, or a particular scenario may not be elaborated or executed due to +data and control flow. The warnings can be suppressed with compiler switch +@code{-gnatws}. -The error is easily corrected by rearranging the declarations so that the -body of @code{One} appears before the declaration containing the call -(note that in Ada 95 as well as later versions of the Ada standard, -declarations can appear in any order, so there is no restriction that -would prevent this reordering, and if we write: +@node Dynamic Elaboration Model in GNAT,Static Elaboration Model in GNAT,Common Elaboration-model Traits,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat dynamic-elaboration-model-in-gnat}@anchor{23a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{23b} +@section Dynamic Elaboration Model in GNAT + + +The dynamic model assumes that all code within all units in a partition is +elaboration code. As a result, run-time checks are installed for each scenario +regardless of whether the target is internal or external. The checks can be +suppressed using pragma @code{Suppress (Elaboration_Check)}. This behavior is +identical to that specified by the Ada Reference Manual. The following example +showcases run-time checks installed by GNAT to verify the elaboration state of +package @code{Dynamic_Model}. @example -function One return Float; +with Server; +package body Dynamic_Model is + procedure API is + begin + ... + end API; + + <check that the body of Server.Gen is elaborated> + package Inst is new Server.Gen; + + T : Server.Task_Type; -function One return Float is begin - return 1.0; -end One; + <check that the body of Server.Task_Type is elaborated> -Q : Float := One; + <check that the body of Server.Proc is elaborated> + Server.Proc; +end Dynamic_Model; @end example -then all is well, no warning is generated, and no -@code{Program_Error} exception -will be raised. -Things are more complicated when a chain of subprograms is executed: +The checks verify that the body of a target has been successfully elaborated +before a scenario activates, calls, or instantiates a target. + +Note that no scenario within package @code{Dynamic_Model} calls procedure @code{API}. +In fact, procedure @code{API} may not be invoked by elaboration code within the +partition, however the dynamic model assumes that this can happen. + +The dynamic model emits very few diagnostics, but can make suggestions on +missing @code{Elaborate} and @code{Elaborate_All} pragmas for library-level +scenarios. This information is available when compiler switch @code{-gnatel} +is in effect. @example -function A return Integer; -function B return Integer; -function C return Integer; +1. with Server; +2. package body Dynamic_Model is +3. Val : constant Integer := Server.Func; + | + >>> info: call to "Func" during elaboration + >>> info: missing pragma "Elaborate_All" for unit "Server" -function B return Integer is begin return A; end; -function C return Integer is begin return B; end; +4. end Dynamic_Model; +@end example -X : Integer := C; +@node Static Elaboration Model in GNAT,SPARK Elaboration Model in GNAT,Dynamic Elaboration Model in GNAT,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat static-elaboration-model-in-gnat}@anchor{23c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{23d} +@section Static Elaboration Model in GNAT -function A return Integer is begin return 1; end; + +In contrast to the dynamic model, the static model is more precise in its +analysis of elaboration code. The model makes a clear distinction between +internal and external targets, and resorts to different diagnostics and +run-time checks based on the nature of the target. + + +@itemize * + +@item +@emph{Internal targets} + +The static model performs extensive diagnostics on scenarios which elaborate +or execute internal targets. The warnings resulting from these diagnostics +are enabled by default, but can be suppressed using compiler switch +@code{-gnatws}. + +@example + 1. package body Static_Model is + 2. generic + 3. with function Func return Integer; + 4. package Gen is + 5. Val : constant Integer := Func; + 6. end Gen; + 7. + 8. function ABE return Integer; + 9. +10. function Cause_ABE return Boolean is +11. package Inst is new Gen (ABE); + | + >>> warning: in instantiation at line 5 + >>> warning: cannot call "ABE" before body seen + >>> warning: Program_Error may be raised at run time + >>> warning: body of unit "Static_Model" elaborated + >>> warning: function "Cause_ABE" called at line 16 + >>> warning: function "ABE" called at line 5, instance at line 11 + +12. begin +13. ... +14. end Cause_ABE; +15. +16. Val : constant Boolean := Cause_ABE; +17. +18. function ABE return Integer is +19. begin +20. ... +21. end ABE; +22. end Static_Model; +@end example + +The example above illustrates an ABE problem within package @code{Static_Model}, +which is hidden by several layers of indirection. The elaboration of package +body @code{Static_Model} elaborates the declaration of @code{Val}. This invokes +function @code{Cause_ABE}, which instantiates generic unit @code{Gen} as @code{Inst}. +The elaboration of @code{Inst} invokes function @code{ABE}, however the body of +@code{ABE} has not been elaborated yet. + +@item +@emph{External targets} + +The static model installs run-time checks to verify the elaboration status +of server targets only when the scenario that elaborates or executes that +target is part of the elaboration code of the client unit. The checks can be +suppressed using pragma @code{Suppress (Elaboration_Check)}. + +@example +with Server; +package body Static_Model is + generic + with function Func return Integer; + package Gen is + Val : constant Integer := Func; + end Gen; + + function Call_Func return Boolean is + <check that the body of Server.Func is elaborated> + package Inst is new Gen (Server.Func); + begin + ... + end Call_Func; + + Val : constant Boolean := Call_Func; +end Static_Model; @end example -Now the call to @code{C} -at elaboration time in the declaration of @code{X} is correct, because -the body of @code{C} is already elaborated, -and the call to @code{B} within the body of -@code{C} is correct, but the call -to @code{A} within the body of @code{B} is incorrect, because the body -of @code{A} has not been elaborated, so @code{Program_Error} -will be raised on the call to @code{A}. -In this case GNAT will generate a -warning that @code{Program_Error} may be -raised at the point of the call. Let's look at the warning: +In the example above, the elaboration of package body @code{Static_Model} +elaborates the declaration of @code{Val}. This invokes function @code{Call_Func}, +which instantiates generic unit @code{Gen} as @code{Inst}. The elaboration of +@code{Inst} invokes function @code{Server.Func}. Since @code{Server.Func} is an +external target, GNAT installs a run-time check to verify that its body has +been elaborated. + +In addition to checks, the static model installs implicit @code{Elaborate} and +@code{Elaborate_All} pragmas to guarantee safe elaboration use of server units. +This information is available when compiler switch @code{-gnatel} is in +effect. @example - 1. procedure x is - 2. function A return Integer; - 3. function B return Integer; - 4. function C return Integer; - 5. - 6. function B return Integer is begin return A; end; - | - >>> warning: call to "A" before body is elaborated may - raise Program_Error - >>> warning: "B" called at line 7 - >>> warning: "C" called at line 9 - - 7. function C return Integer is begin return B; end; + 1. with Server; + 2. package body Static_Model is + 3. generic + 4. with function Func return Integer; + 5. package Gen is + 6. Val : constant Integer := Func; + 7. end Gen; 8. - 9. X : Integer := C; -10. -11. function A return Integer is begin return 1; end; -12. -13. begin -14. null; -15. end; -@end example + 9. function Call_Func return Boolean is +10. package Inst is new Gen (Server.Func); + | + >>> info: instantiation of "Gen" during elaboration + >>> info: in instantiation at line 6 + >>> info: call to "Func" during elaboration + >>> info: in instantiation at line 6 + >>> info: implicit pragma "Elaborate_All" generated for unit "Server" + >>> info: body of unit "Static_Model" elaborated + >>> info: function "Call_Func" called at line 15 + >>> info: function "Func" called at line 6, instance at line 10 + +11. begin +12. ... +13. end Call_Func; +14. +15. Val : constant Boolean := Call_Func; + | + >>> info: call to "Call_Func" during elaboration + +16. end Static_Model; +@end example + +In the example above, the elaboration of package body @code{Static_Model} +elaborates the declaration of @code{Val}. This invokes function @code{Call_Func}, +which instantiates generic unit @code{Gen} as @code{Inst}. The elaboration of +@code{Inst} invokes function @code{Server.Func}. Since @code{Server.Func} is an +external target, GNAT installs an implicit @code{Elaborate_All} pragma for unit +@code{Server}. The pragma guarantees that both the spec and body of @code{Server}, +along with any additional dependencies that @code{Server} may require, are +elaborated prior to the body of @code{Static_Model}. +@end itemize + +@node SPARK Elaboration Model in GNAT,Mixing Elaboration Models,Static Elaboration Model in GNAT,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{23e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat spark-elaboration-model-in-gnat}@anchor{23f} +@section SPARK Elaboration Model in GNAT + -Note that the message here says 'may raise', instead of the direct case, -where the message says 'will be raised'. That's because whether -@code{A} is -actually called depends in general on run-time flow of control. -For example, if the body of @code{B} said +The SPARK model is identical to the static model in its handling of internal +targets. The SPARK model, however, requires explicit @code{Elaborate} or +@code{Elaborate_All} pragmas to be present in the program when a target is +external, and emits hard errors instead of warnings: @example -function B return Integer is -begin - if some-condition-depending-on-input-data then - return A; - else - return 1; - end if; -end B; -@end example - -then we could not know until run time whether the incorrect call to A would -actually occur, so @code{Program_Error} might -or might not be raised. It is possible for a compiler to -do a better job of analyzing bodies, to -determine whether or not @code{Program_Error} -might be raised, but it certainly -couldn't do a perfect job (that would require solving the halting problem -and is provably impossible), and because this is a warning anyway, it does -not seem worth the effort to do the analysis. Cases in which it -would be relevant are rare. - -In practice, warnings of either of the forms given -above will usually correspond to -real errors, and should be examined carefully and eliminated. -In the rare case where a warning is bogus, it can be suppressed by any of -the following methods: +1. with Server; +2. package body SPARK_Model with SPARK_Mode is +3. Val : constant Integer := Server.Func; + | + >>> call to "Func" during elaboration in SPARK + >>> unit "SPARK_Model" requires pragma "Elaborate_All" for "Server" + >>> body of unit "SPARK_Model" elaborated + >>> function "Func" called at line 3 + +4. end SPARK_Model; +@end example + +@node Mixing Elaboration Models,Elaboration Circularities,SPARK Elaboration Model in GNAT,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{240}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{241} +@section Mixing Elaboration Models + + +It is possible to mix units compiled with a different elaboration model, +however the following rules must be observed: @itemize * @item -Compile with the @code{-gnatws} switch set +A client unit compiled with the dynamic model can only @emph{with} a server unit +that meets at least one of the following criteria: + + +@itemize - + +@item +The server unit is compiled with the dynamic model. @item -Suppress @code{Elaboration_Check} for the called subprogram +The server unit is a GNAT implementation unit from the Ada, GNAT, +Interfaces, or System hierarchies. @item -Use pragma @code{Warnings_Off} to turn warnings off for the call +The server unit has pragma @code{Pure} or @code{Preelaborate}. + +@item +The client unit has an explicit @code{Elaborate_All} pragma for the server +unit. @end itemize +@end itemize + +These rules ensure that elaboration checks are not omitted. If the rules are +violated, the binder emits a warning: + +@example +warning: "x.ads" has dynamic elaboration checks and with's +warning: "y.ads" which has static elaboration checks +@end example -For the internal elaboration check case, -GNAT by default generates the -necessary run-time checks to ensure -that @code{Program_Error} is raised if any -call fails an elaboration check. Of course this can only happen if a -warning has been issued as described above. The use of pragma -@code{Suppress (Elaboration_Check)} may (but is not guaranteed to) suppress -some of these checks, meaning that it may be possible (but is not -guaranteed) for a program to be able to call a subprogram whose body -is not yet elaborated, without raising a @code{Program_Error} exception. +The warnings can be suppressed by binder switch @code{-ws}. -@node Controlling Elaboration in GNAT - External Calls,Default Behavior in GNAT - Ensuring Safety,Controlling Elaboration in GNAT - Internal Calls,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{236}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-elaboration-in-gnat-external-calls}@anchor{237} -@section Controlling Elaboration in GNAT - External Calls +@node Elaboration Circularities,Resolving Elaboration Circularities,Mixing Elaboration Models,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{242}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{243} +@section Elaboration Circularities -The previous section discussed the case in which the execution of a -particular thread of elaboration code occurred entirely within a -single unit. This is the easy case to handle, because a programmer -has direct and total control over the order of elaboration, and -furthermore, checks need only be generated in cases which are rare -and which the compiler can easily detect. -The situation is more complex when separate compilation is taken into account. -Consider the following: +If the binder cannot find an acceptable elaboration order, it outputs detailed +diagnostics describing an @strong{elaboration circularity}. @example -package Math is - function Sqrt (Arg : Float) return Float; -end Math; +package Server is + function Func return Integer; +end Server; +@end example -package body Math is - function Sqrt (Arg : Float) return Float is +@example +with Client; +package body Server is + function Func return Integer is begin - ... - end Sqrt; -end Math; + ... + end Func; +end Server; +@end example -with Math; -package Stuff is - X : Float := Math.Sqrt (0.5); -end Stuff; +@example +with Server; +package Client is + Val : constant Integer := Server.Func; +end Client; +@end example -with Stuff; -procedure Main is -begin - ... -end Main; +@example +with Client; +procedure Main is begin null; end Main; @end example -where @code{Main} is the main program. When this program is executed, the -elaboration code must first be executed, and one of the jobs of the -binder is to determine the order in which the units of a program are -to be elaborated. In this case we have four units: the spec and body -of @code{Math}, -the spec of @code{Stuff} and the body of @code{Main}). -In what order should the four separate sections of elaboration code -be executed? +@example +error: elaboration circularity detected +info: "server (body)" must be elaborated before "client (spec)" +info: reason: implicit Elaborate_All in unit "client (spec)" +info: recompile "client (spec)" with -gnatel for full details +info: "server (body)" +info: must be elaborated along with its spec: +info: "server (spec)" +info: which is withed by: +info: "client (spec)" +info: "client (spec)" must be elaborated before "server (body)" +info: reason: with clause +@end example + +In the example above, @code{Client} must be elaborated prior to @code{Main} by virtue +of a @emph{with} clause. The elaboration of @code{Client} invokes @code{Server.Func}, and +static model generates an implicit @code{Elaborate_All} pragma for @code{Server}. The +pragma implies that both the spec and body of @code{Server}, along with any units +they @emph{with}, must be elaborated prior to @code{Client}. However, @code{Server}'s body +@emph{with}s @code{Client}, implying that @code{Client} must be elaborated prior to +@code{Server}. The end result is that @code{Client} must be elaborated prior to +@code{Client}, and this leads to a circularity. + +@node Resolving Elaboration Circularities,Resolving Task Issues,Elaboration Circularities,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{244}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-elaboration-circularities}@anchor{245} +@section Resolving Elaboration Circularities + + +When faced with an elaboration circularity, a programmer has several options +available. -There are some restrictions in the order of elaboration that the binder -can choose. In particular, if unit U has a @emph{with} -for a package @code{X}, then you -are assured that the spec of @code{X} -is elaborated before U , but you are -not assured that the body of @code{X} -is elaborated before U. -This means that in the above case, the binder is allowed to choose the -order: + +@itemize * + +@item +@emph{Fix the program} + +The most desirable option from the point of view of long-term maintenance +is to rearrange the program so that the elaboration problems are avoided. +One useful technique is to place the elaboration code into separate child +packages. Another is to move some of the initialization code to explicitly +invoked subprograms, where the program controls the order of initialization +explicitly. Although this is the most desirable option, it may be impractical +and involve too much modification, especially in the case of complex legacy +code. + +@item +@emph{Switch to more permissive elaboration model} + +If the compilation was performed using the static model, enable the dynamic +model with compilation switch @code{-gnatE}. GNAT will no longer generate +implicit @code{Elaborate} and @code{Elaborate_All} pragmas, resulting in a behavior +identical to that specified by the Ada Reference Manual. The binder will +generate an executable program that may or may not raise @code{Program_Error}, +and it is the programmer's responsibility to ensure that it does not raise +@code{Program_Error}. + +@item +@emph{Suppress all elaboration checks} + +The drawback of run-time checks is that they generate overhead at run time, +both in space and time. If the programmer is absolutely sure that a program +will not raise an elaboration-related @code{Program_Error}, then using the +pragma @code{Suppress (Elaboration_Check)} globally (as a configuration pragma) +will eliminate all run-time checks. + +@item +@emph{Suppress elaboration checks selectively} + +If a scenario cannot possibly lead to an elaboration @code{Program_Error}, +and the binder nevertheless complains about implicit @code{Elaborate} and +@code{Elaborate_All} pragmas that lead to elaboration circularities, it +is possible to suppress the generation of implicit @code{Elaborate} and +@code{Elaborate_All} pragmas, as well as run-time checks. Clearly this can +be unsafe, and it is the responsibility of the programmer to make sure +that the resulting program has no elaboration anomalies. Pragma +@code{Suppress (Elaboration_Check)} can be used with different levels of +granularity to achieve these effects. + + +@itemize - + +@item +@emph{Target suppression} + +When the pragma is placed in a declarative part, without a second argument +naming an entity, it will suppress implicit @code{Elaborate} and +@code{Elaborate_All} pragma generation, as well as run-time checks, on all +targets within the region. @example -spec of Math -spec of Stuff -body of Math -body of Main +package Range_Suppress is + pragma Suppress (Elaboration_Check); + + function Func return Integer; + + generic + procedure Gen; + + pragma Unsuppress (Elaboration_Check); + + task type Tsk; +end Range_Suppress; @end example -but that's not good, because now the call to @code{Math.Sqrt} -that happens during -the elaboration of the @code{Stuff} -spec happens before the body of @code{Math.Sqrt} is -elaborated, and hence causes @code{Program_Error} exception to be raised. -At first glance, one might say that the binder is misbehaving, because -obviously you want to elaborate the body of something you @emph{with} first, but -that is not a general rule that can be followed in all cases. Consider - -@example -package X is ... - -package Y is ... - -with X; -package body Y is ... - -with Y; -package body X is ... -@end example - -This is a common arrangement, and, apart from the order of elaboration -problems that might arise in connection with elaboration code, this works fine. -A rule that says that you must first elaborate the body of anything you -@emph{with} cannot work in this case: -the body of @code{X} @emph{with}s @code{Y}, -which means you would have to -elaborate the body of @code{Y} first, but that @emph{with}s @code{X}, -which means -you have to elaborate the body of @code{X} first, but ... and we have a -loop that cannot be broken. - -It is true that the binder can in many cases guess an order of elaboration -that is unlikely to cause a @code{Program_Error} -exception to be raised, and it tries to do so (in the -above example of @code{Math/Stuff/Spec}, the GNAT binder will -by default -elaborate the body of @code{Math} right after its spec, so all will be well). - -However, a program that blindly relies on the binder to be helpful can -get into trouble, as we discussed in the previous sections, so GNAT -provides a number of facilities for assisting the programmer in -developing programs that are robust with respect to elaboration order. - -@node Default Behavior in GNAT - Ensuring Safety,Treatment of Pragma Elaborate,Controlling Elaboration in GNAT - External Calls,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{238}@anchor{gnat_ugn/elaboration_order_handling_in_gnat default-behavior-in-gnat-ensuring-safety}@anchor{239} -@section Default Behavior in GNAT - Ensuring Safety - - -The default behavior in GNAT ensures elaboration safety. In its -default mode GNAT implements the -rule we previously described as the right approach. Let's restate it: - -@emph{If a unit has elaboration code that can directly or indirectly make a -call to a subprogram in a |withed| unit, or instantiate a generic -package in a |withed| unit, then if the |withed| unit -does not have pragma `@w{`}Pure`@w{`} or `@w{`}Preelaborate`@w{`}, then the client should have an -`@w{`}Elaborate_All`@w{`} pragma for the |withed| unit.} - -@emph{In the case of instantiating a generic subprogram, it is always -sufficient to have only an `@w{`}Elaborate`@w{`} pragma for the -|withed| unit.} - -By following this rule a client is assured that calls and instantiations -can be made without risk of an exception. - -In this mode GNAT traces all calls that are potentially made from -elaboration code, and puts in any missing implicit @code{Elaborate} -and @code{Elaborate_All} pragmas. -The advantage of this approach is that no elaboration problems -are possible if the binder can find an elaboration order that is -consistent with these implicit @code{Elaborate} and -@code{Elaborate_All} pragmas. The -disadvantage of this approach is that no such order may exist. - -If the binder does not generate any diagnostics, then it means that it has -found an elaboration order that is guaranteed to be safe. However, the binder -may still be relying on implicitly generated @code{Elaborate} and -@code{Elaborate_All} pragmas so portability to other compilers than GNAT is not -guaranteed. - -If it is important to guarantee portability, then the compilations should -use the @code{-gnatel} -(info messages for elaboration pragmas) switch. This will cause info messages -to be generated indicating the missing @code{Elaborate} and -@code{Elaborate_All} pragmas. -Consider the following source program: +In the example above, a pair of Suppress/Unsuppress pragmas define a region +of suppression within package @code{Range_Suppress}. As a result, no implicit +@code{Elaborate} and @code{Elaborate_All} pragmas, nor any run-time checks, will +be generated by callers of @code{Func} and instantiators of @code{Gen}. Note that +task type @code{Tsk} is not within this region. + +An alternative to the region-based suppression is to use multiple +@code{Suppress} pragmas with arguments naming specific entities for which +elaboration checks should be suppressed: @example -with k; -package j is - m : integer := k.r; -end; +package Range_Suppress is + function Func return Integer; + pragma Suppress (Elaboration_Check, Func); + + generic + procedure Gen; + pragma Suppress (Elaboration_Check, Gen); + + task type Tsk; +end Range_Suppress; @end example -where it is clear that there -should be a pragma @code{Elaborate_All} -for unit @code{k}. An implicit pragma will be generated, and it is -likely that the binder will be able to honor it. However, if you want -to port this program to some other Ada compiler than GNAT. -it is safer to include the pragma explicitly in the source. If this -unit is compiled with the @code{-gnatel} -switch, then the compiler outputs an information message: - -@example -1. with k; -2. package j is -3. m : integer := k.r; - | - >>> info: call to "r" may raise Program_Error - >>> info: missing pragma Elaborate_All for "k" - -4. end; -@end example - -and these messages can be used as a guide for supplying manually -the missing pragmas. It is usually a bad idea to use this -option during development. That's because it will tell you when -you need to put in a pragma, but cannot tell you when it is time -to take it out. So the use of pragma @code{Elaborate_All} may lead to -unnecessary dependencies and even false circularities. - -This default mode is more restrictive than the Ada Reference -Manual, and it is possible to construct programs which will compile -using the dynamic model described there, but will run into a -circularity using the safer static model we have described. - -Of course any Ada compiler must be able to operate in a mode -consistent with the requirements of the Ada Reference Manual, -and in particular must have the capability of implementing the -standard dynamic model of elaboration with run-time checks. - -In GNAT, this standard mode can be achieved either by the use of -the @code{-gnatE} switch on the compiler (@code{gcc} or -@code{gnatmake}) command, or by the use of the configuration pragma: - -@example -pragma Elaboration_Checks (DYNAMIC); -@end example - -Either approach will cause the unit affected to be compiled using the -standard dynamic run-time elaboration checks described in the Ada -Reference Manual. The static model is generally preferable, since it -is clearly safer to rely on compile and link time checks rather than -run-time checks. However, in the case of legacy code, it may be -difficult to meet the requirements of the static model. This -issue is further discussed in -@ref{23a,,What to Do If the Default Elaboration Behavior Fails}. - -Note that the static model provides a strict subset of the allowed -behavior and programs of the Ada Reference Manual, so if you do -adhere to the static model and no circularities exist, -then you are assured that your program will -work using the dynamic model, providing that you remove any -pragma Elaborate statements from the source. - -@node Treatment of Pragma Elaborate,Elaboration Issues for Library Tasks,Default Behavior in GNAT - Ensuring Safety,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat treatment-of-pragma-elaborate}@anchor{23b}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{23c} -@section Treatment of Pragma Elaborate - - -@geindex Pragma Elaborate - -The use of @code{pragma Elaborate} -should generally be avoided in Ada 95 and Ada 2005 programs, -since there is no guarantee that transitive calls -will be properly handled. Indeed at one point, this pragma was placed -in Annex J (Obsolescent Features), on the grounds that it is never useful. - -Now that's a bit restrictive. In practice, the case in which -@code{pragma Elaborate} is useful is when the caller knows that there -are no transitive calls, or that the called unit contains all necessary -transitive @code{pragma Elaborate} statements, and legacy code often -contains such uses. - -Strictly speaking the static mode in GNAT should ignore such pragmas, -since there is no assurance at compile time that the necessary safety -conditions are met. In practice, this would cause GNAT to be incompatible -with correctly written Ada 83 code that had all necessary -@code{pragma Elaborate} statements in place. Consequently, we made the -decision that GNAT in its default mode will believe that if it encounters -a @code{pragma Elaborate} then the programmer knows what they are doing, -and it will trust that no elaboration errors can occur. - -The result of this decision is two-fold. First to be safe using the -static mode, you should remove all @code{pragma Elaborate} statements. -Second, when fixing circularities in existing code, you can selectively -use @code{pragma Elaborate} statements to convince the static mode of -GNAT that it need not generate an implicit @code{pragma Elaborate_All} -statement. - -When using the static mode with @code{-gnatwl}, any use of -@code{pragma Elaborate} will generate a warning about possible -problems. +@item +@emph{Scenario suppression} -@node Elaboration Issues for Library Tasks,Mixing Elaboration Models,Treatment of Pragma Elaborate,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-issues-for-library-tasks}@anchor{23d}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{23e} -@section Elaboration Issues for Library Tasks +When the pragma @code{Suppress} is placed in a declarative or statement +part, without an entity argument, it will suppress implicit @code{Elaborate} +and @code{Elaborate_All} pragma generation, as well as run-time checks, on +all scenarios within the region. +@example +with Server; +package body Range_Suppress is + pragma Suppress (Elaboration_Check); -@geindex Library tasks -@geindex elaboration issues + function Func return Integer is + begin + return Server.Func; + end Func; -@geindex Elaboration of library tasks + procedure Gen is + begin + Server.Proc; + end Gen; -In this section we examine special elaboration issues that arise for -programs that declare library level tasks. + pragma Unsuppress (Elaboration_Check); -Generally the model of execution of an Ada program is that all units are -elaborated, and then execution of the program starts. However, the -declaration of library tasks definitely does not fit this model. The -reason for this is that library tasks start as soon as they are declared -(more precisely, as soon as the statement part of the enclosing package -body is reached), that is to say before elaboration -of the program is complete. This means that if such a task calls a -subprogram, or an entry in another task, the callee may or may not be -elaborated yet, and in the standard -Reference Manual model of dynamic elaboration checks, you can even -get timing dependent Program_Error exceptions, since there can be -a race between the elaboration code and the task code. + task body Tsk is + begin + Server.Proc; + end Tsk; +end Range_Suppress; +@end example + +In the example above, a pair of Suppress/Unsuppress pragmas define a region +of suppression within package body @code{Range_Suppress}. As a result, the +calls to @code{Server.Func} in @code{Func} and @code{Server.Proc} in @code{Gen} will +not generate any implicit @code{Elaborate} and @code{Elaborate_All} pragmas or +run-time checks. +@end itemize +@end itemize + +@node Resolving Task Issues,Elaboration-related Compiler Switches,Resolving Elaboration Circularities,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{246}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-task-issues}@anchor{247} +@section Resolving Task Issues -The static model of elaboration in GNAT seeks to avoid all such -dynamic behavior, by being conservative, and the conservative -approach in this particular case is to assume that all the code -in a task body is potentially executed at elaboration time if -a task is declared at the library level. -This can definitely result in unexpected circularities. Consider -the following example +The model of execution in Ada dictates that elaboration must first take place, +and only then can the main program be started. Tasks which are activated during +elaboration violate this model and may lead to serious concurrent problems at +elaboration time. + +A task can be activated in two different ways: + + +@itemize * + +@item +The task is created by an allocator in which case it is activated immediately +after the allocator is evaluated. + +@item +The task is declared at the library level or within some nested master in +which case it is activated before starting execution of the statement +sequence of the master defining the task. +@end itemize + +Since the elaboration of a partition is performed by the environment task +servicing that partition, any tasks activated during elaboration may be in +a race with the environment task, and lead to unpredictable state and behavior. +The static model seeks to avoid such interactions by assuming that all code in +the task body is executed at elaboration time, if the task was activated by +elaboration code. @example package Decls is - task Lib_Task is - entry Start; - end Lib_Task; + task Lib_Task is + entry Start; + end Lib_Task; - type My_Int is new Integer; + type My_Int is new Integer; - function Ident (M : My_Int) return My_Int; + function Ident (M : My_Int) return My_Int; end Decls; +@end example +@example with Utils; package body Decls is - task body Lib_Task is - begin - accept Start; - Utils.Put_Val (2); - end Lib_Task; - - function Ident (M : My_Int) return My_Int is - begin - return M; - end Ident; + task body Lib_Task is + begin + accept Start; + Utils.Put_Val (2); + end Lib_Task; + + function Ident (M : My_Int) return My_Int is + begin + return M; + end Ident; end Decls; +@end example +@example with Decls; package Utils is - procedure Put_Val (Arg : Decls.My_Int); + procedure Put_Val (Arg : Decls.My_Int); end Utils; +@end example -with Text_IO; +@example +with Ada.Text_IO; use Ada.Text_IO; package body Utils is - procedure Put_Val (Arg : Decls.My_Int) is - begin - Text_IO.Put_Line (Decls.My_Int'Image (Decls.Ident (Arg))); - end Put_Val; + procedure Put_Val (Arg : Decls.My_Int) is + begin + Put_Line (Arg'Img); + end Put_Val; end Utils; +@end example +@example with Decls; procedure Main is begin Decls.Lib_Task.Start; -end; +end Main; @end example -If the above example is compiled in the default static elaboration -mode, then a circularity occurs. The circularity comes from the call -@code{Utils.Put_Val} in the task body of @code{Decls.Lib_Task}. Since -this call occurs in elaboration code, we need an implicit pragma -@code{Elaborate_All} for @code{Utils}. This means that not only must -the spec and body of @code{Utils} be elaborated before the body -of @code{Decls}, but also the spec and body of any unit that is -@emph{with}ed by the body of @code{Utils} must also be elaborated before -the body of @code{Decls}. This is the transitive implication of -pragma @code{Elaborate_All} and it makes sense, because in general -the body of @code{Put_Val} might have a call to something in a -@emph{with}ed unit. - -In this case, the body of Utils (actually its spec) @emph{with}s -@code{Decls}. Unfortunately this means that the body of @code{Decls} -must be elaborated before itself, in case there is a call from the -body of @code{Utils}. - -Here is the exact chain of events we are worrying about: - - -@itemize * +When the above example is compiled with the static model, an elaboration +circularity arises: -@item -In the body of @code{Decls} a call is made from within the body of a library -task to a subprogram in the package @code{Utils}. Since this call may -occur at elaboration time (given that the task is activated at elaboration -time), we have to assume the worst, i.e., that the -call does happen at elaboration time. - -@item -This means that the body and spec of @code{Util} must be elaborated before -the body of @code{Decls} so that this call does not cause an access before -elaboration. - -@item -Within the body of @code{Util}, specifically within the body of -@code{Util.Put_Val} there may be calls to any unit @emph{with}ed -by this package. - -@item -One such @emph{with}ed package is package @code{Decls}, so there -might be a call to a subprogram in @code{Decls} in @code{Put_Val}. -In fact there is such a call in this example, but we would have to -assume that there was such a call even if it were not there, since -we are not supposed to write the body of @code{Decls} knowing what -is in the body of @code{Utils}; certainly in the case of the -static elaboration model, the compiler does not know what is in -other bodies and must assume the worst. - -@item -This means that the spec and body of @code{Decls} must also be -elaborated before we elaborate the unit containing the call, but -that unit is @code{Decls}! This means that the body of @code{Decls} -must be elaborated before itself, and that's a circularity. -@end itemize - -Indeed, if you add an explicit pragma @code{Elaborate_All} for @code{Utils} in -the body of @code{Decls} you will get a true Ada Reference Manual -circularity that makes the program illegal. +@example +error: elaboration circularity detected +info: "decls (body)" must be elaborated before "decls (body)" +info: reason: implicit Elaborate_All in unit "decls (body)" +info: recompile "decls (body)" with -gnatel for full details +info: "decls (body)" +info: must be elaborated along with its spec: +info: "decls (spec)" +info: which is withed by: +info: "utils (spec)" +info: which is withed by: +info: "decls (body)" +@end example -In practice, we have found that problems with the static model of -elaboration in existing code often arise from library tasks, so -we must address this particular situation. +In the above example, @code{Decls} must be elaborated prior to @code{Main} by virtue +of a with clause. The elaboration of @code{Decls} activates task @code{Lib_Task}. The +static model conservatibely assumes that all code within the body of +@code{Lib_Task} is executed, and generates an implicit @code{Elaborate_All} pragma +for @code{Units} due to the call to @code{Utils.Put_Val}. The pragma implies that +both the spec and body of @code{Utils}, along with any units they @emph{with}, +must be elaborated prior to @code{Decls}. However, @code{Utils}'s spec @emph{with}s +@code{Decls}, implying that @code{Decls} must be elaborated before @code{Utils}. The end +result is that @code{Utils} must be elaborated prior to @code{Utils}, and this +leads to a circularity. -Note that if we compile and run the program above, using the dynamic model of -elaboration (that is to say use the @code{-gnatE} switch), -then it compiles, binds, -links, and runs, printing the expected result of 2. Therefore in some sense -the circularity here is only apparent, and we need to capture -the properties of this program that distinguish it from other library-level -tasks that have real elaboration problems. +In reality, the example above will not exhibit an ABE problem at run time. +When the body of task @code{Lib_Task} is activated, execution will wait for entry +@code{Start} to be accepted, and the call to @code{Utils.Put_Val} will not take place +at elaboration time. Task @code{Lib_Task} will resume its execution after the main +program is executed because @code{Main} performs a rendezvous with +@code{Lib_Task.Start}, and at that point all units have already been elaborated. +As a result, the static model may seem overly conservative, partly because it +does not take control and data flow into account. -We have four possible answers to this question: +When faced with a task elaboration circularity, a programmer has several +options available: @itemize * @item -Use the dynamic model of elaboration. +@emph{Use the dynamic model} -If we use the @code{-gnatE} switch, then as noted above, the program works. -Why is this? If we examine the task body, it is apparent that the task cannot -proceed past the -@code{accept} statement until after elaboration has been completed, because -the corresponding entry call comes from the main program, not earlier. -This is why the dynamic model works here. But that's really giving -up on a precise analysis, and we prefer to take this approach only if we cannot -solve the -problem in any other manner. So let us examine two ways to reorganize -the program to avoid the potential elaboration problem. +The dynamic model does not generate implicit @code{Elaborate} and +@code{Elaborate_All} pragmas. Instead, it will install checks prior to every +call in the example above, thus verifying the successful elaboration of +@code{Utils.Put_Val} in case the call to it takes place at elaboration time. +The dynamic model is enabled with compiler switch @code{-gnatE}. @item -Split library tasks into separate packages. +@emph{Isolate the tasks} -Write separate packages, so that library tasks are isolated from -other declarations as much as possible. Let us look at a variation on -the above program. +Relocating tasks in their own separate package could decouple them from +dependencies that would otherwise cause an elaboration circularity. The +example above can be rewritten as follows: @example -package Decls1 is - task Lib_Task is - entry Start; - end Lib_Task; +package Decls1 is -- new + task Lib_Task is + entry Start; + end Lib_Task; end Decls1; +@end example +@example with Utils; -package body Decls1 is - task body Lib_Task is - begin - accept Start; - Utils.Put_Val (2); - end Lib_Task; +package body Decls1 is -- new + task body Lib_Task is + begin + accept Start; + Utils.Put_Val (2); + end Lib_Task; end Decls1; +@end example -package Decls2 is - type My_Int is new Integer; - function Ident (M : My_Int) return My_Int; +@example +package Decls2 is -- new + type My_Int is new Integer; + function Ident (M : My_Int) return My_Int; end Decls2; +@end example +@example with Utils; -package body Decls2 is - function Ident (M : My_Int) return My_Int is - begin - return M; - end Ident; +package body Decls2 is -- new + function Ident (M : My_Int) return My_Int is + begin + return M; + end Ident; end Decls2; +@end example +@example with Decls2; package Utils is - procedure Put_Val (Arg : Decls2.My_Int); + procedure Put_Val (Arg : Decls2.My_Int); end Utils; +@end example -with Text_IO; +@example +with Ada.Text_IO; use Ada.Text_IO; package body Utils is - procedure Put_Val (Arg : Decls2.My_Int) is - begin - Text_IO.Put_Line (Decls2.My_Int'Image (Decls2.Ident (Arg))); - end Put_Val; + procedure Put_Val (Arg : Decls2.My_Int) is + begin + Put_Line (Arg'Img); + end Put_Val; end Utils; +@end example +@example with Decls1; procedure Main is begin Decls1.Lib_Task.Start; -end; +end Main; @end example -All we have done is to split @code{Decls} into two packages, one -containing the library task, and one containing everything else. Now -there is no cycle, and the program compiles, binds, links and executes -using the default static model of elaboration. - @item -Declare separate task types. +@emph{Declare the tasks} -A significant part of the problem arises because of the use of the -single task declaration form. This means that the elaboration of -the task type, and the elaboration of the task itself (i.e., the -creation of the task) happen at the same time. A good rule -of style in Ada is to always create explicit task types. By -following the additional step of placing task objects in separate -packages from the task type declaration, many elaboration problems -are avoided. Here is another modified example of the example program: +The original example uses a single task declaration for @code{Lib_Task}. An +explicit task type declaration and a properly placed task object could avoid +the dependencies that would otherwise cause an elaboration circularity. The +example can be rewritten as follows: @example package Decls is - task type Lib_Task_Type is - entry Start; - end Lib_Task_Type; + task type Lib_Task is -- new + entry Start; + end Lib_Task; - type My_Int is new Integer; + type My_Int is new Integer; - function Ident (M : My_Int) return My_Int; + function Ident (M : My_Int) return My_Int; end Decls; +@end example +@example with Utils; package body Decls is - task body Lib_Task_Type is - begin - accept Start; - Utils.Put_Val (2); - end Lib_Task_Type; - - function Ident (M : My_Int) return My_Int is - begin - return M; - end Ident; + task body Lib_Task is + begin + accept Start; + Utils.Put_Val (2); + end Lib_Task; + + function Ident (M : My_Int) return My_Int is + begin + return M; + end Ident; end Decls; +@end example +@example with Decls; package Utils is - procedure Put_Val (Arg : Decls.My_Int); + procedure Put_Val (Arg : Decls.My_Int); end Utils; +@end example -with Text_IO; +@example +with Ada.Text_IO; use Ada.Text_IO; package body Utils is - procedure Put_Val (Arg : Decls.My_Int) is - begin - Text_IO.Put_Line (Decls.My_Int'Image (Decls.Ident (Arg))); - end Put_Val; + procedure Put_Val (Arg : Decls.My_Int) is + begin + Put_Line (Arg'Img); + end Put_Val; end Utils; +@end example +@example with Decls; -package Declst is - Lib_Task : Decls.Lib_Task_Type; -end Declst; +package Obj_Decls is -- new + Task_Obj : Decls.Lib_Task; +end Obj_Decls; +@end example -with Declst; +@example +with Obj_Decls; procedure Main is begin - Declst.Lib_Task.Start; -end; + Obj_Decls.Task_Obj.Start; -- new +end Main; @end example -What we have done here is to replace the @code{task} declaration in -package @code{Decls} with a @code{task type} declaration. Then we -introduce a separate package @code{Declst} to contain the actual -task object. This separates the elaboration issues for -the @code{task type} -declaration, which causes no trouble, from the elaboration issues -of the task object, which is also unproblematic, since it is now independent -of the elaboration of @code{Utils}. -This separation of concerns also corresponds to -a generally sound engineering principle of separating declarations -from instances. This version of the program also compiles, binds, links, -and executes, generating the expected output. -@end itemize - -@geindex No_Entry_Calls_In_Elaboration_Code restriction - - -@itemize * - @item -Use No_Entry_Calls_In_Elaboration_Code restriction. - -The previous two approaches described how a program can be restructured -to avoid the special problems caused by library task bodies. in practice, -however, such restructuring may be difficult to apply to existing legacy code, -so we must consider solutions that do not require massive rewriting. +@emph{Use restriction No_Entry_Calls_In_Elaboration_Code} -Let us consider more carefully why our original sample program works -under the dynamic model of elaboration. The reason is that the code -in the task body blocks immediately on the @code{accept} -statement. Now of course there is nothing to prohibit elaboration -code from making entry calls (for example from another library level task), -so we cannot tell in isolation that -the task will not execute the accept statement during elaboration. +The issue exhibited in the original example under this section revolves +around the body of @code{Lib_Task} blocking on an accept statement. There is +no rule to prevent elaboration code from performing entry calls, however in +practice this is highly unusual. In addition, the pattern of starting tasks +at elaboration time and then immediately blocking on accept or select +statements is quite common. -However, in practice it is very unusual to see elaboration code -make any entry calls, and the pattern of tasks starting -at elaboration time and then immediately blocking on @code{accept} or -@code{select} statements is very common. What this means is that -the compiler is being too pessimistic when it analyzes the -whole package body as though it might be executed at elaboration -time. - -If we know that the elaboration code contains no entry calls, (a very safe -assumption most of the time, that could almost be made the default -behavior), then we can compile all units of the program under control -of the following configuration pragma: +If a programmer knows that elaboration code will not perform any entry +calls, then the programmer can indicate that the static model should not +process the remainder of a task body once an accept or select statement has +been encountered. This behavior can be specified by a configuration pragma: @example pragma Restrictions (No_Entry_Calls_In_Elaboration_Code); @end example -This pragma can be placed in the @code{gnat.adc} file in the usual -manner. If we take our original unmodified program and compile it -in the presence of a @code{gnat.adc} containing the above pragma, -then once again, we can compile, bind, link, and execute, obtaining -the expected result. In the presence of this pragma, the compiler does -not trace calls in a task body, that appear after the first @code{accept} -or @code{select} statement, and therefore does not report a potential -circularity in the original program. - -The compiler will check to the extent it can that the above -restriction is not violated, but it is not always possible to do a -complete check at compile time, so it is important to use this -pragma only if the stated restriction is in fact met, that is to say -no task receives an entry call before elaboration of all units is completed. +In addition to the change in behavior with respect to task bodies, the +static model will verify that no entry calls take place at elaboration time. @end itemize -@node Mixing Elaboration Models,What to Do If the Default Elaboration Behavior Fails,Elaboration Issues for Library Tasks,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{23f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{240} -@section Mixing Elaboration Models +@node Elaboration-related Compiler Switches,Summary of Procedures for Elaboration Control,Resolving Task Issues,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{248}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id15}@anchor{249} +@section Elaboration-related Compiler Switches -So far, we have assumed that the entire program is either compiled -using the dynamic model or static model, ensuring consistency. It -is possible to mix the two models, but rules have to be followed -if this mixing is done to ensure that elaboration checks are not -omitted. +GNAT has several switches that affect the elaboration model and consequently +the elaboration order chosen by the binder. -The basic rule is that -@strong{a unit compiled with the static model cannot -be |withed| by a unit compiled with the dynamic model}. -The reason for this is that in the static model, a unit assumes that -its clients guarantee to use (the equivalent of) pragma -@code{Elaborate_All} so that no elaboration checks are required -in inner subprograms, and this assumption is violated if the -client is compiled with dynamic checks. +@geindex -gnatdE (gnat) -The precise rule is as follows. A unit that is compiled with dynamic -checks can only @emph{with} a unit that meets at least one of the -following criteria: +@table @asis -@itemize * +@item @code{-gnatdE} -@item -The @emph{with}ed unit is itself compiled with dynamic elaboration -checks (that is with the @code{-gnatE} switch. +Elaboration checks on predefined units -@item -The @emph{with}ed unit is an internal GNAT implementation unit from -the System, Interfaces, Ada, or GNAT hierarchies. +When this switch is in effect, GNAT will consider scenarios and targets that +come from the Ada, GNAT, Interfaces, and System hierarchies. This switch is +useful when a programmer has defined a custom grandchild of those packages. +@end table -@item -The @emph{with}ed unit has pragma Preelaborate or pragma Pure. +@geindex -gnatd.G (gnat) -@item -The @emph{with}ing unit (that is the client) has an explicit pragma -@code{Elaborate_All} for the @emph{with}ed unit. -@end itemize -If this rule is violated, that is if a unit with dynamic elaboration -checks @emph{with}s a unit that does not meet one of the above four -criteria, then the binder (@code{gnatbind}) will issue a warning -similar to that in the following example: +@table @asis + +@item @code{-gnatd.G} + +Ignore calls through generic formal parameters for elaboration + +When this switch is in effect, GNAT will ignore calls that invoke generic +actual entries, operators, or subprograms via generic formal subprograms. As +a result, GNAT will not generate implicit @code{Elaborate} and @code{Elaborate_All} +pragmas, and run-time checks for such calls. Note that this switch does not +overlap with @code{-gnatdL}. @example -warning: "x.ads" has dynamic elaboration checks and with's -warning: "y.ads" which has static elaboration checks +package body Ignore_Calls is + function ABE return Integer; + + generic + with function Gen_Formal return Integer; + package Gen is + Val : constant Integer := Gen_Formal; + end Gen; + + package Inst is new Gen (ABE); + + function ABE return Integer is + begin + ... + end ABE; +end Ignore_Calls; @end example -These warnings indicate that the rule has been violated, and that as a result -elaboration checks may be missed in the resulting executable file. -This warning may be suppressed using the @code{-ws} binder switch -in the usual manner. +In the example above, the call to function @code{ABE} will be ignored because it +occurs during the elaboration of instance @code{Inst}, through a call to generic +formal subprogram @code{Gen_Formal}. +@end table + +@geindex -gnatdL (gnat) + -One useful application of this mixing rule is in the case of a subsystem -which does not itself @emph{with} units from the remainder of the -application. In this case, the entire subsystem can be compiled with -dynamic checks to resolve a circularity in the subsystem, while -allowing the main application that uses this subsystem to be compiled -using the more reliable default static model. +@table @asis -@node What to Do If the Default Elaboration Behavior Fails,Elaboration for Indirect Calls,Mixing Elaboration Models,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{241}@anchor{gnat_ugn/elaboration_order_handling_in_gnat what-to-do-if-the-default-elaboration-behavior-fails}@anchor{23a} -@section What to Do If the Default Elaboration Behavior Fails +@item @code{-gnatdL} +Ignore external calls from instances for elaboration -If the binder cannot find an acceptable order, it outputs detailed -diagnostics. For example: +When this switch is in effect, GNAT will ignore calls that originate from +within an instance and directly target an entry, operator, or subprogram +defined outside the instance. As a result, GNAT will not generate implicit +@code{Elaborate} and @code{Elaborate_All} pragmas, and run-time checks for such +calls. Note that this switch does not overlap with @code{-gnatd.G}. @example -error: elaboration circularity detected -info: "proc (body)" must be elaborated before "pack (body)" -info: reason: Elaborate_All probably needed in unit "pack (body)" -info: recompile "pack (body)" with -gnatel -info: for full details -info: "proc (body)" -info: is needed by its spec: -info: "proc (spec)" -info: which is withed by: -info: "pack (body)" -info: "pack (body)" must be elaborated before "proc (body)" -info: reason: pragma Elaborate in unit "proc (body)" -@end example - -In this case we have a cycle that the binder cannot break. On the one -hand, there is an explicit pragma Elaborate in @code{proc} for -@code{pack}. This means that the body of @code{pack} must be elaborated -before the body of @code{proc}. On the other hand, there is elaboration -code in @code{pack} that calls a subprogram in @code{proc}. This means -that for maximum safety, there should really be a pragma -Elaborate_All in @code{pack} for @code{proc} which would require that -the body of @code{proc} be elaborated before the body of -@code{pack}. Clearly both requirements cannot be satisfied. -Faced with a circularity of this kind, you have three different options. +package body Ignore_Calls is + function ABE return Integer; + generic + package Gen is + Val : constant Integer := ABE; + end Gen; -@itemize * + package Inst is new Gen; -@item -@emph{Fix the program} + function ABE return Integer is + begin + ... + end ABE; +end Ignore_Calls; +@end example -The most desirable option from the point of view of long-term maintenance -is to rearrange the program so that the elaboration problems are avoided. -One useful technique is to place the elaboration code into separate -child packages. Another is to move some of the initialization code to -explicitly called subprograms, where the program controls the order -of initialization explicitly. Although this is the most desirable option, -it may be impractical and involve too much modification, especially in -the case of complex legacy code. +In the example above, the call to function @code{ABE} will be ignored because it +originates from within an instance and targets a subprogram defined outside +the instance. +@end table -@item -@emph{Perform dynamic checks} +@geindex -gnatd.o (gnat) -If the compilations are done using the @code{-gnatE} -(dynamic elaboration check) switch, then GNAT behaves in a quite different -manner. Dynamic checks are generated for all calls that could possibly result -in raising an exception. With this switch, the compiler does not generate -implicit @code{Elaborate} or @code{Elaborate_All} pragmas. The behavior then is -exactly as specified in the @cite{Ada Reference Manual}. -The binder will generate -an executable program that may or may not raise @code{Program_Error}, and then -it is the programmer's job to ensure that it does not raise an exception. Note -that it is important to compile all units with the switch, it cannot be used -selectively. -@item -@emph{Suppress checks} +@table @asis -The drawback of dynamic checks is that they generate a -significant overhead at run time, both in space and time. If you -are absolutely sure that your program cannot raise any elaboration -exceptions, and you still want to use the dynamic elaboration model, -then you can use the configuration pragma -@code{Suppress (Elaboration_Check)} to suppress all such checks. For -example this pragma could be placed in the @code{gnat.adc} file. +@item @code{-gnatd.o} -@item -@emph{Suppress checks selectively} +Conservative elaboration order for indirect calls -When you know that certain calls or instantiations in elaboration code cannot -possibly lead to an elaboration error, and the binder nevertheless complains -about implicit @code{Elaborate} and @code{Elaborate_All} pragmas that lead to -elaboration circularities, it is possible to remove those warnings locally and -obtain a program that will bind. Clearly this can be unsafe, and it is the -responsibility of the programmer to make sure that the resulting program has no -elaboration anomalies. The pragma @code{Suppress (Elaboration_Check)} can be -used with different granularity to suppress warnings and break elaboration -circularities: +When this switch is in effect, GNAT will treat @code{'Access} of an entry, +operator, or subprogram as an immediate call to that target. As a result, +GNAT will generate implicit @code{Elaborate} and @code{Elaborate_All} pragmas as +well as run-time checks for such attribute references. +@example + 1. package body Attribute_Call is + 2. function Func return Integer; + 3. type Func_Ptr is access function return Integer; + 4. + 5. Ptr : constant Func_Ptr := Func'Access; + | + >>> warning: cannot call "Func" before body seen + >>> warning: Program_Error may be raised at run time + >>> warning: body of unit "Attribute_Call" elaborated + >>> warning: "Access" of "Func" taken at line 5 + >>> warning: function "Func" called at line 5 -@itemize * + 6. + 7. function Func return Integer is + 8. begin + 9. ... +10. end Func; +11. end Attribute_Call; +@end example -@item -Place the pragma that names the called subprogram in the declarative part -that contains the call. +In the example above, the elaboration of declaration @code{Ptr} is assigned +@code{Func'Access} before the body of @code{Func} has been elaborated. +@end table -@item -Place the pragma in the declarative part, without naming an entity. This -disables warnings on all calls in the corresponding declarative region. +@geindex -gnatd.U (gnat) -@item -Place the pragma in the package spec that declares the called subprogram, -and name the subprogram. This disables warnings on all elaboration calls to -that subprogram. -@item -Place the pragma in the package spec that declares the called subprogram, -without naming any entity. This disables warnings on all elaboration calls to -all subprograms declared in this spec. +@table @asis -@item -Use Pragma Elaborate. +@item @code{-gnatd.U} -As previously described in section @ref{23b,,Treatment of Pragma Elaborate}, -GNAT in static mode assumes that a @code{pragma} Elaborate indicates correctly -that no elaboration checks are required on calls to the designated unit. -There may be cases in which the caller knows that no transitive calls -can occur, so that a @code{pragma Elaborate} will be sufficient in a -case where @code{pragma Elaborate_All} would cause a circularity. -@end itemize +Ignore indirect calls for static elaboration -These five cases are listed in order of decreasing safety, and therefore -require increasing programmer care in their application. Consider the -following program: +When this switch is in effect, GNAT will ignore @code{'Access} of an entry, +operator, or subprogram when the static model is in effect. +@end table -@example -package Pack1 is - function F1 return Integer; - X1 : Integer; -end Pack1; +@geindex -gnatd.y (gnat) -package Pack2 is - function F2 return Integer; - function Pure (x : integer) return integer; - -- pragma Suppress (Elaboration_Check, On => Pure); -- (3) - -- pragma Suppress (Elaboration_Check); -- (4) -end Pack2; -with Pack2; -package body Pack1 is - function F1 return Integer is - begin - return 100; - end F1; - Val : integer := Pack2.Pure (11); -- Elab. call (1) -begin - declare - -- pragma Suppress(Elaboration_Check, Pack2.F2); -- (1) - -- pragma Suppress(Elaboration_Check); -- (2) - begin - X1 := Pack2.F2 + 1; -- Elab. call (2) - end; -end Pack1; +@table @asis -with Pack1; -package body Pack2 is - function F2 return Integer is - begin - return Pack1.F1; - end F2; - function Pure (x : integer) return integer is - begin - return x ** 3 - 3 * x; - end; -end Pack2; +@item @code{-gnatd.y} -with Pack1, Ada.Text_IO; -procedure Proc3 is -begin - Ada.Text_IO.Put_Line(Pack1.X1'Img); -- 101 -end Proc3; -@end example +Disable implicit pragma Elaborate[_All] on task bodies -In the absence of any pragmas, an attempt to bind this program produces -the following diagnostics: +When this switch is in effect, GNAT will not generate @code{Elaborate} and +@code{Elaborate_All} pragmas if the need for the pragma came directly or +indirectly from a task body. @example -error: elaboration circularity detected -info: "pack1 (body)" must be elaborated before "pack1 (body)" -info: reason: Elaborate_All probably needed in unit "pack1 (body)" -info: recompile "pack1 (body)" with -gnatel for full details -info: "pack1 (body)" -info: must be elaborated along with its spec: -info: "pack1 (spec)" -info: which is withed by: -info: "pack2 (body)" -info: which must be elaborated along with its spec: -info: "pack2 (spec)" -info: which is withed by: -info: "pack1 (body)" +with Server; +package body Disable_Task is + task T; + + task body T is + begin + Server.Proc; + end T; +end Disable_Task; @end example -The sources of the circularity are the two calls to @code{Pack2.Pure} and -@code{Pack2.F2} in the body of @code{Pack1}. We can see that the call to -F2 is safe, even though F2 calls F1, because the call appears after the -elaboration of the body of F1. Therefore the pragma (1) is safe, and will -remove the warning on the call. It is also possible to use pragma (2) -because there are no other potentially unsafe calls in the block. +In the example above, the activation of single task @code{T} invokes +@code{Server.Proc}, which implies that @code{Server} requires @code{Elaborate_All}, +however GNAT will not generate the pragma. +@end table -The call to @code{Pure} is safe because this function does not depend on the -state of @code{Pack2}. Therefore any call to this function is safe, and it -is correct to place pragma (3) in the corresponding package spec. +@geindex -gnatE (gnat) -Finally, we could place pragma (4) in the spec of @code{Pack2} to disable -warnings on all calls to functions declared therein. Note that this is not -necessarily safe, and requires more detailed examination of the subprogram -bodies involved. In particular, a call to @code{F2} requires that @code{F1} -be already elaborated. -@end itemize -It is hard to generalize on which of these four approaches should be -taken. Obviously if it is possible to fix the program so that the default -treatment works, this is preferable, but this may not always be practical. -It is certainly simple enough to use @code{-gnatE} -but the danger in this case is that, even if the GNAT binder -finds a correct elaboration order, it may not always do so, -and certainly a binder from another Ada compiler might not. A -combination of testing and analysis (for which the -information messages generated with the @code{-gnatel} -switch can be useful) must be used to ensure that the program is free -of errors. One switch that is useful in this testing is the -@code{-p} (pessimistic elaboration order) switch for @code{gnatbind}. -Normally the binder tries to find an order that has the best chance -of avoiding elaboration problems. However, if this switch is used, the binder -plays a devil's advocate role, and tries to choose the order that -has the best chance of failing. If your program works even with this -switch, then it has a better chance of being error free, but this is still -not a guarantee. - -For an example of this approach in action, consider the C-tests (executable -tests) from the ACATS suite. If these are compiled and run with the default -treatment, then all but one of them succeed without generating any error -diagnostics from the binder. However, there is one test that fails, and -this is not surprising, because the whole point of this test is to ensure -that the compiler can handle cases where it is impossible to determine -a correct order statically, and it checks that an exception is indeed -raised at run time. - -This one test must be compiled and run using the @code{-gnatE} -switch, and then it passes. Alternatively, the entire suite can -be run using this switch. It is never wrong to run with the dynamic -elaboration switch if your code is correct, and we assume that the -C-tests are indeed correct (it is less efficient, but efficiency is -not a factor in running the ACATS tests.) - -@node Elaboration for Indirect Calls,Summary of Procedures for Elaboration Control,What to Do If the Default Elaboration Behavior Fails,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{242}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-for-indirect-calls}@anchor{243} -@section Elaboration for Indirect Calls - - -@geindex Dispatching calls - -@geindex Indirect calls - -In rare cases, the static elaboration model fails to prevent -dispatching calls to not-yet-elaborated subprograms. In such cases, we -fall back to run-time checks; premature calls to any primitive -operation of a tagged type before the body of the operation has been -elaborated will raise @code{Program_Error}. - -Access-to-subprogram types, however, are handled conservatively in many -cases. This was not true in earlier versions of the compiler; you can use -the @code{-gnatd.U} debug switch to revert to the old behavior if the new -conservative behavior causes elaboration cycles. Here, 'conservative' means -that if you do @code{P'Access} during elaboration, the compiler will normally -assume that you might call @code{P} indirectly during elaboration, so it adds an -implicit @code{pragma Elaborate_All} on the library unit containing @code{P}. The -@code{-gnatd.U} switch is safe if you know there are no such calls. If the -program worked before, it will continue to work with @code{-gnatd.U}. But beware -that code modifications such as adding an indirect call can cause erroneous -behavior in the presence of @code{-gnatd.U}. - -These implicit Elaborate_All pragmas are not added in all cases, because -they cause elaboration cycles in certain common code patterns. If you want -even more conservative handling of P'Access, you can use the @code{-gnatd.o} -switch. +@table @asis -See @code{debug.adb} for documentation on the @code{-gnatd...} debug switches. +@item @code{-gnatE} -@node Summary of Procedures for Elaboration Control,Other Elaboration Order Considerations,Elaboration for Indirect Calls,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{244}@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{245} -@section Summary of Procedures for Elaboration Control +Dynamic elaboration checking mode enabled +When this switch is in effect, GNAT activates the dynamic elaboration model. +@end table -@geindex Elaboration control +@geindex -gnatel (gnat) -First, compile your program with the default options, using none of -the special elaboration-control switches. If the binder successfully -binds your program, then you can be confident that, apart from issues -raised by the use of access-to-subprogram types and dynamic dispatching, -the program is free of elaboration errors. If it is important that the -program be portable to other compilers than GNAT, then use the -@code{-gnatel} -switch to generate messages about missing @code{Elaborate} or -@code{Elaborate_All} pragmas, and supply the missing pragmas. - -If the program fails to bind using the default static elaboration -handling, then you can fix the program to eliminate the binder -message, or recompile the entire program with the -@code{-gnatE} switch to generate dynamic elaboration checks, -and, if you are sure there really are no elaboration problems, -use a global pragma @code{Suppress (Elaboration_Check)}. - -@node Other Elaboration Order Considerations,Determining the Chosen Elaboration Order,Summary of Procedures for Elaboration Control,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{246}@anchor{gnat_ugn/elaboration_order_handling_in_gnat other-elaboration-order-considerations}@anchor{247} -@section Other Elaboration Order Considerations - - -This section has been entirely concerned with the issue of finding a valid -elaboration order, as defined by the Ada Reference Manual. In a case -where several elaboration orders are valid, the task is to find one -of the possible valid elaboration orders (and the static model in GNAT -will ensure that this is achieved). - -The purpose of the elaboration rules in the Ada Reference Manual is to -make sure that no entity is accessed before it has been elaborated. For -a subprogram, this means that the spec and body must have been elaborated -before the subprogram is called. For an object, this means that the object -must have been elaborated before its value is read or written. A violation -of either of these two requirements is an access before elaboration order, -and this section has been all about avoiding such errors. - -In the case where more than one order of elaboration is possible, in the -sense that access before elaboration errors are avoided, then any one of -the orders is 'correct' in the sense that it meets the requirements of -the Ada Reference Manual, and no such error occurs. - -However, it may be the case for a given program, that there are -constraints on the order of elaboration that come not from consideration -of avoiding elaboration errors, but rather from extra-lingual logic -requirements. Consider this example: - -@example -with Init_Constants; -package Constants is - X : Integer := 0; - Y : Integer := 0; -end Constants; - -package Init_Constants is - procedure P; --* require a body* -end Init_Constants; - -with Constants; -package body Init_Constants is - procedure P is begin null; end; -begin - Constants.X := 3; - Constants.Y := 4; -end Init_Constants; -with Constants; -package Calc is - Z : Integer := Constants.X + Constants.Y; -end Calc; +@table @asis -with Calc; -with Text_IO; use Text_IO; -procedure Main is -begin - Put_Line (Calc.Z'Img); -end Main; -@end example +@item @code{-gnatel} -In this example, there is more than one valid order of elaboration. For -example both the following are correct orders: +Turn on info messages on generated Elaborate[_All] pragmas -@example -Init_Constants spec -Constants spec -Calc spec -Init_Constants body -Main body -@end example +When this switch is in effect, GNAT will emit the following supplementary +information depending on the elaboration model in effect. -and -@example -Init_Constants spec -Constants spec -Init_Constants body -Calc spec -Main body -@end example +@itemize - + +@item +@emph{Dynamic model} -There is no language rule to prefer one or the other, both are correct -from an order of elaboration point of view. But the programmatic effects -of the two orders are very different. In the first, the elaboration routine -of @code{Calc} initializes @code{Z} to zero, and then the main program -runs with this value of zero. But in the second order, the elaboration -routine of @code{Calc} runs after the body of Init_Constants has set -@code{X} and @code{Y} and thus @code{Z} is set to 7 before @code{Main} runs. +GNAT will indicate missing @code{Elaborate} and @code{Elaborate_All} pragmas for +all library-level scenarios within the partition. -One could perhaps by applying pretty clever non-artificial intelligence -to the situation guess that it is more likely that the second order of -elaboration is the one desired, but there is no formal linguistic reason -to prefer one over the other. In fact in this particular case, GNAT will -prefer the second order, because of the rule that bodies are elaborated -as soon as possible, but it's just luck that this is what was wanted -(if indeed the second order was preferred). +@item +@emph{Static model} -If the program cares about the order of elaboration routines in a case like -this, it is important to specify the order required. In this particular -case, that could have been achieved by adding to the spec of Calc: +GNAT will indicate all scenarios executed during elaboration. In addition, +it will provide detailed traceback when an implicit @code{Elaborate} or +@code{Elaborate_All} pragma is generated. + +@item +@emph{SPARK model} + +GNAT will indicate how an elaboration requirement is met by the context of +a unit. @example -pragma Elaborate_All (Constants); +1. with Server; pragma Elaborate_All (Server); +2. package Client with SPARK_Mode is +3. Val : constant Integer := Server.Func; + | + >>> info: call to "Func" during elaboration in SPARK + >>> info: "Elaborate_All" requirement for unit "Server" met by pragma at line 1 + +4. end Client; @end example +@end itemize +@end table + +@geindex -gnatw.f (gnat) -which requires that the body (if any) and spec of @code{Constants}, -as well as the body and spec of any unit @emph{with}ed by -@code{Constants} be elaborated before @code{Calc} is elaborated. -Clearly no automatic method can always guess which alternative you require, -and if you are working with legacy code that had constraints of this kind -which were not properly specified by adding @code{Elaborate} or -@code{Elaborate_All} pragmas, then indeed it is possible that two different -compilers can choose different orders. +@table @asis + +@item @code{-gnatw.f} -However, GNAT does attempt to diagnose the common situation where there -are uninitialized variables in the visible part of a package spec, and the -corresponding package body has an elaboration block that directly or -indirectly initializes one or more of these variables. This is the situation -in which a pragma Elaborate_Body is usually desirable, and GNAT will generate -a warning that suggests this addition if it detects this situation. +Turn on warnings for suspicious Subp'Access -The @code{gnatbind` :switch:`-p` switch may be useful in smoking -out problems. This switch causes bodies to be elaborated as late as possible -instead of as early as possible. In the example above, it would have forced -the choice of the first elaboration order. If you get different results -when using this switch, and particularly if one set of results is right, -and one is wrong as far as you are concerned, it shows that you have some -missing `@w{`}Elaborate} pragmas. For the example above, we have the -following output: +When this switch is in effect, GNAT will treat @code{'Access} of an entry, +operator, or subprogram as a potential call to the target and issue warnings: @example -$ gnatmake -f -q main -$ main - 7 -$ gnatmake -f -q main -bargs -p -$ main - 0 + 1. package body Attribute_Call is + 2. function Func return Integer; + 3. type Func_Ptr is access function return Integer; + 4. + 5. Ptr : constant Func_Ptr := Func'Access; + | + >>> warning: "Access" attribute of "Func" before body seen + >>> warning: possible Program_Error on later references + >>> warning: body of unit "Attribute_Call" elaborated + >>> warning: "Access" of "Func" taken at line 5 + + 6. + 7. function Func return Integer is + 8. begin + 9. ... +10. end Func; +11. end Attribute_Call; @end example -It is of course quite unlikely that both these results are correct, so -it is up to you in a case like this to investigate the source of the -difference, by looking at the two elaboration orders that are chosen, -and figuring out which is correct, and then adding the necessary -@code{Elaborate} or @code{Elaborate_All} pragmas to ensure the desired order. +In the example above, the elaboration of declaration @code{Ptr} is assigned +@code{Func'Access} before the body of @code{Func} has been elaborated. +@end table + +@node Summary of Procedures for Elaboration Control,Inspecting the Chosen Elaboration Order,Elaboration-related Compiler Switches,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{24a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id16}@anchor{24b} +@section Summary of Procedures for Elaboration Control + + +A programmer should first compile the program with the default options, using +none of the binder or compiler switches. If the binder succeeds in finding an +elaboration order, then apart from possible cases involing dispatching calls +and access-to-subprogram types, the program is free of elaboration errors. +If it is important for the program to be portable to compilers other than GNAT, +then the programmer should use compilation switch @code{-gnatel} and +consider the messages about missing or implicitly created @code{Elaborate} and +@code{Elaborate_All} pragmas. -@node Determining the Chosen Elaboration Order,,Other Elaboration Order Considerations,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat determining-the-chosen-elaboration-order}@anchor{248}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id15}@anchor{249} -@section Determining the Chosen Elaboration Order +If the binder reports an elaboration circularity, the programmer has several +options: -To see the elaboration order that the binder chooses, you can look at -the last part of the file:@cite{b~xxx.adb} binder output file. Here is an example: +@itemize * + +@item +Ensure that warnings are enabled. This will allow the static model to output +trace information of elaboration issues. The trace information could shed +light on previously unforeseen dependencies, as well as their origins. + +@item +Use switch @code{-gnatel} to obtain messages on generated implicit +@code{Elaborate} and @code{Elaborate_All} pragmas. The trace information could +indicate why a server unit must be elaborated prior to a client unit. + +@item +If the warnings produced by the static model indicate that a task is +involved, consider the options in the section on resolving task issues as +well as compiler switch @code{-gnatd.y}. + +@item +If the warnings produced by the static model indicate that an generic +instantiations are involved, consider using compiler switches +@code{-gnatd.G} and @code{-gnatdL}. + +@item +If none of the steps outlined above resolve the circularity, recompile the +program using the dynamic model by using compiler switch @code{-gnatE}. +@end itemize + +@node Inspecting the Chosen Elaboration Order,,Summary of Procedures for Elaboration Control,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat inspecting-the-chosen-elaboration-order}@anchor{24c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id17}@anchor{24d} +@section Inspecting the Chosen Elaboration Order + + +To see the elaboration order chosen by the binder, inspect the contents of file +@cite{b~xxx.adb}. On certain targets, this file appears as @cite{b_xxx.adb}. The +elaboration order appears as a sequence of calls to @code{Elab_Body} and +@code{Elab_Spec}, interspersed with assignments to @cite{Exxx} which indicates that a +particular unit is elaborated. For example: @example System.Soft_Links'Elab_Body; @@ -28909,14 +28928,8 @@ Ada.Text_Io'Elab_Body; E07 := True; @end example -Here Elab_Spec elaborates the spec -and Elab_Body elaborates the body. The assignments to the @code{E@emph{xx}} flags -flag that the corresponding body is now elaborated. - -You can also ask the binder to generate a more -readable list of the elaboration order using the -@code{-l} switch when invoking the binder. Here is -an example of the output generated by this switch: +Note also binder switch @code{-l}, which outputs the chosen elaboration +order and provides a more readable form of the above: @example ada (spec) @@ -29006,7 +29019,7 @@ gdbstr (body) @end example @node Inline Assembler,GNU Free Documentation License,Elaboration Order Handling in GNAT,Top -@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10}@anchor{gnat_ugn/inline_assembler doc}@anchor{24a}@anchor{gnat_ugn/inline_assembler id1}@anchor{24b} +@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10}@anchor{gnat_ugn/inline_assembler doc}@anchor{24e}@anchor{gnat_ugn/inline_assembler id1}@anchor{24f} @chapter Inline Assembler @@ -29065,7 +29078,7 @@ and with assembly language programming. @end menu @node Basic Assembler Syntax,A Simple Example of Inline Assembler,,Inline Assembler -@anchor{gnat_ugn/inline_assembler id2}@anchor{24c}@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{24d} +@anchor{gnat_ugn/inline_assembler id2}@anchor{250}@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{251} @section Basic Assembler Syntax @@ -29181,7 +29194,7 @@ Intel: Destination first; for example @code{mov eax, 4}@w{ } @node A Simple Example of Inline Assembler,Output Variables in Inline Assembler,Basic Assembler Syntax,Inline Assembler -@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{24e}@anchor{gnat_ugn/inline_assembler id3}@anchor{24f} +@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{252}@anchor{gnat_ugn/inline_assembler id3}@anchor{253} @section A Simple Example of Inline Assembler @@ -29330,7 +29343,7 @@ If there are no errors, @code{as} will generate an object file @code{nothing.out}. @node Output Variables in Inline Assembler,Input Variables in Inline Assembler,A Simple Example of Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id4}@anchor{250}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{251} +@anchor{gnat_ugn/inline_assembler id4}@anchor{254}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{255} @section Output Variables in Inline Assembler @@ -29697,7 +29710,7 @@ end Get_Flags_3; @end quotation @node Input Variables in Inline Assembler,Inlining Inline Assembler Code,Output Variables in Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id5}@anchor{252}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{253} +@anchor{gnat_ugn/inline_assembler id5}@anchor{256}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{257} @section Input Variables in Inline Assembler @@ -29786,7 +29799,7 @@ _increment__incr.1: @end quotation @node Inlining Inline Assembler Code,Other Asm Functionality,Input Variables in Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id6}@anchor{254}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{255} +@anchor{gnat_ugn/inline_assembler id6}@anchor{258}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{259} @section Inlining Inline Assembler Code @@ -29857,7 +29870,7 @@ movl %esi,%eax thus saving the overhead of stack frame setup and an out-of-line call. @node Other Asm Functionality,,Inlining Inline Assembler Code,Inline Assembler -@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{256}@anchor{gnat_ugn/inline_assembler id7}@anchor{257} +@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{25a}@anchor{gnat_ugn/inline_assembler id7}@anchor{25b} @section Other @code{Asm} Functionality @@ -29872,7 +29885,7 @@ and @code{Volatile}, which inhibits unwanted optimizations. @end menu @node The Clobber Parameter,The Volatile Parameter,,Other Asm Functionality -@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{258}@anchor{gnat_ugn/inline_assembler id8}@anchor{259} +@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{25c}@anchor{gnat_ugn/inline_assembler id8}@anchor{25d} @subsection The @code{Clobber} Parameter @@ -29936,7 +29949,7 @@ Use 'register' name @code{memory} if you changed a memory location @end itemize @node The Volatile Parameter,,The Clobber Parameter,Other Asm Functionality -@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{25a}@anchor{gnat_ugn/inline_assembler id9}@anchor{25b} +@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{25e}@anchor{gnat_ugn/inline_assembler id9}@anchor{25f} @subsection The @code{Volatile} Parameter @@ -29972,7 +29985,7 @@ to @code{True} only if the compiler's optimizations have created problems. @node GNU Free Documentation License,Index,Inline Assembler,Top -@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{25c}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{25d} +@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{260}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{261} @chapter GNU Free Documentation License diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index 9373f9519e7..8de6f355d0c 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -62,7 +62,9 @@ package body Lib is Yes_After, -- S1 is in same extended unit as S2, and appears after it No); -- S2 is not in same extended unit as S2 - function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result; + function Check_Same_Extended_Unit + (S1 : Source_Ptr; + S2 : Source_Ptr) return SEU_Result; -- Used by In_Same_Extended_Unit and Earlier_In_Extended_Unit. Returns -- value as described above. @@ -273,7 +275,10 @@ package body Lib is -- Check_Same_Extended_Unit -- ------------------------------ - function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result is + function Check_Same_Extended_Unit + (S1 : Source_Ptr; + S2 : Source_Ptr) return SEU_Result + is Max_Iterations : constant Nat := Maximum_Instantiations * 2; -- Limit to prevent a potential infinite loop @@ -459,6 +464,7 @@ package body Lib is -- Prevent looping forever if Counter > Max_Iterations then + -- ??? Not quite right, but return a value to be able to generate -- SCIL files and hope for the best. @@ -502,11 +508,22 @@ package body Lib is -- Earlier_In_Extended_Unit -- ------------------------------ - function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is + function Earlier_In_Extended_Unit + (S1 : Source_Ptr; + S2 : Source_Ptr) return Boolean + is begin return Check_Same_Extended_Unit (S1, S2) = Yes_Before; end Earlier_In_Extended_Unit; + function Earlier_In_Extended_Unit + (N1 : Node_Or_Entity_Id; + N2 : Node_Or_Entity_Id) return Boolean + is + begin + return Earlier_In_Extended_Unit (Sloc (N1), Sloc (N2)); + end Earlier_In_Extended_Unit; + ----------------------- -- Exact_Source_Name -- ----------------------- @@ -747,7 +764,9 @@ package body Lib is begin return Get_Code_Or_Source_Unit - (S, Unwind_Instances => True, Unwind_Subunits => False); + (S => S, + Unwind_Instances => True, + Unwind_Subunits => False); end Get_Source_Unit; function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is @@ -807,8 +826,7 @@ package body Lib is -- Node may be in spec (or subunit etc) of main unit else - return - In_Same_Extended_Unit (N, Cunit (Main_Unit)); + return In_Same_Extended_Unit (N, Cunit (Main_Unit)); end if; end In_Extended_Main_Code_Unit; @@ -828,8 +846,7 @@ package body Lib is -- Location may be in spec (or subunit etc) of main unit else - return - In_Same_Extended_Unit (Loc, Sloc (Cunit (Main_Unit))); + return In_Same_Extended_Unit (Loc, Sloc (Cunit (Main_Unit))); end if; end In_Extended_Main_Code_Unit; diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index a5b9858eaa9..be6864a3e83 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -481,13 +481,20 @@ package Lib is -- avoid registering switches added automatically by the gcc driver at the -- end of the command line. - function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean; + function Earlier_In_Extended_Unit + (S1 : Source_Ptr; + S2 : Source_Ptr) return Boolean; -- Given two Sloc values for which In_Same_Extended_Unit is true, determine -- if S1 appears before S2. Returns True if S1 appears before S2, and False -- otherwise. The result is undefined if S1 and S2 are not in the same -- extended unit. Note: this routine will not give reliable results if -- called after Sprint has been called with -gnatD set. + function Earlier_In_Extended_Unit + (N1 : Node_Or_Entity_Id; + N2 : Node_Or_Entity_Id) return Boolean; + -- Same as above, but the inputs denote nodes or entities + procedure Enable_Switch_Storing; -- Enable registration of switches by Store_Compilation_Switch. Used to -- avoid registering switches added automatically by the gcc driver at the diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index e121e596913..aaa3ccb2e40 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -612,6 +612,12 @@ package body Sem is when N_With_Clause => Analyze_With_Clause (N); + -- A call to analyze a call marker is ignored because the node does + -- not have any static and run-time semantics. + + when N_Call_Marker => + null; + -- A call to analyze the Empty node is an error, but most likely it -- is an error caused by an attempt to analyze a malformed piece of -- tree caused by some other error, so if there have been any other @@ -1242,6 +1248,15 @@ package body Sem is Scope_Stack.Locked := True; end Lock; + ------------------------ + -- Preanalysis_Active -- + ------------------------ + + function Preanalysis_Active return Boolean is + begin + return not Full_Analysis and not Expander_Active; + end Preanalysis_Active; + ---------------- -- Preanalyze -- ---------------- diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index fca920a8a00..500f9220fd2 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -683,6 +683,10 @@ package Sem is -- This function returns True if an explicit pragma Suppress for check C -- is present in the package defining E. + function Preanalysis_Active return Boolean; + pragma Inline (Preanalysis_Active); + -- Determine whether preanalysis is active at the point of invocation + procedure Preanalyze (N : Node_Id); -- Performs a pre-analysis of node N. During pre-analysis no expansion is -- carried out for N or its children. For more info on pre-analysis read diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 5bedc6c8c12..5aef17df8ec 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -28,7 +28,6 @@ with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; with Atree; use Atree; with Casing; use Casing; with Checks; use Checks; -with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; @@ -806,6 +805,20 @@ package body Sem_Attr is ("prefix of % attribute cannot be enumeration literal"); end if; + -- Preserve relevant elaboration-related attributes of the context + -- which are no longer available or very expensive to recompute once + -- analysis, resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => N, + Checks => True, + Modes => True); + + -- Save the scenario for later examination by the ABE Processing + -- phase. + + Record_Elaboration_Scenario (N); + -- Case of access to subprogram if Is_Entity_Name (P) and then Is_Overloadable (Entity (P)) then @@ -860,14 +873,6 @@ package body Sem_Attr is Kill_Current_Values; end if; - -- In the static elaboration model, treat the attribute reference - -- as a call for elaboration purposes. Suppress this treatment - -- under debug flag. In any case, we are all done. - - if not Dynamic_Elaboration_Checks and not Debug_Flag_Dot_UU then - Check_Elab_Call (N); - end if; - return; -- Component is an operation of a protected type @@ -11133,8 +11138,8 @@ package body Sem_Attr is -- 'Unrestricted_Access or in case of a subprogram. if Is_Entity_Name (P) - and then (Attr_Id = Attribute_Unrestricted_Access - or else Is_Subprogram (Entity (P))) + and then (Attr_Id = Attribute_Unrestricted_Access + or else Is_Subprogram (Entity (P))) then Set_Address_Taken (Entity (P)); end if; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index aeec421b5a3..9f538e06438 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -839,6 +839,10 @@ package body Sem_Ch12 is -- entity is marked as having a limited_view actual when some actual is -- a limited view. This is used to place the instance body properly. + procedure Provide_Completing_Bodies (N : Node_Id); + -- Generate completing bodies for all subprograms found within package or + -- subprogram declaration N. + procedure Remove_Parent (In_Body : Boolean := False); -- Reverse effect after instantiation of child is complete @@ -3542,6 +3546,14 @@ package body Sem_Ch12 is Set_SPARK_Pragma_Inherited (Id); Set_SPARK_Aux_Pragma_Inherited (Id); + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => Id, + Checks => True); + -- Analyze aspects now, so that generated pragmas appear in the -- declarations before building and analyzing the generic copy. @@ -3670,7 +3682,7 @@ package body Sem_Ch12 is Create_Generic_Contract (N); Spec := Specification (N); - Id := Defining_Entity (Spec); + Id := Defining_Entity (Spec); Generate_Definition (Id); if Nkind (Id) = N_Defining_Operator_Symbol then @@ -3697,14 +3709,27 @@ package body Sem_Ch12 is Analyze_Generic_Formal_Part (N); - Formals := Parameter_Specifications (Spec); - if Nkind (Spec) = N_Function_Specification then Set_Ekind (Id, E_Generic_Function); else Set_Ekind (Id, E_Generic_Procedure); end if; + -- Set SPARK_Mode from context + + Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); + Set_SPARK_Pragma_Inherited (Id); + + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => Id, + Checks => True); + + Formals := Parameter_Specifications (Spec); + if Present (Formals) then Process_Formals (Formals, Spec); end if; @@ -3900,6 +3925,16 @@ package body Sem_Ch12 is -- Start of processing for Analyze_Package_Instantiation begin + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => N, + Checks => True, + Level => True, + Modes => True); + Check_SPARK_05_Restriction ("generic is not allowed", N); -- Very first thing: check for Text_IO special unit in case we are @@ -4562,19 +4597,26 @@ package body Sem_Ch12 is Analyze (Act_Decl); Set_Unit (Parent (N), N); Set_Body_Required (Parent (N), False); + end if; - -- We never need elaboration checks on instantiations, since by - -- definition, the body instantiation is elaborated at the same - -- time as the spec instantiation. + -- Save the scenario for later examination by the ABE Processing + -- phase. - Set_Suppress_Elaboration_Warnings (Act_Decl_Id); - Set_Kill_Elaboration_Checks (Act_Decl_Id); - end if; + Record_Elaboration_Scenario (N); + + -- The instantiation results in a guaranteed ABE - Check_Elab_Instantiation (N); + if Is_Known_Guaranteed_ABE (N) and then Needs_Body then + + -- Do not instantiate the corresponding body because gigi cannot + -- handle certain types of premature instantiations. - if ABE_Is_Certain (N) and then Needs_Body then Pending_Instantiations.Decrement_Last; + + -- Create completing bodies for all subprogram declarations since + -- their real bodies will not be instantiated. + + Provide_Completing_Bodies (Instance_Spec (N)); end if; Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); @@ -5056,7 +5098,7 @@ package body Sem_Ch12 is -- No point in inlining if ABE is inevitable - and then not ABE_Is_Certain (N) + and then not Is_Known_Guaranteed_ABE (N) -- Or if subprogram is eliminated @@ -5242,12 +5284,7 @@ package body Sem_Ch12 is Check_Eliminated (Act_Decl_Id); Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id)); - -- In compilation unit case, kill elaboration checks on the - -- instantiation, since they are never needed -- the body is - -- instantiated at the same point as the spec. - if Nkind (Parent (N)) = N_Compilation_Unit then - Set_Suppress_Elaboration_Warnings (Act_Decl_Id); Set_Kill_Elaboration_Checks (Act_Decl_Id); Set_Is_Compilation_Unit (Anon_Id); @@ -5338,6 +5375,16 @@ package body Sem_Ch12 is -- Start of processing for Analyze_Subprogram_Instantiation begin + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => N, + Checks => True, + Level => True, + Modes => True); + Check_SPARK_05_Restriction ("generic is not allowed", N); -- Very first thing: check for special Text_IO unit in case we are @@ -5590,8 +5637,17 @@ package body Sem_Ch12 is Set_Ignore_SPARK_Mode_Pragmas (Anon_Id); end if; - if not Is_Intrinsic_Subprogram (Gen_Unit) then - Check_Elab_Instantiation (N); + -- Save the scenario for later examination by the ABE Processing + -- phase. + + Record_Elaboration_Scenario (N); + + -- The instantiation results in a guaranteed ABE. Create a completing + -- body for the subprogram declaration because the real body will not + -- be instantiated. + + if Is_Known_Guaranteed_ABE (N) then + Provide_Completing_Bodies (Instance_Spec (N)); end if; if Is_Dispatching_Operation (Act_Decl_Id) @@ -8561,7 +8617,7 @@ package body Sem_Ch12 is -- The parent was a premature instantiation. Insert freeze node at -- the end the current declarative part. - if ABE_Is_Certain (Get_Unit_Instantiation_Node (Par)) then + if Is_Known_Guaranteed_ABE (Get_Unit_Instantiation_Node (Par)) then Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); -- Handle the following case: @@ -13991,6 +14047,102 @@ package body Sem_Ch12 is end if; end Preanalyze_Actuals; + ------------------------------- + -- Provide_Completing_Bodies -- + ------------------------------- + + procedure Provide_Completing_Bodies (N : Node_Id) is + procedure Build_Completing_Body (Subp_Decl : Node_Id); + -- Generate the completing body for subprogram declaration Subp_Decl + + procedure Provide_Completing_Bodies_In (Decls : List_Id); + -- Generating completing bodies for all subprograms found in declarative + -- list Decls. + + --------------------------- + -- Build_Completing_Body -- + --------------------------- + + procedure Build_Completing_Body (Subp_Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (Subp_Decl); + Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); + Spec : Node_Id; + + begin + -- Nothing to do if the subprogram already has a completing body + + if Present (Corresponding_Body (Subp_Decl)) then + return; + + -- Mark the function as having a valid return statement even though + -- the body contains a single raise statement. + + elsif Ekind (Subp_Id) = E_Function then + Set_Return_Present (Subp_Id); + end if; + + -- Clone the specification to obtain new entities and reset the only + -- semantic field. + + Spec := Copy_Subprogram_Spec (Specification (Subp_Decl)); + Set_Generic_Parent (Spec, Empty); + + -- Generate: + -- function Func ... return ... is + -- <or> + -- procedure Proc ... is + -- begin + -- raise Program_Error with "access before elaboration"; + -- edn Proc; + + Insert_After_And_Analyze (Subp_Decl, + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Raise_Program_Error (Loc, + Reason => PE_Access_Before_Elaboration))))); + end Build_Completing_Body; + + ---------------------------------- + -- Provide_Completing_Bodies_In -- + ---------------------------------- + + procedure Provide_Completing_Bodies_In (Decls : List_Id) is + Decl : Node_Id; + + begin + if Present (Decls) then + Decl := First (Decls); + while Present (Decl) loop + Provide_Completing_Bodies (Decl); + Next (Decl); + end loop; + end if; + end Provide_Completing_Bodies_In; + + -- Local variables + + Spec : Node_Id; + + -- Start of processing for Provide_Completing_Bodies + + begin + if Nkind (N) = N_Package_Declaration then + Spec := Specification (N); + + Push_Scope (Defining_Entity (N)); + Provide_Completing_Bodies_In (Visible_Declarations (Spec)); + Provide_Completing_Bodies_In (Private_Declarations (Spec)); + Pop_Scope; + + elsif Nkind (N) = N_Subprogram_Declaration then + Build_Completing_Body (N); + end if; + end Provide_Completing_Bodies; + ------------------- -- Remove_Parent -- ------------------- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index eea0778c1a2..769b7e9e814 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4709,6 +4709,20 @@ package body Sem_Ch3 is end if; end if; + -- Set the SPARK mode from the current context (may be overwritten later + -- with explicit pragma). + + Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); + Set_SPARK_Pragma_Inherited (Id); + + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => Id, + Checks => True); + -- Initialize alignment and size and capture alignment setting Init_Alignment (Id); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 54d0a8600d2..03876afafc4 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -379,6 +379,15 @@ package body Sem_Ch5 is begin Mark_Coextensions (N, Rhs); + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => N, + Checks => True, + Modes => True); + -- Analyze the target of the assignment first in case the expression -- contains references to Ghost entities. The checks that verify the -- proper use of a Ghost entity need to know the enclosing context. @@ -917,11 +926,9 @@ package body Sem_Ch5 is Error_Msg_CRT ("composite assignment", N); end if; - -- Check elaboration warning for left side if not in elab code + -- Save the scenario for later examination by the ABE Processing phase - if not In_Subprogram_Or_Concurrent_Unit then - Check_Elab_Assign (Lhs); - end if; + Record_Elaboration_Scenario (N); -- Set Referenced_As_LHS if appropriate. We only set this flag if the -- assignment is a source assignment in the extended main source unit. @@ -2044,13 +2051,13 @@ package body Sem_Ch5 is begin if No (Iterator) then - null; -- error reported below. + null; -- error reported below elsif not Is_Overloaded (Iterator) then Check_Reverse_Iteration (Etype (Iterator)); - -- If Iterator is overloaded, use reversible iterator if - -- one is available. + -- If Iterator is overloaded, use reversible iterator if one is + -- available. elsif Is_Overloaded (Iterator) then Get_First_Interp (Iterator, I, It); @@ -3609,8 +3616,7 @@ package body Sem_Ch5 is end if; else - - -- Pre-Ada2012 for-loops and while loops. + -- Pre-Ada2012 for-loops and while loops Analyze_Statements (Statements (N)); end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 3e892f836ad..a85ca60cd5f 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -226,6 +226,20 @@ package body Sem_Ch6 is Generate_Definition (Subp_Id); + -- Set the SPARK mode from the current context (may be overwritten later + -- with explicit pragma). + + Set_SPARK_Pragma (Subp_Id, SPARK_Mode_Pragma); + Set_SPARK_Pragma_Inherited (Subp_Id); + + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => Subp_Id, + Checks => True); + Set_Is_Abstract_Subprogram (Subp_Id); New_Overloaded_Entity (Subp_Id); Check_Delayed_Subprogram (Subp_Id); @@ -1468,7 +1482,7 @@ package body Sem_Ch6 is Set_Actual_Subtypes (N, Current_Scope); - Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); + Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); Set_SPARK_Pragma_Inherited (Body_Id); -- Analyze any aspect specifications that appear on the generic @@ -1769,13 +1783,12 @@ package body Sem_Ch6 is if Analyzed (N) then return; - end if; -- If there is an error analyzing the name (which may have been -- rewritten if the original call was in prefix notation) then error -- has been emitted already, mark node and return. - if Error_Posted (N) or else Etype (Name (N)) = Any_Type then + elsif Error_Posted (N) or else Etype (Name (N)) = Any_Type then Set_Etype (N, Any_Type); return; end if; @@ -1849,9 +1862,9 @@ package body Sem_Ch6 is New_N := Make_Indexed_Component (Loc, - Prefix => + Prefix => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc), + Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc), Selector_Name => New_Occurrence_Of (Entity (P), Loc)), Expressions => Actuals); Set_Name (N, New_N); @@ -1957,7 +1970,8 @@ package body Sem_Ch6 is then New_N := Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc), + Prefix => + New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc), Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc)); Rewrite (Prefix (P), New_N); Analyze (P); @@ -4026,7 +4040,7 @@ package body Sem_Ch6 is -- between the spec and body. elsif No (SPARK_Pragma (Body_Id)) then - Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); + Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); Set_SPARK_Pragma_Inherited (Body_Id); end if; @@ -4471,12 +4485,11 @@ package body Sem_Ch6 is Stm : Node_Id; begin - -- Skip initial labels (for one thing this occurs when we are in - -- front-end ZCX mode, but in any case it is irrelevant), and also - -- initial Push_xxx_Error_Label nodes, which are also irrelevant. + -- Skip call markers installed by the ABE mechanism, labels, and + -- Push_xxx_Error_Label to find the first real statement. Stm := First (Statements (HSS)); - while Nkind (Stm) = N_Label + while Nkind_In (Stm, N_Call_Marker, N_Label) or else Nkind (Stm) in N_Push_xxx_Label loop Next (Stm); @@ -4657,8 +4670,9 @@ package body Sem_Ch6 is and then Is_Entry_Barrier_Function (N) then null; + else - Set_SPARK_Pragma (Designator, SPARK_Mode_Pragma); + Set_SPARK_Pragma (Designator, SPARK_Mode_Pragma); Set_SPARK_Pragma_Inherited (Designator); end if; @@ -4671,6 +4685,14 @@ package body Sem_Ch6 is Set_Ignore_SPARK_Mode_Pragmas (Designator); end if; + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => Designator, + Checks => True); + if Debug_Flag_C then Write_Str ("==> subprogram spec "); Write_Name (Chars (Designator)); diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 1565662ca12..f9a590095a0 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1144,16 +1144,10 @@ package body Sem_Ch7 is end if; end if; - if Is_Comp_Unit then - - -- Set Body_Required indication on the compilation unit node, and - -- determine whether elaboration warnings may be meaningful on it. + -- Set Body_Required indication on the compilation unit node + if Is_Comp_Unit then Set_Body_Required (Parent (N), Body_Required); - - if not Body_Required then - Set_Suppress_Elaboration_Warnings (Id); - end if; end if; End_Package_Scope (Id); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 95bb0fe4a97..d0c417ba0f5 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -57,6 +57,7 @@ with Sem_Ch13; use Sem_Ch13; with Sem_Dim; use Sem_Dim; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; +with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; @@ -4133,6 +4134,11 @@ package body Sem_Ch8 is Statements => New_List (Attr_Node))); end if; + -- Signal the ABE mechanism that the generated subprogram body has not + -- ABE ramifications. + + Set_Was_Attribute_Reference (Body_Node); + -- In case of tagged types we add the body of the generated function to -- the freezing actions of the type (because in the general case such -- type is still not frozen). We exclude from this processing generic @@ -4192,15 +4198,6 @@ package body Sem_Ch8 is Error_Msg_N ("a library unit can only rename another library unit", N); end if; - - -- We suppress elaboration warnings for the resulting entity, since - -- clearly they are not needed, and more particularly, in the case - -- of a generic formal subprogram, the resulting entity can appear - -- after the instantiation itself, and thus look like a bogus case - -- of access before elaboration. - - Set_Suppress_Elaboration_Warnings (New_S); - end Attribute_Renaming; ---------------------- @@ -5433,6 +5430,16 @@ package body Sem_Ch8 is return; end if; + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + if Nkind (N) = N_Identifier then + Mark_Elaboration_Attributes + (N_Id => N, + Modes => True); + end if; + -- Here if Entity pointer was not set, we need full visibility analysis -- First we generate debugging output if the debug E flag is set. @@ -5907,6 +5914,10 @@ package body Sem_Ch8 is <<Done>> Check_Restriction_No_Use_Of_Entity (N); + + -- Save the scenario for later examination by the ABE Processing phase + + Record_Elaboration_Scenario (N); end Find_Direct_Name; ------------------------ @@ -6421,6 +6432,14 @@ package body Sem_Ch8 is Change_Selected_Component_To_Expanded_Name (N); + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => N, + Modes => True); + -- Set appropriate type if Is_Type (Id) then @@ -6529,6 +6548,10 @@ package body Sem_Ch8 is end if; Check_Restriction_No_Use_Of_Entity (N); + + -- Save the scenario for later examination by the ABE Processing phase + + Record_Elaboration_Scenario (N); end Find_Expanded_Name; -------------------- diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index cbebe2601d2..199cd8a8c7a 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -50,6 +50,7 @@ with Sem_Ch5; use Sem_Ch5; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; +with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; @@ -1656,6 +1657,14 @@ package body Sem_Ch9 is Set_SPARK_Pragma_Inherited (Def_Id); end if; + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => Def_Id, + Checks => True); + -- Process formals if Present (Formals) then @@ -2281,6 +2290,15 @@ package body Sem_Ch9 is Synch_Type : Entity_Id; begin + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => N, + Checks => True, + Modes => True); + Tasking_Used := True; Check_SPARK_05_Restriction ("requeue statement is not allowed", N); Check_Restriction (No_Requeue_Statements, N); @@ -2553,6 +2571,12 @@ package body Sem_Ch9 is Error_Msg_N ("target protected object of requeue must be a variable", N); end if; + + -- A requeue statement is treated as a call for purposes of ABE checks + -- and diagnostics. Annotate the tree by creating a call marker in case + -- the requeue statement is transformed by expansion. + + Build_Call_Marker (N); end Analyze_Requeue; ------------------------------ @@ -2836,6 +2860,14 @@ package body Sem_Ch9 is Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma); Set_SPARK_Pragma_Inherited (Obj_Id); + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => Obj_Id, + Checks => True); + -- Instead of calling Analyze on the new node, call the proper analysis -- procedure directly. Otherwise the node would be expanded twice, with -- disastrous result. @@ -3099,6 +3131,14 @@ package body Sem_Ch9 is Set_SPARK_Pragma_Inherited (T); Set_SPARK_Aux_Pragma_Inherited (T); + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => T, + Checks => True); + Push_Scope (T); if Ada_Version >= Ada_2005 then diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 7be57cfce97..47e9c99e36e 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -24,31 +24,27 @@ ------------------------------------------------------------------------------ with Atree; use Atree; -with Checks; use Checks; with Debug; use Debug; with Einfo; use Einfo; -with Elists; use Elists; with Errout; use Errout; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; -with Expander; use Expander; with Lib; use Lib; with Lib.Load; use Lib.Load; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; -with Output; use Output; with Restrict; use Restrict; with Rident; use Rident; +with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; -with Sem_Cat; use Sem_Cat; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; +with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; -with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Table; @@ -56,2126 +52,5147 @@ with Tbuild; use Tbuild; with Uintp; use Uintp; with Uname; use Uname; +with GNAT.HTable; use GNAT.HTable; + package body Sem_Elab is - -- The following table records the recursive call chain for output in the - -- Output routine. Each entry records the call node and the entity of the - -- called routine. The number of entries in the table (i.e. the value of - -- Elab_Call.Last) indicates the current depth of recursion and is used to - -- identify the outer level. + ----------------------------------------- + -- Access-before-elaboration mechanism -- + ----------------------------------------- + + -- The access-before-elaboration (ABE) mechanism implemented in this unit + -- has the following objectives: + -- + -- * Diagnose at compile-time or install run-time checks to prevent ABE + -- access to data and behaviour. + -- + -- The high level idea is to accurately diagnose ABE issues within a + -- single unit because the ABE mechanism can inspect the whole unit. + -- As soon as the elaboration graph extends to an external unit, the + -- diagnostics stop because the body of the unit may not be available. + -- Due to control and data flow, the ABE mechanism cannot accurately + -- determine whether a particular scenario will be elaborated or not. + -- Conditional ABE checks are therefore used to verify the elaboration + -- status of a local and external target at run time. + -- + -- * Supply elaboration dependencies for a unit to binde + -- + -- The ABE mechanism registers each outgoing elaboration edge for the + -- main unit in its ALI file. GNATbind and binde can then reconstruct + -- the full elaboration graph and determine the proper elaboration + -- order for all units in the compilation. + -- + -- The ABE mechanism supports three models of elaboration: + -- + -- * Dynamic model - This is the most permissive of the three models. + -- When the dynamic model is in effect, the mechanism performs very + -- little diagnostics and generates run-time checks to detect ABE + -- issues. The behaviour of this model is identical to that specified + -- by the Ada RM. This model is enabled with switch -gnatE. + -- + -- * Static model - This is the middle ground of the three models. When + -- the static model is in effect, the mechanism diagnoses and installs + -- run-time checks to detect ABE issues in the main unit. In addition, + -- the mechanism generates implicit Elaborate or Elaborate_All pragmas + -- to ensure the prior elaboration of withed units. The model employs + -- textual order, with clause context, and elaboration-related source + -- pragmas. This is the default model. + -- + -- * SPARK model - This is the most conservative of the three models and + -- impelements the semantics defined in SPARK RM 7.7. The SPARK model + -- is in effect only when a context resides in a SPARK_Mode On region, + -- otherwise the mechanism falls back to one of the previous models. + -- + -- The ABE mechanism consists of a "recording" phase and a "processing" + -- phase. + + ----------------- + -- Terminology -- + ----------------- + + -- * Bridge target - A type of target. A bridge target is a link between + -- scenarios. It is usually a byproduct of expansion and does not have + -- any direct ABE ramifications. + -- + -- * Call marker - A special node used to indicate the presence of a call + -- in the tree in case expansion transforms or eliminates the original + -- call. N_Call_Marker nodes do not have static and run-time semantics. + -- + -- * Conditional ABE - A type of ABE. A conditional ABE occurs when the + -- elaboration or invocation of a target by a scenario within the main + -- unit causes an ABE, but does not cause an ABE for another scenarios + -- within the main unit. + -- + -- * Declaration level - A type of enclosing level. A scenario or target is + -- at the declaration level when it appears within the declarations of a + -- block statement, entry body, subprogram body, or task body, ignoring + -- enclosing packges. + -- + -- * Generic library level - A type of enclosing level. A scenario or + -- target is at the generic library level if it appears in a generic + -- package library unit, ignoring enclosing packages. + -- + -- * Guaranteed ABE - A type of ABE. A guaranteed ABE occurs when the + -- elaboration or invocation of a target by all scenarios within the + -- main unit causes an ABE. + -- + -- * Instantiation library level - A type of enclosing level. A scenario + -- or target is at the instantiation library level if it appears in an + -- instantiation library unit, ignoring enclosing packages. + -- + -- * Library level - A type of enclosing level. A scenario or target is at + -- the library level if it appears in a package library unit, ignoring + -- enclosng packages. + -- + -- * Non-library level encapsulator - A construct that cannot be elaborated + -- on its own and requires elaboration by a top level scenario. + -- + -- * Scenario - A construct or context which may be elaborated or executed + -- by elaboration code. The scenarios recognized by the ABE mechanism are + -- as follows: + -- + -- - '[Unrestricted_]Access of entries, operators, and subprograms + -- + -- - Assignments to variables + -- + -- - Calls to entries, operators, and subprograms + -- + -- - Instantiations + -- + -- - References to variables + -- + -- - Task activation + -- + -- * Target - A construct referenced by a scenario. The targets recognized + -- by the ABE mechanism are as follows: + -- + -- - For '[Unrestricted_]Access of entries, operators, and subprograms, + -- the target is the entry, operator, or subprogram. + -- + -- - For assignments to variables, the target is the variable + -- + -- - For calls, the target is the entry, operator, or subprogram + -- + -- - For instantiations, the target is the generic template + -- + -- - For references to variables, the target is the variable + -- + -- - For task activation, the target is the task body + -- + -- * Top level scenario - A scenario which appears in a non-generic main + -- unit. Depending on the elaboration model is in effect, the following + -- addotional restrictions apply: + -- + -- - Dynamic model - No restrictions + -- + -- - SPARK model - Falls back to either the dynamic or static model + -- + -- - Static model - The scenario must be at the library level + + --------------------- + -- Recording phase -- + --------------------- + + -- The Recording phase coincides with the analysis/resolution phase of the + -- compiler. It has the following objectives: + -- + -- * Record all top level scenarios for examination by the Processing + -- phase. + -- + -- Saving only a certain number of nodes improves the performance of + -- the ABE mechanism. This eliminates the need to examine the whole + -- tree in a separate pass. + -- + -- * Detect and diagnose calls in preelaborable or pure units, including + -- generic bodies. + -- + -- This diagnostic is carried out during the Recording phase because it + -- does not need the heavy recursive traversal done by the Processing + -- phase. + -- + -- * Detect and diagnose guaranteed ABEs caused by instantiations, + -- calls, and task activation. + -- + -- The issues detected by the ABE mechanism are reported as warnings + -- because they do not violate Ada semantics. Forward instantiations + -- may thus reach gigi, however gigi cannot handle certain kinds of + -- premature instantiations and may crash. To avoid this limitation, + -- the ABE mechanism must identify forward instantiations as early as + -- possible and suppress their bodies. Calls and task activations are + -- included in this category for completeness. + + ---------------------- + -- Processing phase -- + ---------------------- + + -- The Processing phase is a separate pass which starts after instantiating + -- and/or inlining of bodies, but before the removal of Ghost code. It has + -- the following objectives: + -- + -- * Examine all top level scenarios saved during the Recording phase + -- + -- The top level scenarios act as roots for depth-first traversal of + -- the call/instantiation/task activation graph. The traversal stops + -- when an outgoing edge leaves the main unit. + -- + -- * Depending on the elaboration model in effect, perform the following + -- actions: + -- + -- - Dynamic model - Diagnose guaranteed ABEs and install run-time + -- conditional ABE checks. + -- + -- - SPARK model - Enforce the SPARK elaboration rules + -- + -- - Static model - Diagnose conditional/guaranteed ABEs, install + -- run-time conditional ABE checks, and guarantee the elaboration + -- of external units. + -- + -- * Examine nested scenarios + -- + -- Nested scenarios discovered during the depth-first traversal are + -- in turn subjected to the same actions outlined above and examined + -- for the next level of nested scenarios. + + ------------------ + -- Architecture -- + ------------------ + + -- +------------------------ Recording phase ---------------------------+ + -- | | + -- | Record_Elaboration_Scenario | + -- | | | + -- | +--> Check_Preelaborated_Call | + -- | | | + -- | +--> Process_Guaranteed_ABE | + -- | | | + -- +------------------------- | --------------------------------------+ + -- | + -- | + -- v + -- Top_Level_Scenarios + -- +-----------+-----------+ .. +-----------+ + -- | Scenario1 | Scenario2 | .. | ScenarioN | + -- +-----------+-----------+ .. +-----------+ + -- | + -- | + -- +------------------------- | --------------------------------------+ + -- | | | + -- | Check_Elaboration_Scenarios | + -- | | | + -- | v | + -- | +----------- Process_Scenario <-----------+ | + -- | | | | + -- | +--> Process_Access Is_Suitable_Scenario | + -- | | ^ | + -- | +--> Process_Activation_Call --+ | | + -- | | +---> Traverse_Body | + -- | +--> Process_Call -------------+ | + -- | | | + -- | +--> Process_Instantiation | + -- | | | + -- | +--> Process_Variable_Assignment | + -- | | | + -- | +--> Process_Variable_Reference | + -- | | + -- +------------------------- Processing phase -------------------------+ + + ---------------------- + -- Important points -- + ---------------------- + + -- The Processing phase starts after the analysis, resolution, expansion + -- phase has completed. As a result, no current semantic information is + -- available. The scope stack is empty, global flags such as In_Instance + -- or Inside_A_Generic become useless. To remedy this, the ABE mechanism + -- must either save or recompute semantic information. + + -- Expansion heavily transforms calls and to some extent instantiations. To + -- remedy this, the ABE mechanism generates N_Call_Marker nodes in order to + -- capture the target and relevant attributes of the original call. + + -- The diagnostics of the ABE mechanism depend on accurate source locations + -- to determine the spacial relation of nodes. - type Elab_Call_Element is record - Cloc : Source_Ptr; - Ent : Entity_Id; + -------------- + -- Switches -- + -------------- + + -- The following switches may be used to control the behavior of the ABE + -- mechanism. + -- + -- -gnatdE elaboration checks on predefined units + -- + -- The ABE mechanism considers scenarios which appear in internal + -- units (Ada, GNAT, Interfaces, System). + -- + -- -gnatd.G ignore calls through generic formal parameters for elaboration + -- + -- The ABE mechanism does not generate N_Call_Marker nodes for + -- calls which occur in expanded instances, and invoke generic + -- actual subprograms through generic formal subprograms. As a + -- result, the calls are not recorded or processed. + -- + -- If switches -gnatd.G and -gnatdL are used together, then the + -- ABE mechanism effectively ignores all calls which cause the + -- elaboration flow to "leave" the instance. + -- + -- -gnatdL ignore external calls from instances for elaboration + -- + -- The ABE mechanism does not generate N_Call_Marker nodes for + -- calls which occur in expanded instances, do not invoke generic + -- actual subprograms through formal subprograms, and the target + -- is external to the instance. As a result, the calls are not + -- recorded or processed. + -- + -- If switches -gnatd.G and -gnatdL are used together, then the + -- ABE mechanism effectively ignores all calls which cause the + -- elaboration flow to "leave" the instance. + -- + -- -gnatd.o conservarive elaboration order for indirect calls + -- + -- The ABE mechanism treats '[Unrestricted_]Access of an entry, + -- operator, or subprogram as an immediate invocation of the + -- target. As a result, it performs ABE checks and diagnostics on + -- the immediate call. + -- + -- -gnatd.U ignore indirect calls for static elaboration + -- + -- The ABE mechanism does not consider '[Unrestricted_]Access of + -- entries, operators, and subprograms. As a result, the scenarios + -- are not recorder or processed. + -- + -- -gnatd.y disable implicit pragma Elaborate_All on task bodies + -- + -- The ABE mechanism does not generate implicit Elaborate_All when + -- the need for the pragma came from a task body. + -- + -- -gnatE dynamic elaboration checking mode enabled + -- + -- The ABE mechanism assumes that any scenario is elaborated or + -- invoked by elaboration code. The ABE mechanism performs very + -- little diagnostics and generates condintional ABE checks to + -- detect ABE issues at run-time. + -- + -- -gnatel turn on info messages on generated Elaborate[_All] pragmas + -- + -- The ABE mechanism produces information messages on generated + -- implicit Elabote[_All] pragmas along with traceback showing + -- why the pragma was generated. In addition, the ABE mechanism + -- produces information messages for each scenario elaborated or + -- invoked by elaboration code. + -- + -- -gnateL turn off info messages on generated Elaborate[_All] pragmas + -- + -- The complimentary switch for -gnatel. + -- + -- -gnatwl turn on warnings for elaboration problems + -- + -- The ABE mechanism produces warnings on detected ABEs along with + -- traceback showing the graph of the ABE. + -- + -- -gnatwL turn off warnings for elaboration problems + -- + -- The complimentary switch for -gnatwl. + -- + -- -gnatw.f turn on warnings for suspicious Subp'Access + -- + -- The ABE mechanism treats '[Unrestricted_]Access of an entry, + -- operator, or subprogram as a pseudo invocation of the target. + -- As a result, it performs ABE diagnostics on the pseudo call. + -- + -- -gnatw.F turn off warnings for suspicious Subp'Access + -- + -- The complimentary switch for -gnatw.f. + + --------------------------- + -- Adding a new scenario -- + --------------------------- + + -- The following steps describe how to add a new elaboration scenario and + -- preserve the existing architecture. + -- + -- 1) If necessary, update predicates Is_Check_Emitting_Scenario and + -- Is_Scenario. + -- + -- 2) Add predicate Is_Suitable_xxx. Include a call to it in predicate + -- Is_Suitable_Scenario. + -- + -- 3) Update routine Record_Elaboration_Scenario + -- + -- 4) Add routine Process_xxx. Include a call to it in Process_Scenario. + -- + -- 5) Add routine Info_xxx. Include a call to it in Process_xxx. + -- + -- 6) Add routine Output_xxx. Include a call to it in routine + -- Output_Active_Scenarios. + -- + -- 7) If necessary, add a new Extract_xxx_Attributes routine + -- + -- 8) If necessary, update routine Is_Potential_Scenario + + ------------------------- + -- Adding a new target -- + ------------------------- + + -- The following steps describe how to add a new elaboration target and + -- preserve the existing architecture. + -- + -- 1) Add predicate Is_xxx. + -- + -- 2) Update predicates Is_Ada_Semantic_Target, Is_Bridge_Target, or + -- Is_SPARK_Semantic_Target. If necessary, create a new category. + -- + -- 3) Update the appropriate Info_xxx routine. + -- + -- 4) Update the appropriate Output_xxx routine. + -- + -- 5) Update routine Extract_Target_Attributes. If necessary, create a + -- new Extract_xxx routine. + + -------------------------- + -- Debugging ABE issues -- + -------------------------- + + -- * If the issue involves a call, ensure that the call is eligible for ABE + -- processing and receives a corresponding call marker. The routines of + -- interest are + -- + -- Build_Call_Marker + -- Record_Elaboration_Scenario + + -- * If the issue involves an arbitrary scenario, ensure that the scenario + -- is either recorded, or is successfully recognized while traversing a + -- body. The routines of interest are + -- + -- Record_Elaboration_Scenario + -- Process_Scenario + -- Traverse_Body + + -- * If the issue involves a circularity in the elaboration order, examine + -- the ALI files and look for the following encodings next to units: + -- + -- E indicates a source Elaborate + -- + -- EA indicates a source Elaborate_All + -- + -- AD indicates an implicit Elaborate_All + -- + -- ED indicates an implicit Elaborate + -- + -- If possible, compare these encodings with those generated by the old + -- ABE mechanism. The routines of interest are + -- + -- Ensure_Prior_Elaboration + + ---------------- + -- Attributes -- + ---------------- + + -- The following type captures relevant attributes which pertain to a call + + type Call_Attributes is record + Elab_Checks_OK : Boolean; + -- This flag is set when the call has elaboration checks enabled + + From_Source : Boolean; + -- This flag is set when the call comes from source + + Ghost_Mode_Ignore : Boolean; + -- This flag is set when the call appears in a region subject to pragma + -- Ghost with policy Ignore. + + In_Declarations : Boolean; + -- This flag is set when the call appears at the declaration level + + Is_Dispatching : Boolean; + -- This flag is set when the call is dispatching + + SPARK_Mode_On : Boolean; + -- This flag is set when the call appears in a region subject to pragma + -- SPARK_Mode with value On. end record; - package Elab_Call is new Table.Table - (Table_Component_Type => Elab_Call_Element, - Table_Index_Type => Int, - Table_Low_Bound => 1, - Table_Initial => 50, - Table_Increment => 100, - Table_Name => "Elab_Call"); + -- The following type captures relevant attributes which pertain to the + -- prior elaboration of a unit. This type is coupled together with a unit + -- to form a key -> value relationship. + + type Elaboration_Attributes is record + Source_Pragma : Node_Id; + -- This attribute denotes a source Elaborate or Elaborate_All pragma + -- which guarantees the prior elaboration of some unit with respect + -- to the main unit. The pragma may come from the following contexts: + + -- * The main unit + -- * The spec of the main unit (if applicable) + -- * Any parent spec of the main unit (if applicable) + -- * Any parent subunit of the main unit (if applicable) + + -- The attribute remains Empty if no such pragma is available. Source + -- pragmas play a role in satisfying SPARK elaboration requirements. + + With_Clause : Node_Id; + -- This attribute denotes an internally generated or source with clause + -- for some unit withed by the main unit. With clauses carry flags which + -- represent implicit Elaborate or Elaborate_All pragmas. These clauses + -- play a role in supplying the elaboration dependencies to binde. + end record; - -- The following table records all calls that have been processed starting - -- from an outer level call. The table prevents both infinite recursion and - -- useless reanalysis of calls within the same context. The use of context - -- is important because it allows for proper checks in more complex code: + No_Elaboration_Attributes : constant Elaboration_Attributes := + (Source_Pragma => Empty, + With_Clause => Empty); - -- if ... then - -- Call; -- requires a check - -- Call; -- does not need a check thanks to the table - -- elsif ... then - -- Call; -- requires a check, different context - -- end if; + -- The following type captures relevant attributes which pertain to an + -- instantiation. - -- Call; -- requires a check, different context + type Instantiation_Attributes is record + Elab_Checks_OK : Boolean; + -- This flag is set when the instantiation has elaboration checks + -- enabled. - type Visited_Element is record - Subp_Id : Entity_Id; - -- The entity of the subprogram being called + Ghost_Mode_Ignore : Boolean; + -- This flag is set when the instantiation appears in a region subject + -- to pragma Ghost with policy ignore, or starts one such region. - Context : Node_Id; - -- The context where the call to the subprogram occurs + In_Declarations : Boolean; + -- This flag is set when the instantiation appears at the declaration + -- level. + + SPARK_Mode_On : Boolean; + -- This flag is set when the instantiation appears in a region subject + -- to pragma SPARK_Mode with value On, or starts one such region. end record; - package Elab_Visited is new Table.Table - (Table_Component_Type => Visited_Element, - Table_Index_Type => Int, - Table_Low_Bound => 1, - Table_Initial => 200, - Table_Increment => 100, - Table_Name => "Elab_Visited"); + -- The following type captures relevant attributes which pertain to a + -- target. + + type Target_Attributes is record + Elab_Checks_OK : Boolean; + -- This flag is set when the target has elaboration checks enabled + + From_Source : Boolean; + -- This flag is set when the target comes from source + + Ghost_Mode_Ignore : Boolean; + -- This flag is set when the target appears in a region subject to + -- pragma Ghost with policy ignore, or starts one such region. + + SPARK_Mode_On : Boolean; + -- This flag is set when the target appears in a region subject to + -- pragma SPARK_Mode with value On, or starts one such region. + + Spec_Decl : Node_Id; + -- This attribute denotes the declaration of Spec_Id + + Unit_Id : Entity_Id; + -- This attribute denotes the top unit where Spec_Id resides + + -- The semantics of the following attributes depend on the target + + Body_Barf : Node_Id; + Body_Decl : Node_Id; + Spec_Id : Entity_Id; + + -- The target is a generic package or a subprogram + -- + -- * Body_Barf - Empty + -- + -- * Body_Decl - This attribute denotes the generic or subprogram + -- body. + -- + -- * Spec_Id - This attribute denotes the entity of the generic + -- package or subprogram. + + -- The target is a protected entry + -- + -- * Body_Barf - This attribute denotes the body of the barrier + -- function if expansion took place, otherwise it is Empty. + -- + -- * Body_Decl - This attribute denotes the body of the procedure + -- which emulates the entry if expansion took place, otherwise it + -- denotes the body of the protected entry. + -- + -- * Spec_Id - This attribute denotes the entity of the procedure + -- which emulates the entry if expansion took place, otherwise it + -- denotes the protected entry. + + -- The target is a protected subprogram + -- + -- * Body_Barf - Empty + -- + -- * Body_Decl - This attribute denotes the body of the protected or + -- unprotected version of the protected subprogram if expansion took + -- place, otherwise it denotes the body of the protected subprogram. + -- + -- * Spec_Id - This attribute denotes the entity of the protected or + -- unprotected version of the protected subprogram if expansion took + -- place, otherwise it is the entity of the protected subprogram. + + -- The target is a task entry + -- + -- * Body_Barf - Empty + -- + -- * Body_Decl - This attribute denotes the body of the procedure + -- which emulates the task body if expansion took place, otherwise + -- it denotes the body of the task type. + -- + -- * Spec_Id - This attribute denotes the entity of the procedure + -- which emulates the task body if expansion took place, otherwise + -- it denotes the entity of the task type. + end record; + + -- The following type captures relevant attributes which pertain to a task + -- type. - -- The following table records delayed calls which must be examined after - -- all generic bodies have been instantiated. + type Task_Attributes is record + Body_Decl : Node_Id; + -- This attribute denotes the declaration of the procedure body which + -- emulates the behaviour of the task body. - type Delay_Element is record - N : Node_Id; - -- The parameter N from the call to Check_Internal_Call. Note that this - -- node may get rewritten over the delay period by expansion in the call - -- case (but not in the instantiation case). + Elab_Checks_OK : Boolean; + -- This flag is set when the task type has elaboration checks enabled - E : Entity_Id; - -- The parameter E from the call to Check_Internal_Call + Ghost_Mode_Ignore : Boolean; + -- This flag is set when the task type appears in a region subject to + -- pragma Ghost with policy ignore, or starts one such region. - Orig_Ent : Entity_Id; - -- The parameter Orig_Ent from the call to Check_Internal_Call + SPARK_Mode_On : Boolean; + -- This flag is set when the task type appears in a region subject to + -- pragma SPARK_Mode with value On, or starts one such region. - Curscop : Entity_Id; - -- The current scope of the call. This is restored when we complete the - -- delayed call, so that we do this in the right scope. + Spec_Id : Entity_Id; + -- This attribute denotes the entity of the initial declaration of the + -- procedure body which emulates the behaviour of the task body. - Outer_Scope : Entity_Id; - -- Save scope of outer level call + Task_Decl : Node_Id; + -- This attribute denotes the declaration of the task type - From_Elab_Code : Boolean; - -- Save indication of whether this call is from elaboration code + Unit_Id : Entity_Id; + -- This attribute denotes the entity of the compilation unit where the + -- task type resides. + end record; - In_Task_Activation : Boolean; - -- Save indication of whether this call is from a task body. Tasks are - -- activated at the "begin", which is after all local procedure bodies, - -- so calls to those procedures can't fail, even if they occur after the - -- task body. + -- The following type captures relevant attributes which pertain to a + -- variable. - From_SPARK_Code : Boolean; - -- Save indication of whether this call is under SPARK_Mode => On + type Variable_Attributes is record + SPARK_Mode_On : Boolean; + -- This flag is set when the variable appears in a region subject to + -- pragma SPARK_Mode with value On, or starts one such region. + + Unit_Id : Entity_Id; + -- This attribute denotes the entity of the compilation unit where the + -- variable resides. end record; - package Delay_Check is new Table.Table - (Table_Component_Type => Delay_Element, + --------------------- + -- Data structures -- + --------------------- + + -- The following table stores the elaboration status of all units withed by + -- the main unit. + + Elaboration_Context_Max : constant := 1009; + + type Elaboration_Context_Index is range 0 .. Elaboration_Context_Max - 1; + + function Elaboration_Context_Hash + (Key : Entity_Id) return Elaboration_Context_Index; + -- Obtain the hash value of entity Key + + package Elaboration_Context is new Simple_HTable + (Header_Num => Elaboration_Context_Index, + Element => Elaboration_Attributes, + No_Element => No_Elaboration_Attributes, + Key => Entity_Id, + Hash => Elaboration_Context_Hash, + Equal => "="); + + -- The following table stores all active scenarios in a recursive traversal + -- starting from a top level scenario. This table must be maintained in a + -- FIFO fashion. + + package Scenario_Stack is new Table.Table + (Table_Component_Type => Node_Id, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 100, + Table_Name => "Scenario_Stack"); + + -- The following table stores all top level scenario saved during the + -- Recording phase. The contents of this table act as traversal roots + -- later in the Processing phase. This table must be maintained in a + -- LIFO fashion. + + package Top_Level_Scenarios is new Table.Table + (Table_Component_Type => Node_Id, Table_Index_Type => Int, Table_Low_Bound => 1, Table_Initial => 1000, Table_Increment => 100, - Table_Name => "Delay_Check"); - - C_Scope : Entity_Id; - -- Top-level scope of current scope. Compute this only once at the outer - -- level, i.e. for a call to Check_Elab_Call from outside this unit. - - Outer_Level_Sloc : Source_Ptr; - -- Save Sloc value for outer level call node for comparisons of source - -- locations. A body is too late if it appears after the *outer* level - -- call, not the particular call that is being analyzed. - - From_Elab_Code : Boolean; - -- This flag shows whether the outer level call currently being examined - -- is or is not in elaboration code. We are only interested in calls to - -- routines in other units if this flag is True. - - In_Task_Activation : Boolean := False; - -- This flag indicates whether we are performing elaboration checks on task - -- bodies, at the point of activation. If true, we do not raise - -- Program_Error for calls to local procedures, because all local bodies - -- are known to be elaborated. However, we still need to trace such calls, - -- because a local procedure could call a procedure in another package, - -- so we might need an implicit Elaborate_All. - - Delaying_Elab_Checks : Boolean := True; - -- This is set True till the compilation is complete, including the - -- insertion of all instance bodies. Then when Check_Elab_Calls is called, - -- the delay table is used to make the delayed calls and this flag is reset - -- to False, so that the calls are processed. + Table_Name => "Top_Level_Scenarios"); + + -- The following table stores the bodies of all eligible scenarios visited + -- during a traversal starting from a top level scenario. The contents of + -- this table must be reset upon each new traversal. + + Visited_Bodies_Max : constant := 511; + + type Visited_Bodies_Index is range 0 .. Visited_Bodies_Max - 1; + + function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index; + -- Obtain the hash value of node Key + + package Visited_Bodies is new Simple_HTable + (Header_Num => Visited_Bodies_Index, + Element => Boolean, + No_Element => False, + Key => Node_Id, + Hash => Visited_Bodies_Hash, + Equal => "="); ----------------------- - -- Local Subprograms -- + -- Local subprograms -- ----------------------- - -- Note: Outer_Scope in all following specs represents the scope of - -- interest of the outer level call. If it is set to Standard_Standard, - -- then it means the outer level call was at elaboration level, and that - -- thus all calls are of interest. If it was set to some other scope, - -- then the original call was an inner call, and we are not interested - -- in calls that go outside this scope. - - procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id); - -- Analysis of construct N shows that we should set Elaborate_All_Desirable - -- for the WITH clause for unit U (which will always be present). A special - -- case is when N is a function or procedure instantiation, in which case - -- it is sufficient to set Elaborate_Desirable, since in this case there is - -- no possibility of transitive elaboration issues. - - procedure Check_A_Call - (N : Node_Id; - E : Entity_Id; - Outer_Scope : Entity_Id; - Inter_Unit_Only : Boolean; - Generate_Warnings : Boolean := True; - In_Init_Proc : Boolean := False); - -- This is the internal recursive routine that is called to check for - -- possible elaboration error. The argument N is a subprogram call or - -- generic instantiation, or 'Access attribute reference to be checked, and - -- E is the entity of the called subprogram, or instantiated generic unit, - -- or subprogram referenced by 'Access. - -- - -- In SPARK mode, N can also be a variable reference, since in SPARK this - -- also triggers a requirement for Elaborate_All, and in this case E is the - -- entity being referenced. - -- - -- Outer_Scope is the outer level scope for the original reference. - -- Inter_Unit_Only is set if the call is only to be checked in the - -- case where it is to another unit (and skipped if within a unit). - -- Generate_Warnings is set to False to suppress warning messages about - -- missing pragma Elaborate_All's. These messages are not wanted for - -- inner calls in the dynamic model. Note that an instance of the Access - -- attribute applied to a subprogram also generates a call to this - -- procedure (since the referenced subprogram may be called later - -- indirectly). Flag In_Init_Proc should be set whenever the current - -- context is a type init proc. - -- - -- Note: this might better be called Check_A_Reference to recognize the - -- variable case for SPARK, but we prefer to retain the historical name - -- since in practice this is mostly about checking calls for the possible - -- occurrence of an access-before-elaboration exception. - - procedure Check_Bad_Instantiation (N : Node_Id); - -- N is a node for an instantiation (if called with any other node kind, - -- Check_Bad_Instantiation ignores the call). This subprogram checks for - -- the special case of a generic instantiation of a generic spec in the - -- same declarative part as the instantiation where a body is present and - -- has not yet been seen. This is an obvious error, but needs to be checked - -- specially at the time of the instantiation, since it is a case where we - -- cannot insert the body anywhere. If this case is detected, warnings are - -- generated, and a raise of Program_Error is inserted. In addition any - -- subprograms in the generic spec are stubbed, and the Bad_Instantiation - -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this - -- flag as an indication that no attempt should be made to insert an - -- instance body. - - procedure Check_Internal_Call + procedure Check_Preelaborated_Call (Call : Node_Id); + -- Determine whether entry, operator, or subprogram call Call appears at + -- the library level of a preelaborated unit. Emit an error if this is the + -- case. + + function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id; + pragma Inline (Compilation_Unit); + -- Return the N_Compilation_Unit node of unit Unit_Id + + procedure Elab_Msg_NE + (Msg : String; + N : Node_Id; + Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean); + pragma Inline (Elab_Msg_NE); + -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary node + -- N and entity. If flag Info_Msg is set, the routine emits an information + -- message, otherwise it emits an error. If flag In_SPARK is set, then + -- string " in SPARK" is added to the end of the message. + + procedure Ensure_Dynamic_Prior_Elaboration + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id); + -- Guarantee the elaboration of unit Unit_Id with respect to the main unit + -- by suggesting the use of Elaborate[_All] with name Prag_Nam. N denotes + -- the related scenario. + + procedure Ensure_Prior_Elaboration + (N : Node_Id; + Unit_Id : Entity_Id; + In_Task_Body : Boolean); + -- Guarantee the elaboration of unit Unit_Id with respect to the main unit. + -- N denotes the related scenario. Flag In_Task_Body should be set when the + -- need for elaboration is initiated from a task body. + + procedure Ensure_Static_Prior_Elaboration + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id); + -- Guarantee the elaboration of unit Unit_Id with respect to the main unit + -- by installing an implicit Elaborate[_All] pragma with name Prag_Nam. N + -- denotes the related scenario. + + function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id; + pragma Inline (Extract_Assignment_Name); + -- Obtain the Name attribute of assignment statement Asmt + + procedure Extract_Call_Attributes + (Call : Node_Id; + Target_Id : out Entity_Id; + Attrs : out Call_Attributes); + -- Obtain attributes Attrs associated with call Call. Target_Id is the + -- entity of the call target. + + function Extract_Call_Name (Call : Node_Id) return Node_Id; + pragma Inline (Extract_Call_Name); + -- Obtain the Name attribute of entry or subprogram call Call + + procedure Extract_Instance_Attributes + (Exp_Inst : Node_Id; + Inst_Body : out Node_Id; + Inst_Decl : out Node_Id); + pragma Inline (Extract_Instance_Attributes); + -- Obtain body Inst_Body and spec Inst_Decl of expanded instance Exp_Inst + + procedure Extract_Instantiation_Attributes + (Exp_Inst : Node_Id; + Inst : out Node_Id; + Inst_Id : out Entity_Id; + Gen_Id : out Entity_Id; + Attrs : out Instantiation_Attributes); + -- Obtain attributes Attrs associated with expanded instantiation Exp_Inst. + -- Inst is the instantiation. Inst_Id is the entity of the instance. Gen_Id + -- is the entity of the generic unit being instantiated. + + procedure Extract_Target_Attributes + (Target_Id : Entity_Id; + Attrs : out Target_Attributes); + -- Obtain attributes Attrs associated with an entry, package, or subprogram + -- denoted by Target_Id. + + procedure Extract_Task_Attributes + (Typ : Entity_Id; + Attrs : out Task_Attributes); + -- Obtain attributes Attrs associated with task type Typ + + procedure Extract_Variable_Reference_Attributes + (Ref : Node_Id; + Var_Id : out Entity_Id; + Attrs : out Variable_Attributes); + -- Obtain attributes Attrs associated with reference Ref which mentions + -- variable Var_Id. + + function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id; + pragma Inline (Find_Code_Unit); + -- Return the code unit which contains arbitrary node or entity N. This + -- is the unit of the file which physically contains the related construct + -- denoted by N except when N is within an instantiation. In that case the + -- unit is that of the top level instantiation. + + procedure Find_Elaborated_Units; + -- Populate table Elaboration_Context with all units which have prior + -- elaboration with respect to the main unit. + + function Find_Enclosing_Instance (N : Node_Id) return Node_Id; + pragma Inline (Find_Enclosing_Instance); + -- Find the declaration or body of the nearest expanded instance which + -- encloses arbitrary node N. Return Empty if no such instance exists. + + function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id; + pragma Inline (Find_Top_Unit); + -- Return the top unit which contains arbitrary node or entity N. The unit + -- is obtained by logically unwinding instantiations and subunits when N + -- resides within one. + + function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id; + pragma Inline (First_Formal_Type); + -- Return the type of subprogram Subp_Id's first formal parameter. If the + -- subprogram lacks formal parameters, return Empty. + + function Has_Body (Pack_Decl : Node_Id) return Boolean; + -- Determine whether package declaration Pack_Decl has a corresponding body + -- or would eventually have one. + + function Has_Prior_Elaboration + (Unit_Id : Entity_Id; + Context_OK : Boolean := False; + Elab_Body_OK : Boolean := False; + Same_Unit_OK : Boolean := False) return Boolean; + pragma Inline (Has_Prior_Elaboration); + -- Determine whether unit Unit_Id is elaborated prior to the main unit. + -- If flag Context_OK is set, the routine considers the following case + -- as valid prior elaboration: + -- + -- * Unit_Id is in the elaboration context of the main unit + -- + -- If flag Elab_Body_OK is set, the routine considers the following case + -- as valid prior elaboration: + -- + -- * Unit_Id has pragma Elaborate_Body and is not the main unit + -- + -- If flag Same_Unit_OK is set, the routine considers the following cases + -- as valid prior elaboration: + -- + -- * Unit_Id is the main unit + -- + -- * Unit_Id denotes the spec of the main unit body + + function In_External_Instance (N : Node_Id; - E : Entity_Id; - Outer_Scope : Entity_Id; - Orig_Ent : Entity_Id); - -- N is a function call or procedure statement call node and E is the - -- entity of the called function, which is within the current compilation - -- unit (where subunits count as part of the parent). This call checks if - -- this call, or any call within any accessed body could cause an ABE, and - -- if so, outputs a warning. Orig_Ent differs from E only in the case of - -- renamings, and points to the original name of the entity. This is used - -- for error messages. Outer_Scope is the outer level scope for the - -- original call. - - procedure Check_Internal_Call_Continue + Target_Decl : Node_Id) return Boolean; + -- Determine whether a target desctibed by its declaration Target_Decl + -- resides in a package instance which is external to scenario N. + + function In_Main_Context (N : Node_Id) return Boolean; + pragma Inline (In_Main_Context); + -- Determine whether arbitrary node N appears within the main compilation + -- unit. + + function In_Same_Context + (N1 : Node_Id; + N2 : Node_Id; + Nested_OK : Boolean := False) return Boolean; + -- Determine whether two arbitrary nodes N1 and N2 appear within the same + -- context ignoring enclosing library levels. Nested_OK should be set when + -- the context of N1 can enclose that of N2. + + procedure Info_Call + (Call : Node_Id; + Target_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean); + -- Output information concerning call Call which invokes target Target_Id. + -- If flag Info_Msg is set, the routine emits an information message, + -- otherwise it emits an error. If flag In_SPARK is set, then string " in + -- SPARK" is added to the end of the message. + + procedure Info_Instantiation + (Inst : Node_Id; + Gen_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean); + -- Output information concerning instantiation Inst which instantiates + -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an + -- information message, otherwise it emits an error. If flag In_SPARK + -- is set, then string " in SPARK" is added to the end of the message. + + procedure Info_Variable_Reference + (Ref : Node_Id; + Var_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean); + -- Output information concerning reference Ref which mentions variable + -- Var_Id. If flag Info_Msg is set, the routine emits an information + -- message, otherwise it emits an error. If flag In_SPARK is set, then + -- string " in SPARK" is added to the end of the message. + + function Insertion_Node (N : Node_Id; Ins_Nod : Node_Id) return Node_Id; + pragma Inline (Insertion_Node); + -- Obtain the proper insertion node of an ABE check or failure for scenario + -- N and candidate insertion node Ins_Nod. + + procedure Install_ABE_Check + (N : Node_Id; + Id : Entity_Id; + Ins_Nod : Node_Id); + -- Insert a run-time ABE check for elaboration scenario N which verifies + -- whether arbitrary entity Id is elaborated. The check in inserted prior + -- to node Ins_Nod. + + procedure Install_ABE_Check (N : Node_Id; - E : Entity_Id; - Outer_Scope : Entity_Id; - Orig_Ent : Entity_Id); - -- The processing for Check_Internal_Call is divided up into two phases, - -- and this represents the second phase. The second phase is delayed if - -- Delaying_Elab_Checks is set to True. In this delayed case, the first - -- phase makes an entry in the Delay_Check table, which is processed when - -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to - -- Check_Internal_Call. Outer_Scope is the outer level scope for the - -- original call. - - function Has_Generic_Body (N : Node_Id) return Boolean; - -- N is a generic package instantiation node, and this routine determines - -- if this package spec does in fact have a generic body. If so, then - -- True is returned, otherwise False. Note that this is not at all the - -- same as checking if the unit requires a body, since it deals with - -- the case of optional bodies accurately (i.e. if a body is optional, - -- then it looks to see if a body is actually present). Note: this - -- function can only do a fully correct job if in generating code mode - -- where all bodies have to be present. If we are operating in semantics - -- check only mode, then in some cases of optional bodies, a result of - -- False may incorrectly be given. In practice this simply means that - -- some cases of warnings for incorrect order of elaboration will only - -- be given when generating code, which is not a big problem (and is - -- inevitable, given the optional body semantics of Ada). - - procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty); - -- Given code for an elaboration check (or unconditional raise if the check - -- is not needed), inserts the code in the appropriate place. N is the call - -- or instantiation node for which the check code is required. C is the - -- test whose failure triggers the raise. - - function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean; - -- Returns True if node N is a call to a generic formal subprogram - - function Is_Finalization_Procedure (Id : Entity_Id) return Boolean; - -- Determine whether entity Id denotes a [Deep_]Finalize procedure - - procedure Output_Calls - (N : Node_Id; - Check_Elab_Flag : Boolean); - -- Outputs chain of calls stored in the Elab_Call table. The caller has - -- already generated the main warning message, so the warnings generated - -- are all continuation messages. The argument is the call node at which - -- the messages are to be placed. When Check_Elab_Flag is set, calls are - -- enumerated only when flag Elab_Warning is set for the dynamic case or - -- when flag Elab_Info_Messages is set for the static case. - - function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; - -- Given two scopes, determine whether they are the same scope from an - -- elaboration point of view, i.e. packages and blocks are ignored. - - procedure Set_C_Scope; - -- On entry C_Scope is set to some scope. On return, C_Scope is reset - -- to be the enclosing compilation unit of this scope. - - function Get_Referenced_Ent (N : Node_Id) return Entity_Id; - -- N is either a function or procedure call or an access attribute that - -- references a subprogram. This call retrieves the relevant entity. If - -- this is a call to a protected subprogram, the entity is a selected - -- component. The callable entity may be absent, in which case Empty is - -- returned. This happens with non-analyzed calls in nested generics. - -- - -- If SPARK_Mode is On, then N can also be a reference to an E_Variable - -- entity, in which case, the value returned is simply this entity. - - procedure Set_Elaboration_Constraint - (Call : Node_Id; - Subp : Entity_Id; - Scop : Entity_Id); - -- The current unit U may depend semantically on some unit P that is not - -- in the current context. If there is an elaboration call that reaches P, - -- we need to indicate that P requires an Elaborate_All, but this is not - -- effective in U's ali file, if there is no with_clause for P. In this - -- case we add the Elaborate_All on the unit Q that directly or indirectly - -- makes P available. This can happen in two cases: - -- - -- a) Q declares a subtype of a type declared in P, and the call is an - -- initialization call for an object of that subtype. - -- - -- b) Q declares an object of some tagged type whose root type is - -- declared in P, and the initialization call uses object notation on - -- that object to reach a primitive operation or a classwide operation - -- declared in P. - -- - -- If P appears in the context of U, the current processing is correct. - -- Otherwise we must identify these two cases to retrieve Q and place the - -- Elaborate_All_Desirable on it. - - function Spec_Entity (E : Entity_Id) return Entity_Id; - -- Given a compilation unit entity, if it is a spec entity, it is returned - -- unchanged. If it is a body entity, then the spec for the corresponding - -- spec is returned - - procedure Supply_Bodies (N : Node_Id); - -- Given a node, N, that is either a subprogram declaration or a package - -- declaration, this procedure supplies dummy bodies for the subprogram - -- or for all subprograms in the package. If the given node is not one of - -- these two possibilities, then Supply_Bodies does nothing. The dummy body - -- contains a single Raise statement. - - procedure Supply_Bodies (L : List_Id); - -- Calls Supply_Bodies for all elements of the given list L - - function Within (E1, E2 : Entity_Id) return Boolean; - -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one - -- of its contained scopes, False otherwise. - - function Within_Elaborate_All - (Unit : Unit_Number_Type; - E : Entity_Id) return Boolean; - -- Return True if we are within the scope of an Elaborate_All for E, or if - -- we are within the scope of an Elaborate_All for some other unit U, and U - -- with's E. This prevents spurious warnings when the called entity is - -- renamed within U, or in case of generic instances. + Target_Id : Entity_Id; + Target_Decl : Node_Id; + Target_Body : Node_Id; + Ins_Nod : Node_Id); + -- Insert a run-time ABE check for elaboration scenario N which verifies + -- whether target Target_Id with initial declaration Target_Decl and body + -- Target_Body is elaborated. The check is inserted prior to node Ins_Nod. + + procedure Install_ABE_Failure (N : Node_Id; Ins_Nod : Node_Id); + -- Insert a Program_Error concerning a guaranteed ABE for elaboration + -- scenario N. The failure is inserted prior to node Node_Id. + + function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Accept_Alternative_Proc); + -- Determine whether arbitrary entity Id denotes an internally generated + -- procedure which encapsulates the statements of an accept alternative. + + function Is_Activation_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Activation_Proc); + -- Determine whether arbitrary entity Id denotes a runtime procedure in + -- charge with activating tasks. + + function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean; + pragma Inline (Is_Ada_Semantic_Target); + -- Determine whether arbitrary entity Id nodes a source or internally + -- generated subprogram which emulates Ada semantics. + + function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean; + pragma Inline (Is_Bodiless_Subprogram); + -- Determine whether subprogram Subp_Id will never have a body + + function Is_Check_Emitting_Scenario (N : Node_Id) return Boolean; + pragma Inline (Is_Check_Emitting_Scenario); + -- Determine whether arbitrary node N denotes a scenario which may emit a + -- conditional ABE check. + + function Is_Controlled_Proc + (Subp_Id : Entity_Id; + Subp_Nam : Name_Id) return Boolean; + pragma Inline (Is_Controlled_Proc); + -- Determine whether subprogram Subp_Id denotes controlled type primitives + -- Adjust, Finalize, or Initialize as denoted by name Subp_Nam. + + function Is_Default_Initial_Condition_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Default_Initial_Condition_Proc); + -- Determine whether arbitrary entity Id denotes internally generated + -- routine Default_Initial_Condition. + + function Is_Finalizer_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Finalizer_Proc); + -- Determine whether arbitrary entity Id denotes internally generated + -- routine _Finalizer. + + function Is_Guaranteed_ABE + (N : Node_Id; + Target_Decl : Node_Id; + Target_Body : Node_Id) return Boolean; + -- Determine whether scenario N with a target described by its initial + -- declaration Target_Decl and body Target_Decl results in a guaranteed + -- ABE. + + function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Initial_Condition_Proc); + -- Determine whether arbitrary entity Id denotes internally generated + -- routine Initial_Condition. + + function Is_Invariant_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Invariant_Proc); + -- Determine whether arbitrary entity Id denotes an invariant procedure + + function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean; + pragma Inline (Is_Non_Library_Level_Encapsulator); + -- Determine whether arbitrary node N is a non-library encapsulator + + function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Partial_Invariant_Proc); + -- Determine whether arbitrary entity Id denotes a partial invariant + -- procedure. + + function Is_Postconditions_Proc (Id : Entity_Id) return Boolean; + pragma Inline (Is_Postconditions_Proc); + -- Determine whether arbitrary entity Id denotes internally generated + -- routine _Postconditions. + + function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean; + pragma Inline (Is_Preelaborated_Unit); + -- Determine whether arbitrary entity Id denotes a unit which is subject to + -- one of the following pragmas: + -- + -- * Preelaborable + -- * Pure + -- * Remote_Call_Interface + -- * Remote_Types + -- * Shared_Passive + + function Is_Protected_Entry (Id : Entity_Id) return Boolean; + pragma Inline (Is_Protected_Entry); + -- Determine whether arbitrary entity Id denotes a protected entry + + function Is_Protected_Subp (Id : Entity_Id) return Boolean; + pragma Inline (Is_Protected_Subp); + -- Determine whether entity Id denotes a protected subprogram + + function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean; + pragma Inline (Is_Protected_Body_Subp); + -- Determine whether entity Id denotes the protected or unprotected version + -- of a protected subprogram. + + function Is_Safe_Activation + (Call : Node_Id; + Task_Decl : Node_Id) return Boolean; + pragma Inline (Is_Safe_Activation); + -- Determine whether call Call which activates a task object described by + -- declaration Task_Decl is always ABE-safe. + + function Is_Safe_Call + (Call : Node_Id; + Target_Attrs : Target_Attributes) return Boolean; + pragma Inline (Is_Safe_Call); + -- Determine whether call Call which invokes a target described by + -- attributes Target_Attrs is always ABE-safe. + + function Is_Safe_Instantiation + (Inst : Node_Id; + Gen_Attrs : Target_Attributes) return Boolean; + pragma Inline (Is_Safe_Instantiation); + -- Determine whether instance Inst which instantiates a generic unit + -- described by attributes Gen_Attrs is always ABE-safe. + + function Is_Same_Unit + (Unit_1 : Entity_Id; + Unit_2 : Entity_Id) return Boolean; + pragma Inline (Is_Same_Unit); + -- Determine whether entities Unit_1 and Unit_2 denote the same unit + + function Is_Scenario (N : Node_Id) return Boolean; + pragma Inline (Is_Scenario); + -- Determine whether attribute node N denotes a scenario. The scenario may + -- not necessarily be eligible for ABE processing. + + function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean; + pragma Inline (Is_SPARK_Semantic_Target); + -- Determine whether arbitrary entity Id nodes a source or internally + -- generated subprogram which emulates SPARK semantics. + + function Is_Suitable_Access (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Access); + -- Determine whether arbitrary node N denotes a suitable attribute for ABE + -- processing. + + function Is_Suitable_Call (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Call); + -- Determine whether arbitrary node N denotes a suitable call for ABE + -- processing. + + function Is_Suitable_Instantiation (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Instantiation); + -- Determine whether arbitrary node N is a suitable instantiation for ABE + -- processing. + + function Is_Suitable_Scenario (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Scenario); + -- Determine whether arbitrary node N is a suitable scenario for ABE + -- processing. + + function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Variable_Assignment); + -- Determine whether arbitrary node N denotes a suitable assignment for ABE + -- processing. + + function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Variable_Reference); + -- Determine whether arbitrary node N is a suitable reference to a variable + -- for ABE processing. + + function Is_Task_Entry (Id : Entity_Id) return Boolean; + pragma Inline (Is_Task_Entry); + -- Determine whether arbitrary entity Id denotes a task entry + + function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean; + pragma Inline (Is_Up_Level_Target); + -- Determine whether the current root resides at the declaration level. If + -- this is the case, determine whether a target described by declaration + -- Target_Decl is within a context which encloses the current root or is in + -- a different unit. + + procedure Meet_Elaboration_Requirement + (N : Node_Id; + Target_Id : Entity_Id; + Req_Nam : Name_Id); + -- Determine whether elaboration requirement Req_Nam for scenario N with + -- target Target_Id is met by the context of the main unit using the SPARK + -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an + -- error if this is not the case. + + function Non_Private_View (Typ : Entity_Id) return Entity_Id; + pragma Inline (Non_Private_View); + -- Return the full view of private type Typ if available, otherwise return + -- type Typ. + + procedure Output_Active_Scenarios (Error_Nod : Node_Id); + -- Output the contents of the active scenario stack from earliest to latest + -- to supplement an earlier error emitted for node Error_Nod. + + procedure Pop_Active_Scenario (N : Node_Id); + pragma Inline (Pop_Active_Scenario); + -- Pop the top of the scenario stack. A check is made to ensure that the + -- scenario being removed is the same as N. + + procedure Process_Access (Attr : Node_Id; In_Task_Body : Boolean); + -- Perform ABE checks and diagnostics for 'Access to entry, operator, or + -- subprogram denoted by Attr. Flag In_Task_Body should be set when the + -- processing is initiated from a task body. + + generic + with procedure Process_Single_Activation + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + In_Task_Body : Boolean); + -- Perform ABE checks and diagnostics for task activation call Call + -- which activates task Obj_Id. Call_Attrs are the attributes of the + -- activation call. Task_Attrs are the attributes of the task type. + -- Flag In_Task_Body should be set when the processing is initiated + -- from a task body. + + procedure Process_Activation_Call + (Call : Node_Id; + Call_Attrs : Call_Attributes; + In_Task_Body : Boolean); + -- Perform ABE checks and diagnostics for activation call Call by invoking + -- routine Process_Single_Activation on each task object being activated. + -- Call_Attrs are the attributes of the activation call. Flag In_Task_Body + -- should be set when the processing is initiated from a task body. + + procedure Process_Activation_Conditional_ABE_Impl + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + In_Task_Body : Boolean); + -- Perform common conditional ABE checks and diagnostics for call Call + -- which activates task Obj_Id ignoring the Ada or SPARK rules. CAll_Attrs + -- are the attributes of the activation call. Task_Attrs are the attributes + -- of the task type. Flag In_Task_Body should be set when the processing is + -- initiated from a task body. + + procedure Process_Activation_Guaranteed_ABE_Impl + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + In_Task_Body : Boolean); + -- Perform common guaranteed ABE checks and diagnostics for call Call + -- which activates task Obj_Id ignoring the Ada or SPARK rules. CAll_Attrs + -- are the attributes of the activation call. Task_Attrs are the attributes + -- of the task type. Flag In_Task_Body should be set when the processing is + -- initiated from a task body. + + procedure Process_Call + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + In_Task_Body : Boolean); + -- Top level dispatcher for processing of calls. Perform ABE checks and + -- diagnostics for call Call which invokes target Target_Id. Call_Attrs + -- are the attributes of the call. Flag In_Task_Body should be set when + -- the processing is initiated from a task body. + + procedure Process_Call_Ada + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes; + In_Task_Body : Boolean); + -- Perform ABE checks and diagnostics for call Call which invokes target + -- Target_Id using the Ada rules. Call_Attrs are the attributes of the + -- call. Target_Attrs are attributes of the target. Flag In_Task_Body + -- should be set when the processing is initiated from a task body. + + procedure Process_Call_Conditional_ABE + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes); + -- Perform common conditional ABE checks and diagnostics for call Call that + -- invokes target Target_Id ignoring the Ada or SPARK rules. Call_Attrs are + -- the attributes of the call. Target_Attrs are attributes of the target. + + procedure Process_Call_Guaranteed_ABE + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id); + -- Perform common guaranteed ABE checks and diagnostics for call Call which + -- invokes target Target_Id ignoring the Ada or SPARK rules. Call_Attrs are + -- the attributes of the call. + + procedure Process_Call_SPARK + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes); + -- Perform ABE checks and diagnostics for call Call which invokes target + -- Target_Id using the SPARK rules. Call_Attrs are the attributes of the + -- call. Target_Attrs are attributes of the target. + + procedure Process_Guaranteed_ABE (N : Node_Id); + -- Top level dispatcher for processing of scenarios which result in a + -- guaranteed ABE. + + procedure Process_Instantiation + (Exp_Inst : Node_Id; + In_Task_Body : Boolean); + -- Top level dispatcher for processing of instantiations. Perform ABE + -- checks and diagnostics for expanded instantiation Exp_Inst. Flag + -- In_Task_Body should be set when the processing is initiated from a + -- task body. + + procedure Process_Instantiation_Ada + (Exp_Inst : Node_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes; + In_Task_Body : Boolean); + -- Perform ABE checks and diagnostics for expanded instantiation Exp_Inst + -- of generic Gen_Id using the Ada rules. Inst is the instantiation node. + -- Inst_Attrs are the attributes of the instance. Gen_Attrs are the + -- attributes of the generic. Flag In_Task_Body should be set when the + -- processing is initiated from a task body. + + procedure Process_Instantiation_Conditional_ABE + (Exp_Inst : Node_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes); + -- Perform common conditional ABE checks and diagnostics for expanded + -- instantiation Exp_Inst of generic Gen_Id ignoring the Ada or SPARK + -- rules. Inst is the instantiation node. Inst_Attrs are the attributes + -- of the instance. Gen_Attrs are the attributes of the generic. + + procedure Process_Instantiation_Guaranteed_ABE (Exp_Inst : Node_Id); + -- Perform common guaranteed ABE checks and diagnostics for expanded + -- instantiation Exp_Inst of generic Gen_Id ignoring the Ada or SPARK + -- rules. + + procedure Process_Instantiation_SPARK + (Exp_Inst : Node_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes); + -- Perform ABE checks and diagnostics for expanded instantiation Exp_Inst + -- of generic Gen_Id using the SPARK rules. Inst is the instantiation node. + -- Inst_Attrs are the attributes of the instance. Gen_Attrs are the + -- attributes of the generic. + + procedure Process_Scenario (N : Node_Id; In_Task_Body : Boolean := False); + -- Top level dispatcher for processing of various elaboration scenarios. + -- Perform ABE checks and diagnostics for scenario N. Flag In_Task_Body + -- should be set when the processing is initiated from a task body. + + procedure Process_Variable_Assignment (Asmt : Node_Id); + -- Perform ABE checks and diagnostics for assignment statement Asmt + + procedure Process_Variable_Reference (Ref : Node_Id); + -- Perform ABE checks and diagnostics for variable reference Ref + + procedure Push_Active_Scenario (N : Node_Id); + pragma Inline (Push_Active_Scenario); + -- Push scenario N on top of the scenario stack + + function Root_Scenario return Node_Id; + pragma Inline (Root_Scenario); + -- Return the top level scenario which started a recursive search for other + -- scenarios. It is assumed that there is a valid top level scenario on the + -- active scenario stack. + + function Static_Elaboration_Checks return Boolean; + pragma Inline (Static_Elaboration_Checks); + -- Determine whether the static model is in effect + + procedure Traverse_Body (N : Node_Id; In_Task_Body : Boolean); + -- Inspect the declarations and statements of subprogram body N for + -- suitable elaboration scenarios and process them. Flag In_Task_Body + -- should be set when the traversal is initiated from a task body. + + procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id); + -- Update all relevant internal data structures when scenario Old_N is + -- transformed into scenario New_N by Atree.Rewrite. - -------------------------------------- - -- Activate_Elaborate_All_Desirable -- - -------------------------------------- + ----------------------- + -- Build_Call_Marker -- + ----------------------- - procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id) is - UN : constant Unit_Number_Type := Get_Code_Unit (N); - CU : constant Node_Id := Cunit (UN); - UE : constant Entity_Id := Cunit_Entity (UN); - Unm : constant Unit_Name_Type := Unit_Name (UN); - CI : constant List_Id := Context_Items (CU); - Itm : Node_Id; - Ent : Entity_Id; + procedure Build_Call_Marker (N : Node_Id) is + function In_External_Context + (Call : Node_Id; + Target_Id : Entity_Id) return Boolean; + pragma Inline (In_External_Context); + -- Determine whether target Target_Id is external to call N which must + -- reside within an instance. - procedure Add_To_Context_And_Mark (Itm : Node_Id); - -- This procedure is called when the elaborate indication must be - -- applied to a unit not in the context of the referencing unit. The - -- unit gets added to the context as an implicit with. + function In_Premature_Context (Call : Node_Id) return Boolean; + -- Determine whether call Call appears within a premature context - function In_Withs_Of (UEs : Entity_Id) return Boolean; - -- UEs is the spec entity of a unit. If the unit to be marked is - -- in the context item list of this unit spec, then the call returns - -- True and Itm is left set to point to the relevant N_With_Clause node. + function Is_Bridge_Target (Id : Entity_Id) return Boolean; + pragma Inline (Is_Bridge_Target); + -- Determine whether arbitrary entity Id denotes a bridge target - procedure Set_Elab_Flag (Itm : Node_Id); - -- Sets Elaborate_[All_]Desirable as appropriate on Itm + function Is_Default_Expression (Call : Node_Id) return Boolean; + pragma Inline (Is_Default_Expression); + -- Determine whether call Call acts as the expression of a defaulted + -- parameter within a source call. - ----------------------------- - -- Add_To_Context_And_Mark -- - ----------------------------- + function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean; + pragma Inline (Is_Generic_Formal_Subp); + -- Determine whether subprogram Subp_Id denotes a generic formal + -- subprogram which appears in the "prologue" of an instantiation. + + ------------------------- + -- In_External_Context -- + ------------------------- + + function In_External_Context + (Call : Node_Id; + Target_Id : Entity_Id) return Boolean + is + Target_Decl : constant Node_Id := Unit_Declaration_Node (Target_Id); - procedure Add_To_Context_And_Mark (Itm : Node_Id) is - CW : constant Node_Id := - Make_With_Clause (Sloc (Itm), - Name => Name (Itm)); + Inst : Node_Id; + Inst_Body : Node_Id; + Inst_Decl : Node_Id; begin - Set_Library_Unit (CW, Library_Unit (Itm)); - Set_Implicit_With (CW, True); + -- Performance note: parent traversal - -- Set elaborate all desirable on copy and then append the copy to - -- the list of body with's and we are done. + Inst := Find_Enclosing_Instance (Call); - Set_Elab_Flag (CW); - Append_To (CI, CW); - end Add_To_Context_And_Mark; + -- The call appears within an instance - ----------------- - -- In_Withs_Of -- - ----------------- + if Present (Inst) then + + -- The call comes from the main unit and the target does not + + if In_Extended_Main_Code_Unit (Call) + and then not In_Extended_Main_Code_Unit (Target_Decl) + then + return True; + + -- Otherwise the target declaration must not appear within the + -- instance spec or body. + + else + Extract_Instance_Attributes + (Exp_Inst => Inst, + Inst_Decl => Inst_Decl, + Inst_Body => Inst_Body); + + -- Performance note: parent traversal - function In_Withs_Of (UEs : Entity_Id) return Boolean is - UNs : constant Unit_Number_Type := Get_Source_Unit (UEs); - CUs : constant Node_Id := Cunit (UNs); - CIs : constant List_Id := Context_Items (CUs); + return not In_Subtree + (N => Target_Decl, + Root1 => Inst_Decl, + Root2 => Inst_Body); + end if; + end if; + + return False; + end In_External_Context; + + -------------------------- + -- In_Premature_Context -- + -------------------------- + + function In_Premature_Context (Call : Node_Id) return Boolean is + Par : Node_Id; begin - Itm := First (CIs); - while Present (Itm) loop - if Nkind (Itm) = N_With_Clause then - Ent := - Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); + -- Climb the parent chain looking for premature contexts - if U = Ent then - return True; - end if; + Par := Parent (Call); + while Present (Par) loop + + -- Aspect specifications and generic associations are premature + -- contexts because nested calls has not been relocated to their + -- final context. + + if Nkind_In (Par, N_Aspect_Specification, + N_Generic_Association) + then + return True; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Par) then + exit; end if; - Next (Itm); + Par := Parent (Par); end loop; return False; - end In_Withs_Of; + end In_Premature_Context; - ------------------- - -- Set_Elab_Flag -- - ------------------- + ---------------------- + -- Is_Bridge_Target -- + ---------------------- - procedure Set_Elab_Flag (Itm : Node_Id) is + function Is_Bridge_Target (Id : Entity_Id) return Boolean is begin - if Nkind (N) in N_Subprogram_Instantiation then - Set_Elaborate_Desirable (Itm); - else - Set_Elaborate_All_Desirable (Itm); + return + Is_Accept_Alternative_Proc (Id) + or else Is_Finalizer_Proc (Id) + or else Is_Partial_Invariant_Proc (Id) + or else Is_Postconditions_Proc (Id) + or else Is_TSS (Id, TSS_Deep_Adjust) + or else Is_TSS (Id, TSS_Deep_Finalize) + or else Is_TSS (Id, TSS_Deep_Initialize); + end Is_Bridge_Target; + + --------------------------- + -- Is_Default_Expression -- + --------------------------- + + function Is_Default_Expression (Call : Node_Id) return Boolean is + Outer_Call : constant Node_Id := Parent (Call); + Outer_Nam : Node_Id; + + begin + -- To qualify, the node must appear immediately within a source call + -- which invokes a source target. + + if Nkind_In (Outer_Call, N_Entry_Call_Statement, + N_Function_Call, + N_Procedure_Call_Statement) + and then Comes_From_Source (Outer_Call) + then + Outer_Nam := Extract_Call_Name (Outer_Call); + + return + Is_Entity_Name (Outer_Nam) + and then Present (Entity (Outer_Nam)) + and then Is_Subprogram_Or_Entry (Entity (Outer_Nam)) + and then Comes_From_Source (Entity (Outer_Nam)); end if; - end Set_Elab_Flag; - -- Start of processing for Activate_Elaborate_All_Desirable + return False; + end Is_Default_Expression; + + ---------------------------- + -- Is_Generic_Formal_Subp -- + ---------------------------- + + function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean is + Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); + Context : constant Node_Id := Parent (Subp_Decl); + + begin + -- To qualify, the subprogram must rename a generic actual subprogram + -- where the enclosing context is an instantiation. + + return + Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration + and then not Comes_From_Source (Subp_Decl) + and then Nkind_In (Context, N_Function_Specification, + N_Package_Specification, + N_Procedure_Specification) + and then Present (Generic_Parent (Context)); + end Is_Generic_Formal_Subp; + + -- Local variables + + Call_Attrs : Call_Attributes; + Call_Nam : Node_Id; + Marker : Node_Id; + Target_Id : Entity_Id; + + -- Start of processing for Build_Call_Marker begin - -- Do not set binder indication if expansion is disabled, as when - -- compiling a generic unit. + -- Nothing to do for ASIS. As a result, ABE checks and diagnostics are + -- not performed in this mode. + + if ASIS_Mode then + return; + + -- Nothing to do when the input does not denote a call or a requeue + + elsif not Nkind_In (N, N_Entry_Call_Statement, + N_Function_Call, + N_Procedure_Call_Statement, + N_Requeue_Statement) + then + return; + + -- Nothing to do when the call is being preanalyzed as the marker will + -- be inserted in the wrong place. + + elsif Preanalysis_Active then + return; - if not Expander_Active then + -- Nothing to do when the call is analyzed/resolved too early within an + -- intermediate context. + + -- Performance note: parent traversal + + elsif In_Premature_Context (N) then return; end if; - -- If an instance of a generic package contains a controlled object (so - -- we're calling Initialize at elaboration time), and the instance is in - -- a package body P that says "with P;", then we need to return without - -- adding "pragma Elaborate_All (P);" to P. + Call_Nam := Extract_Call_Name (N); + + -- Nothing to do when the call is erroneous or left in a bad state - if U = Main_Unit_Entity then + if not (Is_Entity_Name (Call_Nam) + and then Present (Entity (Call_Nam)) + and then Is_Subprogram_Or_Entry (Entity (Call_Nam))) + then + return; + + -- Nothing to do when the call invokes a generic formal subprogram and + -- switch -gnatd.G (ignore calls through generic formal parameters for + -- elaboration) is in effect. This check must be performed with the + -- direct target of the call to avoid the side effects of mapping + -- actuals to formals using renamings. + + elsif Debug_Flag_Dot_GG + and then Is_Generic_Formal_Subp (Entity (Call_Nam)) + then return; end if; - Itm := First (CI); - while Present (Itm) loop - if Nkind (Itm) = N_With_Clause then - Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); + Extract_Call_Attributes + (Call => N, + Target_Id => Target_Id, + Attrs => Call_Attrs); - -- If we find it, then mark elaborate all desirable and return + -- Nothing to do when the call appears within the expanded spec or + -- body of an instantiated generic, the call does not invoke a generic + -- formal subprogram, the target is external to the instance, and switch + -- -gnatdL (ignore external calls from instances for elaboration) is in + -- effect. This behaviour approximates that of the old ABE mechanism. - if U = Ent then - Set_Elab_Flag (Itm); - return; - end if; - end if; + if Debug_Flag_LL + and then not Is_Generic_Formal_Subp (Entity (Call_Nam)) - Next (Itm); - end loop; + -- Performance note: parent traversal + + and then In_External_Context + (Call => N, + Target_Id => Target_Id) + then + return; + + -- Source calls to source targets are always considered because they + -- reflect the original call graph. + + elsif Comes_From_Source (Target_Id) and then Call_Attrs.From_Source then + null; - -- If we fall through then the with clause is not present in the - -- current unit. One legitimate possibility is that the with clause - -- is present in the spec when we are a body. + -- A call to a source function which acts as the default expression in + -- another call requires special detection. - if Is_Body_Name (Unm) - and then In_Withs_Of (Spec_Entity (UE)) + elsif Comes_From_Source (Target_Id) + and then Nkind (N) = N_Function_Call + and then Is_Default_Expression (N) then - Add_To_Context_And_Mark (Itm); + null; + + -- The target emulates Ada semantics + + elsif Is_Ada_Semantic_Target (Target_Id) then + null; + + -- The target acts as a link between scenarios + + elsif Is_Bridge_Target (Target_Id) then + null; + + -- The target emulates SPARK semantics + + elsif Is_SPARK_Semantic_Target (Target_Id) then + null; + + -- Otherwise the call is not suitable for ABE processing. This prevents + -- the generation of call markers which will never play a role in ABE + -- diagnostics. + + else return; end if; - -- Similarly, we may be in the spec or body of a child unit, where - -- the unit in question is with'ed by some ancestor of the child unit. + -- At this point it is known that the call will play some role in ABE + -- checks and diagnostics. Create a corresponding call marker in case + -- the original call is heavily transformed by expansion later on. - if Is_Child_Name (Unm) then - declare - Pkg : Entity_Id; + Marker := Make_Call_Marker (Sloc (N)); - begin - Pkg := UE; - loop - Pkg := Scope (Pkg); - exit when Pkg = Standard_Standard; - - if In_Withs_Of (Pkg) then - Add_To_Context_And_Mark (Itm); - return; - end if; - end loop; - end; - end if; + -- Inherit the attributes of the original call - -- Here if we do not find with clause on spec or body. We just ignore - -- this case; it means that the elaboration involves some other unit - -- than the unit being compiled, and will be caught elsewhere. - end Activate_Elaborate_All_Desirable; + Set_Target (Marker, Target_Id); + Set_Is_Elaboration_Checks_OK_Node (Marker, Call_Attrs.Elab_Checks_OK); + Set_Is_Declaration_Level_Node (Marker, Call_Attrs.In_Declarations); + Set_Is_Dispatching_Call (Marker, Call_Attrs.Is_Dispatching); + Set_Is_Ignored_Ghost_Node (Marker, Call_Attrs.Ghost_Mode_Ignore); + Set_Is_Source_Call (Marker, Call_Attrs.From_Source); + Set_Is_SPARK_Mode_On_Node (Marker, Call_Attrs.SPARK_Mode_On); - ------------------ - -- Check_A_Call -- - ------------------ + -- The marker is inserted prior to the original call. This placement has + -- several desirable effects: - procedure Check_A_Call - (N : Node_Id; - E : Entity_Id; - Outer_Scope : Entity_Id; - Inter_Unit_Only : Boolean; - Generate_Warnings : Boolean := True; - In_Init_Proc : Boolean := False) - is - Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference; - -- Indicates if we have Access attribute case - - function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean; - -- True if we're calling an instance of a generic subprogram, or a - -- subprogram in an instance of a generic package, and the call is - -- outside that instance. - - procedure Elab_Warning - (Msg_D : String; - Msg_S : String; - Ent : Node_Or_Entity_Id); - -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for - -- dynamic or static elaboration model), N and Ent. Msg_D is a real - -- warning (output if Msg_D is non-null and Elab_Warnings is set), - -- Msg_S is an info message (output if Elab_Info_Messages is set). - - function Find_W_Scope return Entity_Id; - -- Find top-level scope for called entity (not following renamings - -- or derivations). This is where the Elaborate_All will go if it is - -- needed. We start with the called entity, except in the case of an - -- initialization procedure outside the current package, where the init - -- proc is in the root package, and we start from the entity of the name - -- in the call. + -- 1) The marker appears in the same context, in close proximity to + -- the call. - ----------------------------------- - -- Call_To_Instance_From_Outside -- - ----------------------------------- + -- <marker> + -- <call> - function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean is - Scop : Entity_Id := Id; + -- 2) Inserting the marker prior to the call ensures that an ABE check + -- will take effect prior to the call. - begin - loop - if Scop = Standard_Standard then - return False; - end if; + -- <ABE check> + -- <marker> + -- <call> - if Is_Generic_Instance (Scop) then - return not In_Open_Scopes (Scop); - end if; + -- 3) The above two properties are preserved even when the call is a + -- function which is subsequently relocated in order to capture its + -- result. Note that if the call is relocated to a new context, the + -- relocated call will receive a marker of its own. - Scop := Scope (Scop); - end loop; - end Call_To_Instance_From_Outside; + -- <ABE check> + -- <maker> + -- Temp : ... := Func_Call ...; + -- ... Temp ... - ------------------ - -- Elab_Warning -- - ------------------ + -- The insertion must take place even when the call does not occur in + -- the main unit to keep the tree symmetric. This ensures that internal + -- name serialization is consistent in case the call marker causes the + -- tree to transform in some way. - procedure Elab_Warning - (Msg_D : String; - Msg_S : String; - Ent : Node_Or_Entity_Id) - is - begin - -- Dynamic elaboration checks, real warning + Insert_Action (N, Marker); - if Dynamic_Elaboration_Checks then - if not Access_Case then - if Msg_D /= "" and then Elab_Warnings then - Error_Msg_NE (Msg_D, N, Ent); - end if; + -- The marker becomes the "corresponding" scenario for the call. Save + -- the marker for later processing by the ABE phase. - -- In the access case emit first warning message as well, - -- otherwise list of calls will appear as errors. + Record_Elaboration_Scenario (Marker); + end Build_Call_Marker; - elsif Elab_Warnings then - Error_Msg_NE (Msg_S, N, Ent); - end if; + --------------------------------- + -- Check_Elaboration_Scenarios -- + --------------------------------- - -- Static elaboration checks, info message + procedure Check_Elaboration_Scenarios is + begin + -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics + -- are performed in this mode. - else - if Elab_Info_Messages then - Error_Msg_NE (Msg_S, N, Ent); - end if; - end if; - end Elab_Warning; + if ASIS_Mode then + return; + end if; + + -- Examine the context of the main unit and record all units with prior + -- elaboration with respect to it. + + Find_Elaborated_Units; + + -- Examine each top level scenario saved during the Recording phase and + -- perform various actions depending on the elaboration model in effect. + + for Index in Top_Level_Scenarios.First .. Top_Level_Scenarios.Last loop + + -- Clear the table of visited scenario bodies for each new top level + -- scenario. + + Visited_Bodies.Reset; + + Process_Scenario (Top_Level_Scenarios.Table (Index)); + end loop; + end Check_Elaboration_Scenarios; - ------------------ - -- Find_W_Scope -- - ------------------ + ------------------------------ + -- Check_Preelaborated_Call -- + ------------------------------ + + procedure Check_Preelaborated_Call (Call : Node_Id) is + function In_Preelaborated_Context (N : Node_Id) return Boolean; + -- Determine whether arbitrary node appears in a preelaborated context - function Find_W_Scope return Entity_Id is - Refed_Ent : constant Entity_Id := Get_Referenced_Ent (N); - W_Scope : Entity_Id; + ------------------------------ + -- In_Preelaborated_Context -- + ------------------------------ + + function In_Preelaborated_Context (N : Node_Id) return Boolean is + Body_Id : constant Entity_Id := Find_Code_Unit (N); + Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); begin - if Is_Init_Proc (Refed_Ent) - and then not In_Same_Extended_Unit (N, Refed_Ent) + -- The node appears within a package body whose corresponding spec is + -- subject to pragma Remote_Call_Interface or Remote_Types. This does + -- not result in a preelaborated context because the package body may + -- be on another machine. + + if Ekind (Body_Id) = E_Package_Body + and then Ekind (Spec_Id) = E_Package + and then (Is_Remote_Call_Interface (Spec_Id) + or else Is_Remote_Types (Spec_Id)) then - W_Scope := Scope (Refed_Ent); + return False; + + -- Otherwise the node appears within a preelaborated context when the + -- associated unit is preelaborated. + else - W_Scope := E; + return Is_Preelaborated_Unit (Spec_Id); end if; + end In_Preelaborated_Context; - -- Now loop through scopes to get to the enclosing compilation unit + -- Local variables - while not Is_Compilation_Unit (W_Scope) loop - W_Scope := Scope (W_Scope); - end loop; + Call_Attrs : Call_Attributes; + Level : Enclosing_Level_Kind; + Target_Id : Entity_Id; - return W_Scope; - end Find_W_Scope; + -- Start of processing for Check_Preelaborated_Call - -- Local variables + begin + Extract_Call_Attributes + (Call => Call, + Target_Id => Target_Id, + Attrs => Call_Attrs); - Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; - -- Indicates if we have instantiation case - - Loc : constant Source_Ptr := Sloc (N); - - Variable_Case : constant Boolean := - Nkind (N) in N_Has_Entity - and then Present (Entity (N)) - and then Ekind (Entity (N)) = E_Variable; - -- Indicates if we have variable reference case - - W_Scope : constant Entity_Id := Find_W_Scope; - -- Top-level scope of directly called entity for subprogram. This - -- differs from E_Scope in the case where renamings or derivations - -- are involved, since it does not follow these links. W_Scope is - -- generally in a visible unit, and it is this scope that may require - -- an Elaborate_All. However, there are some cases (initialization - -- calls and calls involving object notation) where W_Scope might not - -- be in the context of the current unit, and there is an intermediate - -- package that is, in which case the Elaborate_All has to be placed - -- on this intermediate package. These special cases are handled in - -- Set_Elaboration_Constraint. - - Ent : Entity_Id; - Callee_Unit_Internal : Boolean; - Caller_Unit_Internal : Boolean; - Decl : Node_Id; - Inst_Callee : Source_Ptr; - Inst_Caller : Source_Ptr; - Unit_Callee : Unit_Number_Type; - Unit_Caller : Unit_Number_Type; - - Body_Acts_As_Spec : Boolean; - -- Set to true if call is to body acting as spec (no separate spec) - - Cunit_SC : Boolean := False; - -- Set to suppress dynamic elaboration checks where one of the - -- enclosing scopes has Elaboration_Checks_Suppressed set, or else - -- if a pragma Elaborate[_All] applies to that scope, in which case - -- warnings on the scope are also suppressed. For the internal case, - -- we ignore this flag. - - E_Scope : Entity_Id; - -- Top-level scope of entity for called subprogram. This value includes - -- following renamings and derivations, so this scope can be in a - -- non-visible unit. This is the scope that is to be investigated to - -- see whether an elaboration check is required. - - Is_DIC : Boolean; - -- Flag set when the subprogram being invoked is the procedure generated - -- for pragma Default_Initial_Condition. - - SPARK_Elab_Errors : Boolean; - -- Flag set when an entity is called or a variable is read during SPARK - -- dynamic elaboration. - - -- Start of processing for Check_A_Call - - begin - -- If the call is known to be within a local Suppress Elaboration - -- pragma, nothing to check. This can happen in task bodies. But - -- we ignore this for a call to a generic formal. - - if Nkind (N) in N_Subprogram_Call - and then No_Elaboration_Check (N) - and then not Is_Call_Of_Generic_Formal (N) - then + -- Nothing to do when the call is internally generated because it is + -- assumed that it will never violate preelaboration. + + if not Call_Attrs.From_Source then return; + end if; - -- If this is a rewrite of a Valid_Scalars attribute, then nothing to - -- check, we don't mind in this case if the call occurs before the body - -- since this is all generated code. + -- Performance note: parent traversal - elsif Nkind (Original_Node (N)) = N_Attribute_Reference - and then Attribute_Name (Original_Node (N)) = Name_Valid_Scalars - then - return; + Level := Find_Enclosing_Level (Call); - -- Intrinsics such as instances of Unchecked_Deallocation do not have - -- any body, so elaboration checking is not needed, and would be wrong. + -- Library level calls are always considered because they are part of + -- the associated unit's elaboration actions. - elsif Is_Intrinsic_Subprogram (E) then - return; + if Level in Library_Level then + null; + + -- Calls at the library level of a generic package body must be checked + -- because they would render an instantiation illegal if the template is + -- marked as preelaborated. Note that this does not apply to calls at + -- the library level of a generic package spec. + + elsif Level = Generic_Package_Body then + null; - -- Do not consider references to internal variables for SPARK semantics + -- Otherwise the call does not appear at the proper level and must not + -- be considered for this check. - elsif Variable_Case and then not Comes_From_Source (E) then + else return; end if; - -- Proceed with check + -- The call appears within a preelaborated unit. Emit a warning only for + -- internal uses, otherwise this is an error. + + if In_Preelaborated_Context (Call) then + Error_Msg_Warn := GNAT_Mode; + Error_Msg_N + ("<<non-static call not allowed in preelaborated unit", Call); + end if; + end Check_Preelaborated_Call; + + ---------------------- + -- Compilation_Unit -- + ---------------------- - Ent := E; + function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is + Comp_Unit : Node_Id; - -- For a variable reference, just set Body_Acts_As_Spec to False + begin + Comp_Unit := Parent (Unit_Id); - if Variable_Case then - Body_Acts_As_Spec := False; + -- Handle the case where a concurrent subunit is rewritten as a null + -- statement due to expansion activities. + + if Nkind (Comp_Unit) = N_Null_Statement + and then Nkind_In (Original_Node (Comp_Unit), N_Protected_Body, + N_Task_Body) + then + Comp_Unit := Parent (Comp_Unit); + pragma Assert (Nkind (Comp_Unit) = N_Subunit); - -- Additional checks for all other cases + -- Otherwise use the declaration node of the unit else - -- Go to parent for derived subprogram, or to original subprogram in - -- the case of a renaming (Alias covers both these cases). + Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id)); + end if; - loop - if (Suppress_Elaboration_Warnings (Ent) - or else Elaboration_Checks_Suppressed (Ent)) - and then (Inst_Case or else No (Alias (Ent))) - then - return; - end if; + if Nkind (Comp_Unit) = N_Subunit then + Comp_Unit := Parent (Comp_Unit); + end if; - -- Nothing to do for imported entities + pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); - if Is_Imported (Ent) then - return; - end if; + return Comp_Unit; + end Compilation_Unit; - exit when Inst_Case or else No (Alias (Ent)); - Ent := Alias (Ent); - end loop; + ----------------- + -- Elab_Msg_NE -- + ----------------- - Decl := Unit_Declaration_Node (Ent); + procedure Elab_Msg_NE + (Msg : String; + N : Node_Id; + Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean) + is + function Prefix return String; + -- Obtain the prefix of the message - if Nkind (Decl) = N_Subprogram_Body then - Body_Acts_As_Spec := True; + function Suffix return String; + -- Obtain the suffix of the message - elsif Nkind_In (Decl, N_Subprogram_Declaration, - N_Subprogram_Body_Stub) - or else Inst_Case - then - Body_Acts_As_Spec := False; + ------------ + -- Prefix -- + ------------ - -- If we have none of an instantiation, subprogram body or subprogram - -- declaration, or in the SPARK case, a variable reference, then - -- it is not a case that we want to check. (One case is a call to a - -- generic formal subprogram, where we do not want the check in the - -- template). + function Prefix return String is + begin + if Info_Msg then + return "info: "; + else + return ""; + end if; + end Prefix; + ------------ + -- Suffix -- + ------------ + + function Suffix return String is + begin + if In_SPARK then + return " in SPARK"; else - return; + return ""; + end if; + end Suffix; + + -- Start of processing for Elab_Msg_NE + + begin + Error_Msg_NE (Prefix & Msg & Suffix, N, Id); + end Elab_Msg_NE; + + ------------------------------ + -- Elaboration_Context_Hash -- + ------------------------------ + + function Elaboration_Context_Hash + (Key : Entity_Id) return Elaboration_Context_Index + is + begin + return Elaboration_Context_Index (Key mod Elaboration_Context_Max); + end Elaboration_Context_Hash; + + -------------------------------------- + -- Ensure_Dynamic_Prior_Elaboration -- + -------------------------------------- + + procedure Ensure_Dynamic_Prior_Elaboration + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id) + is + procedure Info_Missing_Pragma; + pragma Inline (Info_Missing_Pragma); + -- Output information concerning missing Elaborate or Elaborate_All + -- pragma with name Prag_Nam for scenario N which ensures the prior + -- elaboration of Unit_Id. + + ------------------------- + -- Info_Missing_Pragma -- + ------------------------- + + procedure Info_Missing_Pragma is + begin + -- Internal units are ignored as they cause unnecessary noise + + if not In_Internal_Unit (Unit_Id) then + + -- The name of the unit subjected to the elaboration pragma is + -- fully qualified to improve the clarity of the info message. + + Error_Msg_Name_1 := Prag_Nam; + Error_Msg_Qual_Level := Nat'Last; + + Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id); + Error_Msg_Qual_Level := 0; end if; + end Info_Missing_Pragma; + + -- Local variables + + Elab_Attrs : Elaboration_Attributes; + Level : Enclosing_Level_Kind; + + -- Start of processing for Ensure_Dynamic_Prior_Elaboration + + begin + Elab_Attrs := Elaboration_Context.Get (Unit_Id); + + -- Nothing to do when the unit is guaranteed prior elaboration by means + -- of a source Elaborate[_All] pragma. + + if Present (Elab_Attrs.Source_Pragma) then + return; end if; - E_Scope := Ent; - loop - if Elaboration_Checks_Suppressed (E_Scope) - or else Suppress_Elaboration_Warnings (E_Scope) + -- Output extra information on a missing Elaborate[_All] pragma when + -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas + -- is in effect. + + if Elab_Info_Messages then + + -- Performance note: parent traversal + + Level := Find_Enclosing_Level (N); + + -- Declaration level scenario + + if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N)) + and then Level = Declaration_Level then - Cunit_SC := True; - end if; + null; - -- Exit when we get to compilation unit, not counting subunits + -- Library level scenario - exit when Is_Compilation_Unit (E_Scope) - and then (Is_Child_Unit (E_Scope) - or else Scope (E_Scope) = Standard_Standard); + elsif Level in Library_Level then + null; - pragma Assert (E_Scope /= Standard_Standard); + -- Instantiation library level scenario - -- Move up a scope looking for compilation unit + elsif Level = Instantiation then + null; - E_Scope := Scope (E_Scope); - end loop; + -- Otherwise the scenario does not appear at the proper level and + -- cannot possibly act as a top level scenario. - -- No checks needed for pure or preelaborated compilation units + else + return; + end if; - if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then - return; + Info_Missing_Pragma; end if; + end Ensure_Dynamic_Prior_Elaboration; - -- If the generic entity is within a deeper instance than we are, then - -- either the instantiation to which we refer itself caused an ABE, in - -- which case that will be handled separately, or else we know that the - -- body we need appears as needed at the point of the instantiation. - -- However, this assumption is only valid if we are in static mode. + ------------------------------ + -- Ensure_Prior_Elaboration -- + ------------------------------ - if not Dynamic_Elaboration_Checks - and then - Instantiation_Depth (Sloc (Ent)) > Instantiation_Depth (Sloc (N)) - then - return; + procedure Ensure_Prior_Elaboration + (N : Node_Id; + Unit_Id : Entity_Id; + In_Task_Body : Boolean) + is + Prag_Nam : Name_Id; + + begin + -- Instantiating an external generic unit requires an implicit Elaborate + -- because Elaborate_All is too strong and could introduce non-existent + -- elaboration cycles. + + -- package External is + -- function Func ...; + -- end External; + + -- with External; + -- generic + -- package Gen is + -- X : ... := External.Func; + -- end Gen; + + -- [with External;] -- implicit with for External + -- [pragma Elaborate_All (External);] -- Elaborate_All for External + -- with Gen; + -- [pragma Elaborate (Gen);] -- Elaborate for generic + -- procedure Main is + -- package Inst is new Gen; -- calls External.Func + -- ... + -- end Main; + + if Nkind (N) in N_Generic_Instantiation then + Prag_Nam := Name_Elaborate; + + -- Otherwise generate an implicit Elaborate_All + + else + Prag_Nam := Name_Elaborate_All; end if; - -- Do not give a warning for a package with no body + -- Nothing to do when the need for prior elaboration came from a task + -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on + -- task bodies) is in effect. - if Ekind (Ent) = E_Generic_Package and then not Has_Generic_Body (N) then + if Debug_Flag_Dot_Y and then In_Task_Body then return; + + -- Nothing to do when the unit is elaborated prior to the main unit. + -- This check must also consider the following cases: + + -- * No check is made against the context of the main unit because this + -- is specific to the elaboration model in effect and requires custom + -- handling (see Ensure_xxx_Prior_Elaboration). + + -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma + -- Elaborate[_All] MUST be generated even though Unit_Id is always + -- elaborated prior to the main unit. This is a conservative strategy + -- which ensures that other units withed by Unit_Id will not lead to + -- an ABE. + + -- package A is package body A is + -- procedure ABE; procedure ABE is ... end ABE; + -- end A; end A; + + -- with A; + -- package B is package body B is + -- pragma Elaborate_Body; procedure Proc is + -- begin + -- procedure Proc; A.ABE; + -- package B; end Proc; + -- end B; + + -- with B; + -- package C is package body C is + -- ... ... + -- end C; begin + -- B.Proc; + -- end C; + + -- In the example above, the elaboration of C invokes B.Proc. B is + -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] is + -- generated for B in C, then the following elaboratio order will lead + -- to an ABE: + + -- spec of A elaborated + -- spec of B elaborated + -- body of B elaborated + -- spec of C elaborated + -- body of C elaborated <-- calls B.Proc which calls A.ABE + -- body of A elaborated <-- problem + + -- The generation of an implicit pragma Elaborate_All (B) ensures that + -- the elaboration order mechanism will not pick the above order. + + -- An implicit Elaborate is NOT generated when the unit is subject to + -- Elaborate_Body because both pragmas have the exact same effect. + + -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] MUST + -- NOT be generated in this case because a unit cannot depend on its + -- own elaboration. This case is therefore treated as valid prior + -- elaboration. + + elsif Has_Prior_Elaboration + (Unit_Id => Unit_Id, + Same_Unit_OK => True, + Elab_Body_OK => Prag_Nam = Name_Elaborate) + then + return; + + -- Suggest the use of pragma Prag_Nam when the dynamic model is in + -- effect. + + elsif Dynamic_Elaboration_Checks then + Ensure_Dynamic_Prior_Elaboration + (N => N, + Unit_Id => Unit_Id, + Prag_Nam => Prag_Nam); + + -- Install an implicit pragma Prag_Nam when the static model is in + -- effect. + + else + pragma Assert (Static_Elaboration_Checks); + + Ensure_Static_Prior_Elaboration + (N => N, + Unit_Id => Unit_Id, + Prag_Nam => Prag_Nam); end if; + end Ensure_Prior_Elaboration; - -- Case of entity is in same unit as call or instantiation. In the - -- instantiation case, W_Scope may be different from E_Scope; we want - -- the unit in which the instantiation occurs, since we're analyzing - -- based on the expansion. + ------------------------------------- + -- Ensure_Static_Prior_Elaboration -- + ------------------------------------- - if W_Scope = C_Scope then - if not Inter_Unit_Only then - Check_Internal_Call (N, Ent, Outer_Scope, E); + procedure Ensure_Static_Prior_Elaboration + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id) + is + function Find_With_Clause + (Items : List_Id; + Withed_Id : Entity_Id) return Node_Id; + -- Find a non-limited with clause in the list of context items Items + -- which withs unit Withed_Id. Return Empty if no such clause is found. + + procedure Info_Implicit_Pragma; + pragma Inline (Info_Implicit_Pragma); + -- Output information concerning an implicitly generated Elaborate or + -- Elaborate_All pragma with name Prag_Nam for scenario N which ensures + -- the prior elaboration of unit Unit_Id. + + ---------------------- + -- Find_With_Clause -- + ---------------------- + + function Find_With_Clause + (Items : List_Id; + Withed_Id : Entity_Id) return Node_Id + is + Item : Node_Id; + + begin + -- Examine the context clauses looking for a suitable with. Note that + -- limited clauses do not affect the elaboration order. + + Item := First (Items); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then not Error_Posted (Item) + and then not Limited_Present (Item) + and then Entity (Name (Item)) = Withed_Id + then + return Item; + end if; + + Next (Item); + end loop; + + return Empty; + end Find_With_Clause; + + -------------------------- + -- Info_Implicit_Pragma -- + -------------------------- + + procedure Info_Implicit_Pragma is + begin + -- Internal units are ignored as they cause unnecessary noise + + if not In_Internal_Unit (Unit_Id) then + + -- The name of the unit subjected to the elaboration pragma is + -- fully qualified to improve the clarity of the info message. + + Error_Msg_Name_1 := Prag_Nam; + Error_Msg_Qual_Level := Nat'Last; + + Error_Msg_NE + ("info: implicit pragma % generated for unit &", N, Unit_Id); + + Error_Msg_Qual_Level := 0; + Output_Active_Scenarios (N); end if; + end Info_Implicit_Pragma; - return; - end if; + -- Local variables + + Main_Cunit : constant Node_Id := Cunit (Main_Unit); + Loc : constant Source_Ptr := Sloc (Main_Cunit); + Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id); + + Is_Instantiation : constant Boolean := + Nkind (N) in N_Generic_Instantiation; - -- Case of entity is not in current unit (i.e. with'ed unit case) + Clause : Node_Id; + Elab_Attrs : Elaboration_Attributes; + Items : List_Id; - -- We are only interested in such calls if the outer call was from - -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode. + -- Start of processing for Ensure_Static_Prior_Elaboration - if not From_Elab_Code and then not Dynamic_Elaboration_Checks then + begin + Elab_Attrs := Elaboration_Context.Get (Unit_Id); + + -- Nothing to do when the unit is guaranteed prior elaboration by means + -- of a source Elaborate[_All] pragma. + + if Present (Elab_Attrs.Source_Pragma) then return; - end if; - -- Nothing to do if some scope said that no checks were required + -- Nothing to do when the unit has an existing implicit Elaborate[_All] + -- pragma installed by a previous scenario. + + elsif Present (Elab_Attrs.With_Clause) then + + -- The unit is already guaranteed prior elaboration by means of an + -- implicit Elaborate pragma, however the current scenario imposes + -- a stronger requirement of Elaborate_All. "Upgrade" the existing + -- pragma to match this new requirement. + + if Elaborate_Desirable (Elab_Attrs.With_Clause) + and then Prag_Nam = Name_Elaborate_All + then + Set_Elaborate_All_Desirable (Elab_Attrs.With_Clause); + Set_Elaborate_Desirable (Elab_Attrs.With_Clause, False); + end if; - if Cunit_SC then return; end if; - -- Nothing to do for a generic instance, because a call to an instance - -- cannot fail the elaboration check, because the body of the instance - -- is always elaborated immediately after the spec. + -- At this point it is known that the unit has no prior elaboration + -- according to pragmas and hierarchical relationships. - if Call_To_Instance_From_Outside (Ent) then - return; + Items := Context_Items (Main_Cunit); + + if No (Items) then + Items := New_List; + Set_Context_Items (Main_Cunit, Items); end if; - -- Nothing to do if subprogram with no separate spec. However, a call - -- to Deep_Initialize may result in a call to a user-defined Initialize - -- procedure, which imposes a body dependency. This happens only if the - -- type is controlled and the Initialize procedure is not inherited. + -- Locate the with clause for the unit. Note that there may not be a + -- clause if the unit is visible through a subunit-body, body-spec, or + -- spec-parent relationship. - if Body_Acts_As_Spec then - if Is_TSS (Ent, TSS_Deep_Initialize) then - declare - Typ : constant Entity_Id := Etype (First_Formal (Ent)); - Init : Entity_Id; + Clause := + Find_With_Clause + (Items => Items, + Withed_Id => Unit_Id); - begin - if not Is_Controlled (Typ) then - return; - else - Init := Find_Prim_Op (Typ, Name_Initialize); + -- Generate: + -- with Id; - if Comes_From_Source (Init) then - Ent := Init; - else - return; - end if; - end if; - end; + -- Note that adding implicit with clauses is safe because analysis, + -- resolution, and expansion have already taken place and it is not + -- possible to interfere with visibility. - else - return; - end if; + if No (Clause) then + Clause := + Make_With_Clause (Loc, + Name => New_Occurrence_Of (Unit_Id, Loc)); + + Set_Implicit_With (Clause); + Set_Library_Unit (Clause, Unit_Cunit); + + Append_To (Items, Clause); end if; - -- Check cases of internal units + -- Instantiations require an implicit Elaborate because Elaborate_All is + -- too conservative and may introduce non-existent elaboration cycles. - Callee_Unit_Internal := In_Internal_Unit (E_Scope); + if Is_Instantiation then + Set_Elaborate_Desirable (Clause); - -- Do not give a warning if the with'ed unit is internal and this is - -- the generic instantiation case (this saves a lot of hassle dealing - -- with the Text_IO special child units) + -- Otherwise generate an implicit Elaborate_All - if Callee_Unit_Internal and Inst_Case then - return; + else + Set_Elaborate_All_Desirable (Clause); end if; - if C_Scope = Standard_Standard then - Caller_Unit_Internal := False; - else - Caller_Unit_Internal := In_Internal_Unit (C_Scope); + -- The implicit Elaborate[_All] ensures the prior elaboration of the + -- unit. Include the unit in the elaboration context of the main unit. + + Elaboration_Context.Set (Unit_Id, + Elaboration_Attributes'(Source_Pragma => Empty, + With_Clause => Clause)); + + -- Output extra information on an implicit Elaborate[_All] pragma when + -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas is + -- in effect. + + if Elab_Info_Messages then + Info_Implicit_Pragma; end if; + end Ensure_Static_Prior_Elaboration; - -- Do not give a warning if the with'ed unit is internal and the caller - -- is not internal (since the binder always elaborates internal units - -- first). + ----------------------------- + -- Extract_Assignment_Name -- + ----------------------------- - if Callee_Unit_Internal and not Caller_Unit_Internal then - return; + function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id is + Nam : Node_Id; + + begin + Nam := Name (Asmt); + + -- When the name denotes an array or record component, find the whole + -- object. + + while Nkind_In (Nam, N_Explicit_Dereference, + N_Indexed_Component, + N_Selected_Component, + N_Slice) + loop + Nam := Prefix (Nam); + end loop; + + return Nam; + end Extract_Assignment_Name; + + ----------------------------- + -- Extract_Call_Attributes -- + ----------------------------- + + procedure Extract_Call_Attributes + (Call : Node_Id; + Target_Id : out Entity_Id; + Attrs : out Call_Attributes) + is + From_Source : Boolean; + In_Declarations : Boolean; + Is_Dispatching : Boolean; + + begin + -- Extraction for call markers + + if Nkind (Call) = N_Call_Marker then + Target_Id := Target (Call); + From_Source := Is_Source_Call (Call); + In_Declarations := Is_Declaration_Level_Node (Call); + Is_Dispatching := Is_Dispatching_Call (Call); + + -- Extraction for entry calls, requeue, and subprogram calls + + else + pragma Assert (Nkind_In (Call, N_Entry_Call_Statement, + N_Function_Call, + N_Procedure_Call_Statement, + N_Requeue_Statement)); + + Target_Id := Entity (Extract_Call_Name (Call)); + From_Source := Comes_From_Source (Call); + + -- Performance note: parent traversal + + In_Declarations := Find_Enclosing_Level (Call) = Declaration_Level; + Is_Dispatching := + Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement) + and then Present (Controlling_Argument (Call)); end if; - -- For now, if debug flag -gnatdE is not set, do no checking for one - -- internal unit withing another. This fixes the problem with the sgi - -- build and storage errors. To be resolved later ??? + -- Obtain the original entry or subprogram which the target may rename + -- except when the target is an instantiation. In this case the alias + -- is the internally generated subprogram which appears within the the + -- anonymous package created for the instantiation. Such an alias is not + -- a suitable target. - if (Callee_Unit_Internal and Caller_Unit_Internal) - and not Debug_Flag_EE + if not (Is_Subprogram (Target_Id) + and then Is_Generic_Instance (Target_Id)) then - return; + Target_Id := Get_Renamed_Entity (Target_Id); + end if; + + -- Set all attributes + + Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call); + Attrs.From_Source := From_Source; + Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Call); + Attrs.In_Declarations := In_Declarations; + Attrs.Is_Dispatching := Is_Dispatching; + Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Call); + end Extract_Call_Attributes; + + ----------------------- + -- Extract_Call_Name -- + ----------------------- + + function Extract_Call_Name (Call : Node_Id) return Node_Id is + Nam : Node_Id; + + begin + Nam := Name (Call); + + -- When the call invokes an entry family, the name appears as an indexed + -- component. + + if Nkind (Nam) = N_Indexed_Component then + Nam := Prefix (Nam); end if; - if Is_TSS (E, TSS_Deep_Initialize) then - Ent := E; + -- When the call employs the object.operation form, the name appears as + -- a selected component. + + if Nkind (Nam) = N_Selected_Component then + Nam := Selector_Name (Nam); end if; - -- If the call is in an instance, and the called entity is not - -- defined in the same instance, then the elaboration issue focuses - -- around the unit containing the template, it is this unit that - -- requires an Elaborate_All. + return Nam; + end Extract_Call_Name; + + --------------------------------- + -- Extract_Instance_Attributes -- + --------------------------------- + + procedure Extract_Instance_Attributes + (Exp_Inst : Node_Id; + Inst_Body : out Node_Id; + Inst_Decl : out Node_Id) + is + Body_Id : Entity_Id; - -- However, if we are doing dynamic elaboration, we need to chase the - -- call in the usual manner. + begin + -- Assume that the attributes are unavailable - -- We also need to chase the call in the usual manner if it is a call - -- to a generic formal parameter, since that case was not handled as - -- part of the processing of the template. + Inst_Body := Empty; + Inst_Decl := Empty; - Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N))); - Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent))); + -- Generic package or subprogram spec + + if Nkind_In (Exp_Inst, N_Package_Declaration, + N_Subprogram_Declaration) + then + Inst_Decl := Exp_Inst; + Body_Id := Corresponding_Body (Inst_Decl); + + if Present (Body_Id) then + Inst_Body := Unit_Declaration_Node (Body_Id); + end if; + + -- Generic package or subprogram body - if Inst_Caller = No_Location then - Unit_Caller := No_Unit; else - Unit_Caller := Get_Source_Unit (N); + pragma Assert + (Nkind_In (Exp_Inst, N_Package_Body, N_Subprogram_Body)); + + Inst_Body := Exp_Inst; + Inst_Decl := Unit_Declaration_Node (Corresponding_Spec (Inst_Body)); end if; + end Extract_Instance_Attributes; + + -------------------------------------- + -- Extract_Instantiation_Attributes -- + -------------------------------------- + + procedure Extract_Instantiation_Attributes + (Exp_Inst : Node_Id; + Inst : out Node_Id; + Inst_Id : out Entity_Id; + Gen_Id : out Entity_Id; + Attrs : out Instantiation_Attributes) + is + begin + Inst := Original_Node (Exp_Inst); + Inst_Id := Defining_Entity (Inst); + + -- Traverse a possible chain of renamings to obtain the original generic + -- being instantiatied. + + Gen_Id := Get_Renamed_Entity (Entity (Name (Inst))); + + -- Set all attributes + + Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst); + Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Inst); + Attrs.In_Declarations := Is_Declaration_Level_Node (Inst); + Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Inst); + end Extract_Instantiation_Attributes; + + ------------------------------- + -- Extract_Target_Attributes -- + ------------------------------- + + procedure Extract_Target_Attributes + (Target_Id : Entity_Id; + Attrs : out Target_Attributes) + is + procedure Extract_Package_Or_Subprogram_Attributes + (Spec_Id : out Entity_Id; + Body_Decl : out Node_Id); + -- Obtain the attributes associated with a package or a subprogram. + -- Spec_Id is the package or subprogram. Body_Decl is the declaration + -- of the corresponding package or subprogram body. + + procedure Extract_Protected_Entry_Attributes + (Spec_Id : out Entity_Id; + Body_Decl : out Node_Id; + Body_Barf : out Node_Id); + -- Obtain the attributes associated with a protected entry [family]. + -- Spec_Id is the entity of the protected body subprogram. Body_Decl + -- is the declaration of Spec_Id's corresponding body. Body_Barf is + -- the declaration of the barrier function body. + + procedure Extract_Protected_Subprogram_Attributes + (Spec_Id : out Entity_Id; + Body_Decl : out Node_Id); + -- Obtain the attributes associated with a protected subprogram. Formal + -- Spec_Id is the entity of the protected body subprogram. Body_Decl is + -- the declaration of Spec_Id's corresponding body. + + procedure Extract_Task_Entry_Attributes + (Spec_Id : out Entity_Id; + Body_Decl : out Node_Id); + -- Obtain the attributes associated with a task entry [family]. Formal + -- Spec_Id is the entity of the task body procedure. Body_Decl is the + -- declaration of Spec_Id's corresponding body. + + ---------------------------------------------- + -- Extract_Package_Or_Subprogram_Attributes -- + ---------------------------------------------- + + procedure Extract_Package_Or_Subprogram_Attributes + (Spec_Id : out Entity_Id; + Body_Decl : out Node_Id) + is + Body_Id : Entity_Id; + Init_Id : Entity_Id; + Spec_Decl : Node_Id; + + begin + -- Assume that the body is not available + + Body_Decl := Empty; + Spec_Id := Target_Id; + + -- For body retrieval purposes, the entity of the initial declaration + -- is that of the spec. + + Init_Id := Spec_Id; + + -- The only exception to the above is a function which returns a + -- constrained array type in a SPARK-to-C compilation. In this case + -- the function receives a corresponding procedure which has an out + -- parameter. The proper body for ABE checks and diagnostics is that + -- of the procedure. + + if Ekind (Init_Id) = E_Function + and then Rewritten_For_C (Init_Id) + then + Init_Id := Corresponding_Procedure (Init_Id); + end if; + + -- Extract the attributes of the body + + Spec_Decl := Unit_Declaration_Node (Init_Id); + + -- The initial declaration is a stand alone subprogram body + + if Nkind (Spec_Decl) = N_Subprogram_Body then + Body_Decl := Spec_Decl; + + -- Otherwise the package or subprogram has a spec and a completing + -- body. + + elsif Nkind_In (Spec_Decl, N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration, + N_Package_Declaration, + N_Subprogram_Body_Stub, + N_Subprogram_Declaration) + then + Body_Id := Corresponding_Body (Spec_Decl); + + if Present (Body_Id) then + Body_Decl := Unit_Declaration_Node (Body_Id); + end if; + end if; + end Extract_Package_Or_Subprogram_Attributes; + + ---------------------------------------- + -- Extract_Protected_Entry_Attributes -- + ---------------------------------------- + + procedure Extract_Protected_Entry_Attributes + (Spec_Id : out Entity_Id; + Body_Decl : out Node_Id; + Body_Barf : out Node_Id) + is + Barf_Id : Entity_Id; + Body_Id : Entity_Id; + + begin + -- Assume that the bodies are not available + + Body_Barf := Empty; + Body_Decl := Empty; + + -- When the entry [family] has already been expanded, it carries both + -- the procedure which emulates the behavior of the entry [family] as + -- well as the barrier function. + + if Present (Protected_Body_Subprogram (Target_Id)) then + Spec_Id := Protected_Body_Subprogram (Target_Id); + + -- Extract the attributes of the barrier function + + Barf_Id := + Corresponding_Body + (Unit_Declaration_Node (Barrier_Function (Target_Id))); + + if Present (Barf_Id) then + Body_Barf := Unit_Declaration_Node (Barf_Id); + end if; + + -- Otherwise no expansion took place + + else + Spec_Id := Target_Id; + end if; + + -- Extract the attributes of the entry body + + Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); + + if Present (Body_Id) then + Body_Decl := Unit_Declaration_Node (Body_Id); + end if; + end Extract_Protected_Entry_Attributes; + + --------------------------------------------- + -- Extract_Protected_Subprogram_Attributes -- + --------------------------------------------- + + procedure Extract_Protected_Subprogram_Attributes + (Spec_Id : out Entity_Id; + Body_Decl : out Node_Id) + is + Body_Id : Entity_Id; + + begin + -- Assume that the body is not available + + Body_Decl := Empty; + + -- When the protected subprogram has already been expanded, it + -- carries the subprogram which seizes the lock and invokes the + -- original statements. + + if Present (Protected_Subprogram (Target_Id)) then + Spec_Id := + Protected_Body_Subprogram (Protected_Subprogram (Target_Id)); + + -- Otherwise no expansion took place + + else + Spec_Id := Target_Id; + end if; + + -- Extract the attributes of the body + + Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); + + if Present (Body_Id) then + Body_Decl := Unit_Declaration_Node (Body_Id); + end if; + end Extract_Protected_Subprogram_Attributes; + + ----------------------------------- + -- Extract_Task_Entry_Attributes -- + ----------------------------------- + + procedure Extract_Task_Entry_Attributes + (Spec_Id : out Entity_Id; + Body_Decl : out Node_Id) + is + Task_Typ : constant Entity_Id := Non_Private_View (Scope (Target_Id)); + Body_Id : Entity_Id; + + begin + -- Assume that the body is not available + + Body_Decl := Empty; + + -- The the task type has already been expanded, it carries the + -- procedure which emulates the behavior of the task body. + + if Present (Task_Body_Procedure (Task_Typ)) then + Spec_Id := Task_Body_Procedure (Task_Typ); + + -- Otherwise no expansion took place + + else + Spec_Id := Task_Typ; + end if; + + -- Extract the attributes of the body + + Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); + + if Present (Body_Id) then + Body_Decl := Unit_Declaration_Node (Body_Id); + end if; + end Extract_Task_Entry_Attributes; + + -- Local variables + + Prag : constant Node_Id := SPARK_Pragma (Target_Id); + Body_Barf : Node_Id; + Body_Decl : Node_Id; + Spec_Id : Entity_Id; + + -- Start of processing for Extract_Target_Attributes + + begin + -- Assume that the body of the barrier function is not available + + Body_Barf := Empty; + + -- The target is a protected entry [family] + + if Is_Protected_Entry (Target_Id) then + Extract_Protected_Entry_Attributes + (Spec_Id => Spec_Id, + Body_Decl => Body_Decl, + Body_Barf => Body_Barf); + + -- The target is a protected subprogram + + elsif Is_Protected_Subp (Target_Id) + or else Is_Protected_Body_Subp (Target_Id) + then + Extract_Protected_Subprogram_Attributes + (Spec_Id => Spec_Id, + Body_Decl => Body_Decl); + + -- The target is a task entry [family] + + elsif Is_Task_Entry (Target_Id) then + Extract_Task_Entry_Attributes + (Spec_Id => Spec_Id, + Body_Decl => Body_Decl); + + -- Otherwise the target is a package or a subprogram - if Inst_Callee = No_Location then - Unit_Callee := No_Unit; else - Unit_Callee := Get_Source_Unit (Ent); + Extract_Package_Or_Subprogram_Attributes + (Spec_Id => Spec_Id, + Body_Decl => Body_Decl); end if; - if Unit_Caller /= No_Unit - and then Unit_Callee /= Unit_Caller - and then not Dynamic_Elaboration_Checks - and then not Is_Call_Of_Generic_Formal (N) - then - E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); + -- Set all attributes + + Attrs.Body_Barf := Body_Barf; + Attrs.Body_Decl := Body_Decl; + Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Target_Id); + Attrs.From_Source := Comes_From_Source (Target_Id); + Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Target_Id); + Attrs.SPARK_Mode_On := + Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On; + Attrs.Spec_Decl := Unit_Declaration_Node (Spec_Id); + Attrs.Spec_Id := Spec_Id; + Attrs.Unit_Id := Find_Top_Unit (Target_Id); - -- If we don't get a spec entity, just ignore call. Not quite - -- clear why this check is necessary. ??? + -- At this point certain attributes should always be available + + pragma Assert (Present (Attrs.Spec_Decl)); + pragma Assert (Present (Attrs.Spec_Id)); + pragma Assert (Present (Attrs.Unit_Id)); + end Extract_Target_Attributes; + + ----------------------------- + -- Extract_Task_Attributes -- + ----------------------------- - if No (E_Scope) then + procedure Extract_Task_Attributes + (Typ : Entity_Id; + Attrs : out Task_Attributes) + is + Task_Typ : constant Entity_Id := Non_Private_View (Typ); + + Body_Decl : Node_Id; + Body_Id : Entity_Id; + Prag : Node_Id; + Spec_Id : Entity_Id; + + begin + -- Assume that the body of the task procedure is not available + + Body_Decl := Empty; + + -- The initial declaration is that of the task body procedure + + Spec_Id := Get_Task_Body_Procedure (Task_Typ); + Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id)); + + if Present (Body_Id) then + Body_Decl := Unit_Declaration_Node (Body_Id); + end if; + + Prag := SPARK_Pragma (Task_Typ); + + -- Set all attributes + + Attrs.Body_Decl := Body_Decl; + Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Task_Typ); + Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Task_Typ); + Attrs.SPARK_Mode_On := + Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On; + Attrs.Spec_Id := Spec_Id; + Attrs.Task_Decl := Declaration_Node (Task_Typ); + Attrs.Unit_Id := Find_Top_Unit (Task_Typ); + + -- At this point certain attributes should always be available + + pragma Assert (Present (Attrs.Spec_Id)); + pragma Assert (Present (Attrs.Task_Decl)); + pragma Assert (Present (Attrs.Unit_Id)); + end Extract_Task_Attributes; + + ------------------------------------------- + -- Extract_Variable_Reference_Attributes -- + ------------------------------------------- + + procedure Extract_Variable_Reference_Attributes + (Ref : Node_Id; + Var_Id : out Entity_Id; + Attrs : out Variable_Attributes) + is + begin + -- Traverse a possible chain of renamings to obtain the original + -- variable being referenced. + + Var_Id := Get_Renamed_Entity (Entity (Ref)); + + Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Ref); + Attrs.Unit_Id := Find_Top_Unit (Var_Id); + + -- At this point certain attributes should always be available + + pragma Assert (Present (Attrs.Unit_Id)); + end Extract_Variable_Reference_Attributes; + + -------------------- + -- Find_Code_Unit -- + -------------------- + + function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id is + N_Unit : constant Node_Id := Unit (Cunit (Get_Code_Unit (N))); + + begin + return Defining_Entity (N_Unit, Concurrent_Subunit => True); + end Find_Code_Unit; + + --------------------------- + -- Find_Elaborated_Units -- + --------------------------- + + procedure Find_Elaborated_Units is + procedure Add_Pragma (Prag : Node_Id); + -- Determine whether pragma Prag denotes a legal Elaborate[_All] pragma. + -- If this is the case, add the related unit to the elaboration context. + -- For pragma Elaborate_All, include recursively all units withed by the + -- related unit. + + procedure Add_Unit + (Unit_Id : Entity_Id; + Prag : Node_Id; + Full_Context : Boolean); + -- Add unit Unit_Id to the elaboration context. Prag denotes the pragma + -- which prompted the inclusion of the unit to the elaboration context. + -- If flag Full_Context is set, examine the non-limited clauses of unit + -- Unit_Id and add each withed unit to the context. + + procedure Find_Elaboration_Context (Comp_Unit : Node_Id); + -- Examine the context items of compilation unit Comp_Unit for suitable + -- elaboration-related pragmas and add all related units to the context. + + ---------------- + -- Add_Pragma -- + ---------------- + + procedure Add_Pragma (Prag : Node_Id) is + Prag_Args : constant List_Id := Pragma_Argument_Associations (Prag); + Prag_Nam : constant Name_Id := Pragma_Name (Prag); + Unit_Arg : Node_Id; + + begin + -- Nothing to do if the pragma is not related to elaboration + + if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then + return; + + -- Nothing to do when the pragma is illegal + + elsif Error_Posted (Prag) then return; end if; - -- Otherwise step to enclosing compilation unit + Unit_Arg := Get_Pragma_Arg (First (Prag_Args)); - while not Is_Compilation_Unit (E_Scope) loop - E_Scope := Scope (E_Scope); - end loop; + -- The argument of the pragma may appear in package.package form - -- For the case where N is not an instance, and is not a call within - -- instance to other than a generic formal, we recompute E_Scope - -- for the error message, since we do NOT want to go to the unit - -- that has the ultimate declaration in the case of renaming and - -- derivation and we also want to go to the generic unit in the - -- case of an instance, and no further. + if Nkind (Unit_Arg) = N_Selected_Component then + Unit_Arg := Selector_Name (Unit_Arg); + end if; - else - -- Loop to carefully follow renamings and derivations one step - -- outside the current unit, but not further. + Add_Unit + (Unit_Id => Entity (Unit_Arg), + Prag => Prag, + Full_Context => Prag_Nam = Name_Elaborate_All); + end Add_Pragma; + + -------------- + -- Add_Unit -- + -------------- + + procedure Add_Unit + (Unit_Id : Entity_Id; + Prag : Node_Id; + Full_Context : Boolean) + is + Clause : Node_Id; + Elab_Attrs : Elaboration_Attributes; + + begin + -- Nothing to do when some previous error left a with clause or a + -- pragma in a bad state. + + if No (Unit_Id) then + return; + end if; + + Elab_Attrs := Elaboration_Context.Get (Unit_Id); + + -- The current unit is not part of the context. Prepare a new set of + -- attributes. + + if Elab_Attrs = No_Elaboration_Attributes then + Elab_Attrs := + Elaboration_Attributes'(Source_Pragma => Prag, + With_Clause => Empty); - if not (Inst_Case or Variable_Case) - and then Present (Alias (Ent)) + -- The unit is already included in the context by means of pragma + -- Elaborate. "Upgrage" the existing attributes when the unit is + -- subject to Elaborate_All because the new pragma covers a larger + -- set of units. All other properties remain the same. + + elsif Pragma_Name (Elab_Attrs.Source_Pragma) = Name_Elaborate + and then Pragma_Name (Prag) = Name_Elaborate_All then - E_Scope := Alias (Ent); + Elab_Attrs.Source_Pragma := Prag; + + -- Otherwise the unit is already included in the context + else - E_Scope := Ent; + return; end if; - loop - while not Is_Compilation_Unit (E_Scope) loop - E_Scope := Scope (E_Scope); + -- Add or update the attributes of the unit + + Elaboration_Context.Set (Unit_Id, Elab_Attrs); + + -- Includes all units withed by the current one when computing the + -- full context. + + if Full_Context then + + -- Process all non-limited with clauses found in the context of + -- the current unit. Note that limited clauses do not impose an + -- elaboration order. + + Clause := First (Context_Items (Compilation_Unit (Unit_Id))); + while Present (Clause) loop + if Nkind (Clause) = N_With_Clause + and then not Error_Posted (Clause) + and then not Limited_Present (Clause) + then + Add_Unit + (Unit_Id => Entity (Name (Clause)), + Prag => Prag, + Full_Context => Full_Context); + end if; + + Next (Clause); end loop; + end if; + end Add_Unit; - -- If E_Scope is the same as C_Scope, it means that there - -- definitely was a local renaming or derivation, and we - -- are not yet out of the current unit. + ------------------------------ + -- Find_Elaboration_Context -- + ------------------------------ - exit when E_Scope /= C_Scope; - Ent := Alias (Ent); - E_Scope := Ent; + procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is + Prag : Node_Id; - -- If no alias, there could be a previous error, but not if we've - -- already reached the outermost level (Standard). + begin + pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); - if No (Ent) then - return; + -- Process all elaboration-related pragmas found in the context of + -- the compilation unit. + + Prag := First (Context_Items (Comp_Unit)); + while Present (Prag) loop + if Nkind (Prag) = N_Pragma then + Add_Pragma (Prag); end if; + + Next (Prag); end loop; + end Find_Elaboration_Context; + + -- Local variables + + Par_Id : Entity_Id; + Unt : Node_Id; + + -- Start of processing for Find_Elaborated_Units + + begin + -- Perform a traversal which examines the context of the main unit and + -- populates the Elaboration_Context table with all units elaborated + -- prior to the main unit. The traversal performs the following jumps: + + -- subunit -> parent subunit + -- parent subunit -> body + -- body -> spec + -- spec -> parent spec + -- parent spec -> grandparent spec and so on + + -- The traversal relies on units rather than scopes because the scope of + -- a subunit is some spec, while this traversal must process the body as + -- well. Given that protected and task bodies can also be subunits, this + -- complicates the scope approach even further. + + Unt := Unit (Cunit (Main_Unit)); + + -- Perform the following traversals when the main unit is a subunit + + -- subunit -> parent subunit + -- parent subunit -> body + + while Present (Unt) and then Nkind (Unt) = N_Subunit loop + Find_Elaboration_Context (Parent (Unt)); + + -- Continue the traversal by going to the unit which contains the + -- corresponding stub. + + if Present (Corresponding_Stub (Unt)) then + Unt := Unit (Cunit (Get_Source_Unit (Corresponding_Stub (Unt)))); + + -- Otherwise the subunit may be erroneous or left in a bad state + + else + exit; + end if; + end loop; + + -- Perform the following traversal now that subunits have been taken + -- care of, or the main unit is a body. + + -- body -> spec + + if Present (Unt) + and then Nkind_In (Unt, N_Package_Body, N_Subprogram_Body) + then + Find_Elaboration_Context (Parent (Unt)); + + -- Continue the traversal by going to the unit which contains the + -- corresponding spec. + + if Present (Corresponding_Spec (Unt)) then + Unt := Unit (Cunit (Get_Source_Unit (Corresponding_Spec (Unt)))); + end if; end if; - if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then - return; + -- Perform the following traversals now that the body has been taken + -- care of, or the main unit is a spec. + + -- spec -> parent spec + -- parent spec -> grandparent spec and so on + + if Present (Unt) + and then Nkind_In (Unt, N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration, + N_Package_Declaration, + N_Subprogram_Declaration) + then + Find_Elaboration_Context (Parent (Unt)); + + -- Process a potential chain of parent units which ends with the + -- main unit spec. The traversal can now safely rely on the scope + -- chain. + + Par_Id := Scope (Defining_Entity (Unt)); + while Present (Par_Id) and then Par_Id /= Standard_Standard loop + Find_Elaboration_Context (Compilation_Unit (Par_Id)); + + Par_Id := Scope (Par_Id); + end loop; end if; + end Find_Elaborated_Units; - -- Determine whether the Default_Initial_Condition procedure of some - -- type is being invoked. + ----------------------------- + -- Find_Enclosing_Instance -- + ----------------------------- + + function Find_Enclosing_Instance (N : Node_Id) return Node_Id is + Par : Node_Id; + Spec_Id : Entity_Id; + + begin + -- Climb the parent chain looking for an enclosing instance spec or body + + Par := N; + while Present (Par) loop + + -- Generic package or subprogram spec + + if Nkind_In (Par, N_Package_Declaration, + N_Subprogram_Declaration) + and then Is_Generic_Instance (Defining_Entity (Par)) + then + return Par; + + -- Generic package or subprogram body + + elsif Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then + Spec_Id := Corresponding_Spec (Par); + + if Present (Spec_Id) and then Is_Generic_Instance (Spec_Id) then + return Par; + end if; + end if; + + Par := Parent (Par); + end loop; + + return Empty; + end Find_Enclosing_Instance; + + -------------------------- + -- Find_Enclosing_Level -- + -------------------------- + + function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind is + function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind; + -- Obtain the corresponding level of unit Unit + + -------------- + -- Level_Of -- + -------------- + + function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind is + Spec_Id : Entity_Id; + + begin + if Nkind (Unit) in N_Generic_Instantiation then + return Instantiation; + + elsif Nkind (Unit) = N_Generic_Package_Declaration then + return Generic_Package_Spec; + + elsif Nkind (Unit) = N_Package_Declaration then + return Package_Spec; - Is_DIC := Ekind (Ent) = E_Procedure and then Is_DIC_Procedure (Ent); + elsif Nkind (Unit) = N_Package_Body then + Spec_Id := Corresponding_Spec (Unit); - -- Checks related to Default_Initial_Condition fall under the SPARK - -- umbrella because this is a SPARK-specific annotation. + -- The body belongs to a generic package - SPARK_Elab_Errors := - SPARK_Mode = On and (Is_DIC or Dynamic_Elaboration_Checks); + if Present (Spec_Id) + and then Ekind (Spec_Id) = E_Generic_Package + then + return Generic_Package_Body; + + -- Otherwise the body belongs to a non-generic package. This also + -- treats an illegal package body without a corresponding spec as + -- a non-generic package body. - -- Now check if an Elaborate_All (or dynamic check) is needed + else + return Package_Body; + end if; + end if; - if (Elab_Info_Messages or Elab_Warnings or SPARK_Elab_Errors) - and then Generate_Warnings - and then not Suppress_Elaboration_Warnings (Ent) - and then not Elaboration_Checks_Suppressed (Ent) - and then not Suppress_Elaboration_Warnings (E_Scope) - and then not Elaboration_Checks_Suppressed (E_Scope) + return No_Level; + end Level_Of; + + -- Local variables + + Context : Node_Id; + Curr : Node_Id; + Prev : Node_Id; + + -- Start of processing for Find_Enclosing_Level + + begin + -- Call markers and instantiations which appear at the declaration level + -- but are later relocated in a different context retain their original + -- declaration level. + + if Nkind_In (N, N_Call_Marker, + N_Function_Instantiation, + N_Package_Instantiation, + N_Procedure_Instantiation) + and then Is_Declaration_Level_Node (N) then - -- Instantiation case + return Declaration_Level; + end if; + + -- Climb the parent chain looking at the enclosing levels + + Prev := N; + Curr := Parent (Prev); + while Present (Curr) loop + + -- A traversal from a subunit continues via the corresponding stub + + if Nkind (Curr) = N_Subunit then + Curr := Corresponding_Stub (Curr); + + -- The current construct is a package. Packages are ignored because + -- they are always elaborated when the enclosing context is invoked + -- or elaborated. + + elsif Nkind_In (Curr, N_Package_Body, N_Package_Declaration) then + null; + + -- The current construct is a block statement + + elsif Nkind (Curr) = N_Block_Statement then + + -- Ignore internally generated blocks created by the expander for + -- various purposes such as abort defer/undefer. + + if not Comes_From_Source (Curr) then + null; + + -- If the traversal came from the handled sequence of statments, + -- then the node appears at the level of the enclosing construct. + -- This is a more reliable test because transients scopes within + -- the declarative region of the encapsulator are hard to detect. + + elsif Nkind (Prev) = N_Handled_Sequence_Of_Statements + and then Handled_Statement_Sequence (Curr) = Prev + then + return Find_Enclosing_Level (Parent (Curr)); + + -- Otherwise the traversal came from the declarations, the node is + -- at the declaration level. - if Inst_Case then - if Comes_From_Source (Ent) and then SPARK_Elab_Errors then - Error_Msg_NE - ("instantiation of & during elaboration in SPARK", N, Ent); else - Elab_Warning - ("instantiation of & may raise Program_Error?l?", - "info: instantiation of & during elaboration?$?", Ent); + return Declaration_Level; end if; - -- Indirect call case, info message only in static elaboration - -- case, because the attribute reference itself cannot raise an - -- exception. Note that SPARK does not permit indirect calls. + -- The current construct is a declaration level encapsulator - elsif Access_Case then - Elab_Warning ("", "info: access to & during elaboration?$?", Ent); + elsif Nkind_In (Curr, N_Entry_Body, + N_Subprogram_Body, + N_Task_Body) + then + -- If the traversal came from the handled sequence of statments, + -- then the node cannot possibly appear at any level. This is + -- a more reliable test because transients scopes within the + -- declarative region of the encapsulator are hard to detect. - -- Variable reference in SPARK mode + if Nkind (Prev) = N_Handled_Sequence_Of_Statements + and then Handled_Statement_Sequence (Curr) = Prev + then + return No_Level; - elsif Variable_Case then - if Comes_From_Source (Ent) and then SPARK_Elab_Errors then - Error_Msg_NE - ("reference to & during elaboration in SPARK", N, Ent); + -- Otherwise the traversal came from the declarations, the node is + -- at the declaration level. + + else + return Declaration_Level; end if; - -- Subprogram call case + -- The current construct is a non-library level encapsulator which + -- indicates that the node cannot possibly appear at any level. + -- Note that this check must come after the declaration level check + -- because both predicates share certain nodes. - else - if Nkind (Name (N)) in N_Has_Entity - and then Is_Init_Proc (Entity (Name (N))) - and then Comes_From_Source (Ent) + elsif Is_Non_Library_Level_Encapsulator (Curr) then + Context := Parent (Curr); + + -- The sole exception is when the encapsulator is the compilation + -- utit itself because the compilation unit node requires special + -- processing (see below). + + if Present (Context) + and then Nkind (Context) = N_Compilation_Unit then - Elab_Warning - ("implicit call to & may raise Program_Error?l?", - "info: implicit call to & during elaboration?$?", - Ent); - - elsif SPARK_Elab_Errors then - - -- Emit a specialized error message when the elaboration of an - -- object of a private type evaluates the expression of pragma - -- Default_Initial_Condition. This prevents the internal name - -- of the procedure from appearing in the error message. - - if Is_DIC then - Error_Msg_N - ("call to Default_Initial_Condition during elaboration in " - & "SPARK", N); - else - Error_Msg_NE - ("call to & during elaboration in SPARK", N, Ent); - end if; + null; + + -- Otherwise the node is not at any level else - Elab_Warning - ("call to & may raise Program_Error?l?", - "info: call to & during elaboration?$?", - Ent); + return No_Level; end if; + + -- The current construct is a compilation unit. The node appears at + -- the [generic] library level when the unit is a [generic] package. + + elsif Nkind (Curr) = N_Compilation_Unit then + return Level_Of (Unit (Curr)); end if; - Error_Msg_Qual_Level := Nat'Last; + Prev := Curr; + Curr := Parent (Prev); + end loop; + + return No_Level; + end Find_Enclosing_Level; + + ------------------- + -- Find_Top_Unit -- + ------------------- - -- Case of Elaborate_All not present and required, for SPARK this - -- is an error, so give an error message. + function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id is + N_Unit : constant Node_Id := Unit (Cunit (Get_Top_Level_Code_Unit (N))); - if SPARK_Elab_Errors then - Error_Msg_NE -- CODEFIX - ("\Elaborate_All pragma required for&", N, W_Scope); + begin + return Defining_Entity (N_Unit, Concurrent_Subunit => True); + end Find_Top_Unit; - -- Otherwise we generate an implicit pragma. For a subprogram - -- instantiation, Elaborate is good enough, since no transitive - -- call is possible at elaboration time in this case. + ----------------------- + -- First_Formal_Type -- + ----------------------- - elsif Nkind (N) in N_Subprogram_Instantiation then - Elab_Warning - ("\missing pragma Elaborate for&?l?", - "\implicit pragma Elaborate for& generated?$?", - W_Scope); + function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id is + Formal_Id : constant Entity_Id := First_Formal (Subp_Id); + Typ : Entity_Id; - -- For all other cases, we need an implicit Elaborate_All + begin + if Present (Formal_Id) then + Typ := Etype (Formal_Id); - else - Elab_Warning - ("\missing pragma Elaborate_All for&?l?", - "\implicit pragma Elaborate_All for & generated?$?", - W_Scope); - end if; + -- Handle various combinations of concurrent and private types - Error_Msg_Qual_Level := 0; + loop + if Ekind_In (Typ, E_Protected_Type, E_Task_Type) + and then Present (Anonymous_Object (Typ)) + then + Typ := Anonymous_Object (Typ); - -- Take into account the flags related to elaboration warning - -- messages when enumerating the various calls involved. This - -- ensures the proper pairing of the main warning and the - -- clarification messages generated by Output_Calls. + elsif Is_Concurrent_Record_Type (Typ) then + Typ := Corresponding_Concurrent_Type (Typ); - Output_Calls (N, Check_Elab_Flag => True); + elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + Typ := Full_View (Typ); - -- Set flag to prevent further warnings for same unit unless in - -- All_Errors_Mode. + else + exit; + end if; + end loop; - if not All_Errors_Mode and not Dynamic_Elaboration_Checks then - Set_Suppress_Elaboration_Warnings (W_Scope); - end if; + return Typ; end if; - -- Check for runtime elaboration check required + return Empty; + end First_Formal_Type; - if Dynamic_Elaboration_Checks then - if not Elaboration_Checks_Suppressed (Ent) - and then not Elaboration_Checks_Suppressed (W_Scope) - and then not Elaboration_Checks_Suppressed (E_Scope) - and then not Cunit_SC - then - -- Runtime elaboration check required. Generate check of the - -- elaboration Boolean for the unit containing the entity. + -------------- + -- Has_Body -- + -------------- + + function Has_Body (Pack_Decl : Node_Id) return Boolean is + function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id; + -- Try to locate the corresponding body of spec Spec_Id. If no body is + -- found, return Empty. + + function Find_Body + (Spec_Id : Entity_Id; + From : Node_Id) return Node_Id; + -- Try to locate the corresponding body of spec Spec_Id in the node list + -- which follows arbitrary node From. If no body is found, return Empty. + + function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id; + -- Attempt to load the body of unit Unit_Nam. If the load failed, return + -- Empty. If the compilation will not generate code, return Empty. + + ----------------------------- + -- Find_Corresponding_Body -- + ----------------------------- - -- Note that for this case, we do check the real unit (the one - -- from following renamings, since that is the issue). + function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id is + Context : constant Entity_Id := Scope (Spec_Id); + Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); + Body_Decl : Node_Id; + Body_Id : Entity_Id; - -- Could this possibly miss a useless but required PE??? + begin + if Is_Compilation_Unit (Spec_Id) then + Body_Id := Corresponding_Body (Spec_Decl); - Insert_Elab_Check (N, - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Elaborated, - Prefix => - New_Occurrence_Of (Spec_Entity (E_Scope), Loc))); + if Present (Body_Id) then + return Unit_Declaration_Node (Body_Id); - -- Prevent duplicate elaboration checks on the same call, - -- which can happen if the body enclosing the call appears - -- itself in a call whose elaboration check is delayed. + -- The package is at the library and requires a body. Load the + -- corresponding body because the optional body may be declared + -- there. - if Nkind (N) in N_Subprogram_Call then - Set_No_Elaboration_Check (N); + elsif Unit_Requires_Body (Spec_Id) then + return + Load_Package_Body + (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec_Decl)))); + + -- Otherwise there is no optional body + + else + return Empty; end if; - end if; - -- Case of static elaboration model + -- The immediate context is a package. The optional body may be + -- within the body of that package. - else - -- Do not do anything if elaboration checks suppressed. Note that - -- we check Ent here, not E, since we want the real entity for the - -- body to see if checks are suppressed for it, not the dummy - -- entry for renamings or derivations. - - if Elaboration_Checks_Suppressed (Ent) - or else Elaboration_Checks_Suppressed (E_Scope) - or else Elaboration_Checks_Suppressed (W_Scope) - then - null; + -- procedure Proc is + -- package Nested_1 is + -- package Nested_2 is + -- generic + -- package Pack is + -- end Pack; + -- end Nested_2; + -- end Nested_1; - -- Do not generate an Elaborate_All for finalization routines - -- that perform partial clean up as part of initialization. + -- package body Nested_1 is + -- package body Nested_2 is separate; + -- end Nested_1; - elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then - null; + -- separate (Proc.Nested_1.Nested_2) + -- package body Nested_2 is + -- package body Pack is -- optional body + -- ... + -- end Pack; + -- end Nested_2; + + elsif Is_Package_Or_Generic_Package (Context) then + Body_Decl := Find_Corresponding_Body (Context); + + -- The optional body is within the body of the enclosing package + + if Present (Body_Decl) then + return + Find_Body + (Spec_Id => Spec_Id, + From => First (Declarations (Body_Decl))); - -- Here we need to generate an implicit elaborate all + -- Otherwise the enclosing package does not have a body. This may + -- be the result of an error or a genuine lack of a body. + + else + return Empty; + end if; + + -- Otherwise the immediate context is a body. The optional body may + -- be within the same list as the spec. + + -- procedure Proc is + -- generic + -- package Pack is + -- end Pack; + + -- package body Pack is -- optional body + -- ... + -- end Pack; else - -- Generate Elaborate_All warning unless suppressed + return + Find_Body + (Spec_Id => Spec_Id, + From => Next (Spec_Decl)); + end if; + end Find_Corresponding_Body; - if (Elab_Info_Messages and Generate_Warnings and not Inst_Case) - and then not Suppress_Elaboration_Warnings (Ent) - and then not Suppress_Elaboration_Warnings (E_Scope) - and then not Suppress_Elaboration_Warnings (W_Scope) + --------------- + -- Find_Body -- + --------------- + + function Find_Body + (Spec_Id : Entity_Id; + From : Node_Id) return Node_Id + is + Spec_Nam : constant Name_Id := Chars (Spec_Id); + Item : Node_Id; + Lib_Unit : Node_Id; + + begin + Item := From; + while Present (Item) loop + + -- The current item denotes the optional body + + if Nkind (Item) = N_Package_Body + and then Chars (Defining_Entity (Item)) = Spec_Nam then - Error_Msg_Node_2 := W_Scope; - Error_Msg_NE - ("info: call to& in elaboration code requires pragma " - & "Elaborate_All on&?$?", N, E); + return Item; + + -- The current item denotes a stub, the optional body may be in + -- the subunit. + + elsif Nkind (Item) = N_Package_Body_Stub + and then Chars (Defining_Entity (Item)) = Spec_Nam + then + Lib_Unit := Library_Unit (Item); + + -- The corresponding subunit was previously loaded + + if Present (Lib_Unit) then + return Lib_Unit; + + -- Otherwise attempt to load the corresponding subunit + + else + return Load_Package_Body (Get_Unit_Name (Item)); + end if; end if; - -- Set indication for binder to generate Elaborate_All + Next (Item); + end loop; + + return Empty; + end Find_Body; + + ----------------------- + -- Load_Package_Body -- + ----------------------- + + function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id is + Body_Decl : Node_Id; + Unit_Num : Unit_Number_Type; - Set_Elaboration_Constraint (N, E, W_Scope); + begin + -- The load is performed only when the compilation will generate code + + if Operating_Mode = Generate_Code then + Unit_Num := + Load_Unit + (Load_Name => Unit_Nam, + Required => False, + Subunit => False, + Error_Node => Pack_Decl); + + -- The load failed most likely because the physical file is + -- missing. + + if Unit_Num = No_Unit then + return Empty; + + -- Otherwise the load was successful, return the body of the unit + + else + Body_Decl := Unit (Cunit (Unit_Num)); + + -- If the unit is a subunit with an available proper body, + -- return the proper body. + + if Nkind (Body_Decl) = N_Subunit + and then Present (Proper_Body (Body_Decl)) + then + Body_Decl := Proper_Body (Body_Decl); + end if; + + return Body_Decl; + end if; end if; - end if; - end Check_A_Call; - ----------------------------- - -- Check_Bad_Instantiation -- - ----------------------------- + return Empty; + end Load_Package_Body; - procedure Check_Bad_Instantiation (N : Node_Id) is - Ent : Entity_Id; + -- Local variables + + Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl); + + -- Start of processing for Has_Body begin - -- Nothing to do if we do not have an instantiation (happens in some - -- error cases, and also in the formal package declaration case) + -- The body is available - if Nkind (N) not in N_Generic_Instantiation then - return; + if Present (Corresponding_Body (Pack_Decl)) then + return True; - -- Nothing to do if serious errors detected (avoid cascaded errors) + -- The body is required if the package spec contains a construct which + -- requires a completion in a body. - elsif Serious_Errors_Detected /= 0 then - return; + elsif Unit_Requires_Body (Pack_Id) then + return True; - -- Nothing to do if not in full analysis mode + -- The body may be optional - elsif not Full_Analysis then - return; + else + return Present (Find_Corresponding_Body (Pack_Id)); + end if; + end Has_Body; - -- Nothing to do if inside a generic template + --------------------------- + -- Has_Prior_Elaboration -- + --------------------------- - elsif Inside_A_Generic then - return; + function Has_Prior_Elaboration + (Unit_Id : Entity_Id; + Context_OK : Boolean := False; + Elab_Body_OK : Boolean := False; + Same_Unit_OK : Boolean := False) return Boolean + is + Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); - -- Nothing to do if a library level instantiation + begin + -- A preelaborated unit is always elaborated prior to the main unit - elsif Nkind (Parent (N)) = N_Compilation_Unit then - return; + if Is_Preelaborated_Unit (Unit_Id) then + return True; - -- Nothing to do if we are compiling a proper body for semantic - -- purposes only. The generic body may be in another proper body. + -- An internal unit is always elaborated prior to a non-internal main + -- unit. - elsif - Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit + elsif In_Internal_Unit (Unit_Id) + and then not In_Internal_Unit (Main_Id) then - return; - end if; + return True; - Ent := Get_Generic_Entity (N); + -- A unit has prior elaboration if it appears within the context of the + -- main unit. Consider this case only when requested by the caller. - -- The case we are interested in is when the generic spec is in the - -- current declarative part + elsif Context_OK + and then Elaboration_Context.Get (Unit_Id) /= No_Elaboration_Attributes + then + return True; - if not Same_Elaboration_Scope (Current_Scope, Scope (Ent)) - or else not In_Same_Extended_Unit (N, Ent) + -- A unit whose body is elaborated together with its spec has prior + -- elaboration except with respect to itself. Consider this case only + -- when requested by the caller. + + elsif Elab_Body_OK + and then Has_Pragma_Elaborate_Body (Unit_Id) + and then not Is_Same_Unit (Unit_Id, Main_Id) then - return; + return True; + + -- A unit has no prior elaboration with respect to itself, but does not + -- require any means of ensuring its own elaboration either. Treat this + -- case as valid prior elaboration only when requested by the caller. + + elsif Same_Unit_OK and then Is_Same_Unit (Unit_Id, Main_Id) then + return True; end if; - -- If the generic entity is within a deeper instance than we are, then - -- either the instantiation to which we refer itself caused an ABE, in - -- which case that will be handled separately. Otherwise, we know that - -- the body we need appears as needed at the point of the instantiation. - -- If they are both at the same level but not within the same instance - -- then the body of the generic will be in the earlier instance. + return False; + end Has_Prior_Elaboration; - declare - D1 : constant Nat := Instantiation_Depth (Sloc (Ent)); - D2 : constant Nat := Instantiation_Depth (Sloc (N)); + -------------------------- + -- In_External_Instance -- + -------------------------- - begin - if D1 > D2 then - return; + function In_External_Instance + (N : Node_Id; + Target_Decl : Node_Id) return Boolean + is + Dummy : Node_Id; + Inst_Body : Node_Id; + Inst_Decl : Node_Id; - elsif D1 = D2 - and then Is_Generic_Instance (Scope (Ent)) - and then not In_Open_Scopes (Scope (Ent)) + begin + -- Performance note: parent traversal + + Inst_Decl := Find_Enclosing_Instance (Target_Decl); + + -- The target declaration appears within an instance spec. Visibility is + -- ignored because internally generated primitives for private types may + -- reside in the private declarations and still be invoked from outside. + + if Present (Inst_Decl) + and then Nkind (Inst_Decl) = N_Package_Declaration + then + -- The scenario comes from the main unit and the instance does not + + if In_Extended_Main_Code_Unit (N) + and then not In_Extended_Main_Code_Unit (Inst_Decl) then - return; - end if; - end; + return True; - -- Now we can proceed, if the entity being called has a completion, - -- then we are definitely OK, since we have already seen the body. + -- Otherwise the scenario must not appear within the instance spec or + -- body. - if Has_Completion (Ent) then - return; - end if; + else + Extract_Instance_Attributes + (Exp_Inst => Inst_Decl, + Inst_Body => Inst_Body, + Inst_Decl => Dummy); - -- If there is no body, then nothing to do + -- Performance note: parent traversal - if not Has_Generic_Body (N) then - return; + return not In_Subtree + (N => N, + Root1 => Inst_Decl, + Root2 => Inst_Body); + end if; end if; - -- Here we definitely have a bad instantiation + return False; + end In_External_Instance; + + --------------------- + -- In_Main_Context -- + --------------------- + + function In_Main_Context (N : Node_Id) return Boolean is + begin + -- Scenarios outside the main unit are not considered because the ALI + -- information supplied to binde is for the main unit only. + + if not In_Extended_Main_Code_Unit (N) then + return False; - Error_Msg_Warn := SPARK_Mode /= On; - Error_Msg_NE ("cannot instantiate& before body seen<<", N, Ent); + -- Scenarios within internal units are not considered unless switch + -- -gnatdE (elaboration checks on predefined units) is in effect. - if Present (Instance_Spec (N)) then - Supply_Bodies (Instance_Spec (N)); + elsif not Debug_Flag_EE and then In_Internal_Unit (N) then + return False; end if; - Error_Msg_N ("\Program_Error [<<", N); - Insert_Elab_Check (N); - Set_ABE_Is_Certain (N); - end Check_Bad_Instantiation; + return True; + end In_Main_Context; --------------------- - -- Check_Elab_Call -- + -- In_Same_Context -- --------------------- - procedure Check_Elab_Call - (N : Node_Id; - Outer_Scope : Entity_Id := Empty; - In_Init_Proc : Boolean := False) + function In_Same_Context + (N1 : Node_Id; + N2 : Node_Id; + Nested_OK : Boolean := False) return Boolean is - Ent : Entity_Id; - P : Node_Id; + function Find_Enclosing_Context (N : Node_Id) return Node_Id; + -- Return the nearest enclosing non-library level or compilation unit + -- node which which encapsulates arbitrary node N. Return Empty is no + -- such context is available. + + function In_Nested_Context + (Outer : Node_Id; + Inner : Node_Id) return Boolean; + -- Determine whether arbitrary node Outer encapsulates arbitrary node + -- Inner. + + ---------------------------- + -- Find_Enclosing_Context -- + ---------------------------- + + function Find_Enclosing_Context (N : Node_Id) return Node_Id is + Context : Node_Id; + Par : Node_Id; - begin - -- If the reference is not in the main unit, there is nothing to check. - -- Elaboration call from units in the context of the main unit will lead - -- to semantic dependencies when those units are compiled. + begin + Par := Parent (N); + while Present (Par) loop - if not In_Extended_Main_Code_Unit (N) then - return; - end if; + -- A traversal from a subunit continues via the corresponding stub - -- For an entry call, check relevant restriction + if Nkind (Par) = N_Subunit then + Par := Corresponding_Stub (Par); - if Nkind (N) = N_Entry_Call_Statement - and then not In_Subprogram_Or_Concurrent_Unit - then - Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N); + -- Stop the traversal when the nearest enclosing non-library level + -- encapsulator has been reached. - -- Nothing to do if this is not an expected type of reference (happens - -- in some error conditions, and in some cases where rewriting occurs). + elsif Is_Non_Library_Level_Encapsulator (Par) then + Context := Parent (Par); - elsif Nkind (N) not in N_Subprogram_Call - and then Nkind (N) /= N_Attribute_Reference - and then (SPARK_Mode /= On - or else Nkind (N) not in N_Has_Entity - or else No (Entity (N)) - or else Ekind (Entity (N)) /= E_Variable) - then - return; + -- The sole exception is when the encapsulator is the unit of + -- compilation because this case requires special processing + -- (see below). - -- Nothing to do if this is a call already rewritten for elab checking. - -- Such calls appear as the targets of If_Expressions. + if Present (Context) + and then Nkind (Context) = N_Compilation_Unit + then + null; - -- This check MUST be wrong, it catches far too much + else + return Par; + end if; - elsif Nkind (Parent (N)) = N_If_Expression then - return; + -- Reaching a compilation unit node without hitting a non-library + -- level encapsulator indicates that N is at the library level in + -- which case the compilation unit is the context. - -- Nothing to do if inside a generic template + elsif Nkind (Par) = N_Compilation_Unit then + return Par; + end if; - elsif Inside_A_Generic - and then No (Enclosing_Generic_Body (N)) - then - return; + Par := Parent (Par); + end loop; - -- Nothing to do if call is being pre-analyzed, as when within a - -- pre/postcondition, a predicate, or an invariant. + return Empty; + end Find_Enclosing_Context; - elsif In_Spec_Expression then - return; - end if; + ----------------------- + -- In_Nested_Context -- + ----------------------- - -- Nothing to do if this is a call to a postcondition, which is always - -- within a subprogram body, even though the current scope may be the - -- enclosing scope of the subprogram. + function In_Nested_Context + (Outer : Node_Id; + Inner : Node_Id) return Boolean + is + Par : Node_Id; - if Nkind (N) = N_Procedure_Call_Statement - and then Is_Entity_Name (Name (N)) - and then Chars (Entity (Name (N))) = Name_uPostconditions - then - return; - end if; + begin + Par := Inner; + while Present (Par) loop - -- Here we have a reference at elaboration time that must be checked + -- A traversal from a subunit continues via the corresponding stub - if Debug_Flag_LL then - Write_Str (" Check_Elab_Ref: "); + if Nkind (Par) = N_Subunit then + Par := Corresponding_Stub (Par); - if Nkind (N) = N_Attribute_Reference then - if not Is_Entity_Name (Prefix (N)) then - Write_Str ("<<not entity name>>"); - else - Write_Name (Chars (Entity (Prefix (N)))); + elsif Par = Outer then + return True; end if; - Write_Str ("'Access"); + Par := Parent (Par); + end loop; + + return False; + end In_Nested_Context; - elsif No (Name (N)) or else not Is_Entity_Name (Name (N)) then - Write_Str ("<<not entity name>> "); + -- Local variables - else - Write_Name (Chars (Entity (Name (N)))); - end if; + Context_1 : constant Node_Id := Find_Enclosing_Context (N1); + Context_2 : constant Node_Id := Find_Enclosing_Context (N2); + + -- Start of processing for In_Same_Context + + begin + -- Both nodes appear within the same context + + if Context_1 = Context_2 then + return True; + + -- Both nodes appear in compilation units. Determine whether one unit + -- is the body of the other. + + elsif Nkind (Context_1) = N_Compilation_Unit + and then Nkind (Context_2) = N_Compilation_Unit + then + return + Is_Same_Unit + (Unit_1 => Defining_Entity (Unit (Context_1)), + Unit_2 => Defining_Entity (Unit (Context_2))); + + -- The context of N1 encloses the context of N2 - Write_Str (" reference at "); - Write_Location (Sloc (N)); - Write_Eol; + elsif Nested_OK and then In_Nested_Context (Context_1, Context_2) then + return True; end if; - -- Climb up the tree to make sure we are not inside default expression - -- of a parameter specification or a record component, since in both - -- these cases, we will be doing the actual reference later, not now, - -- and it is at the time of the actual reference (statically speaking) - -- that we must do our static check, not at the time of its initial - -- analysis). + return False; + end In_Same_Context; - -- However, we have to check references within component definitions - -- (e.g. a function call that determines an array component bound), - -- so we terminate the loop in that case. + ---------------- + -- Initialize -- + ---------------- - P := Parent (N); - while Present (P) loop - if Nkind_In (P, N_Parameter_Specification, - N_Component_Declaration) - then - return; + procedure Initialize is + begin + -- Set the soft link which enables Atree.Rewrite to update a top level + -- scenario each time it is transformed into another node. - -- The reference occurs within the constraint of a component, - -- so it must be checked. + Set_Rewriting_Proc (Update_Elaboration_Scenario'Access); + end Initialize; - elsif Nkind (P) = N_Component_Definition then - exit; + --------------- + -- Info_Call -- + --------------- - else - P := Parent (P); - end if; - end loop; + procedure Info_Call + (Call : Node_Id; + Target_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean) + is + procedure Info_Accept_Alternative; + pragma Inline (Info_Accept_Alternative); + -- Output information concerning an accept alternative + + procedure Info_Simple_Call; + pragma Inline (Info_Simple_Call); + -- Output information concerning the call + + procedure Info_Type_Actions (Action : String); + pragma Inline (Info_Type_Actions); + -- Output information concerning action Action of a type + + procedure Info_Verification_Call + (Pred : String; + Id : Entity_Id; + Id_Kind : String); + pragma Inline (Info_Verification_Call); + -- Output information concerning the verification of predicate Pred + -- applied to related entity Id with kind Id_Kind. - -- Stuff that happens only at the outer level + ----------------------------- + -- Info_Accept_Alternative -- + ----------------------------- - if No (Outer_Scope) then - Elab_Visited.Set_Last (0); + procedure Info_Accept_Alternative is + Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id); - -- Nothing to do if current scope is Standard (this is a bit odd, but - -- it happens in the case of generic instantiations). + begin + pragma Assert (Present (Entry_Id)); - C_Scope := Current_Scope; + Elab_Msg_NE + (Msg => "accept for entry & during elaboration", + N => Call, + Id => Entry_Id, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end Info_Accept_Alternative; - if C_Scope = Standard_Standard then - return; - end if; + ---------------------- + -- Info_Simple_Call -- + ---------------------- - -- First case, we are in elaboration code + procedure Info_Simple_Call is + begin + Elab_Msg_NE + (Msg => "call to & during elaboration", + N => Call, + Id => Target_Id, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end Info_Simple_Call; - From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; + ----------------------- + -- Info_Type_Actions -- + ----------------------- - if From_Elab_Code then + procedure Info_Type_Actions (Action : String) is + Typ : constant Entity_Id := First_Formal_Type (Target_Id); - -- Complain if ref that comes from source in preelaborated unit - -- and we are not inside a subprogram (i.e. we are in elab code). + begin + pragma Assert (Present (Typ)); + + Elab_Msg_NE + (Msg => Action & " actions for type & during elaboration", + N => Call, + Id => Typ, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end Info_Type_Actions; + + ---------------------------- + -- Info_Verification_Call -- + ---------------------------- + + procedure Info_Verification_Call + (Pred : String; + Id : Entity_Id; + Id_Kind : String) + is + begin + pragma Assert (Present (Id)); - if Comes_From_Source (N) - and then In_Preelaborated_Unit - and then not In_Inlined_Body - and then Nkind (N) /= N_Attribute_Reference - then - -- This is a warning in GNAT mode allowing such calls to be - -- used in the predefined library with appropriate care. + Elab_Msg_NE + (Msg => + "verification of " & Pred & " of " & Id_Kind & " & during " + & "elaboration", + N => Call, + Id => Id, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end Info_Verification_Call; - Error_Msg_Warn := GNAT_Mode; - Error_Msg_N - ("<<non-static call not allowed in preelaborated unit", N); - return; - end if; + -- Start of processing for Info_Call - -- Second case, we are inside a subprogram or concurrent unit, which - -- means we are not in elaboration code. + begin + -- Do not output anything for targets defined in internal units because + -- this creates noise. - else - -- In this case, the issue is whether we are inside the - -- declarative part of the unit in which we live, or inside its - -- statements. In the latter case, there is no issue of ABE calls - -- at this level (a call from outside to the unit in which we live - -- might cause an ABE, but that will be detected when we analyze - -- that outer level call, as it recurses into the called unit). - - -- Climb up the tree, doing this test, and also testing for being - -- inside a default expression, which, as discussed above, is not - -- checked at this stage. - - declare - P : Node_Id; - L : List_Id; - - begin - P := N; - loop - -- If we find a parentless subtree, it seems safe to assume - -- that we are not in a declarative part and that no - -- checking is required. - - if No (P) then - return; - end if; + if not In_Internal_Unit (Target_Id) then - if Is_List_Member (P) then - L := List_Containing (P); - P := Parent (L); - else - L := No_List; - P := Parent (P); - end if; + -- Accept alternative - exit when Nkind (P) = N_Subunit; + if Is_Accept_Alternative_Proc (Target_Id) then + Info_Accept_Alternative; - -- Filter out case of default expressions, where we do not - -- do the check at this stage. + -- Adjustment - if Nkind_In (P, N_Parameter_Specification, - N_Component_Declaration) - then - return; - end if; + elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then + Info_Type_Actions ("adjustment"); - -- A protected body has no elaboration code and contains - -- only other bodies. + -- Default_Initial_Condition - if Nkind (P) = N_Protected_Body then - return; + elsif Is_Default_Initial_Condition_Proc (Target_Id) then + Info_Verification_Call + (Pred => "Default_Initial_Condition", + Id => First_Formal_Type (Target_Id), + Id_Kind => "type"); - elsif Nkind_In (P, N_Subprogram_Body, - N_Task_Body, - N_Block_Statement, - N_Entry_Body) - then - if L = Declarations (P) then - exit; + -- Entries + + elsif Is_Protected_Entry (Target_Id) then + Info_Simple_Call; + + -- Task entry calls are never processed because the entry being + -- invoked does not have a corresponding "body", it has a select. + + elsif Is_Task_Entry (Target_Id) then + null; - -- We are not in elaboration code, but we are doing - -- dynamic elaboration checks, in this case, we still - -- need to do the reference, since the subprogram we are - -- in could be called from another unit, also in dynamic - -- elaboration check mode, at elaboration time. + -- Finalization - elsif Dynamic_Elaboration_Checks then + elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then + Info_Type_Actions ("finalization"); - -- We provide a debug flag to disable this check. That - -- way we have an easy work around for regressions - -- that are caused by this new check. This debug flag - -- can be removed later. + -- Calls to _Finalizer procedures must not appear in the output + -- because this creates confusing noise. - if Debug_Flag_DD then - return; - end if; + elsif Is_Finalizer_Proc (Target_Id) then + null; - -- Do the check in this case + -- Initial_Condition - exit; + elsif Is_Initial_Condition_Proc (Target_Id) then + Info_Verification_Call + (Pred => "Initial_Condition", + Id => Find_Enclosing_Scope (Call), + Id_Kind => "package"); - elsif Nkind (P) = N_Task_Body then + -- Initialization - -- The check is deferred until Check_Task_Activation - -- but we need to capture local suppress pragmas - -- that may inhibit checks on this call. + elsif Is_Init_Proc (Target_Id) + or else Is_TSS (Target_Id, TSS_Deep_Initialize) + then + Info_Type_Actions ("initialization"); - Ent := Get_Referenced_Ent (N); + -- Invariant - if No (Ent) then - return; + elsif Is_Invariant_Proc (Target_Id) then + Info_Verification_Call + (Pred => "invariants", + Id => First_Formal_Type (Target_Id), + Id_Kind => "type"); - elsif Elaboration_Checks_Suppressed (Current_Scope) - or else Elaboration_Checks_Suppressed (Ent) - or else Elaboration_Checks_Suppressed (Scope (Ent)) - then - if Nkind (N) in N_Subprogram_Call then - Set_No_Elaboration_Check (N); - end if; - end if; + -- Partial invariant calls must not appear in the output because this + -- creates confusing noise. - return; + elsif Is_Partial_Invariant_Proc (Target_Id) then + null; - -- Static model, call is not in elaboration code, we - -- never need to worry, because in the static model the - -- top-level caller always takes care of things. + -- _Postconditions - else - return; - end if; - end if; - end loop; - end; + elsif Is_Postconditions_Proc (Target_Id) then + Info_Verification_Call + (Pred => "postconditions", + Id => Find_Enclosing_Scope (Call), + Id_Kind => "subprogram"); + + -- Subprograms must come last because some of the previous cases fall + -- under this category. + + elsif Ekind (Target_Id) = E_Function then + Info_Simple_Call; + + elsif Ekind (Target_Id) = E_Procedure then + Info_Simple_Call; + + else + pragma Assert (False); + null; end if; end if; + end Info_Call; - Ent := Get_Referenced_Ent (N); + ------------------------ + -- Info_Instantiation -- + ------------------------ - if No (Ent) then + procedure Info_Instantiation + (Inst : Node_Id; + Gen_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean) + is + begin + Elab_Msg_NE + (Msg => "instantiation of & during elaboration", + N => Inst, + Id => Gen_Id, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end Info_Instantiation; + + ----------------------------- + -- Info_Variable_Reference -- + ----------------------------- + + procedure Info_Variable_Reference + (Ref : Node_Id; + Var_Id : Entity_Id; + Info_Msg : Boolean; + In_SPARK : Boolean) + is + begin + Elab_Msg_NE + (Msg => "reference to variable & during elaboration", + N => Ref, + Id => Var_Id, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end Info_Variable_Reference; + + -------------------- + -- Insertion_Node -- + -------------------- + + function Insertion_Node (N : Node_Id; Ins_Nod : Node_Id) return Node_Id is + begin + -- When the scenario denotes an instantiation, the proper insertion node + -- is the instance spec. This ensures that the generic actuals will not + -- be evaluated prior to a potential ABE. + + if Nkind (N) in N_Generic_Instantiation + and then Present (Instance_Spec (N)) + then + return Instance_Spec (N); + + -- Otherwise the proper insertion node is the candidate insertion node + + else + return Ins_Nod; + end if; + end Insertion_Node; + + ----------------------- + -- Install_ABE_Check -- + ----------------------- + + procedure Install_ABE_Check + (N : Node_Id; + Id : Entity_Id; + Ins_Nod : Node_Id) + is + Check_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod); + -- Insert the check prior to this node + + Loc : constant Source_Ptr := Sloc (N); + Spec_Id : constant Entity_Id := Unique_Entity (Id); + Unit_Id : constant Entity_Id := Find_Top_Unit (Id); + Scop_Id : Entity_Id; + + begin + -- Nothing to do when the compilation will not produce an executable + + if Serious_Errors_Detected > 0 then + return; + + -- Nothing to do for a compilation unit because there is no executable + -- environment at that level. + + elsif Nkind (Parent (Check_Ins_Nod)) = N_Compilation_Unit then + return; + + -- Nothing to do when the unit is elaborated prior to the main unit. + -- This check must also consider the following cases: + + -- * Id's unit appears in the context of the main unit + + -- * Id's unit is subject to pragma Elaborate_Body. An ABE check MUST + -- NOT be generated because Id's unit is always elaborated prior to + -- the main unit. + + -- * Id's unit is the main unit. An ABE check MUST be generated in this + -- case because a conditional ABE may be raised depending on the flow + -- of execution within the main unit (flag Same_Unit_OK is False). + + elsif Has_Prior_Elaboration + (Unit_Id => Unit_Id, + Context_OK => True, + Elab_Body_OK => True) + then return; end if; - -- Determine whether a prior call to the same subprogram was already - -- examined within the same context. If this is the case, then there is - -- no need to proceed with the various warnings and checks because the - -- work was already done for the previous call. + -- Prevent multiple scenarios from installing the same ABE check + + Set_Is_Elaboration_Checks_OK_Node (N, False); + + -- Install the nearest enclosing scope of the scenario as there must be + -- something on the scope stack. + + -- Performance note: parent traversal + + Scop_Id := Find_Enclosing_Scope (Check_Ins_Nod); + pragma Assert (Present (Scop_Id)); + + Push_Scope (Scop_Id); - declare - Self : constant Visited_Element := - (Subp_Id => Ent, Context => Parent (N)); + -- Generate: + -- if not Spec_Id'Elaborated then + -- raise Program_Error with "access before elaboration"; + -- end if; + + Insert_Action (Check_Ins_Nod, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Spec_Id, Loc), + Attribute_Name => Name_Elaborated)), + Reason => PE_Access_Before_Elaboration)); + + Pop_Scope; + end Install_ABE_Check; + + ----------------------- + -- Install_ABE_Check -- + ----------------------- + + procedure Install_ABE_Check + (N : Node_Id; + Target_Id : Entity_Id; + Target_Decl : Node_Id; + Target_Body : Node_Id; + Ins_Nod : Node_Id) + is + procedure Build_Elaboration_Entity; + pragma Inline (Build_Elaboration_Entity); + -- Create a new elaboration flag for Target_Id, insert it prior to + -- Target_Decl, and set it after Body_Decl. + + ------------------------------ + -- Build_Elaboration_Entity -- + ------------------------------ + + procedure Build_Elaboration_Entity is + Loc : constant Source_Ptr := Sloc (Target_Id); + Flag_Id : Entity_Id; begin - for Index in 1 .. Elab_Visited.Last loop - if Self = Elab_Visited.Table (Index) then - return; - end if; - end loop; - end; + -- Create the declaration of the elaboration flag. The name carries a + -- unique counter in case of name overloading. - -- See if we need to analyze this reference. We analyze it if either of - -- the following conditions is met: + Flag_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Target_Id), 'E', -1)); - -- It is an inner level call (since in this case it was triggered - -- by an outer level call from elaboration code), but only if the - -- call is within the scope of the original outer level call. + Set_Elaboration_Entity (Target_Id, Flag_Id); + Set_Elaboration_Entity_Required (Target_Id); - -- It is an outer level reference from elaboration code, or a call to - -- an entity is in the same elaboration scope. + Push_Scope (Scope (Target_Id)); - -- And in these cases, we will check both inter-unit calls and - -- intra-unit (within a single unit) calls. + -- Generate: + -- Enn : Short_Integer := 0; - C_Scope := Current_Scope; + Insert_Action (Target_Decl, + Make_Object_Declaration (Loc, + Defining_Identifier => Flag_Id, + Object_Definition => + New_Occurrence_Of (Standard_Short_Integer, Loc), + Expression => Make_Integer_Literal (Loc, Uint_0))); - -- If not outer level reference, then we follow it if it is within the - -- original scope of the outer reference. + -- Generate: + -- Enn := 1; - if Present (Outer_Scope) - and then Within (Scope (Ent), Outer_Scope) - then - Set_C_Scope; - Check_A_Call - (N => N, - E => Ent, - Outer_Scope => Outer_Scope, - Inter_Unit_Only => False, - In_Init_Proc => In_Init_Proc); - - -- Nothing to do if elaboration checks suppressed for this scope. - -- However, an interesting exception, the fact that elaboration checks - -- are suppressed within an instance (because we can trace the body when - -- we process the template) does not extend to calls to generic formal - -- subprograms. - - elsif Elaboration_Checks_Suppressed (Current_Scope) - and then not Is_Call_Of_Generic_Formal (N) + Set_Elaboration_Flag (Target_Body, Target_Id); + + Pop_Scope; + end Build_Elaboration_Entity; + + -- Local variables + + Target_Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id); + + -- Start for processing for Install_ABE_Check + + begin + -- Nothing to do when the compilation will not produce an executable + + if Serious_Errors_Detected > 0 then + return; + + -- Nothing to do when the target is a protected subprogram because the + -- check is associated with the protected body subprogram. + + elsif Is_Protected_Subp (Target_Id) then + return; + + -- Nothing to do when the target is elaborated prior to the main unit. + -- This check must also consider the following cases: + + -- * The unit of the target appears in the context of the main unit + + -- * The unit of the target is subject to pragma Elaborate_Body. An ABE + -- check MUST NOT be generated because the unit is always elaborated + -- prior to the main unit. + + -- * The unit of the target is the main unit. An ABE check MUST be added + -- in this case because a conditional ABE may be raised depending on + -- the flow of execution within the main unit (flag Same_Unit_OK is + -- False). + + elsif Has_Prior_Elaboration + (Unit_Id => Target_Unit_Id, + Context_OK => True, + Elab_Body_OK => True) then - null; + return; + + -- Create an elaboration flag for the target when it does not have one - elsif From_Elab_Code then - Set_C_Scope; - Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); + elsif No (Elaboration_Entity (Target_Id)) then + Build_Elaboration_Entity; + end if; - elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then - Set_C_Scope; - Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); + Install_ABE_Check + (N => N, + Ins_Nod => Ins_Nod, + Id => Target_Id); + end Install_ABE_Check; - -- If none of those cases holds, but Dynamic_Elaboration_Checks mode - -- is set, then we will do the check, but only in the inter-unit case - -- (this is to accommodate unguarded elaboration calls from other units - -- in which this same mode is set). We don't want warnings in this case, - -- it would generate warnings having nothing to do with elaboration. + ------------------------- + -- Install_ABE_Failure -- + ------------------------- - elsif Dynamic_Elaboration_Checks then - Set_C_Scope; - Check_A_Call - (N, - Ent, - Standard_Standard, - Inter_Unit_Only => True, - Generate_Warnings => False); + procedure Install_ABE_Failure (N : Node_Id; Ins_Nod : Node_Id) is + Fail_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod); + -- Insert the failure prior to this node - -- Otherwise nothing to do + Loc : constant Source_Ptr := Sloc (N); + Scop_Id : Entity_Id; - else + begin + -- Nothing to do when the compilation will not produce an executable + + if Serious_Errors_Detected > 0 then + return; + + -- Do not install an ABE check for a compilation unit because there is + -- no executable environment at that level. + + elsif Nkind (Parent (Fail_Ins_Nod)) = N_Compilation_Unit then return; end if; - -- A call to an Init_Proc in elaboration code may bring additional - -- dependencies, if some of the record components thereof have - -- initializations that are function calls that come from source. We - -- treat the current node as a call to each of these functions, to check - -- their elaboration impact. + -- Prevent multiple scenarios from installing the same ABE failure - if Is_Init_Proc (Ent) and then From_Elab_Code then - Process_Init_Proc : declare - Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent); + Set_Is_Elaboration_Checks_OK_Node (N, False); - function Check_Init_Call (Nod : Node_Id) return Traverse_Result; - -- Find subprogram calls within body of Init_Proc for Traverse - -- instantiation below. + -- Install the nearest enclosing scope of the scenario as there must be + -- something on the scope stack. - procedure Traverse_Body is new Traverse_Proc (Check_Init_Call); - -- Traversal procedure to find all calls with body of Init_Proc + -- Performance note: parent traversal - --------------------- - -- Check_Init_Call -- - --------------------- + Scop_Id := Find_Enclosing_Scope (Fail_Ins_Nod); + pragma Assert (Present (Scop_Id)); - function Check_Init_Call (Nod : Node_Id) return Traverse_Result is - Func : Entity_Id; + Push_Scope (Scop_Id); - begin - if Nkind (Nod) in N_Subprogram_Call - and then Is_Entity_Name (Name (Nod)) - then - Func := Entity (Name (Nod)); + -- Generate: + -- raise Program_Error with "access before elaboration"; - if Comes_From_Source (Func) then - Check_A_Call - (N, Func, Standard_Standard, Inter_Unit_Only => True); - end if; + Insert_Action (Fail_Ins_Nod, + Make_Raise_Program_Error (Loc, + Reason => PE_Access_Before_Elaboration)); - return OK; + Pop_Scope; + end Install_ABE_Failure; - else - return OK; - end if; - end Check_Init_Call; + -------------------------------- + -- Is_Accept_Alternative_Proc -- + -------------------------------- - -- Start of processing for Process_Init_Proc + function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a procedure with a receiving entry - begin - if Nkind (Unit_Decl) = N_Subprogram_Body then - Traverse_Body (Handled_Statement_Sequence (Unit_Decl)); - end if; - end Process_Init_Proc; + return Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id)); + end Is_Accept_Alternative_Proc; + + ------------------------ + -- Is_Activation_Proc -- + ------------------------ + + function Is_Activation_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote one of the runtime procedures in + -- charge of task activation. + + if Ekind (Id) = E_Procedure then + if Restricted_Profile then + return Is_RTE (Id, RE_Activate_Restricted_Tasks); + else + return Is_RTE (Id, RE_Activate_Tasks); + end if; end if; - end Check_Elab_Call; - ----------------------- - -- Check_Elab_Assign -- - ----------------------- + return False; + end Is_Activation_Proc; - procedure Check_Elab_Assign (N : Node_Id) is - Ent : Entity_Id; - Scop : Entity_Id; + ---------------------------- + -- Is_Ada_Semantic_Target -- + ---------------------------- - Pkg_Spec : Entity_Id; - Pkg_Body : Entity_Id; + function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean is + begin + return + Is_Activation_Proc (Id) + or else Is_Controlled_Proc (Id, Name_Adjust) + or else Is_Controlled_Proc (Id, Name_Finalize) + or else Is_Controlled_Proc (Id, Name_Initialize) + or else Is_Init_Proc (Id) + or else Is_Invariant_Proc (Id) + or else Is_Protected_Entry (Id) + or else Is_Protected_Subp (Id) + or else Is_Protected_Body_Subp (Id) + or else Is_Task_Entry (Id); + end Is_Ada_Semantic_Target; + ---------------------------- + -- Is_Bodiless_Subprogram -- + ---------------------------- + + function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is begin - -- For record or array component, check prefix. If it is an access type, - -- then there is nothing to do (we do not know what is being assigned), - -- but otherwise this is an assignment to the prefix. + -- An abstract subprogram does not have a body - if Nkind_In (N, N_Indexed_Component, - N_Selected_Component, - N_Slice) + if Ekind_In (Subp_Id, E_Function, + E_Operator, + E_Procedure) + and then Is_Abstract_Subprogram (Subp_Id) then - if not Is_Access_Type (Etype (Prefix (N))) then - Check_Elab_Assign (Prefix (N)); - end if; + return True; - return; - end if; + -- A formal subprogram does not have a body - -- For type conversion, check expression + elsif Is_Formal_Subprogram (Subp_Id) then + return True; - if Nkind (N) = N_Type_Conversion then - Check_Elab_Assign (Expression (N)); - return; + -- An imported subprogram may have a body, however it is not known at + -- compile or bind time where the body resides and whether it will be + -- elaborated on time. + + elsif Is_Imported (Subp_Id) then + return True; end if; - -- Nothing to do if this is not an entity reference otherwise get entity + return False; + end Is_Bodiless_Subprogram; - if Is_Entity_Name (N) then - Ent := Entity (N); - else - return; - end if; + -------------------------------- + -- Is_Check_Emitting_Scenario -- + -------------------------------- + + function Is_Check_Emitting_Scenario (N : Node_Id) return Boolean is + begin + return + Nkind_In (N, N_Call_Marker, + N_Function_Instantiation, + N_Package_Instantiation, + N_Procedure_Instantiation); + end Is_Check_Emitting_Scenario; + + ------------------------ + -- Is_Controlled_Proc -- + ------------------------ - -- What we are looking for is a reference in the body of a package that - -- modifies a variable declared in the visible part of the package spec. + function Is_Controlled_Proc + (Subp_Id : Entity_Id; + Subp_Nam : Name_Id) return Boolean + is + Formal_Id : Entity_Id; + + begin + pragma Assert (Nam_In (Subp_Nam, Name_Adjust, + Name_Finalize, + Name_Initialize)); - if Present (Ent) - and then Comes_From_Source (N) - and then not Suppress_Elaboration_Warnings (Ent) - and then Ekind (Ent) = E_Variable - and then not In_Private_Part (Ent) - and then Is_Library_Level_Entity (Ent) + -- To qualify, the subprogram must denote a source procedure with name + -- Adjust, Finalize, or Initialize where the sole formal is controlled. + + if Comes_From_Source (Subp_Id) + and then Ekind (Subp_Id) = E_Procedure + and then Chars (Subp_Id) = Subp_Nam then - Scop := Current_Scope; - loop - if No (Scop) or else Scop = Standard_Standard then - return; - elsif Ekind (Scop) = E_Package - and then Is_Compilation_Unit (Scop) - then - exit; - else - Scop := Scope (Scop); - end if; - end loop; + Formal_Id := First_Formal (Subp_Id); - -- Here Scop points to the containing library package + return + Present (Formal_Id) + and then Is_Controlled (Etype (Formal_Id)) + and then No (Next_Formal (Formal_Id)); + end if; - Pkg_Spec := Scop; - Pkg_Body := Body_Entity (Pkg_Spec); + return False; + end Is_Controlled_Proc; - -- All OK if the package has an Elaborate_Body pragma + --------------------------------------- + -- Is_Default_Initial_Condition_Proc -- + --------------------------------------- - if Has_Pragma_Elaborate_Body (Scop) then - return; - end if; + function Is_Default_Initial_Condition_Proc + (Id : Entity_Id) return Boolean + is + begin + -- To qualify, the entity must denote a Default_Initial_Condition + -- procedure. - -- OK if entity being modified is not in containing package spec + return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id); + end Is_Default_Initial_Condition_Proc; - if not In_Same_Source_Unit (Scop, Ent) then - return; - end if; + ----------------------- + -- Is_Finalizer_Proc -- + ----------------------- - -- All OK if entity appears in generic package or generic instance. - -- We just get too messed up trying to give proper warnings in the - -- presence of generics. Better no message than a junk one. + function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a _Finalizer procedure - Scop := Scope (Ent); - while Present (Scop) and then Scop /= Pkg_Spec loop - if Ekind (Scop) = E_Generic_Package then - return; - elsif Ekind (Scop) = E_Package - and then Is_Generic_Instance (Scop) - then - return; - end if; + return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer; + end Is_Finalizer_Proc; - Scop := Scope (Scop); - end loop; + ----------------------- + -- Is_Guaranteed_ABE -- + ----------------------- - -- All OK if in task, don't issue warnings there + function Is_Guaranteed_ABE + (N : Node_Id; + Target_Decl : Node_Id; + Target_Body : Node_Id) return Boolean + is + begin + -- Avoid cascaded errors if there were previous serious infractions. + -- As a result the scenario will not be treated as a guaranteed ABE. + -- This behaviour parallels that of the old ABE mechanism. - if In_Task_Activation then - return; - end if; + if Serious_Errors_Detected > 0 then + return False; - -- OK if no package body + -- The scenario and the target appear within the same context ignoring + -- enclosing library levels. - if No (Pkg_Body) then - return; - end if; + -- Performance note: parent traversal - -- OK if reference is not in package body + elsif In_Same_Context (N, Target_Decl) then - if not In_Same_Source_Unit (Pkg_Body, N) then - return; + -- The target body has already been encountered. The scenario results + -- in a guaranteed ABE if it appears prior to the body. + + if Present (Target_Body) then + return Earlier_In_Extended_Unit (N, Target_Body); + + -- Otherwise the body has not been encountered yet. The scenario is + -- a guaranteed ABE since the body will appear later. It is assumed + -- that the caller has already checked whether the scenario is ABE- + -- safe as optional bodies are not considered here. + + else + return True; end if; + end if; - -- OK if package body has no handled statement sequence + return False; + end Is_Guaranteed_ABE; - declare - HSS : constant Node_Id := - Handled_Statement_Sequence (Declaration_Node (Pkg_Body)); - begin - if No (HSS) or else not Comes_From_Source (HSS) then - return; - end if; - end; + ------------------------------- + -- Is_Initial_Condition_Proc -- + ------------------------------- - -- We definitely have a case of a modification of an entity in - -- the package spec from the elaboration code of the package body. - -- We may not give the warning (because there are some additional - -- checks to avoid too many false positives), but it would be a good - -- idea for the binder to try to keep the body elaboration close to - -- the spec elaboration. + function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote an Initial_Condition procedure - Set_Elaborate_Body_Desirable (Pkg_Spec); + return + Ekind (Id) = E_Procedure and then Is_Initial_Condition_Procedure (Id); + end Is_Initial_Condition_Proc; - -- All OK in gnat mode (we know what we are doing) + ----------------------- + -- Is_Invariant_Proc -- + ----------------------- - if GNAT_Mode then - return; - end if; + function Is_Invariant_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote the "full" invariant procedure - -- All OK if all warnings suppressed + return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id); + end Is_Invariant_Proc; - if Warning_Mode = Suppress then - return; - end if; + --------------------------------------- + -- Is_Non_Library_Level_Encapsulator -- + --------------------------------------- - -- All OK if elaboration checks suppressed for entity + function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean is + begin + case Nkind (N) is + when N_Abstract_Subprogram_Declaration + | N_Aspect_Specification + | N_Component_Declaration + | N_Entry_Body + | N_Entry_Declaration + | N_Expression_Function + | N_Formal_Abstract_Subprogram_Declaration + | N_Formal_Concrete_Subprogram_Declaration + | N_Formal_Object_Declaration + | N_Formal_Package_Declaration + | N_Formal_Type_Declaration + | N_Generic_Association + | N_Implicit_Label_Declaration + | N_Incomplete_Type_Declaration + | N_Private_Extension_Declaration + | N_Private_Type_Declaration + | N_Protected_Body + | N_Protected_Type_Declaration + | N_Single_Protected_Declaration + | N_Single_Task_Declaration + | N_Subprogram_Body + | N_Subprogram_Declaration + | N_Task_Body + | N_Task_Type_Declaration + => + return True; - if Checks_May_Be_Suppressed (Ent) - and then Is_Check_Suppressed (Ent, Elaboration_Check) - then - return; - end if; + when others => + return Is_Generic_Declaration_Or_Body (N); + end case; + end Is_Non_Library_Level_Encapsulator; + + ------------------------------- + -- Is_Partial_Invariant_Proc -- + ------------------------------- - -- OK if the entity is initialized. Note that the No_Initialization - -- flag usually means that the initialization has been rewritten into - -- assignments, but that still counts for us. + function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote the "partial" invariant procedure - declare - Decl : constant Node_Id := Declaration_Node (Ent); - begin - if Nkind (Decl) = N_Object_Declaration - and then (Present (Expression (Decl)) - or else No_Initialization (Decl)) - then - return; - end if; - end; + return + Ekind (Id) = E_Procedure and then Is_Partial_Invariant_Procedure (Id); + end Is_Partial_Invariant_Proc; + + ---------------------------- + -- Is_Postconditions_Proc -- + ---------------------------- - -- Here is where we give the warning + function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a _Postconditions procedure - -- All OK if warnings suppressed on the entity + return + Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions; + end Is_Postconditions_Proc; - if not Has_Warnings_Off (Ent) then - Error_Msg_Sloc := Sloc (Ent); + --------------------------- + -- Is_Preelaborated_Unit -- + --------------------------- - Error_Msg_NE - ("??& can be accessed by clients before this initialization", - N, Ent); - Error_Msg_NE - ("\??add Elaborate_Body to spec to ensure & is initialized", - N, Ent); - end if; + function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean is + begin + return + Is_Preelaborated (Id) + or else Is_Pure (Id) + or else Is_Remote_Call_Interface (Id) + or else Is_Remote_Types (Id) + or else Is_Shared_Passive (Id); + end Is_Preelaborated_Unit; - if not All_Errors_Mode then - Set_Suppress_Elaboration_Warnings (Ent); - end if; - end if; - end Check_Elab_Assign; + ------------------------ + -- Is_Protected_Entry -- + ------------------------ - ---------------------- - -- Check_Elab_Calls -- - ---------------------- + function Is_Protected_Entry (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote an entry defined in a protected + -- type. - -- WARNING: This routine manages SPARK regions + return + Is_Entry (Id) + and then Is_Protected_Type (Non_Private_View (Scope (Id))); + end Is_Protected_Entry; - procedure Check_Elab_Calls is - Saved_SM : SPARK_Mode_Type; - Saved_SMP : Node_Id; + ----------------------- + -- Is_Protected_Subp -- + ----------------------- + function Is_Protected_Subp (Id : Entity_Id) return Boolean is begin - -- If expansion is disabled, do not generate any checks, unless we - -- are in GNATprove mode, so that errors are issued in GNATprove for - -- violations of static elaboration rules in SPARK code. Also skip - -- checks if any subunits are missing because in either case we lack the - -- full information that we need, and no object file will be created in - -- any case. + -- To qualify, the entity must denote a subprogram defined within a + -- protected type. + + return + Ekind_In (Id, E_Function, E_Procedure) + and then Is_Protected_Type (Non_Private_View (Scope (Id))); + end Is_Protected_Subp; - if (not Expander_Active and not GNATprove_Mode) - or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) - or else Subunits_Missing + ---------------------------- + -- Is_Protected_Body_Subp -- + ---------------------------- + + function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote a subprogram with attribute + -- Protected_Subprogram set. + + return + Ekind_In (Id, E_Function, E_Procedure) + and then Present (Protected_Subprogram (Id)); + end Is_Protected_Body_Subp; + + ------------------------ + -- Is_Safe_Activation -- + ------------------------ + + function Is_Safe_Activation + (Call : Node_Id; + Task_Decl : Node_Id) return Boolean + is + begin + -- The activation of a task coming from an external instance cannot + -- cause an ABE because the generic was already instantiated. Note + -- that the instantiation itself may lead to an ABE. + + return + In_External_Instance + (N => Call, + Target_Decl => Task_Decl); + end Is_Safe_Activation; + + ------------------ + -- Is_Safe_Call -- + ------------------ + + function Is_Safe_Call + (Call : Node_Id; + Target_Attrs : Target_Attributes) return Boolean + is + begin + -- The target is either an abstract subprogram, formal subprogram, or + -- imported, in which case it does not have a body at compile or bind + -- time. Assume that the call is ABE-safe. + + if Is_Bodiless_Subprogram (Target_Attrs.Spec_Id) then + return True; + + -- The target is an instantiation of a generic subprogram. The call + -- cannot cause an ABE because the generic was already instantiated. + -- Note that the instantiation itself may lead to an ABE. + + elsif Is_Generic_Instance (Target_Attrs.Spec_Id) then + return True; + + -- The invocation of a target coming from an external instance cannot + -- cause an ABE because the generic was already instantiated. Note that + -- the instantiation itself may lead to an ABE. + + elsif In_External_Instance + (N => Call, + Target_Decl => Target_Attrs.Spec_Decl) then - return; + return True; + + -- The target is a subprogram body without a previous declaration. The + -- call cannot cause an ABE because the body has already been seen. + + elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body + and then No (Corresponding_Spec (Target_Attrs.Spec_Decl)) + then + return True; + + -- The target is a subprogram body stub without a prior declaration. + -- The call cannot cause an ABE because the proper body substitutes + -- the stub. + + elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body_Stub + and then No (Corresponding_Spec_Of_Stub (Target_Attrs.Spec_Decl)) + then + return True; + + -- Subprogram bodies which wrap attribute references used as actuals + -- in instantiations are always ABE-safe. These bodies are artifacts + -- of expansion. + + elsif Present (Target_Attrs.Body_Decl) + and then Nkind (Target_Attrs.Body_Decl) = N_Subprogram_Body + and then Was_Attribute_Reference (Target_Attrs.Body_Decl) + then + return True; end if; - -- Skip delayed calls if we had any errors + return False; + end Is_Safe_Call; - if Serious_Errors_Detected = 0 then - Delaying_Elab_Checks := False; - Expander_Mode_Save_And_Set (True); + --------------------------- + -- Is_Safe_Instantiation -- + --------------------------- - for J in Delay_Check.First .. Delay_Check.Last loop - Push_Scope (Delay_Check.Table (J).Curscop); - From_Elab_Code := Delay_Check.Table (J).From_Elab_Code; - In_Task_Activation := Delay_Check.Table (J).In_Task_Activation; + function Is_Safe_Instantiation + (Inst : Node_Id; + Gen_Attrs : Target_Attributes) return Boolean + is + begin + -- The generic is an intrinsic subprogram in which case it does not + -- have a body at compile or bind time. Assume that the instantiation + -- is ABE-safe. - Saved_SM := SPARK_Mode; - Saved_SMP := SPARK_Mode_Pragma; + if Is_Bodiless_Subprogram (Gen_Attrs.Spec_Id) then + return True; - -- Set appropriate value of SPARK_Mode + -- The instantiation of an external nested generic cannot cause an ABE + -- if the outer generic was already instantiated. Note that the instance + -- of the outer generic may lead to an ABE. - if Delay_Check.Table (J).From_SPARK_Code then - SPARK_Mode := On; - end if; + elsif In_External_Instance + (N => Inst, + Target_Decl => Gen_Attrs.Spec_Decl) + then + return True; + + -- The generic is a package. The instantiation cannot cause an ABE when + -- the package has no body. + + elsif Ekind (Gen_Attrs.Spec_Id) = E_Generic_Package + and then not Has_Body (Gen_Attrs.Spec_Decl) + then + return True; + end if; + + return False; + end Is_Safe_Instantiation; - Check_Internal_Call_Continue - (N => Delay_Check.Table (J).N, - E => Delay_Check.Table (J).E, - Outer_Scope => Delay_Check.Table (J).Outer_Scope, - Orig_Ent => Delay_Check.Table (J).Orig_Ent); + ------------------ + -- Is_Same_Unit -- + ------------------ + + function Is_Same_Unit + (Unit_1 : Entity_Id; + Unit_2 : Entity_Id) return Boolean + is + function Is_Subunit (Unit_Id : Entity_Id) return Boolean; + pragma Inline (Is_Subunit); + -- Determine whether unit Unit_Id is a subunit + + function Normalize_Unit (Unit_Id : Entity_Id) return Entity_Id; + -- Strip a potential subunit chain ending with unit Unit_Id and return + -- the corresponding spec. + + ---------------- + -- Is_Subunit -- + ---------------- + + function Is_Subunit (Unit_Id : Entity_Id) return Boolean is + begin + return Nkind (Parent (Unit_Declaration_Node (Unit_Id))) = N_Subunit; + end Is_Subunit; + + -------------------- + -- Normalize_Unit -- + -------------------- + + function Normalize_Unit (Unit_Id : Entity_Id) return Entity_Id is + Result : Entity_Id; + + begin + -- Eliminate a potential chain of subunits to reach to proper body - Restore_SPARK_Mode (Saved_SM, Saved_SMP); - Pop_Scope; + Result := Unit_Id; + while Present (Result) + and then Result /= Standard_Standard + and then Is_Subunit (Result) + loop + Result := Scope (Result); end loop; - -- Set Delaying_Elab_Checks back on for next main compilation + -- Obtain the entity of the corresponding spec (if any) - Expander_Mode_Restore; - Delaying_Elab_Checks := True; - end if; - end Check_Elab_Calls; + return Unique_Entity (Result); + end Normalize_Unit; + + -- Start of processing for Is_Same_Unit + + begin + return Normalize_Unit (Unit_1) = Normalize_Unit (Unit_2); + end Is_Same_Unit; + + ----------------- + -- Is_Scenario -- + ----------------- + + function Is_Scenario (N : Node_Id) return Boolean is + begin + case Nkind (N) is + when N_Assignment_Statement + | N_Attribute_Reference + | N_Call_Marker + | N_Entry_Call_Statement + | N_Expanded_Name + | N_Function_Call + | N_Function_Instantiation + | N_Identifier + | N_Package_Instantiation + | N_Procedure_Call_Statement + | N_Procedure_Instantiation + | N_Requeue_Statement + => + return True; + + when others => + return False; + end case; + end Is_Scenario; ------------------------------ - -- Check_Elab_Instantiation -- + -- Is_SPARK_Semantic_Target -- ------------------------------ - procedure Check_Elab_Instantiation - (N : Node_Id; - Outer_Scope : Entity_Id := Empty) - is - Ent : Entity_Id; + function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean is + begin + return + Is_Default_Initial_Condition_Proc (Id) + or else Is_Initial_Condition_Proc (Id); + end Is_SPARK_Semantic_Target; + + ------------------------ + -- Is_Suitable_Access -- + ------------------------ + + function Is_Suitable_Access (N : Node_Id) return Boolean is + Nam : Name_Id; + Pref : Node_Id; + Subp_Id : Entity_Id; begin - -- Check for and deal with bad instantiation case. There is some - -- duplicated code here, but we will worry about this later ??? + if Nkind (N) /= N_Attribute_Reference then + return False; - Check_Bad_Instantiation (N); + -- Internally-generated attributes are assumed to be ABE safe - if ABE_Is_Certain (N) then - return; + elsif not Comes_From_Source (N) then + return False; end if; - -- Nothing to do if we do not have an instantiation (happens in some - -- error cases, and also in the formal package declaration case) + Nam := Attribute_Name (N); + Pref := Prefix (N); - if Nkind (N) not in N_Generic_Instantiation then - return; - end if; + -- Sanitize the prefix of the attribute - -- Nothing to do if inside a generic template + if not Is_Entity_Name (Pref) then + return False; - if Inside_A_Generic then - return; + elsif No (Entity (Pref)) then + return False; end if; - -- Nothing to do if the instantiation is not in the main unit + Subp_Id := Entity (Pref); - if not In_Extended_Main_Code_Unit (N) then - return; + if not Is_Subprogram_Or_Entry (Subp_Id) then + return False; end if; - Ent := Get_Generic_Entity (N); - From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; + -- Traverse a possible chain of renamings to obtain the original entry + -- or subprogram which the prefix may rename. - -- See if we need to analyze this instantiation. We analyze it if - -- either of the following conditions is met: + Subp_Id := Get_Renamed_Entity (Subp_Id); - -- It is an inner level instantiation (since in this case it was - -- triggered by an outer level call from elaboration code), but - -- only if the instantiation is within the scope of the original - -- outer level call. + -- To qualify, the attribute must meet the following prerequisites: - -- It is an outer level instantiation from elaboration code, or the - -- instantiated entity is in the same elaboration scope. + return - -- And in these cases, we will check both the inter-unit case and - -- the intra-unit (within a single unit) case. + -- This particular scenario is relevant only in the static model when + -- switch -gnatd.U (ignore 'Access) is not in effect. - C_Scope := Current_Scope; + Static_Elaboration_Checks + and then not Debug_Flag_Dot_UU - if Present (Outer_Scope) and then Within (Scope (Ent), Outer_Scope) then - Set_C_Scope; - Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False); + -- The prefix must denote an entry, operator, or subprogram which is + -- not imported. - elsif From_Elab_Code then - Set_C_Scope; - Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); + and then Comes_From_Source (Subp_Id) + and then Is_Subprogram_Or_Entry (Subp_Id) + and then not Is_Bodiless_Subprogram (Subp_Id) - elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then - Set_C_Scope; - Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); + -- The attribute name must be one of the 'Access forms. Note that + -- 'Unchecked_Access cannot apply to a subprogram. - -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is - -- set, then we will do the check, but only in the inter-unit case (this - -- is to accommodate unguarded elaboration calls from other units in - -- which this same mode is set). We inhibit warnings in this case, since - -- this instantiation is not occurring in elaboration code. + and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access); + end Is_Suitable_Access; - elsif Dynamic_Elaboration_Checks then - Set_C_Scope; - Check_A_Call - (N, - Ent, - Standard_Standard, - Inter_Unit_Only => True, - Generate_Warnings => False); + ---------------------- + -- Is_Suitable_Call -- + ---------------------- - else - return; + function Is_Suitable_Call (N : Node_Id) return Boolean is + begin + -- Entry and subprogram calls are intentionally ignored because they + -- may undergo expansion depending on the compilation mode, previous + -- errors, generic context, etc. Call markers play the role of calls + -- and provide a uniform foundation for ABE processing. + + return Nkind (N) = N_Call_Marker; + end Is_Suitable_Call; + + ------------------------------- + -- Is_Suitable_Instantiation -- + ------------------------------- + + function Is_Suitable_Instantiation (N : Node_Id) return Boolean is + Orig_N : constant Node_Id := Original_Node (N); + -- Use the original node in case an instantiation library unit is + -- rewritten as a package or subprogram. + + begin + -- To qualify, the instantiation must come from source + + return + Comes_From_Source (Orig_N) + and then Nkind (Orig_N) in N_Generic_Instantiation; + end Is_Suitable_Instantiation; + + -------------------------- + -- Is_Suitable_Scenario -- + -------------------------- + + function Is_Suitable_Scenario (N : Node_Id) return Boolean is + begin + return + Is_Suitable_Access (N) + or else Is_Suitable_Call (N) + or else Is_Suitable_Instantiation (N) + or else Is_Suitable_Variable_Assignment (N) + or else Is_Suitable_Variable_Reference (N); + end Is_Suitable_Scenario; + + ------------------------------------- + -- Is_Suitable_Variable_Assignment -- + ------------------------------------- + + function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean is + N_Unit : Node_Id; + N_Unit_Id : Entity_Id; + Nam : Node_Id; + Var_Decl : Node_Id; + Var_Id : Entity_Id; + Var_Unit : Node_Id; + Var_Unit_Id : Entity_Id; + + begin + if Nkind (N) /= N_Assignment_Statement then + return False; + + -- Internally-generated assigments are assumed to be ABE safe + + elsif not Comes_From_Source (N) then + return False; + + -- Assignments are ignored in GNAT mode on the assumption that they are + -- ABE-safe. This behaviour parallels that of the old ABE mechanism. + + elsif GNAT_Mode then + return False; end if; - end Check_Elab_Instantiation; - ------------------------- - -- Check_Internal_Call -- - ------------------------- + Nam := Extract_Assignment_Name (N); - procedure Check_Internal_Call - (N : Node_Id; - E : Entity_Id; - Outer_Scope : Entity_Id; - Orig_Ent : Entity_Id) - is - function Within_Initial_Condition (Call : Node_Id) return Boolean; - -- Determine whether call Call occurs within pragma Initial_Condition or - -- pragma Check with check_kind set to Initial_Condition. + -- Sanitize the left hand side of the assignment - ------------------------------ - -- Within_Initial_Condition -- - ------------------------------ + if not Is_Entity_Name (Nam) then + return False; - function Within_Initial_Condition (Call : Node_Id) return Boolean is - Args : List_Id; - Nam : Name_Id; - Par : Node_Id; + elsif No (Entity (Nam)) then + return False; + end if; - begin - -- Traverse the parent chain looking for an enclosing pragma + Var_Id := Entity (Nam); - Par := Call; - while Present (Par) loop - if Nkind (Par) = N_Pragma then - Nam := Pragma_Name (Par); + -- Sanitize the variable - -- Pragma Initial_Condition appears in its alternative from as - -- Check (Initial_Condition, ...). + if Var_Id = Any_Id then + return False; - if Nam = Name_Check then - Args := Pragma_Argument_Associations (Par); + elsif Ekind (Var_Id) /= E_Variable then + return False; + end if; - -- Pragma Check should have at least two arguments + Var_Decl := Declaration_Node (Var_Id); - pragma Assert (Present (Args)); + if Nkind (Var_Decl) /= N_Object_Declaration then + return False; + end if; - return - Chars (Expression (First (Args))) = Name_Initial_Condition; + N_Unit_Id := Find_Top_Unit (N); + N_Unit := Unit_Declaration_Node (N_Unit_Id); - -- Direct match + Var_Unit_Id := Find_Top_Unit (Var_Decl); + Var_Unit := Unit_Declaration_Node (Var_Unit_Id); - elsif Nam = Name_Initial_Condition then - return True; + -- To qualify, the assignment must meet the following prerequisites: - -- Since pragmas are never nested within other pragmas, stop - -- the traversal. + return + Comes_From_Source (Var_Id) - else - return False; - end if; + -- The variable must be susceptible to warnings + + and then not Has_Warnings_Off (Var_Id) + + -- The variable must be declared in the spec of compilation unit U + + and then Nkind (Var_Unit) = N_Package_Declaration + + -- Performance note: parent traversal + + and then Find_Enclosing_Level (Var_Decl) = Package_Spec + + -- The variable must lack initialization + + and then not Has_Init_Expression (Var_Decl) + and then No (Expression (Var_Decl)) + + -- The assignment must occur in the body of compilation unit U + + and then Nkind (N_Unit) = N_Package_Body + and then Present (Corresponding_Body (Var_Unit)) + and then Corresponding_Body (Var_Unit) = N_Unit_Id + + -- The package spec must lack pragma Elaborate_Body + + and then not Has_Pragma_Elaborate_Body (Var_Unit_Id); + end Is_Suitable_Variable_Assignment; + + ------------------------------------ + -- Is_Suitable_Variable_Reference -- + ------------------------------------ + + function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean is + function In_Pragma (Nod : Node_Id) return Boolean; + -- Determine whether arbitrary node N appears within a pragma + + --------------- + -- In_Pragma -- + --------------- + + function In_Pragma (Nod : Node_Id) return Boolean is + Par : Node_Id; + + begin + Par := Nod; + while Present (Par) loop + if Nkind (Par) = N_Pragma then + return True; -- Prevent the search from going too far @@ -2184,1667 +5201,2947 @@ package body Sem_Elab is end if; Par := Parent (Par); - - -- If assertions are not enabled, the check pragma is rewritten - -- as an if_statement in sem_prag, to generate various warnings - -- on boolean expressions. Retrieve the original pragma. - - if Nkind (Original_Node (Par)) = N_Pragma then - Par := Original_Node (Par); - end if; end loop; return False; - end Within_Initial_Condition; + end In_Pragma; -- Local variables - Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; + Prag : Node_Id; + Var_Id : Entity_Id; - -- Start of processing for Check_Internal_Call + -- Start of processing for Is_Suitable_Variable_Reference begin - -- For P'Access, we want to warn if the -gnatw.f switch is set, and the - -- node comes from source. + -- Attributes and operator sumbols are not considered to be suitable + -- references to variables even though they are part of predicate + -- Is_Entity_Name. - if Nkind (N) = N_Attribute_Reference - and then ((not Warn_On_Elab_Access and then not Debug_Flag_Dot_O) - or else not Comes_From_Source (N)) - then - return; + if not Nkind_In (N, N_Expanded_Name, N_Identifier) then + return False; - -- If not function or procedure call, instantiation, or 'Access, then - -- ignore call (this happens in some error cases and rewriting cases). + -- Internally generated references are assumed to be ABE safe - elsif not Nkind_In (N, N_Attribute_Reference, - N_Function_Call, - N_Procedure_Call_Statement) - and then not Inst_Case - then - return; + elsif not Comes_From_Source (N) then + return False; + end if; - -- Nothing to do if this is a call or instantiation that has already - -- been found to be a sure ABE. + -- Sanitize the reference - elsif Nkind (N) /= N_Attribute_Reference and then ABE_Is_Certain (N) then - return; + Var_Id := Entity (N); - -- Nothing to do if errors already detected (avoid cascaded errors) + if No (Var_Id) then + return False; - elsif Serious_Errors_Detected /= 0 then - return; + elsif Var_Id = Any_Id then + return False; - -- Nothing to do if not in full analysis mode + elsif Ekind (Var_Id) /= E_Variable then + return False; + end if; - elsif not Full_Analysis then - return; + Prag := SPARK_Pragma (Var_Id); - -- Nothing to do if analyzing in special spec-expression mode, since the - -- call is not actually being made at this time. + -- To qualify, the reference must meet the following prerequisites: - elsif In_Spec_Expression then - return; + return + Comes_From_Source (Var_Id) - -- Nothing to do for call to intrinsic subprogram + -- Both the variable and the reference must appear in SPARK_Mode On + -- regions because this scenario falls under the SPARK rules. - elsif Is_Intrinsic_Subprogram (E) then - return; + and then Present (Prag) + and then Get_SPARK_Mode_From_Annotation (Prag) = On + and then Is_SPARK_Mode_On_Node (N) - -- Nothing to do if call is within a generic unit + -- The reference must not be considered when it appears in a pragma. + -- If the pragma has run-time semantics, then the reference will be + -- reconsidered once the pragma is expanded. - elsif Inside_A_Generic then - return; + -- Performance note: parent traversal - -- Nothing to do when the call appears within pragma Initial_Condition. - -- The pragma is part of the elaboration statements of a package body - -- and may only call external subprograms or subprograms whose body is - -- already available. + and then not In_Pragma (N); + end Is_Suitable_Variable_Reference; - elsif Within_Initial_Condition (N) then - return; + ------------------- + -- Is_Task_Entry -- + ------------------- + + function Is_Task_Entry (Id : Entity_Id) return Boolean is + begin + -- To qualify, the entity must denote an entry defined in a task type + + return + Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id))); + end Is_Task_Entry; + + ------------------------ + -- Is_Up_Level_Target -- + ------------------------ + + function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean is + Root : constant Node_Id := Root_Scenario; + + begin + -- The root appears within the declaratons of a block statement, entry + -- body, subprogram body, or task body ignoring enclosing packages. The + -- root is always within the main unit. An up level target is a notion + -- applicable only to the static model because scenarios are reached by + -- means of graph traversal started from a fixed declarative or library + -- level. + + -- Performance note: parent traversal + + if Static_Elaboration_Checks + and then Find_Enclosing_Level (Root) = Declaration_Level + then + -- The target is within the main unit. It acts as an up level target + -- when it appears within a context which encloses the root. + + -- package body Main_Unit is + -- function Func ...; -- target + + -- procedure Proc is + -- X : ... := Func; -- root scenario + + if In_Extended_Main_Code_Unit (Target_Decl) then + + -- Performance note: parent traversal + + return not In_Same_Context (Root, Target_Decl, Nested_OK => True); + + -- Otherwise the target is external to the main unit which makes it + -- an up level target. + + else + return True; + end if; end if; - -- Delay this call if we are still delaying calls + return False; + end Is_Up_Level_Target; - if Delaying_Elab_Checks then - Delay_Check.Append - ((N => N, - E => E, - Orig_Ent => Orig_Ent, - Curscop => Current_Scope, - Outer_Scope => Outer_Scope, - From_Elab_Code => From_Elab_Code, - In_Task_Activation => In_Task_Activation, - From_SPARK_Code => SPARK_Mode = On)); - return; + ------------------------------- + -- Kill_Elaboration_Scenario -- + ------------------------------- - -- Otherwise, call phase 2 continuation right now + procedure Kill_Elaboration_Scenario (N : Node_Id) is + begin + -- Eliminate the scenario by suppressing the generation of conditional + -- ABE checks or guaranteed ABE failures. Note that other diagnostics + -- must be carried out ignoring the fact that the scenario is within + -- dead code. - else - Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent); + if Is_Scenario (N) then + Set_Is_Elaboration_Checks_OK_Node (N, False); end if; - end Check_Internal_Call; + end Kill_Elaboration_Scenario; ---------------------------------- - -- Check_Internal_Call_Continue -- + -- Meet_Elaboration_Requirement -- ---------------------------------- - procedure Check_Internal_Call_Continue - (N : Node_Id; - E : Entity_Id; - Outer_Scope : Entity_Id; - Orig_Ent : Entity_Id) + procedure Meet_Elaboration_Requirement + (N : Node_Id; + Target_Id : Entity_Id; + Req_Nam : Name_Id) is - function Find_Elab_Reference (N : Node_Id) return Traverse_Result; - -- Function applied to each node as we traverse the body. Checks for - -- call or entity reference that needs checking, and if so checks it. - -- Always returns OK, so entire tree is traversed, except that as - -- described below subprogram bodies are skipped for now. + Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); + Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id); + + function Find_Preelaboration_Pragma + (Prag_Nam : Name_Id) return Node_Id; + pragma Inline (Find_Preelaboration_Pragma); + -- Traverse the visible declarations of unit Unit_Id and locate a source + -- preelaboration-related pragma with name Prag_Nam. + + procedure Info_Requirement_Met (Prag : Node_Id); + pragma Inline (Info_Requirement_Met); + -- Output information concerning pragma Prag which meets requirement + -- Req_Nam. + + procedure Info_Scenario; + pragma Inline (Info_Scenario); + -- Output information concerning scenario N + + -------------------------------- + -- Find_Preelaboration_Pragma -- + -------------------------------- + + function Find_Preelaboration_Pragma + (Prag_Nam : Name_Id) return Node_Id + is + Spec : constant Node_Id := Parent (Unit_Id); + Decl : Node_Id; - procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference); - -- Traverse procedure using above Find_Elab_Reference function + begin + -- A preelaboration-related pragma comes from source and appears at + -- the top of the visible declarations of a package. - ------------------------- - -- Find_Elab_Reference -- - ------------------------- + if Nkind (Spec) = N_Package_Specification then + Decl := First (Visible_Declarations (Spec)); + while Present (Decl) loop + if Comes_From_Source (Decl) then + if Nkind (Decl) = N_Pragma + and then Pragma_Name (Decl) = Prag_Nam + then + return Decl; + + -- Otherwise the construct terminates the region where the + -- preelabortion-related pragma may appear. + + else + exit; + end if; + end if; + + Next (Decl); + end loop; + end if; + + return Empty; + end Find_Preelaboration_Pragma; - function Find_Elab_Reference (N : Node_Id) return Traverse_Result is - Actual : Node_Id; + -------------------------- + -- Info_Requirement_Met -- + -------------------------- + procedure Info_Requirement_Met (Prag : Node_Id) is begin - -- If user has specified that there are no entry calls in elaboration - -- code, do not trace past an accept statement, because the rendez- - -- vous will happen after elaboration. + pragma Assert (Present (Prag)); - if Nkind_In (Original_Node (N), N_Accept_Statement, - N_Selective_Accept) - and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code) - then - return Abandon; + Error_Msg_Name_1 := Req_Nam; + Error_Msg_Sloc := Sloc (Prag); + Error_Msg_NE + ("\\% requirement for unit & met by pragma #", N, Unit_Id); + end Info_Requirement_Met; - -- If we have a function call, check it + ------------------- + -- Info_Scenario -- + ------------------- - elsif Nkind (N) = N_Function_Call then - Check_Elab_Call (N, Outer_Scope); - return OK; + procedure Info_Scenario is + begin + if Is_Suitable_Call (N) then + Info_Call + (Call => N, + Target_Id => Target_Id, + Info_Msg => False, + In_SPARK => True); + + elsif Is_Suitable_Instantiation (N) then + Info_Instantiation + (Inst => N, + Gen_Id => Target_Id, + Info_Msg => False, + In_SPARK => True); + + elsif Is_Suitable_Variable_Reference (N) then + Info_Variable_Reference + (Ref => N, + Var_Id => Target_Id, + Info_Msg => False, + In_SPARK => True); + + -- No other scenario may impose a requirement on the context of the + -- main unit. - -- If we have a procedure call, check the call, and also check - -- arguments that are assignments (OUT or IN OUT mode formals). + else + pragma Assert (False); + null; + end if; + end Info_Scenario; - elsif Nkind (N) = N_Procedure_Call_Statement then - Check_Elab_Call (N, Outer_Scope, In_Init_Proc => Is_Init_Proc (E)); + -- Local variables - Actual := First_Actual (N); - while Present (Actual) loop - if Known_To_Be_Assigned (Actual) then - Check_Elab_Assign (Actual); - end if; + Elab_Attrs : Elaboration_Attributes; + Elab_Nam : Name_Id; + Req_Met : Boolean; - Next_Actual (Actual); - end loop; + -- Start of processing for Meet_Elaboration_Requirement - return OK; + begin + pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All)); - -- If we have an access attribute for a subprogram, check it. - -- Suppress this behavior under debug flag. + -- Assume that the requirement has not been met - elsif not Debug_Flag_Dot_UU - and then Nkind (N) = N_Attribute_Reference - and then Nam_In (Attribute_Name (N), Name_Access, - Name_Unrestricted_Access) - and then Is_Entity_Name (Prefix (N)) - and then Is_Subprogram (Entity (Prefix (N))) - then - Check_Elab_Call (N, Outer_Scope); - return OK; + Req_Met := False; - -- In SPARK mode, if we have an entity reference to a variable, then - -- check it. For now we consider any reference. + -- If the target is within the main unit, either at the source level or + -- through an instantiation, then there is no real requirement to meet + -- because the main unit cannot force its own elaboration by means of an + -- Elaborate[_All] pragma. Treat this case as valid coverage. - elsif SPARK_Mode = On - and then Nkind (N) in N_Has_Entity - and then Present (Entity (N)) - and then Ekind (Entity (N)) = E_Variable - then - Check_Elab_Call (N, Outer_Scope); - return OK; + if In_Extended_Main_Code_Unit (Target_Id) then + Req_Met := True; - -- If we have a generic instantiation, check it + -- Otherwise the target resides in an external unit - elsif Nkind (N) in N_Generic_Instantiation then - Check_Elab_Instantiation (N, Outer_Scope); - return OK; + -- The requirement is met when the target comes from an internal unit + -- because such a unit is elaborated prior to a non-internal unit. - -- Skip subprogram bodies that come from source (wait for call to - -- analyze these). The reason for the come from source test is to - -- avoid catching task bodies. + elsif In_Internal_Unit (Unit_Id) + and then not In_Internal_Unit (Main_Id) + then + Req_Met := True; - -- For task bodies, we should really avoid these too, waiting for the - -- task activation, but that's too much trouble to catch for now, so - -- we go in unconditionally. This is not so terrible, it means the - -- error backtrace is not quite complete, and we are too eager to - -- scan bodies of tasks that are unused, but this is hardly very - -- significant. + -- The requirement is met when the target comes from a preelaborated + -- unit. This portion must parallel predicate Is_Preelaborated_Unit. - elsif Nkind (N) = N_Subprogram_Body - and then Comes_From_Source (N) - then - return Skip; + elsif Is_Preelaborated_Unit (Unit_Id) then + Req_Met := True; + + -- Output extra information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas. + + if Elab_Info_Messages then + if Is_Preelaborated (Unit_Id) then + Elab_Nam := Name_Preelaborate; + + elsif Is_Pure (Unit_Id) then + Elab_Nam := Name_Pure; + + elsif Is_Remote_Call_Interface (Unit_Id) then + Elab_Nam := Name_Remote_Call_Interface; + + elsif Is_Remote_Types (Unit_Id) then + Elab_Nam := Name_Remote_Types; + + else + pragma Assert (Is_Shared_Passive (Unit_Id)); + Elab_Nam := Name_Shared_Passive; + end if; + + Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam)); + end if; + + -- Determine whether the context of the main unit has a pragma strong + -- enough to meet the requirement. - elsif Nkind (N) = N_Assignment_Statement - and then Comes_From_Source (N) + else + Elab_Attrs := Elaboration_Context.Get (Unit_Id); + + -- The pragma must be either Elaborate_All or be as strong as the + -- requirement. + + if Present (Elab_Attrs.Source_Pragma) + and then Nam_In (Pragma_Name (Elab_Attrs.Source_Pragma), + Name_Elaborate_All, + Req_Nam) then - Check_Elab_Assign (Name (N)); - return OK; + Req_Met := True; - else - return OK; + -- Output extra information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas. + + if Elab_Info_Messages then + Info_Requirement_Met (Elab_Attrs.Source_Pragma); + end if; end if; - end Find_Elab_Reference; + end if; + + -- The requirement was not met by the context of the main unit, issue an + -- error. - Inst_Case : constant Boolean := Is_Generic_Unit (E); - Loc : constant Source_Ptr := Sloc (N); + if not Req_Met then + Info_Scenario; - Ebody : Entity_Id; - Sbody : Node_Id; + Error_Msg_Name_1 := Req_Nam; + Error_Msg_Node_2 := Unit_Id; + Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id); + + Output_Active_Scenarios (N); + end if; + end Meet_Elaboration_Requirement; + + ---------------------- + -- Non_Private_View -- + ---------------------- - -- Start of processing for Check_Internal_Call_Continue + function Non_Private_View (Typ : Entity_Id) return Entity_Id is + Result : Entity_Id; begin - -- Save outer level call if at outer level + Result := Typ; - if Elab_Call.Last = 0 then - Outer_Level_Sloc := Loc; + if Is_Private_Type (Result) and then Present (Full_View (Result)) then + Result := Full_View (Result); end if; - -- If the call is to a function that renames a literal, no check needed + return Result; + end Non_Private_View; - if Ekind (E) = E_Enumeration_Literal then - return; - end if; + ----------------------------- + -- Output_Active_Scenarios -- + ----------------------------- - -- Register the subprogram as examined within this particular context. - -- This ensures that calls to the same subprogram but in different - -- contexts receive warnings and checks of their own since the calls - -- may be reached through different flow paths. + procedure Output_Active_Scenarios (Error_Nod : Node_Id) is + procedure Output_Access (N : Node_Id); + -- Emit a specific diagnostic message for 'Access denote by N - Elab_Visited.Append ((Subp_Id => E, Context => Parent (N))); + procedure Output_Activation_Call (N : Node_Id); + -- Emit a specific diagnostic message for task activation N - Sbody := Unit_Declaration_Node (E); + procedure Output_Call (N : Node_Id; Target_Id : Entity_Id); + -- Emit a specific diagnostic message for call N which invokes target + -- Target_Id. - if not Nkind_In (Sbody, N_Subprogram_Body, N_Package_Body) then - Ebody := Corresponding_Body (Sbody); + procedure Output_Header; + -- Emit a specific diagnostic message for the unit of the root scenario - if No (Ebody) then - return; - else - Sbody := Unit_Declaration_Node (Ebody); - end if; - end if; + procedure Output_Instantiation (N : Node_Id); + -- Emit a specific diagnostic message for instantiation N - -- If the body appears after the outer level call or instantiation then - -- we have an error case handled below. + procedure Output_Variable_Assignment (N : Node_Id); + -- Emit a specific diagnostic message for assignment statement N - if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody)) - and then not In_Task_Activation - then - null; + procedure Output_Variable_Reference (N : Node_Id); + -- Emit a specific diagnostic message for variable reference N + + ------------------- + -- Output_Access -- + ------------------- - -- If we have the instantiation case we are done, since we now know that - -- the body of the generic appeared earlier. + procedure Output_Access (N : Node_Id) is + Subp_Id : constant Entity_Id := Entity (Prefix (N)); - elsif Inst_Case then - return; + begin + Error_Msg_Name_1 := Attribute_Name (N); + Error_Msg_Sloc := Sloc (N); + Error_Msg_NE ("\\ % of & taken #", Error_Nod, Subp_Id); + end Output_Access; - -- Otherwise we have a call, so we trace through the called body to see - -- if it has any problems. + ---------------------------- + -- Output_Activation_Call -- + ---------------------------- - else - pragma Assert (Nkind (Sbody) = N_Subprogram_Body); - - Elab_Call.Append ((Cloc => Loc, Ent => E)); - - if Debug_Flag_LL then - Write_Str ("Elab_Call.Last = "); - Write_Int (Int (Elab_Call.Last)); - Write_Str (" Ent = "); - Write_Name (Chars (E)); - Write_Str (" at "); - Write_Location (Sloc (N)); - Write_Eol; - end if; + procedure Output_Activation_Call (N : Node_Id) is + function Find_Activator (Call : Node_Id) return Entity_Id; + -- Find the nearest enclosing construct which houses call Call - -- Now traverse declarations and statements of subprogram body. Note - -- that we cannot simply Traverse (Sbody), since traverse does not - -- normally visit subprogram bodies. + -------------------- + -- Find_Activator -- + -------------------- + + function Find_Activator (Call : Node_Id) return Entity_Id is + Par : Node_Id; - declare - Decl : Node_Id; begin - Decl := First (Declarations (Sbody)); - while Present (Decl) loop - Traverse (Decl); - Next (Decl); + -- Climb the parent chain looking for a package [body] or a + -- construct with a statement sequence. + + Par := Parent (Call); + while Present (Par) loop + if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then + return Defining_Entity (Par); + + elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then + return Defining_Entity (Parent (Par)); + end if; + + Par := Parent (Par); end loop; - end; - Traverse (Handled_Statement_Sequence (Sbody)); + return Empty; + end Find_Activator; - Elab_Call.Decrement_Last; - return; - end if; + -- Local variables - -- Here is the case of calling a subprogram where the body has not yet - -- been encountered. A warning message is needed, except if this is the - -- case of appearing within an aspect specification that results in - -- a check call, we do not really have such a situation, so no warning - -- is needed (e.g. the case of a precondition, where the call appears - -- textually before the body, but in actual fact is moved to the - -- appropriate subprogram body and so does not need a check). + Activator : constant Entity_Id := Find_Activator (N); - declare - P : Node_Id; - O : Node_Id; + -- Start of processing for Output_Activation_Call begin - P := Parent (N); - loop - -- Keep looking at parents if we are still in the subexpression + pragma Assert (Present (Activator)); - if Nkind (P) in N_Subexpr then - P := Parent (P); + Error_Msg_NE ("\\ local tasks of & activated", Error_Nod, Activator); + end Output_Activation_Call; - -- Here P is the parent of the expression, check for special case + ----------------- + -- Output_Call -- + ----------------- - else - O := Original_Node (P); + procedure Output_Call (N : Node_Id; Target_Id : Entity_Id) is + procedure Output_Accept_Alternative; + pragma Inline (Output_Accept_Alternative); + -- Emit a specific diagnostic message concerning an accept + -- alternative. - -- Definitely not the special case if orig node is not a pragma + procedure Output_Call (Kind : String); + pragma Inline (Output_Call); + -- Emit a specific diagnostic message concerning a call of kind Kind - exit when Nkind (O) /= N_Pragma; + procedure Output_Type_Actions (Action : String); + pragma Inline (Output_Type_Actions); + -- Emit a specific diagnostic message concerning action Action of a + -- type. - -- Check we have an If statement or a null statement (happens - -- when the If has been expanded to be True). + procedure Output_Verification_Call + (Pred : String; + Id : Entity_Id; + Id_Kind : String); + pragma Inline (Output_Verification_Call); + -- Emit a specific diagnostic message concerning the verification of + -- predicate Pred applied to related entity Id with kind Id_Kind. - exit when not Nkind_In (P, N_If_Statement, N_Null_Statement); + ------------------------------- + -- Output_Accept_Alternative -- + ------------------------------- - -- Our special case will be indicated either by the pragma - -- coming from an aspect ... + procedure Output_Accept_Alternative is + Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id); - if Present (Corresponding_Aspect (O)) then - return; + begin + pragma Assert (Present (Entry_Id)); - -- Or, in the case of an initial condition, specifically by a - -- Check pragma specifying an Initial_Condition check. + Error_Msg_NE ("\\ entry & selected #", Error_Nod, Entry_Id); + end Output_Accept_Alternative; - elsif Pragma_Name (O) = Name_Check - and then - Chars - (Expression (First (Pragma_Argument_Associations (O)))) = - Name_Initial_Condition - then - return; + ----------------- + -- Output_Call -- + ----------------- - -- For anything else, we have an error + procedure Output_Call (Kind : String) is + begin + Error_Msg_NE ("\\ " & Kind & " & called #", Error_Nod, Target_Id); + end Output_Call; - else - exit; - end if; - end if; - end loop; - end; + ------------------------- + -- Output_Type_Actions -- + ------------------------- - -- Not that special case, warning and dynamic check is required + procedure Output_Type_Actions (Action : String) is + Typ : constant Entity_Id := First_Formal_Type (Target_Id); - -- If we have nothing in the call stack, then this is at the outer - -- level, and the ABE is bound to occur, unless it's a 'Access, or - -- it's a renaming. + begin + pragma Assert (Present (Typ)); - if Elab_Call.Last = 0 then - Error_Msg_Warn := SPARK_Mode /= On; + Error_Msg_NE + ("\\ " & Action & " actions for type & #", Error_Nod, Typ); + end Output_Type_Actions; + + ------------------------------ + -- Output_Verification_Call -- + ------------------------------ + + procedure Output_Verification_Call + (Pred : String; + Id : Entity_Id; + Id_Kind : String) + is + begin + pragma Assert (Present (Id)); - declare - Insert_Check : Boolean := True; - -- This flag is set to True if an elaboration check should be - -- inserted. + Error_Msg_NE + ("\\ " & Pred & " of " & Id_Kind & " & verified #", + Error_Nod, Id); + end Output_Verification_Call; - begin - if In_Task_Activation then - Insert_Check := False; + -- Start of processing for Output_Call - elsif Inst_Case then - Error_Msg_NE - ("cannot instantiate& before body seen<<", N, Orig_Ent); + begin + Error_Msg_Sloc := Sloc (N); - elsif Nkind (N) = N_Attribute_Reference then - Error_Msg_NE - ("Access attribute of & before body seen<<", N, Orig_Ent); - Error_Msg_N ("\possible Program_Error on later references<", N); - Insert_Check := False; + -- Accept alternative - elsif Nkind (Unit_Declaration_Node (Orig_Ent)) /= - N_Subprogram_Renaming_Declaration - then - Error_Msg_NE - ("cannot call& before body seen<<", N, Orig_Ent); + if Is_Accept_Alternative_Proc (Target_Id) then + Output_Accept_Alternative; - elsif not Is_Generic_Actual_Subprogram (Orig_Ent) then - Insert_Check := False; - end if; + -- Adjustment - if Insert_Check then - Error_Msg_N ("\Program_Error [<<", N); - Insert_Elab_Check (N); - end if; - end; + elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then + Output_Type_Actions ("adjustment"); - -- Call is not at outer level + -- Default_Initial_Condition - else - -- Do not generate elaboration checks in GNATprove mode because the - -- elaboration counter and the check are both forms of expansion. + elsif Is_Default_Initial_Condition_Proc (Target_Id) then + Output_Verification_Call + (Pred => "Default_Initial_Condition", + Id => First_Formal_Type (Target_Id), + Id_Kind => "type"); + + -- Entries - if GNATprove_Mode then + elsif Is_Protected_Entry (Target_Id) then + Output_Call ("entry"); + + -- Task entry calls are never processed because the entry being + -- invoked does not have a corresponding "body", it has a select. A + -- task entry call appears in the stack of active scenarios for the + -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and + -- nothing more. + + elsif Is_Task_Entry (Target_Id) then null; - -- Generate an elaboration check - - elsif not Elaboration_Checks_Suppressed (E) then - Set_Elaboration_Entity_Required (E); - - -- Create a declaration of the elaboration entity, and insert it - -- prior to the subprogram or the generic unit, within the same - -- scope. Since the subprogram may be overloaded, create a unique - -- entity. - - if No (Elaboration_Entity (E)) then - declare - Loce : constant Source_Ptr := Sloc (E); - Ent : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_External_Name (Chars (E), 'E', -1)); - - begin - Set_Elaboration_Entity (E, Ent); - Push_Scope (Scope (E)); - - Insert_Action (Declaration_Node (E), - Make_Object_Declaration (Loce, - Defining_Identifier => Ent, - Object_Definition => - New_Occurrence_Of (Standard_Short_Integer, Loce), - Expression => - Make_Integer_Literal (Loc, Uint_0))); - - -- Set elaboration flag at the point of the body - - Set_Elaboration_Flag (Sbody, E); - - -- Kill current value indication. This is necessary because - -- the tests of this flag are inserted out of sequence and - -- must not pick up bogus indications of the wrong constant - -- value. Also, this is never a true constant, since one way - -- or another, it gets reset. - - Set_Current_Value (Ent, Empty); - Set_Last_Assignment (Ent, Empty); - Set_Is_True_Constant (Ent, False); - Pop_Scope; - end; - end if; + -- Finalization - -- Generate: - -- if Enn = 0 then - -- raise Program_Error with "access before elaboration"; - -- end if; + elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then + Output_Type_Actions ("finalization"); - Insert_Elab_Check (N, - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Elaborated, - Prefix => New_Occurrence_Of (E, Loc))); - end if; + -- Calls to _Finalizer procedures must not appear in the output + -- because this creates confusing noise. - -- Generate the warning + elsif Is_Finalizer_Proc (Target_Id) then + null; + + -- Initial_Condition - if not Suppress_Elaboration_Warnings (E) - and then not Elaboration_Checks_Suppressed (E) + elsif Is_Initial_Condition_Proc (Target_Id) then + Output_Verification_Call + (Pred => "Initial_Condition", + Id => Find_Enclosing_Scope (N), + Id_Kind => "package"); - -- Suppress this warning if we have a function call that occurred - -- within an assertion expression, since we can get false warnings - -- in this case, due to the out of order handling in this case. + -- Initialization - and then - (Nkind (Original_Node (N)) /= N_Function_Call - or else not In_Assertion_Expression_Pragma (Original_Node (N))) + elsif Is_Init_Proc (Target_Id) + or else Is_TSS (Target_Id, TSS_Deep_Initialize) then - Error_Msg_Warn := SPARK_Mode /= On; + Output_Type_Actions ("initialization"); - if Inst_Case then - Error_Msg_NE - ("instantiation of& may occur before body is seen<l<", - N, Orig_Ent); - else - -- A rather specific check. For Finalize/Adjust/Initialize, if - -- the type has Warnings_Off set, suppress the warning. + -- Invariant - if Nam_In (Chars (E), Name_Adjust, - Name_Finalize, - Name_Initialize) - and then Present (First_Formal (E)) - then - declare - T : constant Entity_Id := Etype (First_Formal (E)); - begin - if Is_Controlled (T) then - if Warnings_Off (T) - or else (Ekind (T) = E_Private_Type - and then Warnings_Off (Full_View (T))) - then - goto Output; - end if; - end if; - end; - end if; + elsif Is_Invariant_Proc (Target_Id) then + Output_Verification_Call + (Pred => "invariants", + Id => First_Formal_Type (Target_Id), + Id_Kind => "type"); - -- Go ahead and give warning if not this special case + -- Partial invariant calls must not appear in the output because this + -- creates confusing noise. Note that a partial invariant is always + -- invoked by the "full" invariant which is already placed on the + -- stack. - Error_Msg_NE - ("call to& may occur before body is seen<l<", N, Orig_Ent); - end if; + elsif Is_Partial_Invariant_Proc (Target_Id) then + null; - Error_Msg_N ("\Program_Error ]<l<", N); + -- _Postconditions - -- There is no need to query the elaboration warning message flags - -- because the main message is an error, not a warning, therefore - -- all the clarification messages produces by Output_Calls must be - -- emitted unconditionally. + elsif Is_Postconditions_Proc (Target_Id) then + Output_Verification_Call + (Pred => "postconditions", + Id => Find_Enclosing_Scope (N), + Id_Kind => "subprogram"); - <<Output>> + -- Subprograms must come last because some of the previous cases fall + -- under this category. - Output_Calls (N, Check_Elab_Flag => False); - end if; - end if; - end Check_Internal_Call_Continue; + elsif Ekind (Target_Id) = E_Function then + Output_Call ("function"); - --------------------------- - -- Check_Task_Activation -- - --------------------------- + elsif Ekind (Target_Id) = E_Procedure then + Output_Call ("procedure"); - procedure Check_Task_Activation (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Inter_Procs : constant Elist_Id := New_Elmt_List; - Intra_Procs : constant Elist_Id := New_Elmt_List; - Ent : Entity_Id; - P : Entity_Id; - Task_Scope : Entity_Id; - Cunit_SC : Boolean := False; - Decl : Node_Id; - Elmt : Elmt_Id; - Enclosing : Entity_Id; - - procedure Add_Task_Proc (Typ : Entity_Id); - -- Add to Task_Procs the task body procedure(s) of task types in Typ. - -- For record types, this procedure recurses over component types. - - procedure Collect_Tasks (Decls : List_Id); - -- Collect the types of the tasks that are to be activated in the given - -- list of declarations, in order to perform elaboration checks on the - -- corresponding task procedures that are called implicitly here. - - function Outer_Unit (E : Entity_Id) return Entity_Id; - -- find enclosing compilation unit of Entity, ignoring subunits, or - -- else enclosing subprogram. If E is not a package, there is no need - -- for inter-unit elaboration checks. + else + pragma Assert (False); + null; + end if; + end Output_Call; ------------------- - -- Add_Task_Proc -- + -- Output_Header -- ------------------- - procedure Add_Task_Proc (Typ : Entity_Id) is - Comp : Entity_Id; - Proc : Entity_Id := Empty; + procedure Output_Header is + Unit_Id : constant Entity_Id := Find_Top_Unit (Root_Scenario); begin - if Is_Task_Type (Typ) then - Proc := Get_Task_Body_Procedure (Typ); + if Ekind (Unit_Id) = E_Package then + Error_Msg_NE ("\\ spec of unit & elaborated", Error_Nod, Unit_Id); - elsif Is_Array_Type (Typ) - and then Has_Task (Base_Type (Typ)) - then - Add_Task_Proc (Component_Type (Typ)); + elsif Ekind (Unit_Id) = E_Package_Body then + Error_Msg_NE ("\\ body of unit & elaborated", Error_Nod, Unit_Id); - elsif Is_Record_Type (Typ) - and then Has_Task (Base_Type (Typ)) - then - Comp := First_Component (Typ); - while Present (Comp) loop - Add_Task_Proc (Etype (Comp)); - Comp := Next_Component (Comp); - end loop; + else + Error_Msg_NE ("\\ in body of unit &", Error_Nod, Unit_Id); end if; + end Output_Header; - -- If the task type is another unit, we will perform the usual - -- elaboration check on its enclosing unit. If the type is in the - -- same unit, we can trace the task body as for an internal call, - -- but we only need to examine other external calls, because at - -- the point the task is activated, internal subprogram bodies - -- will have been elaborated already. We keep separate lists for - -- each kind of task. + -------------------------- + -- Output_Instantiation -- + -------------------------- - -- Skip this test if errors have occurred, since in this case - -- we can get false indications. + procedure Output_Instantiation (N : Node_Id) is + procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String); + pragma Inline (Output_Instantiation); + -- Emit a specific diagnostic message concerning an instantiation of + -- generic unit Gen_Id. Kind denotes the kind of the instantiation. - if Serious_Errors_Detected /= 0 then - return; + -------------------------- + -- Output_Instantiation -- + -------------------------- + + procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String) is + begin + Error_Msg_NE + ("\\ " & Kind & " & instantiated as & #", Error_Nod, Gen_Id); + end Output_Instantiation; + + -- Local variables + + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Inst_Id : Entity_Id; + Gen_Id : Entity_Id; + + -- Start of processing for Output_Instantiation + + begin + Extract_Instantiation_Attributes + (Exp_Inst => N, + Inst => Inst, + Inst_Id => Inst_Id, + Gen_Id => Gen_Id, + Attrs => Inst_Attrs); + + Error_Msg_Node_2 := Inst_Id; + Error_Msg_Sloc := Sloc (Inst); + + if Nkind (Inst) = N_Function_Instantiation then + Output_Instantiation (Gen_Id, "function"); + + elsif Nkind (Inst) = N_Package_Instantiation then + Output_Instantiation (Gen_Id, "package"); + + elsif Nkind (Inst) = N_Procedure_Instantiation then + Output_Instantiation (Gen_Id, "procedure"); + + else + pragma Assert (False); + null; end if; + end Output_Instantiation; - if Present (Proc) then - if Outer_Unit (Scope (Proc)) = Enclosing then + -------------------------------- + -- Output_Variable_Assignment -- + -------------------------------- - if No (Corresponding_Body (Unit_Declaration_Node (Proc))) - and then - (not Is_Generic_Instance (Scope (Proc)) - or else Scope (Proc) = Scope (Defining_Identifier (Decl))) - then - Error_Msg_Warn := SPARK_Mode /= On; - Error_Msg_N - ("task will be activated before elaboration of its body<<", - Decl); - Error_Msg_N ("\Program_Error [<<", Decl); - - elsif Present - (Corresponding_Body (Unit_Declaration_Node (Proc))) - then - Append_Elmt (Proc, Intra_Procs); - end if; + procedure Output_Variable_Assignment (N : Node_Id) is + Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (N)); - else - -- No need for multiple entries of the same type + begin + Error_Msg_Sloc := Sloc (N); + Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id); + end Output_Variable_Assignment; - Elmt := First_Elmt (Inter_Procs); - while Present (Elmt) loop - if Node (Elmt) = Proc then - return; - end if; + ------------------------------- + -- Output_Variable_Reference -- + ------------------------------- + + procedure Output_Variable_Reference (N : Node_Id) is + Dummy : Variable_Attributes; + Var_Id : Entity_Id; + + begin + Extract_Variable_Reference_Attributes + (Ref => N, + Var_Id => Var_Id, + Attrs => Dummy); + + Error_Msg_Sloc := Sloc (N); + Error_Msg_NE ("\\ variable & referenced #", Error_Nod, Var_Id); + end Output_Variable_Reference; + + -- Local variables + + package Stack renames Scenario_Stack; + + Dummy : Call_Attributes; + N : Node_Id; + Posted : Boolean; + Target_Id : Entity_Id; + + -- Start of processing for Output_Active_Scenarios + + begin + -- Active scenarios are emitted only when the static model is in effect + -- because there is an inherent order by which all these scenarios were + -- reached from the declaration or library level. + + if not Static_Elaboration_Checks then + return; + end if; + + Posted := False; + + for Index in Stack.First .. Stack.Last loop + N := Stack.Table (Index); + + if not Posted then + Posted := True; + Output_Header; + end if; + + -- 'Access + + if Nkind (N) = N_Attribute_Reference then + Output_Access (N); + + -- Calls - Next_Elmt (Elmt); - end loop; + elsif Is_Suitable_Call (N) then + Extract_Call_Attributes + (Call => N, + Target_Id => Target_Id, + Attrs => Dummy); - Append_Elmt (Proc, Inter_Procs); + if Is_Activation_Proc (Target_Id) then + Output_Activation_Call (N); + else + Output_Call (N, Target_Id); end if; + + -- Instantiations + + elsif Is_Suitable_Instantiation (N) then + Output_Instantiation (N); + + -- Variable assignments + + elsif Nkind (N) = N_Assignment_Statement then + Output_Variable_Assignment (N); + + -- Variable references + + elsif Is_Suitable_Variable_Reference (N) then + Output_Variable_Reference (N); + + else + pragma Assert (False); + null; end if; - end Add_Task_Proc; + end loop; + end Output_Active_Scenarios; - ------------------- - -- Collect_Tasks -- - ------------------- + ------------------------- + -- Pop_Active_Scenario -- + ------------------------- + + procedure Pop_Active_Scenario (N : Node_Id) is + Top : Node_Id renames Scenario_Stack.Table (Scenario_Stack.Last); + + begin + pragma Assert (Top = N); + Scenario_Stack.Decrement_Last; + end Pop_Active_Scenario; + + -------------------- + -- Process_Access -- + -------------------- + + procedure Process_Access (Attr : Node_Id; In_Task_Body : Boolean) is + function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id; + pragma Inline (Build_Access_Marker); + -- Create a suitable call marker which invokes target Target_Id + + ------------------------- + -- Build_Access_Marker -- + ------------------------- + + function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id is + Marker : Node_Id; - procedure Collect_Tasks (Decls : List_Id) is begin - if Present (Decls) then - Decl := First (Decls); - while Present (Decl) loop - if Nkind (Decl) = N_Object_Declaration - and then Has_Task (Etype (Defining_Identifier (Decl))) - then - Add_Task_Proc (Etype (Defining_Identifier (Decl))); - end if; + Marker := Make_Call_Marker (Sloc (Attr)); - Next (Decl); + -- Inherit relevant attributes from the attribute + + -- Performance note: parent traversal + + Set_Target (Marker, Target_Id); + Set_Is_Declaration_Level_Node + (Marker, Find_Enclosing_Level (Attr) = Declaration_Level); + Set_Is_Dispatching_Call + (Marker, False); + Set_Is_Elaboration_Checks_OK_Node + (Marker, Is_Elaboration_Checks_OK_Node (Attr)); + Set_Is_Source_Call + (Marker, Comes_From_Source (Attr)); + Set_Is_SPARK_Mode_On_Node + (Marker, Is_SPARK_Mode_On_Node (Attr)); + + -- Partially insert the call marker into the tree by setting its + -- parent pointer. + + Set_Parent (Marker, Attr); + + return Marker; + end Build_Access_Marker; + + -- Local variables + + Root : constant Node_Id := Root_Scenario; + Target_Id : constant Entity_Id := Entity (Prefix (Attr)); + + Target_Attrs : Target_Attributes; + + -- Start of processing for Process_Access + + begin + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. + + if Elab_Info_Messages then + Error_Msg_NE + ("info: access to & during elaboration", Attr, Target_Id); + end if; + + Extract_Target_Attributes + (Target_Id => Target_Id, + Attrs => Target_Attrs); + + -- Both the attribute and the corresponding body are in the same unit. + -- The corresponding body must appear prior to the root scenario which + -- started the recursive search. If this is not the case, then there is + -- a potential ABE if the access value is used to call the subprogram. + -- Emit a warning only when switch -gnatw.f (warnings on suspucious + -- 'Access) is in effect. + + if Warn_On_Elab_Access + and then Present (Target_Attrs.Body_Decl) + and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) + and then Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) + then + Error_Msg_Name_1 := Attribute_Name (Attr); + Error_Msg_NE ("??% attribute of & before body seen", Attr, Target_Id); + Error_Msg_N ("\possible Program_Error on later references", Attr); + + Output_Active_Scenarios (Attr); + end if; + + -- Treat the attribute as an immediate invocation of the target when + -- switch -gnatd.o (conservarive elaboration order for indirect calls) + -- is in effect. Note that the prior elaboration of the unit containing + -- the target is ensured processing the corresponding call marker. + + if Debug_Flag_Dot_O then + Process_Scenario + (N => Build_Access_Marker (Target_Id), + In_Task_Body => In_Task_Body); + + -- Otherwise ensure that the unit with the corresponding body is + -- elaborated prior to the main unit. + + else + Ensure_Prior_Elaboration + (N => Attr, + Unit_Id => Target_Attrs.Unit_Id, + In_Task_Body => In_Task_Body); + end if; + end Process_Access; + + ----------------------------- + -- Process_Activation_Call -- + ----------------------------- + + procedure Process_Activation_Call + (Call : Node_Id; + Call_Attrs : Call_Attributes; + In_Task_Body : Boolean) + is + procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id); + -- Perform ABE checks and diagnostics for object Obj_Id with type Typ. + -- Typ may be a task type or a composite type with at least one task + -- component. + + procedure Process_Task_Objects (List : List_Id); + -- Perform ABE checks and diagnostics for all task objects found in + -- the list List. + + ------------------------- + -- Process_Task_Object -- + ------------------------- + + procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id) is + Base_Typ : constant Entity_Id := Base_Type (Typ); + + Comp_Id : Entity_Id; + Task_Attrs : Task_Attributes; + + begin + if Is_Task_Type (Typ) then + Extract_Task_Attributes + (Typ => Base_Typ, + Attrs => Task_Attrs); + + Process_Single_Activation + (Call => Call, + Call_Attrs => Call_Attrs, + Obj_Id => Obj_Id, + Task_Attrs => Task_Attrs, + In_Task_Body => In_Task_Body); + + -- Examine the component type when the object is an array + + elsif Is_Array_Type (Typ) and then Has_Task (Base_Typ) then + Process_Task_Object (Obj_Id, Component_Type (Typ)); + + -- Examine individual component types when the object is a record + + elsif Is_Record_Type (Typ) and then Has_Task (Base_Typ) then + Comp_Id := First_Component (Typ); + while Present (Comp_Id) loop + Process_Task_Object (Obj_Id, Etype (Comp_Id)); + Next_Component (Comp_Id); end loop; end if; - end Collect_Tasks; + end Process_Task_Object; - ---------------- - -- Outer_Unit -- - ---------------- + -------------------------- + -- Process_Task_Objects -- + -------------------------- - function Outer_Unit (E : Entity_Id) return Entity_Id is - Outer : Entity_Id; + procedure Process_Task_Objects (List : List_Id) is + Item : Node_Id; + Item_Id : Entity_Id; + Item_Typ : Entity_Id; begin - Outer := E; - while Present (Outer) loop - if Elaboration_Checks_Suppressed (Outer) then - Cunit_SC := True; + -- Examine the contents of the list looking for an object declaration + -- of a task type or one that contains a task within. + + Item := First (List); + while Present (Item) loop + if Nkind (Item) = N_Object_Declaration then + Item_Id := Defining_Entity (Item); + Item_Typ := Etype (Item_Id); + + if Has_Task (Item_Typ) then + Process_Task_Object (Item_Id, Item_Typ); + end if; end if; - exit when Is_Child_Unit (Outer) - or else Scope (Outer) = Standard_Standard - or else Ekind (Outer) /= E_Package; - Outer := Scope (Outer); + Next (Item); end loop; + end Process_Task_Objects; + + -- Local variables - return Outer; - end Outer_Unit; + Context : Node_Id; + Spec : Node_Id; - -- Start of processing for Check_Task_Activation + -- Start of processing for Process_Activation_Call begin - Enclosing := Outer_Unit (Current_Scope); + -- Nothing to do when the activation is a guaranteed ABE + + if Is_Known_Guaranteed_ABE (Call) then + return; + end if; + + -- Find the proper context of the activation call where all task objects + -- being activated are declared. This is usually the immediate parent of + -- the call. + + Context := Parent (Call); + + -- In the case of package bodies, the activation call is in the handled + -- sequence of statements, but the task objects are in the declaration + -- list of the body. + + if Nkind (Context) = N_Handled_Sequence_Of_Statements + and then Nkind (Parent (Context)) = N_Package_Body + then + Context := Parent (Context); + end if; + + -- Process all task objects defined in both the spec and body when the + -- activation call precedes the "begin" of a package body. + + if Nkind (Context) = N_Package_Body then + Spec := + Specification + (Unit_Declaration_Node (Corresponding_Spec (Context))); - -- Find all tasks declared in the current unit + Process_Task_Objects (Visible_Declarations (Spec)); + Process_Task_Objects (Private_Declarations (Spec)); + Process_Task_Objects (Declarations (Context)); - if Nkind (N) = N_Package_Body then - P := Unit_Declaration_Node (Corresponding_Spec (N)); + -- Process all task objects defined in the spec when the activation call + -- appears at the end of a package spec. - Collect_Tasks (Declarations (N)); - Collect_Tasks (Visible_Declarations (Specification (P))); - Collect_Tasks (Private_Declarations (Specification (P))); + elsif Nkind (Context) = N_Package_Specification then + Process_Task_Objects (Visible_Declarations (Context)); + Process_Task_Objects (Private_Declarations (Context)); - elsif Nkind (N) = N_Package_Declaration then - Collect_Tasks (Visible_Declarations (Specification (N))); - Collect_Tasks (Private_Declarations (Specification (N))); + -- Otherwise the context of the activation is some construct with a + -- declarative part. Note that the corresponding record type of a task + -- type is controlled. Because of this, the finalization machinery must + -- relocate the task object to the handled statements of the construct + -- to perform proper finalization in case of an exception. Examine the + -- statements of the construct rather than the declarations. else - Collect_Tasks (Declarations (N)); + pragma Assert (Nkind (Context) = N_Handled_Sequence_Of_Statements); + + Process_Task_Objects (Statements (Context)); end if; + end Process_Activation_Call; + + --------------------------------------------- + -- Process_Activation_Conditional_ABE_Impl -- + --------------------------------------------- + + procedure Process_Activation_Conditional_ABE_Impl + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + In_Task_Body : Boolean) + is + Check_OK : constant Boolean := + not Is_Ignored_Ghost_Entity (Obj_Id) + and then not Task_Attrs.Ghost_Mode_Ignore + and then Is_Elaboration_Checks_OK_Id (Obj_Id) + and then Task_Attrs.Elab_Checks_OK; + -- A run-time ABE check may be installed only when the object and the + -- task type have active elaboration checks, and both are not ignored + -- Ghost constructs. - -- We only perform detailed checks in all tasks that are library level - -- entities. If the master is a subprogram or task, activation will - -- depend on the activation of the master itself. + Root : constant Node_Id := Root_Scenario; - -- Should dynamic checks be added in the more general case??? + begin + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. - if Ekind (Enclosing) /= E_Package then - return; + if Elab_Info_Messages then + Error_Msg_NE + ("info: activation of & during elaboration", Call, Obj_Id); end if; - -- For task types defined in other units, we want the unit containing - -- the task body to be elaborated before the current one. + -- Nothing to do when the activation is a guaranteed ABE - Elmt := First_Elmt (Inter_Procs); - while Present (Elmt) loop - Ent := Node (Elmt); - Task_Scope := Outer_Unit (Scope (Ent)); + if Is_Known_Guaranteed_ABE (Call) then + return; - if not Is_Compilation_Unit (Task_Scope) then - null; + -- Nothing to do when the root scenario appears at the declaration + -- level and the task is in the same unit, but outside this context. - elsif Suppress_Elaboration_Warnings (Task_Scope) - or else Elaboration_Checks_Suppressed (Task_Scope) - then - null; + -- task type Task_Typ; -- task declaration - elsif Dynamic_Elaboration_Checks then - if not Elaboration_Checks_Suppressed (Ent) - and then not Cunit_SC - and then not Restriction_Active - (No_Entry_Calls_In_Elaboration_Code) - then - -- Runtime elaboration check required. Generate check of the - -- elaboration counter for the unit containing the entity. - - Insert_Elab_Check (N, - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Spec_Entity (Task_Scope), Loc), - Attribute_Name => Name_Elaborated)); - end if; + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- T : Task_Typ; + -- begin + -- <activation call> -- activation site + -- end; + -- ... + -- end A; - else - -- Force the binder to elaborate other unit first + -- X : ... := A; -- root scenario + -- ... - if Elab_Info_Messages - and then not Suppress_Elaboration_Warnings (Ent) - and then not Elaboration_Checks_Suppressed (Ent) - and then not Suppress_Elaboration_Warnings (Task_Scope) - and then not Elaboration_Checks_Suppressed (Task_Scope) - then - Error_Msg_Node_2 := Task_Scope; - Error_Msg_NE - ("info: activation of an instance of task type & requires " - & "pragma Elaborate_All on &?$?", N, Ent); + -- task body Task_Typ is + -- ... + -- end Task_Typ; + + -- In the example above, the context of X is the declarative list of + -- Proc. The "elaboration" of X may reach the activation of T whose body + -- is defined outside of X's context. The task body is relevant only + -- when Proc is invoked, but this happens only in "normal" elaboration, + -- therefore the task body must not be considered if this is not the + -- case. + + -- Performance note: parent traversal + + elsif Is_Up_Level_Target (Task_Attrs.Task_Decl) then + return; + + -- Nothing to do when the activation is ABE-safe + + -- generic + -- package Gen is + -- task type Task_Typ; + -- end Gen; + + -- package body Gen is + -- task body Task_Typ is + -- begin + -- ... + -- end Task_Typ; + -- end Gen; + + -- with Gen; + -- procedure Main is + -- package Nested is + -- ... + -- end Nested; + + -- package body Nested is + -- package Inst is new Gen; + -- T : Inst.Task_Typ; + -- [begin] + -- <activation call> -- safe activation + -- end Nested; + -- ... + + elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then + + -- Note that the task body must still be examined for any nested + -- scenarios. + + null; + + -- The activation call and the task body are both in the main unit + + elsif Present (Task_Attrs.Body_Decl) + and then In_Extended_Main_Code_Unit (Task_Attrs.Body_Decl) + then + -- If the root scenario appears prior to the task body, then this is + -- a possible ABE with respect to the root scenario. + + -- task type Task_Typ; + + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- package Pack is + -- ... + -- end Pack; + + -- package body Pack is + -- T : Task_Typ; + -- [begin] + -- <activation call> -- activation of T + -- end Pack; + -- ... + -- end A; + + -- X : ... := A; -- root scenario + + -- task body Task_Typ is -- task body + -- ... + -- end Task_Typ; + + -- Y : ... := A; -- root scenario + + -- IMPORTANT: The activation of T is a possible ABE for X, but + -- not for Y. Intalling an unconditional ABE raise prior to the + -- activation call would be wrong as it will fail for Y as well + -- but in Y's case the activation of T is never an ABE. + + if Earlier_In_Extended_Unit (Root, Task_Attrs.Body_Decl) then + + -- ABE diagnostics are emitted only in the static model because + -- there is a well-defined order to visiting scenarios. Without + -- this order diagnostics appear jumbled and result in unwanted + -- noise. + + if Static_Elaboration_Checks then + Error_Msg_Sloc := Sloc (Call); + Error_Msg_N + ("??task & will be activated # before elaboration of its " + & "body", Obj_Id); + Error_Msg_N + ("\Program_Error may be raised at run time", Obj_Id); + + Output_Active_Scenarios (Obj_Id); end if; - Activate_Elaborate_All_Desirable (N, Task_Scope); - Set_Suppress_Elaboration_Warnings (Task_Scope); + -- Install a conditional run-time ABE check to verify that the + -- task body has been elaborated prior to the activation call. + + if Check_OK then + Install_ABE_Check + (N => Call, + Ins_Nod => Call, + Target_Id => Task_Attrs.Spec_Id, + Target_Decl => Task_Attrs.Task_Decl, + Target_Body => Task_Attrs.Body_Decl); + end if; end if; - Next_Elmt (Elmt); - end loop; + -- Otherwise the task body is not available in this compilation or it + -- resides in an external unit. Install a run-time ABE check to verify + -- that the task body has been elaborated prior to the activation call + -- when the dynamic model is in effect. - -- For tasks declared in the current unit, trace other calls within the - -- task procedure bodies, which are available. + elsif Dynamic_Elaboration_Checks and then Check_OK then + Install_ABE_Check + (N => Call, + Ins_Nod => Call, + Id => Task_Attrs.Unit_Id); + end if; - if not Debug_Flag_Dot_Y then - In_Task_Activation := True; + -- Both the activation call and task type are subject to SPARK_Mode + -- On, this triggers the SPARK rules for task activation. Compared to + -- calls and instantiations, task activation in SPARK does not require + -- the presence of Elaborate[_All] pragmas in case the task type is + -- defined outside the main unit. This is because SPARK utilizes a + -- special policy which activates all tasks after the main unit has + -- finished its elaboration. - Elmt := First_Elmt (Intra_Procs); - while Present (Elmt) loop - Ent := Node (Elmt); - Check_Internal_Call_Continue (N, Ent, Enclosing, Ent); - Next_Elmt (Elmt); - end loop; + if Call_Attrs.SPARK_Mode_On and Task_Attrs.SPARK_Mode_On then + null; - In_Task_Activation := False; + -- Otherwise the Ada rules are in effect. Ensure that the unit with the + -- task body is elaborated prior to the main unit. + + else + Ensure_Prior_Elaboration + (N => Call, + Unit_Id => Task_Attrs.Unit_Id, + In_Task_Body => In_Task_Body); end if; - end Check_Task_Activation; - ------------------------------- - -- Is_Call_Of_Generic_Formal -- - ------------------------------- + Traverse_Body (Task_Attrs.Body_Decl, In_Task_Body => True); + end Process_Activation_Conditional_ABE_Impl; + + procedure Process_Activation_Conditional_ABE is + new Process_Activation_Call (Process_Activation_Conditional_ABE_Impl); + + -------------------------------------------- + -- Process_Activation_Guaranteed_ABE_Impl -- + -------------------------------------------- + + procedure Process_Activation_Guaranteed_ABE_Impl + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + In_Task_Body : Boolean) + is + pragma Unreferenced (Call_Attrs); + pragma Unreferenced (In_Task_Body); + + Check_OK : constant Boolean := + not Is_Ignored_Ghost_Entity (Obj_Id) + and then not Task_Attrs.Ghost_Mode_Ignore + and then Is_Elaboration_Checks_OK_Id (Obj_Id) + and then Task_Attrs.Elab_Checks_OK; + -- A run-time ABE check may be installed only when the object and the + -- task type have active elaboration checks, and both are not ignored + -- Ghost constructs. - function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean is begin - return Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) + -- Nothing to do when the root scenario appears at the declaration + -- level and the task is in the same unit, but outside this context. + + -- task type Task_Typ; -- task declaration + + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- T : Task_Typ; + -- begin + -- <activation call> -- activation site + -- end; + -- ... + -- end A; + + -- X : ... := A; -- root scenario + -- ... + + -- task body Task_Typ is + -- ... + -- end Task_Typ; + + -- In the example above, the context of X is the declarative list of + -- Proc. The "elaboration" of X may reach the activation of T whose body + -- is defined outside of X's context. The task body is relevant only + -- when Proc is invoked, but this happens only in "normal" elaboration, + -- therefore the task body must not be considered if this is not the + -- case. + + -- Performance note: parent traversal + + if Is_Up_Level_Target (Task_Attrs.Task_Decl) then + return; - -- Always return False if debug flag -gnatd.G is set + -- Nothing to do when the activation is ABE-safe + + -- generic + -- package Gen is + -- task type Task_Typ; + -- end Gen; + + -- package body Gen is + -- task body Task_Typ is + -- begin + -- ... + -- end Task_Typ; + -- end Gen; + + -- with Gen; + -- procedure Main is + -- package Nested is + -- ... + -- end Nested; + + -- package body Nested is + -- package Inst is new Gen; + -- T : Inst.Task_Typ; + -- [begin] + -- <activation call> -- safe activation + -- end Nested; + -- ... + + elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then + return; - and then not Debug_Flag_Dot_GG + -- An activation call leads to a guaranteed ABE when the activation + -- call and the task appear within the same context ignoring library + -- levels, and the body of the task has not been seen yet or appears + -- after the activation call. - -- For now, we detect this by looking for the strange identifier - -- node, whose Chars reflect the name of the generic formal, but - -- the Chars of the Entity references the generic actual. + -- procedure Guaranteed_ABE is + -- task type Task_Typ; - and then Nkind (Name (N)) = N_Identifier - and then Chars (Name (N)) /= Chars (Entity (Name (N))); - end Is_Call_Of_Generic_Formal; + -- package Nested is + -- ... + -- end Nested; - -------------------------------- - -- Set_Elaboration_Constraint -- - -------------------------------- + -- package body Nested is + -- T : Task_Typ; + -- [begin] + -- <activation call> -- guaranteed ABE + -- end Nested; - procedure Set_Elaboration_Constraint - (Call : Node_Id; - Subp : Entity_Id; - Scop : Entity_Id) - is - Elab_Unit : Entity_Id; + -- task body Task_Typ is + -- ... + -- end Task_Typ; + -- ... + + -- Performance note: parent traversal + + elsif Is_Guaranteed_ABE + (N => Call, + Target_Decl => Task_Attrs.Task_Decl, + Target_Body => Task_Attrs.Body_Decl) + then + Error_Msg_Sloc := Sloc (Call); + Error_Msg_N + ("??task & will be activated # before elaboration of its body", + Obj_Id); + Error_Msg_N ("\Program_Error will be raised at run time", Obj_Id); + + -- Mark the activation call as a guaranteed ABE + + Set_Is_Known_Guaranteed_ABE (Call); + + -- Install a run-time ABE failue because this activation call will + -- always result in an ABE. + + if Check_OK then + Install_ABE_Failure + (N => Call, + Ins_Nod => Call); + end if; + end if; + end Process_Activation_Guaranteed_ABE_Impl; - -- Check whether this is a call to an Initialize subprogram for a - -- controlled type. Note that Call can also be a 'Access attribute - -- reference, which now generates an elaboration check. + procedure Process_Activation_Guaranteed_ABE is + new Process_Activation_Call (Process_Activation_Guaranteed_ABE_Impl); - Init_Call : constant Boolean := - Nkind (Call) = N_Procedure_Call_Statement - and then Chars (Subp) = Name_Initialize - and then Comes_From_Source (Subp) - and then Present (Parameter_Associations (Call)) - and then Is_Controlled (Etype (First_Actual (Call))); + ------------------ + -- Process_Call -- + ------------------ + + procedure Process_Call + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + In_Task_Body : Boolean) + is + SPARK_Rules_On : Boolean; + Target_Attrs : Target_Attributes; begin - -- If the unit is mentioned in a with_clause of the current unit, it is - -- visible, and we can set the elaboration flag. + Extract_Target_Attributes + (Target_Id => Target_Id, + Attrs => Target_Attrs); - if Is_Immediately_Visible (Scop) - or else (Is_Child_Unit (Scop) and then Is_Visible_Lib_Unit (Scop)) - then - Activate_Elaborate_All_Desirable (Call, Scop); - Set_Suppress_Elaboration_Warnings (Scop); - return; + -- The SPARK rules are in effect when both the call and target are + -- subject to SPARK_Mode On. + + SPARK_Rules_On := + Call_Attrs.SPARK_Mode_On and Target_Attrs.SPARK_Mode_On; + + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. + + if Elab_Info_Messages then + Info_Call + (Call => Call, + Target_Id => Target_Id, + Info_Msg => True, + In_SPARK => SPARK_Rules_On); end if; - -- If this is not an initialization call or a call using object notation - -- we know that the unit of the called entity is in the context, and we - -- can set the flag as well. The unit need not be visible if the call - -- occurs within an instantiation. + -- Check whether the invocation of an entry clashes with an existing + -- restriction. - if Is_Init_Proc (Subp) - or else Init_Call - or else Nkind (Original_Node (Call)) = N_Selected_Component - then - null; -- detailed processing follows. + if Is_Protected_Entry (Target_Id) then + Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); + + elsif Is_Task_Entry (Target_Id) then + Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); + + -- Task entry calls are never processed because the entry being + -- invoked does not have a corresponding "body", it has a select. - else - Activate_Elaborate_All_Desirable (Call, Scop); - Set_Suppress_Elaboration_Warnings (Scop); return; end if; - -- If the unit is not in the context, there must be an intermediate unit - -- that is, on which we need to place to elaboration flag. This happens - -- with init proc calls. + -- Nothing to do when the call is a guaranteed ABE - if Is_Init_Proc (Subp) or else Init_Call then + if Is_Known_Guaranteed_ABE (Call) then + return; - -- The initialization call is on an object whose type is not declared - -- in the same scope as the subprogram. The type of the object must - -- be a subtype of the type of operation. This object is the first - -- actual in the call. + -- Nothing to do when the root scenario appears at the declaration level + -- and the target is in the same unit, but outside this context. - declare - Typ : constant Entity_Id := - Etype (First (Parameter_Associations (Call))); - begin - Elab_Unit := Scope (Typ); - while (Present (Elab_Unit)) - and then not Is_Compilation_Unit (Elab_Unit) - loop - Elab_Unit := Scope (Elab_Unit); - end loop; - end; + -- function B ...; -- target declaration - -- If original node uses selected component notation, the prefix is - -- visible and determines the scope that must be elaborated. After - -- rewriting, the prefix is the first actual in the call. + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- return B; -- call site + -- ... + -- end A; - elsif Nkind (Original_Node (Call)) = N_Selected_Component then - Elab_Unit := Scope (Etype (First (Parameter_Associations (Call)))); + -- X : ... := A; -- root scenario + -- ... - -- Not one of special cases above + -- function B ... is + -- ... + -- end B; - else - -- Using previously computed scope. If the elaboration check is - -- done after analysis, the scope is not visible any longer, but - -- must still be in the context. + -- In the example above, the context of X is the declarative region of + -- Proc. The "elaboration" of X may eventually reach B which is defined + -- outside of X's context. B is relevant only when Proc is invoked, but + -- this happens only by means of "normal" elaboration, therefore B must + -- not be considered if this is not the case. - Elab_Unit := Scop; - end if; + -- Performance note: parent traversal - Activate_Elaborate_All_Desirable (Call, Elab_Unit); - Set_Suppress_Elaboration_Warnings (Elab_Unit); - end Set_Elaboration_Constraint; + elsif Is_Up_Level_Target (Target_Attrs.Spec_Decl) then + return; - ------------------------ - -- Get_Referenced_Ent -- - ------------------------ + -- The SPARK rules are in effect - function Get_Referenced_Ent (N : Node_Id) return Entity_Id is - Nam : Node_Id; + elsif SPARK_Rules_On then + Process_Call_SPARK + (Call => Call, + Call_Attrs => Call_Attrs, + Target_Id => Target_Id, + Target_Attrs => Target_Attrs); - begin - if Nkind (N) in N_Has_Entity - and then Present (Entity (N)) - and then Ekind (Entity (N)) = E_Variable - then - return Entity (N); - end if; + -- Otherwise the Ada rules are in effect - if Nkind (N) = N_Attribute_Reference then - Nam := Prefix (N); else - Nam := Name (N); + Process_Call_Ada + (Call => Call, + Call_Attrs => Call_Attrs, + Target_Id => Target_Id, + Target_Attrs => Target_Attrs, + In_Task_Body => In_Task_Body); end if; - if No (Nam) then - return Empty; - elsif Nkind (Nam) = N_Selected_Component then - return Entity (Selector_Name (Nam)); - elsif not Is_Entity_Name (Nam) then - return Empty; - else - return Entity (Nam); - end if; - end Get_Referenced_Ent; + -- Inspect the target body (and barried function) for other suitable + -- elaboration scenarios. + + Traverse_Body (Target_Attrs.Body_Barf, In_Task_Body); + Traverse_Body (Target_Attrs.Body_Decl, In_Task_Body); + end Process_Call; ---------------------- - -- Has_Generic_Body -- + -- Process_Call_Ada -- ---------------------- - function Has_Generic_Body (N : Node_Id) return Boolean is - Ent : constant Entity_Id := Get_Generic_Entity (N); - Decl : constant Node_Id := Unit_Declaration_Node (Ent); - Scop : Entity_Id; - - function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id; - -- Determine if the list of nodes headed by N and linked by Next - -- contains a package body for the package spec entity E, and if so - -- return the package body. If not, then returns Empty. - - function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id; - -- This procedure is called load the unit whose name is given by Nam. - -- This unit is being loaded to see whether it contains an optional - -- generic body. The returned value is the loaded unit, which is always - -- a package body (only package bodies can contain other entities in the - -- sense in which Has_Generic_Body is interested). We only attempt to - -- load bodies if we are generating code. If we are in semantics check - -- only mode, then it would be wrong to load bodies that are not - -- required from a semantic point of view, so in this case we return - -- Empty. The result is that the caller may incorrectly decide that a - -- generic spec does not have a body when in fact it does, but the only - -- harm in this is that some warnings on elaboration problems may be - -- lost in semantic checks only mode, which is not big loss. We also - -- return Empty if we go for a body and it is not there. - - function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id; - -- PE is the entity for a package spec. This function locates the - -- corresponding package body, returning Empty if none is found. The - -- package body returned is fully parsed but may not yet be analyzed, - -- so only syntactic fields should be referenced. - - ------------------ - -- Find_Body_In -- - ------------------ - - function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is - Nod : Node_Id; + procedure Process_Call_Ada + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes; + In_Task_Body : Boolean) + is + function In_Initialization_Context (N : Node_Id) return Boolean; + -- Determine whether arbitrary node N appears within a type init proc or + -- primitive [Deep_]Initialize. + + ------------------------------- + -- In_Initialization_Context -- + ------------------------------- + + function In_Initialization_Context (N : Node_Id) return Boolean is + Par : Node_Id; + Spec_Id : Entity_Id; begin - Nod := N; - while Present (Nod) loop + -- Climb the parent chain looking for initialization actions - -- If we found the package body we are looking for, return it + Par := Parent (N); + while Present (Par) loop - if Nkind (Nod) = N_Package_Body - and then Chars (Defining_Unit_Name (Nod)) = Chars (E) + -- A block may be part of the initialization actions of a default + -- initialized object. + + if Nkind (Par) = N_Block_Statement + and then Is_Initialization_Block (Par) then - return Nod; + return True; - -- If we found the stub for the body, go after the subunit, - -- loading it if necessary. + -- A subprogram body may denote an initialization routine - elsif Nkind (Nod) = N_Package_Body_Stub - and then Chars (Defining_Identifier (Nod)) = Chars (E) - then - if Present (Library_Unit (Nod)) then - return Unit (Library_Unit (Nod)); + elsif Nkind (Par) = N_Subprogram_Body then + Spec_Id := Unique_Defining_Entity (Par); - else - return Load_Package_Body (Get_Unit_Name (Nod)); + -- The current subprogram body denotes a type init proc or + -- primitive [Deep_]Initialize. + + if Is_Init_Proc (Spec_Id) + or else Is_Controlled_Proc (Spec_Id, Name_Initialize) + or else Is_TSS (Spec_Id, TSS_Deep_Initialize) + then + return True; end if; - -- If neither package body nor stub, keep looking on chain + -- Prevent the search from going too far - else - Next (Nod); + elsif Is_Body_Or_Package_Declaration (Par) then + exit; end if; + + Par := Parent (Par); end loop; - return Empty; - end Find_Body_In; + return False; + end In_Initialization_Context; - ----------------------- - -- Load_Package_Body -- - ----------------------- + -- Local variables - function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is - U : Unit_Number_Type; + Check_OK : constant Boolean := + not Call_Attrs.Ghost_Mode_Ignore + and then not Target_Attrs.Ghost_Mode_Ignore + and then Call_Attrs.Elab_Checks_OK + and then Target_Attrs.Elab_Checks_OK; + -- A run-time ABE check may be installed only when both the call and the + -- target have active elaboration checks, and both are not ignored Ghost + -- constructs. - begin - if Operating_Mode /= Generate_Code then - return Empty; - else - U := - Load_Unit - (Load_Name => Nam, - Required => False, - Subunit => False, - Error_Node => N); + -- Start of processing for Process_Call_Ada - if U = No_Unit then - return Empty; - else - return Unit (Cunit (U)); - end if; - end if; - end Load_Package_Body; + begin + -- Nothing to do for an Ada dispatching call because there are no ABE + -- diagnostics for either models. ABE checks for the dynamic model are + -- handled by Install_Primitive_Elaboration_Check. - ------------------------------- - -- Locate_Corresponding_Body -- - ------------------------------- + if Call_Attrs.Is_Dispatching then + return; - function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is - Spec : constant Node_Id := Declaration_Node (PE); - Decl : constant Node_Id := Parent (Spec); - Scop : constant Entity_Id := Scope (PE); - PBody : Node_Id; + -- Nothing to do when the call is ABE-safe - begin - if Is_Library_Level_Entity (PE) then + -- generic + -- function Gen ...; - -- If package is a library unit that requires a body, we have no - -- choice but to go after that body because it might contain an - -- optional body for the original generic package. + -- function Gen ... is + -- begin + -- ... + -- end Gen; - if Unit_Requires_Body (PE) then + -- with Gen; + -- procedure Main is + -- function Inst is new Gen; + -- X : ... := Inst; -- safe call + -- ... - -- Load the body. Note that we are a little careful here to use - -- Spec to get the unit number, rather than PE or Decl, since - -- in the case where the package is itself a library level - -- instantiation, Spec will properly reference the generic - -- template, which is what we really want. + elsif Is_Safe_Call (Call, Target_Attrs) then + return; - return - Load_Package_Body - (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec)))); + -- The call and the target body are both in the main unit - -- But if the package is a library unit that does NOT require - -- a body, then no body is permitted, so we are sure that there - -- is no body for the original generic package. + elsif Present (Target_Attrs.Body_Decl) + and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) + then + Process_Call_Conditional_ABE + (Call => Call, + Call_Attrs => Call_Attrs, + Target_Id => Target_Id, + Target_Attrs => Target_Attrs); + + -- Otherwise the target body is not available in this compilation or it + -- resides in an external unit. Install a run-time ABE check to verify + -- that the target body has been elaborated prior to the call site when + -- the dynamic model is in effect. + + elsif Dynamic_Elaboration_Checks and then Check_OK then + Install_ABE_Check + (N => Call, + Ins_Nod => Call, + Id => Target_Attrs.Unit_Id); + end if; - else - return Empty; - end if; + -- No implicit pragma Elaborate[_All] is generated when the call has + -- elaboration checks suppressed. This behaviour parallels that of the + -- old ABE mechanism. + + if not Call_Attrs.Elab_Checks_OK then + null; - -- Otherwise look and see if we are embedded in a further package + -- No implicit pragma Elaborate[_All] is generated for finalization + -- actions when primitive [Deep_]Finalize is not defined in the main + -- unit and the call appears within some initialization actions. This + -- behaviour parallels that of the old ABE mechanism. - elsif Is_Package_Or_Generic_Package (Scop) then + -- Performance note: parent traversal - -- If so, get the body of the enclosing package, and look in - -- its package body for the package body we are looking for. + elsif (Is_Controlled_Proc (Target_Id, Name_Finalize) + or else Is_TSS (Target_Id, TSS_Deep_Finalize)) + and then not In_Extended_Main_Code_Unit (Target_Attrs.Spec_Decl) + and then In_Initialization_Context (Call) + then + null; - PBody := Locate_Corresponding_Body (Scop); + -- Otherwise ensure that the unit with the target body is elaborated + -- prior to the main unit. - if No (PBody) then - return Empty; - else - return Find_Body_In (PE, First (Declarations (PBody))); - end if; + else + Ensure_Prior_Elaboration + (N => Call, + Unit_Id => Target_Attrs.Unit_Id, + In_Task_Body => In_Task_Body); + end if; + end Process_Call_Ada; - -- If we are not embedded in a further package, then the body - -- must be in the same declarative part as we are. + ---------------------------------- + -- Process_Call_Conditional_ABE -- + ---------------------------------- - else - return Find_Body_In (PE, Next (Decl)); + procedure Process_Call_Conditional_ABE + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes) + is + Check_OK : constant Boolean := + not Call_Attrs.Ghost_Mode_Ignore + and then not Target_Attrs.Ghost_Mode_Ignore + and then Call_Attrs.Elab_Checks_OK + and then Target_Attrs.Elab_Checks_OK; + -- A run-time ABE check may be installed only when both the call and the + -- target have active elaboration checks, and both are not ignored Ghost + -- constructs. + + Root : constant Node_Id := Root_Scenario; + + begin + -- If the root scenario appears prior to the target body, then this is a + -- possible ABE with respect to the root scenario. + + -- function B ...; + + -- function A ... is + -- begin + -- if Some_Condition then + -- return B; -- call site + -- ... + -- end A; + + -- X : ... := A; -- root scenario + + -- function B ... is -- target body + -- ... + -- end B; + + -- Y : ... := A; -- root scenario + + -- IMPORTANT: The call to B from A is a possible ABE for X, but not for + -- Y. Installing an unconditional ABE raise prior to the call to B would + -- be wrong as it will fail for Y as well, but in Y's case the call to B + -- is never an ABE. + + if Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) then + + -- ABE diagnostics are emitted only in the static model because there + -- is a well-defined order to visiting scenarios. Without this order + -- diagnostics appear jumbled and result in unwanted noise. + + if Static_Elaboration_Checks then + Error_Msg_NE ("??cannot call & before body seen", Call, Target_Id); + Error_Msg_N ("\Program_Error may be raised at run time", Call); + + Output_Active_Scenarios (Call); end if; - end Locate_Corresponding_Body; - -- Start of processing for Has_Generic_Body + -- Install a conditional run-time ABE check to verify that the target + -- body has been elaborated prior to the call. + + if Check_OK then + Install_ABE_Check + (N => Call, + Ins_Nod => Call, + Target_Id => Target_Attrs.Spec_Id, + Target_Decl => Target_Attrs.Spec_Decl, + Target_Body => Target_Attrs.Body_Decl); + end if; + end if; + end Process_Call_Conditional_ABE; + + --------------------------------- + -- Process_Call_Guaranteed_ABE -- + --------------------------------- + + procedure Process_Call_Guaranteed_ABE + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id) + is + Target_Attrs : Target_Attributes; begin - if Present (Corresponding_Body (Decl)) then - return True; + Extract_Target_Attributes + (Target_Id => Target_Id, + Attrs => Target_Attrs); - elsif Unit_Requires_Body (Ent) then - return True; + -- Nothing to do when the root scenario appears at the declaration level + -- and the target is in the same unit, but outside this context. - -- Compilation units cannot have optional bodies + -- function B ...; -- target declaration - elsif Is_Compilation_Unit (Ent) then - return False; + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- return B; -- call site + -- ... + -- end A; - -- Otherwise look at what scope we are in + -- X : ... := A; -- root scenario + -- ... - else - Scop := Scope (Ent); + -- function B ... is + -- ... + -- end B; - -- Case of entity is in other than a package spec, in this case - -- the body, if present, must be in the same declarative part. + -- In the example above, the context of X is the declarative region of + -- Proc. The "elaboration" of X may eventually reach B which is defined + -- outside of X's context. B is relevant only when Proc is invoked, but + -- this happens only by means of "normal" elaboration, therefore B must + -- not be considered if this is not the case. - if not Is_Package_Or_Generic_Package (Scop) then - declare - P : Node_Id; + -- Performance note: parent traversal - begin - -- Declaration node may get us a spec, so if so, go to - -- the parent declaration. + if Is_Up_Level_Target (Target_Attrs.Spec_Decl) then + return; - P := Declaration_Node (Ent); - while not Is_List_Member (P) loop - P := Parent (P); - end loop; + -- Nothing to do when the call is ABE-safe - return Present (Find_Body_In (Ent, Next (P))); - end; + -- generic + -- function Gen ...; - -- If the entity is in a package spec, then we have to locate - -- the corresponding package body, and look there. + -- function Gen ... is + -- begin + -- ... + -- end Gen; - else - declare - PBody : constant Node_Id := Locate_Corresponding_Body (Scop); + -- with Gen; + -- procedure Main is + -- function Inst is new Gen; + -- X : ... := Inst; -- safe call + -- ... - begin - if No (PBody) then - return False; - else - return - Present - (Find_Body_In (Ent, (First (Declarations (PBody))))); - end if; - end; + elsif Is_Safe_Call (Call, Target_Attrs) then + return; + + -- A call leads to a guaranteed ABE when the call and the target appear + -- within the same context ignoring library levels, and the body of the + -- target has not been seen yet or appears after the call. + + -- procedure Guaranteed_ABE is + -- function Func ...; + + -- package Nested is + -- Obj : ... := Func; -- guaranteed ABE + -- end Nested; + + -- function Func ... is + -- ... + -- end Func; + -- ... + + -- Performance note: parent traversal + + elsif Is_Guaranteed_ABE + (N => Call, + Target_Decl => Target_Attrs.Spec_Decl, + Target_Body => Target_Attrs.Body_Decl) + then + Error_Msg_NE ("??cannot call & before body seen", Call, Target_Id); + Error_Msg_N ("\Program_Error will be raised at run time", Call); + + -- Mark the call as a guarnateed ABE + + Set_Is_Known_Guaranteed_ABE (Call); + + -- Install a run-time ABE failure because the call will always result + -- in an ABE. The failure is installed when both the call and target + -- have enabled elaboration checks, and both are not ignored Ghost + -- constructs. + + if Call_Attrs.Elab_Checks_OK + and then Target_Attrs.Elab_Checks_OK + and then not Call_Attrs.Ghost_Mode_Ignore + and then not Target_Attrs.Ghost_Mode_Ignore + then + Install_ABE_Failure + (N => Call, + Ins_Nod => Call); end if; end if; - end Has_Generic_Body; + end Process_Call_Guaranteed_ABE; - ----------------------- - -- Insert_Elab_Check -- - ----------------------- + ------------------------ + -- Process_Call_SPARK -- + ------------------------ - procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is - Nod : Node_Id; - Loc : constant Source_Ptr := Sloc (N); + procedure Process_Call_SPARK + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes) + is + begin + -- A call to a source target or to a target which emulates Ada or SPARK + -- semantics imposes an Elaborate_All requirement on the context of the + -- main unit. Determine whether the context has a pragma strong enough + -- to meet the requirement. The check is orthogonal to the ABE effects + -- of the call. + + if Target_Attrs.From_Source + or else Is_Ada_Semantic_Target (Target_Id) + or else Is_SPARK_Semantic_Target (Target_Id) + then + Meet_Elaboration_Requirement + (N => Call, + Target_Id => Target_Id, + Req_Nam => Name_Elaborate_All); + end if; - Chk : Node_Id; - -- The check (N_Raise_Program_Error) node to be inserted + -- Nothing to do when the call is ABE-safe - begin - -- If expansion is disabled, do not generate any checks. Also - -- skip checks if any subunits are missing because in either - -- case we lack the full information that we need, and no object - -- file will be created in any case. + -- generic + -- function Gen ...; - if not Expander_Active or else Subunits_Missing then + -- function Gen ... is + -- begin + -- ... + -- end Gen; + + -- with Gen; + -- procedure Main is + -- function Inst is new Gen; + -- X : ... := Inst; -- safe call + -- ... + + if Is_Safe_Call (Call, Target_Attrs) then return; - end if; - -- If we have a generic instantiation, where Instance_Spec is set, - -- then this field points to a generic instance spec that has - -- been inserted before the instantiation node itself, so that - -- is where we want to insert a check. + -- The call and the target body are both in the main unit - if Nkind (N) in N_Generic_Instantiation - and then Present (Instance_Spec (N)) + elsif Present (Target_Attrs.Body_Decl) + and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) then - Nod := Instance_Spec (N); + Process_Call_Conditional_ABE + (Call => Call, + Call_Attrs => Call_Attrs, + Target_Id => Target_Id, + Target_Attrs => Target_Attrs); + + -- Otherwise the target body is not available in this compilation or it + -- resides in an external unit. There is no need to guarantee the prior + -- elaboration of the unit with the target body because either the main + -- unit meets the Elaborate_All requirement imposed by the call, or the + -- program is illegal. + else - Nod := N; + null; end if; + end Process_Call_SPARK; + + ---------------------------- + -- Process_Guaranteed_ABE -- + ---------------------------- + + procedure Process_Guaranteed_ABE (N : Node_Id) is + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + + begin + -- Add the current scenario to the stack of active scenarios - -- Build check node, possibly with condition + Push_Active_Scenario (N); - Chk := - Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration); + -- Only calls, instantiations, and task activations may result in a + -- guaranteed ABE. - if Present (C) then - Set_Condition (Chk, Make_Op_Not (Loc, Right_Opnd => C)); + if Is_Suitable_Call (N) then + Extract_Call_Attributes + (Call => N, + Target_Id => Target_Id, + Attrs => Call_Attrs); + + if Is_Activation_Proc (Target_Id) then + Process_Activation_Guaranteed_ABE + (Call => N, + Call_Attrs => Call_Attrs, + In_Task_Body => False); + + else + Process_Call_Guaranteed_ABE + (Call => N, + Call_Attrs => Call_Attrs, + Target_Id => Target_Id); + end if; + + elsif Is_Suitable_Instantiation (N) then + Process_Instantiation_Guaranteed_ABE (N); end if; - -- If we are inserting at the top level, insert in Aux_Decls + -- Remove the current scenario from the stack of active scenarios once + -- all ABE diagnostics and checks have been performed. - if Nkind (Parent (Nod)) = N_Compilation_Unit then - declare - ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod)); + Pop_Active_Scenario (N); + end Process_Guaranteed_ABE; - begin - if No (Declarations (ADN)) then - Set_Declarations (ADN, New_List (Chk)); - else - Append_To (Declarations (ADN), Chk); - end if; + --------------------------- + -- Process_Instantiation -- + --------------------------- + + procedure Process_Instantiation + (Exp_Inst : Node_Id; + In_Task_Body : Boolean) + is + Gen_Attrs : Target_Attributes; + Gen_Id : Entity_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Inst_Id : Entity_Id; + + SPARK_Rules_On : Boolean; + -- This flag is set when the SPARK rules are in effect + + begin + Extract_Instantiation_Attributes + (Exp_Inst => Exp_Inst, + Inst => Inst, + Inst_Id => Inst_Id, + Gen_Id => Gen_Id, + Attrs => Inst_Attrs); + + Extract_Target_Attributes (Gen_Id, Gen_Attrs); + + -- The SPARK rules are in effect when both the instantiation and generic + -- are subject to SPARK_Mode On. + + SPARK_Rules_On := Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On; + + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. + + if Elab_Info_Messages then + Info_Instantiation + (Inst => Inst, + Gen_Id => Gen_Id, + Info_Msg => True, + In_SPARK => SPARK_Rules_On); + end if; + + -- Nothing to do when the instantiation is a guaranteed ABE + + if Is_Known_Guaranteed_ABE (Inst) then + return; + + -- Nothing to do when the root scenario appears at the declaration level + -- and the generic is in the same unit, but outside this context. + + -- generic + -- procedure Gen is ...; -- generic declaration + + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- procedure I is new Gen; -- instantiation site + -- ... + -- ... + -- end A; + + -- X : ... := A; -- root scenario + -- ... - Analyze (Chk); - end; + -- procedure Gen is + -- ... + -- end Gen; - -- Otherwise just insert as an action on the node in question + -- In the example above, the context of X is the declarative region of + -- Proc. The "elaboration" of X may eventually reach Gen which appears + -- outside of X's context. Gen is relevant only when Proc is invoked, + -- but this happens only by means of "normal" elaboration, therefore + -- Gen must not be considered if this is not the case. + + -- Performance note: parent traversal + + elsif Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then + return; + + -- The SPARK rules are in effect + + elsif SPARK_Rules_On then + Process_Instantiation_SPARK + (Exp_Inst => Exp_Inst, + Inst => Inst, + Inst_Attrs => Inst_Attrs, + Gen_Id => Gen_Id, + Gen_Attrs => Gen_Attrs); + + -- Otherwise the Ada rules are in effect else - Insert_Action (Nod, Chk); + Process_Instantiation_Ada + (Exp_Inst => Exp_Inst, + Inst => Inst, + Inst_Attrs => Inst_Attrs, + Gen_Id => Gen_Id, + Gen_Attrs => Gen_Attrs, + In_Task_Body => In_Task_Body); end if; - end Insert_Elab_Check; + end Process_Instantiation; ------------------------------- - -- Is_Finalization_Procedure -- + -- Process_Instantiation_Ada -- ------------------------------- - function Is_Finalization_Procedure (Id : Entity_Id) return Boolean is - begin - -- Check whether Id is a procedure with at least one parameter + procedure Process_Instantiation_Ada + (Exp_Inst : Node_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes; + In_Task_Body : Boolean) + is + Check_OK : constant Boolean := + not Inst_Attrs.Ghost_Mode_Ignore + and then not Gen_Attrs.Ghost_Mode_Ignore + and then Inst_Attrs.Elab_Checks_OK + and then Gen_Attrs.Elab_Checks_OK; + -- A run-time ABE check may be installed only when both the instance and + -- the generic have active elaboration checks and both are not ignored + -- Ghost constructs. - if Ekind (Id) = E_Procedure and then Present (First_Formal (Id)) then - declare - Typ : constant Entity_Id := Etype (First_Formal (Id)); - Deep_Fin : Entity_Id := Empty; - Fin : Entity_Id := Empty; + begin + -- Nothing to do when the instantiation is ABE-safe - begin - -- If the type of the first formal does not require finalization - -- actions, then this is definitely not [Deep_]Finalize. + -- generic + -- package Gen is + -- ... + -- end Gen; - if not Needs_Finalization (Typ) then - return False; - end if; + -- package body Gen is + -- ... + -- end Gen; - -- At this point we have the following scenario: + -- with Gen; + -- procedure Main is + -- package Inst is new Gen (ABE); -- safe instantiation + -- ... - -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]); + if Is_Safe_Instantiation (Inst, Gen_Attrs) then + return; - -- Recover the two possible versions of [Deep_]Finalize using the - -- type of the first parameter and compare with the input. + -- The instantiation and the generic body are both in the main unit - Deep_Fin := TSS (Typ, TSS_Deep_Finalize); + elsif Present (Gen_Attrs.Body_Decl) + and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl) + then + Process_Instantiation_Conditional_ABE + (Exp_Inst => Exp_Inst, + Inst => Inst, + Inst_Attrs => Inst_Attrs, + Gen_Id => Gen_Id, + Gen_Attrs => Gen_Attrs); + + -- Otherwise the generic body is not available in this compilation or it + -- resides in an external unit. Install a run-time ABE check to verify + -- that the generic body has been elaborated prior to the instantiation + -- when the dynamic model is in effect. + + elsif Dynamic_Elaboration_Checks and then Check_OK then + Install_ABE_Check + (N => Inst, + Ins_Nod => Exp_Inst, + Id => Gen_Attrs.Unit_Id); + end if; - if Is_Controlled (Typ) then - Fin := Find_Prim_Op (Typ, Name_Finalize); - end if; + -- Ensure that the unit with the generic body is elaborated prior to + -- the main unit. No implicit pragma Elaborate[_All] is generated if + -- the instantiation has elaboration checks suppressed. This behaviour + -- parallels that of the old ABE mechanism. - return (Present (Deep_Fin) and then Id = Deep_Fin) - or else (Present (Fin) and then Id = Fin); - end; + if Inst_Attrs.Elab_Checks_OK then + Ensure_Prior_Elaboration + (N => Inst, + Unit_Id => Gen_Attrs.Unit_Id, + In_Task_Body => In_Task_Body); end if; + end Process_Instantiation_Ada; + + ------------------------------------------- + -- Process_Instantiation_Conditional_ABE -- + ------------------------------------------- + + procedure Process_Instantiation_Conditional_ABE + (Exp_Inst : Node_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes) + is + Check_OK : constant Boolean := + not Inst_Attrs.Ghost_Mode_Ignore + and then not Gen_Attrs.Ghost_Mode_Ignore + and then Inst_Attrs.Elab_Checks_OK + and then Gen_Attrs.Elab_Checks_OK; + -- A run-time ABE check may be installed only when both the instance and + -- the generic have active elaboration checks and both are not ignored + -- Ghost constructs. - return False; - end Is_Finalization_Procedure; + Root : constant Node_Id := Root_Scenario; - ------------------ - -- Output_Calls -- - ------------------ + begin + -- If the root scenario appears prior to the generic body, then this is + -- a possible ABE with respect to the root scenario. - procedure Output_Calls - (N : Node_Id; - Check_Elab_Flag : Boolean) - is - function Emit (Flag : Boolean) return Boolean; - -- Determine whether to emit an error message based on the combination - -- of flags Check_Elab_Flag and Flag. + -- generic + -- package Gen is + -- ... + -- end Gen; - function Is_Printable_Error_Name return Boolean; - -- An internal function, used to determine if a name, stored in the - -- Name_Buffer, is either a non-internal name, or is an internal name - -- that is printable by the error message circuits (i.e. it has a single - -- upper case letter at the end). + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- package Inst is new Gen; -- instantiation site + -- ... + -- end A; - ---------- - -- Emit -- - ---------- + -- X : ... := A; -- root scenario - function Emit (Flag : Boolean) return Boolean is - begin - if Check_Elab_Flag then - return Flag; - else - return True; - end if; - end Emit; + -- package body Gen is -- generic body + -- ... + -- end Gen; - ----------------------------- - -- Is_Printable_Error_Name -- - ----------------------------- + -- Y : ... := A; -- root scenario - function Is_Printable_Error_Name return Boolean is - begin - if not Is_Internal_Name then - return True; + -- IMPORTANT: The instantiation of Gen is a possible ABE for X, but not + -- for Y. Installing an unconditional ABE raise prior to the instance + -- site would be wrong as it will fail for Y as well, but in Y's case + -- the instantiation of Gen is never an ABE. - elsif Name_Len = 1 then - return False; + if Earlier_In_Extended_Unit (Root, Gen_Attrs.Body_Decl) then - else - Name_Len := Name_Len - 1; - return not Is_Internal_Name; + -- ABE diagnostics are emitted only in the static model because there + -- is a well-defined order to visiting scenarios. Without this order + -- diagnostics appear jumbled and result in unwanted noise. + + if Static_Elaboration_Checks then + Error_Msg_NE + ("??cannot instantiate & before body seen", Inst, Gen_Id); + Error_Msg_N ("\Program_Error may be raised at run time", Inst); + + Output_Active_Scenarios (Inst); end if; - end Is_Printable_Error_Name; - -- Local variables + -- Install a conditional run-time ABE check to verify that the + -- generic body has been elaborated prior to the instantiation. + + if Check_OK then + Install_ABE_Check + (N => Inst, + Ins_Nod => Exp_Inst, + Target_Id => Gen_Attrs.Spec_Id, + Target_Decl => Gen_Attrs.Spec_Decl, + Target_Body => Gen_Attrs.Body_Decl); + end if; + end if; + end Process_Instantiation_Conditional_ABE; - Ent : Entity_Id; + ------------------------------------------ + -- Process_Instantiation_Guaranteed_ABE -- + ------------------------------------------ - -- Start of processing for Output_Calls + procedure Process_Instantiation_Guaranteed_ABE (Exp_Inst : Node_Id) is + Gen_Attrs : Target_Attributes; + Gen_Id : Entity_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Inst_Id : Entity_Id; begin - for J in reverse 1 .. Elab_Call.Last loop - Error_Msg_Sloc := Elab_Call.Table (J).Cloc; + Extract_Instantiation_Attributes + (Exp_Inst => Exp_Inst, + Inst => Inst, + Inst_Id => Inst_Id, + Gen_Id => Gen_Id, + Attrs => Inst_Attrs); + + Extract_Target_Attributes (Gen_Id, Gen_Attrs); + + -- Nothing to do when the root scenario appears at the declaration level + -- and the generic is in the same unit, but outside this context. + + -- generic + -- procedure Gen is ...; -- generic declaration + + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- procedure I is new Gen; -- instantiation site + -- ... + -- ... + -- end A; + + -- X : ... := A; -- root scenario + -- ... + + -- procedure Gen is + -- ... + -- end Gen; + + -- In the example above, the context of X is the declarative region of + -- Proc. The "elaboration" of X may eventually reach Gen which appears + -- outside of X's context. Gen is relevant only when Proc is invoked, + -- but this happens only by means of "normal" elaboration, therefore + -- Gen must not be considered if this is not the case. + + -- Performance note: parent traversal + + if Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then + return; - Ent := Elab_Call.Table (J).Ent; - Get_Name_String (Chars (Ent)); + -- Nothing to do when the instantiation is ABE-safe - -- Dynamic elaboration model, warnings controlled by -gnatwl + -- generic + -- package Gen is + -- ... + -- end Gen; - if Dynamic_Elaboration_Checks then - if Emit (Elab_Warnings) then - if Is_Generic_Unit (Ent) then - Error_Msg_NE ("\\?l?& instantiated #", N, Ent); - elsif Is_Init_Proc (Ent) then - Error_Msg_N ("\\?l?initialization procedure called #", N); - elsif Is_Printable_Error_Name then - Error_Msg_NE ("\\?l?& called #", N, Ent); - else - Error_Msg_N ("\\?l?called #", N); - end if; - end if; + -- package body Gen is + -- ... + -- end Gen; - -- Static elaboration model, info messages controlled by -gnatel + -- with Gen; + -- procedure Main is + -- package Inst is new Gen (ABE); -- safe instantiation + -- ... - else - if Emit (Elab_Info_Messages) then - if Is_Generic_Unit (Ent) then - Error_Msg_NE ("\\?$?& instantiated #", N, Ent); - elsif Is_Init_Proc (Ent) then - Error_Msg_N ("\\?$?initialization procedure called #", N); - elsif Is_Printable_Error_Name then - Error_Msg_NE ("\\?$?& called #", N, Ent); - else - Error_Msg_N ("\\?$?called #", N); - end if; - end if; - end if; - end loop; - end Output_Calls; + elsif Is_Safe_Instantiation (Inst, Gen_Attrs) then + return; - ---------------------------- - -- Same_Elaboration_Scope -- - ---------------------------- + -- An instantiation leads to a guaranteed ABE when the instantiation and + -- the generic appear within the same context ignoring library levels, + -- and the body of the generic has not been seen yet or appears after + -- the instantiation. - function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is - S1 : Entity_Id; - S2 : Entity_Id; + -- procedure Guaranteed_ABE is + -- generic + -- procedure Gen; - begin - -- Find elaboration scope for Scop1 - -- This is either a subprogram or a compilation unit. + -- package Nested is + -- procedure Inst is new Gen; -- guaranteed ABE + -- end Nested; - S1 := Scop1; - while S1 /= Standard_Standard - and then not Is_Compilation_Unit (S1) - and then Ekind_In (S1, E_Package, E_Protected_Type, E_Block) - loop - S1 := Scope (S1); - end loop; + -- procedure Gen is + -- ... + -- end Gen; + -- ... - -- Find elaboration scope for Scop2 + -- Performance note: parent traversal - S2 := Scop2; - while S2 /= Standard_Standard - and then not Is_Compilation_Unit (S2) - and then Ekind_In (S2, E_Package, E_Protected_Type, E_Block) - loop - S2 := Scope (S2); - end loop; + elsif Is_Guaranteed_ABE + (N => Inst, + Target_Decl => Gen_Attrs.Spec_Decl, + Target_Body => Gen_Attrs.Body_Decl) + then + Error_Msg_NE + ("??cannot instantiate & before body seen", Inst, Gen_Id); + Error_Msg_N ("\Program_Error will be raised at run time", Inst); - return S1 = S2; - end Same_Elaboration_Scope; + -- Mark the instantiation as a guarantee ABE. This automatically + -- suppresses the instantiation of the generic body. - ----------------- - -- Set_C_Scope -- - ----------------- + Set_Is_Known_Guaranteed_ABE (Inst); + + -- Install a run-time ABE failure because the instantiation will + -- always result in an ABE. The failure is installed when both the + -- instance and the generic have enabled elaboration checks, and both + -- are not ignored Ghost constructs. + + if Inst_Attrs.Elab_Checks_OK + and then Gen_Attrs.Elab_Checks_OK + and then not Inst_Attrs.Ghost_Mode_Ignore + and then not Gen_Attrs.Ghost_Mode_Ignore + then + Install_ABE_Failure + (N => Inst, + Ins_Nod => Exp_Inst); + end if; + end if; + end Process_Instantiation_Guaranteed_ABE; + + --------------------------------- + -- Process_Instantiation_SPARK -- + --------------------------------- + + procedure Process_Instantiation_SPARK + (Exp_Inst : Node_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes) + is + Req_Nam : Name_Id; - procedure Set_C_Scope is begin - while not Is_Compilation_Unit (C_Scope) loop - C_Scope := Scope (C_Scope); - end loop; - end Set_C_Scope; + -- A source instantiation imposes an Elaborate[_All] requirement on the + -- context of the main unit. Determine whether the context has a pragma + -- strong enough to meet the requirement. The check is orthogonal to the + -- ABE ramifications of the instantiation. - ----------------- - -- Spec_Entity -- - ----------------- + if Nkind (Inst) = N_Package_Instantiation then + Req_Nam := Name_Elaborate; + else + Req_Nam := Name_Elaborate_All; + end if; + + Meet_Elaboration_Requirement + (N => Inst, + Target_Id => Gen_Id, + Req_Nam => Req_Nam); + + -- Nothing to do when the instantiation is ABE-safe - function Spec_Entity (E : Entity_Id) return Entity_Id is - Decl : Node_Id; + -- generic + -- package Gen is + -- ... + -- end Gen; + + -- package body Gen is + -- ... + -- end Gen; + + -- with Gen; + -- procedure Main is + -- package Inst is new Gen (ABE); -- safe instantiation + -- ... + + if Is_Safe_Instantiation (Inst, Gen_Attrs) then + return; + + -- The instantiation and the generic body are both in the main unit + + elsif Present (Gen_Attrs.Body_Decl) + and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl) + then + Process_Instantiation_Conditional_ABE + (Exp_Inst => Exp_Inst, + Inst => Inst, + Inst_Attrs => Inst_Attrs, + Gen_Id => Gen_Id, + Gen_Attrs => Gen_Attrs); + + -- Otherwise the generic body is not available in this compilation or + -- it resides in an external unit. There is no need to guarantee the + -- prior elaboration of the unit with the generic body because either + -- the main unit meets the Elaborate[_All] requirement imposed by the + -- instantiation, or the program is illegal. + + else + null; + end if; + end Process_Instantiation_SPARK; + + --------------------------------- + -- Process_Variable_Assignment -- + --------------------------------- + + procedure Process_Variable_Assignment (Asmt : Node_Id) is + Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (Asmt)); + Spec_Id : Entity_Id; begin - -- Check for case of body entity - -- Why is the check for E_Void needed??? + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. - if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then - Decl := E; + if Elab_Info_Messages then + Error_Msg_NE + ("info: assignment to & during elaboration", Asmt, Var_Id); + end if; - loop - Decl := Parent (Decl); - exit when Nkind (Decl) in N_Proper_Body; - end loop; + Spec_Id := Find_Top_Unit (Var_Id); + + -- Generate an implicit Elaborate_Body in the spec + + Set_Elaborate_Body_Desirable (Spec_Id); - return Corresponding_Spec (Decl); + -- No warning is emitted for internal uses. This behaviour parallels + -- that of the old ABE mechanism. + + if GNAT_Mode then + null; else - return E; + Error_Msg_NE + ("??variable & can be accessed by clients before this " + & "initialization", Asmt, Var_Id); + + Error_Msg_NE + ("\add pragma ""Elaborate_Body"" to spec & to ensure proper " + & "initialization", Asmt, Spec_Id); + + Output_Active_Scenarios (Asmt); end if; - end Spec_Entity; + end Process_Variable_Assignment; - ------------------- - -- Supply_Bodies -- - ------------------- + -------------------------------- + -- Process_Variable_Reference -- + -------------------------------- + + procedure Process_Variable_Reference (Ref : Node_Id) is + Var_Attrs : Variable_Attributes; + Var_Id : Entity_Id; - procedure Supply_Bodies (N : Node_Id) is begin - if Nkind (N) = N_Subprogram_Declaration then - declare - Ent : constant Entity_Id := Defining_Unit_Name (Specification (N)); + Extract_Variable_Reference_Attributes + (Ref => Ref, + Var_Id => Var_Id, + Attrs => Var_Attrs); + + -- Output relevant information when switch -gnatel (info messages on + -- implicit Elaborate[_All] pragmas) is in effect. + + if Elab_Info_Messages then + Elab_Msg_NE + (Msg => "reference to variable & during elaboration", + N => Ref, + Id => Var_Id, + Info_Msg => True, + In_SPARK => True); + end if; - begin - -- Internal subprograms will already have a generated body, so - -- there is no need to provide a stub for them. - - if No (Corresponding_Body (N)) then - declare - Loc : constant Source_Ptr := Sloc (N); - Formals : constant List_Id := Copy_Parameter_List (Ent); - Nam : constant Entity_Id := - Make_Defining_Identifier (Loc, Chars (Ent)); - Stats : constant List_Id := - New_List ( - Make_Raise_Program_Error (Loc, - Reason => PE_Access_Before_Elaboration)); - Spec : Node_Id; - - begin - if Ekind (Ent) = E_Function then - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => Nam, - Parameter_Specifications => Formals, - Result_Definition => - New_Copy_Tree - (Result_Definition (Specification (N)))); - - -- We cannot reliably make a return statement for this - -- body, but none is needed because the call raises - -- program error. - - Set_Return_Present (Ent); + -- A source variable reference imposes an Elaborate_All requirement on + -- the context of the main unit. Determine whethe the context has a + -- pragma strong enough to meet the requirement. - else - Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Nam, - Parameter_Specifications => Formals); - end if; + Meet_Elaboration_Requirement + (N => Ref, + Target_Id => Var_Id, + Req_Nam => Name_Elaborate_All); + end Process_Variable_Reference; + + -------------------------- + -- Push_Active_Scenario -- + -------------------------- + + procedure Push_Active_Scenario (N : Node_Id) is + begin + Scenario_Stack.Append (N); + end Push_Active_Scenario; - Insert_After_And_Analyze (N, - Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => New_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, Stats))); - end; + ---------------------- + -- Process_Scenario -- + ---------------------- + + procedure Process_Scenario (N : Node_Id; In_Task_Body : Boolean := False) is + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + + begin + -- Add the current scenario to the stack of active scenarios + + Push_Active_Scenario (N); + + -- 'Access + + if Is_Suitable_Access (N) then + Process_Access (N, In_Task_Body); + + -- Calls + + elsif Is_Suitable_Call (N) then + + -- In general, only calls found within the main unit are processed + -- because the ALI information supplied to binde is for the main + -- unit only. However, to preserve the consistency of the tree and + -- ensure proper serialization of internal names, external calls + -- also receive corresponding call markers (see Build_Call_Marker). + -- Regardless of the reason, external calls must not be processed. + + if In_Main_Context (N) then + Extract_Call_Attributes + (Call => N, + Target_Id => Target_Id, + Attrs => Call_Attrs); + + if Is_Activation_Proc (Target_Id) then + Process_Activation_Conditional_ABE + (Call => N, + Call_Attrs => Call_Attrs, + In_Task_Body => In_Task_Body); + + else + Process_Call + (Call => N, + Call_Attrs => Call_Attrs, + Target_Id => Target_Id, + In_Task_Body => In_Task_Body); end if; - end; + end if; - elsif Nkind (N) = N_Package_Declaration then - declare - Spec : constant Node_Id := Specification (N); - begin - Push_Scope (Defining_Unit_Name (Spec)); - Supply_Bodies (Visible_Declarations (Spec)); - Supply_Bodies (Private_Declarations (Spec)); - Pop_Scope; - end; - end if; - end Supply_Bodies; - - procedure Supply_Bodies (L : List_Id) is - Elmt : Node_Id; - begin - if Present (L) then - Elmt := First (L); - while Present (Elmt) loop - Supply_Bodies (Elmt); - Next (Elmt); - end loop; + -- Instantiations + + elsif Is_Suitable_Instantiation (N) then + Process_Instantiation (N, In_Task_Body); + + -- Variable assignments + + elsif Is_Suitable_Variable_Assignment (N) then + Process_Variable_Assignment (N); + + -- Variable references + + elsif Is_Suitable_Variable_Reference (N) then + Process_Variable_Reference (N); end if; - end Supply_Bodies; - ------------ - -- Within -- - ------------ + -- Remove the current scenario from the stack of active scenarios once + -- all ABE diagnostics and checks have been performed. + + Pop_Active_Scenario (N); + end Process_Scenario; + + --------------------------------- + -- Record_Elaboration_Scenario -- + --------------------------------- + + procedure Record_Elaboration_Scenario (N : Node_Id) is + Level : Enclosing_Level_Kind; + + Declaration_Level_OK : Boolean; + -- This flag is set when a particular scenario is allowed to appear at + -- the declaration level. - function Within (E1, E2 : Entity_Id) return Boolean is - Scop : Entity_Id; begin - Scop := E1; - loop - if Scop = E2 then - return True; - elsif Scop = Standard_Standard then - return False; + -- Assume that the scenario must not appear at the declaration level + + Declaration_Level_OK := False; + + -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics + -- are performed in this mode. + + if ASIS_Mode then + return; + + -- Nothing to do when the scenario is being preanalyzed + + elsif Preanalysis_Active then + return; + end if; + + -- Ensure that a library level call does not appear in a preelaborated + -- unit. The check must come before ignoring scenarios within external + -- units or inside generics because calls in those context must also be + -- verified. + + if Is_Suitable_Call (N) then + Check_Preelaborated_Call (N); + end if; + + -- Nothing to do when the scenario does not appear within the main unit + + if not In_Main_Context (N) then + return; + + -- Scenarios within a generic unit are never considered because generics + -- cannot be elaborated. + + elsif Inside_A_Generic then + return; + + -- Scenarios which do not fall in one of the elaboration categories + -- listed below are not considered. The categories are: + + -- 'Access for entries, operators, and subprograms + -- Calls (includes task activation) + -- Instantiations + -- Variable assignments + -- Variable references + + elsif Is_Suitable_Access (N) + or else Is_Suitable_Variable_Assignment (N) + or else Is_Suitable_Variable_Reference (N) + then + null; + + elsif Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N) then + Declaration_Level_OK := True; + + -- Otherwise the input does not denote a suitable scenario + + else + return; + end if; + + -- The static model imposes additional restrictions on the placement of + -- scenarios. In contrast, the dynamic model assumes that every scenario + -- will be elaborated or invoked at some point. + + if Static_Elaboration_Checks then + + -- Performance note: parent traversal + + Level := Find_Enclosing_Level (N); + + -- Declaration level scenario + + if Declaration_Level_OK and then Level = Declaration_Level then + null; + + -- Library level scenario + + elsif Level in Library_Level then + null; + + -- Instantiation library level scenario + + elsif Level = Instantiation then + null; + + -- Otherwise the scenario does not appear at the proper level and + -- cannot possibly act as a top level scenario. + else - Scop := Scope (Scop); + return; end if; - end loop; - end Within; + end if; - -------------------------- - -- Within_Elaborate_All -- - -------------------------- + -- Perform early detection of guaranteed ABEs in order to suppress the + -- instantiation of generic bodies as gigi cannot handle certain types + -- of premature instantiations. - function Within_Elaborate_All - (Unit : Unit_Number_Type; - E : Entity_Id) return Boolean - is - type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean; - pragma Pack (Unit_Number_Set); + Process_Guaranteed_ABE (N); - Seen : Unit_Number_Set := (others => False); - -- Seen (X) is True after we have seen unit X in the walk. This is used - -- to prevent processing the same unit more than once. + -- At this point all checks have been performed. Record the scenario for + -- later processing by the ABE phase. - Result : Boolean := False; + Top_Level_Scenarios.Append (N); - procedure Helper (Unit : Unit_Number_Type); - -- This helper procedure does all the work for Within_Elaborate_All. It - -- walks the dependency graph, and sets Result to True if it finds an - -- appropriate Elaborate_All. + -- Mark a scenario which may produce run-time conditional ABE checks or + -- guaranteed ABE failures as recorded. The flag ensures that scenario + -- rewritting performed by Atree.Rewrite will be properly reflected in + -- all relevant internal data structures. - ------------ - -- Helper -- - ------------ + if Is_Check_Emitting_Scenario (N) then + Set_Is_Recorded_Scenario (N); + end if; + end Record_Elaboration_Scenario; - procedure Helper (Unit : Unit_Number_Type) is - CU : constant Node_Id := Cunit (Unit); + ------------------- + -- Root_Scenario -- + ------------------- - Item : Node_Id; - Item2 : Node_Id; - Elab_Id : Entity_Id; - Par : Node_Id; + function Root_Scenario return Node_Id is + package Stack renames Scenario_Stack; + begin + -- Ensure that the scenario stack has at least one active scenario in + -- it. The one at the bottom (index First) is the root scenario. + + pragma Assert (Stack.Last >= Stack.First); + return Stack.Table (Stack.First); + end Root_Scenario; + + ------------------------------- + -- Static_Elaboration_Checks -- + ------------------------------- + + function Static_Elaboration_Checks return Boolean is + begin + return not Dynamic_Elaboration_Checks; + end Static_Elaboration_Checks; + + ------------------- + -- Traverse_Body -- + ------------------- + + procedure Traverse_Body (N : Node_Id; In_Task_Body : Boolean) is + function Is_Potential_Scenario (Nod : Node_Id) return Traverse_Result; + -- Determine whether arbitrary node Nod denotes a suitable scenario and + -- if so, process it. + + procedure Traverse_Potential_Scenarios is + new Traverse_Proc (Is_Potential_Scenario); + + procedure Traverse_List (List : List_Id); + -- Inspect list List for suitable elaboration scenarios and process them + + --------------------------- + -- Is_Potential_Scenario -- + --------------------------- + + function Is_Potential_Scenario (Nod : Node_Id) return Traverse_Result is begin - if Seen (Unit) then - return; - else - Seen (Unit) := True; + -- Special cases + + -- Skip constructs which do not have elaboration of their own and + -- need to be elaborated by other means such as invocation, task + -- activation, etc. + + if Is_Non_Library_Level_Encapsulator (Nod) then + return Skip; + + -- Terminate the traversal of a task body with an accept statement + -- when no entry calls in elaboration are allowed because the task + -- will block at run-time and none of the remaining statements will + -- be executed. + + elsif Nkind_In (Original_Node (Nod), N_Accept_Statement, + N_Selective_Accept) + and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code) + then + return Abandon; + + -- Certain nodes carry semantic lists which act as repositories until + -- expansion transforms the node and relocates the contents. Examine + -- these lists in case expansion is disabled. + + elsif Nkind_In (Nod, N_And_Then, N_Or_Else) then + Traverse_List (Actions (Nod)); + + elsif Nkind_In (Nod, N_Elsif_Part, N_Iteration_Scheme) then + Traverse_List (Condition_Actions (Nod)); + + elsif Nkind (Nod) = N_If_Expression then + Traverse_List (Then_Actions (Nod)); + Traverse_List (Else_Actions (Nod)); + + elsif Nkind_In (Nod, N_Component_Association, + N_Iterated_Component_Association) + then + Traverse_List (Loop_Actions (Nod)); + + -- General case + + elsif Is_Suitable_Scenario (Nod) then + Process_Scenario (Nod, In_Task_Body); end if; - -- First, check for Elaborate_Alls on this unit + return OK; + end Is_Potential_Scenario; + + ------------------- + -- Traverse_List -- + ------------------- + + procedure Traverse_List (List : List_Id) is + Item : Node_Id; - Item := First (Context_Items (CU)); + begin + Item := First (List); while Present (Item) loop - if Nkind (Item) = N_Pragma - and then Pragma_Name (Item) = Name_Elaborate_All - then - -- Return if some previous error on the pragma itself. The - -- pragma may be unanalyzed, because of a previous error, or - -- if it is the context of a subunit, inherited by its parent. + Traverse_Potential_Scenarios (Item); + Next (Item); + end loop; + end Traverse_List; - if Error_Posted (Item) or else not Analyzed (Item) then - return; - end if; + -- Start of processing for Traverse_Body - Elab_Id := - Entity - (Expression (First (Pragma_Argument_Associations (Item)))); + begin + -- Nothing to do when there is no body - if E = Elab_Id then - Result := True; - return; - end if; + if No (N) then + return; - Par := Parent (Unit_Declaration_Node (Elab_Id)); + elsif Nkind (N) /= N_Subprogram_Body then + return; + end if; - Item2 := First (Context_Items (Par)); - while Present (Item2) loop - if Nkind (Item2) = N_With_Clause - and then Entity (Name (Item2)) = E - and then not Limited_Present (Item2) - then - Result := True; - return; - end if; + -- Nothing to do if the body was already traversed during the processing + -- of the same top level scenario. - Next (Item2); - end loop; - end if; + if Visited_Bodies.Get (N) then + return; - Next (Item); + -- Otherwise mark the body as traversed + + else + Visited_Bodies.Set (N, True); + end if; + + -- Examine the declarations for suitable scenarios + + Traverse_List (Declarations (N)); + + -- Examine the handled sequence of statements. This also includes any + -- exceptions handlers. + + Traverse_Potential_Scenarios (Handled_Statement_Sequence (N)); + end Traverse_Body; + + --------------------------------- + -- Update_Elaboration_Scenario -- + --------------------------------- + + procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id) is + package Scenarios renames Top_Level_Scenarios; + + begin + -- A scenario is being transformed by Atree.Rewrite. Update all relevant + -- internal data structures to reflect this change. This ensures that a + -- potential run-time conditional ABE check or a guaranteed ABE failure + -- is inserted at the proper place in the tree. + + if Is_Check_Emitting_Scenario (Old_N) + and then Is_Recorded_Scenario (Old_N) + and then Old_N /= New_N + then + -- Performance note: list traversal + + for Index in Scenarios.First .. Scenarios.Last loop + if Scenarios.Table (Index) = Old_N then + Scenarios.Table (Index) := New_N; + + Set_Is_Recorded_Scenario (Old_N, False); + Set_Is_Recorded_Scenario (New_N); + return; + end if; end loop; - -- Second, recurse on with's. We could do this as part of the above - -- loop, but it's probably more efficient to have two loops, because - -- the relevant Elaborate_All is likely to be on the initial unit. In - -- other words, we're walking the with's breadth-first. This part is - -- only necessary in the dynamic elaboration model. - - if Dynamic_Elaboration_Checks then - Item := First (Context_Items (CU)); - while Present (Item) loop - if Nkind (Item) = N_With_Clause - and then not Limited_Present (Item) - then - -- Note: the following call to Get_Cunit_Unit_Number does a - -- linear search, which could be slow, but it's OK because - -- we're about to give a warning anyway. Also, there might - -- be hundreds of units, but not millions. If it turns out - -- to be a problem, we could store the Get_Cunit_Unit_Number - -- in each N_Compilation_Unit node, but that would involve - -- rearranging N_Compilation_Unit_Aux to make room. - - Helper (Get_Cunit_Unit_Number (Library_Unit (Item))); - - if Result then - return; - end if; - end if; + -- A recorded scenario must be in the table of recorded scenarios - Next (Item); - end loop; - end if; - end Helper; + pragma Assert (False); + end if; + end Update_Elaboration_Scenario; - -- Start of processing for Within_Elaborate_All + ------------------------- + -- Visited_Bodies_Hash -- + ------------------------- + function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index is begin - Helper (Unit); - return Result; - end Within_Elaborate_All; + return Visited_Bodies_Index (Key mod Visited_Bodies_Max); + end Visited_Bodies_Hash; end Sem_Elab; diff --git a/gcc/ada/sem_elab.ads b/gcc/ada/sem_elab.ads index d2465827681..ddcd43306b0 100644 --- a/gcc/ada/sem_elab.ads +++ b/gcc/ada/sem_elab.ads @@ -23,158 +23,93 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the routines used to deal with issuing warnings --- for cases of calls that may require warnings about possible access --- before elaboration. +-- This package contains routines which handle access-before-elaboration +-- run-time checks and compile-time diagnostics. See the body for details. with Types; use Types; package Sem_Elab is - ----------------------------- - -- Description of Approach -- - ----------------------------- - - -- Every non-static call that is encountered by Sem_Res results in a call - -- to Check_Elab_Call, with N being the call node, and Outer set to its - -- default value of True. In addition X'Access is treated like a call - -- for the access-to-procedure case, and in SPARK mode only we also - -- check variable references. - - -- The goal of Check_Elab_Call is to determine whether or not the reference - -- in question can generate an access before elaboration error (raising - -- Program_Error) either by directly calling a subprogram whose body - -- has not yet been elaborated, or indirectly, by calling a subprogram - -- whose body has been elaborated, but which contains a call to such a - -- subprogram. - - -- In addition, in SPARK mode, we are checking for a variable reference in - -- another package, which requires an explicit Elaborate_All pragma. - - -- The only references that we need to look at the outer level are - -- references that occur in elaboration code. There are two cases. The - -- reference can be at the outer level of elaboration code, or it can - -- be within another unit, e.g. the elaboration code of a subprogram. - - -- In the case of an elaboration call at the outer level, we must trace - -- all calls to outer level routines either within the current unit or to - -- other units that are with'ed. For calls within the current unit, we can - -- determine if the body has been elaborated or not, and if it has not, - -- then a warning is generated. - - -- Note that there are two subcases. If the original call directly calls a - -- subprogram whose body has not been elaborated, then we know that an ABE - -- will take place, and we replace the call by a raise of Program_Error. - -- If the call is indirect, then we don't know that the PE will be raised, - -- since the call might be guarded by a conditional. In this case we set - -- Do_Elab_Check on the call so that a dynamic check is generated, and - -- output a warning. - - -- For calls to a subprogram in a with'ed unit or a 'Access or variable - -- reference (SPARK mode case), we require that a pragma Elaborate_All - -- or pragma Elaborate be present, or that the referenced unit have a - -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none - -- of these conditions is met, then a warning is generated that a pragma - -- Elaborate_All may be needed (error in the SPARK case), or an implicit - -- pragma is generated. - - -- For the case of an elaboration call at some inner level, we are - -- interested in tracing only calls to subprograms at the same level, - -- i.e. those that can be called during elaboration. Any calls to - -- outer level routines cannot cause ABE's as a result of the original - -- call (there might be an outer level call to the subprogram from - -- outside that causes the ABE, but that gets analyzed separately). - - -- Note that we never trace calls to inner level subprograms, since - -- these cannot result in ABE's unless there is an elaboration problem - -- at a lower level, which will be separately detected. - - -- Note on pragma Elaborate. The checking here assumes that a pragma - -- Elaborate on a with'ed unit guarantees that subprograms within the - -- unit can be called without causing an ABE. This is not in fact the - -- case since pragma Elaborate does not guarantee the transitive - -- coverage guaranteed by Elaborate_All. However, we decide to trust - -- the user in this case. - - -------------------------------------- - -- Instantiation Elaboration Errors -- - -------------------------------------- - - -- A special case arises when an instantiation appears in a context - -- that is known to be before the body is elaborated, e.g. - - -- generic package x is ... - -- ... - -- package xx is new x; - -- ... - -- package body x is ... - - -- In this situation it is certain that an elaboration error will - -- occur, and an unconditional raise Program_Error statement is - -- inserted before the instantiation, and a warning generated. - - -- The problem is that in this case we have no place to put the - -- body of the instantiation. We can't put it in the normal place, - -- because it is too early, and will cause errors to occur as a - -- result of referencing entities before they are declared. - - -- Our approach in this case is simply to avoid creating the body - -- of the instantiation in such a case. The instantiation spec is - -- modified to include dummy bodies for all subprograms, so that - -- the resulting code does not contain subprogram specs with no - -- corresponding bodies. - - procedure Check_Elab_Call - (N : Node_Id; - Outer_Scope : Entity_Id := Empty; - In_Init_Proc : Boolean := False); - -- Check a call for possible elaboration problems. The node N is either an - -- N_Function_Call or N_Procedure_Call_Statement node or an access - -- attribute reference whose prefix is a subprogram. - -- - -- If SPARK_Mode is On, then N can also be a variable reference, since - -- SPARK requires the use of Elaborate_All for references to variables - -- in other packages. - - -- The Outer_Scope argument indicates whether this is an outer level - -- call from Sem_Res (Outer_Scope set to Empty), or an internal recursive - -- call (Outer_Scope set to entity of outermost call, see body). The flag - -- In_Init_Proc should be set whenever the current context is a type - -- init proc. - - -- Note: this might better be called Check_Elab_Reference (to recognize - -- the SPARK case), but we prefer to keep the original name, since this - -- is primarily used for checking for calls that could generate an ABE). - - procedure Check_Elab_Calls; - -- Not all the processing for Check_Elab_Call can be done at the time - -- of calls to Check_Elab_Call. This is because for internal calls, we - -- need to wait to complete the check until all generic bodies have been - -- instantiated. The Check_Elab_Calls procedure cleans up these waiting - -- checks. It is called once after the completion of instantiation. - - procedure Check_Elab_Assign (N : Node_Id); - -- N is either the left side of an assignment, or a procedure argument for - -- a mode OUT or IN OUT formal. This procedure checks for a possible case - -- of access to an entity from elaboration code before the entity has been - -- initialized, and issues appropriate warnings. - - procedure Check_Elab_Instantiation - (N : Node_Id; - Outer_Scope : Entity_Id := Empty); - -- Check an instantiation for possible elaboration problems. N is an - -- instantiation node (N_Package_Instantiation, N_Function_Instantiation, - -- or N_Procedure_Instantiation), and Outer_Scope indicates if this is - -- an outer level call from Sem_Ch12 (Outer_Scope set to Empty), or an - -- internal recursive call (Outer_Scope set to scope of outermost call, - -- see body for further details). The returned value is relevant only - -- for an outer level call, and is set to False if an elaboration error - -- is bound to occur on the instantiation, and True otherwise. This is - -- used by the caller to signal that the body of the instance should - -- not be generated (see detailed description in body). - - procedure Check_Task_Activation (N : Node_Id); - -- At the point at which tasks are activated in a package body, check - -- that the bodies of the tasks are elaborated. + procedure Build_Call_Marker (N : Node_Id); + -- Create a call marker for call or requeue statement N and record it for + -- later processing by the ABE mechanism. + + procedure Check_Elaboration_Scenarios; + -- Examine each scenario recorded during analysis/resolution and apply the + -- Ada or SPARK elaboration rules taking into account the model in effect. + -- This processing detects and diagnoses ABE issues, installs conditional + -- ABE checks or guaranteed ABE failures, and ensures the elaboration of + -- units. + + -- The following type classifies the various enclosing levels used in ABE + -- diagnostics. + + type Enclosing_Level_Kind is + (Declaration_Level, + -- A construct is at the "declaration level" when it appears within the + -- declarations of a block statement, an entry body, a subprogram body, + -- or a task body, ignoring enclosing packages. Example: + + -- package Pack is + -- procedure Proc is -- subprogram body + -- package Nested is -- enclosing package ignored + -- X ... -- at declaration level + + Generic_Package_Spec, + Generic_Package_Body, + -- A construct is at the "generic library level" when it appears in a + -- generic package library unit, ignoring enclosing packages. Example: + + -- generic + -- package Pack is -- generic package spec + -- package Nested is -- enclosing package ignored + -- X ... -- at generic library level + + Instantiation, + -- A construct is at the "instantiation library level" when it appears + -- in a library unit which is also an instantiation. Example: + + -- package Inst is new Gen; -- at instantiation level + + Package_Spec, + Package_Body, + -- A construct is at the "library level" when it appears in a package + -- library unit, ignoring enclosing packages. Example: + + -- package body Pack is -- package body + -- package Nested is -- enclosing package ignored + -- X ... -- at library level + + No_Level); + -- This value is used to indicate that none of the levels above are in + -- effect. + + subtype Generic_Library_Level is Enclosing_Level_Kind range + Generic_Package_Spec .. + Generic_Package_Body; + + subtype Library_Level is Enclosing_Level_Kind range + Package_Spec .. + Package_Body; + + subtype Any_Library_Level is Enclosing_Level_Kind range + Generic_Package_Spec .. + Package_Body; + + function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind; + -- Determine the enclosing level of arbitrary node N + + procedure Initialize; + -- Initialize the internal structures of this unit + + procedure Kill_Elaboration_Scenario (N : Node_Id); + -- Determine whether arbitrary node N denotes a scenario which requires + -- ABE diagnostics or runtime checks and eliminate it from a region with + -- dead code. + + procedure Record_Elaboration_Scenario (N : Node_Id); + -- Determine whether atribtray node N denotes a scenario which requires + -- ABE diagnostics or runtime checks. If this is the case, store N into + -- a table for later processing. end Sem_Elab; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 59bbdb5f0ab..0456101092a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -14384,12 +14384,11 @@ package body Sem_Prag is Call := Get_Pragma_Arg (Arg1); end if; - if Nkind_In (Call, - N_Indexed_Component, - N_Function_Call, - N_Identifier, - N_Expanded_Name, - N_Selected_Component) + if Nkind_In (Call, N_Expanded_Name, + N_Function_Call, + N_Identifier, + N_Indexed_Component, + N_Selected_Component) then -- If this pragma Debug comes from source, its argument was -- parsed as a name form (which is syntactically identical). @@ -14999,26 +14998,6 @@ package body Sem_Prag is Set_Elaborate_Present (Citem, True); Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem)); - -- With the pragma present, elaboration calls on - -- subprograms from the named unit need no further - -- checks, as long as the pragma appears in the current - -- compilation unit. If the pragma appears in some unit - -- in the context, there might still be a need for an - -- Elaborate_All_Desirable from the current compilation - -- to the named unit, so we keep the check enabled. - - if In_Extended_Main_Source_Unit (N) then - - -- This does not apply in SPARK mode, where we allow - -- pragma Elaborate, but we don't trust it to be right - -- so we will still insist on the Elaborate_All. - - if SPARK_Mode /= On then - Set_Suppress_Elaboration_Warnings - (Entity (Name (Citem))); - end if; - end if; - exit Inner; end if; @@ -15096,14 +15075,6 @@ package body Sem_Prag is Set_Elaborate_All_Present (Citem, True); Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem)); - -- Suppress warnings and elaboration checks on the named - -- unit if the pragma is in the current compilation, as - -- for pragma Elaborate. - - if In_Extended_Main_Source_Unit (N) then - Set_Suppress_Elaboration_Warnings - (Entity (Name (Citem))); - end if; exit Innr; end if; @@ -15151,27 +15122,8 @@ package body Sem_Prag is then Error_Pragma ("pragma% must refer to a spec, not a body"); else - Set_Body_Required (Cunit_Node, True); + Set_Body_Required (Cunit_Node); Set_Has_Pragma_Elaborate_Body (Cunit_Ent); - - -- If we are in dynamic elaboration mode, then we suppress - -- elaboration warnings for the unit, since it is definitely - -- fine NOT to do dynamic checks at the first level (and such - -- checks will be suppressed because no elaboration boolean - -- is created for Elaborate_Body packages). - - -- But in the static model of elaboration, Elaborate_Body is - -- definitely NOT good enough to ensure elaboration safety on - -- its own, since the body may WITH other units that are not - -- safe from an elaboration point of view, so a client must - -- still do an Elaborate_All on such units. - - -- Debug flag -gnatdD restores the old behavior of 3.13, where - -- Elaborate_Body always suppressed elab warnings. - - if Dynamic_Elaboration_Checks or Debug_Flag_DD then - Set_Suppress_Elaboration_Warnings (Cunit_Ent); - end if; end if; end Elaborate_Body; @@ -20249,7 +20201,6 @@ package body Sem_Prag is else if not Debug_Flag_U then Set_Is_Preelaborated (Ent); - Set_Suppress_Elaboration_Warnings (Ent); end if; end if; end if; @@ -20877,7 +20828,6 @@ package body Sem_Prag is if not Debug_Flag_U then Set_Is_Pure (Ent); Set_Has_Pragma_Pure (Ent); - Set_Suppress_Elaboration_Warnings (Ent); end if; end Pure; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 1435e047f5a..0722e3742f7 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -63,8 +63,8 @@ with Sem_Ch13; use Sem_Ch13; with Sem_Dim; use Sem_Dim; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; -with Sem_Elim; use Sem_Elim; with Sem_Elab; use Sem_Elab; +with Sem_Elim; use Sem_Elim; with Sem_Eval; use Sem_Eval; with Sem_Intr; use Sem_Intr; with Sem_Util; use Sem_Util; @@ -1325,6 +1325,12 @@ package body Sem_Res is begin Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N)); + -- Ensure that the corresponding operator has the same parent as the + -- original call. This guarantees that parent traversals performed by + -- the ABE mechanism succeed. + + Set_Parent (Op_Node, Parent (N)); + -- Binary operator if Is_Binary then @@ -5785,6 +5791,15 @@ package body Sem_Res is -- Start of processing for Resolve_Call begin + -- Preserve relevant elaboration-related attributes of the context which + -- are no longer available or very expensive to recompute once analysis, + -- resolution, and expansion are over. + + Mark_Elaboration_Attributes + (N_Id => N, + Checks => True, + Modes => True); + -- The context imposes a unique interpretation with type Typ on a -- procedure or function call. Find the entity of the subprogram that -- yields the expected type, and propagate the corresponding formal @@ -5841,10 +5856,15 @@ package body Sem_Res is elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component) or else (Is_Entity_Name (Subp) - and then Ekind (Entity (Subp)) = E_Entry) + and then Ekind_In (Entity (Subp), E_Entry, E_Entry_Family)) then Resolve_Entry_Call (N, Typ); - Check_Elab_Call (N); + + -- Annotate the tree by creating a call marker in case the original + -- call is transformed by expansion. The call marker is automatically + -- saved for later examination by the ABE Processing phase. + + Build_Call_Marker (N); -- Kill checks and constant values, as above for indirect case -- Who knows what happens when another task is activated? @@ -6100,14 +6120,14 @@ package body Sem_Res is -- the proper indexed component. Index_Node := - Make_Indexed_Component (Loc, - Prefix => - Make_Function_Call (Loc, - Name => New_Subp, - Parameter_Associations => - New_List - (Remove_Head (Parameter_Associations (N)))), - Expressions => Parameter_Associations (N)); + Make_Indexed_Component (Loc, + Prefix => + Make_Function_Call (Loc, + Name => New_Subp, + Parameter_Associations => + New_List + (Remove_Head (Parameter_Associations (N)))), + Expressions => Parameter_Associations (N)); end if; -- Preserve the parenthesis count of the node @@ -6122,7 +6142,13 @@ package body Sem_Res is Set_Etype (Prefix (N), Ret_Type); Set_Etype (N, Typ); Resolve_Indexed_Component (N, Typ); - Check_Elab_Call (Prefix (N)); + + -- Annotate the tree by creating a call marker in case + -- the original call is transformed by expansion. The call + -- marker is automatically saved for later examination by + -- the ABE Processing phase. + + Build_Call_Marker (Prefix (N)); end if; end if; @@ -6633,7 +6659,12 @@ package body Sem_Res is -- All done, evaluate call and deal with elaboration issues Eval_Call (N); - Check_Elab_Call (N); + + -- Annotate the tree by creating a call marker in case the original call + -- is transformed by expansion. The call marker is automatically saved + -- for later examination by the ABE Processing phase. + + Build_Call_Marker (N); -- In GNATprove mode, expansion is disabled, but we want to inline some -- subprograms to facilitate formal verification. Indirect calls through @@ -7176,7 +7207,7 @@ package body Sem_Res is else Error_Msg_N - ("invalid use of subtype mark in expression or call", N); + ("invalid use of subtype mark in expression or call", N); end if; -- Check discriminant use if entity is discriminant in current scope, @@ -7269,17 +7300,6 @@ package body Sem_Res is & "(SPARK RM 7.1.3(12))", N); end if; - -- Check for possible elaboration issues with respect to reads of - -- variables. The act of renaming the variable is not considered a - -- read as it simply establishes an alias. - - if Ekind (E) = E_Variable - and then Dynamic_Elaboration_Checks - and then Nkind (Par) /= N_Object_Renaming_Declaration - then - Check_Elab_Call (N); - end if; - -- The variable may eventually become a constituent of a single -- protected/task type. Record the reference now and verify its -- legality when analyzing the contract of the variable @@ -7524,14 +7544,13 @@ package body Sem_Res is ------------------------ procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is - Entry_Name : constant Node_Id := Name (N); - Loc : constant Source_Ptr := Sloc (Entry_Name); - Actuals : List_Id; - First_Named : Node_Id; - Nam : Entity_Id; - Norm_OK : Boolean; - Obj : Node_Id; - Was_Over : Boolean; + Entry_Name : constant Node_Id := Name (N); + Loc : constant Source_Ptr := Sloc (Entry_Name); + + Nam : Entity_Id; + Norm_OK : Boolean; + Obj : Node_Id; + Was_Over : Boolean; begin -- We kill all checks here, because it does not seem worth the effort to @@ -7645,7 +7664,6 @@ package body Sem_Res is and then Present (Contract_Wrapper (Nam)) and then Current_Scope /= Contract_Wrapper (Nam) then - -- Note the entity being called before rewriting the call, so that -- it appears used at this point. @@ -7760,16 +7778,29 @@ package body Sem_Res is Entry_Name); end if; - Actuals := Parameter_Associations (N); - First_Named := First_Named_Actual (N); + declare + Entry_Call : Node_Id; + + begin + Entry_Call := + Make_Entry_Call_Statement (Loc, + Name => Entry_Name, + Parameter_Associations => Parameter_Associations (N)); - Rewrite (N, - Make_Entry_Call_Statement (Loc, - Name => Entry_Name, - Parameter_Associations => Actuals)); + -- Inherit relevant attributes from the original call - Set_First_Named_Actual (N, First_Named); - Set_Analyzed (N, True); + Set_First_Named_Actual + (Entry_Call, First_Named_Actual (N)); + + Set_Is_Elaboration_Checks_OK_Node + (Entry_Call, Is_Elaboration_Checks_OK_Node (N)); + + Set_Is_SPARK_Mode_On_Node + (Entry_Call, Is_SPARK_Mode_On_Node (N)); + + Rewrite (N, Entry_Call); + Set_Analyzed (N, True); + end; -- Protected functions can return on the secondary stack, in which -- case we must trigger the transient scope mechanism. diff --git a/gcc/ada/sem_spark.adb b/gcc/ada/sem_spark.adb index 8c81d2e760f..fa9c19927a4 100644 --- a/gcc/ada/sem_spark.adb +++ b/gcc/ada/sem_spark.adb @@ -2314,6 +2314,7 @@ package body Sem_SPARK is when N_Abstract_Subprogram_Declaration | N_At_Clause | N_Attribute_Definition_Clause + | N_Call_Marker | N_Delta_Constraint | N_Digits_Constraint | N_Empty diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 42063827760..0ae717cfccd 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -53,6 +53,7 @@ with Sem_Attr; use Sem_Attr; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Disp; use Sem_Disp; +with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; @@ -941,6 +942,45 @@ package body Sem_Util is and then not In_Same_Extended_Unit (N, T); end Bad_Unordered_Enumeration_Reference; + ---------------------------- + -- Begin_Keyword_Location -- + ---------------------------- + + function Begin_Keyword_Location (N : Node_Id) return Source_Ptr 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)); + + HSS := Handled_Statement_Sequence (N); + + -- When the handled sequence of statements comes from source, the + -- location of the "begin" keyword is that of the sequence itself. + -- Note that an internal construct may inherit a source sequence. + + if Comes_From_Source (HSS) then + return Sloc (HSS); + + -- The parser generates an internal handled sequence of statements to + -- capture the location of the "begin" keyword if present in the source. + -- Since there are no source statements, the location of the "begin" + -- keyword is effectively that of the "end" keyword. + + elsif Comes_From_Source (N) then + return Sloc (HSS); + + -- Otherwise the construct is internal and should carry the location of + -- the original construct which prompted its creation. + + else + return Sloc (N); + end if; + end Begin_Keyword_Location; + -------------------------- -- Build_Actual_Subtype -- -------------------------- @@ -5760,11 +5800,10 @@ package body Sem_Util is --------------------- function Defining_Entity - (N : Node_Id; - Empty_On_Errors : Boolean := False) return Entity_Id + (N : Node_Id; + Empty_On_Errors : Boolean := False; + Concurrent_Subunit : Boolean := False) return Entity_Id is - Err : Entity_Id := Empty; - begin case Nkind (N) is when N_Abstract_Subprogram_Declaration @@ -5816,7 +5855,23 @@ package body Sem_Util is return Defining_Identifier (N); when N_Subunit => - return Defining_Entity (Proper_Body (N)); + declare + Bod : constant Node_Id := Proper_Body (N); + Orig_Bod : constant Node_Id := Original_Node (Bod); + + begin + -- Retrieve the entity of the original protected or task body + -- if requested by the caller. + + if Concurrent_Subunit + and then Nkind (Bod) = N_Null_Statement + and then Nkind_In (Orig_Bod, N_Protected_Body, N_Task_Body) + then + return Defining_Entity (Orig_Bod); + else + return Defining_Entity (Bod); + end if; + end; when N_Function_Instantiation | N_Function_Specification @@ -5832,6 +5887,7 @@ package body Sem_Util is => declare Nam : constant Node_Id := Defining_Unit_Name (N); + Err : Entity_Id := Empty; begin if Nkind (Nam) in N_Entity then @@ -6862,6 +6918,82 @@ package body Sem_Util is end if; end Enclosing_Subprogram; + -------------------------- + -- End_Keyword_Location -- + -------------------------- + + function End_Keyword_Location (N : Node_Id) return Source_Ptr is + function End_Label_Loc (Nod : Node_Id) return Source_Ptr; + -- Return the source location of Nod's end label according to the + -- following precedence rules: + -- + -- 1) If the end label exists, return its location + -- 2) If Nod exists, return its location + -- 3) Return the location of N + + ------------------- + -- End_Label_Loc -- + ------------------- + + function End_Label_Loc (Nod : Node_Id) return Source_Ptr is + Label : Node_Id; + + begin + if Present (Nod) then + Label := End_Label (Nod); + + if Present (Label) then + return Sloc (Label); + else + return Sloc (Nod); + end if; + + else + return Sloc (N); + end if; + end End_Label_Loc; + + -- Local variables + + Owner : Node_Id; + + -- 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) + then + Owner := Handled_Statement_Sequence (N); + + elsif Nkind (N) = N_Package_Declaration then + Owner := Specification (N); + + elsif Nkind (N) = N_Protected_Body then + Owner := N; + + elsif Nkind_In (N, 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) + then + Owner := Task_Definition (N); + + -- This routine should not be called with other contexts + + else + pragma Assert (False); + null; + end if; + + return End_Label_Loc (Owner); + end End_Keyword_Location; + ------------------------ -- Ensure_Freeze_Node -- ------------------------ @@ -7735,6 +7867,93 @@ package body Sem_Util is return Empty; end Find_Enclosing_Iterator_Loop; + -------------------------- + -- Find_Enclosing_Scope -- + -------------------------- + + function Find_Enclosing_Scope (N : Node_Id) return Entity_Id is + Par : Node_Id; + Spec_Id : Entity_Id; + + begin + -- Examine the parent chain looking for a construct which defines a + -- scope. + + Par := Parent (N); + while Present (Par) loop + case Nkind (Par) is + + -- The construct denotes a declaration, the proper scope is its + -- entity. + + when N_Entry_Declaration + | N_Expression_Function + | N_Full_Type_Declaration + | N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration + | N_Package_Declaration + | N_Private_Extension_Declaration + | N_Protected_Type_Declaration + | N_Single_Protected_Declaration + | N_Single_Task_Declaration + | N_Subprogram_Declaration + | N_Task_Type_Declaration + => + return Defining_Entity (Par); + + -- The construct denotes a body, the proper scope is the entity of + -- the corresponding spec. + + when N_Entry_Body + | N_Package_Body + | N_Protected_Body + | N_Subprogram_Body + | N_Task_Body + => + Spec_Id := Corresponding_Spec (Par); + + -- The defining entity of a stand-alone subprogram body defines + -- a scope. + + if Nkind (Par) = N_Subprogram_Body and then No (Spec_Id) then + return Defining_Entity (Par); + + -- Otherwise there should be corresponding spec which defines a + -- scope. + + else + pragma Assert (Present (Spec_Id)); + + return Spec_Id; + end if; + + -- Special cases + + -- Blocks, loops, and return statements have artificial scopes + + when N_Block_Statement + | N_Loop_Statement + => + return Entity (Identifier (Par)); + + when N_Extended_Return_Statement => + return Return_Statement_Entity (Par); + + -- A traversal from a subunit continues via the corresponding stub + + when N_Subunit => + Par := Corresponding_Stub (Par); + + when others => + null; + end case; + + Par := Parent (Par); + end loop; + + return Standard_Standard; + end Find_Enclosing_Scope; + ------------------------------------ -- Find_Loop_In_Conditional_Block -- ------------------------------------ @@ -9393,7 +9612,7 @@ package body Sem_Util is -- Get_Task_Body_Procedure -- ----------------------------- - function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is + function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is begin -- Note: A task type may be the completion of a private type with -- discriminants. When performing elaboration checks on a task @@ -10523,12 +10742,14 @@ package body Sem_Util is -- Has_Non_Trivial_Precondition -- ---------------------------------- - function Has_Non_Trivial_Precondition (P : Entity_Id) return Boolean is - Cont : constant Node_Id := Find_Aspect (P, Aspect_Pre); + function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is + Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre); + begin - return Present (Cont) - and then Class_Present (Cont) - and then not Is_Entity_Name (Expression (Cont)); + return + Present (Pre) + and then Class_Present (Pre) + and then not Is_Entity_Name (Expression (Pre)); end Has_Non_Trivial_Precondition; ------------------- @@ -10769,160 +10990,6 @@ package body Sem_Util is Ent : Entity_Id; Exp : Node_Id; - function Is_Preelaborable_Expression (N : Node_Id) return Boolean; - -- Returns True if and only if the expression denoted by N does not - -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)). - - --------------------------------- - -- Is_Preelaborable_Expression -- - --------------------------------- - - function Is_Preelaborable_Expression (N : Node_Id) return Boolean is - Exp : Node_Id; - Assn : Node_Id; - Choice : Node_Id; - Comp_Type : Entity_Id; - Is_Array_Aggr : Boolean; - - begin - if Is_OK_Static_Expression (N) then - return True; - - elsif Nkind (N) = N_Null then - return True; - - -- Attributes are allowed in general, even if their prefix is a - -- formal type. (It seems that certain attributes known not to be - -- static might not be allowed, but there are no rules to prevent - -- them.) - - elsif Nkind (N) = N_Attribute_Reference then - return True; - - -- The name of a discriminant evaluated within its parent type is - -- defined to be preelaborable (10.2.1(8)). Note that we test for - -- names that denote discriminals as well as discriminants to - -- catch references occurring within init procs. - - elsif Is_Entity_Name (N) - and then - (Ekind (Entity (N)) = E_Discriminant - or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter) - and then Present (Discriminal_Link (Entity (N))))) - then - return True; - - elsif Nkind (N) = N_Qualified_Expression then - return Is_Preelaborable_Expression (Expression (N)); - - -- For aggregates we have to check that each of the associations - -- is preelaborable. - - elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then - Is_Array_Aggr := Is_Array_Type (Etype (N)); - - if Is_Array_Aggr then - Comp_Type := Component_Type (Etype (N)); - end if; - - -- Check the ancestor part of extension aggregates, which must - -- be either the name of a type that has preelaborable init or - -- an expression that is preelaborable. - - if Nkind (N) = N_Extension_Aggregate then - declare - Anc_Part : constant Node_Id := Ancestor_Part (N); - - begin - if Is_Entity_Name (Anc_Part) - and then Is_Type (Entity (Anc_Part)) - then - if not Has_Preelaborable_Initialization - (Entity (Anc_Part)) - then - return False; - end if; - - elsif not Is_Preelaborable_Expression (Anc_Part) then - return False; - end if; - end; - end if; - - -- Check positional associations - - Exp := First (Expressions (N)); - while Present (Exp) loop - if not Is_Preelaborable_Expression (Exp) then - return False; - end if; - - Next (Exp); - end loop; - - -- Check named associations - - Assn := First (Component_Associations (N)); - while Present (Assn) loop - Choice := First (Choices (Assn)); - while Present (Choice) loop - if Is_Array_Aggr then - if Nkind (Choice) = N_Others_Choice then - null; - - elsif Nkind (Choice) = N_Range then - if not Is_OK_Static_Range (Choice) then - return False; - end if; - - elsif not Is_OK_Static_Expression (Choice) then - return False; - end if; - - else - Comp_Type := Etype (Choice); - end if; - - Next (Choice); - end loop; - - -- If the association has a <> at this point, then we have - -- to check whether the component's type has preelaborable - -- initialization. Note that this only occurs when the - -- association's corresponding component does not have a - -- default expression, the latter case having already been - -- expanded as an expression for the association. - - if Box_Present (Assn) then - if not Has_Preelaborable_Initialization (Comp_Type) then - return False; - end if; - - -- In the expression case we check whether the expression - -- is preelaborable. - - elsif - not Is_Preelaborable_Expression (Expression (Assn)) - then - return False; - end if; - - Next (Assn); - end loop; - - -- If we get here then aggregate as a whole is preelaborable - - return True; - - -- All other cases are not preelaborable - - else - return False; - end if; - end Is_Preelaborable_Expression; - - -- Start of processing for Check_Components - begin -- Loop through entities of record or protected type @@ -10969,7 +11036,7 @@ package body Sem_Util is -- Require the default expression to be preelaborable - elsif not Is_Preelaborable_Expression (Exp) then + elsif not Is_Preelaborable_Construct (Exp) then Has_PE := False; exit; end if; @@ -11714,21 +11781,23 @@ package body Sem_Util is -- In_Instance_Visible_Part -- ------------------------------ - function In_Instance_Visible_Part return Boolean is - S : Entity_Id; + function In_Instance_Visible_Part + (Id : Entity_Id := Current_Scope) return Boolean + is + Inst : Entity_Id; begin - S := Current_Scope; - while Present (S) and then S /= Standard_Standard loop - if Ekind (S) = E_Package - and then Is_Generic_Instance (S) - and then not In_Package_Body (S) - and then not In_Private_Part (S) + Inst := Id; + while Present (Inst) and then Inst /= Standard_Standard loop + if Ekind (Inst) = E_Package + and then Is_Generic_Instance (Inst) + and then not In_Package_Body (Inst) + and then not In_Private_Part (Inst) then return True; end if; - S := Scope (S); + Inst := Scope (Inst); end loop; return False; @@ -11887,7 +11956,7 @@ package body Sem_Util is -- In_Subtree -- ---------------- - function In_Subtree (Root : Node_Id; N : Node_Id) return Boolean is + function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is Curr : Node_Id; begin @@ -11903,6 +11972,30 @@ package body Sem_Util is return False; end In_Subtree; + ---------------- + -- In_Subtree -- + ---------------- + + function In_Subtree + (N : Node_Id; + Root1 : Node_Id; + Root2 : Node_Id) return Boolean + is + Curr : Node_Id; + + begin + Curr := N; + while Present (Curr) loop + if Curr = Root1 or else Curr = Root2 then + return True; + end if; + + Curr := Parent (Curr); + end loop; + + return False; + end In_Subtree; + --------------------- -- In_Visible_Part -- --------------------- @@ -15287,6 +15380,162 @@ package body Sem_Util is end if; end Is_Potentially_Unevaluated; + -------------------------------- + -- Is_Preelaborable_Aggregate -- + -------------------------------- + + function Is_Preelaborable_Aggregate (Aggr : Node_Id) return Boolean is + Aggr_Typ : constant Entity_Id := Etype (Aggr); + Array_Aggr : constant Boolean := Is_Array_Type (Aggr_Typ); + + Anc_Part : Node_Id; + Assoc : Node_Id; + Choice : Node_Id; + Comp_Typ : Entity_Id; + Expr : Node_Id; + + begin + if Array_Aggr then + Comp_Typ := Component_Type (Aggr_Typ); + end if; + + -- Inspect the ancestor part + + if Nkind (Aggr) = N_Extension_Aggregate then + Anc_Part := Ancestor_Part (Aggr); + + -- The ancestor denotes a subtype mark + + if Is_Entity_Name (Anc_Part) + and then Is_Type (Entity (Anc_Part)) + then + if not Has_Preelaborable_Initialization (Entity (Anc_Part)) then + return False; + end if; + + -- Otherwise the ancestor denotes an expression + + elsif not Is_Preelaborable_Construct (Anc_Part) then + return False; + end if; + end if; + + -- Inspect the positional associations + + Expr := First (Expressions (Aggr)); + while Present (Expr) loop + if not Is_Preelaborable_Construct (Expr) then + return False; + end if; + + Next (Expr); + end loop; + + -- Inspect the named associations + + Assoc := First (Component_Associations (Aggr)); + while Present (Assoc) loop + + -- Inspect the choices of the current named association + + Choice := First (Choices (Assoc)); + while Present (Choice) loop + if Array_Aggr then + + -- For a choice to be preelaborable, it must denote either a + -- static range or a static expression. + + if Nkind (Choice) = N_Others_Choice then + null; + + elsif Nkind (Choice) = N_Range then + if not Is_OK_Static_Range (Choice) then + return False; + end if; + + elsif not Is_OK_Static_Expression (Choice) then + return False; + end if; + + else + Comp_Typ := Etype (Choice); + end if; + + Next (Choice); + end loop; + + -- The type of the choice must have preelaborable initialization if + -- the association carries a <>. + + if Box_Present (Assoc) then + if not Has_Preelaborable_Initialization (Comp_Typ) then + return False; + end if; + + -- The type of the expression must have preelaborable initialization + + elsif not Is_Preelaborable_Construct (Expression (Assoc)) then + return False; + end if; + + Next (Assoc); + end loop; + + -- At this point the aggregate is preelaborable + + return True; + end Is_Preelaborable_Aggregate; + + -------------------------------- + -- Is_Preelaborable_Construct -- + -------------------------------- + + function Is_Preelaborable_Construct (N : Node_Id) return Boolean is + begin + -- Aggregates + + if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then + return Is_Preelaborable_Aggregate (N); + + -- Attributes are allowed in general, even if their prefix is a formal + -- type. It seems that certain attributes known not to be static might + -- not be allowed, but there are no rules to prevent them. + + elsif Nkind (N) = N_Attribute_Reference then + return True; + + -- Expressions + + elsif Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then + return True; + + elsif Nkind (N) = N_Qualified_Expression then + return Is_Preelaborable_Construct (Expression (N)); + + -- Names are preelaborable when they denote a discriminant of an + -- enclosing type. Discriminals are also considered for this check. + + elsif Is_Entity_Name (N) + and then Present (Entity (N)) + and then + (Ekind (Entity (N)) = E_Discriminant + or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter) + and then Present (Discriminal_Link (Entity (N))))) + then + return True; + + -- Statements + + elsif Nkind (N) = N_Null then + return True; + + -- Otherwise the construct is not preelaborable + + else + return False; + end if; + end Is_Preelaborable_Construct; + --------------------------------- -- Is_Protected_Self_Reference -- --------------------------------- @@ -16941,6 +17190,306 @@ package body Sem_Util is return N; end Last_Source_Statement; + ----------------------- + -- Mark_Coextensions -- + ----------------------- + + procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is + Is_Dynamic : Boolean; + -- Indicates whether the context causes nested coextensions to be + -- dynamic or static + + function Mark_Allocator (N : Node_Id) return Traverse_Result; + -- Recognize an allocator node and label it as a dynamic coextension + + -------------------- + -- Mark_Allocator -- + -------------------- + + function Mark_Allocator (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Allocator then + if Is_Dynamic then + Set_Is_Dynamic_Coextension (N); + + -- If the allocator expression is potentially dynamic, it may + -- be expanded out of order and require dynamic allocation + -- anyway, so we treat the coextension itself as dynamic. + -- Potential optimization ??? + + elsif Nkind (Expression (N)) = N_Qualified_Expression + and then Nkind (Expression (Expression (N))) = N_Op_Concat + then + Set_Is_Dynamic_Coextension (N); + else + Set_Is_Static_Coextension (N); + end if; + end if; + + return OK; + end Mark_Allocator; + + procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator); + + -- Start of processing for Mark_Coextensions + + begin + -- An allocator that appears on the right-hand side of an assignment is + -- treated as a potentially dynamic coextension when the right-hand side + -- is an allocator or a qualified expression. + + -- Obj := new ...'(new Coextension ...); + + if Nkind (Context_Nod) = N_Assignment_Statement then + Is_Dynamic := + Nkind_In (Expression (Context_Nod), 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 + -- expression is either aggregate, allocator, or qualified expression. + + -- return (new Coextension ...); + -- 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); + + -- An alloctor that appears within the initialization expression of an + -- object declaration is considered a potentially dynamic coextension + -- when the initialization expression is an allocator or a qualified + -- expression. + + -- Obj : ... := new ...'(new Coextension ...); + + -- A similar case arises when the object declaration is part of an + -- extended return statement. + + -- return Obj : ... := new ...'(new Coextension ...); + -- 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; + + -- This routine should not be called with constructs that cannot contain + -- coextensions. + + else + raise Program_Error; + end if; + + Mark_Allocators (Root_Nod); + end Mark_Coextensions; + + --------------------------------- + -- Mark_Elaboration_Attributes -- + --------------------------------- + + procedure Mark_Elaboration_Attributes + (N_Id : Node_Or_Entity_Id; + Checks : Boolean := False; + Level : Boolean := False; + Modes : Boolean := False) + is + function Elaboration_Checks_OK + (Target_Id : Entity_Id; + Context_Id : Entity_Id) return Boolean; + -- Determine whether elaboration checks are enabled for target Target_Id + -- which resides within context Context_Id. + + procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id); + -- Preserve relevant attributes of the context in arbitrary entity Id + + procedure Mark_Elaboration_Attributes_Node (N : Node_Id); + -- Preserve relevant attributes of the context in arbitrary node N + + --------------------------- + -- Elaboration_Checks_OK -- + --------------------------- + + function Elaboration_Checks_OK + (Target_Id : Entity_Id; + Context_Id : Entity_Id) return Boolean + is + Encl_Scop : Entity_Id; + + begin + -- Elaboration checks are suppressed for the target + + if Elaboration_Checks_Suppressed (Target_Id) then + return False; + end if; + + -- Otherwise elaboration checks are OK for the target, but may be + -- suppressed for the context where the target is declared. + + Encl_Scop := Context_Id; + while Present (Encl_Scop) and then Encl_Scop /= Standard_Standard loop + if Elaboration_Checks_Suppressed (Encl_Scop) then + return False; + end if; + + Encl_Scop := Scope (Encl_Scop); + end loop; + + -- Neither the target nor its declarative context have elaboration + -- checks suppressed. + + return True; + end Elaboration_Checks_OK; + + ------------------------------------ + -- Mark_Elaboration_Attributes_Id -- + ------------------------------------ + + procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id) is + begin + -- Mark the status of elaboration checks in effect. Do not reset the + -- status in case the entity is reanalyzed with checks suppressed. + + if Checks and then not Is_Elaboration_Checks_OK_Id (Id) then + Set_Is_Elaboration_Checks_OK_Id (Id, + Elaboration_Checks_OK + (Target_Id => Id, + Context_Id => Scope (Id))); + + -- Entities do not need to capture their enclosing level. The Ghost + -- and SPARK modes in effect are already marked during analysis. + + else + null; + end if; + end Mark_Elaboration_Attributes_Id; + + -------------------------------------- + -- Mark_Elaboration_Attributes_Node -- + -------------------------------------- + + procedure Mark_Elaboration_Attributes_Node (N : Node_Id) is + function Extract_Name (N : Node_Id) return Node_Id; + -- Obtain the Name attribute of call or instantiation N + + ------------------ + -- Extract_Name -- + ------------------ + + function Extract_Name (N : Node_Id) return Node_Id is + Nam : Node_Id; + + begin + Nam := Name (N); + + -- A call to an entry family appears in indexed form + + if Nkind (Nam) = N_Indexed_Component then + Nam := Prefix (Nam); + end if; + + -- The name may also appear in qualified form + + if Nkind (Nam) = N_Selected_Component then + Nam := Selector_Name (Nam); + end if; + + return Nam; + end Extract_Name; + + -- Local variables + + Context_Id : Entity_Id; + Nam : Node_Id; + + -- Start of processing for Mark_Elaboration_Attributes_Node + + begin + -- Mark the status of elaboration checks in effect. Do not reset the + -- status in case the node is reanalyzed with checks suppressed. + + if Checks and then not Is_Elaboration_Checks_OK_Node (N) then + + -- Assignments, attribute references, and variable references do + -- not have a "declarative" context. + + Context_Id := Empty; + + -- The status of elaboration checks for calls and instantiations + -- depends on the most recent pragma Suppress/Unsuppress, as well + -- as the suppression status of the context where the target is + -- defined. + + -- package Pack is + -- function Func ...; + -- end Pack; + + -- with Pack; + -- procedure Main is + -- pragma Suppress (Elaboration_Checks, Pack); + -- X : ... := Pack.Func; + -- ... + + -- In the example above, the call to Func has elaboration checks + -- enabled because there is no active general purpose suppression + -- pragma, however the elaboration checks of Pack are explicitly + -- 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) + then + Nam := Extract_Name (N); + + if Is_Entity_Name (Nam) and then Present (Entity (Nam)) then + Context_Id := Scope (Entity (Nam)); + end if; + end if; + + Set_Is_Elaboration_Checks_OK_Node (N, + Elaboration_Checks_OK + (Target_Id => Empty, + Context_Id => Context_Id)); + end if; + + -- Mark the enclosing level of the node. Do not reset the status in + -- case the node is relocated and reanalyzed. + + if Level and then not Is_Declaration_Level_Node (N) then + Set_Is_Declaration_Level_Node (N, + Find_Enclosing_Level (N) = Declaration_Level); + end if; + + -- Mark the Ghost and SPARK mode in effect + + if Modes then + if Ghost_Mode = Ignore then + Set_Is_Ignored_Ghost_Node (N); + end if; + + if SPARK_Mode = On then + Set_Is_SPARK_Mode_On_Node (N); + end if; + end if; + end Mark_Elaboration_Attributes_Node; + + -- Start of processing for Mark_Elaboration_Attributes + + begin + if Nkind (N_Id) in N_Entity then + Mark_Elaboration_Attributes_Id (N_Id); + else + Mark_Elaboration_Attributes_Node (N_Id); + end if; + end Mark_Elaboration_Attributes; + ---------------------------------- -- Matching_Static_Array_Bounds -- ---------------------------------- @@ -17245,103 +17794,6 @@ package body Sem_Util is end case; end May_Be_Lvalue; - ----------------------- - -- Mark_Coextensions -- - ----------------------- - - procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is - Is_Dynamic : Boolean; - -- Indicates whether the context causes nested coextensions to be - -- dynamic or static - - function Mark_Allocator (N : Node_Id) return Traverse_Result; - -- Recognize an allocator node and label it as a dynamic coextension - - -------------------- - -- Mark_Allocator -- - -------------------- - - function Mark_Allocator (N : Node_Id) return Traverse_Result is - begin - if Nkind (N) = N_Allocator then - if Is_Dynamic then - Set_Is_Dynamic_Coextension (N); - - -- If the allocator expression is potentially dynamic, it may - -- be expanded out of order and require dynamic allocation - -- anyway, so we treat the coextension itself as dynamic. - -- Potential optimization ??? - - elsif Nkind (Expression (N)) = N_Qualified_Expression - and then Nkind (Expression (Expression (N))) = N_Op_Concat - then - Set_Is_Dynamic_Coextension (N); - else - Set_Is_Static_Coextension (N); - end if; - end if; - - return OK; - end Mark_Allocator; - - procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator); - - -- Start of processing for Mark_Coextensions - - begin - -- An allocator that appears on the right-hand side of an assignment is - -- treated as a potentially dynamic coextension when the right-hand side - -- is an allocator or a qualified expression. - - -- Obj := new ...'(new Coextension ...); - - if Nkind (Context_Nod) = N_Assignment_Statement then - Is_Dynamic := - Nkind_In (Expression (Context_Nod), 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 - -- expression is either aggregate, allocator, or qualified expression. - - -- return (new Coextension ...); - -- 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); - - -- An allocator that appears within the initialization expression of an - -- object declaration is considered a potentially dynamic coextension - -- when the initialization expression is an allocator or a qualified - -- expression. - - -- Obj : ... := new ...'(new Coextension ...); - - -- A similar case arises when the object declaration is part of an - -- extended return statement. - - -- return Obj : ... := new ...'(new Coextension ...); - -- 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; - - -- This routine should not be called with constructs that cannot contain - -- coextensions. - - else - raise Program_Error; - end if; - - Mark_Allocators (Root_Nod); - end Mark_Coextensions; - ----------------- -- Might_Raise -- ----------------- @@ -18508,8 +18960,8 @@ package body Sem_Util is -- the subtree being replicated. elsif not In_Subtree - (Root => Source, - N => Declaration_Node (Id)) + (N => Declaration_Node (Id), + Root => Source) then return; end if; @@ -18653,8 +19105,8 @@ package body Sem_Util is -- the subtree being replicated. elsif not In_Subtree - (Root => Source, - N => Associated_Node_For_Itype (Itype)) + (N => Associated_Node_For_Itype (Itype), + Root => Source) then return; end if; @@ -21986,15 +22438,18 @@ package body Sem_Util is -- Scope_Within -- ------------------ - function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is - Scop : Entity_Id; + function Scope_Within + (Inner : Entity_Id; + Outer : Entity_Id) return Boolean + is + Curr : Entity_Id; begin - Scop := Scope1; - while Scop /= Standard_Standard loop - Scop := Scope (Scop); + Curr := Inner; + while Present (Curr) and then Curr /= Standard_Standard loop + Curr := Scope (Curr); - if Scop = Scope2 then + if Curr = Outer then return True; end if; end loop; @@ -22006,17 +22461,20 @@ package body Sem_Util is -- Scope_Within_Or_Same -- -------------------------- - function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is - Scop : Entity_Id; + function Scope_Within_Or_Same + (Inner : Entity_Id; + Outer : Entity_Id) return Boolean + is + Curr : Entity_Id; begin - Scop := Scope1; - while Scop /= Standard_Standard loop - if Scop = Scope2 then + Curr := Inner; + while Present (Curr) and then Curr /= Standard_Standard loop + if Curr = Outer then return True; - else - Scop := Scope (Scop); end if; + + Curr := Scope (Curr); end loop; return False; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 30c35cb1591..2ebd54f3989 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -202,6 +202,10 @@ package Sem_Util is -- given, and the reference N is not in the same extended source unit as -- the declaration of T. + function Begin_Keyword_Location (N : Node_Id) return Source_Ptr; + -- Given block statement, entry body, package body, subprogram body, or + -- task body N, return the closest source location to the "begin" keyword. + function Build_Actual_Subtype (T : Entity_Id; N : Node_Or_Entity_Id) return Node_Id; @@ -547,8 +551,9 @@ package Sem_Util is -- instead of 0). function Defining_Entity - (N : Node_Id; - Empty_On_Errors : Boolean := False) return Entity_Id; + (N : Node_Id; + Empty_On_Errors : Boolean := False; + Concurrent_Subunit : Boolean := False) return Entity_Id; -- Given a declaration N, returns the associated defining entity. If the -- declaration has a specification, the entity is obtained from the -- specification. If the declaration has a defining unit name, then the @@ -572,6 +577,9 @@ package Sem_Util is -- -- The former semantics is appropriate for the back end; the latter -- semantics is appropriate for the front end. + -- + -- Set flag Concurrent_Subunit to handle rewritings of concurrent bodies + -- which act as subunits. Such bodies are generally rewritten as null. function Denotes_Discriminant (N : Node_Id; @@ -685,6 +693,12 @@ package Sem_Util is -- Utility function to return the Ada entity of the subprogram enclosing -- the entity E, if any. Returns Empty if no enclosing subprogram. + function End_Keyword_Location (N : Node_Id) return Source_Ptr; + -- Given block statement, entry body, package body, package declaration, + -- protected body, [single] protected type declaration, subprogram body, + -- task body, or [single] task type declaration N, return the closest + -- source location of the "end" keyword. + procedure Ensure_Freeze_Node (E : Entity_Id); -- Make sure a freeze node is allocated for entity E. If necessary, build -- and initialize a new freeze node and set Has_Delayed_Freeze True for E. @@ -740,12 +754,6 @@ package Sem_Util is -- Call is set to the node for the corresponding call. If the node N is not -- an actual parameter then Formal and Call are set to Empty. - function Find_Specific_Type (CW : Entity_Id) return Entity_Id; - -- Find specific type of a class-wide type, and handle the case of an - -- incomplete type coming either from a limited_with clause or from an - -- incomplete type declaration. If resulting type is private return its - -- full view. - function Find_Body_Discriminal (Spec_Discriminant : Entity_Id) return Entity_Id; -- Given a discriminant of the record type that implements a task or @@ -762,9 +770,12 @@ package Sem_Util is -- discriminant at the same position in this new type. function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id; - -- Given an arbitrary entity, try to find the nearest enclosing iterator - -- loop. If such a loop is found, return the entity of its identifier (the - -- E_Loop scope), otherwise return Empty. + -- Find the nearest iterator loop which encloses arbitrary entity Id. If + -- such a loop exists, return the entity of its identifier (E_Loop scope), + -- otherwise return Empty. + + function Find_Enclosing_Scope (N : Node_Id) return Entity_Id; + -- Find the nearest scope which encloses arbitrary node N function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id; -- Find the nested loop statement in a conditional block. Loops subject to @@ -868,6 +879,12 @@ package Sem_Util is -- If the state space is that of a package, Pack_Id denotes its entity, -- otherwise Pack_Id is Empty. + function Find_Specific_Type (CW : Entity_Id) return Entity_Id; + -- Find specific type of a class-wide type, and handle the case of an + -- incomplete type coming either from a limited_with clause or from an + -- incomplete type declaration. If resulting type is private return its + -- full view. + function Find_Static_Alternative (N : Node_Id) return Node_Id; -- N is a case statement whose expression is a compile-time value. -- Determine the alternative chosen, so that the code of non-selected @@ -1134,8 +1151,7 @@ package Sem_Util is -- subprogram or entry and returns it, or if no subprogram can be found, -- returns Empty. - function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id; - pragma Inline (Get_Task_Body_Procedure); + function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id; -- Given an entity for a task type or subtype, retrieves the -- Task_Body_Procedure field from the corresponding task type declaration. @@ -1259,14 +1275,14 @@ package Sem_Util is -- as expressed in pragma Refined_State. This function does not take into -- account the visible refinement region of abstract state Id. - function Has_Null_Body (Proc_Id : Entity_Id) return Boolean; - -- Determine whether the body of procedure Proc_Id contains a sole - -- null statement, possibly followed by an optional return. Used to - -- optimize useless calls to assertion checks. + function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean; + -- Determine whether subprogram Subp has a class-wide precondition that is + -- not statically True. - function Has_Non_Trivial_Precondition (P : Entity_Id) return Boolean; - -- True if subprogram has a class-wide precondition that is not - -- statically True. + function Has_Null_Body (Proc_Id : Entity_Id) return Boolean; + -- Determine whether the body of procedure Proc_Id contains a sole null + -- statement, possibly followed by an optional return. Used to optimize + -- useless calls to assertion checks. function Has_Null_Exclusion (N : Node_Id) return Boolean; -- Determine whether node N has a null exclusion @@ -1357,9 +1373,10 @@ package Sem_Util is -- Returns True if current scope is with the private part or the body of -- an instance. Other semantic checks are suppressed in this context. - function In_Instance_Visible_Part return Boolean; - -- Returns True if current scope is within the visible part of a package - -- instance, where several additional semantic checks apply. + function In_Instance_Visible_Part + (Id : Entity_Id := Current_Scope) return Boolean; + -- Returns True if arbitrary entity Id is within the visible part of a + -- package instance, where several additional semantic checks apply. function In_Package_Body return Boolean; -- Returns True if current scope is within a package body @@ -1382,9 +1399,17 @@ package Sem_Util is -- appearing anywhere within such a construct (that is it does not need -- to be directly within). - function In_Subtree (Root : Node_Id; N : Node_Id) return Boolean; + function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean; -- Determine whether node N is within the subtree rooted at Root + function In_Subtree + (N : Node_Id; + Root1 : Node_Id; + Root2 : Node_Id) return Boolean; + -- Determine whether node N is within the subtree rooted at Root1 or Root2. + -- This version is more efficient than calling the single root version of + -- Is_Subtree twice. + function In_Visible_Part (Scope_Id : Entity_Id) return Boolean; -- Determine whether a declaration occurs within the visible part of a -- package specification. The package must be on the scope stack, and the @@ -1765,6 +1790,14 @@ package Sem_Util is -- persistent. A private type is potentially persistent if the full type -- is potentially persistent. + function Is_Preelaborable_Aggregate (Aggr : Node_Id) return Boolean; + -- Determine whether aggregate Aggr violates the restrictions of + -- preelaborable constructs as defined in ARM 10.2.1(5-9). + + function Is_Preelaborable_Construct (N : Node_Id) return Boolean; + -- Determine whether arbitrary node N violates the restrictions of + -- preelaborable constructs as defined in ARM 10.2.1(5-9). + function Is_Protected_Self_Reference (N : Node_Id) return Boolean; -- Return True if node N denotes a protected type name which represents -- the current instance of a protected object according to RM 9.4(21/2). @@ -2028,6 +2061,24 @@ package Sem_Util is -- statement in Statements (HSS) that has Comes_From_Source set. If no -- such statement exists, Empty is returned. + procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id); + -- Given a node which designates the context of analysis and an origin in + -- the tree, traverse from Root_Nod and mark all allocators as either + -- dynamic or static depending on Context_Nod. Any incorrect marking is + -- cleaned up during resolution. + + procedure Mark_Elaboration_Attributes + (N_Id : Node_Or_Entity_Id; + Checks : Boolean := False; + Level : Boolean := False; + Modes : Boolean := False); + -- Preserve relevant elaboration-related properties of the context in + -- arbitrary entity or node N_Id. When flag Checks is set, the routine + -- saves the status of Elaboration_Check. When flag Level is set, the + -- routine captures the declaration level of N_Id if applicable. When + -- flag Modes is set, the routine saves the Ghost and SPARK modes in + -- effect if applicable. + function Matching_Static_Array_Bounds (L_Typ : Node_Id; R_Typ : Node_Id) return Boolean; @@ -2035,12 +2086,6 @@ package Sem_Util is -- same number of dimensions, and the same static bounds for each index -- position. - procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id); - -- Given a node which designates the context of analysis and an origin in - -- the tree, traverse from Root_Nod and mark all allocators as either - -- dynamic or static depending on Context_Nod. Any incorrect marking is - -- cleaned up during resolution. - function May_Be_Lvalue (N : Node_Id) return Boolean; -- Determines if N could be an lvalue (e.g. an assignment left hand side). -- An lvalue is defined as any expression which appears in a context where @@ -2460,15 +2505,19 @@ package Sem_Util is -- this is the case, and False if no scalar parts are present (meaning that -- the result of Valid_Scalars applied to T is always vacuously True). - function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean; - -- Determines if the entity Scope1 is the same as Scope2, or if it is - -- inside it, where both entities represent scopes. Note that scopes - -- are only partially ordered, so Scope_Within_Or_Same (A,B) and - -- Scope_Within_Or_Same (B,A) can both be False for a given pair A,B. - - function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean; - -- Like Scope_Within_Or_Same, except that this function returns - -- False in the case where Scope1 and Scope2 are the same scope. + function Scope_Within + (Inner : Entity_Id; + Outer : Entity_Id) return Boolean; + -- Determine whether scope Inner appears within scope Outer. Note that + -- scopes are partially ordered, so Scope_Within (A, B) and Scope_Within + -- (B, A) may both return False. + + function Scope_Within_Or_Same + (Inner : Entity_Id; + Outer : Entity_Id) return Boolean; + -- Determine whether scope Inner appears within scope Outer or both renote + -- the same scope. Note that scopes are partially ordered, so Scope_Within + -- (A, B) and Scope_Within (B, A) may both return False. procedure Set_Convention (E : Entity_Id; Val : Convention_Id); -- Same as Basic_Set_Convention, but with an extra check for access types. diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index f20d9df5a9d..aae54547268 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -248,6 +248,10 @@ package body Sem_Warn is -- If so, Ref is set to point to the reference node, and Var is set to -- the referenced Entity. + function Has_Condition_Actions (Iter : Node_Id) return Boolean; + -- Determine whether iteration scheme Iter has meaningful condition + -- actions. + function Has_Indirection (T : Entity_Id) return Boolean; -- If the controlling variable is an access type, or is a record type -- with access components, assume that it is changed indirectly and @@ -360,6 +364,29 @@ package body Sem_Warn is end if; end Find_Var; + --------------------------- + -- Has_Condition_Actions -- + --------------------------- + + function Has_Condition_Actions (Iter : Node_Id) return Boolean is + Action : Node_Id; + + begin + -- A call marker is not considered a meaningful action because it + -- acts as an annotation and has no runtime semantics. + + Action := First (Condition_Actions (Iter)); + while Present (Action) loop + if Nkind (Action) /= N_Call_Marker then + return True; + end if; + + Next (Action); + end loop; + + return False; + end Has_Condition_Actions; + --------------------- -- Has_Indirection -- --------------------- @@ -597,7 +624,7 @@ package body Sem_Warn is -- Skip processing for while iteration with conditions actions, -- since they make it too complicated to get the warning right. - if Present (Condition_Actions (Iter)) then + if Has_Condition_Actions (Iter) then return; end if; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 4eb1c8c6f47..e4f8608eb73 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -61,19 +61,6 @@ package body Sinfo is -- uniform format of the conditions following this. Note that csinfo -- expects this uniform format. - function ABE_Is_Certain - (N : Node_Id) return Boolean is - begin - pragma Assert (False - or else NT (N).Nkind = N_Formal_Package_Declaration - or else NT (N).Nkind = N_Function_Call - or else NT (N).Nkind = N_Function_Instantiation - or else NT (N).Nkind = N_Package_Instantiation - or else NT (N).Nkind = N_Procedure_Call_Statement - or else NT (N).Nkind = N_Procedure_Instantiation); - return Flag18 (N); - end ABE_Is_Certain; - function Abort_Present (N : Node_Id) return Boolean is begin @@ -439,7 +426,7 @@ package body Sinfo is end Classifications; function Cleanup_Actions - (N : Node_Id) return List_Id is + (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Block_Statement); @@ -447,7 +434,7 @@ package body Sinfo is end Cleanup_Actions; function Comes_From_Extended_Return_Statement - (N : Node_Id) return Boolean is + (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Simple_Return_Statement); @@ -951,7 +938,7 @@ package body Sinfo is or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_Selected_Component or else NT (N).Nkind = N_Type_Conversion); - return Flag1 (N); + return Flag3 (N); end Do_Discriminant_Check; function Do_Division_Check @@ -1856,14 +1843,16 @@ package body Sinfo is return Flag16 (N); end Is_Controlling_Actual; - function Is_Disabled + function Is_Declaration_Level_Node (N : Node_Id) return Boolean is begin pragma Assert (False - or else NT (N).Nkind = N_Aspect_Specification - or else NT (N).Nkind = N_Pragma); - return Flag15 (N); - end Is_Disabled; + or else NT (N).Nkind = N_Call_Marker + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Procedure_Instantiation); + return Flag5 (N); + end Is_Declaration_Level_Node; function Is_Delayed_Aspect (N : Node_Id) return Boolean is @@ -1875,6 +1864,23 @@ package body Sinfo is return Flag14 (N); end Is_Delayed_Aspect; + function Is_Disabled + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Pragma); + return Flag15 (N); + end Is_Disabled; + + function Is_Dispatching_Call + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Call_Marker); + return Flag3 (N); + end Is_Dispatching_Call; + function Is_Dynamic_Coextension (N : Node_Id) return Boolean is begin @@ -1892,8 +1898,27 @@ package body Sinfo is return Flag1 (N); end Is_Effective_Use_Clause; + function Is_Elaboration_Checks_OK_Node + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_Attribute_Reference + or else NT (N).Nkind = N_Call_Marker + or else NT (N).Nkind = N_Entry_Call_Statement + or else NT (N).Nkind = N_Expanded_Name + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Identifier + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Procedure_Call_Statement + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Requeue_Statement); + return Flag1 (N); + end Is_Elaboration_Checks_OK_Node; + function Is_Elsif - (N : Node_Id) return Boolean is + (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_If_Expression); @@ -1982,6 +2007,25 @@ package body Sinfo is return Flag4 (N); end Is_Inherited_Pragma; + function Is_Initialization_Block + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement); + return Flag1 (N); + end Is_Initialization_Block; + + function Is_Known_Guaranteed_ABE + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Call_Marker + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Procedure_Instantiation); + return Flag18 (N); + end Is_Known_Guaranteed_ABE; + function Is_Machine_Number (N : Node_Id) return Boolean is begin @@ -2038,6 +2082,44 @@ package body Sinfo is return Flag4 (N); end Is_Qualified_Universal_Literal; + function Is_Recorded_Scenario + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Call_Marker + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Procedure_Instantiation); + return Flag6 (N); + end Is_Recorded_Scenario; + + function Is_Source_Call + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Call_Marker); + return Flag4 (N); + end Is_Source_Call; + + function Is_SPARK_Mode_On_Node + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_Attribute_Reference + or else NT (N).Nkind = N_Call_Marker + or else NT (N).Nkind = N_Entry_Call_Statement + or else NT (N).Nkind = N_Expanded_Name + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Identifier + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Procedure_Call_Statement + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Requeue_Statement); + return Flag2 (N); + end Is_SPARK_Mode_On_Node; + function Is_Static_Coextension (N : Node_Id) return Boolean is begin @@ -2425,15 +2507,6 @@ package body Sinfo is return Flag7 (N); end No_Ctrl_Actions; - function No_Elaboration_Check - (N : Node_Id) return Boolean is - begin - pragma Assert (False - or else NT (N).Nkind = N_Function_Call - or else NT (N).Nkind = N_Procedure_Call_Statement); - return Flag14 (N); - end No_Elaboration_Check; - function No_Entities_Ref_In_Spec (N : Node_Id) return Boolean is begin @@ -2465,7 +2538,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Function_Call); - return Flag1 (N); + return Flag17 (N); end No_Side_Effect_Removal; function No_Truncation @@ -3192,6 +3265,14 @@ package body Sinfo is return Flag15 (N); end Tagged_Present; + function Target + (N : Node_Id) return Entity_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Call_Marker); + return Node1 (N); + end Target; + function Target_Type (N : Node_Id) return Entity_Id is begin @@ -3364,6 +3445,14 @@ package body Sinfo is return Elist2 (N); end Used_Operations; + function Was_Attribute_Reference + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body); + return Flag2 (N); + end Was_Attribute_Reference; + function Was_Expression_Function (N : Node_Id) return Boolean is begin @@ -3395,19 +3484,6 @@ package body Sinfo is -- Field Set Procedures -- -------------------------- - procedure Set_ABE_Is_Certain - (N : Node_Id; Val : Boolean := True) is - begin - pragma Assert (False - or else NT (N).Nkind = N_Formal_Package_Declaration - or else NT (N).Nkind = N_Function_Call - or else NT (N).Nkind = N_Function_Instantiation - or else NT (N).Nkind = N_Package_Instantiation - or else NT (N).Nkind = N_Procedure_Call_Statement - or else NT (N).Nkind = N_Procedure_Instantiation); - Set_Flag18 (N, Val); - end Set_ABE_Is_Certain; - procedure Set_Abort_Present (N : Node_Id; Val : Boolean := True) is begin @@ -4285,7 +4361,7 @@ package body Sinfo is or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_Selected_Component or else NT (N).Nkind = N_Type_Conversion); - Set_Flag1 (N, Val); + Set_Flag3 (N, Val); end Set_Do_Discriminant_Check; procedure Set_Do_Division_Check @@ -5181,6 +5257,17 @@ package body Sinfo is Set_Flag16 (N, Val); end Set_Is_Controlling_Actual; + procedure Set_Is_Declaration_Level_Node + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Call_Marker + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Procedure_Instantiation); + Set_Flag5 (N, Val); + end Set_Is_Declaration_Level_Node; + procedure Set_Is_Delayed_Aspect (N : Node_Id; Val : Boolean := True) is begin @@ -5200,6 +5287,14 @@ package body Sinfo is Set_Flag15 (N, Val); end Set_Is_Disabled; + procedure Set_Is_Dispatching_Call + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Call_Marker); + Set_Flag3 (N, Val); + end Set_Is_Dispatching_Call; + procedure Set_Is_Dynamic_Coextension (N : Node_Id; Val : Boolean := True) is begin @@ -5217,8 +5312,27 @@ package body Sinfo is Set_Flag1 (N, Val); end Set_Is_Effective_Use_Clause; + procedure Set_Is_Elaboration_Checks_OK_Node + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_Attribute_Reference + or else NT (N).Nkind = N_Call_Marker + or else NT (N).Nkind = N_Entry_Call_Statement + or else NT (N).Nkind = N_Expanded_Name + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Identifier + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Procedure_Call_Statement + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Requeue_Statement); + Set_Flag1 (N, Val); + end Set_Is_Elaboration_Checks_OK_Node; + procedure Set_Is_Elsif - (N : Node_Id; Val : Boolean := True) is + (N : Node_Id; Val : Boolean := True) is begin pragma Assert (False or else NT (N).Nkind = N_If_Expression); @@ -5307,6 +5421,25 @@ package body Sinfo is Set_Flag4 (N, Val); end Set_Is_Inherited_Pragma; + procedure Set_Is_Initialization_Block + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Block_Statement); + Set_Flag1 (N, Val); + end Set_Is_Initialization_Block; + + procedure Set_Is_Known_Guaranteed_ABE + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Call_Marker + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Procedure_Instantiation); + Set_Flag18 (N, Val); + end Set_Is_Known_Guaranteed_ABE; + procedure Set_Is_Machine_Number (N : Node_Id; Val : Boolean := True) is begin @@ -5363,6 +5496,44 @@ package body Sinfo is Set_Flag4 (N, Val); end Set_Is_Qualified_Universal_Literal; + procedure Set_Is_Recorded_Scenario + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Call_Marker + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Procedure_Instantiation); + Set_Flag6 (N, Val); + end Set_Is_Recorded_Scenario; + + procedure Set_Is_Source_Call + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Call_Marker); + Set_Flag4 (N, Val); + end Set_Is_Source_Call; + + procedure Set_Is_SPARK_Mode_On_Node + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_Attribute_Reference + or else NT (N).Nkind = N_Call_Marker + or else NT (N).Nkind = N_Entry_Call_Statement + or else NT (N).Nkind = N_Expanded_Name + or else NT (N).Nkind = N_Function_Call + or else NT (N).Nkind = N_Function_Instantiation + or else NT (N).Nkind = N_Identifier + or else NT (N).Nkind = N_Package_Instantiation + or else NT (N).Nkind = N_Procedure_Call_Statement + or else NT (N).Nkind = N_Procedure_Instantiation + or else NT (N).Nkind = N_Requeue_Statement); + Set_Flag2 (N, Val); + end Set_Is_SPARK_Mode_On_Node; + procedure Set_Is_Static_Coextension (N : Node_Id; Val : Boolean := True) is begin @@ -5750,15 +5921,6 @@ package body Sinfo is Set_Flag7 (N, Val); end Set_No_Ctrl_Actions; - procedure Set_No_Elaboration_Check - (N : Node_Id; Val : Boolean := True) is - begin - pragma Assert (False - or else NT (N).Nkind = N_Function_Call - or else NT (N).Nkind = N_Procedure_Call_Statement); - Set_Flag14 (N, Val); - end Set_No_Elaboration_Check; - procedure Set_No_Entities_Ref_In_Spec (N : Node_Id; Val : Boolean := True) is begin @@ -5790,7 +5952,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Function_Call); - Set_Flag1 (N, Val); + Set_Flag17 (N, Val); end Set_No_Side_Effect_Removal; procedure Set_No_Truncation @@ -6517,6 +6679,14 @@ package body Sinfo is Set_Flag15 (N, Val); end Set_Tagged_Present; + procedure Set_Target + (N : Node_Id; Val : Entity_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Call_Marker); + Set_Node1 (N, Val); -- semantic field, no parent set + end Set_Target; + procedure Set_Target_Type (N : Node_Id; Val : Entity_Id) is begin @@ -6689,6 +6859,14 @@ package body Sinfo is Set_Elist2 (N, Val); end Set_Used_Operations; + procedure Set_Was_Attribute_Reference + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Subprogram_Body); + Set_Flag2 (N, Val); + end Set_Was_Attribute_Reference; + procedure Set_Was_Expression_Function (N : Node_Id; Val : Boolean := True) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 0c4dfdf3910..05ac1a30859 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -845,15 +845,6 @@ package Sinfo is -- section describes the usage of the semantic fields, which are used to -- contain additional information determined during semantic analysis. - -- ABE_Is_Certain (Flag18-Sem) - -- This flag is set in an instantiation node or a call node is determined - -- to be sure to raise an ABE. This is used to trigger special handling - -- of such cases, particularly in the instantiation case where we avoid - -- instantiating the body if this flag is set. This flag is also present - -- in an N_Formal_Package_Declaration node since formal package - -- declarations are treated like instantiations, but it is always set to - -- False in this context. - -- Accept_Handler_Records (List5-Sem) -- This field is present only in an N_Accept_Alternative node. It is used -- to temporarily hold the exception handler records from an accept @@ -1159,7 +1150,7 @@ package Sinfo is -- that an accessibility check is required for the parameter. It is -- not yet decided who takes care of this check (TBD ???). - -- Do_Discriminant_Check (Flag1-Sem) + -- Do_Discriminant_Check (Flag3-Sem) -- This flag is set on N_Selected_Component nodes to indicate that a -- discriminant check is required using the discriminant check routine -- associated with the selector. The actual check is generated by the @@ -1663,10 +1654,6 @@ package Sinfo is -- place in the various Analyze_xxx_In_Decl_Part routines which perform -- full analysis. The flag prevents the reanalysis of a delayed pragma. - -- Is_Expanded_Contract (Flag1-Sem) - -- Present in N_Contract nodes. Set if the contract has already undergone - -- expansion activities. - -- Is_Asynchronous_Call_Block (Flag7-Sem) -- A flag set in a Block_Statement node to indicate that it is the -- expansion of an asynchronous entry call. Such a block needs cleanup @@ -1701,6 +1688,12 @@ package Sinfo is -- a dispatching call. It is off in all other cases. See Sem_Disp for -- details of its use. + -- Is_Declaration_Level_Node (Flag5-Sem) + -- Present in call marker and instantiation nodes. Set when the constuct + -- appears within the declarations of a block statement, an entry body, + -- a subprogram body, or a task body. The flag aids the ABE Processing + -- phase to catch certain forms of guaranteed ABEs. + -- Is_Delayed_Aspect (Flag14-Sem) -- Present in N_Pragma and N_Attribute_Definition_Clause nodes which -- come from aspect specifications, where the evaluation of the aspect @@ -1715,6 +1708,10 @@ package Sinfo is -- If this flag is set, the aspect or policy is not analyzed for semantic -- correctness, so any expressions etc will not be marked as analyzed. + -- Is_Dispatching_Call (Flag3-Sem) + -- Present in call marker nodes. Set when the related call which prompted + -- the creation of the marker is dispatching. + -- Is_Dynamic_Coextension (Flag18-Sem) -- Present in allocator nodes, to indicate that this is an allocator -- for an access discriminant of a dynamically allocated object. The @@ -1725,6 +1722,15 @@ package Sinfo is -- Present in both N_Use_Type_Clause and N_Use_Package_Clause to indicate -- a use clause is "used" in the current source. + -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) + -- Present in nodes which represent an elaboration scenario. Those are + -- assignment statement, attribute reference, call marker, entry call + -- statement, expanded name, function call, identifier, instantiation, + -- procedure call statement, and requeue statement nodes. Set when the + -- node appears within a context which allows for the generation of + -- run-time ABE checks. This flag detemines whether the ABE Processing + -- phase generates conditional ABE checks and guaranteed ABE failures. + -- Is_Entry_Barrier_Function (Flag8-Sem) -- This flag is set on N_Subprogram_Declaration and N_Subprogram_Body -- nodes which emulate the barrier function of a protected entry body. @@ -1735,6 +1741,10 @@ package Sinfo is -- actuals to support a build-in-place style of call have been added to -- the call. + -- Is_Expanded_Contract (Flag1-Sem) + -- Present in N_Contract nodes. Set if the contract has already undergone + -- expansion activities. + -- Is_Finalization_Wrapper (Flag9-Sem) -- This flag is present in N_Block_Statement nodes. It is set when the -- block acts as a wrapper of a handled construct which has controlled @@ -1794,6 +1804,19 @@ package Sinfo is -- This flag is set in an N_Pragma node that appears in a N_Contract node -- to indicate that the pragma has been inherited from a parent context. + -- Is_Initialization_Block (Flag1-Sem) + -- Defined in block nodes. Set when the block statement was created by + -- the finalization machinery to wrap initialization statements. This + -- flag aids the ABE Processing phase to suppress the diagnostics of + -- finalization actions in initialization contexts. + + -- Is_Known_Guaranteed_ABE (Flag18-Sem) + -- Present in call markers and instantiations. Set when the elaboration + -- or evaluation of the scenario results in a guaranteed ABE. The flag + -- is used to suppress the instantiation of generic bodies because gigi + -- cannot handle certain forms of premature instantiation, as well as to + -- prevent the reexamination of the node by the ABE Processing phase. + -- Is_Machine_Number (Flag11-Sem) -- This flag is set in an N_Real_Literal node to indicate that the value -- is a machine number. This avoids some unnecessary cases of converting @@ -1839,6 +1862,25 @@ package Sinfo is -- the resolution of accidental overloading of binary or unary operators -- which may occur in instances. + -- Is_Recorded_Scenario (Flag6-Sem) + -- Present in call marker and instantiation nodes. Set when the scenario + -- was saved by the ABE Recording phase. This flag aids the ABE machinery + -- to keep its internal data up-to-date in case the node is transformed + -- by Atree.Rewrite. + + -- Is_Source_Call (Flag4-Sem) + -- Present in call marker nodes. Set when the related call came from + -- source. + + -- Is_SPARK_Mode_On_Node (Flag2-Sem) + -- Present in nodes which represent an elaboration scenario. Those are + -- assignment statement, attribute reference, call marker, entry call + -- statement, expanded name, function call, identifier, instantiation, + -- procedure call statement, and requeue statement nodes. Set when the + -- node appears within a context subject to SPARK_Mode On. This flag + -- determines when the SPARK model of elaboration be activated by the + -- ABE Processing phase. + -- Is_Static_Coextension (Flag14-Sem) -- Present in N_Allocator nodes. Set if the allocator is a coextension -- of an object allocated on the stack rather than the heap. @@ -2040,13 +2082,6 @@ package Sinfo is -- expansions where the generated assignments are initializations, not -- real assignments. - -- No_Elaboration_Check (Flag14-Sem) - -- Present in N_Function_Call and N_Procedure_Call_Statement. Indicates - -- that no elaboration check is needed on the call, because it appears in - -- the context of a local Suppress pragma. This is used on calls within - -- task bodies, where the actual elaboration checks are applied after - -- analysis, when the local scope stack is not present. - -- No_Entities_Ref_In_Spec (Flag8-Sem) -- Present in N_With_Clause nodes. Set if the with clause is on the -- package or subprogram spec where the main unit is the corresponding @@ -2069,7 +2104,7 @@ package Sinfo is -- It is used to indicate that processing for extended overflow checking -- modes is not required (this is used to prevent infinite recursion). - -- No_Side_Effect_Removal (Flag1-Sem) + -- No_Side_Effect_Removal (Flag17-Sem) -- Present in N_Function_Call nodes. Set when a function call does not -- require side effect removal. This attribute suppresses the generation -- of a temporary to capture the result of the function which eventually @@ -2281,6 +2316,10 @@ package Sinfo is -- of a FOR loop is known to be null, or is probably null (loop would -- only execute if invalid values are present). + -- Target (Node1-Sem) + -- Present in call marker nodes. References the entity of the entry, + -- operator, or subprogram invoked by the related call or requeue. + -- Target_Type (Node2-Sem) -- Used in an N_Validate_Unchecked_Conversion node to point to the target -- type entity for the unchecked conversion instantiation which gigi must @@ -2353,6 +2392,12 @@ package Sinfo is -- on exit from the scope of the use_type_clause, in particular in the -- case of Use_All_Type, when those operations several scopes. + -- Was_Attribute_Reference (Flag2-Sem) + -- Present in N_Subprogram_Body. Set to True if the original source is an + -- attribute reference which is an actual in a generic instantiation. The + -- instantiation prologue renames these attributes, and expansion later + -- converts them into subprogram bodies. + -- Was_Expression_Function (Flag18-Sem) -- Present in N_Subprogram_Body. True if the original source had an -- N_Expression_Function, which was converted to the N_Subprogram_Body @@ -2478,9 +2523,11 @@ package Sinfo is -- Entity (Node4-Sem) -- Associated_Node (Node4-Sem) -- Original_Discriminant (Node2-Sem) + -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) + -- Is_SPARK_Mode_On_Node (Flag2-Sem) + -- Has_Private_View (Flag11-Sem) (set in generic units) -- Redundant_Use (Flag13-Sem) -- Atomic_Sync_Required (Flag14-Sem) - -- Has_Private_View (Flag11-Sem) (set in generic units) -- plus fields for expression -------------------------- @@ -2625,20 +2672,20 @@ package Sinfo is -- Corresponding_Aspect (Node3-Sem) (set to Empty if not present) -- Pragma_Identifier (Node4) -- Next_Rep_Item (Node5-Sem) - -- Class_Present (Flag6) set if from Aspect with 'Class - -- From_Aspect_Specification (Flag13-Sem) - -- Import_Interface_Present (Flag16-Sem) + -- Is_Generic_Contract_Pragma (Flag2-Sem) + -- Is_Checked_Ghost_Pragma (Flag3-Sem) + -- Is_Inherited_Pragma (Flag4-Sem) -- Is_Analyzed_Pragma (Flag5-Sem) + -- Class_Present (Flag6) set if from Aspect with 'Class + -- Uneval_Old_Accept (Flag7-Sem) + -- Is_Ignored_Ghost_Pragma (Flag8-Sem) + -- Is_Ignored (Flag9-Sem) -- Is_Checked (Flag11-Sem) - -- Is_Checked_Ghost_Pragma (Flag3-Sem) + -- From_Aspect_Specification (Flag13-Sem) -- Is_Delayed_Aspect (Flag14-Sem) -- Is_Disabled (Flag15-Sem) - -- Is_Generic_Contract_Pragma (Flag2-Sem) - -- Is_Ignored (Flag9-Sem) - -- Is_Ignored_Ghost_Pragma (Flag8-Sem) - -- Is_Inherited_Pragma (Flag4-Sem) + -- Import_Interface_Present (Flag16-Sem) -- Split_PPC (Flag17) set if corresponding aspect had Split_PPC set - -- Uneval_Old_Accept (Flag7-Sem) -- Uneval_Old_Warn (Flag18-Sem) -- Note: we should have a section on what pragmas are passed on to @@ -3780,8 +3827,8 @@ package Sinfo is -- Sloc points to ALL -- Prefix (Node3) -- Actual_Designated_Subtype (Node4-Sem) - -- Atomic_Sync_Required (Flag14-Sem) -- Has_Dereference_Action (Flag13-Sem) + -- Atomic_Sync_Required (Flag14-Sem) -- plus fields for expression ------------------------------- @@ -3847,10 +3894,10 @@ package Sinfo is -- Prefix (Node3) -- Selector_Name (Node2) -- Associated_Node (Node4-Sem) - -- Do_Discriminant_Check (Flag1-Sem) + -- Do_Discriminant_Check (Flag3-Sem) -- Is_In_Discriminant_Check (Flag11-Sem) - -- Is_Prefixed_Call (Flag17-Sem) -- Atomic_Sync_Required (Flag14-Sem) + -- Is_Prefixed_Call (Flag17-Sem) -- plus fields for expression -------------------------- @@ -3943,10 +3990,11 @@ package Sinfo is -- Expressions (List1) (set to No_List if no associated expressions) -- Entity (Node4-Sem) used if the attribute yields a type -- Associated_Node (Node4-Sem) - -- Do_Overflow_Check (Flag17-Sem) + -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) + -- Is_SPARK_Mode_On_Node (Flag2-Sem) -- Header_Size_Added (Flag11-Sem) - -- Must_Be_Byte_Aligned (Flag14-Sem) -- Redundant_Use (Flag13-Sem) + -- Must_Be_Byte_Aligned (Flag14-Sem) -- plus fields for expression -- Note: in Modify_Tree_For_C mode, Max and Min attributes are expanded @@ -4137,7 +4185,7 @@ package Sinfo is ---------------------------------- -- NAMED_ARRAY_AGGREGATE ::= - -- | (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION}) + -- (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION}) -- See Record_Aggregate (4.3.1) for node structure @@ -4674,7 +4722,7 @@ package Sinfo is -- Sloc points to first token of subtype mark -- Subtype_Mark (Node4) -- Expression (Node3) - -- Do_Discriminant_Check (Flag1-Sem) + -- Do_Discriminant_Check (Flag3-Sem) -- Do_Length_Check (Flag4-Sem) -- Float_Truncate (Flag11-Sem) -- Do_Tag_Check (Flag13-Sem) @@ -4839,13 +4887,15 @@ package Sinfo is -- Sloc points to := -- Name (Node2) -- Expression (Node3) - -- Do_Discriminant_Check (Flag1-Sem) - -- Do_Tag_Check (Flag13-Sem) + -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) + -- Is_SPARK_Mode_On_Node (Flag2-Sem) + -- Do_Discriminant_Check (Flag3-Sem) -- Do_Length_Check (Flag4-Sem) -- Forwards_OK (Flag5-Sem) -- Backwards_OK (Flag6-Sem) -- No_Ctrl_Actions (Flag7-Sem) -- Has_Target_Names (Flag8-Sem) + -- Do_Tag_Check (Flag13-Sem) -- Componentwise_Assignment (Flag14-Sem) -- Suppress_Assignment_Checks (Flag18-Sem) @@ -5101,15 +5151,16 @@ package Sinfo is -- Identifier (Node1) block direct name (set to Empty if not present) -- Declarations (List2) (set to No_List if no DECLARE part) -- Handled_Statement_Sequence (Node4) - -- Cleanup_Actions (List5-Sem) - -- Is_Abort_Block (Flag4-Sem) - -- Is_Task_Master (Flag5-Sem) -- Activation_Chain_Entity (Node3-Sem) + -- Cleanup_Actions (List5-Sem) -- Has_Created_Identifier (Flag15) - -- Is_Task_Allocation_Block (Flag6) -- Is_Asynchronous_Call_Block (Flag7) + -- Is_Task_Allocation_Block (Flag6) -- Exception_Junk (Flag8-Sem) + -- Is_Abort_Block (Flag4-Sem) -- Is_Finalization_Wrapper (Flag9-Sem) + -- Is_Initialization_Block (Flag1-Sem) + -- Is_Task_Master (Flag5-Sem) ------------------------- -- 5.7 Exit Statement -- @@ -5273,8 +5324,8 @@ package Sinfo is -- symbol turns out to be a normal string after all. -- Entity (Node4-Sem) -- Associated_Node (Node4-Sem) - -- Has_Private_View (Flag11-Sem) set in generic units. -- Etype (Node5-Sem) + -- Has_Private_View (Flag11-Sem) set in generic units -- Note: the Strval field may be set to No_String for generated -- operator symbols that are known not to be string literals @@ -5399,6 +5450,7 @@ package Sinfo is -- Is_Protected_Subprogram_Body (Flag7-Sem) -- Is_Task_Body_Procedure (Flag1-Sem) -- Is_Task_Master (Flag5-Sem) + -- Was_Attribute_Reference (Flag2-Sem) -- Was_Expression_Function (Flag18-Sem) -- Was_Originally_Stub (Flag13-Sem) @@ -5422,9 +5474,9 @@ package Sinfo is -- actual parameter part) -- First_Named_Actual (Node4-Sem) -- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching) + -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) + -- Is_SPARK_Mode_On_Node (Flag2-Sem) -- Do_Tag_Check (Flag13-Sem) - -- No_Elaboration_Check (Flag14-Sem) - -- ABE_Is_Certain (Flag18-Sem) -- plus fields for expression -- If any IN parameter requires a range check, then the corresponding @@ -5452,11 +5504,11 @@ package Sinfo is -- actual parameter part) -- First_Named_Actual (Node4-Sem) -- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching) - -- No_Side_Effect_Removal (Flag1-Sem) + -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) + -- Is_SPARK_Mode_On_Node (Flag2-Sem) -- Is_Expanded_Build_In_Place_Call (Flag11-Sem) -- Do_Tag_Check (Flag13-Sem) - -- No_Elaboration_Check (Flag14-Sem) - -- ABE_Is_Certain (Flag18-Sem) + -- No_Side_Effect_Removal (Flag17-Sem) -- plus fields for expression -------------------------------- @@ -6165,6 +6217,8 @@ package Sinfo is -- Parameter_Associations (List3) (set to No_List if no -- actual parameter part) -- First_Named_Actual (Node4-Sem) + -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) + -- Is_SPARK_Mode_On_Node (Flag2-Sem) ------------------------------ -- 9.5.4 Requeue Statement -- @@ -6180,6 +6234,8 @@ package Sinfo is -- Sloc points to REQUEUE -- Name (Node2) -- Abort_Present (Flag15) + -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) + -- Is_SPARK_Mode_On_Node (Flag2-Sem) -------------------------- -- 9.6 Delay Statement -- @@ -6975,7 +7031,11 @@ package Sinfo is -- generic actual part) -- Parent_Spec (Node4-Sem) -- Instance_Spec (Node5-Sem) - -- ABE_Is_Certain (Flag18-Sem) + -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) + -- Is_SPARK_Mode_On_Node (Flag2-Sem) + -- Is_Declaration_Level_Node (Flag5-Sem) + -- Is_Recorded_Scenario (Flag6-Sem) + -- Is_Known_Guaranteed_ABE (Flag18-Sem) -- N_Procedure_Instantiation -- Sloc points to PROCEDURE @@ -6985,9 +7045,13 @@ package Sinfo is -- Generic_Associations (List3) (set to No_List if no -- generic actual part) -- Instance_Spec (Node5-Sem) + -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) + -- Is_SPARK_Mode_On_Node (Flag2-Sem) + -- Is_Declaration_Level_Node (Flag5-Sem) + -- Is_Recorded_Scenario (Flag6-Sem) -- Must_Override (Flag14) set if overriding indicator present -- Must_Not_Override (Flag15) set if not_overriding indicator present - -- ABE_Is_Certain (Flag18-Sem) + -- Is_Known_Guaranteed_ABE (Flag18-Sem) -- N_Function_Instantiation -- Sloc points to FUNCTION @@ -6997,9 +7061,13 @@ package Sinfo is -- generic actual part) -- Parent_Spec (Node4-Sem) -- Instance_Spec (Node5-Sem) + -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) + -- Is_SPARK_Mode_On_Node (Flag2-Sem) + -- Is_Declaration_Level_Node (Flag5-Sem) + -- Is_Recorded_Scenario (Flag6-Sem) -- Must_Override (Flag14) set if overriding indicator present -- Must_Not_Override (Flag15) set if not_overriding indicator present - -- ABE_Is_Certain (Flag18-Sem) + -- Is_Known_Guaranteed_ABE (Flag18-Sem) -- Note: overriding indicator is an Ada 2005 feature @@ -7312,7 +7380,6 @@ package Sinfo is -- empty generic actual part) -- Box_Present (Flag15) -- Instance_Spec (Node5-Sem) - -- ABE_Is_Certain (Flag18-Sem) -------------------------------------- -- 12.7 Formal Package Actual Part -- @@ -7722,6 +7789,42 @@ package Sinfo is -- reconstructed tree printed by Sprint, and the node descriptions here -- show this syntax. + ----------------- + -- Call_Marker -- + ----------------- + + -- This node is created during the analysis/resolution of entry calls, + -- requeues, and subprogram calls. It performs several functions: + + -- * Call markers provide a uniform model for handling calls by the + -- ABE mechanism, regardless of whether expansion took place. + + -- * The call marker captures the target of the related call along + -- with other attributes which are either unavailabe or expensive + -- to recompute once analysis, resolution, and expansion are over. + + -- * The call marker aids the ABE Processing phase by signaling the + -- presence of a call in case the original call was transformed by + -- expansion. + + -- * The call marker acts as a reference point for the insertion of + -- run-time conditional ABE checks or guaranteed ABE failures. + + -- Sprint syntax: #target# + + -- The Sprint syntax shown above is not enabled by default + + -- N_Call_Marker + -- Sloc points to Sloc of original call + -- Target (Node1-Sem) + -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) + -- Is_SPARK_Mode_On_Node (Flag2-Sem) + -- Is_Dispatching_Call (Flag3-Sem) + -- Is_Source_Call (Flag4-Sem) + -- Is_Declaration_Level_Node (Flag5-Sem) + -- Is_Recorded_Scenario (Flag6-Sem) + -- Is_Known_Guaranteed_ABE (Flag18-Sem) + ------------------------ -- Compound Statement -- ------------------------ @@ -7851,7 +7954,9 @@ package Sinfo is -- Selector_Name (Node2) -- Entity (Node4-Sem) -- Associated_Node (Node4-Sem) - -- Has_Private_View (Flag11-Sem) set in generic units. + -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) + -- Is_SPARK_Mode_On_Node (Flag2-Sem) + -- Has_Private_View (Flag11-Sem) set in generic units -- Redundant_Use (Flag13-Sem) -- Atomic_Sync_Required (Flag14-Sem) -- plus fields for expression @@ -8352,8 +8457,8 @@ package Sinfo is -- Empty -- ----------- - -- Used as the contents of the Nkind field of the dummy Empty node - -- and in some other situations to indicate an uninitialized value. + -- Used as the contents of the Nkind field of the dummy Empty node and in + -- some other situations to indicate an uninitialized value. -- N_Empty -- Chars (Name1) is set to No_Name @@ -8709,6 +8814,7 @@ package Sinfo is N_Access_Definition, N_Access_To_Object_Definition, N_Aspect_Specification, + N_Call_Marker, N_Case_Expression_Alternative, N_Case_Statement_Alternative, N_Compilation_Unit, @@ -8977,9 +9083,6 @@ package Sinfo is -- these routines check that they are being applied to an appropriate -- node, as well as checking that the node is in range. - function ABE_Is_Certain - (N : Node_Id) return Boolean; -- Flag18 - function Abort_Present (N : Node_Id) return Boolean; -- Flag15 @@ -9251,7 +9354,7 @@ package Sinfo is (N : Node_Id) return Boolean; -- Flag13 function Do_Discriminant_Check - (N : Node_Id) return Boolean; -- Flag1 + (N : Node_Id) return Boolean; -- Flag3 function Do_Division_Check (N : Node_Id) return Boolean; -- Flag13 @@ -9544,18 +9647,27 @@ package Sinfo is function Is_Controlling_Actual (N : Node_Id) return Boolean; -- Flag16 + function Is_Declaration_Level_Node + (N : Node_Id) return Boolean; -- Flag5 + function Is_Delayed_Aspect (N : Node_Id) return Boolean; -- Flag14 function Is_Disabled (N : Node_Id) return Boolean; -- Flag15 + function Is_Dispatching_Call + (N : Node_Id) return Boolean; -- Flag3 + function Is_Dynamic_Coextension (N : Node_Id) return Boolean; -- Flag18 function Is_Effective_Use_Clause (N : Node_Id) return Boolean; -- Flag1 + function Is_Elaboration_Checks_OK_Node + (N : Node_Id) return Boolean; -- Flag1 + function Is_Elsif (N : Node_Id) return Boolean; -- Flag13 @@ -9589,6 +9701,12 @@ package Sinfo is function Is_Inherited_Pragma (N : Node_Id) return Boolean; -- Flag4 + function Is_Initialization_Block + (N : Node_Id) return Boolean; -- Flag1 + + function Is_Known_Guaranteed_ABE + (N : Node_Id) return Boolean; -- Flag18 + function Is_Machine_Number (N : Node_Id) return Boolean; -- Flag11 @@ -9610,6 +9728,15 @@ package Sinfo is function Is_Qualified_Universal_Literal (N : Node_Id) return Boolean; -- Flag4 + function Is_Recorded_Scenario + (N : Node_Id) return Boolean; -- Flag6 + + function Is_Source_Call + (N : Node_Id) return Boolean; -- Flag4 + + function Is_SPARK_Mode_On_Node + (N : Node_Id) return Boolean; -- Flag2 + function Is_Static_Coextension (N : Node_Id) return Boolean; -- Flag14 @@ -9727,9 +9854,6 @@ package Sinfo is function No_Ctrl_Actions (N : Node_Id) return Boolean; -- Flag7 - function No_Elaboration_Check - (N : Node_Id) return Boolean; -- Flag14 - function No_Entities_Ref_In_Spec (N : Node_Id) return Boolean; -- Flag8 @@ -9740,7 +9864,7 @@ package Sinfo is (N : Node_Id) return Boolean; -- Flag17 function No_Side_Effect_Removal - (N : Node_Id) return Boolean; -- Flag1 + (N : Node_Id) return Boolean; -- Flag17 function No_Truncation (N : Node_Id) return Boolean; -- Flag17 @@ -9961,6 +10085,9 @@ package Sinfo is function Tagged_Present (N : Node_Id) return Boolean; -- Flag15 + function Target + (N : Node_Id) return Entity_Id; -- Node1 + function Target_Type (N : Node_Id) return Entity_Id; -- Node2 @@ -10021,6 +10148,9 @@ package Sinfo is function Used_Operations (N : Node_Id) return Elist_Id; -- Elist2 + function Was_Attribute_Reference + (N : Node_Id) return Boolean; -- Flag2 + function Was_Expression_Function (N : Node_Id) return Boolean; -- Flag18 @@ -10042,9 +10172,6 @@ package Sinfo is -- tree pointers (List1-4), the parent pointer of the Val node is set to -- point back to node N. This automates the setting of the parent pointer. - procedure Set_ABE_Is_Certain - (N : Node_Id; Val : Boolean := True); -- Flag18 - procedure Set_Abort_Present (N : Node_Id; Val : Boolean := True); -- Flag15 @@ -10316,7 +10443,7 @@ package Sinfo is (N : Node_Id; Val : Boolean := True); -- Flag13 procedure Set_Do_Discriminant_Check - (N : Node_Id; Val : Boolean := True); -- Flag1 + (N : Node_Id; Val : Boolean := True); -- Flag3 procedure Set_Do_Division_Check (N : Node_Id; Val : Boolean := True); -- Flag13 @@ -10606,18 +10733,27 @@ package Sinfo is procedure Set_Is_Controlling_Actual (N : Node_Id; Val : Boolean := True); -- Flag16 + procedure Set_Is_Declaration_Level_Node + (N : Node_Id; Val : Boolean := True); -- Flag5 + procedure Set_Is_Delayed_Aspect (N : Node_Id; Val : Boolean := True); -- Flag14 procedure Set_Is_Disabled (N : Node_Id; Val : Boolean := True); -- Flag15 + procedure Set_Is_Dispatching_Call + (N : Node_Id; Val : Boolean := True); -- Flag3 + procedure Set_Is_Dynamic_Coextension (N : Node_Id; Val : Boolean := True); -- Flag18 procedure Set_Is_Effective_Use_Clause (N : Node_Id; Val : Boolean := True); -- Flag1 + procedure Set_Is_Elaboration_Checks_OK_Node + (N : Node_Id; Val : Boolean := True); -- Flag1 + procedure Set_Is_Elsif (N : Node_Id; Val : Boolean := True); -- Flag13 @@ -10651,6 +10787,12 @@ package Sinfo is procedure Set_Is_Inherited_Pragma (N : Node_Id; Val : Boolean := True); -- Flag4 + procedure Set_Is_Initialization_Block + (N : Node_Id; Val : Boolean := True); -- Flag1 + + procedure Set_Is_Known_Guaranteed_ABE + (N : Node_Id; Val : Boolean := True); -- Flag18 + procedure Set_Is_Machine_Number (N : Node_Id; Val : Boolean := True); -- Flag11 @@ -10672,6 +10814,15 @@ package Sinfo is procedure Set_Is_Qualified_Universal_Literal (N : Node_Id; Val : Boolean := True); -- Flag4 + procedure Set_Is_Recorded_Scenario + (N : Node_Id; Val : Boolean := True); -- Flag6 + + procedure Set_Is_Source_Call + (N : Node_Id; Val : Boolean := True); -- Flag4 + + procedure Set_Is_SPARK_Mode_On_Node + (N : Node_Id; Val : Boolean := True); -- Flag2 + procedure Set_Is_Static_Coextension (N : Node_Id; Val : Boolean := True); -- Flag14 @@ -10789,9 +10940,6 @@ package Sinfo is procedure Set_No_Ctrl_Actions (N : Node_Id; Val : Boolean := True); -- Flag7 - procedure Set_No_Elaboration_Check - (N : Node_Id; Val : Boolean := True); -- Flag14 - procedure Set_No_Entities_Ref_In_Spec (N : Node_Id; Val : Boolean := True); -- Flag8 @@ -10802,7 +10950,7 @@ package Sinfo is (N : Node_Id; Val : Boolean := True); -- Flag17 procedure Set_No_Side_Effect_Removal - (N : Node_Id; Val : Boolean := True); -- Flag1 + (N : Node_Id; Val : Boolean := True); -- Flag17 procedure Set_No_Truncation (N : Node_Id; Val : Boolean := True); -- Flag17 @@ -11023,6 +11171,9 @@ package Sinfo is procedure Set_Tagged_Present (N : Node_Id; Val : Boolean := True); -- Flag15 + procedure Set_Target + (N : Node_Id; Val : Entity_Id); -- Node1 + procedure Set_Target_Type (N : Node_Id; Val : Entity_Id); -- Node2 @@ -11083,6 +11234,9 @@ package Sinfo is procedure Set_Used_Operations (N : Node_Id; Val : Elist_Id); -- Elist2 + procedure Set_Was_Attribute_Reference + (N : Node_Id; Val : Boolean := True); -- Flag2 + procedure Set_Was_Expression_Function (N : Node_Id; Val : Boolean := True); -- Flag18 @@ -12854,6 +13008,13 @@ package Sinfo is 4 => False, -- SCIL_Entity (Node4-Sem) 5 => False), -- SCIL_Tag_Value (Node5-Sem) + N_Call_Marker => + (1 => True, -- Target (Node1-Sem) + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- unused + -- Entries for Empty, Error and Unused. Even thought these have a Chars -- field for debugging purposes, they are not really syntactic fields, so -- we mark all fields as unused. @@ -12890,7 +13051,6 @@ package Sinfo is -- Inline Pragmas -- -------------------- - pragma Inline (ABE_Is_Certain); pragma Inline (Abort_Present); pragma Inline (Abortable_Part); pragma Inline (Abstract_Present); @@ -12988,10 +13148,10 @@ package Sinfo is pragma Inline (Do_Range_Check); pragma Inline (Do_Storage_Check); pragma Inline (Do_Tag_Check); - pragma Inline (Elaborate_Present); pragma Inline (Elaborate_All_Desirable); pragma Inline (Elaborate_All_Present); pragma Inline (Elaborate_Desirable); + pragma Inline (Elaborate_Present); pragma Inline (Else_Actions); pragma Inline (Else_Statements); pragma Inline (Elsif_Parts); @@ -13080,10 +13240,13 @@ package Sinfo is pragma Inline (Is_Component_Left_Opnd); pragma Inline (Is_Component_Right_Opnd); pragma Inline (Is_Controlling_Actual); + pragma Inline (Is_Declaration_Level_Node); pragma Inline (Is_Delayed_Aspect); pragma Inline (Is_Disabled); + pragma Inline (Is_Dispatching_Call); pragma Inline (Is_Dynamic_Coextension); pragma Inline (Is_Effective_Use_Clause); + pragma Inline (Is_Elaboration_Checks_OK_Node); pragma Inline (Is_Elsif); pragma Inline (Is_Entry_Barrier_Function); pragma Inline (Is_Expanded_Build_In_Place_Call); @@ -13095,6 +13258,8 @@ package Sinfo is pragma Inline (Is_Ignored_Ghost_Pragma); pragma Inline (Is_In_Discriminant_Check); pragma Inline (Is_Inherited_Pragma); + pragma Inline (Is_Initialization_Block); + pragma Inline (Is_Known_Guaranteed_ABE); pragma Inline (Is_Machine_Number); pragma Inline (Is_Null_Loop); pragma Inline (Is_Overloaded); @@ -13102,6 +13267,9 @@ package Sinfo is pragma Inline (Is_Prefixed_Call); pragma Inline (Is_Protected_Subprogram_Body); pragma Inline (Is_Qualified_Universal_Literal); + pragma Inline (Is_Recorded_Scenario); + pragma Inline (Is_Source_Call); + pragma Inline (Is_SPARK_Mode_On_Node); pragma Inline (Is_Static_Coextension); pragma Inline (Is_Static_Expression); pragma Inline (Is_Subprogram_Descriptor); @@ -13140,7 +13308,6 @@ package Sinfo is pragma Inline (Next_Rep_Item); pragma Inline (Next_Use_Clause); pragma Inline (No_Ctrl_Actions); - pragma Inline (No_Elaboration_Check); pragma Inline (No_Entities_Ref_In_Spec); pragma Inline (No_Initialization); pragma Inline (No_Minimize_Eliminate); @@ -13218,6 +13385,7 @@ package Sinfo is pragma Inline (Suppress_Loop_Warnings); pragma Inline (Synchronized_Present); pragma Inline (Tagged_Present); + pragma Inline (Target); pragma Inline (Target_Type); pragma Inline (Task_Definition); pragma Inline (Task_Present); @@ -13238,11 +13406,11 @@ package Sinfo is pragma Inline (Variants); pragma Inline (Visible_Declarations); pragma Inline (Used_Operations); + pragma Inline (Was_Attribute_Reference); pragma Inline (Was_Expression_Function); pragma Inline (Was_Originally_Stub); pragma Inline (Withed_Body); - pragma Inline (Set_ABE_Is_Certain); pragma Inline (Set_Abort_Present); pragma Inline (Set_Abortable_Part); pragma Inline (Set_Abstract_Present); @@ -13429,10 +13597,13 @@ package Sinfo is pragma Inline (Set_Is_Component_Left_Opnd); pragma Inline (Set_Is_Component_Right_Opnd); pragma Inline (Set_Is_Controlling_Actual); + pragma Inline (Set_Is_Declaration_Level_Node); pragma Inline (Set_Is_Delayed_Aspect); pragma Inline (Set_Is_Disabled); + pragma Inline (Set_Is_Dispatching_Call); pragma Inline (Set_Is_Dynamic_Coextension); pragma Inline (Set_Is_Effective_Use_Clause); + pragma Inline (Set_Is_Elaboration_Checks_OK_Node); pragma Inline (Set_Is_Elsif); pragma Inline (Set_Is_Entry_Barrier_Function); pragma Inline (Set_Is_Expanded_Build_In_Place_Call); @@ -13444,6 +13615,8 @@ package Sinfo is pragma Inline (Set_Is_Ignored_Ghost_Pragma); pragma Inline (Set_Is_In_Discriminant_Check); pragma Inline (Set_Is_Inherited_Pragma); + pragma Inline (Set_Is_Initialization_Block); + pragma Inline (Set_Is_Known_Guaranteed_ABE); pragma Inline (Set_Is_Machine_Number); pragma Inline (Set_Is_Null_Loop); pragma Inline (Set_Is_Overloaded); @@ -13451,6 +13624,9 @@ package Sinfo is pragma Inline (Set_Is_Prefixed_Call); pragma Inline (Set_Is_Protected_Subprogram_Body); pragma Inline (Set_Is_Qualified_Universal_Literal); + pragma Inline (Set_Is_Recorded_Scenario); + pragma Inline (Set_Is_Source_Call); + pragma Inline (Set_Is_SPARK_Mode_On_Node); pragma Inline (Set_Is_Static_Coextension); pragma Inline (Set_Is_Static_Expression); pragma Inline (Set_Is_Subprogram_Descriptor); @@ -13490,7 +13666,6 @@ package Sinfo is pragma Inline (Set_Next_Rep_Item); pragma Inline (Set_Next_Use_Clause); pragma Inline (Set_No_Ctrl_Actions); - pragma Inline (Set_No_Elaboration_Check); pragma Inline (Set_No_Entities_Ref_In_Spec); pragma Inline (Set_No_Initialization); pragma Inline (Set_No_Minimize_Eliminate); @@ -13567,6 +13742,7 @@ package Sinfo is pragma Inline (Set_Synchronized_Present); pragma Inline (Set_TSS_Elist); pragma Inline (Set_Tagged_Present); + pragma Inline (Set_Target); pragma Inline (Set_Target_Type); pragma Inline (Set_Task_Definition); pragma Inline (Set_Task_Present); @@ -13586,6 +13762,7 @@ package Sinfo is pragma Inline (Set_Variant_Part); pragma Inline (Set_Variants); pragma Inline (Set_Visible_Declarations); + pragma Inline (Set_Was_Attribute_Reference); pragma Inline (Set_Was_Expression_Function); pragma Inline (Set_Was_Originally_Stub); pragma Inline (Set_Withed_Body); diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 0052409b552..ac2dcd8a14d 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -1225,6 +1225,15 @@ package body Sprint is Write_Char (';'); + when N_Call_Marker => + null; + + -- Enable the following code for debugging purposes only + + -- Write_Indent_Str ("#"); + -- Write_Id (Target (Node)); + -- Write_Char ('#'); + when N_Case_Expression => declare Has_Parens : constant Boolean := Paren_Count (Node) > 0; |