Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/sem_elab.adb @ 131:84e7813d76e9
gcc-8.2
| author | mir3636 |
|---|---|
| date | Thu, 25 Oct 2018 07:37:49 +0900 |
| parents | 04ced10e8804 |
| children | 1830386684a0 |
line wrap: on
line diff
--- a/gcc/ada/sem_elab.adb Fri Oct 27 22:46:09 2017 +0900 +++ b/gcc/ada/sem_elab.adb Thu Oct 25 07:37:49 2018 +0900 @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2017, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2018, 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- -- @@ -24,28 +24,34 @@ ------------------------------------------------------------------------------ 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_Ch11; use Exp_Ch11; 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; @@ -67,7 +73,7 @@ -- * 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 + -- 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. @@ -111,6 +117,9 @@ -- Terminology -- ----------------- + -- * ABE - An attempt to activate, call, or instantiate a scenario which + -- has not been fully elaborated. + -- -- * 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. @@ -127,7 +136,12 @@ -- * 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. + -- enclosing packages. + -- + -- * Early call region - A section of code which ends at a subprogram body + -- and starts from the nearest non-preelaborable construct which precedes + -- the subprogram body. The early call region extends from a package body + -- to a package spec when the spec carries pragma Elaborate_Body. -- -- * Generic library level - A type of enclosing level. A scenario or -- target is at the generic library level if it appears in a generic @@ -145,8 +159,8 @@ -- 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. + -- * 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 @@ -154,15 +168,19 @@ -- -- - '[Unrestricted_]Access of entries, operators, and subprograms -- - -- - Assignments to variables - -- - -- - Calls to entries, operators, and subprograms - -- - -- - Instantiations - -- - -- - Reads of variables - -- - -- - Task activation + -- - Assignments to variables + -- + -- - Calls to entries, operators, and subprograms + -- + -- - Derived type declarations + -- + -- - Instantiations + -- + -- - Pragma Refined_State + -- + -- - Reads of variables + -- + -- - Task activation -- -- * Target - A construct referenced by a scenario. The targets recognized -- by the ABE mechanism are as follows: @@ -174,13 +192,17 @@ -- -- - For calls, the target is the entry, operator, or subprogram -- + -- - For derived type declarations, the target is the derived type + -- -- - For instantiations, the target is the generic template -- + -- - For pragma Refined_State, the targets are the constituents + -- -- - For reads of 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 + -- * 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: -- @@ -197,13 +219,20 @@ -- 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 + -- * 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. -- + -- * Record certain SPARK scenarios which are not necessarily executable + -- during elaboration, but still require elaboration-related checks. + -- + -- 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. -- @@ -230,23 +259,24 @@ -- 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 + -- * 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. -- + -- * Examine all SPARK scenarios saved during the Recording phase + -- -- * Depending on the elaboration model in effect, perform the following -- actions: -- - -- - Dynamic model - Diagnose guaranteed ABEs and install run-time - -- conditional ABE checks. + -- - Dynamic model - 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. + -- - Static model - Diagnose conditional ABEs, install run-time + -- conditional ABE checks, and guarantee the elaboration of + -- external units. -- -- * Examine nested scenarios -- @@ -258,44 +288,72 @@ -- Architecture -- ------------------ - -- +------------------------ Recording phase ---------------------------+ + -- Analysis/Resolution + -- | + -- +- Build_Call_Marker + -- | + -- +- Build_Variable_Reference_Marker + -- | + -- +- | -------------------- Recording phase ---------------------------+ + -- | v | + -- | Record_Elaboration_Scenario | + -- | | | + -- | +--> Check_Preelaborated_Call | + -- | | | + -- | +--> Process_Guaranteed_ABE | + -- | | | | + -- | | +--> Process_Guaranteed_ABE_Activation | + -- | | | | + -- | | +--> Process_Guaranteed_ABE_Call | + -- | | | | + -- | | +--> Process_Guaranteed_ABE_Instantiation | + -- | | | + -- +- | ----------------------------------------------------------------+ + -- | + -- | + -- +--> SPARK_Scenarios + -- | +-----------+-----------+ .. +-----------+ + -- | | Scenario1 | Scenario2 | .. | ScenarioN | + -- | +-----------+-----------+ .. +-----------+ + -- | + -- +--> Top_Level_Scenarios + -- | +-----------+-----------+ .. +-----------+ + -- | | Scenario1 | Scenario2 | .. | ScenarioN | + -- | +-----------+-----------+ .. +-----------+ + -- | + -- End of Compilation + -- | + -- +- | --------------------- Processing phase -------------------------+ + -- | v | + -- | Check_Elaboration_Scenarios | + -- | | | + -- | +--> Check_SPARK_Scenario | + -- | | | | + -- | | +--> Check_SPARK_Derived_Type | + -- | | | | + -- | | +--> Check_SPARK_Instantiation | + -- | | | | + -- | | +--> Check_SPARK_Refined_State_Pragma | + -- | | | + -- | +--> Process_Conditional_ABE <---------------------------+ | + -- | | | | + -- | +--> Process_Conditional_ABE_Access Is_Suitable_Scenario | + -- | | ^ | + -- | +--> Process_Conditional_ABE_Activation | | + -- | | | | | + -- | | +-----------------------------+ | | + -- | | | | | + -- | +--> Process_Conditional_ABE_Call +--------> Traverse_Body | + -- | | | | | + -- | | +-----------------------------+ | + -- | | | + -- | +--> Process_Conditional_ABE_Instantiation | + -- | | | + -- | +--> Process_Conditional_ABE_Variable_Assignment | + -- | | | + -- | +--> Process_Conditional_ABE_Variable_Reference | -- | | - -- | 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_Read | - -- | | - -- +------------------------- Processing phase -------------------------+ + -- +--------------------------------------------------------------------+ ---------------------- -- Important points -- @@ -314,6 +372,61 @@ -- The diagnostics of the ABE mechanism depend on accurate source locations -- to determine the spacial relation of nodes. + ----------------------------------------- + -- Suppression of elaboration warnings -- + ----------------------------------------- + + -- Elaboration warnings along multiple traversal paths rooted at a scenario + -- are suppressed when the scenario has elaboration warnings suppressed. + -- + -- Root scenario + -- | + -- +-- Child scenario 1 + -- | | + -- | +-- Grandchild scenario 1 + -- | | + -- | +-- Grandchild scenario N + -- | + -- +-- Child scenario N + -- + -- If the root scenario has elaboration warnings suppressed, then all its + -- child, grandchild, etc. scenarios will have their elaboration warnings + -- suppressed. + -- + -- In addition to switch -gnatwL, pragma Warnings may be used to suppress + -- elaboration-related warnings when used in the following manner: + -- + -- pragma Warnings ("L"); + -- <scenario-or-target> + -- + -- <target> + -- pragma Warnings (Off, target); + -- + -- pragma Warnings (Off); + -- <scenario-or-target> + -- + -- * To suppress elaboration warnings for '[Unrestricted_]Access of + -- entries, operators, and subprograms, either: + -- + -- - Suppress the entry, operator, or subprogram, or + -- - Suppress the attribute, or + -- - Use switch -gnatw.f + -- + -- * To suppress elaboration warnings for calls to entries, operators, + -- and subprograms, either: + -- + -- - Suppress the entry, operator, or subprogram, or + -- - Suppress the call + -- + -- * To suppress elaboration warnings for instantiations, suppress the + -- instantiation. + -- + -- * To suppress elaboration warnings for task activations, either: + -- + -- - Suppress the task object, or + -- - Suppress the task type, or + -- - Suppress the activation call + -------------- -- Switches -- -------------- @@ -321,6 +434,20 @@ -- The following switches may be used to control the behavior of the ABE -- mechanism. -- + -- -gnatd_a stop elaboration checks on accept or select statement + -- + -- The ABE mechanism stops the traversal of a task body when it + -- encounters an accept or a select statement. This behavior is + -- equivalent to restriction No_Entry_Calls_In_Elaboration_Code, + -- but without penalizing actual entry calls during elaboration. + -- + -- -gnatd_e ignore entry calls and requeue statements for elaboration + -- + -- The ABE mechanism does not generate N_Call_Marker nodes for + -- protected or task entry calls as well as requeue statements. + -- As a result, the calls and requeues are not recorded or + -- processed. + -- -- -gnatdE elaboration checks on predefined units -- -- The ABE mechanism considers scenarios which appear in internal @@ -333,9 +460,11 @@ -- 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. + -- -gnatd_i ignore activations and calls to instances for elaboration + -- + -- The ABE mechanism ignores calls and task activations when they + -- target a subprogram or task type defined an external instance. + -- As a result, the calls and task activations are not processed. -- -- -gnatdL ignore external calls from instances for elaboration -- @@ -345,10 +474,6 @@ -- 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 conservative elaboration order for indirect calls -- -- The ABE mechanism treats '[Unrestricted_]Access of an entry, @@ -356,6 +481,33 @@ -- target. As a result, it performs ABE checks and diagnostics on -- the immediate call. -- + -- -gnatd_p ignore assertion pragmas for elaboration + -- + -- The ABE mechanism does not generate N_Call_Marker nodes for + -- calls to subprograms which verify the run-time semantics of + -- the following assertion pragmas: + -- + -- Default_Initial_Condition + -- Initial_Condition + -- Invariant + -- Invariant'Class + -- Post + -- Post'Class + -- Postcondition + -- Type_Invariant + -- Type_Invariant_Class + -- + -- As a result, the assertion expressions of the pragmas are not + -- processed. + -- + -- -gnatd_s stop elaboration checks on synchronous suspension + -- + -- The ABE mechanism stops the traversal of a task body when it + -- encounters a call to one of the following routines: + -- + -- Ada.Synchronous_Barriers.Wait_For_Release + -- Ada.Synchronous_Task_Control.Suspend_Until_True + -- -- -gnatd.U ignore indirect calls for static elaboration -- -- The ABE mechanism does not consider '[Unrestricted_]Access of @@ -391,16 +543,32 @@ -- -- -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. + -- The complementary switch for -gnatel. + -- + -- -gnatH legacy elaboration checking mode enabled + -- + -- When this switch is in effect, the pre-18.x ABE model becomes + -- the defacto ABE model. This ammounts to cutting off all entry + -- points into the new ABE mechanism, and giving full control to + -- the old ABE mechanism. + -- + -- -gnatJ permissive elaboration checking mode enabled + -- + -- This switch activates the following switches: + -- + -- -gnatd_a + -- -gnatd_e + -- -gnatd.G + -- -gnatd_i + -- -gnatdL + -- -gnatd_p + -- -gnatd_s + -- -gnatd.U + -- -gnatd.y + -- + -- IMPORTANT: The behavior of the ABE mechanism becomes more + -- permissive at the cost of accurate diagnostics and runtime + -- ABE checks. -- -- -gnatw.f turn on warnings for suspicious Subp'Access -- @@ -410,45 +578,69 @@ -- -- -gnatw.F turn off warnings for suspicious Subp'Access -- - -- The complimentary switch for -gnatw.f. + -- The complementary switch for -gnatw.f. + -- + -- -gnatwl turn on warnings for elaboration problems + -- + -- The ABE mechanism produces warnings on detected ABEs along with + -- a traceback showing the graph of the ABE. + -- + -- -gnatwL turn off warnings for elaboration problems + -- + -- The complementary switch for -gnatwl. --------------------------- -- 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. + -- preserve the existing architecture. Note that not all of the steps may + -- need to be carried out. + -- + -- 1) Update predicate 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 + -- 4) Add routine Process_Conditional_ABE_xxx. Include a call to it in + -- routine Process_Conditional_ABE. + -- + -- 5) Add routine Process_Guaranteed_ABE_xxx. Include a call to it in + -- routine Process_Guaranteed_ABE. + -- + -- 6) Add routine Check_SPARK_xxx. Include a call to it in routine + -- Check_SPARK_Scenario. + -- + -- 7) Add routine Info_xxx. Include a call to it in routine + -- Process_Conditional_ABE_xxx. + -- + -- 8) 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 + -- 9) Add routine Extract_xxx_Attributes + -- + -- 10) 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. + -- preserve the existing architecture. Note that not all of the steps may + -- need to be carried out. -- -- 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. + -- 2) Update the following predicates + -- + -- Is_Ada_Semantic_Target + -- Is_Assertion_Pragma_Target + -- Is_Bridge_Target + -- Is_SPARK_Semantic_Target + -- + -- If necessary, create a new category. -- -- 3) Update the appropriate Info_xxx routine. -- @@ -473,7 +665,8 @@ -- body. The routines of interest are -- -- Record_Elaboration_Scenario - -- Process_Scenario + -- Process_Conditional_ABE + -- Process_Guaranteed_ABE -- Traverse_Body -- * If the issue involves a circularity in the elaboration order, examine @@ -496,12 +689,19 @@ -- Attributes -- ---------------- + -- To minimize the amount of code within routines, the ABE mechanism relies + -- on "attribute" records to capture relevant information for a scenario or + -- a target. + -- 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 + Elab_Warnings_OK : Boolean; + -- This flag is set when the call has elaboration warnings elabled + From_Source : Boolean; -- This flag is set when the call comes from source @@ -557,6 +757,10 @@ -- This flag is set when the instantiation has elaboration checks -- enabled. + Elab_Warnings_OK : Boolean; + -- This flag is set when the instantiation has elaboration warnings + -- enabled. + 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. @@ -570,6 +774,43 @@ -- to pragma SPARK_Mode with value On, or starts one such region. end record; + -- The following type captures relevant attributes which pertain to the + -- state of the Processing phase. + + type Processing_Attributes is record + Suppress_Implicit_Pragmas : Boolean; + -- This flag is set when the Processing phase must not generate any + -- implicit Elaborate[_All] pragmas. + + Suppress_Warnings : Boolean; + -- This flag is set when the Processing phase must not emit any warnings + -- on elaboration problems. + + Within_Initial_Condition : Boolean; + -- This flag is set when the Processing phase is currently examining a + -- scenario which was reached from an initial condition procedure. + + Within_Instance : Boolean; + -- This flag is set when the Processing phase is currently examining a + -- scenario which was reached from a scenario defined in an instance. + + Within_Partial_Finalization : Boolean; + -- This flag is set when the Processing phase is currently examining a + -- scenario which was reached from a partial finalization procedure. + + Within_Task_Body : Boolean; + -- This flag is set when the Processing phase is currently examining a + -- scenario which was reached from a task body. + end record; + + Initial_State : constant Processing_Attributes := + (Suppress_Implicit_Pragmas => False, + Suppress_Warnings => False, + Within_Initial_Condition => False, + Within_Instance => False, + Within_Partial_Finalization => False, + Within_Task_Body => False); + -- The following type captures relevant attributes which pertain to a -- target. @@ -577,6 +818,9 @@ Elab_Checks_OK : Boolean; -- This flag is set when the target has elaboration checks enabled + Elab_Warnings_OK : Boolean; + -- This flag is set when the target has elaboration warnings enabled + From_Source : Boolean; -- This flag is set when the target comes from source @@ -659,6 +903,9 @@ Elab_Checks_OK : Boolean; -- This flag is set when the task type has elaboration checks enabled + Elab_Warnings_OK : Boolean; + -- This flag is set when the task type has elaboration warnings enabled + 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. @@ -683,10 +930,6 @@ -- variable. 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. @@ -696,27 +939,117 @@ -- Data structures -- --------------------- + -- The ABE mechanism employs lists and hash tables to store information + -- pertaining to scenarios and targets, as well as the Processing phase. + -- The need for data structures comes partly from the size limitation of + -- nodes. Note that the use of hash tables is conservative and operations + -- are carried out only when a particular hash table has at least one key + -- value pair (see xxx_In_Use flags). + + -- The following table stores the early call regions of subprogram bodies + + Early_Call_Regions_Max : constant := 101; + + type Early_Call_Regions_Index is range 0 .. Early_Call_Regions_Max - 1; + + function Early_Call_Regions_Hash + (Key : Entity_Id) return Early_Call_Regions_Index; + -- Obtain the hash value of entity Key + + Early_Call_Regions_In_Use : Boolean := False; + -- This flag determines whether table Early_Call_Regions contains at least + -- least one key/value pair. + + Early_Call_Regions_No_Element : constant Node_Id := Empty; + + package Early_Call_Regions is new Simple_HTable + (Header_Num => Early_Call_Regions_Index, + Element => Node_Id, + No_Element => Early_Call_Regions_No_Element, + Key => Entity_Id, + Hash => Early_Call_Regions_Hash, + Equal => "="); + -- 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; + Elaboration_Statuses_Max : constant := 1009; + + type Elaboration_Statuses_Index is range 0 .. Elaboration_Statuses_Max - 1; + + function Elaboration_Statuses_Hash + (Key : Entity_Id) return Elaboration_Statuses_Index; -- Obtain the hash value of entity Key - package Elaboration_Context is new Simple_HTable - (Header_Num => Elaboration_Context_Index, + Elaboration_Statuses_In_Use : Boolean := False; + -- This flag flag determines whether table Elaboration_Statuses contains at + -- least one key/value pair. + + Elaboration_Statuses_No_Element : constant Elaboration_Attributes := + No_Elaboration_Attributes; + + package Elaboration_Statuses is new Simple_HTable + (Header_Num => Elaboration_Statuses_Index, Element => Elaboration_Attributes, - No_Element => No_Elaboration_Attributes, + No_Element => Elaboration_Statuses_No_Element, Key => Entity_Id, - Hash => Elaboration_Context_Hash, + Hash => Elaboration_Statuses_Hash, + Equal => "="); + + -- The following table stores a status flag for each SPARK scenario saved + -- in table SPARK_Scenarios. + + Recorded_SPARK_Scenarios_Max : constant := 127; + + type Recorded_SPARK_Scenarios_Index is + range 0 .. Recorded_SPARK_Scenarios_Max - 1; + + function Recorded_SPARK_Scenarios_Hash + (Key : Node_Id) return Recorded_SPARK_Scenarios_Index; + -- Obtain the hash value of Key + + Recorded_SPARK_Scenarios_In_Use : Boolean := False; + -- This flag flag determines whether table Recorded_SPARK_Scenarios + -- contains at least one key/value pair. + + Recorded_SPARK_Scenarios_No_Element : constant Boolean := False; + + package Recorded_SPARK_Scenarios is new Simple_HTable + (Header_Num => Recorded_SPARK_Scenarios_Index, + Element => Boolean, + No_Element => Recorded_SPARK_Scenarios_No_Element, + Key => Node_Id, + Hash => Recorded_SPARK_Scenarios_Hash, + Equal => "="); + + -- The following table stores a status flag for each top-level scenario + -- recorded in table Top_Level_Scenarios. + + Recorded_Top_Level_Scenarios_Max : constant := 503; + + type Recorded_Top_Level_Scenarios_Index is + range 0 .. Recorded_Top_Level_Scenarios_Max - 1; + + function Recorded_Top_Level_Scenarios_Hash + (Key : Node_Id) return Recorded_Top_Level_Scenarios_Index; + -- Obtain the hash value of entity Key + + Recorded_Top_Level_Scenarios_In_Use : Boolean := False; + -- This flag flag determines whether table Recorded_Top_Level_Scenarios + -- contains at least one key/value pair. + + Recorded_Top_Level_Scenarios_No_Element : constant Boolean := False; + + package Recorded_Top_Level_Scenarios is new Simple_HTable + (Header_Num => Recorded_Top_Level_Scenarios_Index, + Element => Boolean, + No_Element => Recorded_Top_Level_Scenarios_No_Element, + Key => Node_Id, + Hash => Recorded_Top_Level_Scenarios_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 + -- starting from a top-level scenario. This table must be maintained in a -- FIFO fashion. package Scenario_Stack is new Table.Table @@ -727,7 +1060,19 @@ Table_Increment => 100, Table_Name => "Scenario_Stack"); - -- The following table stores all top level scenario saved during the + -- The following table stores SPARK scenarios which are not necessarily + -- executable during elaboration, but still require elaboration-related + -- checks. + + package SPARK_Scenarios 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 => "SPARK_Scenarios"); + + -- 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. @@ -741,7 +1086,7 @@ 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 + -- 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; @@ -751,10 +1096,16 @@ function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index; -- Obtain the hash value of node Key + Visited_Bodies_In_Use : Boolean := False; + -- This flag determines whether table Visited_Bodies contains at least one + -- key/value pair. + + Visited_Bodies_No_Element : constant Boolean := False; + package Visited_Bodies is new Simple_HTable (Header_Num => Visited_Bodies_Index, Element => Boolean, - No_Element => False, + No_Element => Visited_Bodies_No_Element, Key => Node_Id, Hash => Visited_Bodies_Hash, Equal => "="); @@ -763,15 +1114,52 @@ -- Local subprograms -- ----------------------- + -- Multiple local subprograms are utilized to lower the semantic complexity + -- of the Recording and Processing phase. + 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. + pragma Inline (Check_Preelaborated_Call); + -- Verify that entry, operator, or subprogram call Call does not appear at + -- the library level of a preelaborated unit. + + procedure Check_SPARK_Derived_Type (Typ_Decl : Node_Id); + pragma Inline (Check_SPARK_Derived_Type); + -- Verify that the freeze node of a derived type denoted by declaration + -- Typ_Decl is within the early call region of each overriding primitive + -- body that belongs to the derived type (SPARK RM 7.7(8)). + + procedure Check_SPARK_Instantiation (Exp_Inst : Node_Id); + pragma Inline (Check_SPARK_Instantiation); + -- Verify that expanded instance Exp_Inst does not precede the generic body + -- it instantiates (SPARK RM 7.7(6)). + + procedure Check_SPARK_Model_In_Effect (N : Node_Id); + pragma Inline (Check_SPARK_Model_In_Effect); + -- Determine whether a suitable elaboration model is currently in effect + -- for verifying the SPARK rules of scenario N. Emit a warning if this is + -- not the case. + + procedure Check_SPARK_Scenario (N : Node_Id); + pragma Inline (Check_SPARK_Scenario); + -- Top-level dispatcher for verifying SPARK scenarios which are not always + -- executable during elaboration but still need elaboration-related checks. + + procedure Check_SPARK_Refined_State_Pragma (N : Node_Id); + pragma Inline (Check_SPARK_Refined_State_Pragma); + -- Verify that each constituent of Refined_State pragma N which belongs to + -- an abstract state mentioned in pragma Initializes has prior elaboration + -- with respect to the main unit (SPARK RM 7.7.1(7)). function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id; pragma Inline (Compilation_Unit); -- Return the N_Compilation_Unit node of unit Unit_Id + function Early_Call_Region (Body_Id : Entity_Id) return Node_Id; + pragma Inline (Early_Call_Region); + -- Return the early call region associated with entry or subprogram body + -- Body_Id. IMPORTANT: This routine does not find the early call region. + -- To compute it, use routine Find_Early_Call_Region. + procedure Elab_Msg_NE (Msg : String; N : Node_Id; @@ -784,13 +1172,20 @@ -- 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 Elaboration_Status + (Unit_Id : Entity_Id) return Elaboration_Attributes; + pragma Inline (Elaboration_Status); + -- Return the set of elaboration attributes associated with unit Unit_Id + 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. + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id; + State : Processing_Attributes); + -- Guarantee the elaboration of unit Unit_Id with respect to the main unit + -- by installing pragma Elaborate or Elaborate_All denoted by Prag_Nam. N + -- denotes the related scenario. State denotes the current state of the + -- Processing phase. procedure Ensure_Prior_Elaboration_Dynamic (N : Node_Id; @@ -867,10 +1262,22 @@ -- 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. + -- unit is that of the top-level instantiation. + + function Find_Early_Call_Region + (Body_Decl : Node_Id; + Assume_Elab_Body : Boolean := False; + Skip_Memoization : Boolean := False) return Node_Id; + -- Find the start of the early call region which belongs to subprogram body + -- Body_Decl as defined in SPARK RM 7.7. The behavior of the routine is to + -- find the early call region, memoize it, and return it, but this behavior + -- can be altered. Flag Assume_Elab_Body should be set when a package spec + -- may lack pragma Elaborate_Body, but the routine must still examine that + -- spec. Flag Skip_Memoization should be set when the routine must avoid + -- memoizing the region. procedure Find_Elaborated_Units; - -- Populate table Elaboration_Context with all units which have prior + -- Populate table Elaboration_Statuses with all units which have prior -- elaboration with respect to the main unit. function Find_Enclosing_Instance (N : Node_Id) return Node_Id; @@ -941,6 +1348,10 @@ -- context ignoring enclosing library levels. Nested_OK should be set when -- the context of N1 can enclose that of N2. + function In_Task_Body (N : Node_Id) return Boolean; + pragma Inline (In_Task_Body); + -- Determine whether arbitrary node N appears within a task body + procedure Info_Call (Call : Node_Id; Target_Id : Entity_Id; @@ -962,16 +1373,16 @@ -- 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_Read + procedure Info_Variable_Reference (Ref : Node_Id; Var_Id : Entity_Id; Info_Msg : Boolean; In_SPARK : Boolean); - pragma Inline (Info_Variable_Read); - -- Output information concerning reference Ref which reads 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. + pragma Inline (Info_Variable_Reference); + -- 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); @@ -1012,18 +1423,18 @@ 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 + -- Determine whether arbitrary entity Id denodes a source or internally -- generated subprogram which emulates Ada semantics. + function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean; + pragma Inline (Is_Assertion_Pragma_Target); + -- Determine whether arbitrary entity Id denotes a procedure which varifies + -- the run-time semantics of an assertion pragma. + 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; @@ -1101,6 +1512,16 @@ -- Determine whether entity Id denotes the protected or unprotected version -- of a protected subprogram. + function Is_Recorded_SPARK_Scenario (N : Node_Id) return Boolean; + pragma Inline (Is_Recorded_SPARK_Scenario); + -- Determine whether arbitrary node N is a recorded SPARK scenario which + -- appears in table SPARK_Scenarios. + + function Is_Recorded_Top_Level_Scenario (N : Node_Id) return Boolean; + pragma Inline (Is_Recorded_Top_Level_Scenario); + -- Determine whether arbitrary node N is a recorded top-level scenario + -- which appears in table Top_Level_Scenarios. + function Is_Safe_Activation (Call : Node_Id; Task_Decl : Node_Id) return Boolean; @@ -1158,15 +1579,39 @@ -- Determine whether arbitrary node N is a suitable scenario for ABE -- processing. + function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_SPARK_Derived_Type); + -- Determine whether arbitrary node N denotes a suitable derived type + -- declaration for ABE processing using the SPARK rules. + + function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_SPARK_Instantiation); + -- Determine whether arbitrary node N denotes a suitable instantiation for + -- ABE processing using the SPARK rules. + + function Is_Suitable_SPARK_Refined_State_Pragma + (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_SPARK_Refined_State_Pragma); + -- Determine whether arbitrary node N denotes a suitable Refined_State + -- pragma for ABE processing using the SPARK rules. + 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_Read (N : Node_Id) return Boolean; - pragma Inline (Is_Suitable_Variable_Read); - -- Determine whether arbitrary node N is a suitable variable read 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 variable reference for + -- ABE processing. + + function Is_Synchronous_Suspension_Call (N : Node_Id) return Boolean; + pragma Inline (Is_Synchronous_Suspension_Call); + -- Determine whether arbitrary node N denotes a call to one the following + -- routines: + -- + -- Ada.Synchronous_Barriers.Wait_For_Release + -- Ada.Synchronous_Task_Control.Suspend_Until_True function Is_Task_Entry (Id : Entity_Id) return Boolean; pragma Inline (Is_Task_Entry); @@ -1179,6 +1624,11 @@ -- Target_Decl is within a context which encloses the current root or is in -- a different unit. + function Is_Visited_Body (Body_Decl : Node_Id) return Boolean; + pragma Inline (Is_Visited_Body); + -- Determine whether subprogram body Body_Decl is already visited during a + -- recursive traversal started from a top-level scenario. + procedure Meet_Elaboration_Requirement (N : Node_Id; Target_Id : Entity_Id; @@ -1202,88 +1652,154 @@ -- 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); + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + State : Processing_Attributes); -- 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); + -- State is the current state of the Processing phase. + + procedure Process_Activation_Generic + (Call : Node_Id; + Call_Attrs : Call_Attributes; + State : Processing_Attributes); -- 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); + -- Call_Attrs are the attributes of the activation call. State is the + -- current state of the Processing phase. + + procedure Process_Conditional_ABE + (N : Node_Id; + State : Processing_Attributes := Initial_State); + -- Top-level dispatcher for processing of various elaboration scenarios. + -- Perform conditional ABE checks and diagnostics for scenario N. State + -- is the current state of the Processing phase. + + procedure Process_Conditional_ABE_Access + (Attr : Node_Id; + State : Processing_Attributes); + -- Perform ABE checks and diagnostics for 'Access to entry, operator, or + -- subprogram denoted by Attr. State is the current state of the Processing + -- phase. + + procedure Process_Conditional_ABE_Activation_Impl + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + State : Processing_Attributes); -- Perform common conditional ABE checks and diagnostics for call Call - -- which activates task Obj_Id ignoring the Ada or SPARK rules. CAll_Attrs + -- 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); + -- of the task type. State is the current state of the Processing phase. + + procedure Process_Conditional_ABE_Call + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + State : Processing_Attributes); -- 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 + -- are the attributes of the call. State is the current state of the + -- Processing phase. + + procedure Process_Conditional_ABE_Call_Ada (Call : Node_Id; Call_Attrs : Call_Attributes; Target_Id : Entity_Id; Target_Attrs : Target_Attributes; - In_Task_Body : Boolean); + State : Processing_Attributes); -- 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. Target_Attrs are attributes of the target. State is the current + -- state of the Processing phase. + + procedure Process_Conditional_ABE_Call_SPARK (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 + Target_Attrs : Target_Attributes; + State : Processing_Attributes); + -- Perform ABE checks and diagnostics for call Call which invokes target + -- Target_Id using the SPARK rules. Target_Attrs denotes the attributes of + -- the target. State is the current state of the Processing phase. + + procedure Process_Conditional_ABE_Instantiation + (Exp_Inst : Node_Id; + State : Processing_Attributes); + -- Top-level dispatcher for processing of instantiations. Perform ABE + -- checks and diagnostics for expanded instantiation Exp_Inst. State is + -- the current state of the Processing phase. + + procedure Process_Conditional_ABE_Instantiation_Ada + (Exp_Inst : Node_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes; + State : Processing_Attributes); + -- 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 denotes the + -- attributes of the generic. State is the current state of the Processing + -- phase. + + procedure Process_Conditional_ABE_Instantiation_SPARK + (Inst : Node_Id; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes; + State : Processing_Attributes); + -- Perform ABE checks and diagnostics for instantiation Inst of generic + -- Gen_Id using the SPARK rules. Gen_Attrs denotes the attributes of the + -- generic. State is the current state of the Processing phase. + + procedure Process_Conditional_ABE_Variable_Assignment (Asmt : Node_Id); + -- Top-level dispatcher for processing of variable assignments. Perform ABE + -- checks and diagnostics for assignment statement Asmt. + + procedure Process_Conditional_ABE_Variable_Assignment_Ada + (Asmt : Node_Id; + Var_Id : Entity_Id); + -- Perform ABE checks and diagnostics for assignment statement Asmt that + -- updates the value of variable Var_Id using the Ada rules. + + procedure Process_Conditional_ABE_Variable_Assignment_SPARK + (Asmt : Node_Id; + Var_Id : Entity_Id); + -- Perform ABE checks and diagnostics for assignment statement Asmt that + -- updates the value of variable Var_Id using the SPARK rules. + + procedure Process_Conditional_ABE_Variable_Reference (Ref : Node_Id); + -- Top-level dispatcher for processing of variable references. Perform ABE + -- checks and diagnostics for variable reference Ref. + + procedure Process_Conditional_ABE_Variable_Reference_Read + (Ref : Node_Id; + Var_Id : Entity_Id; + Attrs : Variable_Attributes); + -- Perform ABE checks and diagnostics for reference Ref described by its + -- attributes Attrs, that reads variable Var_Id. + + procedure Process_Guaranteed_ABE (N : Node_Id); + -- Top-level dispatcher for processing of scenarios which result in a + -- guaranteed ABE. + + procedure Process_Guaranteed_ABE_Activation_Impl + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + State : Processing_Attributes); + -- 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. State is provided for compatibility and is not used. + + procedure Process_Guaranteed_ABE_Call (Call : Node_Id; Call_Attrs : Call_Attributes; Target_Id : Entity_Id); @@ -1291,110 +1807,69 @@ -- 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); + procedure Process_Guaranteed_ABE_Instantiation (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); - -- Top level dispatcher for processing of variable assignments. Perform ABE - -- checks and diagnostics for assignment statement Asmt. - - procedure Process_Variable_Assignment_Ada - (Asmt : Node_Id; - Var_Id : Entity_Id); - -- Perform ABE checks and diagnostics for assignment statement Asmt that - -- updates the value of variable Var_Id using the Ada rules. - - procedure Process_Variable_Assignment_SPARK - (Asmt : Node_Id; - Var_Id : Entity_Id); - -- Perform ABE checks and diagnostics for assignment statement Asmt that - -- updates the value of variable Var_Id using the SPARK rules. - - procedure Process_Variable_Read (Ref : Node_Id); - -- Perform ABE checks and diagnostics for reference Ref that reads a - -- variable. - procedure Push_Active_Scenario (N : Node_Id); pragma Inline (Push_Active_Scenario); -- Push scenario N on top of the scenario stack + procedure Record_SPARK_Elaboration_Scenario (N : Node_Id); + pragma Inline (Record_SPARK_Elaboration_Scenario); + -- Save SPARK scenario N in table SPARK_Scenarios for later processing + + procedure Reset_Visited_Bodies; + pragma Inline (Reset_Visited_Bodies); + -- Clear the contents of table Visited_Bodies + 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 + -- 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. + procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id); + pragma Inline (Set_Early_Call_Region); + -- Associate an early call region with begins at construct Start with entry + -- or subprogram body Body_Id. + + procedure Set_Elaboration_Status + (Unit_Id : Entity_Id; + Val : Elaboration_Attributes); + pragma Inline (Set_Elaboration_Status); + -- Associate an set of elaboration attributes with unit Unit_Id + + procedure Set_Is_Recorded_SPARK_Scenario + (N : Node_Id; + Val : Boolean := True); + pragma Inline (Set_Is_Recorded_SPARK_Scenario); + -- Mark scenario N as being recorded in table SPARK_Scenarios + + procedure Set_Is_Recorded_Top_Level_Scenario + (N : Node_Id; + Val : Boolean := True); + pragma Inline (Set_Is_Recorded_Top_Level_Scenario); + -- Mark scenario N as being recorded in table Top_Level_Scenarios + + procedure Set_Is_Visited_Body (Subp_Body : Node_Id); + pragma Inline (Set_Is_Visited_Body); + -- Mark subprogram body Subp_Body as being visited during a recursive + -- traversal started from a top-level scenario. + 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 Traverse_Body (N : Node_Id; State : Processing_Attributes); + -- Inspect the declarative and statement lists of subprogram body N for + -- suitable elaboration scenarios and process them. State is the current + -- state of the Processing phase. + + function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id; + pragma Inline (Unit_Entity); + -- Return the entity of the initial declaration for unit Unit_Id procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id); pragma Inline (Update_Elaboration_Scenario); @@ -1407,11 +1882,11 @@ procedure Build_Call_Marker (N : Node_Id) is function In_External_Context - (Call : Node_Id; - Target_Id : Entity_Id) return Boolean; + (Call : Node_Id; + Target_Attrs : Target_Attributes) return Boolean; pragma Inline (In_External_Context); - -- Determine whether target Target_Id is external to call N which must - -- reside within an instance. + -- Determine whether a target described by attributes Target_Attrs is + -- external to call Call which must reside within an instance. function In_Premature_Context (Call : Node_Id) return Boolean; -- Determine whether call Call appears within a premature context @@ -1435,11 +1910,9 @@ ------------------------- function In_External_Context - (Call : Node_Id; - Target_Id : Entity_Id) return Boolean + (Call : Node_Id; + Target_Attrs : Target_Attributes) return Boolean is - Target_Decl : constant Node_Id := Unit_Declaration_Node (Target_Id); - Inst : Node_Id; Inst_Body : Node_Id; Inst_Decl : Node_Id; @@ -1456,7 +1929,7 @@ -- 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) + and then not In_Extended_Main_Code_Unit (Target_Attrs.Spec_Decl) then return True; @@ -1472,7 +1945,7 @@ -- Performance note: parent traversal return not In_Subtree - (N => Target_Decl, + (N => Target_Attrs.Spec_Decl, Root1 => Inst_Decl, Root2 => Inst_Body); end if; @@ -1583,18 +2056,32 @@ -- Local variables - Call_Attrs : Call_Attributes; - Call_Nam : Node_Id; - Marker : Node_Id; - Target_Id : Entity_Id; + Call_Attrs : Call_Attributes; + Call_Nam : Node_Id; + Marker : Node_Id; + Target_Attrs : Target_Attributes; + Target_Id : Entity_Id; -- Start of processing for Build_Call_Marker begin - -- Nothing to do for ASIS. As a result, ABE checks and diagnostics are - -- not performed in this mode. - - if ASIS_Mode then + -- Nothing to do when switch -gnatH (legacy elaboration checking mode + -- enabled) is in effect because the legacy ABE mechanism does not need + -- to carry out this action. + + if Legacy_Elaboration_Checks then + return; + + -- Nothing to do for ASIS because ABE checks and diagnostics are not + -- performed in this mode. + + elsif ASIS_Mode 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; -- Nothing to do when the input does not denote a call or a requeue @@ -1606,18 +2093,13 @@ 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; - - -- 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 + -- Nothing to do when the input denotes entry call or requeue statement, + -- and switch -gnatd_e (ignore entry calls and requeue statements for + -- elaboration) is in effect. + + elsif Debug_Flag_Underscore_E + and then Nkind_In (N, N_Entry_Call_Statement, N_Requeue_Statement) + then return; end if; @@ -1641,6 +2123,15 @@ and then Is_Generic_Formal_Subp (Entity (Call_Nam)) then return; + + -- Nothing to do when the call is analyzed/resolved too early within an + -- intermediate context. This check is saved for last because it incurs + -- a performance penalty. + + -- Performance note: parent traversal + + elsif In_Premature_Context (N) then + return; end if; Extract_Call_Attributes @@ -1648,11 +2139,15 @@ Target_Id => Target_Id, Attrs => Call_Attrs); + Extract_Target_Attributes + (Target_Id => Target_Id, + Attrs => Target_Attrs); + -- 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. + -- effect. if Debug_Flag_LL and then not Is_Generic_Formal_Subp (Entity (Call_Nam)) @@ -1660,21 +2155,30 @@ -- Performance note: parent traversal and then In_External_Context - (Call => N, - Target_Id => Target_Id) + (Call => N, + Target_Attrs => Target_Attrs) + then + return; + + -- Nothing to do when the call invokes an assertion pragma procedure + -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is + -- in effect. + + elsif Debug_Flag_Underscore_P + and then Is_Assertion_Pragma_Target (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 + elsif Target_Attrs.From_Source and then Call_Attrs.From_Source then null; -- A call to a source function which acts as the default expression in -- another call requires special detection. - elsif Comes_From_Source (Target_Id) + elsif Target_Attrs.From_Source and then Nkind (N) = N_Function_Call and then Is_Default_Expression (N) then @@ -1711,13 +2215,16 @@ -- Inherit the attributes of the original call - 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); + Set_Target (Marker, Target_Id); + Set_Is_Declaration_Level_Node (Marker, Call_Attrs.In_Declarations); + Set_Is_Dispatching_Call (Marker, Call_Attrs.Is_Dispatching); + Set_Is_Elaboration_Checks_OK_Node + (Marker, Call_Attrs.Elab_Checks_OK); + Set_Is_Elaboration_Warnings_OK_Node + (Marker, Call_Attrs.Elab_Warnings_OK); + 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); -- The marker is inserted prior to the original call. This placement has -- several desirable effects: @@ -1758,35 +2265,96 @@ Record_Elaboration_Scenario (Marker); end Build_Call_Marker; + ------------------------------------- + -- Build_Variable_Reference_Marker -- + ------------------------------------- + + procedure Build_Variable_Reference_Marker + (N : Node_Id; + Read : Boolean; + Write : Boolean) + is + Marker : Node_Id; + Var_Attrs : Variable_Attributes; + Var_Id : Entity_Id; + + begin + Extract_Variable_Reference_Attributes + (Ref => N, + Var_Id => Var_Id, + Attrs => Var_Attrs); + + Marker := Make_Variable_Reference_Marker (Sloc (N)); + + -- Inherit the attributes of the original variable reference + + Set_Target (Marker, Var_Id); + Set_Is_Read (Marker, Read); + Set_Is_Write (Marker, Write); + + -- The marker is inserted prior to the original variable reference. The + -- insertion must take place even when the reference does not occur in + -- the main unit to keep the tree symmetric. This ensures that internal + -- name serialization is consistent in case the variable marker causes + -- the tree to transform in some way. + + Insert_Action (N, Marker); + + -- The marker becomes the "corresponding" scenario for the reference. + -- Save the marker for later processing for the ABE phase. + + Record_Elaboration_Scenario (Marker); + end Build_Variable_Reference_Marker; + --------------------------------- -- Check_Elaboration_Scenarios -- --------------------------------- procedure Check_Elaboration_Scenarios is begin - -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics - -- are performed in this mode. - - if ASIS_Mode then - return; - end if; + -- Nothing to do when switch -gnatH (legacy elaboration checking mode + -- enabled) is in effect because the legacy ABE mechanism does not need + -- to carry out this action. + + if Legacy_Elaboration_Checks then + return; + + -- Nothing to do for ASIS because ABE checks and diagnostics are not + -- performed in this mode. + + elsif ASIS_Mode then + return; + end if; + + -- Restore the original elaboration model which was in effect when the + -- scenarios were first recorded. The model may be specified by pragma + -- Elaboration_Checks which appears on the initial declaration of the + -- main unit. + + Install_Elaboration_Model (Unit_Entity (Cunit_Entity (Main_Unit))); -- 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. + -- Examine each top-level scenario saved during the Recording phase for + -- conditional ABEs and perform various actions depending on the model + -- in effect. The table of visited bodies is created for each new top- + -- level scenario. 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)); + Reset_Visited_Bodies; + + Process_Conditional_ABE (Top_Level_Scenarios.Table (Index)); + end loop; + + -- Examine each SPARK scenario saved during the Recording phase which + -- is not necessarily executable during elaboration, but still requires + -- elaboration-related checks. + + for Index in SPARK_Scenarios.First .. SPARK_Scenarios.Last loop + Check_SPARK_Scenario (SPARK_Scenarios.Table (Index)); end loop; end Check_Elaboration_Scenarios; @@ -1852,7 +2420,7 @@ Level := Find_Enclosing_Level (Call); - -- Library level calls are always considered because they are part of + -- Library-level calls are always considered because they are part of -- the associated unit's elaboration actions. if Level in Library_Level then @@ -1883,6 +2451,627 @@ end if; end Check_Preelaborated_Call; + ------------------------------ + -- Check_SPARK_Derived_Type -- + ------------------------------ + + procedure Check_SPARK_Derived_Type (Typ_Decl : Node_Id) is + Typ : constant Entity_Id := Defining_Entity (Typ_Decl); + + -- NOTE: The routines within Check_SPARK_Derived_Type are intentionally + -- unnested to avoid deep indentation of code. + + Stop_Check : exception; + -- This exception is raised when the freeze node violates the placement + -- rules. + + procedure Check_Overriding_Primitive + (Prim : Entity_Id; + FNode : Node_Id); + pragma Inline (Check_Overriding_Primitive); + -- Verify that freeze node FNode is within the early call region of + -- overriding primitive Prim's body. + + function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr; + pragma Inline (Freeze_Node_Location); + -- Return a more accurate source location associated with freeze node + -- FNode. + + function Precedes_Source_Construct (N : Node_Id) return Boolean; + pragma Inline (Precedes_Source_Construct); + -- Determine whether arbitrary node N appears prior to some source + -- construct. + + procedure Suggest_Elaborate_Body + (N : Node_Id; + Body_Decl : Node_Id; + Error_Nod : Node_Id); + pragma Inline (Suggest_Elaborate_Body); + -- Suggest the use of pragma Elaborate_Body when the pragma will allow + -- for node N to appear within the early call region of subprogram body + -- Body_Decl. The suggestion is attached to Error_Nod as a continuation + -- error. + + -------------------------------- + -- Check_Overriding_Primitive -- + -------------------------------- + + procedure Check_Overriding_Primitive + (Prim : Entity_Id; + FNode : Node_Id) + is + Prim_Decl : constant Node_Id := Unit_Declaration_Node (Prim); + Body_Decl : Node_Id; + Body_Id : Entity_Id; + Region : Node_Id; + + begin + -- Nothing to do for predefined primitives because they are artifacts + -- of tagged type expansion and cannot override source primitives. + + if Is_Predefined_Dispatching_Operation (Prim) then + return; + end if; + + Body_Id := Corresponding_Body (Prim_Decl); + + -- Nothing to do when the primitive does not have a corresponding + -- body. This can happen when the unit with the bodies is not the + -- main unit subjected to ABE checks. + + if No (Body_Id) then + return; + + -- The primitive overrides a parent or progenitor primitive + + elsif Present (Overridden_Operation (Prim)) then + + -- Nothing to do when overriding an interface primitive happens by + -- inheriting a non-interface primitive as the check would be done + -- on the parent primitive. + + if Present (Alias (Prim)) then + return; + end if; + + -- Nothing to do when the primitive is not overriding. The body of + -- such a primitive cannot be targeted by a dispatching call which + -- is executable during elaboration, and cannot cause an ABE. + + else + return; + end if; + + Body_Decl := Unit_Declaration_Node (Body_Id); + Region := Find_Early_Call_Region (Body_Decl); + + -- The freeze node appears prior to the early call region of the + -- primitive body. + + -- IMPORTANT: This check must always be performed even when -gnatd.v + -- (enforce SPARK elaboration rules in SPARK code) is not specified + -- because the static model cannot guarantee the absence of ABEs in + -- in the presence of dispatching calls. + + if Earlier_In_Extended_Unit (FNode, Region) then + Error_Msg_Node_2 := Prim; + Error_Msg_NE + ("first freezing point of type & must appear within early call " + & "region of primitive body & (SPARK RM 7.7(8))", + Typ_Decl, Typ); + + Error_Msg_Sloc := Sloc (Region); + Error_Msg_N ("\region starts #", Typ_Decl); + + Error_Msg_Sloc := Sloc (Body_Decl); + Error_Msg_N ("\region ends #", Typ_Decl); + + Error_Msg_Sloc := Freeze_Node_Location (FNode); + Error_Msg_N ("\first freezing point #", Typ_Decl); + + -- If applicable, suggest the use of pragma Elaborate_Body in the + -- associated package spec. + + Suggest_Elaborate_Body + (N => FNode, + Body_Decl => Body_Decl, + Error_Nod => Typ_Decl); + + raise Stop_Check; + end if; + end Check_Overriding_Primitive; + + -------------------------- + -- Freeze_Node_Location -- + -------------------------- + + function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr is + Context : constant Node_Id := Parent (FNode); + Loc : constant Source_Ptr := Sloc (FNode); + + Prv_Decls : List_Id; + Vis_Decls : List_Id; + + begin + -- In general, the source location of the freeze node is as close as + -- possible to the real freeze point, except when the freeze node is + -- at the "bottom" of a package spec. + + if Nkind (Context) = N_Package_Specification then + Prv_Decls := Private_Declarations (Context); + Vis_Decls := Visible_Declarations (Context); + + -- The freeze node appears in the private declarations of the + -- package. + + if Present (Prv_Decls) + and then List_Containing (FNode) = Prv_Decls + then + null; + + -- The freeze node appears in the visible declarations of the + -- package and there are no private declarations. + + elsif Present (Vis_Decls) + and then List_Containing (FNode) = Vis_Decls + and then (No (Prv_Decls) or else Is_Empty_List (Prv_Decls)) + then + null; + + -- Otherwise the freeze node is not in the "last" declarative list + -- of the package. Use the existing source location of the freeze + -- node. + + else + return Loc; + end if; + + -- The freeze node appears at the "bottom" of the package when it + -- is in the "last" declarative list and is either the last in the + -- list or is followed by internal constructs only. In that case + -- the more appropriate source location is that of the package end + -- label. + + if not Precedes_Source_Construct (FNode) then + return Sloc (End_Label (Context)); + end if; + end if; + + return Loc; + end Freeze_Node_Location; + + ------------------------------- + -- Precedes_Source_Construct -- + ------------------------------- + + function Precedes_Source_Construct (N : Node_Id) return Boolean is + Decl : Node_Id; + + begin + Decl := Next (N); + while Present (Decl) loop + if Comes_From_Source (Decl) then + return True; + + -- A generated body for a source expression function is treated as + -- a source construct. + + elsif Nkind (Decl) = N_Subprogram_Body + and then Was_Expression_Function (Decl) + and then Comes_From_Source (Original_Node (Decl)) + then + return True; + end if; + + Next (Decl); + end loop; + + return False; + end Precedes_Source_Construct; + + ---------------------------- + -- Suggest_Elaborate_Body -- + ---------------------------- + + procedure Suggest_Elaborate_Body + (N : Node_Id; + Body_Decl : Node_Id; + Error_Nod : Node_Id) + is + Unt : constant Node_Id := Unit (Cunit (Main_Unit)); + Region : Node_Id; + + begin + -- The suggestion applies only when the subprogram body resides in a + -- compilation package body, and a pragma Elaborate_Body would allow + -- for the node to appear in the early call region of the subprogram + -- body. This implies that all code from the subprogram body up to + -- the node is preelaborable. + + if Nkind (Unt) = N_Package_Body then + + -- Find the start of the early call region again assuming that the + -- package spec has pragma Elaborate_Body. Note that the internal + -- data structures are intentionally not updated because this is a + -- speculative search. + + Region := + Find_Early_Call_Region + (Body_Decl => Body_Decl, + Assume_Elab_Body => True, + Skip_Memoization => True); + + -- If the node appears within the early call region, assuming that + -- the package spec carries pragma Elaborate_Body, then it is safe + -- to suggest the pragma. + + if Earlier_In_Extended_Unit (Region, N) then + Error_Msg_Name_1 := Name_Elaborate_Body; + Error_Msg_NE + ("\consider adding pragma % in spec of unit &", + Error_Nod, Defining_Entity (Unt)); + end if; + end if; + end Suggest_Elaborate_Body; + + -- Local variables + + FNode : constant Node_Id := Freeze_Node (Typ); + Prims : constant Elist_Id := Direct_Primitive_Operations (Typ); + + Prim_Elmt : Elmt_Id; + + -- Start of processing for Check_SPARK_Derived_Type + + begin + -- A type should have its freeze node set by the time SPARK scenarios + -- are being verified. + + pragma Assert (Present (FNode)); + + -- Verify that the freeze node of the derived type is within the early + -- call region of each overriding primitive body (SPARK RM 7.7(8)). + + if Present (Prims) then + Prim_Elmt := First_Elmt (Prims); + while Present (Prim_Elmt) loop + Check_Overriding_Primitive + (Prim => Node (Prim_Elmt), + FNode => FNode); + + Next_Elmt (Prim_Elmt); + end loop; + end if; + + exception + when Stop_Check => + null; + end Check_SPARK_Derived_Type; + + ------------------------------- + -- Check_SPARK_Instantiation -- + ------------------------------- + + procedure Check_SPARK_Instantiation (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 + 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 instantiation and the generic body are both in the main unit + + if Present (Gen_Attrs.Body_Decl) + and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl) + + -- If the instantiation appears prior to the generic body, then the + -- instantiation is illegal (SPARK RM 7.7(6)). + + -- IMPORTANT: This check must always be performed even when -gnatd.v + -- (enforce SPARK elaboration rules in SPARK code) is not specified + -- because the rule prevents use-before-declaration of objects that + -- may precede the generic body. + + and then Earlier_In_Extended_Unit (Inst, Gen_Attrs.Body_Decl) + then + Error_Msg_NE ("cannot instantiate & before body seen", Inst, Gen_Id); + end if; + end Check_SPARK_Instantiation; + + --------------------------------- + -- Check_SPARK_Model_In_Effect -- + --------------------------------- + + SPARK_Model_Warning_Posted : Boolean := False; + -- This flag prevents the same SPARK model-related warning from being + -- emitted multiple times. + + procedure Check_SPARK_Model_In_Effect (N : Node_Id) is + begin + -- Do not emit the warning multiple times as this creates useless noise + + if SPARK_Model_Warning_Posted then + null; + + -- SPARK rule verification requires the "strict" static model + + elsif Static_Elaboration_Checks and not Relaxed_Elaboration_Checks then + null; + + -- Any other combination of models does not guarantee the absence of ABE + -- problems for SPARK rule verification purposes. Note that there is no + -- need to check for the legacy ABE mechanism because the legacy code + -- has its own orthogonal processing for SPARK rules. + + else + SPARK_Model_Warning_Posted := True; + + Error_Msg_N + ("??SPARK elaboration checks require static elaboration model", N); + + if Dynamic_Elaboration_Checks then + Error_Msg_N ("\dynamic elaboration model is in effect", N); + else + pragma Assert (Relaxed_Elaboration_Checks); + Error_Msg_N ("\relaxed elaboration model is in effect", N); + end if; + end if; + end Check_SPARK_Model_In_Effect; + + -------------------------- + -- Check_SPARK_Scenario -- + -------------------------- + + procedure Check_SPARK_Scenario (N : Node_Id) is + begin + -- Ensure that a suitable elaboration model is in effect for SPARK rule + -- verification. + + Check_SPARK_Model_In_Effect (N); + + -- Add the current scenario to the stack of active scenarios + + Push_Active_Scenario (N); + + if Is_Suitable_SPARK_Derived_Type (N) then + Check_SPARK_Derived_Type (N); + + elsif Is_Suitable_SPARK_Instantiation (N) then + Check_SPARK_Instantiation (N); + + elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then + Check_SPARK_Refined_State_Pragma (N); + end if; + + -- Remove the current scenario from the stack of active scenarios once + -- all ABE diagnostics and checks have been performed. + + Pop_Active_Scenario (N); + end Check_SPARK_Scenario; + + -------------------------------------- + -- Check_SPARK_Refined_State_Pragma -- + -------------------------------------- + + procedure Check_SPARK_Refined_State_Pragma (N : Node_Id) is + + -- NOTE: The routines within Check_SPARK_Refined_State_Pragma are + -- intentionally unnested to avoid deep indentation of code. + + procedure Check_SPARK_Constituent (Constit_Id : Entity_Id); + pragma Inline (Check_SPARK_Constituent); + -- Ensure that a single constituent Constit_Id is elaborated prior to + -- the main unit. + + procedure Check_SPARK_Constituents (Constits : Elist_Id); + pragma Inline (Check_SPARK_Constituents); + -- Ensure that all constituents found in list Constits are elaborated + -- prior to the main unit. + + procedure Check_SPARK_Initialized_State (State : Node_Id); + pragma Inline (Check_SPARK_Initialized_State); + -- Ensure that the constituents of single abstract state State are + -- elaborated prior to the main unit. + + procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id); + pragma Inline (Check_SPARK_Initialized_States); + -- Ensure that the constituents of all abstract states which appear in + -- the Initializes pragma of package Pack_Id are elaborated prior to the + -- main unit. + + ----------------------------- + -- Check_SPARK_Constituent -- + ----------------------------- + + procedure Check_SPARK_Constituent (Constit_Id : Entity_Id) is + Prag : Node_Id; + + begin + -- Nothing to do for "null" constituents + + if Nkind (Constit_Id) = N_Null then + return; + + -- Nothing to do for illegal constituents + + elsif Error_Posted (Constit_Id) then + return; + end if; + + Prag := SPARK_Pragma (Constit_Id); + + -- The check applies only when the constituent is subject to pragma + -- SPARK_Mode On. + + if Present (Prag) + and then Get_SPARK_Mode_From_Annotation (Prag) = On + then + -- An external constituent of an abstract state which appears in + -- the Initializes pragma of a package spec imposes an Elaborate + -- requirement on the context of the main unit. Determine whether + -- the context has a pragma strong enough to meet the requirement. + + -- IMPORTANT: This check is performed only when -gnatd.v (enforce + -- SPARK elaboration rules in SPARK code) is in effect because the + -- static model can ensure the prior elaboration of the unit which + -- contains a constituent by installing implicit Elaborate pragma. + + if Debug_Flag_Dot_V then + Meet_Elaboration_Requirement + (N => N, + Target_Id => Constit_Id, + Req_Nam => Name_Elaborate); + + -- Otherwise ensure that the unit with the external constituent is + -- elaborated prior to the main unit. + + else + Ensure_Prior_Elaboration + (N => N, + Unit_Id => Find_Top_Unit (Constit_Id), + Prag_Nam => Name_Elaborate, + State => Initial_State); + end if; + end if; + end Check_SPARK_Constituent; + + ------------------------------ + -- Check_SPARK_Constituents -- + ------------------------------ + + procedure Check_SPARK_Constituents (Constits : Elist_Id) is + Constit_Elmt : Elmt_Id; + + begin + if Present (Constits) then + Constit_Elmt := First_Elmt (Constits); + while Present (Constit_Elmt) loop + Check_SPARK_Constituent (Node (Constit_Elmt)); + Next_Elmt (Constit_Elmt); + end loop; + end if; + end Check_SPARK_Constituents; + + ----------------------------------- + -- Check_SPARK_Initialized_State -- + ----------------------------------- + + procedure Check_SPARK_Initialized_State (State : Node_Id) is + Prag : Node_Id; + State_Id : Entity_Id; + + begin + -- Nothing to do for "null" initialization items + + if Nkind (State) = N_Null then + return; + + -- Nothing to do for illegal states + + elsif Error_Posted (State) then + return; + end if; + + State_Id := Entity_Of (State); + + -- Sanitize the state + + if No (State_Id) then + return; + + elsif Error_Posted (State_Id) then + return; + + elsif Ekind (State_Id) /= E_Abstract_State then + return; + end if; + + -- The check is performed only when the abstract state is subject to + -- SPARK_Mode On. + + Prag := SPARK_Pragma (State_Id); + + if Present (Prag) + and then Get_SPARK_Mode_From_Annotation (Prag) = On + then + Check_SPARK_Constituents (Refinement_Constituents (State_Id)); + end if; + end Check_SPARK_Initialized_State; + + ------------------------------------ + -- Check_SPARK_Initialized_States -- + ------------------------------------ + + procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id) is + Prag : constant Node_Id := Get_Pragma (Pack_Id, Pragma_Initializes); + Init : Node_Id; + Inits : Node_Id; + + begin + if Present (Prag) then + Inits := Expression (Get_Argument (Prag, Pack_Id)); + + -- Avoid processing a "null" initialization list. The only other + -- alternative is an aggregate. + + if Nkind (Inits) = N_Aggregate then + + -- The initialization items appear in list form: + -- + -- (state1, state2) + + if Present (Expressions (Inits)) then + Init := First (Expressions (Inits)); + while Present (Init) loop + Check_SPARK_Initialized_State (Init); + Next (Init); + end loop; + end if; + + -- The initialization items appear in associated form: + -- + -- (state1 => item1, + -- state2 => (item2, item3)) + + if Present (Component_Associations (Inits)) then + Init := First (Component_Associations (Inits)); + while Present (Init) loop + Check_SPARK_Initialized_State (Init); + Next (Init); + end loop; + end if; + end if; + end if; + end Check_SPARK_Initialized_States; + + -- Local variables + + Pack_Body : constant Node_Id := Find_Related_Package_Or_Body (N); + + -- Start of processing for Check_SPARK_Refined_State_Pragma + + begin + -- Pragma Refined_State must be associated with a package body + + pragma Assert + (Present (Pack_Body) and then Nkind (Pack_Body) = N_Package_Body); + + -- Verify that each external contitunent of an abstract state mentioned + -- in pragma Initializes is properly elaborated. + + Check_SPARK_Initialized_States (Unique_Defining_Entity (Pack_Body)); + end Check_SPARK_Refined_State_Pragma; + ---------------------- -- Compilation_Unit -- ---------------------- @@ -1931,6 +3120,36 @@ return Comp_Unit; end Compilation_Unit; + ----------------------- + -- Early_Call_Region -- + ----------------------- + + function Early_Call_Region (Body_Id : Entity_Id) return Node_Id is + begin + pragma Assert (Ekind_In (Body_Id, E_Entry, + E_Entry_Family, + E_Function, + E_Procedure, + E_Subprogram_Body)); + + if Early_Call_Regions_In_Use then + return Early_Call_Regions.Get (Body_Id); + end if; + + return Early_Call_Regions_No_Element; + end Early_Call_Region; + + ----------------------------- + -- Early_Call_Regions_Hash -- + ----------------------------- + + function Early_Call_Regions_Hash + (Key : Entity_Id) return Early_Call_Regions_Index + is + begin + return Early_Call_Regions_Index (Key mod Early_Call_Regions_Max); + end Early_Call_Regions_Hash; + ----------------- -- Elab_Msg_NE -- ----------------- @@ -1980,66 +3199,63 @@ 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 + ------------------------ + -- Elaboration_Status -- + ------------------------ + + function Elaboration_Status + (Unit_Id : Entity_Id) return Elaboration_Attributes is begin - return Elaboration_Context_Index (Key mod Elaboration_Context_Max); - end Elaboration_Context_Hash; + if Elaboration_Statuses_In_Use then + return Elaboration_Statuses.Get (Unit_Id); + end if; + + return Elaboration_Statuses_No_Element; + end Elaboration_Status; + + ------------------------------- + -- Elaboration_Statuses_Hash -- + ------------------------------- + + function Elaboration_Statuses_Hash + (Key : Entity_Id) return Elaboration_Statuses_Index + is + begin + return Elaboration_Statuses_Index (Key mod Elaboration_Statuses_Max); + end Elaboration_Statuses_Hash; ------------------------------ -- Ensure_Prior_Elaboration -- ------------------------------ procedure Ensure_Prior_Elaboration - (N : Node_Id; - Unit_Id : Entity_Id; - In_Task_Body : Boolean) - is + (N : Node_Id; + Unit_Id : Entity_Id; 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; + State : Processing_Attributes) + is + begin + pragma Assert (Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All)); + + -- Nothing to do when the caller has suppressed the generation of + -- implicit Elaborate[_All] pragmas. + + if State.Suppress_Implicit_Pragmas then + return; + + -- Nothing to do when the need for prior elaboration came from a partial + -- finalization routine which occurs in an initialization context. This + -- behaviour parallels that of the old ABE mechanism. + + elsif State.Within_Partial_Finalization then + return; -- 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 Debug_Flag_Dot_Y and then In_Task_Body then + elsif Debug_Flag_Dot_Y and then State.Within_Task_Body then return; -- Nothing to do when the unit is elaborated prior to the main unit. @@ -2170,7 +3386,7 @@ -- Start of processing for Ensure_Prior_Elaboration_Dynamic begin - Elab_Attrs := Elaboration_Context.Get (Unit_Id); + Elab_Attrs := Elaboration_Status (Unit_Id); -- Nothing to do when the unit is guaranteed prior elaboration by means -- of a source Elaborate[_All] pragma. @@ -2299,9 +3515,6 @@ 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; - Clause : Node_Id; Elab_Attrs : Elaboration_Attributes; Items : List_Id; @@ -2309,7 +3522,7 @@ -- Start of processing for Ensure_Prior_Elaboration_Static begin - Elab_Attrs := Elaboration_Context.Get (Unit_Id); + Elab_Attrs := Elaboration_Status (Unit_Id); -- Nothing to do when the unit is guaranteed prior elaboration by means -- of a source Elaborate[_All] pragma. @@ -2374,14 +3587,10 @@ Append_To (Items, Clause); end if; - -- Instantiations require an implicit Elaborate because Elaborate_All is - -- too conservative and may introduce non-existent elaboration cycles. - - if Is_Instantiation then + -- Mark the with clause depending on the pragma required + + if Prag_Nam = Name_Elaborate then Set_Elaborate_Desirable (Clause); - - -- Otherwise generate an implicit Elaborate_All - else Set_Elaborate_All_Desirable (Clause); end if; @@ -2389,9 +3598,10 @@ -- 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)); + Set_Elaboration_Status + (Unit_Id => Unit_Id, + Val => 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 @@ -2482,6 +3692,7 @@ -- Set all attributes Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call); + Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call); Attrs.From_Source := From_Source; Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Call); Attrs.In_Declarations := In_Declarations; @@ -2568,8 +3779,8 @@ Attrs : out Instantiation_Attributes) is begin - Inst := Original_Node (Exp_Inst); - Inst_Id := Defining_Entity (Inst); + Inst := Original_Node (Exp_Inst); + Inst_Id := Defining_Entity (Inst); -- Traverse a possible chain of renamings to obtain the original generic -- being instantiatied. @@ -2579,6 +3790,7 @@ -- Set all attributes Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst); + Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_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); @@ -2859,6 +4071,7 @@ Attrs.Body_Barf := Body_Barf; Attrs.Body_Decl := Body_Decl; Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Target_Id); + Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_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 := @@ -2909,6 +4122,7 @@ Attrs.Body_Decl := Body_Decl; Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Task_Typ); + Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_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; @@ -2932,14 +4146,45 @@ 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); + function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id; + -- Obtain the ultimate renamed variable of variable Id + + -------------------------- + -- Get_Renamed_Variable -- + -------------------------- + + function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id is + Ren_Id : Entity_Id; + + begin + Ren_Id := Id; + while Present (Renamed_Entity (Ren_Id)) + and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity + loop + Ren_Id := Renamed_Entity (Ren_Id); + end loop; + + return Ren_Id; + end Get_Renamed_Variable; + + -- Start of processing for Extract_Variable_Reference_Attributes + + begin + -- Extraction for variable reference markers + + if Nkind (Ref) = N_Variable_Reference_Marker then + Var_Id := Target (Ref); + + -- Extraction for expanded names and identifiers + + else + Var_Id := Entity (Ref); + end if; + + -- Obtain the original variable which the reference mentions + + Var_Id := Get_Renamed_Variable (Var_Id); + Attrs.Unit_Id := Find_Top_Unit (Var_Id); -- At this point certain attributes should always be available @@ -2955,6 +4200,847 @@ return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (N)))); end Find_Code_Unit; + ---------------------------- + -- Find_Early_Call_Region -- + ---------------------------- + + function Find_Early_Call_Region + (Body_Decl : Node_Id; + Assume_Elab_Body : Boolean := False; + Skip_Memoization : Boolean := False) return Node_Id + is + -- NOTE: The routines within Find_Early_Call_Region are intentionally + -- unnested to avoid deep indentation of code. + + ECR_Found : exception; + -- This exception is raised when the early call region has been found + + Start : Node_Id := Empty; + -- The start of the early call region. This variable is updated by the + -- various nested routines. Due to the use of exceptions, the variable + -- must be global to the nested routines. + + -- The algorithm implemented in this routine attempts to find the early + -- call region of a subprogram body by inspecting constructs in reverse + -- declarative order, while navigating the tree. The algorithm consists + -- of an Inspection phase and an Advancement phase. The pseudocode is as + -- follows: + -- + -- loop + -- inspection phase + -- advancement phase + -- end loop + -- + -- The infinite loop is terminated by raising exception ECR_Found. The + -- algorithm utilizes two pointers, Curr and Start, to represent the + -- current construct to inspect and the start of the early call region. + -- + -- IMPORTANT: The algorithm must maintain the following invariant at all + -- time for it to function properly - a nested construct is entered only + -- when it contains suitable constructs. This guarantees that leaving a + -- nested or encapsulating construct functions properly. + -- + -- The Inspection phase determines whether the current construct is non- + -- preelaborable, and if it is, the algorithm terminates. + -- + -- The Advancement phase walks the tree in reverse declarative order, + -- while entering and leaving nested and encapsulating constructs. It + -- may also terminate the elaborithm. There are several special cases + -- of advancement. + -- + -- 1) General case: + -- + -- <construct 1> + -- ... + -- <construct N-1> <- Curr + -- <construct N> <- Start + -- <subprogram body> + -- + -- In the general case, a declarative or statement list is traversed in + -- reverse order where Curr is the lead pointer, and Start indicates the + -- last preelaborable construct. + -- + -- 2) Entering handled bodies + -- + -- package body Nested is <- Curr (2.3) + -- <declarations> <- Curr (2.2) + -- begin + -- <statements> <- Curr (2.1) + -- end Nested; + -- <construct> <- Start + -- + -- In this case, the algorithm enters a handled body by starting from + -- the last statement (2.1), or the last declaration (2.2), or the body + -- is consumed (2.3) because it is empty and thus preelaborable. + -- + -- 3) Entering package declarations + -- + -- package Nested is <- Curr (2.3) + -- <visible declarations> <- Curr (2.2) + -- private + -- <private declarations> <- Curr (2.1) + -- end Nested; + -- <construct> <- Start + -- + -- In this case, the algorithm enters a package declaration by starting + -- from the last private declaration (2.1), the last visible declaration + -- (2.2), or the package is consumed (2.3) because it is empty and thus + -- preelaborable. + -- + -- 4) Transitioning from list to list of the same construct + -- + -- Certain constructs have two eligible lists. The algorithm must thus + -- transition from the second to the first list when the second list is + -- exhausted. + -- + -- declare <- Curr (4.2) + -- <declarations> <- Curr (4.1) + -- begin + -- <statements> <- Start + -- end; + -- + -- In this case, the algorithm has exhausted the second list (statements + -- in the example), and continues with the last declaration (4.1) or the + -- construct is consumed (4.2) because it contains only preelaborable + -- code. + -- + -- 5) Transitioning from list to construct + -- + -- tack body Task is <- Curr (5.1) + -- <- Curr (Empty) + -- <construct 1> <- Start + -- + -- In this case, the algorithm has exhausted a list, Curr is Empty, and + -- the owner of the list is consumed (5.1). + -- + -- 6) Transitioning from unit to unit + -- + -- A package body with a spec subject to pragma Elaborate_Body extends + -- the possible range of the early call region to the package spec. + -- + -- package Pack is <- Curr (6.3) + -- pragma Elaborate_Body; <- Curr (6.2) + -- <visible declarations> <- Curr (6.2) + -- private + -- <private declarations> <- Curr (6.1) + -- end Pack; + -- + -- package body Pack is <- Curr, Start + -- + -- In this case, the algorithm has reached a package body compilation + -- unit whose spec is subject to pragma Elaborate_Body, or the caller + -- of the algorithm has specified this behavior. This transition is + -- equivalent to 3). + -- + -- 7) Transitioning from unit to termination + -- + -- Reaching a compilation unit always terminates the algorithm as there + -- are no more lists to examine. This must take 6) into account. + -- + -- 8) Transitioning from subunit to stub + -- + -- package body Pack is separate; <- Curr (8.1) + -- + -- separate (...) + -- package body Pack is <- Curr, Start + -- + -- Reaching a subunit continues the search from the corresponding stub + -- (8.1). + + procedure Advance (Curr : in out Node_Id); + pragma Inline (Advance); + -- Update the Curr and Start pointers depending on their location in the + -- tree to the next eligible construct. This routine raises ECR_Found. + + procedure Enter_Handled_Body (Curr : in out Node_Id); + pragma Inline (Enter_Handled_Body); + -- Update the Curr and Start pointers to enter a nested handled body if + -- applicable. This routine raises ECR_Found. + + procedure Enter_Package_Declaration (Curr : in out Node_Id); + pragma Inline (Enter_Package_Declaration); + -- Update the Curr and Start pointers to enter a nested package spec if + -- applicable. This routine raises ECR_Found. + + function Find_ECR (N : Node_Id) return Node_Id; + pragma Inline (Find_ECR); + -- Find an early call region starting from arbitrary node N + + function Has_Suitable_Construct (List : List_Id) return Boolean; + pragma Inline (Has_Suitable_Construct); + -- Determine whether list List contains at least one suitable construct + -- for inclusion into an early call region. + + procedure Include (N : Node_Id; Curr : out Node_Id); + pragma Inline (Include); + -- Update the Curr and Start pointers to include arbitrary construct N + -- in the early call region. This routine raises ECR_Found. + + function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean; + pragma Inline (Is_OK_Preelaborable_Construct); + -- Determine whether arbitrary node N denotes a preelaboration-safe + -- construct. + + function Is_Suitable_Construct (N : Node_Id) return Boolean; + pragma Inline (Is_Suitable_Construct); + -- Determine whether arbitrary node N denotes a suitable construct for + -- inclusion into the early call region. + + procedure Transition_Body_Declarations + (Bod : Node_Id; + Curr : out Node_Id); + pragma Inline (Transition_Body_Declarations); + -- Update the Curr and Start pointers when construct Bod denotes a block + -- statement or a suitable body. This routine raises ECR_Found. + + procedure Transition_Handled_Statements + (HSS : Node_Id; + Curr : out Node_Id); + pragma Inline (Transition_Handled_Statements); + -- Update the Curr and Start pointers when node HSS denotes a handled + -- sequence of statements. This routine raises ECR_Found. + + procedure Transition_Spec_Declarations + (Spec : Node_Id; + Curr : out Node_Id); + pragma Inline (Transition_Spec_Declarations); + -- Update the Curr and Start pointers when construct Spec denotes + -- a concurrent definition or a package spec. This routine raises + -- ECR_Found. + + procedure Transition_Unit (Unit : Node_Id; Curr : out Node_Id); + pragma Inline (Transition_Unit); + -- Update the Curr and Start pointers when node Unit denotes a potential + -- compilation unit. This routine raises ECR_Found. + + ------------- + -- Advance -- + ------------- + + procedure Advance (Curr : in out Node_Id) is + Context : Node_Id; + + begin + -- Curr denotes one of the following cases upon entry into this + -- routine: + -- + -- * Empty - There is no current construct when a declarative or a + -- statement list has been exhausted. This does not necessarily + -- indicate that the early call region has been computed as it + -- may still be possible to transition to another list. + -- + -- * Encapsulator - The current construct encapsulates declarations + -- and/or statements. This indicates that the early call region + -- may extend within the nested construct. + -- + -- * Preelaborable - The current construct is always preelaborable + -- because Find_ECR would not invoke Advance if this was not the + -- case. + + -- The current construct is an encapsulator or is preelaborable + + if Present (Curr) then + + -- Enter encapsulators by inspecting their declarations and/or + -- statements. + + if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then + Enter_Handled_Body (Curr); + + elsif Nkind (Curr) = N_Package_Declaration then + Enter_Package_Declaration (Curr); + + -- Early call regions have a property which can be exploited to + -- optimize the algorithm. + -- + -- <preceding subprogram body> + -- <preelaborable construct 1> + -- ... + -- <preelaborable construct N> + -- <initiating subprogram body> + -- + -- If a traversal initiated from a subprogram body reaches a + -- preceding subprogram body, then both bodies share the same + -- early call region. + -- + -- The property results in the following desirable effects: + -- + -- * If the preceding body already has an early call region, then + -- the initiating body can reuse it. This minimizes the amount + -- of processing performed by the algorithm. + -- + -- * If the preceding body lack an early call region, then the + -- algorithm can compute the early call region, and reuse it + -- for the initiating body. This processing performs the same + -- amount of work, but has the beneficial effect of computing + -- the early call regions of all preceding bodies. + + elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then + Start := + Find_Early_Call_Region + (Body_Decl => Curr, + Assume_Elab_Body => Assume_Elab_Body, + Skip_Memoization => Skip_Memoization); + + raise ECR_Found; + + -- Otherwise current construct is preelaborable. Unpdate the early + -- call region to include it. + + else + Include (Curr, Curr); + end if; + + -- Otherwise the current construct is missing, indicating that the + -- current list has been exhausted. Depending on the context of the + -- list, several transitions are possible. + + else + -- The invariant of the algorithm ensures that Curr and Start are + -- at the same level of nesting at the point of a transition. The + -- algorithm can determine which list the traversal came from by + -- examining Start. + + Context := Parent (Start); + + -- Attempt the following transitions: + -- + -- private declarations -> visible declarations + -- private declarations -> upper level + -- private declarations -> terminate + -- visible declarations -> upper level + -- visible declarations -> terminate + + if Nkind_In (Context, N_Package_Specification, + N_Protected_Definition, + N_Task_Definition) + then + Transition_Spec_Declarations (Context, Curr); + + -- Attempt the following transitions: + -- + -- statements -> declarations + -- statements -> upper level + -- statements -> corresponding package spec (Elab_Body) + -- statements -> terminate + + elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then + Transition_Handled_Statements (Context, Curr); + + -- Attempt the following transitions: + -- + -- declarations -> upper level + -- declarations -> corresponding package spec (Elab_Body) + -- declarations -> terminate + + elsif Nkind_In (Context, N_Block_Statement, + N_Entry_Body, + N_Package_Body, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body) + then + Transition_Body_Declarations (Context, Curr); + + -- Otherwise it is not possible to transition. Stop the search + -- because there are no more declarations or statements to check. + + else + raise ECR_Found; + end if; + end if; + end Advance; + + -------------------------- + -- Enter_Handled_Body -- + -------------------------- + + procedure Enter_Handled_Body (Curr : in out Node_Id) is + Decls : constant List_Id := Declarations (Curr); + HSS : constant Node_Id := Handled_Statement_Sequence (Curr); + Stmts : List_Id := No_List; + + begin + if Present (HSS) then + Stmts := Statements (HSS); + end if; + + -- The handled body has a non-empty statement sequence. The construct + -- to inspect is the last statement. + + if Has_Suitable_Construct (Stmts) then + Curr := Last (Stmts); + + -- The handled body lacks statements, but has non-empty declarations. + -- The construct to inspect is the last declaration. + + elsif Has_Suitable_Construct (Decls) then + Curr := Last (Decls); + + -- Otherwise the handled body lacks both declarations and statements. + -- The construct to inspect is the node which precedes the handled + -- body. Update the early call region to include the handled body. + + else + Include (Curr, Curr); + end if; + end Enter_Handled_Body; + + ------------------------------- + -- Enter_Package_Declaration -- + ------------------------------- + + procedure Enter_Package_Declaration (Curr : in out Node_Id) is + Pack_Spec : constant Node_Id := Specification (Curr); + Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec); + Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec); + + begin + -- The package has a non-empty private declarations. The construct to + -- inspect is the last private declaration. + + if Has_Suitable_Construct (Prv_Decls) then + Curr := Last (Prv_Decls); + + -- The package lacks private declarations, but has non-empty visible + -- declarations. In this case the construct to inspect is the last + -- visible declaration. + + elsif Has_Suitable_Construct (Vis_Decls) then + Curr := Last (Vis_Decls); + + -- Otherwise the package lacks any declarations. The construct to + -- inspect is the node which precedes the package. Update the early + -- call region to include the package declaration. + + else + Include (Curr, Curr); + end if; + end Enter_Package_Declaration; + + -------------- + -- Find_ECR -- + -------------- + + function Find_ECR (N : Node_Id) return Node_Id is + Curr : Node_Id; + + begin + -- The early call region starts at N + + Curr := Prev (N); + Start := N; + + -- Inspect each node in reverse declarative order while going in and + -- out of nested and enclosing constructs. Note that the only way to + -- terminate this infinite loop is to raise exception ECR_Found. + + loop + -- The current construct is not preelaboration-safe. Terminate the + -- traversal. + + if Present (Curr) + and then not Is_OK_Preelaborable_Construct (Curr) + then + raise ECR_Found; + end if; + + -- Advance to the next suitable construct. This may terminate the + -- traversal by raising ECR_Found. + + Advance (Curr); + end loop; + + exception + when ECR_Found => + return Start; + end Find_ECR; + + ---------------------------- + -- Has_Suitable_Construct -- + ---------------------------- + + function Has_Suitable_Construct (List : List_Id) return Boolean is + Item : Node_Id; + + begin + -- Examine the list in reverse declarative order, looking for a + -- suitable construct. + + if Present (List) then + Item := Last (List); + while Present (Item) loop + if Is_Suitable_Construct (Item) then + return True; + end if; + + Prev (Item); + end loop; + end if; + + return False; + end Has_Suitable_Construct; + + ------------- + -- Include -- + ------------- + + procedure Include (N : Node_Id; Curr : out Node_Id) is + begin + Start := N; + + -- The input node is a compilation unit. This terminates the search + -- because there are no more lists to inspect and there are no more + -- enclosing constructs to climb up to. The transitions are: + -- + -- private declarations -> terminate + -- visible declarations -> terminate + -- statements -> terminate + -- declarations -> terminate + + if Nkind (Parent (Start)) = N_Compilation_Unit then + raise ECR_Found; + + -- Otherwise the input node is still within some list + + else + Curr := Prev (Start); + end if; + end Include; + + ----------------------------------- + -- Is_OK_Preelaborable_Construct -- + ----------------------------------- + + function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is + begin + -- Assignment statements are acceptable as long as they were produced + -- by the ABE mechanism to update elaboration flags. + + if Nkind (N) = N_Assignment_Statement then + return Is_Elaboration_Code (N); + + -- Block statements are acceptable even though they directly violate + -- preelaborability. The intention is not to penalize the early call + -- region when a block contains only preelaborable constructs. + -- + -- declare + -- Val : constant Integer := 1; + -- begin + -- pragma Assert (Val = 1); + -- null; + -- end; + -- + -- Note that the Advancement phase does enter blocks, and will detect + -- any non-preelaborable declarations or statements within. + + elsif Nkind (N) = N_Block_Statement then + return True; + end if; + + -- Otherwise the construct must be preelaborable. The check must take + -- the syntactic and semantic structure of the construct. DO NOT use + -- Is_Preelaborable_Construct here. + + return not Is_Non_Preelaborable_Construct (N); + end Is_OK_Preelaborable_Construct; + + --------------------------- + -- Is_Suitable_Construct -- + --------------------------- + + function Is_Suitable_Construct (N : Node_Id) return Boolean is + Context : constant Node_Id := Parent (N); + + begin + -- An internally-generated statement sequence which contains only a + -- single null statement is not a suitable construct because it is a + -- byproduct of the parser. Such a null statement should be excluded + -- from the early call region because it carries the source location + -- of the "end" keyword, and may lead to confusing diagnistics. + + if Nkind (N) = N_Null_Statement + and then not Comes_From_Source (N) + and then Present (Context) + and then Nkind (Context) = N_Handled_Sequence_Of_Statements + then + return False; + end if; + + -- Otherwise only constructs which correspond to pure Ada constructs + -- are considered suitable. + + case Nkind (N) is + when N_Call_Marker + | N_Freeze_Entity + | N_Freeze_Generic_Entity + | N_Implicit_Label_Declaration + | N_Itype_Reference + | N_Pop_Constraint_Error_Label + | N_Pop_Program_Error_Label + | N_Pop_Storage_Error_Label + | N_Push_Constraint_Error_Label + | N_Push_Program_Error_Label + | N_Push_Storage_Error_Label + | N_SCIL_Dispatch_Table_Tag_Init + | N_SCIL_Dispatching_Call + | N_SCIL_Membership_Test + | N_Variable_Reference_Marker + => + return False; + + when others => + return True; + end case; + end Is_Suitable_Construct; + + ---------------------------------- + -- Transition_Body_Declarations -- + ---------------------------------- + + procedure Transition_Body_Declarations + (Bod : Node_Id; + Curr : out Node_Id) + is + Decls : constant List_Id := Declarations (Bod); + + begin + -- The search must come from the declarations of the body + + pragma Assert + (Is_Non_Empty_List (Decls) + and then List_Containing (Start) = Decls); + + -- The search finished inspecting the declarations. The construct + -- to inspect is the node which precedes the handled body, unless + -- the body is a compilation unit. The transitions are: + -- + -- declarations -> upper level + -- declarations -> corresponding package spec (Elab_Body) + -- declarations -> terminate + + Transition_Unit (Bod, Curr); + end Transition_Body_Declarations; + + ----------------------------------- + -- Transition_Handled_Statements -- + ----------------------------------- + + procedure Transition_Handled_Statements + (HSS : Node_Id; + Curr : out Node_Id) + is + Bod : constant Node_Id := Parent (HSS); + Decls : constant List_Id := Declarations (Bod); + Stmts : constant List_Id := Statements (HSS); + + begin + -- The search must come from the statements of certain bodies or + -- statements. + + pragma Assert (Nkind_In (Bod, N_Block_Statement, + N_Entry_Body, + N_Package_Body, + N_Protected_Body, + N_Subprogram_Body, + N_Task_Body)); + + -- The search must come from the statements of the handled sequence + + pragma Assert + (Is_Non_Empty_List (Stmts) + and then List_Containing (Start) = Stmts); + + -- The search finished inspecting the statements. The handled body + -- has non-empty declarations. The construct to inspect is the last + -- declaration. The transitions are: + -- + -- statements -> declarations + + if Has_Suitable_Construct (Decls) then + Curr := Last (Decls); + + -- Otherwise the handled body lacks declarations. The construct to + -- inspect is the node which precedes the handled body, unless the + -- body is a compilation unit. The transitions are: + -- + -- statements -> upper level + -- statements -> corresponding package spec (Elab_Body) + -- statements -> terminate + + else + Transition_Unit (Bod, Curr); + end if; + end Transition_Handled_Statements; + + ---------------------------------- + -- Transition_Spec_Declarations -- + ---------------------------------- + + procedure Transition_Spec_Declarations + (Spec : Node_Id; + Curr : out Node_Id) + is + Prv_Decls : constant List_Id := Private_Declarations (Spec); + Vis_Decls : constant List_Id := Visible_Declarations (Spec); + + begin + pragma Assert (Present (Start) and then Is_List_Member (Start)); + + -- The search came from the private declarations and finished their + -- inspection. + + if Has_Suitable_Construct (Prv_Decls) + and then List_Containing (Start) = Prv_Decls + then + -- The context has non-empty visible declarations. The node to + -- inspect is the last visible declaration. The transitions are: + -- + -- private declarations -> visible declarations + + if Has_Suitable_Construct (Vis_Decls) then + Curr := Last (Vis_Decls); + + -- Otherwise the context lacks visible declarations. The construct + -- to inspect is the node which precedes the context unless the + -- context is a compilation unit. The transitions are: + -- + -- private declarations -> upper level + -- private declarations -> terminate + + else + Transition_Unit (Parent (Spec), Curr); + end if; + + -- The search came from the visible declarations and finished their + -- inspections. The construct to inspect is the node which precedes + -- the context, unless the context is a compilaton unit. The + -- transitions are: + -- + -- visible declarations -> upper level + -- visible declarations -> terminate + + elsif Has_Suitable_Construct (Vis_Decls) + and then List_Containing (Start) = Vis_Decls + then + Transition_Unit (Parent (Spec), Curr); + + -- At this point both declarative lists are empty, but the traversal + -- still came from within the spec. This indicates that the invariant + -- of the algorithm has been violated. + + else + pragma Assert (False); + raise ECR_Found; + end if; + end Transition_Spec_Declarations; + + --------------------- + -- Transition_Unit -- + --------------------- + + procedure Transition_Unit + (Unit : Node_Id; + Curr : out Node_Id) + is + Context : constant Node_Id := Parent (Unit); + + begin + -- The unit is a compilation unit. This terminates the search because + -- there are no more lists to inspect and there are no more enclosing + -- constructs to climb up to. + + if Nkind (Context) = N_Compilation_Unit then + + -- A package body with a corresponding spec subject to pragma + -- Elaborate_Body is an exception to the above. The annotation + -- allows the search to continue into the package declaration. + -- The transitions are: + -- + -- statements -> corresponding package spec (Elab_Body) + -- declarations -> corresponding package spec (Elab_Body) + + if Nkind (Unit) = N_Package_Body + and then (Assume_Elab_Body + or else Has_Pragma_Elaborate_Body + (Corresponding_Spec (Unit))) + then + Curr := Unit_Declaration_Node (Corresponding_Spec (Unit)); + Enter_Package_Declaration (Curr); + + -- Otherwise terminate the search. The transitions are: + -- + -- private declarations -> terminate + -- visible declarations -> terminate + -- statements -> terminate + -- declarations -> terminate + + else + raise ECR_Found; + end if; + + -- The unit is a subunit. The construct to inspect is the node which + -- precedes the corresponding stub. Update the early call region to + -- include the unit. + + elsif Nkind (Context) = N_Subunit then + Start := Unit; + Curr := Corresponding_Stub (Context); + + -- Otherwise the unit is nested. The construct to inspect is the node + -- which precedes the unit. Update the early call region to include + -- the unit. + + else + Include (Unit, Curr); + end if; + end Transition_Unit; + + -- Local variables + + Body_Id : constant Entity_Id := Defining_Entity (Body_Decl); + Region : Node_Id; + + -- Start of processing for Find_Early_Call_Region + + begin + -- The caller demands the start of the early call region without saving + -- or retrieving it to/from internal data structures. + + if Skip_Memoization then + Region := Find_ECR (Body_Decl); + + -- Default behavior + + else + -- Check whether the early call region of the subprogram body is + -- available. + + Region := Early_Call_Region (Body_Id); + + if No (Region) then + + -- Traverse the declarations in reverse order, starting from the + -- subprogram body, searching for the nearest non-preelaborable + -- construct. The early call region starts after this construct + -- and ends at the subprogram body. + + Region := Find_ECR (Body_Decl); + + -- Associate the early call region with the subprogram body in + -- case other scenarios need it. + + Set_Early_Call_Region (Body_Id, Region); + end if; + end if; + + -- A subprogram body must always have an early call region + + pragma Assert (Present (Region)); + + return Region; + end Find_Early_Call_Region; + --------------------------- -- Find_Elaborated_Units -- --------------------------- @@ -3034,35 +5120,41 @@ return; end if; - Elab_Attrs := Elaboration_Context.Get (Unit_Id); + Elab_Attrs := Elaboration_Status (Unit_Id); + + -- The unit is already included in the context by means of pragma + -- Elaborate[_All]. + + if Present (Elab_Attrs.Source_Pragma) then + + -- Upgrade an existing pragma Elaborate when the unit is subject + -- to Elaborate_All because the new pragma covers a larger set of + -- units. + + if Pragma_Name (Elab_Attrs.Source_Pragma) = Name_Elaborate + and then Pragma_Name (Prag) = Name_Elaborate_All + then + Elab_Attrs.Source_Pragma := Prag; + + -- Otherwise the unit retains its existing pragma and does not + -- need to be included in the context again. + + else + return; + end if; -- The current unit is not part of the context. Prepare a new set of -- attributes. - if Elab_Attrs = No_Elaboration_Attributes then + else Elab_Attrs := Elaboration_Attributes'(Source_Pragma => Prag, With_Clause => Empty); - - -- 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 - Elab_Attrs.Source_Pragma := Prag; - - -- Otherwise the unit is already included in the context - - else - return; end if; -- Add or update the attributes of the unit - Elaboration_Context.Set (Unit_Id, Elab_Attrs); + Set_Elaboration_Status (Unit_Id, Elab_Attrs); -- Includes all units withed by the current one when computing the -- full context. @@ -3356,7 +5448,7 @@ return Declaration_Level; end if; - -- The current construct is a declaration level encapsulator + -- The current construct is a declaration-level encapsulator elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body, @@ -3379,9 +5471,9 @@ return Declaration_Level; end if; - -- The current construct is a non-library level encapsulator which + -- 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 + -- Note that this check must come after the declaration-level check -- because both predicates share certain nodes. elsif Is_Non_Library_Level_Encapsulator (Curr) then @@ -3761,7 +5853,7 @@ -- main unit. Consider this case only when requested by the caller. elsif Context_OK - and then Elaboration_Context.Get (Unit_Id) /= No_Elaboration_Attributes + and then Elaboration_Status (Unit_Id) /= No_Elaboration_Attributes then return True; @@ -3870,7 +5962,7 @@ Nested_OK : Boolean := False) return Boolean is function Find_Enclosing_Context (N : Node_Id) return Node_Id; - -- Return the nearest enclosing non-library level or compilation unit + -- 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. @@ -3897,7 +5989,7 @@ if Nkind (Par) = N_Subunit then Par := Corresponding_Stub (Par); - -- Stop the traversal when the nearest enclosing non-library level + -- Stop the traversal when the nearest enclosing non-library-level -- encapsulator has been reached. elsif Is_Non_Library_Level_Encapsulator (Par) then @@ -3916,7 +6008,7 @@ return Par; end if; - -- Reaching a compilation unit node without hitting a non-library + -- 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. @@ -3992,13 +6084,46 @@ return False; end In_Same_Context; + ------------------ + -- In_Task_Body -- + ------------------ + + function In_Task_Body (N : Node_Id) return Boolean is + Par : Node_Id; + + begin + -- Climb the parent chain looking for a task body [procedure] + + Par := N; + while Present (Par) loop + if Nkind (Par) = N_Task_Body then + return True; + + elsif Nkind (Par) = N_Subprogram_Body + and then Is_Task_Body_Procedure (Par) + then + return True; + + -- Prevent the search from going too far. Note that this predicate + -- shares nodes with the two cases above, and must come last. + + elsif Is_Body_Or_Package_Declaration (Par) then + return False; + end if; + + Par := Parent (Par); + end loop; + + return False; + end In_Task_Body; + ---------------- -- Initialize -- ---------------- procedure Initialize is begin - -- Set the soft link which enables Atree.Rewrite to update a top level + -- Set the soft link which enables Atree.Rewrite to update a top-level -- scenario each time it is transformed into another node. Set_Rewriting_Proc (Update_Elaboration_Scenario'Access); @@ -4226,24 +6351,26 @@ In_SPARK => In_SPARK); end Info_Instantiation; - ------------------------ - -- Info_Variable_Read -- - ------------------------ - - procedure Info_Variable_Read + ----------------------------- + -- 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 => "read of variable & during elaboration", - N => Ref, - Id => Var_Id, - Info_Msg => Info_Msg, - In_SPARK => In_SPARK); - end Info_Variable_Read; + if Is_Read (Ref) then + Elab_Msg_NE + (Msg => "read of variable & during elaboration", + N => Ref, + Id => Var_Id, + Info_Msg => Info_Msg, + In_SPARK => In_SPARK); + end if; + end Info_Variable_Reference; -------------------- -- Insertion_Node -- @@ -4571,6 +6698,20 @@ or else Is_Task_Entry (Id); end Is_Ada_Semantic_Target; + -------------------------------- + -- Is_Assertion_Pragma_Target -- + -------------------------------- + + function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean is + begin + return + Is_Default_Initial_Condition_Proc (Id) + or else Is_Initial_Condition_Proc (Id) + or else Is_Invariant_Proc (Id) + or else Is_Partial_Invariant_Proc (Id) + or else Is_Postconditions_Proc (Id); + end Is_Assertion_Pragma_Target; + ---------------------------- -- Is_Bodiless_Subprogram -- ---------------------------- @@ -4602,19 +6743,6 @@ return False; end Is_Bodiless_Subprogram; - -------------------------------- - -- 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 -- ------------------------ @@ -4870,6 +6998,32 @@ and then Present (Protected_Subprogram (Id)); end Is_Protected_Body_Subp; + -------------------------------- + -- Is_Recorded_SPARK_Scenario -- + -------------------------------- + + function Is_Recorded_SPARK_Scenario (N : Node_Id) return Boolean is + begin + if Recorded_SPARK_Scenarios_In_Use then + return Recorded_SPARK_Scenarios.Get (N); + end if; + + return Recorded_SPARK_Scenarios_No_Element; + end Is_Recorded_SPARK_Scenario; + + ------------------------------------ + -- Is_Recorded_Top_Level_Scenario -- + ------------------------------------ + + function Is_Recorded_Top_Level_Scenario (N : Node_Id) return Boolean is + begin + if Recorded_Top_Level_Scenarios_In_Use then + return Recorded_Top_Level_Scenarios.Get (N); + end if; + + return Recorded_Top_Level_Scenarios_No_Element; + end Is_Recorded_Top_Level_Scenario; + ------------------------ -- Is_Safe_Activation -- ------------------------ @@ -4999,50 +7153,8 @@ (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 - - Result := Unit_Id; - while Present (Result) - and then Result /= Standard_Standard - and then Is_Subunit (Result) - loop - Result := Scope (Result); - end loop; - - -- Obtain the entity of the corresponding spec (if any) - - return Unique_Entity (Result); - end Normalize_Unit; - - -- Start of processing for Is_Same_Unit - - begin - return Normalize_Unit (Unit_1) = Normalize_Unit (Unit_2); + begin + return Unit_Entity (Unit_1) = Unit_Entity (Unit_2); end Is_Same_Unit; ----------------- @@ -5195,14 +7307,91 @@ function Is_Suitable_Scenario (N : Node_Id) return Boolean is begin + -- NOTE: Derived types and pragma Refined_State are intentionally left + -- out because they are not executable during elaboration. + 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_Read (N); + or else Is_Suitable_Variable_Reference (N); end Is_Suitable_Scenario; + ------------------------------------ + -- Is_Suitable_SPARK_Derived_Type -- + ------------------------------------ + + function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean is + Prag : Node_Id; + Typ : Entity_Id; + + begin + -- To qualify, the type declaration must denote a derived tagged type + -- with primitive operations, subject to pragma SPARK_Mode On. + + if Nkind (N) = N_Full_Type_Declaration + and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition + then + Typ := Defining_Entity (N); + Prag := SPARK_Pragma (Typ); + + return + Is_Tagged_Type (Typ) + and then Has_Primitive_Operations (Typ) + and then Present (Prag) + and then Get_SPARK_Mode_From_Annotation (Prag) = On; + end if; + + return False; + end Is_Suitable_SPARK_Derived_Type; + + ------------------------------------- + -- Is_Suitable_SPARK_Instantiation -- + ------------------------------------- + + function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean is + Gen_Attrs : Target_Attributes; + Gen_Id : Entity_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Inst_Id : Entity_Id; + + begin + -- To qualify, both the instantiation and the generic must be subject to + -- SPARK_Mode On. + + if Is_Suitable_Instantiation (N) then + Extract_Instantiation_Attributes + (Exp_Inst => N, + Inst => Inst, + Inst_Id => Inst_Id, + Gen_Id => Gen_Id, + Attrs => Inst_Attrs); + + Extract_Target_Attributes (Gen_Id, Gen_Attrs); + + return Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On; + end if; + + return False; + end Is_Suitable_SPARK_Instantiation; + + -------------------------------------------- + -- Is_Suitable_SPARK_Refined_State_Pragma -- + -------------------------------------------- + + function Is_Suitable_SPARK_Refined_State_Pragma + (N : Node_Id) return Boolean + is + begin + -- To qualfy, the pragma must denote Refined_State + + return + Nkind (N) = N_Pragma + and then Pragma_Name (N) = Name_Refined_State; + end Is_Suitable_SPARK_Refined_State_Pragma; + ------------------------------------- -- Is_Suitable_Variable_Assignment -- ------------------------------------- @@ -5297,187 +7486,46 @@ and then Corresponding_Body (Var_Unit) = N_Unit_Id; end Is_Suitable_Variable_Assignment; - ------------------------------- - -- Is_Suitable_Variable_Read -- - ------------------------------- - - function Is_Suitable_Variable_Read (N : Node_Id) return Boolean is - function In_Pragma (Nod : Node_Id) return Boolean; - -- Determine whether arbitrary node Nod appears within a pragma - - function Is_Variable_Read (Ref : Node_Id) return Boolean; - -- Determine whether variable reference Ref constitutes a read - - --------------- - -- 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 - - elsif Is_Body_Or_Package_Declaration (Par) then - exit; - end if; - - Par := Parent (Par); - end loop; - - return False; - end In_Pragma; - - ---------------------- - -- Is_Variable_Read -- - ---------------------- - - function Is_Variable_Read (Ref : Node_Id) return Boolean is - function Is_Out_Actual (Call : Node_Id) return Boolean; - -- Determine whether the corresponding formal of actual Ref which - -- appears in call Call has mode OUT. - - ------------------- - -- Is_Out_Actual -- - ------------------- - - function Is_Out_Actual (Call : Node_Id) return Boolean is - Actual : Node_Id; - Call_Attrs : Call_Attributes; - Formal : Entity_Id; - Target_Id : Entity_Id; - - begin - Extract_Call_Attributes - (Call => Call, - Target_Id => Target_Id, - Attrs => Call_Attrs); - - -- Inspect the actual and formal parameters, trying to find the - -- corresponding formal for Ref. - - Actual := First_Actual (Call); - Formal := First_Formal (Target_Id); - while Present (Actual) and then Present (Formal) loop - if Actual = Ref then - return Ekind (Formal) = E_Out_Parameter; - end if; - - Next_Actual (Actual); - Next_Formal (Formal); - end loop; - - return False; - end Is_Out_Actual; - - -- Local variables - - Context : constant Node_Id := Parent (Ref); - - -- Start of processing for Is_Variable_Read - - begin - -- The majority of variable references are reads, and they can appear - -- in a great number of contexts. To determine whether a reference is - -- a read, it is more practical to find out whether it is a write. - - -- A reference is a write when it appears immediately on the left- - -- hand side of an assignment. - - if Nkind (Context) = N_Assignment_Statement - and then Name (Context) = Ref - then - return False; - - -- A reference is a write when it acts as an actual in a subprogram - -- call and the corresponding formal has mode OUT. - - elsif Nkind_In (Context, N_Function_Call, - N_Procedure_Call_Statement) - and then Is_Out_Actual (Context) - then - return False; - end if; - - -- Any other reference is a read - - return True; - end Is_Variable_Read; - - -- Local variables - - Prag : Node_Id; - Var_Id : Entity_Id; - - -- Start of processing for Is_Suitable_Variable_Read - - begin - -- This scenario is relevant only when the static model is in effect - -- because it is graph-dependent and does not involve any run-time - -- checks. Allowing it in the dynamic model would create confusing - -- noise. - - if not Static_Elaboration_Checks then - return False; - - -- Attributes and operator sumbols are not considered to be suitable - -- references even though they are part of predicate Is_Entity_Name. - - elsif not Nkind_In (N, N_Expanded_Name, N_Identifier) then - return False; - - -- Nothing to do for internally-generated references because they are - -- assumed to be ABE safe. - - elsif not Comes_From_Source (N) then - return False; - end if; - - -- Sanitize the reference - - Var_Id := Entity (N); - - if No (Var_Id) then - return False; - - elsif Var_Id = Any_Id then - return False; - - elsif Ekind (Var_Id) /= E_Variable then - return False; - end if; - - Prag := SPARK_Pragma (Var_Id); - - -- To qualify, the reference must meet the following prerequisites: - - return - Comes_From_Source (Var_Id) - - -- Both the variable and the reference must appear in SPARK_Mode On - -- regions because this scenario falls under the SPARK rules. - - and then Present (Prag) - and then Get_SPARK_Mode_From_Annotation (Prag) = On - and then Is_SPARK_Mode_On_Node (N) - - -- The reference must denote a variable read - - and then Is_Variable_Read (N) - - -- 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. - - -- Performance note: parent traversal - - and then not In_Pragma (N); - end Is_Suitable_Variable_Read; + ------------------------------------ + -- Is_Suitable_Variable_Reference -- + ------------------------------------ + + function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean is + begin + -- Expanded names and identifiers are intentionally ignored because they + -- be folded, optimized away, etc. Variable references markers play the + -- role of variable references and provide a uniform foundation for ABE + -- processing. + + return Nkind (N) = N_Variable_Reference_Marker; + end Is_Suitable_Variable_Reference; + + ------------------------------------ + -- Is_Synchronous_Suspension_Call -- + ------------------------------------ + + function Is_Synchronous_Suspension_Call (N : Node_Id) return Boolean is + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + + begin + -- To qualify, the call must invoke one of the runtime routines which + -- perform synchronous suspension. + + if Is_Suitable_Call (N) then + Extract_Call_Attributes + (Call => N, + Target_Id => Target_Id, + Attrs => Call_Attrs); + + return + Is_RTE (Target_Id, RE_Suspend_Until_True) + or else + Is_RTE (Target_Id, RE_Wait_For_Release); + end if; + + return False; + end Is_Synchronous_Suspension_Call; ------------------- -- Is_Task_Entry -- @@ -5501,7 +7549,7 @@ 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 + -- 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. @@ -5511,7 +7559,7 @@ 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 + -- 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 @@ -5527,7 +7575,7 @@ 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. + -- an up-level target. else return True; @@ -5537,19 +7585,111 @@ return False; end Is_Up_Level_Target; + --------------------- + -- Is_Visited_Body -- + --------------------- + + function Is_Visited_Body (Body_Decl : Node_Id) return Boolean is + begin + if Visited_Bodies_In_Use then + return Visited_Bodies.Get (Body_Decl); + end if; + + return Visited_Bodies_No_Element; + end Is_Visited_Body; + ------------------------------- -- Kill_Elaboration_Scenario -- ------------------------------- 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. + procedure Kill_SPARK_Scenario; + pragma Inline (Kill_SPARK_Scenario); + -- Eliminate scenario N from table SPARK_Scenarios if it is recorded + -- there. + + procedure Kill_Top_Level_Scenario; + pragma Inline (Kill_Top_Level_Scenario); + -- Eliminate scenario N from table Top_Level_Scenarios if it is recorded + -- there. + + ------------------------- + -- Kill_SPARK_Scenario -- + ------------------------- + + procedure Kill_SPARK_Scenario is + package Scenarios renames SPARK_Scenarios; + + begin + if Is_Recorded_SPARK_Scenario (N) then + + -- Performance note: list traversal + + for Index in Scenarios.First .. Scenarios.Last loop + if Scenarios.Table (Index) = N then + Scenarios.Table (Index) := Empty; + + -- The SPARK scenario is no longer recorded + + Set_Is_Recorded_SPARK_Scenario (N, False); + return; + end if; + end loop; + + -- A recorded SPARK scenario must be in the table of recorded + -- SPARK scenarios. + + pragma Assert (False); + end if; + end Kill_SPARK_Scenario; + + ----------------------------- + -- Kill_Top_Level_Scenario -- + ----------------------------- + + procedure Kill_Top_Level_Scenario is + package Scenarios renames Top_Level_Scenarios; + + begin + if Is_Recorded_Top_Level_Scenario (N) then + + -- Performance node: list traversal + + for Index in Scenarios.First .. Scenarios.Last loop + if Scenarios.Table (Index) = N then + Scenarios.Table (Index) := Empty; + + -- The top-level scenario is no longer recorded + + Set_Is_Recorded_Top_Level_Scenario (N, False); + return; + end if; + end loop; + + -- A recorded top-level scenario must be in the table of recorded + -- top-level scenarios. + + pragma Assert (False); + end if; + end Kill_Top_Level_Scenario; + + -- Start of processing for Kill_Elaboration_Scenario + + begin + -- Nothing to do when switch -gnatH (legacy elaboration checking mode + -- enabled) is in effect because the legacy ABE lechanism does not need + -- to carry out this action. + + if Legacy_Elaboration_Checks then + return; + end if; + + -- Eliminate a recorded scenario when it appears within dead code + -- because it will not be executed at elaboration time. if Is_Scenario (N) then - Set_Is_Elaboration_Checks_OK_Node (N, False); + Kill_SPARK_Scenario; + Kill_Top_Level_Scenario; end if; end Kill_Elaboration_Scenario; @@ -5604,7 +7744,7 @@ return Decl; -- Otherwise the construct terminates the region where the - -- preelabortion-related pragma may appear. + -- preelaboration-related pragma may appear. else exit; @@ -5652,8 +7792,13 @@ Info_Msg => False, In_SPARK => True); - elsif Is_Suitable_Variable_Read (N) then - Info_Variable_Read + elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then + Error_Msg_N + ("read of refinement constituents during elaboration in SPARK", + N); + + elsif Is_Suitable_Variable_Reference (N) then + Info_Variable_Reference (Ref => N, Var_Id => Target_Id, Info_Msg => False, @@ -5741,7 +7886,7 @@ -- enough to meet the requirement. else - Elab_Attrs := Elaboration_Context.Get (Unit_Id); + Elab_Attrs := Elaboration_Status (Unit_Id); -- The pragma must be either Elaborate_All or be as strong as the -- requirement. @@ -5781,16 +7926,12 @@ ---------------------- function Non_Private_View (Typ : Entity_Id) return Entity_Id is - Result : Entity_Id; - - begin - Result := Typ; - - if Is_Private_Type (Result) and then Present (Full_View (Result)) then - Result := Full_View (Result); - end if; - - return Result; + begin + if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + return Full_View (Typ); + else + return Typ; + end if; end Non_Private_View; ----------------------------- @@ -5814,11 +7955,14 @@ procedure Output_Instantiation (N : Node_Id); -- Emit a specific diagnostic message for instantiation N + procedure Output_SPARK_Refined_State_Pragma (N : Node_Id); + -- Emit a specific diagnostic message for Refined_State pragma N + procedure Output_Variable_Assignment (N : Node_Id); -- Emit a specific diagnostic message for assignment statement N - procedure Output_Variable_Read (N : Node_Id); - -- Emit a specific diagnostic message for reference N which reads a + procedure Output_Variable_Reference (N : Node_Id); + -- Emit a specific diagnostic message for reference N which mentions a -- variable. ------------------- @@ -6136,6 +8280,16 @@ end if; end Output_Instantiation; + --------------------------------------- + -- Output_SPARK_Refined_State_Pragma -- + --------------------------------------- + + procedure Output_SPARK_Refined_State_Pragma (N : Node_Id) is + begin + Error_Msg_Sloc := Sloc (N); + Error_Msg_N ("\\ refinement constituents read #", Error_Nod); + end Output_SPARK_Refined_State_Pragma; + -------------------------------- -- Output_Variable_Assignment -- -------------------------------- @@ -6148,11 +8302,11 @@ Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id); end Output_Variable_Assignment; - -------------------------- - -- Output_Variable_Read -- - -------------------------- - - procedure Output_Variable_Read (N : Node_Id) is + ------------------------------- + -- Output_Variable_Reference -- + ------------------------------- + + procedure Output_Variable_Reference (N : Node_Id) is Dummy : Variable_Attributes; Var_Id : Entity_Id; @@ -6163,8 +8317,15 @@ Attrs => Dummy); Error_Msg_Sloc := Sloc (N); - Error_Msg_NE ("\\ variable & read #", Error_Nod, Var_Id); - end Output_Variable_Read; + + if Is_Read (N) then + Error_Msg_NE ("\\ variable & read #", Error_Nod, Var_Id); + + else + pragma Assert (False); + null; + end if; + end Output_Variable_Reference; -- Local variables @@ -6220,15 +8381,20 @@ elsif Is_Suitable_Instantiation (N) then Output_Instantiation (N); + -- Pragma Refined_State + + elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then + Output_SPARK_Refined_State_Pragma (N); + -- Variable assignments elsif Nkind (N) = N_Assignment_Statement then Output_Variable_Assignment (N); - -- Variable read - - elsif Is_Suitable_Variable_Read (N) then - Output_Variable_Read (N); + -- Variable references + + elsif Is_Suitable_Variable_Reference (N) then + Output_Variable_Reference (N); else pragma Assert (False); @@ -6249,119 +8415,14 @@ 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; - - begin - Marker := Make_Call_Marker (Sloc (Attr)); - - -- 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 (conservative 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) + -------------------------------- + -- Process_Activation_Generic -- + -------------------------------- + + procedure Process_Activation_Generic + (Call : Node_Id; + Call_Attrs : Call_Attributes; + State : Processing_Attributes) is procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id); -- Perform ABE checks and diagnostics for object Obj_Id with type Typ. @@ -6369,8 +8430,8 @@ -- component. procedure Process_Task_Objects (List : List_Id); - -- Perform ABE checks and diagnostics for all task objects found in - -- the list List. + -- Perform ABE checks and diagnostics for all task objects found in the + -- list List. ------------------------- -- Process_Task_Object -- @@ -6382,30 +8443,54 @@ Comp_Id : Entity_Id; Task_Attrs : Task_Attributes; + New_State : Processing_Attributes := State; + -- Each step of the Processing phase constitutes a new state + begin if Is_Task_Type (Typ) then Extract_Task_Attributes (Typ => Base_Typ, Attrs => Task_Attrs); + -- Warnings are suppressed when a prior scenario is already in + -- that mode, or when the object, activation call, or task type + -- have warnings suppressed. Update the state of the Processing + -- phase to reflect this. + + New_State.Suppress_Warnings := + New_State.Suppress_Warnings + or else not Is_Elaboration_Warnings_OK_Id (Obj_Id) + or else not Call_Attrs.Elab_Warnings_OK + or else not Task_Attrs.Elab_Warnings_OK; + + -- Update the state of the Processing phase to indicate that any + -- further traversal is now within a task body. + + New_State.Within_Task_Body := True; + Process_Single_Activation - (Call => Call, - Call_Attrs => Call_Attrs, - Obj_Id => Obj_Id, - Task_Attrs => Task_Attrs, - In_Task_Body => In_Task_Body); + (Call => Call, + Call_Attrs => Call_Attrs, + Obj_Id => Obj_Id, + Task_Attrs => Task_Attrs, + State => New_State); -- 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)); + Process_Task_Object + (Obj_Id => Obj_Id, + Typ => 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)); + Process_Task_Object + (Obj_Id => Obj_Id, + Typ => Etype (Comp_Id)); + Next_Component (Comp_Id); end loop; end if; @@ -6431,7 +8516,9 @@ Item_Typ := Etype (Item_Id); if Has_Task (Item_Typ) then - Process_Task_Object (Item_Id, Item_Typ); + Process_Task_Object + (Obj_Id => Item_Id, + Typ => Item_Typ); end if; end if; @@ -6444,7 +8531,7 @@ Context : Node_Id; Spec : Node_Id; - -- Start of processing for Process_Activation_Call + -- Start of processing for Process_Activation_Generic begin -- Nothing to do when the activation is a guaranteed ABE @@ -6500,18 +8587,147 @@ Process_Task_Objects (Statements (Context)); end if; - end Process_Activation_Call; + end Process_Activation_Generic; + + ------------------------------------ + -- Process_Conditional_ABE_Access -- + ------------------------------------ + + procedure Process_Conditional_ABE_Access + (Attr : Node_Id; + State : Processing_Attributes) + 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; + + begin + Marker := Make_Call_Marker (Sloc (Attr)); + + -- 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_Elaboration_Warnings_OK_Node + (Marker, Is_Elaboration_Warnings_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; + + New_State : Processing_Attributes := State; + -- Each step of the Processing phase constitutes a new state + + -- Start of processing for Process_Conditional_ABE_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); + + -- Warnings are suppressed when a prior scenario is already in that + -- mode, or when the attribute or the target have warnings suppressed. + -- Update the state of the Processing phase to reflect this. + + New_State.Suppress_Warnings := + New_State.Suppress_Warnings + or else not Is_Elaboration_Warnings_OK_Node (Attr) + or else not Target_Attrs.Elab_Warnings_OK; + + -- Do not emit any ABE diagnostics when the current or previous scenario + -- in this traversal has suppressed elaboration warnings. + + if New_State.Suppress_Warnings then + null; + + -- 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. + + elsif 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 (conservative 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_Conditional_ABE + (N => Build_Access_Marker (Target_Id), + State => New_State); + + -- 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, + Prag_Nam => Name_Elaborate_All, + State => New_State); + end if; + end Process_Conditional_ABE_Access; --------------------------------------------- - -- Process_Activation_Conditional_ABE_Impl -- + -- Process_Conditional_ABE_Activation_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) + procedure Process_Conditional_ABE_Activation_Impl + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + State : Processing_Attributes) is Check_OK : constant Boolean := not Is_Ignored_Ghost_Entity (Obj_Id) @@ -6524,6 +8740,9 @@ Root : constant Node_Id := Root_Scenario; + New_State : Processing_Attributes := State; + -- Each step of the Processing phase constitutes a new state + begin -- Output relevant information when switch -gnatel (info messages on -- implicit Elaborate[_All] pragmas) is in effect. @@ -6533,16 +8752,27 @@ ("info: activation of & during elaboration", Call, Obj_Id); end if; + -- Nothing to do when the call activates a task whose type is defined + -- within an instance and switch -gnatd_i (ignore activations and calls + -- to instances for elaboration) is in effect. + + if Debug_Flag_Underscore_I + and then In_External_Instance + (N => Call, + Target_Decl => Task_Attrs.Task_Decl) + then + return; + -- Nothing to do when the activation is a guaranteed ABE - if Is_Known_Guaranteed_ABE (Call) then + elsif Is_Known_Guaranteed_ABE (Call) then return; -- 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 @@ -6554,14 +8784,14 @@ -- 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 @@ -6575,29 +8805,24 @@ 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; -- ... @@ -6616,33 +8841,27 @@ 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 Pack; -- activation of T -- ... -- 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 @@ -6650,12 +8869,25 @@ if Earlier_In_Extended_Unit (Root, Task_Attrs.Body_Decl) then + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. + + if State.Suppress_Warnings then + null; + + -- Do not emit any ABE diagnostics when the activation occurs in + -- a partial finalization context because this leads to confusing + -- noise. + + elsif State.Within_Partial_Finalization then + null; + -- 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 + elsif Static_Elaboration_Checks then Error_Msg_Sloc := Sloc (Call); Error_Msg_N ("??task & will be activated # before elaboration of its " @@ -6676,6 +8908,40 @@ Target_Id => Task_Attrs.Spec_Id, Target_Decl => Task_Attrs.Task_Decl, Target_Body => Task_Attrs.Body_Decl); + + -- Update the state of the Processing phase to indicate that + -- no implicit Elaborate[_All] pragmas must be generated from + -- this point on. + -- + -- task type Task_Typ; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- package Pack is + -- <ABE check> + -- T : Task_Typ; + -- end Pack; -- activation of T + -- ... + -- end A; + -- + -- X : ... := A; + -- + -- task body Task_Typ is + -- begin + -- External.Subp; -- imparts Elaborate_All + -- end Task_Typ; + -- + -- If Some_Condition is True, then the ABE check will fail at + -- runtime and the call to External.Subp will never take place, + -- rendering the implicit Elaborate_All useless. + -- + -- If Some_Condition is False, then the call to External.Subp + -- will never take place, rendering the implicit Elaborate_All + -- useless. + + New_State.Suppress_Implicit_Pragmas := True; end if; end if; @@ -6707,291 +8973,39 @@ else Ensure_Prior_Elaboration - (N => Call, - Unit_Id => Task_Attrs.Unit_Id, - In_Task_Body => In_Task_Body); - end if; - - 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. - - begin - -- 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; - - -- 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; - - -- 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. - - -- procedure Guaranteed_ABE is - -- task type Task_Typ; - - -- package Nested is - -- ... - -- end Nested; - - -- package body Nested is - -- T : Task_Typ; - -- [begin] - -- <activation call> -- guaranteed ABE - -- end Nested; - - -- 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; - - procedure Process_Activation_Guaranteed_ABE is - new Process_Activation_Call (Process_Activation_Guaranteed_ABE_Impl); - - ------------------ - -- 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 - Extract_Target_Attributes - (Target_Id => Target_Id, - Attrs => Target_Attrs); - - -- 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; - - -- Check whether the invocation of an entry clashes with an existing - -- restriction. - - 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. - - return; - end if; - - -- Nothing to do when the call is a guaranteed ABE - - if Is_Known_Guaranteed_ABE (Call) then - return; - - -- Nothing to do when the root scenario appears at the declaration level - -- and the target is in the same unit, but outside this context. - - -- function B ...; -- target declaration - - -- procedure Proc is - -- function A ... is - -- begin - -- if Some_Condition then - -- return B; -- call site - -- ... - -- end A; - - -- X : ... := A; -- root scenario - -- ... - - -- function B ... is - -- ... - -- end B; - - -- 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. - - -- Performance note: parent traversal - - elsif Is_Up_Level_Target (Target_Attrs.Spec_Decl) then - return; - - -- The SPARK rules are verified only when -gnatd.v (enforce SPARK - -- elaboration rules in SPARK code) is in effect. - - elsif SPARK_Rules_On and Debug_Flag_Dot_V then - Process_Call_SPARK - (Call => Call, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id, - Target_Attrs => Target_Attrs); - - -- Otherwise the Ada rules are in effect, or SPARK code is allowed to - -- violate the SPARK rules. - - else - 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; - - -- 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; - - ---------------------- - -- Process_Call_Ada -- - ---------------------- - - procedure Process_Call_Ada - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes; - In_Task_Body : Boolean) + (N => Call, + Unit_Id => Task_Attrs.Unit_Id, + Prag_Nam => Name_Elaborate_All, + State => New_State); + end if; + + Traverse_Body + (N => Task_Attrs.Body_Decl, + State => New_State); + end Process_Conditional_ABE_Activation_Impl; + + procedure Process_Conditional_ABE_Activation is + new Process_Activation_Generic (Process_Conditional_ABE_Activation_Impl); + + ---------------------------------- + -- Process_Conditional_ABE_Call -- + ---------------------------------- + + procedure Process_Conditional_ABE_Call + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + State : Processing_Attributes) 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. + -- Determine whether arbitrary node N appears within a type init proc, + -- primitive [Deep_]Initialize, or a block created for initialization + -- purposes. + + function Is_Partial_Finalization_Proc return Boolean; + pragma Inline (Is_Partial_Finalization_Proc); + -- Determine whether call Call with target Target_Id invokes a partial + -- finalization procedure. ------------------------------- -- In_Initialization_Context -- @@ -7042,8 +9056,190 @@ return False; end In_Initialization_Context; + ---------------------------------- + -- Is_Partial_Finalization_Proc -- + ---------------------------------- + + function Is_Partial_Finalization_Proc return Boolean is + begin + -- To qualify, the target must denote primitive [Deep_]Finalize or a + -- finalizer procedure, and the call must appear in an initialization + -- context. + + return + (Is_Controlled_Proc (Target_Id, Name_Finalize) + or else Is_Finalizer_Proc (Target_Id) + or else Is_TSS (Target_Id, TSS_Deep_Finalize)) + and then In_Initialization_Context (Call); + end Is_Partial_Finalization_Proc; + -- Local variables + SPARK_Rules_On : Boolean; + Target_Attrs : Target_Attributes; + + New_State : Processing_Attributes := State; + -- Each step of the Processing phase constitutes a new state + + -- Start of processing for Process_Conditional_ABE_Call + + begin + Extract_Target_Attributes + (Target_Id => Target_Id, + Attrs => Target_Attrs); + + -- 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; + + -- Check whether the invocation of an entry clashes with an existing + -- restriction. + + 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. + + return; + end if; + + -- Nothing to do when the call invokes a target defined within an + -- instance and switch -gnatd_i (ignore activations and calls to + -- instances for elaboration) is in effect. + + if Debug_Flag_Underscore_I + and then In_External_Instance + (N => Call, + Target_Decl => Target_Attrs.Spec_Decl) + then + return; + + -- Nothing to do when the call is a guaranteed ABE + + elsif Is_Known_Guaranteed_ABE (Call) then + return; + + -- Nothing to do when the root scenario appears at the declaration level + -- and the target is in the same unit, but outside this context. + -- + -- function B ...; -- target declaration + -- + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- return B; -- call site + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- ... + -- + -- function B ... is + -- ... + -- end B; + -- + -- 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. + + -- Performance note: parent traversal + + elsif Is_Up_Level_Target (Target_Attrs.Spec_Decl) then + return; + end if; + + -- Warnings are suppressed when a prior scenario is already in that + -- mode, or the call or target have warnings suppressed. Update the + -- state of the Processing phase to reflect this. + + New_State.Suppress_Warnings := + New_State.Suppress_Warnings + or else not Call_Attrs.Elab_Warnings_OK + or else not Target_Attrs.Elab_Warnings_OK; + + -- The call occurs in an initial condition context when a prior scenario + -- is already in that mode, or when the target is an Initial_Condition + -- procedure. Update the state of the Processing phase to reflect this. + + New_State.Within_Initial_Condition := + New_State.Within_Initial_Condition + or else Is_Initial_Condition_Proc (Target_Id); + + -- The call occurs in a partial finalization context when a prior + -- scenario is already in that mode, or when the target denotes a + -- [Deep_]Finalize primitive or a finalizer within an initialization + -- context. Update the state of the Processing phase to reflect this. + + New_State.Within_Partial_Finalization := + New_State.Within_Partial_Finalization + or else Is_Partial_Finalization_Proc; + + -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK + -- elaboration rules in SPARK code) is intentionally not taken into + -- account here because Process_Conditional_ABE_Call_SPARK has two + -- separate modes of operation. + + if SPARK_Rules_On then + Process_Conditional_ABE_Call_SPARK + (Call => Call, + Target_Id => Target_Id, + Target_Attrs => Target_Attrs, + State => New_State); + + -- Otherwise the Ada rules are in effect + + else + Process_Conditional_ABE_Call_Ada + (Call => Call, + Call_Attrs => Call_Attrs, + Target_Id => Target_Id, + Target_Attrs => Target_Attrs, + State => New_State); + end if; + + -- Inspect the target body (and barried function) for other suitable + -- elaboration scenarios. + + Traverse_Body + (N => Target_Attrs.Body_Barf, + State => New_State); + + Traverse_Body + (N => Target_Attrs.Body_Decl, + State => New_State); + end Process_Conditional_ABE_Call; + + -------------------------------------- + -- Process_Conditional_ABE_Call_Ada -- + -------------------------------------- + + procedure Process_Conditional_ABE_Call_Ada + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes; + State : Processing_Attributes) + is Check_OK : constant Boolean := not Call_Attrs.Ghost_Mode_Ignore and then not Target_Attrs.Ghost_Mode_Ignore @@ -7053,7 +9249,10 @@ -- target have active elaboration checks, and both are not ignored Ghost -- constructs. - -- Start of processing for Process_Call_Ada + Root : constant Node_Id := Root_Scenario; + + New_State : Processing_Attributes := State; + -- Each step of the Processing phase constitutes a new state begin -- Nothing to do for an Ada dispatching call because there are no ABE @@ -7064,15 +9263,15 @@ return; -- Nothing to do when the call is ABE-safe - + -- -- generic -- function Gen ...; - + -- -- function Gen ... is -- begin -- ... -- end Gen; - + -- -- with Gen; -- procedure Main is -- function Inst is new Gen; @@ -7087,11 +9286,101 @@ 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); + -- 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 + + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. + + if State.Suppress_Warnings then + null; + + -- Do not emit any ABE diagnostics when the call occurs in a + -- partial finalization context because this leads to confusing + -- noise. + + elsif State.Within_Partial_Finalization then + null; + + -- 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. + + elsif 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; + + -- 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); + + -- Update the state of the Processing phase to indicate that + -- no implicit Elaborate[_All] pragmas must be generated from + -- this point on. + -- + -- function B ...; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- <ABE check> + -- return B; + -- ... + -- end A; + -- + -- X : ... := A; + -- + -- function B ... is + -- External.Subp; -- imparts Elaborate_All + -- end B; + -- + -- If Some_Condition is True, then the ABE check will fail at + -- runtime and the call to External.Subp will never take place, + -- rendering the implicit Elaborate_All useless. + -- + -- If Some_Condition is False, then the call to External.Subp + -- will never take place, rendering the implicit Elaborate_All + -- useless. + + New_State.Suppress_Implicit_Pragmas := True; + end if; + end if; -- 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 @@ -7105,345 +9394,219 @@ Id => Target_Attrs.Unit_Id); 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; - - -- 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. - - -- Performance note: parent traversal - - 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; + -- Ensure that the unit with the target body is elaborated prior to the + -- main unit. The implicit Elaborate[_All] is generated only when the + -- call has elaboration checks enabled. This behaviour parallels that of + -- the old ABE mechanism. + + if Call_Attrs.Elab_Checks_OK then + Ensure_Prior_Elaboration + (N => Call, + Unit_Id => Target_Attrs.Unit_Id, + Prag_Nam => Name_Elaborate_All, + State => New_State); + end if; + end Process_Conditional_ABE_Call_Ada; + + ---------------------------------------- + -- Process_Conditional_ABE_Call_SPARK -- + ---------------------------------------- + + procedure Process_Conditional_ABE_Call_SPARK + (Call : Node_Id; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes; + State : Processing_Attributes) + is + Region : Node_Id; + + begin + -- Ensure that a suitable elaboration model is in effect for SPARK rule + -- verification. + + Check_SPARK_Model_In_Effect (Call); + + -- The call and the target body are both in the main unit + + if Present (Target_Attrs.Body_Decl) + and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl) + then + -- If the call appears prior to the target body, then the call must + -- appear within the early call region of the target body. + -- + -- function B ...; + -- + -- X : ... := B; -- call site + -- + -- <preelaborable construct 1> --+ + -- ... | early call region + -- <preelaborable construct N> --+ + -- + -- function B ... is -- target body + -- ... + -- end B; + -- + -- When the call to B is not nested within some other scenario, the + -- call is automatically illegal because it can never appear in the + -- early call region of B's body. This is equivalent to a guaranteed + -- ABE. + -- + -- <preelaborable construct 1> --+ + -- | + -- function B ...; | + -- | + -- function A ... is | + -- begin | early call region + -- if Some_Condition then + -- return B; -- call site + -- ... + -- end A; | + -- | + -- <preelaborable construct N> --+ + -- + -- function B ... is -- target body + -- ... + -- end B; + -- + -- When the call to B is nested within some other scenario, the call + -- is always ABE-safe. It is not immediately obvious why this is the + -- case. The elaboration safety follows from the early call region + -- rule being applied to ALL calls preceding their associated bodies. + -- + -- In the example above, the call to B is safe as long as the call to + -- A is safe. There are several cases to consider: + -- + -- <call 1 to A> + -- function B ...; + -- + -- <call 2 to A> + -- function A ... is + -- begin + -- if Some_Condition then + -- return B; + -- ... + -- end A; + -- + -- <call 3 to A> + -- function B ... is + -- ... + -- end B; + -- + -- * Call 1 - This call is either nested within some scenario or not, + -- which falls under the two general cases outlined above. + -- + -- * Call 2 - This is the same case as Call 1. + -- + -- * Call 3 - The placement of this call limits the range of B's + -- early call region unto call 3, therefore the call to B is no + -- longer within the early call region of B's body, making it ABE- + -- unsafe and therefore illegal. + + if Earlier_In_Extended_Unit (Call, Target_Attrs.Body_Decl) then + + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. + + if State.Suppress_Warnings then + null; + + -- Do not emit any ABE diagnostics when the call occurs in an + -- initial condition context because this leads to incorrect + -- diagnostics. + + elsif State.Within_Initial_Condition then + null; + + -- Do not emit any ABE diagnostics when the call occurs in a + -- partial finalization context because this leads to confusing + -- noise. + + elsif State.Within_Partial_Finalization then + null; + + -- 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. + + elsif Static_Elaboration_Checks then + + -- Ensure that a call which textually precedes the subprogram + -- body it invokes appears within the early call region of the + -- subprogram body. + + -- IMPORTANT: This check must always be performed even when + -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is + -- not specified because the static model cannot guarantee the + -- absence of elaboration issues in the presence of dispatching + -- calls. + + Region := Find_Early_Call_Region (Target_Attrs.Body_Decl); + + if Earlier_In_Extended_Unit (Call, Region) then + Error_Msg_NE + ("call must appear within early call region of subprogram " + & "body & (SPARK RM 7.7(3))", Call, Target_Id); + + Error_Msg_Sloc := Sloc (Region); + Error_Msg_N ("\region starts #", Call); + + Error_Msg_Sloc := Sloc (Target_Attrs.Body_Decl); + Error_Msg_N ("\region ends #", Call); + + Output_Active_Scenarios (Call); + end if; + end if; + + -- Otherwise the call appears after the target body. The call is + -- ABE-safe as a consequence of applying the early call region rule + -- to ALL calls preceding their associated bodies. + + else + null; + end if; + end if; + + -- 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. + + -- IMPORTANT: This check must be performed only when -gnatd.v (enforce + -- SPARK elaboration rules in SPARK code) is active because the static + -- model can ensure the prior elaboration of the unit which contains a + -- body by installing an implicit Elaborate[_All] pragma. + + if Debug_Flag_Dot_V then + 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; -- Otherwise ensure that the unit with the target body is elaborated -- prior to the main unit. else Ensure_Prior_Elaboration - (N => Call, - Unit_Id => Target_Attrs.Unit_Id, - In_Task_Body => In_Task_Body); - end if; - end Process_Call_Ada; - - ---------------------------------- - -- Process_Call_Conditional_ABE -- - ---------------------------------- - - 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; - - -- 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 - Extract_Target_Attributes - (Target_Id => Target_Id, - Attrs => Target_Attrs); - - -- Nothing to do when the root scenario appears at the declaration level - -- and the target is in the same unit, but outside this context. - - -- function B ...; -- target declaration - - -- procedure Proc is - -- function A ... is - -- begin - -- if Some_Condition then - -- return B; -- call site - -- ... - -- end A; - - -- X : ... := A; -- root scenario - -- ... - - -- function B ... is - -- ... - -- end B; - - -- 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. - - -- Performance note: parent traversal - - if Is_Up_Level_Target (Target_Attrs.Spec_Decl) then - return; - - -- Nothing to do when the call is ABE-safe - - -- generic - -- function Gen ...; - - -- function Gen ... is - -- begin - -- ... - -- end Gen; - - -- with Gen; - -- procedure Main is - -- function Inst is new Gen; - -- X : ... := Inst; -- safe call - -- ... - - 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 Process_Call_Guaranteed_ABE; - - ------------------------ - -- Process_Call_SPARK -- - ------------------------ - - 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; - - -- Nothing to do when the call is ABE-safe - - -- generic - -- function Gen ...; - - -- 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; - - -- The call and the target body are both in the main unit - - 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. 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 - 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 - - Push_Active_Scenario (N); - - -- Only calls, instantiations, and task activations may result in a - -- guaranteed ABE. - - 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; - - -- 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_Guaranteed_ABE; - - --------------------------- - -- Process_Instantiation -- - --------------------------- - - procedure Process_Instantiation - (Exp_Inst : Node_Id; - In_Task_Body : Boolean) + (N => Call, + Unit_Id => Target_Attrs.Unit_Id, + Prag_Nam => Name_Elaborate_All, + State => State); + end if; + end Process_Conditional_ABE_Call_SPARK; + + ------------------------------------------- + -- Process_Conditional_ABE_Instantiation -- + ------------------------------------------- + + procedure Process_Conditional_ABE_Instantiation + (Exp_Inst : Node_Id; + State : Processing_Attributes) is Gen_Attrs : Target_Attributes; Gen_Id : Entity_Id; @@ -7454,6 +9617,9 @@ SPARK_Rules_On : Boolean; -- This flag is set when the SPARK rules are in effect + New_State : Processing_Attributes := State; + -- Each step of the Processing phase constitutes a new state + begin Extract_Instantiation_Attributes (Exp_Inst => Exp_Inst, @@ -7487,10 +9653,10 @@ -- 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 @@ -7500,14 +9666,14 @@ -- ... -- ... -- 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, @@ -7518,43 +9684,49 @@ elsif Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then return; - - -- The SPARK rules are verified only when -gnatd.v (enforce SPARK - -- elaboration rules in SPARK code) is in effect. - - elsif SPARK_Rules_On and Debug_Flag_Dot_V then - Process_Instantiation_SPARK - (Exp_Inst => Exp_Inst, - Inst => Inst, - Inst_Attrs => Inst_Attrs, - Gen_Id => Gen_Id, - Gen_Attrs => Gen_Attrs); + end if; + + -- Warnings are suppressed when a prior scenario is already in that + -- mode, or when the instantiation has warnings suppressed. Update + -- the state of the processing phase to reflect this. + + New_State.Suppress_Warnings := + New_State.Suppress_Warnings or else not Inst_Attrs.Elab_Warnings_OK; + + -- The SPARK rules are in effect + + if SPARK_Rules_On then + Process_Conditional_ABE_Instantiation_SPARK + (Inst => Inst, + Gen_Id => Gen_Id, + Gen_Attrs => Gen_Attrs, + State => New_State); -- Otherwise the Ada rules are in effect, or SPARK code is allowed to -- violate the SPARK rules. else - 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 Process_Instantiation; - - ------------------------------- - -- Process_Instantiation_Ada -- - ------------------------------- - - 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) + Process_Conditional_ABE_Instantiation_Ada + (Exp_Inst => Exp_Inst, + Inst => Inst, + Inst_Attrs => Inst_Attrs, + Gen_Id => Gen_Id, + Gen_Attrs => Gen_Attrs, + State => New_State); + end if; + end Process_Conditional_ABE_Instantiation; + + ----------------------------------------------- + -- Process_Conditional_ABE_Instantiation_Ada -- + ----------------------------------------------- + + procedure Process_Conditional_ABE_Instantiation_Ada + (Exp_Inst : Node_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes; + State : Processing_Attributes) is Check_OK : constant Boolean := not Inst_Attrs.Ghost_Mode_Ignore @@ -7565,18 +9737,23 @@ -- the generic have active elaboration checks and both are not ignored -- Ghost constructs. + Root : constant Node_Id := Root_Scenario; + + New_State : Processing_Attributes := State; + -- Each step of the Processing phase constitutes a new state + begin -- Nothing to do when the instantiation is ABE-safe - + -- -- 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 @@ -7590,12 +9767,109 @@ 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); + -- If the root scenario appears prior to the generic body, then this + -- is a possible ABE with respect to the root scenario. + -- + -- generic + -- package Gen is + -- ... + -- end Gen; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- package Inst is new Gen; -- instantiation site + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- + -- package body Gen is -- generic body + -- ... + -- end Gen; + -- + -- Y : ... := A; -- root scenario + -- + -- 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. + + if Earlier_In_Extended_Unit (Root, Gen_Attrs.Body_Decl) then + + -- Do not emit any ABE diagnostics when a previous scenario in + -- this traversal has suppressed elaboration warnings. + + if State.Suppress_Warnings then + null; + + -- Do not emit any ABE diagnostics when the instantiation occurs + -- in partial finalization context because this leads to unwanted + -- noise. + + elsif State.Within_Partial_Finalization then + null; + + -- 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. + + elsif 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; + + -- 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); + + -- Update the state of the Processing phase to indicate that + -- no implicit Elaborate[_All] pragmas must be generated from + -- this point on. + -- + -- generic + -- package Gen is + -- ... + -- end Gen; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- <ABE check> + -- declare Inst is new Gen; + -- ... + -- end A; + -- + -- X : ... := A; + -- + -- package body Gen is + -- begin + -- External.Subp; -- imparts Elaborate_All + -- end Gen; + -- + -- If Some_Condition is True, then the ABE check will fail at + -- runtime and the call to External.Subp will never take place, + -- rendering the implicit Elaborate_All useless. + -- + -- If Some_Condition is False, then the call to External.Subp + -- will never take place, rendering the implicit Elaborate_All + -- useless. + + New_State.Suppress_Implicit_Pragmas := True; + end if; + end if; -- 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 @@ -7610,300 +9884,76 @@ 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. + -- the main unit. No implicit pragma is generated if the instantiation + -- has elaboration checks suppressed. This behaviour parallels that of + -- the old ABE mechanism. 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. - - Root : constant Node_Id := Root_Scenario; - - begin - -- If the root scenario appears prior to the generic body, then this is - -- a possible ABE with respect to the root scenario. - - -- generic - -- package Gen is - -- ... - -- end Gen; - - -- function A ... is - -- begin - -- if Some_Condition then - -- declare - -- package Inst is new Gen; -- instantiation site - -- ... - -- end A; - - -- X : ... := A; -- root scenario - - -- package body Gen is -- generic body - -- ... - -- end Gen; - - -- Y : ... := A; -- root scenario - - -- 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. - - if Earlier_In_Extended_Unit (Root, Gen_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 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; - - -- 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; - - ------------------------------------------ - -- Process_Instantiation_Guaranteed_ABE -- - ------------------------------------------ - - 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 - 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; - - -- Nothing to do when the instantiation is ABE-safe - - -- 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 - -- ... - - elsif Is_Safe_Instantiation (Inst, Gen_Attrs) then - return; - - -- 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. - - -- procedure Guaranteed_ABE is - -- generic - -- procedure Gen; - - -- package Nested is - -- procedure Inst is new Gen; -- guaranteed ABE - -- end Nested; - - -- procedure Gen is - -- ... - -- end Gen; - -- ... - - -- Performance note: parent traversal - - 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); - - -- Mark the instantiation as a guarantee ABE. This automatically - -- suppresses the instantiation of the generic body. - - 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) + (N => Inst, + Unit_Id => Gen_Attrs.Unit_Id, + Prag_Nam => Name_Elaborate, + State => New_State); + end if; + end Process_Conditional_ABE_Instantiation_Ada; + + ------------------------------------------------- + -- Process_Conditional_ABE_Instantiation_SPARK -- + ------------------------------------------------- + + procedure Process_Conditional_ABE_Instantiation_SPARK + (Inst : Node_Id; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes; + State : Processing_Attributes) is Req_Nam : Name_Id; begin + -- Ensure that a suitable elaboration model is in effect for SPARK rule + -- verification. + + Check_SPARK_Model_In_Effect (Inst); + -- 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. - if Nkind (Inst) = N_Package_Instantiation then - Req_Nam := Name_Elaborate_All; - else - Req_Nam := Name_Elaborate; - end if; - - Meet_Elaboration_Requirement - (N => Inst, - Target_Id => Gen_Id, - Req_Nam => Req_Nam); - - -- Nothing to do when the instantiation is ABE-safe - - -- 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. + -- IMPORTANT: This check must be performed only when -gnatd.v (enforce + -- SPARK elaboration rules in SPARK code) is active because the static + -- model can ensure the prior elaboration of the unit which contains a + -- body by installing an implicit Elaborate[_All] pragma. + + if Debug_Flag_Dot_V then + if Nkind (Inst) = N_Package_Instantiation then + Req_Nam := Name_Elaborate_All; + else + Req_Nam := Name_Elaborate; + end if; + + Meet_Elaboration_Requirement + (N => Inst, + Target_Id => Gen_Id, + Req_Nam => Req_Nam); + + -- Otherwise ensure that the unit with the target body is elaborated + -- prior to the main unit. else - null; - end if; - end Process_Instantiation_SPARK; - - --------------------------------- - -- Process_Variable_Assignment -- - --------------------------------- - - procedure Process_Variable_Assignment (Asmt : Node_Id) is + Ensure_Prior_Elaboration + (N => Inst, + Unit_Id => Gen_Attrs.Unit_Id, + Prag_Nam => Name_Elaborate, + State => State); + end if; + end Process_Conditional_ABE_Instantiation_SPARK; + + ------------------------------------------------- + -- Process_Conditional_ABE_Variable_Assignment -- + ------------------------------------------------- + + procedure Process_Conditional_ABE_Variable_Assignment (Asmt : Node_Id) is Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (Asmt)); Prag : constant Node_Id := SPARK_Pragma (Var_Id); @@ -7937,24 +9987,24 @@ -- variables. if SPARK_Rules_On then - Process_Variable_Assignment_SPARK + Process_Conditional_ABE_Variable_Assignment_SPARK (Asmt => Asmt, Var_Id => Var_Id); -- Otherwise the Ada rules are in effect else - Process_Variable_Assignment_Ada + Process_Conditional_ABE_Variable_Assignment_Ada (Asmt => Asmt, Var_Id => Var_Id); end if; - end Process_Variable_Assignment; - - ------------------------------------- - -- Process_Variable_Assignment_Ada -- - ------------------------------------- - - procedure Process_Variable_Assignment_Ada + end Process_Conditional_ABE_Variable_Assignment; + + ----------------------------------------------------- + -- Process_Conditional_ABE_Variable_Assignment_Ada -- + ----------------------------------------------------- + + procedure Process_Conditional_ABE_Variable_Assignment_Ada (Asmt : Node_Id; Var_Id : Entity_Id) is @@ -7966,14 +10016,10 @@ -- spec without a pragma Elaborate_Body is initialized by elaboration -- code within the corresponding body. - if not Warnings_Off (Var_Id) + if Is_Elaboration_Warnings_OK_Id (Var_Id) and then not Is_Initialized (Var_Decl) and then not Has_Pragma_Elaborate_Body (Spec_Id) then - -- Generate an implicit Elaborate_Body in the spec - - Set_Elaborate_Body_Desirable (Spec_Id); - Error_Msg_NE ("??variable & can be accessed by clients before this " & "initialization", Asmt, Var_Id); @@ -7983,14 +10029,18 @@ & "initialization", Asmt, Spec_Id); Output_Active_Scenarios (Asmt); - end if; - end Process_Variable_Assignment_Ada; - - --------------------------------------- - -- Process_Variable_Assignment_SPARK -- - --------------------------------------- - - procedure Process_Variable_Assignment_SPARK + + -- Generate an implicit Elaborate_Body in the spec + + Set_Elaborate_Body_Desirable (Spec_Id); + end if; + end Process_Conditional_ABE_Variable_Assignment_Ada; + + ------------------------------------------------------- + -- Process_Conditional_ABE_Variable_Assignment_SPARK -- + ------------------------------------------------------- + + procedure Process_Conditional_ABE_Variable_Assignment_SPARK (Asmt : Node_Id; Var_Id : Entity_Id) is @@ -7998,11 +10048,17 @@ Spec_Id : constant Entity_Id := Find_Top_Unit (Var_Decl); begin + -- Ensure that a suitable elaboration model is in effect for SPARK rule + -- verification. + + Check_SPARK_Model_In_Effect (Asmt); + -- Emit an error when an initialized variable declared in a package spec -- without pragma Elaborate_Body is further modified by elaboration code -- within the corresponding body. - if Is_Initialized (Var_Decl) + if Is_Elaboration_Warnings_OK_Id (Var_Id) + and then Is_Initialized (Var_Decl) and then not Has_Pragma_Elaborate_Body (Spec_Id) then Error_Msg_NE @@ -8015,13 +10071,13 @@ Output_Active_Scenarios (Asmt); end if; - end Process_Variable_Assignment_SPARK; - - --------------------------- - -- Process_Variable_Read -- - --------------------------- - - procedure Process_Variable_Read (Ref : Node_Id) is + end Process_Conditional_ABE_Variable_Assignment_SPARK; + + ------------------------------------------------ + -- Process_Conditional_ABE_Variable_Reference -- + ------------------------------------------------ + + procedure Process_Conditional_ABE_Variable_Reference (Ref : Node_Id) is Var_Attrs : Variable_Attributes; Var_Id : Entity_Id; @@ -8031,6 +10087,24 @@ Var_Id => Var_Id, Attrs => Var_Attrs); + if Is_Read (Ref) then + Process_Conditional_ABE_Variable_Reference_Read + (Ref => Ref, + Var_Id => Var_Id, + Attrs => Var_Attrs); + end if; + end Process_Conditional_ABE_Variable_Reference; + + ----------------------------------------------------- + -- Process_Conditional_ABE_Variable_Reference_Read -- + ----------------------------------------------------- + + procedure Process_Conditional_ABE_Variable_Reference_Read + (Ref : Node_Id; + Var_Id : Entity_Id; + Attrs : Variable_Attributes) + is + begin -- Output relevant information when switch -gnatel (info messages on -- implicit Elaborate[_All] pragmas) is in effect. @@ -8046,7 +10120,7 @@ -- Nothing to do when the variable appears within the main unit because -- diagnostics on reads are relevant only for external variables. - if Is_Same_Unit (Var_Attrs.Unit_Id, Cunit_Entity (Main_Unit)) then + if Is_Same_Unit (Attrs.Unit_Id, Cunit_Entity (Main_Unit)) then null; -- Nothing to do when the variable is already initialized. Note that the @@ -8058,7 +10132,7 @@ -- Nothing to do when the external unit guarantees the initialization of -- the variable by means of pragma Elaborate_Body. - elsif Has_Pragma_Elaborate_Body (Var_Attrs.Unit_Id) then + elsif Has_Pragma_Elaborate_Body (Attrs.Unit_Id) then null; -- A variable read imposes an Elaborate requirement on the context of @@ -8071,22 +10145,20 @@ Target_Id => Var_Id, Req_Nam => Name_Elaborate); end if; - end Process_Variable_Read; - - -------------------------- - -- Push_Active_Scenario -- - -------------------------- - - procedure Push_Active_Scenario (N : Node_Id) is - begin - Scenario_Stack.Append (N); - end Push_Active_Scenario; - - ---------------------- - -- Process_Scenario -- - ---------------------- - - procedure Process_Scenario (N : Node_Id; In_Task_Body : Boolean := False) is + end Process_Conditional_ABE_Variable_Reference_Read; + + ----------------------------- + -- Process_Conditional_ABE -- + ----------------------------- + + -- NOTE: The body of this routine is intentionally out of order because it + -- invokes an instantiated subprogram (Process_Conditional_ABE_Activation). + -- Placing the body in alphabetical order will result in a guaranteed ABE. + + procedure Process_Conditional_ABE + (N : Node_Id; + State : Processing_Attributes := Initial_State) + is Call_Attrs : Call_Attributes; Target_Id : Entity_Id; @@ -8098,9 +10170,11 @@ -- 'Access if Is_Suitable_Access (N) then - Process_Access (N, In_Task_Body); - - -- Calls + Process_Conditional_ABE_Access + (Attr => N, + State => State); + + -- Activations and calls elsif Is_Suitable_Call (N) then @@ -8118,41 +10192,489 @@ 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); + Process_Conditional_ABE_Activation + (Call => N, + Call_Attrs => Call_Attrs, + State => State); else - Process_Call - (Call => N, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id, - In_Task_Body => In_Task_Body); + Process_Conditional_ABE_Call + (Call => N, + Call_Attrs => Call_Attrs, + Target_Id => Target_Id, + State => State); end if; end if; -- Instantiations elsif Is_Suitable_Instantiation (N) then - Process_Instantiation (N, In_Task_Body); + Process_Conditional_ABE_Instantiation + (Exp_Inst => N, + State => State); -- Variable assignments elsif Is_Suitable_Variable_Assignment (N) then - Process_Variable_Assignment (N); - - -- Variable read - - elsif Is_Suitable_Variable_Read (N) then - Process_Variable_Read (N); + Process_Conditional_ABE_Variable_Assignment (N); + + -- Variable references + + elsif Is_Suitable_Variable_Reference (N) then + + -- In general, only variable references 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 + -- variable references also receive corresponding variable reference + -- markers (see Build_Varaible_Reference_Marker). Regardless of the + -- reason, external variable references must not be processed. + + if In_Main_Context (N) then + Process_Conditional_ABE_Variable_Reference (N); + end if; end if; -- 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; + end Process_Conditional_ABE; + + -------------------------------------------- + -- Process_Guaranteed_ABE_Activation_Impl -- + -------------------------------------------- + + procedure Process_Guaranteed_ABE_Activation_Impl + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + State : Processing_Attributes) + is + pragma Unreferenced (State); + + 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. + + begin + -- 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; + + -- 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 + -- package Inst is new Gen; + -- T : Inst.Task_Typ; + -- end Nested; -- safe activation + -- ... + + elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then + return; + + -- 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. + -- + -- procedure Guaranteed_ABE is + -- task type Task_Typ; + -- + -- package Nested is + -- T : Task_Typ; + -- <activation call> -- guaranteed ABE + -- end Nested; + -- + -- 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 + if Call_Attrs.Elab_Warnings_OK 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); + end if; + + -- 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_Guaranteed_ABE_Activation_Impl; + + procedure Process_Guaranteed_ABE_Activation is + new Process_Activation_Generic (Process_Guaranteed_ABE_Activation_Impl); + + --------------------------------- + -- Process_Guaranteed_ABE_Call -- + --------------------------------- + + procedure Process_Guaranteed_ABE_Call + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id) + is + Target_Attrs : Target_Attributes; + + begin + Extract_Target_Attributes + (Target_Id => Target_Id, + Attrs => Target_Attrs); + + -- Nothing to do when the root scenario appears at the declaration level + -- and the target is in the same unit, but outside this context. + -- + -- function B ...; -- target declaration + -- + -- procedure Proc is + -- function A ... is + -- begin + -- if Some_Condition then + -- return B; -- call site + -- ... + -- end A; + -- + -- X : ... := A; -- root scenario + -- ... + -- + -- function B ... is + -- ... + -- end B; + -- + -- 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. + + -- Performance note: parent traversal + + if Is_Up_Level_Target (Target_Attrs.Spec_Decl) then + return; + + -- Nothing to do when the call is ABE-safe + -- + -- generic + -- function Gen ...; + -- + -- function Gen ... is + -- begin + -- ... + -- end Gen; + -- + -- with Gen; + -- procedure Main is + -- function Inst is new Gen; + -- X : ... := Inst; -- safe call + -- ... + + 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 + if Call_Attrs.Elab_Warnings_OK then + Error_Msg_NE ("??cannot call & before body seen", Call, Target_Id); + Error_Msg_N ("\Program_Error will be raised at run time", Call); + end if; + + -- 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 Process_Guaranteed_ABE_Call; + + ------------------------------------------ + -- Process_Guaranteed_ABE_Instantiation -- + ------------------------------------------ + + procedure Process_Guaranteed_ABE_Instantiation (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 + 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; + + -- Nothing to do when the instantiation is ABE-safe + -- + -- 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 + -- ... + + elsif Is_Safe_Instantiation (Inst, Gen_Attrs) then + return; + + -- 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. + -- + -- procedure Guaranteed_ABE is + -- generic + -- procedure Gen; + -- + -- package Nested is + -- procedure Inst is new Gen; -- guaranteed ABE + -- end Nested; + -- + -- procedure Gen is + -- ... + -- end Gen; + -- ... + + -- Performance note: parent traversal + + elsif Is_Guaranteed_ABE + (N => Inst, + Target_Decl => Gen_Attrs.Spec_Decl, + Target_Body => Gen_Attrs.Body_Decl) + then + if Inst_Attrs.Elab_Warnings_OK then + Error_Msg_NE + ("??cannot instantiate & before body seen", Inst, Gen_Id); + Error_Msg_N ("\Program_Error will be raised at run time", Inst); + end if; + + -- Mark the instantiation as a guarantee ABE. This automatically + -- suppresses the instantiation of the generic body. + + 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_Guaranteed_ABE_Instantiation; + + ---------------------------- + -- Process_Guaranteed_ABE -- + ---------------------------- + + -- NOTE: The body of this routine is intentionally out of order because it + -- invokes an instantiated subprogram (Process_Guaranteed_ABE_Activation). + -- Placing the body in alphabetical order will result in a 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 + + Push_Active_Scenario (N); + + -- Only calls, instantiations, and task activations may result in a + -- guaranteed ABE. + + 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_Guaranteed_ABE_Activation + (Call => N, + Call_Attrs => Call_Attrs, + State => Initial_State); + + else + Process_Guaranteed_ABE_Call + (Call => N, + Call_Attrs => Call_Attrs, + Target_Id => Target_Id); + end if; + + elsif Is_Suitable_Instantiation (N) then + Process_Guaranteed_ABE_Instantiation (N); + end if; + + -- 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_Guaranteed_ABE; + + -------------------------- + -- Push_Active_Scenario -- + -------------------------- + + procedure Push_Active_Scenario (N : Node_Id) is + begin + Scenario_Stack.Append (N); + end Push_Active_Scenario; --------------------------------- -- Record_Elaboration_Scenario -- @@ -8161,19 +10683,36 @@ procedure Record_Elaboration_Scenario (N : Node_Id) is Level : Enclosing_Level_Kind; + Any_Level_OK : Boolean; + -- This flag is set when a particular scenario is allowed to appear at + -- any level. + Declaration_Level_OK : Boolean; -- This flag is set when a particular scenario is allowed to appear at -- the declaration level. - begin - -- Assume that the scenario must not appear at the declaration level - + Library_Level_OK : Boolean; + -- This flag is set when a particular scenario is allowed to appear at + -- the library level. + + begin + -- Assume that the scenario cannot appear on any level + + Any_Level_OK := False; 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 + Library_Level_OK := False; + + -- Nothing to do when switch -gnatH (legacy elaboration checking mode + -- enabled) is in effect because the legacy ABE mechanism does not need + -- to carry out this action. + + if Legacy_Elaboration_Checks then + return; + + -- Nothing to do for ASIS because ABE checks and diagnostics are not + -- performed in this mode. + + elsif ASIS_Mode then return; -- Nothing to do when the scenario is being preanalyzed @@ -8182,7 +10721,7 @@ return; end if; - -- Ensure that a library level call does not appear in a preelaborated + -- 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. @@ -8208,10 +10747,13 @@ -- 'Access for entries, operators, and subprograms -- Assignments to variables -- Calls (includes task activation) + -- Derived types -- Instantiations + -- Pragma Refined_State -- Reads of variables elsif Is_Suitable_Access (N) then + Library_Level_OK := True; -- Signal any enclosing local exception handlers that the 'Access may -- raise Program_Error due to a failed ABE check when switch -gnatd.o @@ -8226,6 +10768,7 @@ elsif Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N) then Declaration_Level_OK := True; + Library_Level_OK := True; -- Signal any enclosing local exception handlers that the call or -- instantiation may raise Program_Error due to a failed ABE check. @@ -8235,10 +10778,16 @@ Possible_Local_Raise (N, Standard_Program_Error); + elsif Is_Suitable_SPARK_Derived_Type (N) then + Any_Level_OK := True; + + elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then + Library_Level_OK := True; + elsif Is_Suitable_Variable_Assignment (N) - or else Is_Suitable_Variable_Read (N) - then - null; + or else Is_Suitable_Variable_Reference (N) + then + Library_Level_OK := True; -- Otherwise the input does not denote a suitable scenario @@ -8252,31 +10801,76 @@ 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 + -- Certain scenarios are allowed to appear at any level. This check + -- is performed here in order to save on a parent traversal. + + if Any_Level_OK 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. + -- Otherwise the scenario must appear at a specific level else - return; - end if; + -- 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 or instantiation scenario + + elsif Library_Level_OK + and then Level in Library_Or_Instantiation_Level + then + null; + + -- Otherwise the scenario does not appear at the proper level and + -- cannot possibly act as a top-level scenario. + + else + return; + end if; + end if; + end if; + + -- Derived types subject to SPARK_Mode On require elaboration-related + -- checks even though the type may not be declared within elaboration + -- code. The types are recorded in a separate table which is examined + -- during the Processing phase. Note that the checks must be delayed + -- because the bodies of overriding primitives are not available yet. + + if Is_Suitable_SPARK_Derived_Type (N) then + Record_SPARK_Elaboration_Scenario (N); + + -- Nothing left to do for derived types + + return; + + -- Instantiations of generics both subject to SPARK_Mode On require + -- elaboration-related checks even though the instantiations may not + -- appear within elaboration code. The instantiations are recored in + -- a separate table which is examined during the Procesing phase. Note + -- that the checks must be delayed because it is not known yet whether + -- the generic unit has a body or not. + + -- IMPORTANT: A SPARK instantiation is also a normal instantiation which + -- is subject to common conditional and guaranteed ABE checks. + + elsif Is_Suitable_SPARK_Instantiation (N) then + Record_SPARK_Elaboration_Scenario (N); + + -- External constituents that refine abstract states which appear in + -- pragma Initializes require elaboration-related checks even though + -- a Refined_State pragma lacks any elaboration semantic. + + elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then + Record_SPARK_Elaboration_Scenario (N); + + -- Nothing left to do for pragma Refined_State + + return; end if; -- Perform early detection of guaranteed ABEs in order to suppress the @@ -8289,17 +10883,56 @@ -- later processing by the ABE phase. Top_Level_Scenarios.Append (N); - - -- Mark a scenario which may produce run-time conditional ABE checks or - -- guaranteed ABE failures as recorded. The flag ensures that scenario - -- rewriting performed by Atree.Rewrite will be properly reflected in - -- all relevant internal data structures. - - if Is_Check_Emitting_Scenario (N) then - Set_Is_Recorded_Scenario (N); - end if; + Set_Is_Recorded_Top_Level_Scenario (N); end Record_Elaboration_Scenario; + --------------------------------------- + -- Record_SPARK_Elaboration_Scenario -- + --------------------------------------- + + procedure Record_SPARK_Elaboration_Scenario (N : Node_Id) is + begin + SPARK_Scenarios.Append (N); + Set_Is_Recorded_SPARK_Scenario (N); + end Record_SPARK_Elaboration_Scenario; + + ----------------------------------- + -- Recorded_SPARK_Scenarios_Hash -- + ----------------------------------- + + function Recorded_SPARK_Scenarios_Hash + (Key : Node_Id) return Recorded_SPARK_Scenarios_Index + is + begin + return + Recorded_SPARK_Scenarios_Index (Key mod Recorded_SPARK_Scenarios_Max); + end Recorded_SPARK_Scenarios_Hash; + + --------------------------------------- + -- Recorded_Top_Level_Scenarios_Hash -- + --------------------------------------- + + function Recorded_Top_Level_Scenarios_Hash + (Key : Node_Id) return Recorded_Top_Level_Scenarios_Index + is + begin + return + Recorded_Top_Level_Scenarios_Index + (Key mod Recorded_Top_Level_Scenarios_Max); + end Recorded_Top_Level_Scenarios_Hash; + + -------------------------- + -- Reset_Visited_Bodies -- + -------------------------- + + procedure Reset_Visited_Bodies is + begin + if Visited_Bodies_In_Use then + Visited_Bodies_In_Use := False; + Visited_Bodies.Reset; + end if; + end Reset_Visited_Bodies; + ------------------- -- Root_Scenario -- ------------------- @@ -8315,6 +10948,71 @@ return Stack.Table (Stack.First); end Root_Scenario; + --------------------------- + -- Set_Early_Call_Region -- + --------------------------- + + procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id) is + begin + pragma Assert (Ekind_In (Body_Id, E_Entry, + E_Entry_Family, + E_Function, + E_Procedure, + E_Subprogram_Body)); + + Early_Call_Regions_In_Use := True; + Early_Call_Regions.Set (Body_Id, Start); + end Set_Early_Call_Region; + + ---------------------------- + -- Set_Elaboration_Status -- + ---------------------------- + + procedure Set_Elaboration_Status + (Unit_Id : Entity_Id; + Val : Elaboration_Attributes) + is + begin + Elaboration_Statuses_In_Use := True; + Elaboration_Statuses.Set (Unit_Id, Val); + end Set_Elaboration_Status; + + ------------------------------------ + -- Set_Is_Recorded_SPARK_Scenario -- + ------------------------------------ + + procedure Set_Is_Recorded_SPARK_Scenario + (N : Node_Id; + Val : Boolean := True) + is + begin + Recorded_SPARK_Scenarios_In_Use := True; + Recorded_SPARK_Scenarios.Set (N, Val); + end Set_Is_Recorded_SPARK_Scenario; + + ---------------------------------------- + -- Set_Is_Recorded_Top_Level_Scenario -- + ---------------------------------------- + + procedure Set_Is_Recorded_Top_Level_Scenario + (N : Node_Id; + Val : Boolean := True) + is + begin + Recorded_Top_Level_Scenarios_In_Use := True; + Recorded_Top_Level_Scenarios.Set (N, Val); + end Set_Is_Recorded_Top_Level_Scenario; + + ------------------------- + -- Set_Is_Visited_Body -- + ------------------------- + + procedure Set_Is_Visited_Body (Subp_Body : Node_Id) is + begin + Visited_Bodies_In_Use := True; + Visited_Bodies.Set (Subp_Body, True); + end Set_Is_Visited_Body; + ------------------------------- -- Static_Elaboration_Checks -- ------------------------------- @@ -8328,85 +11026,151 @@ -- 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 - -- 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; - - return OK; - end Is_Potential_Scenario; - - ------------------- - -- Traverse_List -- - ------------------- - - procedure Traverse_List (List : List_Id) is - Item : Node_Id; - - begin - Item := First (List); - while Present (Item) loop - Traverse_Potential_Scenarios (Item); - Next (Item); - end loop; - end Traverse_List; + procedure Traverse_Body (N : Node_Id; State : Processing_Attributes) is + procedure Find_And_Process_Nested_Scenarios; + pragma Inline (Find_And_Process_Nested_Scenarios); + -- Examine the declarations and statements of subprogram body N for + -- suitable scenarios. + + --------------------------------------- + -- Find_And_Process_Nested_Scenarios -- + --------------------------------------- + + procedure Find_And_Process_Nested_Scenarios is + function Is_Potential_Scenario + (Nod : Node_Id) return Traverse_Result; + -- Determine whether arbitrary node Nod denotes a suitable scenario. + -- If it does, save it in the Nested_Scenarios list of the subprogram + -- body, and process it. + + procedure Traverse_List (List : List_Id); + pragma Inline (Traverse_List); + -- Invoke Traverse_Potential_Scenarios on each node in list List + + procedure Traverse_Potential_Scenarios is + new Traverse_Proc (Is_Potential_Scenario); + + --------------------------- + -- Is_Potential_Scenario -- + --------------------------- + + function Is_Potential_Scenario + (Nod : Node_Id) return Traverse_Result + is + begin + -- 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 when encountering an + -- accept or select statement, and + -- + -- * Entry calls during elaboration are not allowed. In this + -- case the accept or select statement will cause the task + -- to block at elaboration time because there are no entry + -- calls to unblock it. + -- + -- or + -- + -- * Switch -gnatd_a (stop elaboration checks on accept or + -- select statement) is in effect. + + elsif (Debug_Flag_Underscore_A + or else Restriction_Active + (No_Entry_Calls_In_Elaboration_Code)) + and then Nkind_In (Original_Node (Nod), N_Accept_Statement, + N_Selective_Accept) + then + return Abandon; + + -- Terminate the traversal of a task body when encountering a + -- suspension call, and + -- + -- * Entry calls during elaboration are not allowed. In this + -- case the suspension call emulates an entry call and will + -- cause the task to block at elaboration time. + -- + -- or + -- + -- * Switch -gnatd_s (stop elaboration checks on synchronous + -- suspension) is in effect. + -- + -- Note that the guard should not be checking the state of flag + -- Within_Task_Body because only suspension calls which appear + -- immediately within the statements of the task are supported. + -- Flag Within_Task_Body carries over to deeper levels of the + -- traversal. + + elsif (Debug_Flag_Underscore_S + or else Restriction_Active + (No_Entry_Calls_In_Elaboration_Code)) + and then Is_Synchronous_Suspension_Call (Nod) + and then In_Task_Body (Nod) + 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_Conditional_ABE + (N => Nod, + State => State); + end if; + + return OK; + end Is_Potential_Scenario; + + ------------------- + -- Traverse_List -- + ------------------- + + procedure Traverse_List (List : List_Id) is + Item : Node_Id; + + begin + Item := First (List); + while Present (Item) loop + Traverse_Potential_Scenarios (Item); + Next (Item); + end loop; + end Traverse_List; + + -- Start of processing for Find_And_Process_Nested_Scenarios + + begin + -- 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 Find_And_Process_Nested_Scenarios; -- Start of processing for Traverse_Body @@ -8421,59 +11185,167 @@ end if; -- Nothing to do if the body was already traversed during the processing - -- of the same top level scenario. - - if Visited_Bodies.Get (N) then + -- of the same top-level scenario. + + if Is_Visited_Body (N) then return; -- 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)); + Set_Is_Visited_Body (N); + end if; + + -- Examine the declarations and statements of the subprogram body for + -- suitable scenarios, save and process them accordingly. + + Find_And_Process_Nested_Scenarios; end Traverse_Body; + ----------------- + -- Unit_Entity -- + ----------------- + + function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id is + function Is_Subunit (Id : Entity_Id) return Boolean; + pragma Inline (Is_Subunit); + -- Determine whether the entity of an initial declaration denotes a + -- subunit. + + ---------------- + -- Is_Subunit -- + ---------------- + + function Is_Subunit (Id : Entity_Id) return Boolean is + Decl : constant Node_Id := Unit_Declaration_Node (Id); + + begin + return + Nkind_In (Decl, N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration, + N_Package_Declaration, + N_Protected_Type_Declaration, + N_Subprogram_Declaration, + N_Task_Type_Declaration) + and then Present (Corresponding_Body (Decl)) + and then Nkind (Parent (Unit_Declaration_Node + (Corresponding_Body (Decl)))) = N_Subunit; + end Is_Subunit; + + -- Local variables + + Id : Entity_Id; + + -- Start of processing for Unit_Entity + + begin + Id := Unique_Entity (Unit_Id); + + -- Skip all subunits found in the scope chain which ends at the input + -- unit. + + while Is_Subunit (Id) loop + Id := Scope (Id); + end loop; + + return Id; + end Unit_Entity; + --------------------------------- -- Update_Elaboration_Scenario -- --------------------------------- procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id) is - package Scenarios renames Top_Level_Scenarios; - - begin + procedure Update_SPARK_Scenario; + pragma Inline (Update_SPARK_Scenario); + -- Update the contents of table SPARK_Scenarios if Old_N is recorded + -- there. + + procedure Update_Top_Level_Scenario; + pragma Inline (Update_Top_Level_Scenario); + -- Update the contexts of table Top_Level_Scenarios if Old_N is recorded + -- there. + + --------------------------- + -- Update_SPARK_Scenario -- + --------------------------- + + procedure Update_SPARK_Scenario is + package Scenarios renames SPARK_Scenarios; + + begin + if Is_Recorded_SPARK_Scenario (Old_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; + + -- The old SPARK scenario is no longer recorded, but the new + -- one is. + + Set_Is_Recorded_Top_Level_Scenario (Old_N, False); + Set_Is_Recorded_Top_Level_Scenario (New_N); + return; + end if; + end loop; + + -- A recorded SPARK scenario must be in the table of recorded + -- SPARK scenarios. + + pragma Assert (False); + end if; + end Update_SPARK_Scenario; + + ------------------------------- + -- Update_Top_Level_Scenario -- + ------------------------------- + + procedure Update_Top_Level_Scenario is + package Scenarios renames Top_Level_Scenarios; + + begin + if Is_Recorded_Top_Level_Scenario (Old_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; + + -- The old top-level scenario is no longer recorded, but the + -- new one is. + + Set_Is_Recorded_Top_Level_Scenario (Old_N, False); + Set_Is_Recorded_Top_Level_Scenario (New_N); + return; + end if; + end loop; + + -- A recorded top-level scenario must be in the table of recorded + -- top-level scenarios. + + pragma Assert (False); + end if; + end Update_Top_Level_Scenario; + + -- Start of processing for Update_Elaboration_Requirement + + begin + -- Nothing to do when the old and new scenarios are one and the same + + if Old_N = New_N then + return; + -- 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; - - -- A recorded scenario must be in the table of recorded scenarios - - pragma Assert (False); + elsif Is_Scenario (Old_N) then + Update_SPARK_Scenario; + Update_Top_Level_Scenario; end if; end Update_Elaboration_Scenario; @@ -8486,4 +11358,3811 @@ return Visited_Bodies_Index (Key mod Visited_Bodies_Max); end Visited_Bodies_Hash; + --------------------------------------------------------------------------- + -- -- + -- L E G A C Y A C C E S S B E F O R E E L A B O R A T I O N -- + -- -- + -- M E C H A N I S M -- + -- -- + --------------------------------------------------------------------------- + + -- This section contains the implementation of the pre-18.x legacy ABE + -- mechanism. The mechanism can be activated using switch -gnatH (legacy + -- elaboration checking mode enabled). + + ----------------------------- + -- 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. + + -- 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. + + type Elab_Call_Element is record + Cloc : Source_Ptr; + Ent : Entity_Id; + 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 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: + + -- 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; + + -- Call; -- requires a check, different context + + type Visited_Element is record + Subp_Id : Entity_Id; + -- The entity of the subprogram being called + + Context : Node_Id; + -- The context where the call to the subprogram occurs + 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 table records delayed calls which must be examined after + -- all generic bodies have been instantiated. + + 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). + + E : Entity_Id; + -- The parameter E from the call to Check_Internal_Call + + Orig_Ent : Entity_Id; + -- The parameter Orig_Ent from the call to Check_Internal_Call + + 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. + + Outer_Scope : Entity_Id; + -- Save scope of outer level call + + From_Elab_Code : Boolean; + -- Save indication of whether this call is from elaboration code + + 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. + + From_SPARK_Code : Boolean; + -- Save indication of whether this call is under SPARK_Mode => On + end record; + + package Delay_Check is new Table.Table + (Table_Component_Type => Delay_Element, + 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. + + ----------------------- + -- 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 + (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 + (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 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. + + 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. + + 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 + + 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. + + -------------------------------------- + -- Activate_Elaborate_All_Desirable -- + -------------------------------------- + + 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 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_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. + + procedure Set_Elab_Flag (Itm : Node_Id); + -- Sets Elaborate_[All_]Desirable as appropriate on Itm + + ----------------------------- + -- Add_To_Context_And_Mark -- + ----------------------------- + + procedure Add_To_Context_And_Mark (Itm : Node_Id) is + CW : constant Node_Id := + Make_With_Clause (Sloc (Itm), + Name => Name (Itm)); + + begin + Set_Library_Unit (CW, Library_Unit (Itm)); + Set_Implicit_With (CW); + + -- Set elaborate all desirable on copy and then append the copy to + -- the list of body with's and we are done. + + Set_Elab_Flag (CW); + Append_To (CI, CW); + end Add_To_Context_And_Mark; + + ----------------- + -- In_Withs_Of -- + ----------------- + + 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); + + 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))); + + if U = Ent then + return True; + end if; + end if; + + Next (Itm); + end loop; + + return False; + end In_Withs_Of; + + ------------------- + -- Set_Elab_Flag -- + ------------------- + + procedure Set_Elab_Flag (Itm : Node_Id) is + begin + if Nkind (N) in N_Subprogram_Instantiation then + Set_Elaborate_Desirable (Itm); + else + Set_Elaborate_All_Desirable (Itm); + end if; + end Set_Elab_Flag; + + -- Start of processing for Activate_Elaborate_All_Desirable + + begin + -- Do not set binder indication if expansion is disabled, as when + -- compiling a generic unit. + + if not Expander_Active 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. + + if U = Main_Unit_Entity 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))); + + -- If we find it, then mark elaborate all desirable and return + + if U = Ent then + Set_Elab_Flag (Itm); + return; + end if; + end if; + + Next (Itm); + end loop; + + -- 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. + + if Is_Body_Name (Unm) + and then In_Withs_Of (Spec_Entity (UE)) + then + Add_To_Context_And_Mark (Itm); + 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. + + if Is_Child_Name (Unm) then + declare + Pkg : Entity_Id; + + 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; + + -- 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; + + ------------------ + -- Check_A_Call -- + ------------------ + + 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. + + ----------------------------------- + -- Call_To_Instance_From_Outside -- + ----------------------------------- + + function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean is + Scop : Entity_Id := Id; + + begin + loop + if Scop = Standard_Standard then + return False; + end if; + + if Is_Generic_Instance (Scop) then + return not In_Open_Scopes (Scop); + end if; + + Scop := Scope (Scop); + end loop; + end Call_To_Instance_From_Outside; + + ------------------ + -- Elab_Warning -- + ------------------ + + procedure Elab_Warning + (Msg_D : String; + Msg_S : String; + Ent : Node_Or_Entity_Id) + is + begin + -- Dynamic elaboration checks, real warning + + 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; + + -- In the access case emit first warning message as well, + -- otherwise list of calls will appear as errors. + + elsif Elab_Warnings then + Error_Msg_NE (Msg_S, N, Ent); + end if; + + -- Static elaboration checks, info message + + else + if Elab_Info_Messages then + Error_Msg_NE (Msg_S, N, Ent); + end if; + end if; + end Elab_Warning; + + ------------------ + -- Find_W_Scope -- + ------------------ + + function Find_W_Scope return Entity_Id is + Refed_Ent : constant Entity_Id := Get_Referenced_Ent (N); + W_Scope : Entity_Id; + + begin + if Is_Init_Proc (Refed_Ent) + and then not In_Same_Extended_Unit (N, Refed_Ent) + then + W_Scope := Scope (Refed_Ent); + else + W_Scope := E; + end if; + + -- Now loop through scopes to get to the enclosing compilation unit + + while not Is_Compilation_Unit (W_Scope) loop + W_Scope := Scope (W_Scope); + end loop; + + return W_Scope; + end Find_W_Scope; + + -- Local variables + + 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 + return; + + -- 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. + + elsif Nkind (Original_Node (N)) = N_Attribute_Reference + and then Attribute_Name (Original_Node (N)) = Name_Valid_Scalars + then + return; + + -- Intrinsics such as instances of Unchecked_Deallocation do not have + -- any body, so elaboration checking is not needed, and would be wrong. + + elsif Is_Intrinsic_Subprogram (E) then + return; + + -- Do not consider references to internal variables for SPARK semantics + + elsif Variable_Case and then not Comes_From_Source (E) then + return; + end if; + + -- Proceed with check + + Ent := E; + + -- For a variable reference, just set Body_Acts_As_Spec to False + + if Variable_Case then + Body_Acts_As_Spec := False; + + -- Additional checks for all other cases + + else + -- Go to parent for derived subprogram, or to original subprogram in + -- the case of a renaming (Alias covers both these cases). + + 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; + + -- Nothing to do for imported entities + + if Is_Imported (Ent) then + return; + end if; + + exit when Inst_Case or else No (Alias (Ent)); + Ent := Alias (Ent); + end loop; + + Decl := Unit_Declaration_Node (Ent); + + if Nkind (Decl) = N_Subprogram_Body then + Body_Acts_As_Spec := True; + + elsif Nkind_In (Decl, N_Subprogram_Declaration, + N_Subprogram_Body_Stub) + or else Inst_Case + then + Body_Acts_As_Spec := False; + + -- 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). + + else + return; + end if; + end if; + + E_Scope := Ent; + loop + if Elaboration_Checks_Suppressed (E_Scope) + or else Suppress_Elaboration_Warnings (E_Scope) + then + Cunit_SC := True; + end if; + + -- Exit when we get to compilation unit, not counting subunits + + exit when Is_Compilation_Unit (E_Scope) + and then (Is_Child_Unit (E_Scope) + or else Scope (E_Scope) = Standard_Standard); + + pragma Assert (E_Scope /= Standard_Standard); + + -- Move up a scope looking for compilation unit + + E_Scope := Scope (E_Scope); + end loop; + + -- No checks needed for pure or preelaborated compilation units + + if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then + return; + 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, 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. + + if not Dynamic_Elaboration_Checks + and then + Instantiation_Depth (Sloc (Ent)) > Instantiation_Depth (Sloc (N)) + then + return; + end if; + + -- Do not give a warning for a package with no body + + if Ekind (Ent) = E_Generic_Package and then not Has_Generic_Body (N) then + return; + end if; + + -- 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. + + if W_Scope = C_Scope then + if not Inter_Unit_Only then + Check_Internal_Call (N, Ent, Outer_Scope, E); + end if; + + return; + end if; + + -- Case of entity is not in current unit (i.e. with'ed unit case) + + -- We are only interested in such calls if the outer call was from + -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode. + + if not From_Elab_Code and then not Dynamic_Elaboration_Checks then + return; + end if; + + -- Nothing to do if some scope said that no checks were required + + 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. + + if Call_To_Instance_From_Outside (Ent) then + return; + 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. + + 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; + + begin + if not Is_Controlled (Typ) then + return; + else + Init := Find_Prim_Op (Typ, Name_Initialize); + + if Comes_From_Source (Init) then + Ent := Init; + else + return; + end if; + end if; + end; + + else + return; + end if; + end if; + + -- Check cases of internal units + + Callee_Unit_Internal := In_Internal_Unit (E_Scope); + + -- 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) + + if Callee_Unit_Internal and Inst_Case then + return; + end if; + + if C_Scope = Standard_Standard then + Caller_Unit_Internal := False; + else + Caller_Unit_Internal := In_Internal_Unit (C_Scope); + end if; + + -- 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). + + if Callee_Unit_Internal and not Caller_Unit_Internal then + return; + 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 ??? + + if (Callee_Unit_Internal and Caller_Unit_Internal) + and not Debug_Flag_EE + then + return; + end if; + + if Is_TSS (E, TSS_Deep_Initialize) then + Ent := E; + 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. + + -- However, if we are doing dynamic elaboration, we need to chase the + -- call in the usual manner. + + -- 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_Caller := Instantiation (Get_Source_File_Index (Sloc (N))); + Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent))); + + if Inst_Caller = No_Location then + Unit_Caller := No_Unit; + else + Unit_Caller := Get_Source_Unit (N); + end if; + + if Inst_Callee = No_Location then + Unit_Callee := No_Unit; + else + Unit_Callee := Get_Source_Unit (Ent); + 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)); + + -- If we don't get a spec entity, just ignore call. Not quite + -- clear why this check is necessary. ??? + + if No (E_Scope) then + return; + end if; + + -- Otherwise step to enclosing compilation unit + + while not Is_Compilation_Unit (E_Scope) loop + E_Scope := Scope (E_Scope); + end loop; + + -- 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. + + else + -- Loop to carefully follow renamings and derivations one step + -- outside the current unit, but not further. + + if not (Inst_Case or Variable_Case) + and then Present (Alias (Ent)) + then + E_Scope := Alias (Ent); + else + E_Scope := Ent; + end if; + + loop + while not Is_Compilation_Unit (E_Scope) loop + E_Scope := Scope (E_Scope); + end loop; + + -- 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. + + exit when E_Scope /= C_Scope; + Ent := Alias (Ent); + E_Scope := Ent; + + -- If no alias, there could be a previous error, but not if we've + -- already reached the outermost level (Standard). + + if No (Ent) then + return; + end if; + end loop; + end if; + + if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then + return; + end if; + + -- Determine whether the Default_Initial_Condition procedure of some + -- type is being invoked. + + Is_DIC := Ekind (Ent) = E_Procedure and then Is_DIC_Procedure (Ent); + + -- Checks related to Default_Initial_Condition fall under the SPARK + -- umbrella because this is a SPARK-specific annotation. + + SPARK_Elab_Errors := + SPARK_Mode = On and (Is_DIC or Dynamic_Elaboration_Checks); + + -- Now check if an Elaborate_All (or dynamic check) is needed + + 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) + then + -- Instantiation case + + 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); + 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. + + elsif Access_Case then + Elab_Warning ("", "info: access to & during elaboration?$?", Ent); + + -- Variable reference in SPARK mode + + 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); + end if; + + -- Subprogram call case + + else + if Nkind (Name (N)) in N_Has_Entity + and then Is_Init_Proc (Entity (Name (N))) + and then Comes_From_Source (Ent) + 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; + + else + Elab_Warning + ("call to & may raise Program_Error?l?", + "info: call to & during elaboration?$?", + Ent); + end if; + end if; + + Error_Msg_Qual_Level := Nat'Last; + + -- Case of Elaborate_All not present and required, for SPARK this + -- is an error, so give an error message. + + if SPARK_Elab_Errors then + Error_Msg_NE -- CODEFIX + ("\Elaborate_All pragma required for&", N, W_Scope); + + -- 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. + + elsif Nkind (N) in N_Subprogram_Instantiation then + Elab_Warning + ("\missing pragma Elaborate for&?l?", + "\implicit pragma Elaborate for& generated?$?", + W_Scope); + + -- For all other cases, we need an implicit Elaborate_All + + else + Elab_Warning + ("\missing pragma Elaborate_All for&?l?", + "\implicit pragma Elaborate_All for & generated?$?", + W_Scope); + end if; + + Error_Msg_Qual_Level := 0; + + -- 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. + + Output_Calls (N, Check_Elab_Flag => True); + + -- Set flag to prevent further warnings for same unit unless in + -- All_Errors_Mode. + + if not All_Errors_Mode and not Dynamic_Elaboration_Checks then + Set_Suppress_Elaboration_Warnings (W_Scope); + end if; + end if; + + -- Check for runtime elaboration check required + + 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. + + -- Note that for this case, we do check the real unit (the one + -- from following renamings, since that is the issue). + + -- Could this possibly miss a useless but required PE??? + + Insert_Elab_Check (N, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Elaborated, + Prefix => + New_Occurrence_Of (Spec_Entity (E_Scope), Loc))); + + -- 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. + + if Nkind (N) in N_Subprogram_Call then + Set_No_Elaboration_Check (N); + end if; + end if; + + -- Case of static elaboration model + + 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; + + -- Do not generate an Elaborate_All for finalization routines + -- that perform partial clean up as part of initialization. + + elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then + null; + + -- Here we need to generate an implicit elaborate all + + else + -- Generate Elaborate_All warning unless suppressed + + 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) + then + Error_Msg_Node_2 := W_Scope; + Error_Msg_NE + ("info: call to& in elaboration code requires pragma " + & "Elaborate_All on&?$?", N, E); + end if; + + -- Set indication for binder to generate Elaborate_All + + Set_Elaboration_Constraint (N, E, W_Scope); + end if; + end if; + end Check_A_Call; + + ----------------------------- + -- Check_Bad_Instantiation -- + ----------------------------- + + procedure Check_Bad_Instantiation (N : Node_Id) is + Ent : Entity_Id; + + begin + -- Nothing to do if we do not have an instantiation (happens in some + -- error cases, and also in the formal package declaration case) + + if Nkind (N) not in N_Generic_Instantiation then + return; + + -- Nothing to do if serious errors detected (avoid cascaded errors) + + elsif Serious_Errors_Detected /= 0 then + return; + + -- Nothing to do if not in full analysis mode + + elsif not Full_Analysis then + return; + + -- Nothing to do if inside a generic template + + elsif Inside_A_Generic then + return; + + -- Nothing to do if a library level instantiation + + elsif Nkind (Parent (N)) = N_Compilation_Unit then + return; + + -- Nothing to do if we are compiling a proper body for semantic + -- purposes only. The generic body may be in another proper body. + + elsif + Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit + then + return; + end if; + + Ent := Get_Generic_Entity (N); + + -- The case we are interested in is when the generic spec is in the + -- current declarative part + + if not Same_Elaboration_Scope (Current_Scope, Scope (Ent)) + or else not In_Same_Extended_Unit (N, Ent) + then + return; + 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. + + declare + D1 : constant Nat := Instantiation_Depth (Sloc (Ent)); + D2 : constant Nat := Instantiation_Depth (Sloc (N)); + + begin + if D1 > D2 then + return; + + elsif D1 = D2 + and then Is_Generic_Instance (Scope (Ent)) + and then not In_Open_Scopes (Scope (Ent)) + then + return; + end if; + end; + + -- Now we can proceed, if the entity being called has a completion, + -- then we are definitely OK, since we have already seen the body. + + if Has_Completion (Ent) then + return; + end if; + + -- If there is no body, then nothing to do + + if not Has_Generic_Body (N) then + return; + end if; + + -- Here we definitely have a bad instantiation + + Error_Msg_Warn := SPARK_Mode /= On; + Error_Msg_NE ("cannot instantiate& before body seen<<", N, Ent); + Error_Msg_N ("\Program_Error [<<", N); + + Insert_Elab_Check (N); + Set_Is_Known_Guaranteed_ABE (N); + end Check_Bad_Instantiation; + + --------------------- + -- Check_Elab_Call -- + --------------------- + + procedure Check_Elab_Call + (N : Node_Id; + Outer_Scope : Entity_Id := Empty; + In_Init_Proc : Boolean := False) + is + Ent : Entity_Id; + P : Node_Id; + + begin + pragma Assert (Legacy_Elaboration_Checks); + + -- 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. + + if not In_Extended_Main_Code_Unit (N) then + return; + end if; + + -- For an entry call, check relevant restriction + + 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); + + -- 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 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; + + -- Nothing to do if this is a call already rewritten for elab checking. + -- Such calls appear as the targets of If_Expressions. + + -- This check MUST be wrong, it catches far too much + + elsif Nkind (Parent (N)) = N_If_Expression then + return; + + -- Nothing to do if inside a generic template + + elsif Inside_A_Generic + and then No (Enclosing_Generic_Body (N)) + then + return; + + -- Nothing to do if call is being preanalyzed, as when within a + -- pre/postcondition, a predicate, or an invariant. + + elsif In_Spec_Expression then + return; + end if; + + -- 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. + + 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; + + -- Here we have a reference at elaboration time that must be checked + + if Debug_Flag_Underscore_LL then + Write_Str (" Check_Elab_Ref: "); + + 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)))); + end if; + + Write_Str ("'Access"); + + elsif No (Name (N)) or else not Is_Entity_Name (Name (N)) then + Write_Str ("<<not entity name>> "); + + else + Write_Name (Chars (Entity (Name (N)))); + end if; + + Write_Str (" reference at "); + Write_Location (Sloc (N)); + Write_Eol; + 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). + + -- 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. + + P := Parent (N); + while Present (P) loop + if Nkind_In (P, N_Parameter_Specification, + N_Component_Declaration) + then + return; + + -- The reference occurs within the constraint of a component, + -- so it must be checked. + + elsif Nkind (P) = N_Component_Definition then + exit; + + else + P := Parent (P); + end if; + end loop; + + -- Stuff that happens only at the outer level + + if No (Outer_Scope) then + Elab_Visited.Set_Last (0); + + -- Nothing to do if current scope is Standard (this is a bit odd, but + -- it happens in the case of generic instantiations). + + C_Scope := Current_Scope; + + if C_Scope = Standard_Standard then + return; + end if; + + -- First case, we are in elaboration code + + From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; + + if From_Elab_Code then + + -- Complain if ref that comes from source in preelaborated unit + -- and we are not inside a subprogram (i.e. we are in elab code). + + 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. + + Error_Msg_Warn := GNAT_Mode; + Error_Msg_N + ("<<non-static call not allowed in preelaborated unit", N); + return; + end if; + + -- Second case, we are inside a subprogram or concurrent unit, which + -- means we are not in elaboration code. + + 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 Is_List_Member (P) then + L := List_Containing (P); + P := Parent (L); + else + L := No_List; + P := Parent (P); + end if; + + exit when Nkind (P) = N_Subunit; + + -- Filter out case of default expressions, where we do not + -- do the check at this stage. + + if Nkind_In (P, N_Parameter_Specification, + N_Component_Declaration) + then + return; + end if; + + -- A protected body has no elaboration code and contains + -- only other bodies. + + if Nkind (P) = N_Protected_Body then + return; + + elsif Nkind_In (P, N_Subprogram_Body, + N_Task_Body, + N_Block_Statement, + N_Entry_Body) + then + if L = Declarations (P) then + exit; + + -- 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. + + elsif Dynamic_Elaboration_Checks then + + -- 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. + + if Debug_Flag_DD then + return; + end if; + + -- Do the check in this case + + exit; + + elsif Nkind (P) = N_Task_Body then + + -- The check is deferred until Check_Task_Activation + -- but we need to capture local suppress pragmas + -- that may inhibit checks on this call. + + Ent := Get_Referenced_Ent (N); + + if No (Ent) then + return; + + 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; + + return; + + -- 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. + + else + return; + end if; + end if; + end loop; + end; + end if; + end if; + + Ent := Get_Referenced_Ent (N); + + if No (Ent) 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. + + declare + Self : constant Visited_Element := + (Subp_Id => Ent, Context => Parent (N)); + + begin + for Index in 1 .. Elab_Visited.Last loop + if Self = Elab_Visited.Table (Index) then + return; + end if; + end loop; + end; + + -- See if we need to analyze this reference. We analyze it if either of + -- the following conditions is met: + + -- 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. + + -- It is an outer level reference from elaboration code, or a call to + -- an entity is in the same elaboration scope. + + -- And in these cases, we will check both inter-unit calls and + -- intra-unit (within a single unit) calls. + + C_Scope := Current_Scope; + + -- If not outer level reference, then we follow it if it is within the + -- original scope of the outer reference. + + 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) + then + null; + + elsif From_Elab_Code then + Set_C_Scope; + Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); + + elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then + Set_C_Scope; + Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); + + -- 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. + + elsif Dynamic_Elaboration_Checks then + Set_C_Scope; + Check_A_Call + (N, + Ent, + Standard_Standard, + Inter_Unit_Only => True, + Generate_Warnings => False); + + -- Otherwise nothing to do + + else + 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. + + if Is_Init_Proc (Ent) and then From_Elab_Code then + Process_Init_Proc : declare + Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent); + + function Check_Init_Call (Nod : Node_Id) return Traverse_Result; + -- Find subprogram calls within body of Init_Proc for Traverse + -- instantiation below. + + procedure Traverse_Body is new Traverse_Proc (Check_Init_Call); + -- Traversal procedure to find all calls with body of Init_Proc + + --------------------- + -- Check_Init_Call -- + --------------------- + + function Check_Init_Call (Nod : Node_Id) return Traverse_Result is + Func : Entity_Id; + + begin + if Nkind (Nod) in N_Subprogram_Call + and then Is_Entity_Name (Name (Nod)) + then + Func := Entity (Name (Nod)); + + if Comes_From_Source (Func) then + Check_A_Call + (N, Func, Standard_Standard, Inter_Unit_Only => True); + end if; + + return OK; + + else + return OK; + end if; + end Check_Init_Call; + + -- Start of processing for Process_Init_Proc + + begin + if Nkind (Unit_Decl) = N_Subprogram_Body then + Traverse_Body (Handled_Statement_Sequence (Unit_Decl)); + end if; + end Process_Init_Proc; + end if; + end Check_Elab_Call; + + ----------------------- + -- Check_Elab_Assign -- + ----------------------- + + procedure Check_Elab_Assign (N : Node_Id) is + Ent : Entity_Id; + Scop : Entity_Id; + + Pkg_Spec : Entity_Id; + Pkg_Body : Entity_Id; + + begin + pragma Assert (Legacy_Elaboration_Checks); + + -- 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. + + if Nkind_In (N, N_Indexed_Component, + N_Selected_Component, + N_Slice) + then + if not Is_Access_Type (Etype (Prefix (N))) then + Check_Elab_Assign (Prefix (N)); + end if; + + return; + end if; + + -- For type conversion, check expression + + if Nkind (N) = N_Type_Conversion then + Check_Elab_Assign (Expression (N)); + return; + end if; + + -- Nothing to do if this is not an entity reference otherwise get entity + + if Is_Entity_Name (N) then + Ent := Entity (N); + else + return; + end if; + + -- 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. + + 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) + 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; + + -- Here Scop points to the containing library package + + Pkg_Spec := Scop; + Pkg_Body := Body_Entity (Pkg_Spec); + + -- All OK if the package has an Elaborate_Body pragma + + if Has_Pragma_Elaborate_Body (Scop) then + return; + end if; + + -- OK if entity being modified is not in containing package spec + + if not In_Same_Source_Unit (Scop, Ent) then + return; + end if; + + -- 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. + + 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; + + Scop := Scope (Scop); + end loop; + + -- All OK if in task, don't issue warnings there + + if In_Task_Activation then + return; + end if; + + -- OK if no package body + + if No (Pkg_Body) then + return; + end if; + + -- OK if reference is not in package body + + if not In_Same_Source_Unit (Pkg_Body, N) then + return; + end if; + + -- OK if package body has no handled statement sequence + + 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; + + -- 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. + + Set_Elaborate_Body_Desirable (Pkg_Spec); + + -- All OK in gnat mode (we know what we are doing) + + if GNAT_Mode then + return; + end if; + + -- All OK if all warnings suppressed + + if Warning_Mode = Suppress then + return; + end if; + + -- All OK if elaboration checks suppressed for entity + + if Checks_May_Be_Suppressed (Ent) + and then Is_Check_Suppressed (Ent, Elaboration_Check) + then + return; + end if; + + -- 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. + + 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; + + -- Here is where we give the warning + + -- All OK if warnings suppressed on the entity + + if not Has_Warnings_Off (Ent) then + Error_Msg_Sloc := Sloc (Ent); + + 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; + + if not All_Errors_Mode then + Set_Suppress_Elaboration_Warnings (Ent); + end if; + end if; + end Check_Elab_Assign; + + ---------------------- + -- Check_Elab_Calls -- + ---------------------- + + -- WARNING: This routine manages SPARK regions + + procedure Check_Elab_Calls is + Saved_SM : SPARK_Mode_Type; + Saved_SMP : Node_Id; + + begin + pragma Assert (Legacy_Elaboration_Checks); + + -- 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. + + if (not Expander_Active and not GNATprove_Mode) + or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) + or else Subunits_Missing + then + return; + end if; + + -- Skip delayed calls if we had any errors + + if Serious_Errors_Detected = 0 then + Delaying_Elab_Checks := False; + Expander_Mode_Save_And_Set (True); + + 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; + + Saved_SM := SPARK_Mode; + Saved_SMP := SPARK_Mode_Pragma; + + -- Set appropriate value of SPARK_Mode + + if Delay_Check.Table (J).From_SPARK_Code then + SPARK_Mode := On; + end if; + + 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); + + Restore_SPARK_Mode (Saved_SM, Saved_SMP); + Pop_Scope; + end loop; + + -- Set Delaying_Elab_Checks back on for next main compilation + + Expander_Mode_Restore; + Delaying_Elab_Checks := True; + end if; + end Check_Elab_Calls; + + ------------------------------ + -- Check_Elab_Instantiation -- + ------------------------------ + + procedure Check_Elab_Instantiation + (N : Node_Id; + Outer_Scope : Entity_Id := Empty) + is + Ent : Entity_Id; + + begin + pragma Assert (Legacy_Elaboration_Checks); + + -- Check for and deal with bad instantiation case. There is some + -- duplicated code here, but we will worry about this later ??? + + Check_Bad_Instantiation (N); + + if Is_Known_Guaranteed_ABE (N) then + return; + 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) + + if Nkind (N) not in N_Generic_Instantiation then + return; + end if; + + -- Nothing to do if inside a generic template + + if Inside_A_Generic then + return; + end if; + + -- Nothing to do if the instantiation is not in the main unit + + if not In_Extended_Main_Code_Unit (N) then + return; + end if; + + Ent := Get_Generic_Entity (N); + From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; + + -- See if we need to analyze this instantiation. We analyze it if + -- either of the following conditions is met: + + -- 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. + + -- It is an outer level instantiation from elaboration code, or the + -- instantiated entity is in the same elaboration scope. + + -- And in these cases, we will check both the inter-unit case and + -- the intra-unit (within a single unit) case. + + C_Scope := Current_Scope; + + 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); + + elsif From_Elab_Code then + Set_C_Scope; + Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); + + elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then + Set_C_Scope; + Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); + + -- 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. + + elsif Dynamic_Elaboration_Checks then + Set_C_Scope; + Check_A_Call + (N, + Ent, + Standard_Standard, + Inter_Unit_Only => True, + Generate_Warnings => False); + + else + return; + end if; + end Check_Elab_Instantiation; + + ------------------------- + -- Check_Internal_Call -- + ------------------------- + + 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. + + ------------------------------ + -- Within_Initial_Condition -- + ------------------------------ + + function Within_Initial_Condition (Call : Node_Id) return Boolean is + Args : List_Id; + Nam : Name_Id; + Par : Node_Id; + + begin + -- Traverse the parent chain looking for an enclosing pragma + + Par := Call; + while Present (Par) loop + if Nkind (Par) = N_Pragma then + Nam := Pragma_Name (Par); + + -- Pragma Initial_Condition appears in its alternative from as + -- Check (Initial_Condition, ...). + + if Nam = Name_Check then + Args := Pragma_Argument_Associations (Par); + + -- Pragma Check should have at least two arguments + + pragma Assert (Present (Args)); + + return + Chars (Expression (First (Args))) = Name_Initial_Condition; + + -- Direct match + + elsif Nam = Name_Initial_Condition then + return True; + + -- Since pragmas are never nested within other pragmas, stop + -- the traversal. + + else + return False; + end if; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Par) then + exit; + 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; + + -- Local variables + + Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; + + -- Start of processing for Check_Internal_Call + + begin + -- For P'Access, we want to warn if the -gnatw.f switch is set, and the + -- node comes from source. + + 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 function or procedure call, instantiation, or 'Access, then + -- ignore call (this happens in some error cases and rewriting cases). + + elsif not Nkind_In (N, N_Attribute_Reference, + N_Function_Call, + N_Procedure_Call_Statement) + and then not Inst_Case + then + return; + + -- Nothing to do if this is a call or instantiation that has already + -- been found to be a sure ABE. + + elsif Nkind (N) /= N_Attribute_Reference + and then Is_Known_Guaranteed_ABE (N) + then + return; + + -- Nothing to do if errors already detected (avoid cascaded errors) + + elsif Serious_Errors_Detected /= 0 then + return; + + -- Nothing to do if not in full analysis mode + + elsif not Full_Analysis then + return; + + -- Nothing to do if analyzing in special spec-expression mode, since the + -- call is not actually being made at this time. + + elsif In_Spec_Expression then + return; + + -- Nothing to do for call to intrinsic subprogram + + elsif Is_Intrinsic_Subprogram (E) then + return; + + -- Nothing to do if call is within a generic unit + + elsif Inside_A_Generic then + return; + + -- 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. + + elsif Within_Initial_Condition (N) then + return; + end if; + + -- Delay this call if we are still delaying calls + + 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; + + -- Otherwise, call phase 2 continuation right now + + else + Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent); + end if; + end Check_Internal_Call; + + ---------------------------------- + -- Check_Internal_Call_Continue -- + ---------------------------------- + + procedure Check_Internal_Call_Continue + (N : Node_Id; + E : Entity_Id; + Outer_Scope : Entity_Id; + Orig_Ent : Entity_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. + + procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference); + -- Traverse procedure using above Find_Elab_Reference function + + ------------------------- + -- Find_Elab_Reference -- + ------------------------- + + function Find_Elab_Reference (N : Node_Id) return Traverse_Result is + Actual : Node_Id; + + 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. + + 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; + + -- If we have a function call, check it + + elsif Nkind (N) = N_Function_Call then + Check_Elab_Call (N, Outer_Scope); + return OK; + + -- If we have a procedure call, check the call, and also check + -- arguments that are assignments (OUT or IN OUT mode formals). + + elsif Nkind (N) = N_Procedure_Call_Statement then + Check_Elab_Call (N, Outer_Scope, In_Init_Proc => Is_Init_Proc (E)); + + Actual := First_Actual (N); + while Present (Actual) loop + if Known_To_Be_Assigned (Actual) then + Check_Elab_Assign (Actual); + end if; + + Next_Actual (Actual); + end loop; + + return OK; + + -- If we have an access attribute for a subprogram, check it. + -- Suppress this behavior under debug flag. + + 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; + + -- In SPARK mode, if we have an entity reference to a variable, then + -- check it. For now we consider any reference. + + 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 we have a generic instantiation, check it + + elsif Nkind (N) in N_Generic_Instantiation then + Check_Elab_Instantiation (N, Outer_Scope); + return OK; + + -- 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. + + -- 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. + + elsif Nkind (N) = N_Subprogram_Body + and then Comes_From_Source (N) + then + return Skip; + + elsif Nkind (N) = N_Assignment_Statement + and then Comes_From_Source (N) + then + Check_Elab_Assign (Name (N)); + return OK; + + else + return OK; + end if; + end Find_Elab_Reference; + + Inst_Case : constant Boolean := Is_Generic_Unit (E); + Loc : constant Source_Ptr := Sloc (N); + + Ebody : Entity_Id; + Sbody : Node_Id; + + -- Start of processing for Check_Internal_Call_Continue + + begin + -- Save outer level call if at outer level + + if Elab_Call.Last = 0 then + Outer_Level_Sloc := Loc; + end if; + + -- If the call is to a function that renames a literal, no check needed + + if Ekind (E) = E_Enumeration_Literal then + return; + end if; + + -- 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. + + Elab_Visited.Append ((Subp_Id => E, Context => Parent (N))); + + Sbody := Unit_Declaration_Node (E); + + if not Nkind_In (Sbody, N_Subprogram_Body, N_Package_Body) then + Ebody := Corresponding_Body (Sbody); + + if No (Ebody) then + return; + else + Sbody := Unit_Declaration_Node (Ebody); + end if; + end if; + + -- If the body appears after the outer level call or instantiation then + -- we have an error case handled below. + + if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody)) + and then not In_Task_Activation + then + null; + + -- If we have the instantiation case we are done, since we now know that + -- the body of the generic appeared earlier. + + elsif Inst_Case then + return; + + -- Otherwise we have a call, so we trace through the called body to see + -- if it has any problems. + + else + pragma Assert (Nkind (Sbody) = N_Subprogram_Body); + + Elab_Call.Append ((Cloc => Loc, Ent => E)); + + if Debug_Flag_Underscore_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; + + -- Now traverse declarations and statements of subprogram body. Note + -- that we cannot simply Traverse (Sbody), since traverse does not + -- normally visit subprogram bodies. + + declare + Decl : Node_Id; + begin + Decl := First (Declarations (Sbody)); + while Present (Decl) loop + Traverse (Decl); + Next (Decl); + end loop; + end; + + Traverse (Handled_Statement_Sequence (Sbody)); + + Elab_Call.Decrement_Last; + return; + end if; + + -- 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). + + declare + P : Node_Id; + O : Node_Id; + + begin + P := Parent (N); + loop + -- Keep looking at parents if we are still in the subexpression + + if Nkind (P) in N_Subexpr then + P := Parent (P); + + -- Here P is the parent of the expression, check for special case + + else + O := Original_Node (P); + + -- Definitely not the special case if orig node is not a pragma + + exit when Nkind (O) /= N_Pragma; + + -- Check we have an If statement or a null statement (happens + -- when the If has been expanded to be True). + + exit when not Nkind_In (P, N_If_Statement, N_Null_Statement); + + -- Our special case will be indicated either by the pragma + -- coming from an aspect ... + + if Present (Corresponding_Aspect (O)) then + return; + + -- Or, in the case of an initial condition, specifically by a + -- Check pragma specifying an Initial_Condition check. + + elsif Pragma_Name (O) = Name_Check + and then + Chars + (Expression (First (Pragma_Argument_Associations (O)))) = + Name_Initial_Condition + then + return; + + -- For anything else, we have an error + + else + exit; + end if; + end if; + end loop; + end; + + -- Not that special case, warning and dynamic check is required + + -- 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. + + if Elab_Call.Last = 0 then + Error_Msg_Warn := SPARK_Mode /= On; + + declare + Insert_Check : Boolean := True; + -- This flag is set to True if an elaboration check should be + -- inserted. + + begin + if In_Task_Activation then + Insert_Check := False; + + elsif Inst_Case then + Error_Msg_NE + ("cannot instantiate& before body seen<<", N, Orig_Ent); + + 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; + + elsif Nkind (Unit_Declaration_Node (Orig_Ent)) /= + N_Subprogram_Renaming_Declaration + then + Error_Msg_NE + ("cannot call& before body seen<<", N, Orig_Ent); + + elsif not Is_Generic_Actual_Subprogram (Orig_Ent) then + Insert_Check := False; + end if; + + if Insert_Check then + Error_Msg_N ("\Program_Error [<<", N); + Insert_Elab_Check (N); + end if; + end; + + -- Call is not at outer level + + else + -- Do not generate elaboration checks in GNATprove mode because the + -- elaboration counter and the check are both forms of expansion. + + if GNATprove_Mode 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; + + -- Generate: + -- if Enn = 0 then + -- raise Program_Error with "access before elaboration"; + -- end if; + + Insert_Elab_Check (N, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Elaborated, + Prefix => New_Occurrence_Of (E, Loc))); + end if; + + -- Generate the warning + + if not Suppress_Elaboration_Warnings (E) + and then not Elaboration_Checks_Suppressed (E) + + -- 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. + + and then + (Nkind (Original_Node (N)) /= N_Function_Call + or else not In_Assertion_Expression_Pragma (Original_Node (N))) + then + Error_Msg_Warn := SPARK_Mode /= On; + + 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. + + 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; + + -- Go ahead and give warning if not this special case + + Error_Msg_NE + ("call to& may occur before body is seen<l<", N, Orig_Ent); + end if; + + Error_Msg_N ("\Program_Error ]<l<", N); + + -- 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. + + <<Output>> + + Output_Calls (N, Check_Elab_Flag => False); + end if; + end if; + end Check_Internal_Call_Continue; + + --------------------------- + -- Check_Task_Activation -- + --------------------------- + + 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. + + ------------------- + -- Add_Task_Proc -- + ------------------- + + procedure Add_Task_Proc (Typ : Entity_Id) is + Comp : Entity_Id; + Proc : Entity_Id := Empty; + + begin + if Is_Task_Type (Typ) then + Proc := Get_Task_Body_Procedure (Typ); + + elsif Is_Array_Type (Typ) + and then Has_Task (Base_Type (Typ)) + then + Add_Task_Proc (Component_Type (Typ)); + + 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; + end if; + + -- 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. + + -- Skip this test if errors have occurred, since in this case + -- we can get false indications. + + if Serious_Errors_Detected /= 0 then + return; + end if; + + if Present (Proc) then + if Outer_Unit (Scope (Proc)) = Enclosing then + + 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; + + else + -- No need for multiple entries of the same type + + Elmt := First_Elmt (Inter_Procs); + while Present (Elmt) loop + if Node (Elmt) = Proc then + return; + end if; + + Next_Elmt (Elmt); + end loop; + + Append_Elmt (Proc, Inter_Procs); + end if; + end if; + end Add_Task_Proc; + + ------------------- + -- Collect_Tasks -- + ------------------- + + 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; + + Next (Decl); + end loop; + end if; + end Collect_Tasks; + + ---------------- + -- Outer_Unit -- + ---------------- + + function Outer_Unit (E : Entity_Id) return Entity_Id is + Outer : Entity_Id; + + begin + Outer := E; + while Present (Outer) loop + if Elaboration_Checks_Suppressed (Outer) then + Cunit_SC := True; + end if; + + exit when Is_Child_Unit (Outer) + or else Scope (Outer) = Standard_Standard + or else Ekind (Outer) /= E_Package; + Outer := Scope (Outer); + end loop; + + return Outer; + end Outer_Unit; + + -- Start of processing for Check_Task_Activation + + begin + pragma Assert (Legacy_Elaboration_Checks); + + Enclosing := Outer_Unit (Current_Scope); + + -- Find all tasks declared in the current unit + + if Nkind (N) = N_Package_Body then + P := Unit_Declaration_Node (Corresponding_Spec (N)); + + Collect_Tasks (Declarations (N)); + Collect_Tasks (Visible_Declarations (Specification (P))); + Collect_Tasks (Private_Declarations (Specification (P))); + + elsif Nkind (N) = N_Package_Declaration then + Collect_Tasks (Visible_Declarations (Specification (N))); + Collect_Tasks (Private_Declarations (Specification (N))); + + else + Collect_Tasks (Declarations (N)); + end if; + + -- 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. + + -- Should dynamic checks be added in the more general case??? + + if Ekind (Enclosing) /= E_Package then + return; + end if; + + -- For task types defined in other units, we want the unit containing + -- the task body to be elaborated before the current one. + + Elmt := First_Elmt (Inter_Procs); + while Present (Elmt) loop + Ent := Node (Elmt); + Task_Scope := Outer_Unit (Scope (Ent)); + + if not Is_Compilation_Unit (Task_Scope) then + null; + + elsif Suppress_Elaboration_Warnings (Task_Scope) + or else Elaboration_Checks_Suppressed (Task_Scope) + then + null; + + 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; + + else + -- Force the binder to elaborate other unit first + + 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); + end if; + + Activate_Elaborate_All_Desirable (N, Task_Scope); + Set_Suppress_Elaboration_Warnings (Task_Scope); + end if; + + Next_Elmt (Elmt); + end loop; + + -- For tasks declared in the current unit, trace other calls within the + -- task procedure bodies, which are available. + + if not Debug_Flag_Dot_Y then + In_Task_Activation := True; + + 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; + + In_Task_Activation := False; + end if; + end Check_Task_Activation; + + ------------------------ + -- Get_Referenced_Ent -- + ------------------------ + + function Get_Referenced_Ent (N : Node_Id) return Entity_Id is + Nam : Node_Id; + + 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; + + if Nkind (N) = N_Attribute_Reference then + Nam := Prefix (N); + else + Nam := Name (N); + 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; + + ---------------------- + -- Has_Generic_Body -- + ---------------------- + + 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; + + begin + Nod := N; + while Present (Nod) loop + + -- If we found the package body we are looking for, return it + + if Nkind (Nod) = N_Package_Body + and then Chars (Defining_Unit_Name (Nod)) = Chars (E) + then + return Nod; + + -- If we found the stub for the body, go after the subunit, + -- loading it if necessary. + + 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)); + + else + return Load_Package_Body (Get_Unit_Name (Nod)); + end if; + + -- If neither package body nor stub, keep looking on chain + + else + Next (Nod); + end if; + end loop; + + return Empty; + end Find_Body_In; + + ----------------------- + -- Load_Package_Body -- + ----------------------- + + function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is + U : Unit_Number_Type; + + begin + if Operating_Mode /= Generate_Code then + return Empty; + else + U := + Load_Unit + (Load_Name => Nam, + Required => False, + Subunit => False, + Error_Node => N); + + if U = No_Unit then + return Empty; + else + return Unit (Cunit (U)); + end if; + end if; + end Load_Package_Body; + + ------------------------------- + -- Locate_Corresponding_Body -- + ------------------------------- + + 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; + + begin + if Is_Library_Level_Entity (PE) then + + -- 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. + + if Unit_Requires_Body (PE) then + + -- 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. + + return + Load_Package_Body + (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec)))); + + -- 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. + + else + return Empty; + end if; + + -- Otherwise look and see if we are embedded in a further package + + elsif Is_Package_Or_Generic_Package (Scop) then + + -- If so, get the body of the enclosing package, and look in + -- its package body for the package body we are looking for. + + PBody := Locate_Corresponding_Body (Scop); + + if No (PBody) then + return Empty; + else + return Find_Body_In (PE, First (Declarations (PBody))); + end if; + + -- If we are not embedded in a further package, then the body + -- must be in the same declarative part as we are. + + else + return Find_Body_In (PE, Next (Decl)); + end if; + end Locate_Corresponding_Body; + + -- Start of processing for Has_Generic_Body + + begin + if Present (Corresponding_Body (Decl)) then + return True; + + elsif Unit_Requires_Body (Ent) then + return True; + + -- Compilation units cannot have optional bodies + + elsif Is_Compilation_Unit (Ent) then + return False; + + -- Otherwise look at what scope we are in + + else + Scop := Scope (Ent); + + -- Case of entity is in other than a package spec, in this case + -- the body, if present, must be in the same declarative part. + + if not Is_Package_Or_Generic_Package (Scop) then + declare + P : Node_Id; + + begin + -- Declaration node may get us a spec, so if so, go to + -- the parent declaration. + + P := Declaration_Node (Ent); + while not Is_List_Member (P) loop + P := Parent (P); + end loop; + + return Present (Find_Body_In (Ent, Next (P))); + end; + + -- If the entity is in a package spec, then we have to locate + -- the corresponding package body, and look there. + + else + declare + PBody : constant Node_Id := Locate_Corresponding_Body (Scop); + + begin + if No (PBody) then + return False; + else + return + Present + (Find_Body_In (Ent, (First (Declarations (PBody))))); + end if; + end; + end if; + end if; + end Has_Generic_Body; + + ----------------------- + -- Insert_Elab_Check -- + ----------------------- + + procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is + Nod : Node_Id; + Loc : constant Source_Ptr := Sloc (N); + + Chk : Node_Id; + -- The check (N_Raise_Program_Error) node to be inserted + + 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. + + if not Expander_Active or else Subunits_Missing 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. + + if Nkind (N) in N_Generic_Instantiation + and then Present (Instance_Spec (N)) + then + Nod := Instance_Spec (N); + else + Nod := N; + end if; + + -- Build check node, possibly with condition + + Chk := + Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration); + + if Present (C) then + Set_Condition (Chk, Make_Op_Not (Loc, Right_Opnd => C)); + end if; + + -- If we are inserting at the top level, insert in Aux_Decls + + if Nkind (Parent (Nod)) = N_Compilation_Unit then + declare + ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod)); + + begin + if No (Declarations (ADN)) then + Set_Declarations (ADN, New_List (Chk)); + else + Append_To (Declarations (ADN), Chk); + end if; + + Analyze (Chk); + end; + + -- Otherwise just insert as an action on the node in question + + else + Insert_Action (Nod, Chk); + end if; + end Insert_Elab_Check; + + ------------------------------- + -- Is_Call_Of_Generic_Formal -- + ------------------------------- + + function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean is + begin + return Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) + + -- Always return False if debug flag -gnatd.G is set + + and then not Debug_Flag_Dot_GG + + -- 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. + + and then Nkind (Name (N)) = N_Identifier + and then Chars (Name (N)) /= Chars (Entity (Name (N))); + end Is_Call_Of_Generic_Formal; + + ------------------------------- + -- Is_Finalization_Procedure -- + ------------------------------- + + function Is_Finalization_Procedure (Id : Entity_Id) return Boolean is + begin + -- Check whether Id is a procedure with at least one parameter + + 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 + -- If the type of the first formal does not require finalization + -- actions, then this is definitely not [Deep_]Finalize. + + if not Needs_Finalization (Typ) then + return False; + end if; + + -- At this point we have the following scenario: + + -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]); + + -- Recover the two possible versions of [Deep_]Finalize using the + -- type of the first parameter and compare with the input. + + Deep_Fin := TSS (Typ, TSS_Deep_Finalize); + + if Is_Controlled (Typ) then + Fin := Find_Prim_Op (Typ, Name_Finalize); + end if; + + return (Present (Deep_Fin) and then Id = Deep_Fin) + or else (Present (Fin) and then Id = Fin); + end; + end if; + + return False; + end Is_Finalization_Procedure; + + ------------------ + -- Output_Calls -- + ------------------ + + 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. + + 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). + + ---------- + -- Emit -- + ---------- + + function Emit (Flag : Boolean) return Boolean is + begin + if Check_Elab_Flag then + return Flag; + else + return True; + end if; + end Emit; + + ----------------------------- + -- Is_Printable_Error_Name -- + ----------------------------- + + function Is_Printable_Error_Name return Boolean is + begin + if not Is_Internal_Name then + return True; + + elsif Name_Len = 1 then + return False; + + else + Name_Len := Name_Len - 1; + return not Is_Internal_Name; + end if; + end Is_Printable_Error_Name; + + -- Local variables + + Ent : Entity_Id; + + -- Start of processing for Output_Calls + + begin + for J in reverse 1 .. Elab_Call.Last loop + Error_Msg_Sloc := Elab_Call.Table (J).Cloc; + + Ent := Elab_Call.Table (J).Ent; + Get_Name_String (Chars (Ent)); + + -- Dynamic elaboration model, warnings controlled by -gnatwl + + 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; + + -- Static elaboration model, info messages controlled by -gnatel + + 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; + + ---------------------------- + -- Same_Elaboration_Scope -- + ---------------------------- + + function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is + S1 : Entity_Id; + S2 : Entity_Id; + + begin + -- Find elaboration scope for Scop1 + -- This is either a subprogram or a compilation unit. + + 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; + + -- Find elaboration scope for Scop2 + + 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; + + return S1 = S2; + end Same_Elaboration_Scope; + + ----------------- + -- Set_C_Scope -- + ----------------- + + 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; + + -------------------------------- + -- Set_Elaboration_Constraint -- + -------------------------------- + + procedure Set_Elaboration_Constraint + (Call : Node_Id; + Subp : Entity_Id; + Scop : Entity_Id) + is + Elab_Unit : Entity_Id; + + -- 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. + + 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))); + + begin + -- If the unit is mentioned in a with_clause of the current unit, it is + -- visible, and we can set the elaboration flag. + + 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; + 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. + + if Is_Init_Proc (Subp) + or else Init_Call + or else Nkind (Original_Node (Call)) = N_Selected_Component + then + null; -- detailed processing follows. + + 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. + + if Is_Init_Proc (Subp) or else Init_Call then + + -- 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. + + 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; + + -- 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. + + elsif Nkind (Original_Node (Call)) = N_Selected_Component then + Elab_Unit := Scope (Etype (First (Parameter_Associations (Call)))); + + -- Not one of special cases above + + 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. + + Elab_Unit := Scop; + end if; + + Activate_Elaborate_All_Desirable (Call, Elab_Unit); + Set_Suppress_Elaboration_Warnings (Elab_Unit); + end Set_Elaboration_Constraint; + + ----------------- + -- Spec_Entity -- + ----------------- + + function Spec_Entity (E : Entity_Id) return Entity_Id is + Decl : Node_Id; + + begin + -- Check for case of body entity + -- Why is the check for E_Void needed??? + + if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then + Decl := E; + + loop + Decl := Parent (Decl); + exit when Nkind (Decl) in N_Proper_Body; + end loop; + + return Corresponding_Spec (Decl); + + else + return E; + end if; + end Spec_Entity; + + ------------ + -- Within -- + ------------ + + 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; + else + Scop := Scope (Scop); + end if; + end loop; + end Within; + + -------------------------- + -- Within_Elaborate_All -- + -------------------------- + + 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); + + 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. + + Result : Boolean := False; + + 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. + + ------------ + -- Helper -- + ------------ + + procedure Helper (Unit : Unit_Number_Type) is + CU : constant Node_Id := Cunit (Unit); + + Item : Node_Id; + Item2 : Node_Id; + Elab_Id : Entity_Id; + Par : Node_Id; + + begin + if Seen (Unit) then + return; + else + Seen (Unit) := True; + end if; + + -- First, check for Elaborate_Alls on this unit + + Item := First (Context_Items (CU)); + 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. + + if Error_Posted (Item) or else not Analyzed (Item) then + return; + end if; + + Elab_Id := + Entity + (Expression (First (Pragma_Argument_Associations (Item)))); + + if E = Elab_Id then + Result := True; + return; + end if; + + Par := Parent (Unit_Declaration_Node (Elab_Id)); + + 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; + + Next (Item2); + end loop; + end if; + + Next (Item); + 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; + + Next (Item); + end loop; + end if; + end Helper; + + -- Start of processing for Within_Elaborate_All + + begin + Helper (Unit); + return Result; + end Within_Elaborate_All; + end Sem_Elab;