+2017-10-09 Bob Duff <duff@adacore.com>
+
+ * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): Use
+ Defining_Identifier (Obj_Decl) in two places, because it might have
+ changed.
+ * exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Deal with cases
+ involving 'Input on (not visibly) derived types.
+
+2017-10-09 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * atree.adb: Add new soft link Rewriting_Proc.
+ (Rewrite): Invoke the subprogram attached to the rewriting soft link.
+ (Set_Rewriting_Proc): New routine.
+ * attree.ads: Add new access-to-subprogram type Rewrite_Proc.
+ (Set_Rewriting_Proc): New routine.
+ * checks.adb (Install_Primitive_Elaboration_Check): Use 'E' character
+ for *E*laboration flag to maintain consistency with other elaboration
+ flag generating subprograms.
+ * debug.adb: Document the new usage of flag -gnatdL.
+ * einfo.adb: Node19 is now used as Receiving_Entry. Node39 is now used
+ as Protected_Subprogram. Flag148 is now used as
+ Is_Elaboration_Checks_OK_Id. Flag302 is now used as
+ Is_Initial_Condition_Procedure.
+ (Is_Elaboration_Checks_OK_Id): New routine.
+ (Is_Initial_Condition_Procedure): New routine.
+ (Protected_Subprogram): New routine.
+ (Receiving_Entry): New routine.
+ (SPARK_Pragma): Update assertion.
+ (SPARK_Pragma_Inherited): Update assertion.
+ (Suppress_Elaboration_Warnings): Removed.
+ (Set_Is_Elaboration_Checks_OK_Id): New routine.
+ (Set_Is_Initial_Condition_Procedure): New routine.
+ (Set_Protected_Subprogram): New routine.
+ (Set_Receiving_Entry): New routine.
+ (Set_SPARK_Pragma): Update assertion.
+ (Set_SPARK_Pragma_Inherited): Update assertion.
+ (Write_Entity_Flags): Update the output for Flag148 and Flag302.
+ (Write_Field19_Name): Add output for Receiving_Entry.
+ (Write_Field39_Name): Add output for Protected_Subprogram.
+ (Write_Field40_Name): Update the output for SPARK_Pragma.
+ * einfo.ads: New attributes Is_Elaboration_Checks_OK_Id,
+ Is_Initial_Condition_Procedure, Protected_Subprogram, Receiving_Entry.
+ Remove attribute Suppress_Elaboration_Warnings. Update the stricture
+ of various entities.
+ (Is_Elaboration_Checks_OK_Id): New routine along with pragma Inline.
+ (Is_Initial_Condition_Procedure): New routine along with pragma Inline.
+ (Protected_Subprogram): New routine along with pragma Inline.
+ (Receiving_Entry): New routine along with pragma Inline.
+ (Suppress_Elaboration_Warnings): Removed.
+ (Set_Is_Elaboration_Checks_OK_Id): New routine along with pragma
+ Inline.
+ (Set_Is_Initial_Condition_Procedure): New routine along with pragma
+ Inline.
+ (Set_Protected_Subprogram): New routine along with pragma Inline.
+ (Set_Receiving_Entry): New routine along with pragma Inline.
+ (Set_Suppress_Elaboration_Warnings): Removed.
+ * exp_ch3.adb (Build_Init_Procedure): Use name _Finalizer to maintain
+ consistency with other finalizer generating subprograms.
+ (Default_Initialize_Object): Mark the block which wraps the call to
+ finalize as being part of initialization.
+ * exp_ch7.adb (Expand_N_Package_Declaration): Directly expand pragma
+ Initial_Condition.
+ (Expand_N_Package_Body): Directly expand pragma Initial_Condition.
+ (Next_Suitable_Statement): Update the comment on usage. Skip over call
+ markers generated by the ABE mechanism.
+ * exp_ch9.adb (Activation_Call_Loc): New routine.
+ (Add_Accept): Link the accept procedure to the original entry.
+ (Build_Protected_Sub_Specification): Link the protected or unprotected
+ version to the original subprogram.
+ (Build_Task_Activation_Call): Code cleanup. Use a source location which
+ is very close to the "begin" or "end" keywords when generating the
+ activation call.
+ * exp_prag.adb (Expand_Pragma_Initial_Condition): Reimplemented.
+ * exp_spark.adb (Expand_SPARK): Use Expand_SPARK_N_Loop_Statement to
+ process loops.
+ (Expand_SPARK_N_Loop_Statement): New routine.
+ (Expand_SPARK_N_Object_Declaration): Code cleanup. Partially insert the
+ call to the Default_Initial_Condition procedure.
+ (Expand_SPARK_Op_Ne): Renamed to Expand_SPARK_N_Op_Ne.
+ * exp_util.adb (Build_DIC_Procedure_Body): Capture the SPARK_Mode in
+ effect.
+ (Build_DIC_Procedure_Declaration): Capture the SPARK_Mode in effect.
+ (Insert_Actions): Add processing for N_Call_Marker.
+ (Kill_Dead_Code): Explicitly kill an elaboration scenario.
+ * exp_util.ads (Make_Invariant_Call): Update the comment on usage.
+ * frontend.adb: Initialize Sem_Elab. Process all saved top level
+ elaboration scenarios for ABE issues.
+ * gcc-interface/trans.c (gnat_to_gnu): Add processing for N_Call_Marker
+ nodes.
+ * lib.adb (Earlier_In_Extended_Unit): New variant.
+ * sem.adb (Analyze): Ignore N_Call_Marker nodes.
+ (Preanalysis_Active): New routine.
+ * sem.ads (Preanalysis_Active): New routine.
+ * sem_attr.adb (Analyze_Access_Attribute): Save certain
+ elaboration-related attributes. Save the scenario for ABE processing.
+ * sem_ch3.adb (Analyze_Object_Declaration): Save the SPARK mode in
+ effect. Save certain elaboration-related attributes.
+ * sem_ch5.adb (Analyze_Assignment): Save certain elaboration-related
+ attributes. Save the scenario for ABE processing.
+ * sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): Save the SPARK
+ mode in effect. Save certain elaboration-related attributes.
+ (Analyze_Subprogram_Body_Helper): Skip N_Call_Marker nodes when
+ locating the first real statement.
+ (Analyze_Subprogram_Declaration): Save the SPARK mode in effect. Save
+ certain elaboration-related attributes.
+ * sem_ch7.adb (Analyze_Package_Declaration): Do not suppress
+ elaboration warnings.
+ * sem_ch8.adb (Attribute_Renaming): Mark a subprogram body which was
+ generated for purposes of wrapping an attribute used as a generic
+ actual.
+ (Find_Direct_Name): Save certain elaboration-related attributes. Save
+ the scenario for ABE processing.
+ (Find_Expanded_Name): Save certain elaboration-related attributes. Save
+ the scenario for ABE processing.
+ * sem_ch9.adb (Analyze_Entry_Declaration): Save certain
+ elaboration-related attributes.
+ (Analyze_Requeue): Save certain elaboration-related attributes. Save
+ the scenario for ABE processing.
+ (Analyze_Single_Task_Declaration): Save certain elaboration-related
+ attributes.
+ (Analyze_Task_Type_Declaration): Save certain elaboration-related
+ attributes.
+ * sem_ch12.adb (Analyze_Generic_Package_Declaration): Save certain
+ elaboration-related attributes.
+ (Analyze_Generic_Subprogram_Declaration): Save the SPARK mode in
+ effect. Save certain elaboration-related attributes.
+ (Analyze_Package_Instantiation): Save certain elaboration-related
+ attributes. Save the scenario for ABE processing. Create completing
+ bodies in case the instantiation results in a guaranteed ABE.
+ (Analyze_Subprogram_Instantiation): Save certain elaboration-related
+ attributes Save the scenario for ABE processing. Create a completing
+ body in case the instantiation results in a guaranteed ABE.
+ (Provide_Completing_Bodies): New routine.
+ * sem_elab.ads: Brand new implementation.
+ * sem_prag.adb (Analyze_Pragma, cases Elaborate, Elaborate_All,
+ Elaborate_Body): Do not suppress elaboration warnings.
+ * sem_res.adb (Make_Call_Into_Operator): Set the parent field of the
+ operator.
+ (Resolve_Call): Save certain elaboration-related attributes. Save the
+ scenario for ABE processing.
+ (Resolve_Entity_Name): Do not perform any ABE processing here.
+ (Resolve_Entry_Call): Inherit certain attributes from the original call.
+ * sem_util.adb (Begin_Keyword_Location): New routine.
+ (Defining_Entity): Update the parameter profile. Add processing for
+ concurrent subunits that are rewritten as null statements.
+ (End_Keyword_Location): New routine.
+ (Find_Enclosing_Scope): New routine.
+ (In_Instance_Visible_Part): Code cleanup.
+ (In_Subtree): Update the parameter profile. Add new version.
+ (Is_Preelaborable_Aggregate): New routine.
+ (Is_Preelaborable_Construct): New routine.
+ (Mark_Elaboration_Attributes): New routine.
+ (Scope_Within): Update the parameter profile.
+ (Scope_Within_Or_Same): Update the parameter profile.
+ * sem_util.ads (Begin_Keyword_Location): New routine.
+ (Defining_Entity): Update the parameter profile and the comment on
+ usage.
+ (End_Keyword_Location): New routine.
+ (Find_Enclosing_Scope): New routine.
+ (In_Instance_Visible_Part): Update the parameter profile.
+ (In_Subtree): Update the parameter profile. Add new version.
+ (Is_Preelaborable_Aggregate): New routine.
+ (Is_Preelaborable_Construct): New routine.
+ (Mark_Elaboration_Attributes): New routine.
+ (Scope_Within): Update the parameter profile and the comment on usage.
+ (Scope_Within_Or_Same): Update the parameter profile and the comment on
+ usage.
+ * sem_warn.adb (Check_Infinite_Loop_Warning): Use Has_Condition_Actions
+ to determine whether a loop has meaningful condition actions.
+ (Has_Condition_Actions): New routine.
+ * sinfo.adb (ABE_Is_Certain): Removed.
+ (Is_Declaration_Level_Node): New routine.
+ (Is_Dispatching_Call): New routine.
+ (Is_Elaboration_Checks_OK_Node): New routine.
+ (Is_Initialization_Block): New routine.
+ (Is_Known_Guaranteed_ABE): New routine.
+ (Is_Recorded_Scenario): New routine.
+ (Is_Source_Call): New routine.
+ (Is_SPARK_Mode_On_Node): New routine.
+ (No_Elaboration_Check): Removed.
+ (Target): New routine.
+ (Was_Attribute_Reference): New routine.
+ (Set_ABE_Is_Certain): Removed.
+ (Set_Is_Declaration_Level_Node): New routine.
+ (Set_Is_Dispatching_Call): New routine.
+ (Set_Is_Elaboration_Checks_OK_Node): New routine.
+ (Set_Is_Initialization_Block): New routine.
+ (Set_Is_Known_Guaranteed_ABE): New routine.
+ (Set_Is_Recorded_Scenario): New routine.
+ (Set_Is_Source_Call): New routine.
+ (Set_Is_SPARK_Mode_On_Node): New routine.
+ (Set_No_Elaboration_Check): Removed.
+ (Set_Target): New routine.
+ (Set_Was_Attribute_Reference): New routine.
+ * sinfo.ads: Remove attribute ABE_Is_Certain. Attribute
+ Do_Discriminant_Check now utilizes Flag3. Attribute
+ No_Side_Effect_Removal now utilizes Flag17. Add new node
+ N_Call_Marker. Update the structure of various nodes.
+ (ABE_Is_Certain): Removed along with pragma Inline.
+ (Is_Declaration_Level_Node): New routine along with pragma Inline.
+ (Is_Dispatching_Call): New routine along with pragma Inline.
+ (Is_Elaboration_Checks_OK_Node): New routine along with pragma Inline.
+ (Is_Initialization_Block): New routine along with pragma Inline.
+ (Is_Known_Guaranteed_ABE): New routine along with pragma Inline.
+ (Is_Recorded_Scenario): New routine along with pragma Inline.
+ (Is_Source_Call): New routine along with pragma Inline.
+ (Is_SPARK_Mode_On_Node): New routine along with pragma Inline.
+ (No_Elaboration_Check): Removed along with pragma Inline.
+ (Target): New routine along with pragma Inline.
+ (Was_Attribute_Reference): New routine along with pragma Inline.
+ (Set_ABE_Is_Certain): Removed along with pragma Inline.
+ (Set_Is_Declaration_Level_Node): New routine along with pragma Inline.
+ (Set_Is_Dispatching_Call): New routine along with pragma Inline.
+ (Set_Is_Elaboration_Checks_OK_Node): New routine along with pragma
+ Inline.
+ (Set_Is_Initialization_Block): New routine along with pragma Inline.
+ (Set_Is_Known_Guaranteed_ABE): New routine along with pragma Inline.
+ (Set_Is_Recorded_Scenario): New routine along with pragma Inline.
+ (Set_Is_Source_Call): New routine along with pragma Inline.
+ (Set_Is_SPARK_Mode_On_Node): New routine along with pragma Inline.
+ (Set_No_Elaboration_Check): Removed along with pragma Inline.
+ (Set_Target): New routine along with pragma Inline.
+ (Set_Was_Attribute_Reference): New routine along with pragma Inline.
+ * sprint.adb (Sprint_Node_Actual): Add an entry for N_Call_Marker.
+
2017-10-09 Bob Duff <duff@adacore.com>
* exp_ch7.adb (Create_Finalizer): Suppress checks within the finalizer.
Reporting_Proc : Report_Proc := null;
-- Record argument to last call to Set_Reporting_Proc
+ Rewriting_Proc : Rewrite_Proc := null;
+ -- This soft link captures the procedure invoked during a node rewrite
+
---------------
-- Debugging --
---------------
Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6, V7, V8, V9, V10, V11);
end Ekind_In;
- ------------------------
- -- Set_Reporting_Proc --
- ------------------------
-
- procedure Set_Reporting_Proc (P : Report_Proc) is
- begin
- pragma Assert (Reporting_Proc = null);
- Reporting_Proc := P;
- end Set_Reporting_Proc;
-
------------------
-- Error_Posted --
------------------
if Reporting_Proc /= null then
Reporting_Proc.all (Target => Old_Node, Source => New_Node);
end if;
+
+ -- Invoke the rewriting procedure (if available)
+
+ if Rewriting_Proc /= null then
+ Rewriting_Proc.all (Target => Old_Node, Source => New_Node);
+ end if;
end Rewrite;
------------------
Nodes.Table (N).Link := Union_Id (Val);
end Set_Parent;
+ ------------------------
+ -- Set_Reporting_Proc --
+ ------------------------
+
+ procedure Set_Reporting_Proc (Proc : Report_Proc) is
+ begin
+ pragma Assert (Reporting_Proc = null);
+ Reporting_Proc := Proc;
+ end Set_Reporting_Proc;
+
--------------
-- Set_Sloc --
--------------
Nodes.Table (N).Sloc := Val;
end Set_Sloc;
+ ------------------------
+ -- Set_Rewriting_Proc --
+ ------------------------
+
+ procedure Set_Rewriting_Proc (Proc : Rewrite_Proc) is
+ begin
+ pragma Assert (Rewriting_Proc = null);
+ Rewriting_Proc := Proc;
+ end Set_Rewriting_Proc;
+
----------
-- Sloc --
----------
type Report_Proc is access procedure (Target : Node_Id; Source : Node_Id);
- procedure Set_Reporting_Proc (P : Report_Proc);
+ procedure Set_Reporting_Proc (Proc : Report_Proc);
-- Register a procedure that is invoked when a node is allocated, replaced
-- or rewritten.
+ type Rewrite_Proc is access procedure (Target : Node_Id; Source : Node_Id);
+
+ procedure Set_Rewriting_Proc (Proc : Rewrite_Proc);
+ -- Register a procedure that is invoked when a node is rewritten
+
type Traverse_Result is (Abandon, OK, OK_Orig, Skip);
-- This is the type of the result returned by the Process function passed
-- to Traverse_Func and Traverse_Proc. See below for details.
-- for extending components are completely unused.
type Flags_Byte is record
- Flag0 : Boolean;
+ Flag0 : Boolean;
-- Note: we don't use Flag0 at the moment. To put Flag0 into use
-- requires some awkward work in Treeprs (treeprs.adt), so for the
-- moment we don't use it.
- Flag1 : Boolean;
- Flag2 : Boolean;
- Flag3 : Boolean;
+ Flag1 : Boolean;
+ Flag2 : Boolean;
+ Flag3 : Boolean;
-- These flags are used in the usual manner in Sinfo and Einfo
- Is_Ignored_Ghost_Node : Boolean;
- -- Flag denoting whether the node is subject to pragma Ghost with
- -- policy Ignore. The name of the flag should be Flag4, however this
- -- requires changing the names of all remaining 300+ flags.
+ -- The flags listed below use explicit names because following the
+ -- FlagXXX convention would mean reshuffling of over 300+ flags.
Check_Actuals : Boolean;
-- Flag set to indicate that the marked node is subject to the check
- -- for writable actuals. See xxx for more details. Again it would be
- -- more uniform to use some Flagx here, but that would be disruptive.
+ -- for writable actuals.
+
+ Is_Ignored_Ghost_Node : Boolean;
+ -- Flag denoting whether the node is subject to pragma Ghost with
+ -- policy Ignore.
Spare2 : Boolean;
Spare3 : Boolean;
elsif Checks_May_Be_Suppressed (E) then
if Is_Check_Suppressed (E, Elaboration_Check) then
return True;
+
elsif Dynamic_Elaboration_Checks then
return Is_Check_Suppressed (E, All_Checks);
+
else
return False;
end if;
if Scope_Suppress.Suppress (Elaboration_Check) then
return True;
+
elsif Dynamic_Elaboration_Checks then
return Scope_Suppress.Suppress (All_Checks);
+
else
return False;
end if;
Flag_Id :=
Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Subp_Id), 'F', -1));
+ Chars => New_External_Name (Chars (Subp_Id), 'E', -1));
Set_Is_Frozen (Flag_Id);
-- Insert the declaration of the elaboration flag in front of the
Push_Scope (Scope (Subp_Id));
-- Generate:
- -- F : Boolean := False;
+ -- E : Boolean := False;
Insert_Action (Subp_Decl,
Make_Object_Declaration (Loc,
end if;
-- Generate:
- -- F := True;
+ -- E := True;
Insert_After_And_Analyze (Set_Ins,
Make_Assignment_Statement (Loc,
-- since it clearly was not overridden at any point). For a predefined
-- check, we test the specific flag. For a user defined check, we check
-- the All_Checks flag. The Overflow flag requires special handling to
- -- deal with the General vs Assertion case
+ -- deal with the General vs Assertion case.
if C = Overflow_Check then
return Overflow_Checks_Suppressed (Empty);
+
elsif C in Predefined_Check_Id then
return Scope_Suppress.Suppress (C);
+
else
return Scope_Suppress.Suppress (All_Checks);
end if;
-- dI Inhibit internal name numbering in gnatG listing
-- dJ Prepend subprogram name in messages
-- dK Kill all error messages
- -- dL Output trace information on elaboration checking
+ -- dL Ignore external calls from instances for elaboration
-- dM Assume all variables are modified (no current values)
-- dN No file name information in exception messages
-- dO Output immediate error messages
-- of all error messages. It is used in regression tests where the
-- error messages are target dependent and irrelevant.
- -- dL Output trace information on elaboration checking. This debug
- -- switch causes output to be generated showing each call or
- -- instantiation as it is checked, and the progress of the recursive
- -- trace through elaboration calls at compile time.
+ -- dL The compiler ignores calls in instances and invoke subprograms
+ -- which are external to the instance for the static elaboration
+ -- model. This switch is orthogonal to d.G.
-- dM Assume all variables have been modified, and ignore current value
-- indications. This debug flag disconnects the tracking of constant
-- d.G Previously the compiler ignored calls via generic formal parameters
-- when doing the analysis for the static elaboration model. This is
-- now fixed, but we provide this debug flag to revert to the previous
- -- situation of ignoring such calls to aid in transition.
+ -- situation of ignoring such calls to aid in transition. This switch
+ -- is orthogonal to dL.
-- d.H Sets ASIS_GNSA_Mode to True. This signals the front end to suppress
-- the call to gigi in ASIS_Mode.
.. index:: Order of elaboration
.. index:: Elaboration control
-This appendix describes the handling of elaboration code in Ada and
-in GNAT, and discusses how the order of elaboration of program units can
-be controlled in GNAT, either automatically or with explicit programming
-features.
+This appendix describes the handling of elaboration code in Ada and GNAT, and
+discusses how the order of elaboration of program units can be controlled in
+GNAT, either automatically or with explicit programming features.
.. _Elaboration_Code:
Elaboration Code
================
-Ada provides rather general mechanisms for executing code at elaboration
-time, that is to say before the main program starts executing. Such code arises
-in three contexts:
+Ada defines the term *execution* as the process by which a construct achieves
+its run-time effect. This process is also referred to as **elaboration** for
+declarations and *evaluation* for expressions.
-* *Initializers for variables*
+The execution model in Ada allows for certain sections of an Ada program to be
+executed prior to execution of the program itself, primarily with the intent of
+initializing data. These sections are referred to as **elaboration code**.
+Elaboration code is executed as follows:
- Variables declared at the library level, in package specs or bodies, can
- require initialization that is performed at elaboration time, as in:
+* All partitions of an Ada program are executed in parallel with one another,
+ possibly in a separate address space, and possibly on a separate computer.
- .. code-block:: ada
+* The execution of a partition involves running the environment task for that
+ partition.
- Sqrt_Half : Float := Sqrt (0.5);
+* The environment task executes all elaboration code (if available) for all
+ units within that partition. This code is said to be executed at
+ **elaboration time**.
-* *Package initialization code*
+* The environment task executes the Ada program (if available) for that
+ partition.
- Code in a ``begin`` ... `` end`` section at the outer level of a package body is
- executed as part of the package body elaboration code.
+In addition to the Ada terminology, this appendix defines the following terms:
-* *Library level task allocators*
+* *Scenario*
- Tasks that are declared using task allocators at the library level
- start executing immediately and hence can execute at elaboration time.
+ A construct that is elaborated or executed by elaboration code is referred to
+ as an *elaboration scenario* or simply a **scenario**. GNAT recognizes the
+ following scenarios:
-Subprogram calls are possible in any of these contexts, which means that
-any arbitrary part of the program may be executed as part of the elaboration
-code. It is even possible to write a program which does all its work at
-elaboration time, with a null main program, although stylistically this
-would usually be considered an inappropriate way to structure
-a program.
+ - ``'Access`` of entries, operators, and subprograms
-An important concern arises in the context of elaboration code:
-we have to be sure that it is executed in an appropriate order. What we
-have is a series of elaboration code sections, potentially one section
-for each unit in the program. It is important that these execute
-in the correct order. Correctness here means that, taking the above
-example of the declaration of ``Sqrt_Half``,
-if some other piece of
-elaboration code references ``Sqrt_Half``,
-then it must run after the
-section of elaboration code that contains the declaration of
-``Sqrt_Half``.
+ - Activation of tasks
-There would never be any order of elaboration problem if we made a rule
-that whenever you |with| a unit, you must elaborate both the spec and body
-of that unit before elaborating the unit doing the |withing|:
+ - Calls to entries, operators, and subprograms
-.. code-block:: ada
+ - Instantiations of generic templates
- with Unit_1;
- package Unit_2 is ...
+* *Target*
-would require that both the body and spec of ``Unit_1`` be elaborated
-before the spec of ``Unit_2``. However, a rule like that would be far too
-restrictive. In particular, it would make it impossible to have routines
-in separate packages that were mutually recursive.
+ A construct elaborated by a scenario is referred to as *elaboration target*
+ or simply **target**. GNAT recognizes the following targets:
-You might think that a clever enough compiler could look at the actual
-elaboration code and determine an appropriate correct order of elaboration,
-but in the general case, this is not possible. Consider the following
-example.
+ - For ``'Access`` of entries, operators, and subprograms, the target is the
+ entry, operator, or subprogram being aliased.
-In the body of ``Unit_1``, we have a procedure ``Func_1``
-that references
-the variable ``Sqrt_1``, which is declared in the elaboration code
-of the body of ``Unit_1``:
+ - For activation of tasks, the target is the task body
-.. code-block:: ada
+ - For calls to entries, operators, and subprograms, the target is the entry,
+ operator, or subprogram being invoked.
- Sqrt_1 : Float := Sqrt (0.1);
+ - For instantiations of generic templates, the target is the generic template
+ being instantiated.
-The elaboration code of the body of ``Unit_1`` also contains:
+Elaboration code may appear in two distinct contexts:
-.. code-block:: ada
+* *Library level*
- if expression_1 = 1 then
- Q := Unit_2.Func_2;
- end if;
+ A scenario appears at the library level when it is encapsulated by a package
+ [body] compilation unit, ignoring any other package [body] declarations in
+ between.
-``Unit_2`` is exactly parallel,
-it has a procedure ``Func_2`` that references
-the variable ``Sqrt_2``, which is declared in the elaboration code of
-the body ``Unit_2``:
+ ::
-.. code-block:: ada
+ with Server;
+ package Client is
+ procedure Proc;
- Sqrt_2 : Float := Sqrt (0.1);
+ package Nested is
+ Val : ... := Server.Func;
+ end Nested;
+ end Client;
-The elaboration code of the body of ``Unit_2`` also contains:
+ In the example above, the call to ``Server.Func`` is an elaboration scenario
+ because it appears at the library level of package ``Client``. Note that the
+ declaration of package ``Nested`` is ignored according to the definition
+ given above. As a result, the call to ``Server.Func`` will be executed when
+ the spec of unit ``Client`` is elaborated.
-.. code-block:: ada
+* *Package body statements*
- if expression_2 = 2 then
- Q := Unit_1.Func_1;
- end if;
+ A scenario appears within the statement sequence of a package body when it is
+ bounded by the region starting from the ``begin`` keyword of the package body
+ and ending at the ``end`` keyword of the package body.
-Now the question is, which of the following orders of elaboration is
-acceptable:
+ ::
+
+ package body Client is
+ procedure Proc is
+ begin
+ ...
+ end Proc;
+ begin
+ Proc;
+ end Client;
+
+ In the example above, the call to ``Proc`` is an elaboration scenario because
+ it appears within the statement sequence of package body ``Client``. As a
+ result, the call to ``Proc`` will be executed when the body of ``Client`` is
+ elaborated.
+
+.. _Elaboration_Order:
+
+Elaboration Order
+=================
+
+The sequence by which the elaboration code of all units within a partition is
+executed is referred to as **elaboration order**. The elaboration order depends
+on the following factors:
+
+* |withed| units
+
+* purity of units
+
+* preelaborability of units
+
+* presence of elaboration control pragmas
+
+A program may have several elaboration orders depending on its structure.
+
+::
+
+ package Server is
+ function Func (Index : Integer) return Integer;
+ end Server;
+
+::
+
+ package body Server is
+ Results : array (1 .. 5) of Integer := (1, 2, 3, 4, 5);
+
+ function Func (Index : Integer) return Integer is
+ begin
+ return Results (Index);
+ end Func;
+ end Server;
+
+::
+
+ with Server;
+ package Client is
+ Val : constant Integer := Server.Func (3);
+ end Client;
::
- Spec of Unit_1
- Spec of Unit_2
- Body of Unit_1
- Body of Unit_2
+ with Client;
+ procedure Main is begin null; end Main;
-or
+The following elaboration order exhibits a fundamental problem referred to as
+*access-before-elaboration* or simply **ABE**.
::
- Spec of Unit_2
- Spec of Unit_1
- Body of Unit_2
- Body of Unit_1
-
-If you carefully analyze the flow here, you will see that you cannot tell
-at compile time the answer to this question.
-If ``expression_1`` is not equal to 1,
-and ``expression_2`` is not equal to 2,
-then either order is acceptable, because neither of the function calls is
-executed. If both tests evaluate to true, then neither order is acceptable
-and in fact there is no correct order.
-
-If one of the two expressions is true, and the other is false, then one
-of the above orders is correct, and the other is incorrect. For example,
-if ``expression_1`` /= 1 and ``expression_2`` = 2,
-then the call to ``Func_1``
-will occur, but not the call to ``Func_2.``
-This means that it is essential
-to elaborate the body of ``Unit_1`` before
-the body of ``Unit_2``, so the first
-order of elaboration is correct and the second is wrong.
-
-By making ``expression_1`` and ``expression_2``
-depend on input data, or perhaps
-the time of day, we can make it impossible for the compiler or binder
-to figure out which of these expressions will be true, and hence it
-is impossible to guarantee a safe order of elaboration at run time.
+ spec of Server
+ spec of Client
+ body of Server
+ body of Main
+
+The elaboration of ``Server``'s spec materializes function ``Func``, making it
+callable. The elaboration of ``Client``'s spec elaborates the declaration of
+``Val``. This invokes function ``Server.Func``, however the body of
+``Server.Func`` has not been elaborated yet because ``Server``'s body comes
+after ``Client``'s spec in the elaboration order. As a result, the value of
+constant ``Val`` is now undefined.
+
+Without any guarantees from the language, an undetected ABE problem may hinder
+proper initialization of data, which in turn may lead to undefined behavior at
+run time. To prevent such ABE problems, Ada employs dynamic checks in the same
+vein as index or null exclusion checks. A failed ABE check raises exception
+``Program_Error``.
+
+The following elaboration order avoids the ABE problem and the program can be
+successfully elaborated.
+
+::
+
+ spec of Server
+ body of Server
+ spec of Client
+ body of Main
+
+Ada states that a total elaboration order must exist, but it does not define
+what this order is. A compiler is thus tasked with choosing a suitable
+elaboration order which satisfies the dependencies imposed by |with| clauses,
+unit categorization, and elaboration control pragmas. Ideally an order which
+avoids ABE problems should be chosen, however a compiler may not always find
+such an order due to complications with respect to control and data flow.
.. _Checking_the_Elaboration_Order:
Checking the Elaboration Order
==============================
-In some languages that involve the same kind of elaboration problems,
-e.g., Java and C++, the programmer needs to take these
-ordering problems into account, and it is common to
-write a program in which an incorrect elaboration order gives
-surprising results, because it references variables before they
-are initialized.
-Ada is designed to be a safe language, and a programmer-beware approach is
-clearly not sufficient. Consequently, the language provides three lines
-of defense:
+To avoid placing the entire elaboration order burden on the programmer, Ada
+provides three lines of defense:
+
+* *Static semantics*
+
+ Static semantic rules restrict the possible choice of elaboration order. For
+ instance, if unit Client |withs| unit Server, then the spec of Server is
+ always elaborated prior to Client. The same principle applies to child units
+ - the spec of a parent unit is always elaborated prior to the child unit.
+
+* *Dynamic semantics*
-* *Standard rules*
+ Dynamic checks are performed at run time, to ensure that a target is
+ elaborated prior to a scenario that executes it, thus avoiding ABE problems.
+ A failed run-time check raises exception ``Program_Error``. The following
+ restrictions apply:
- Some standard rules restrict the possible choice of elaboration
- order. In particular, if you |with| a unit, then its spec is always
- elaborated before the unit doing the |with|. Similarly, a parent
- spec is always elaborated before the child spec, and finally
- a spec is always elaborated before its corresponding body.
+ - *Restrictions on calls*
-.. index:: Elaboration checks
-.. index:: Checks, elaboration
+ An entry, operator, or subprogram can be called from elaboration code only
+ when the corresponding body has been elaborated.
-* *Dynamic elaboration checks*
+ - *Restrictions on instantiations*
- Dynamic checks are made at run time, so that if some entity is accessed
- before it is elaborated (typically by means of a subprogram call)
- then the exception (``Program_Error``) is raised.
+ A generic unit can be instantiated by elaboration code only when the
+ corresponding body has been elaborated.
+
+ - *Restrictions on task activation*
+
+ A task can be activated by elaboration code only when the body of the
+ associated task type has been elaborated.
+
+ The restrictions above can be summarized by the following rule:
+
+ *If a target has a body, then this body must be elaborated prior to the
+ execution of the scenario that invokes, instantiates, or activates the
+ target.*
* *Elaboration control*
- Facilities are provided for the programmer to specify the desired order
- of elaboration.
-
-Let's look at these facilities in more detail. First, the rules for
-dynamic checking. One possible rule would be simply to say that the
-exception is raised if you access a variable which has not yet been
-elaborated. The trouble with this approach is that it could require
-expensive checks on every variable reference. Instead Ada has two
-rules which are a little more restrictive, but easier to check, and
-easier to state:
-
-* *Restrictions on calls*
-
- A subprogram can only be called at elaboration time if its body
- has been elaborated. The rules for elaboration given above guarantee
- that the spec of the subprogram has been elaborated before the
- call, but not the body. If this rule is violated, then the
- exception ``Program_Error`` is raised.
-
-* *Restrictions on instantiations*
-
- A generic unit can only be instantiated if the body of the generic
- unit has been elaborated. Again, the rules for elaboration given above
- guarantee that the spec of the generic unit has been elaborated
- before the instantiation, but not the body. If this rule is
- violated, then the exception ``Program_Error`` is raised.
-
-The idea is that if the body has been elaborated, then any variables
-it references must have been elaborated; by checking for the body being
-elaborated we guarantee that none of its references causes any
-trouble. As we noted above, this is a little too restrictive, because a
-subprogram that has no non-local references in its body may in fact be safe
-to call. However, it really would be unsafe to rely on this, because
-it would mean that the caller was aware of details of the implementation
-in the body. This goes against the basic tenets of Ada.
-
-A plausible implementation can be described as follows.
-A Boolean variable is associated with each subprogram
-and each generic unit. This variable is initialized to False, and is set to
-True at the point body is elaborated. Every call or instantiation checks the
-variable, and raises ``Program_Error`` if the variable is False.
-
-Note that one might think that it would be good enough to have one Boolean
-variable for each package, but that would not deal with cases of trying
-to call a body in the same package as the call
-that has not been elaborated yet.
-Of course a compiler may be able to do enough analysis to optimize away
-some of the Boolean variables as unnecessary, and GNAT indeed
-does such optimizations, but still the easiest conceptual model is to
-think of there being one variable per subprogram.
-
-.. _Controlling_the_Elaboration_Order:
-
-Controlling the Elaboration Order
-=================================
+ Pragmas are provided for the programmer to specify the desired elaboration
+ order.
-In the previous section we discussed the rules in Ada which ensure
-that ``Program_Error`` is raised if an incorrect elaboration order is
-chosen. This prevents erroneous executions, but we need mechanisms to
-specify a correct execution and avoid the exception altogether.
-To achieve this, Ada provides a number of features for controlling
-the order of elaboration. We discuss these features in this section.
+.. _Controlling_the_Elaboration_Order_in_Ada:
-First, there are several ways of indicating to the compiler that a given
-unit has no elaboration problems:
+Controlling the Elaboration Order in Ada
+========================================
-* *packages that do not require a body*
+Ada provides several idioms and pragmas to aid the programmer with specifying
+the desired elaboration order and avoiding ABE problems altogether.
- A library package that does not require a body does not permit
- a body (this rule was introduced in Ada 95).
- Thus if we have a such a package, as in:
+* *Packages without a body*
- .. code-block:: ada
+ A library package which does not require a completing body does not suffer
+ from ABE problems.
- package Definitions is
- generic
- type m is new integer;
- package Subp is
- type a is array (1 .. 10) of m;
- type b is array (1 .. 20) of m;
- end Subp;
- end Definitions;
+ ::
+
+ package Pack is
+ generic
+ type Element is private;
+ package Containers is
+ type Element_Array is array (1 .. 10) of Element;
+ end Containers;
+ end Pack;
- A package that |withs| ``Definitions`` may safely instantiate
- ``Definitions.Subp`` because the compiler can determine that there
- definitely is no package body to worry about in this case
+ In the example above, package ``Pack`` does not require a body because it
+ does not contain any constructs which require completion in a body. As a
+ result, generic ``Pack.Containers`` can be instantiated without encountering
+ any ABE problems.
.. index:: pragma Pure
* *pragma Pure*
- This pragma places sufficient restrictions on a unit to guarantee that
- no call to any subprogram in the unit can result in an
- elaboration problem. This means that the compiler does not need
- to worry about the point of elaboration of such units, and in
- particular, does not need to check any calls to any subprograms
- in this unit.
+ Pragma ``Pure`` places sufficient restrictions on a unit to guarantee that no
+ scenario within the unit can result in an ABE problem.
.. index:: pragma Preelaborate
* *pragma Preelaborate*
- This pragma places slightly less stringent restrictions on a unit than
- does pragma Pure,
- but these restrictions are still sufficient to ensure that there
- are no elaboration problems with any calls to the unit.
+ Pragma ``Preelaborate`` is slightly less restrictive than pragma ``Pure``,
+ but still strong enough to prevent ABE problems within a unit.
.. index:: pragma Elaborate_Body
* *pragma Elaborate_Body*
- This pragma requires that the body of a unit be elaborated immediately
- after its spec. Suppose a unit ``A`` has such a pragma,
- and unit ``B`` does
- a |with| of unit ``A``. Recall that the standard rules require
- the spec of unit ``A``
- to be elaborated before the |withing| unit; given the pragma in
- ``A``, we also know that the body of ``A``
- will be elaborated before ``B``, so
- that calls to ``A`` are safe and do not need a check.
-
- Note that, unlike pragma ``Pure`` and pragma ``Preelaborate``,
- the use of ``Elaborate_Body`` does not guarantee that the program is
- free of elaboration problems, because it may not be possible
- to satisfy the requested elaboration order.
- Let's go back to the example with ``Unit_1`` and ``Unit_2``.
- If a programmer marks ``Unit_1`` as ``Elaborate_Body``,
- and not ``Unit_2,`` then the order of
- elaboration will be::
-
- Spec of Unit_2
- Spec of Unit_1
- Body of Unit_1
- Body of Unit_2
-
- Now that means that the call to ``Func_1`` in ``Unit_2``
- need not be checked,
- it must be safe. But the call to ``Func_2`` in
- ``Unit_1`` may still fail if
- ``Expression_1`` is equal to 1,
- and the programmer must still take
- responsibility for this not being the case.
-
- If all units carry a pragma ``Elaborate_Body``, then all problems are
- eliminated, except for calls entirely within a body, which are
- in any case fully under programmer control. However, using the pragma
- everywhere is not always possible.
- In particular, for our ``Unit_1``/`Unit_2` example, if
- we marked both of them as having pragma ``Elaborate_Body``, then
- clearly there would be no possible elaboration order.
-
-The above pragmas allow a server to guarantee safe use by clients, and
-clearly this is the preferable approach. Consequently a good rule
-is to mark units as ``Pure`` or ``Preelaborate`` if possible,
-and if this is not possible,
-mark them as ``Elaborate_Body`` if possible.
-As we have seen, there are situations where neither of these
-three pragmas can be used.
-So we also provide methods for clients to control the
-order of elaboration of the servers on which they depend:
-
-.. index:: pragma Elaborate
-
-* *pragma Elaborate (unit)*
-
- This pragma is placed in the context clause, after a |with| clause,
- and it requires that the body of the named unit be elaborated before
- the unit in which the pragma occurs. The idea is to use this pragma
- if the current unit calls at elaboration time, directly or indirectly,
- some subprogram in the named unit.
-
-
-.. index:: pragma Elaborate_All
-
-* *pragma Elaborate_All (unit)*
-
- This is a stronger version of the Elaborate pragma. Consider the
- following example::
-
- Unit A |withs| unit B and calls B.Func in elab code
- Unit B |withs| unit C, and B.Func calls C.Func
-
-
- Now if we put a pragma ``Elaborate (B)``
- in unit ``A``, this ensures that the
- body of ``B`` is elaborated before the call, but not the
- body of ``C``, so
- the call to ``C.Func`` could still cause ``Program_Error`` to
- be raised.
-
- The effect of a pragma ``Elaborate_All`` is stronger, it requires
- not only that the body of the named unit be elaborated before the
- unit doing the |with|, but also the bodies of all units that the
- named unit uses, following |with| links transitively. For example,
- if we put a pragma ``Elaborate_All (B)`` in unit ``A``,
- then it requires not only that the body of ``B`` be elaborated before ``A``,
- but also the body of ``C``, because ``B`` |withs| ``C``.
-
-We are now in a position to give a usage rule in Ada for avoiding
-elaboration problems, at least if dynamic dispatching and access to
-subprogram values are not used. We will handle these cases separately
-later.
-
-The rule is simple:
-
-*If a unit has elaboration code that can directly or
-indirectly make a call to a subprogram in a |withed| unit, or instantiate
-a generic package in a |withed| unit,
-then if the |withed| unit does not have
-pragma ``Pure`` or ``Preelaborate``, then the client should have
-a pragma ``Elaborate_All``for the |withed| unit.**
-
-By following this rule a client is
-assured that calls can be made without risk of an exception.
-
-For generic subprogram instantiations, the rule can be relaxed to
-require only a pragma ``Elaborate`` since elaborating the body
-of a subprogram cannot cause any transitive elaboration (we are
-not calling the subprogram in this case, just elaborating its
-declaration).
-
-If this rule is not followed, then a program may be in one of four
-states:
-
-* *No order exists*
-
- No order of elaboration exists which follows the rules, taking into
- account any ``Elaborate``, ``Elaborate_All``,
- or ``Elaborate_Body`` pragmas. In
- this case, an Ada compiler must diagnose the situation at bind
- time, and refuse to build an executable program.
-
-* *One or more orders exist, all incorrect*
+ Pragma ``Elaborate_Body`` requires that the body of a unit is elaborated
+ immediately after its spec. This restriction guarantees that no client
+ scenario can execute a server target before the target body has been
+ elaborated because the spec and body are effectively "glued" together.
- One or more acceptable elaboration orders exist, and all of them
- generate an elaboration order problem. In this case, the binder
- can build an executable program, but ``Program_Error`` will be raised
- when the program is run.
+ ::
-* *Several orders exist, some right, some incorrect*
+ package Server is
+ pragma Elaborate_Body;
- One or more acceptable elaboration orders exists, and some of them
- work, and some do not. The programmer has not controlled
- the order of elaboration, so the binder may or may not pick one of
- the correct orders, and the program may or may not raise an
- exception when it is run. This is the worst case, because it means
- that the program may fail when moved to another compiler, or even
- another version of the same compiler.
+ function Func return Integer;
+ end Server;
-* *One or more orders exists, all correct*
+ ::
- One ore more acceptable elaboration orders exist, and all of them
- work. In this case the program runs successfully. This state of
- affairs can be guaranteed by following the rule we gave above, but
- may be true even if the rule is not followed.
+ package body Server is
+ function Func return Integer is
+ begin
+ ...
+ end Func;
+ end Server;
-Note that one additional advantage of following our rules on the use
-of ``Elaborate`` and ``Elaborate_All``
-is that the program continues to stay in the ideal (all orders OK) state
-even if maintenance
-changes some bodies of some units. Conversely, if a program that does
-not follow this rule happens to be safe at some point, this state of affairs
-may deteriorate silently as a result of maintenance changes.
+ ::
-You may have noticed that the above discussion did not mention
-the use of ``Elaborate_Body``. This was a deliberate omission. If you
-|with| an ``Elaborate_Body`` unit, it still may be the case that
-code in the body makes calls to some other unit, so it is still necessary
-to use ``Elaborate_All`` on such units.
+ with Server;
+ package Client is
+ Val : constant Integer := Server.Func;
+ end Client;
+ In the example above, pragma ``Elaborate_Body`` guarantees the following
+ elaboration order:
-.. _Controlling_Elaboration_in_GNAT_-_Internal_Calls:
+ ::
-Controlling Elaboration in GNAT - Internal Calls
-================================================
+ spec of Server
+ body of Server
+ spec of Client
-In the case of internal calls, i.e., calls within a single package, the
-programmer has full control over the order of elaboration, and it is up
-to the programmer to elaborate declarations in an appropriate order. For
-example writing:
+ because the spec of ``Server`` must be elaborated prior to ``Client`` by
+ virtue of the |with| clause, and in addition the body of ``Server`` must be
+ elaborated immediately after the spec of ``Server``.
-.. code-block:: ada
+ Removing pragma ``Elaborate_Body`` could result in the following incorrect
+ elaboration order:
- function One return Float;
-
- Q : Float := One;
+ ::
- function One return Float is
- begin
- return 1.0;
- end One;
-
-will obviously raise ``Program_Error`` at run time, because function
-One will be called before its body is elaborated. In this case GNAT will
-generate a warning that the call will raise ``Program_Error``::
-
- 1. procedure y is
- 2. function One return Float;
- 3.
- 4. Q : Float := One;
- |
- >>> warning: cannot call "One" before body is elaborated
- >>> warning: Program_Error will be raised at run time
-
- 5.
- 6. function One return Float is
- 7. begin
- 8. return 1.0;
- 9. end One;
- 10.
- 11. begin
- 12. null;
- 13. end;
-
-
-Note that in this particular case, it is likely that the call is safe, because
-the function ``One`` does not access any global variables.
-Nevertheless in Ada, we do not want the validity of the check to depend on
-the contents of the body (think about the separate compilation case), so this
-is still wrong, as we discussed in the previous sections.
-
-The error is easily corrected by rearranging the declarations so that the
-body of ``One`` appears before the declaration containing the call
-(note that in Ada 95 as well as later versions of the Ada standard,
-declarations can appear in any order, so there is no restriction that
-would prevent this reordering, and if we write:
-
-.. code-block:: ada
-
- function One return Float;
-
- function One return Float is
- begin
- return 1.0;
- end One;
-
- Q : Float := One;
-
-then all is well, no warning is generated, and no
-``Program_Error`` exception
-will be raised.
-Things are more complicated when a chain of subprograms is executed:
-
-.. code-block:: ada
-
- function A return Integer;
- function B return Integer;
- function C return Integer;
-
- function B return Integer is begin return A; end;
- function C return Integer is begin return B; end;
-
- X : Integer := C;
-
- function A return Integer is begin return 1; end;
-
-Now the call to ``C``
-at elaboration time in the declaration of ``X`` is correct, because
-the body of ``C`` is already elaborated,
-and the call to ``B`` within the body of
-``C`` is correct, but the call
-to ``A`` within the body of ``B`` is incorrect, because the body
-of ``A`` has not been elaborated, so ``Program_Error``
-will be raised on the call to ``A``.
-In this case GNAT will generate a
-warning that ``Program_Error`` may be
-raised at the point of the call. Let's look at the warning::
-
- 1. procedure x is
- 2. function A return Integer;
- 3. function B return Integer;
- 4. function C return Integer;
- 5.
- 6. function B return Integer is begin return A; end;
- |
- >>> warning: call to "A" before body is elaborated may
- raise Program_Error
- >>> warning: "B" called at line 7
- >>> warning: "C" called at line 9
-
- 7. function C return Integer is begin return B; end;
- 8.
- 9. X : Integer := C;
- 10.
- 11. function A return Integer is begin return 1; end;
- 12.
- 13. begin
- 14. null;
- 15. end;
-
-
-Note that the message here says 'may raise', instead of the direct case,
-where the message says 'will be raised'. That's because whether
-``A`` is
-actually called depends in general on run-time flow of control.
-For example, if the body of ``B`` said
-
-.. code-block:: ada
-
- function B return Integer is
- begin
- if some-condition-depending-on-input-data then
- return A;
- else
- return 1;
- end if;
- end B;
-
-then we could not know until run time whether the incorrect call to A would
-actually occur, so ``Program_Error`` might
-or might not be raised. It is possible for a compiler to
-do a better job of analyzing bodies, to
-determine whether or not ``Program_Error``
-might be raised, but it certainly
-couldn't do a perfect job (that would require solving the halting problem
-and is provably impossible), and because this is a warning anyway, it does
-not seem worth the effort to do the analysis. Cases in which it
-would be relevant are rare.
-
-In practice, warnings of either of the forms given
-above will usually correspond to
-real errors, and should be examined carefully and eliminated.
-In the rare case where a warning is bogus, it can be suppressed by any of
-the following methods:
-
-* Compile with the :switch:`-gnatws` switch set
-
-* Suppress ``Elaboration_Check`` for the called subprogram
-
-* Use pragma ``Warnings_Off`` to turn warnings off for the call
-
-For the internal elaboration check case,
-GNAT by default generates the
-necessary run-time checks to ensure
-that ``Program_Error`` is raised if any
-call fails an elaboration check. Of course this can only happen if a
-warning has been issued as described above. The use of pragma
-``Suppress (Elaboration_Check)`` may (but is not guaranteed to) suppress
-some of these checks, meaning that it may be possible (but is not
-guaranteed) for a program to be able to call a subprogram whose body
-is not yet elaborated, without raising a ``Program_Error`` exception.
-
-
-.. _Controlling_Elaboration_in_GNAT_-_External_Calls:
-
-Controlling Elaboration in GNAT - External Calls
-================================================
-
-The previous section discussed the case in which the execution of a
-particular thread of elaboration code occurred entirely within a
-single unit. This is the easy case to handle, because a programmer
-has direct and total control over the order of elaboration, and
-furthermore, checks need only be generated in cases which are rare
-and which the compiler can easily detect.
-The situation is more complex when separate compilation is taken into account.
-Consider the following:
-
-.. code-block:: ada
-
- package Math is
- function Sqrt (Arg : Float) return Float;
- end Math;
-
- package body Math is
- function Sqrt (Arg : Float) return Float is
- begin
- ...
- end Sqrt;
- end Math;
-
- with Math;
- package Stuff is
- X : Float := Math.Sqrt (0.5);
- end Stuff;
-
- with Stuff;
- procedure Main is
- begin
- ...
- end Main;
-
-where ``Main`` is the main program. When this program is executed, the
-elaboration code must first be executed, and one of the jobs of the
-binder is to determine the order in which the units of a program are
-to be elaborated. In this case we have four units: the spec and body
-of ``Math``,
-the spec of ``Stuff`` and the body of ``Main``).
-In what order should the four separate sections of elaboration code
-be executed?
-
-There are some restrictions in the order of elaboration that the binder
-can choose. In particular, if unit U has a |with|
-for a package ``X``, then you
-are assured that the spec of ``X``
-is elaborated before U , but you are
-not assured that the body of ``X``
-is elaborated before U.
-This means that in the above case, the binder is allowed to choose the
-order::
+ spec of Server
+ spec of Client
+ body of Server
+
+ where ``Client`` invokes ``Server.Func``, but the body of ``Server.Func`` has
+ not been elaborated yet.
+
+The pragmas outlined above allow a server unit to guarantee safe elaboration
+use by client units. Thus it is a good rule to mark units as ``Pure`` or
+``Preelaborate``, and if this is not possible, mark them as ``Elaborate_Body``.
+
+There are however situations where ``Pure``, ``Preelaborate``, and
+``Elaborate_Body`` are not applicable. Ada provides another set of pragmas for
+use by client units to help ensure the elaboration safety of server units they
+depend on.
+
+.. index:: pragma Elaborate (Unit)
+
+* *pragma Elaborate (Unit)*
+
+ Pragma ``Elaborate`` can be placed in the context clauses of a unit, after a
+ |with| clause. It guarantees that both the spec and body of its argument will
+ be elaborated prior to the unit with the pragma. Note that other unrelated
+ units may be elaborated in between the spec and the body.
+
+ ::
+
+ package Server is
+ function Func return Integer;
+ end Server;
+
+ ::
+
+ package body Server is
+ function Func return Integer is
+ begin
+ ...
+ end Func;
+ end Server;
+
+ ::
+
+ with Server;
+ pragma Elaborate (Server);
+ package Client is
+ Val : constant Integer := Server.Func;
+ end Client;
+
+ In the example above, pragma ``Elaborate`` guarantees the following
+ elaboration order:
+
+ ::
+
+ spec of Server
+ body of Server
+ spec of Client
+
+ Removing pragma ``Elaborate`` could result in the following incorrect
+ elaboration order:
+
+ ::
+
+ spec of Server
+ spec of Client
+ body of Server
+
+ where ``Client`` invokes ``Server.Func``, but the body of ``Server.Func``
+ has not been elaborated yet.
+
+.. index:: pragma Elaborate_All (Unit)
+
+* *pragma Elaborate_All (Unit)*
+
+ Pragma ``Elaborate_All`` is placed in the context clauses of a unit, after
+ a |with| clause. It guarantees that both the spec and body of its argument
+ will be elaborated prior to the unit with the pragma, as well as all units
+ |withed| by the spec and body of the argument, recursively. Note that other
+ unrelated units may be elaborated in between the spec and the body.
+
+ ::
+
+ package Math is
+ function Factorial (Val : Natural) return Natural;
+ end Math;
+
+ ::
+
+ package body Math is
+ function Factorial (Val : Natural) return Natural is
+ begin
+ ...;
+ end Factorial;
+ end Math;
+
+ ::
+
+ package Computer is
+ type Operation_Kind is (None, Op_Factorial);
+
+ function Compute
+ (Val : Natural;
+ Op : Operation_Kind) return Natural;
+ end Computer;
+
+ ::
+
+ with Math;
+ package body Computer is
+ function Compute
+ (Val : Natural;
+ Op : Operation_Kind) return Natural
+ is
+ if Op = Op_Factorial then
+ return Math.Factorial (Val);
+ end if;
+
+ return 0;
+ end Compute;
+ end Computer;
+
+ ::
+
+ with Computer;
+ pragma Elaborate_All (Computer);
+ package Client is
+ Val : constant Natural :=
+ Computer.Compute (123, Computer.Op_Factorial);
+ end Client;
+
+ In the example above, pragma ``Elaborate_All`` can result in the following
+ elaboration order:
+
+ ::
spec of Math
- spec of Stuff
body of Math
- body of Main
-
-but that's not good, because now the call to ``Math.Sqrt``
-that happens during
-the elaboration of the ``Stuff``
-spec happens before the body of ``Math.Sqrt`` is
-elaborated, and hence causes ``Program_Error`` exception to be raised.
-At first glance, one might say that the binder is misbehaving, because
-obviously you want to elaborate the body of something you |with| first, but
-that is not a general rule that can be followed in all cases. Consider
-
-.. code-block:: ada
-
- package X is ...
-
- package Y is ...
-
- with X;
- package body Y is ...
-
- with Y;
- package body X is ...
-
-This is a common arrangement, and, apart from the order of elaboration
-problems that might arise in connection with elaboration code, this works fine.
-A rule that says that you must first elaborate the body of anything you
-|with| cannot work in this case:
-the body of ``X`` |withs| ``Y``,
-which means you would have to
-elaborate the body of ``Y`` first, but that |withs| ``X``,
-which means
-you have to elaborate the body of ``X`` first, but ... and we have a
-loop that cannot be broken.
-
-It is true that the binder can in many cases guess an order of elaboration
-that is unlikely to cause a ``Program_Error``
-exception to be raised, and it tries to do so (in the
-above example of ``Math/Stuff/Spec``, the GNAT binder will
-by default
-elaborate the body of ``Math`` right after its spec, so all will be well).
-
-However, a program that blindly relies on the binder to be helpful can
-get into trouble, as we discussed in the previous sections, so GNAT
-provides a number of facilities for assisting the programmer in
-developing programs that are robust with respect to elaboration order.
-
-
-.. _Default_Behavior_in_GNAT_-_Ensuring_Safety:
-
-Default Behavior in GNAT - Ensuring Safety
-==========================================
-
-The default behavior in GNAT ensures elaboration safety. In its
-default mode GNAT implements the
-rule we previously described as the right approach. Let's restate it:
-
-*If a unit has elaboration code that can directly or indirectly make a
-call to a subprogram in a |withed| unit, or instantiate a generic
-package in a |withed| unit, then if the |withed| unit
-does not have pragma ``Pure`` or ``Preelaborate``, then the client should have an
-``Elaborate_All`` pragma for the |withed| unit.*
-
-*In the case of instantiating a generic subprogram, it is always
-sufficient to have only an ``Elaborate`` pragma for the
-|withed| unit.*
-
-By following this rule a client is assured that calls and instantiations
-can be made without risk of an exception.
-
-In this mode GNAT traces all calls that are potentially made from
-elaboration code, and puts in any missing implicit ``Elaborate``
-and ``Elaborate_All`` pragmas.
-The advantage of this approach is that no elaboration problems
-are possible if the binder can find an elaboration order that is
-consistent with these implicit ``Elaborate`` and
-``Elaborate_All`` pragmas. The
-disadvantage of this approach is that no such order may exist.
-
-If the binder does not generate any diagnostics, then it means that it has
-found an elaboration order that is guaranteed to be safe. However, the binder
-may still be relying on implicitly generated ``Elaborate`` and
-``Elaborate_All`` pragmas so portability to other compilers than GNAT is not
-guaranteed.
-
-If it is important to guarantee portability, then the compilations should
-use the :switch:`-gnatel`
-(info messages for elaboration pragmas) switch. This will cause info messages
-to be generated indicating the missing ``Elaborate`` and
-``Elaborate_All`` pragmas.
-Consider the following source program:
-
-.. code-block:: ada
-
- with k;
- package j is
- m : integer := k.r;
- end;
-
-where it is clear that there
-should be a pragma ``Elaborate_All``
-for unit ``k``. An implicit pragma will be generated, and it is
-likely that the binder will be able to honor it. However, if you want
-to port this program to some other Ada compiler than GNAT.
-it is safer to include the pragma explicitly in the source. If this
-unit is compiled with the :switch:`-gnatel`
-switch, then the compiler outputs an information message::
-
- 1. with k;
- 2. package j is
- 3. m : integer := k.r;
- |
- >>> info: call to "r" may raise Program_Error
- >>> info: missing pragma Elaborate_All for "k"
-
- 4. end;
-
-and these messages can be used as a guide for supplying manually
-the missing pragmas. It is usually a bad idea to use this
-option during development. That's because it will tell you when
-you need to put in a pragma, but cannot tell you when it is time
-to take it out. So the use of pragma ``Elaborate_All`` may lead to
-unnecessary dependencies and even false circularities.
-
-This default mode is more restrictive than the Ada Reference
-Manual, and it is possible to construct programs which will compile
-using the dynamic model described there, but will run into a
-circularity using the safer static model we have described.
-
-Of course any Ada compiler must be able to operate in a mode
-consistent with the requirements of the Ada Reference Manual,
-and in particular must have the capability of implementing the
-standard dynamic model of elaboration with run-time checks.
-
-In GNAT, this standard mode can be achieved either by the use of
-the :switch:`-gnatE` switch on the compiler (``gcc`` or
-``gnatmake``) command, or by the use of the configuration pragma:
-
-.. code-block:: ada
-
- pragma Elaboration_Checks (DYNAMIC);
-
-Either approach will cause the unit affected to be compiled using the
-standard dynamic run-time elaboration checks described in the Ada
-Reference Manual. The static model is generally preferable, since it
-is clearly safer to rely on compile and link time checks rather than
-run-time checks. However, in the case of legacy code, it may be
-difficult to meet the requirements of the static model. This
-issue is further discussed in
-:ref:`What_to_Do_If_the_Default_Elaboration_Behavior_Fails`.
-
-Note that the static model provides a strict subset of the allowed
-behavior and programs of the Ada Reference Manual, so if you do
-adhere to the static model and no circularities exist,
-then you are assured that your program will
-work using the dynamic model, providing that you remove any
-pragma Elaborate statements from the source.
-
-
-.. _Treatment_of_Pragma_Elaborate:
-
-Treatment of Pragma Elaborate
-=============================
-
-.. index:: Pragma Elaborate
-
-The use of ``pragma Elaborate``
-should generally be avoided in Ada 95 and Ada 2005 programs,
-since there is no guarantee that transitive calls
-will be properly handled. Indeed at one point, this pragma was placed
-in Annex J (Obsolescent Features), on the grounds that it is never useful.
-
-Now that's a bit restrictive. In practice, the case in which
-``pragma Elaborate`` is useful is when the caller knows that there
-are no transitive calls, or that the called unit contains all necessary
-transitive ``pragma Elaborate`` statements, and legacy code often
-contains such uses.
-
-Strictly speaking the static mode in GNAT should ignore such pragmas,
-since there is no assurance at compile time that the necessary safety
-conditions are met. In practice, this would cause GNAT to be incompatible
-with correctly written Ada 83 code that had all necessary
-``pragma Elaborate`` statements in place. Consequently, we made the
-decision that GNAT in its default mode will believe that if it encounters
-a ``pragma Elaborate`` then the programmer knows what they are doing,
-and it will trust that no elaboration errors can occur.
-
-The result of this decision is two-fold. First to be safe using the
-static mode, you should remove all ``pragma Elaborate`` statements.
-Second, when fixing circularities in existing code, you can selectively
-use ``pragma Elaborate`` statements to convince the static mode of
-GNAT that it need not generate an implicit ``pragma Elaborate_All``
-statement.
-
-When using the static mode with :switch:`-gnatwl`, any use of
-``pragma Elaborate`` will generate a warning about possible
-problems.
-
-
-.. _Elaboration_Issues_for_Library_Tasks:
-
-Elaboration Issues for Library Tasks
-====================================
-
-.. index:: Library tasks, elaboration issues
-
-.. index:: Elaboration of library tasks
-
-In this section we examine special elaboration issues that arise for
-programs that declare library level tasks.
-
-Generally the model of execution of an Ada program is that all units are
-elaborated, and then execution of the program starts. However, the
-declaration of library tasks definitely does not fit this model. The
-reason for this is that library tasks start as soon as they are declared
-(more precisely, as soon as the statement part of the enclosing package
-body is reached), that is to say before elaboration
-of the program is complete. This means that if such a task calls a
-subprogram, or an entry in another task, the callee may or may not be
-elaborated yet, and in the standard
-Reference Manual model of dynamic elaboration checks, you can even
-get timing dependent Program_Error exceptions, since there can be
-a race between the elaboration code and the task code.
-
-The static model of elaboration in GNAT seeks to avoid all such
-dynamic behavior, by being conservative, and the conservative
-approach in this particular case is to assume that all the code
-in a task body is potentially executed at elaboration time if
-a task is declared at the library level.
-
-This can definitely result in unexpected circularities. Consider
-the following example
-
-.. code-block:: ada
-
- package Decls is
- task Lib_Task is
- entry Start;
- end Lib_Task;
+ spec of Computer
+ body of Computer
+ spec of Client
- type My_Int is new Integer;
+ Note that there are several allowable suborders for the specs and bodies of
+ ``Math`` and ``Computer``, but the point is that these specs and bodies will
+ be elaborated prior to ``Client``.
- function Ident (M : My_Int) return My_Int;
- end Decls;
+ Removing pragma ``Elaborate_All`` could result in the following incorrect
+ elaboration order
- with Utils;
- package body Decls is
- task body Lib_Task is
- begin
- accept Start;
- Utils.Put_Val (2);
- end Lib_Task;
+ ::
- function Ident (M : My_Int) return My_Int is
+ spec of Math
+ spec of Computer
+ body of Computer
+ spec of Client
+ body of Math
+
+ where ``Client`` invokes ``Computer.Compute``, which in turn invokes
+ ``Math.Factorial``, but the body of ``Math.Factorial`` has not been
+ elaborated yet.
+
+All pragmas shown above can be summarized by the following rule:
+
+*If a client unit elaborates a server target directly or indirectly, then if
+the server unit requires a body and does not have pragma Pure, Preelaborate,
+or Elaborate_Body, then the client unit should have pragma Elaborate or
+Elaborate_All for the server unit.*
+
+If the rule outlined above is not followed, then a program may fall in one of
+the following states:
+
+* *No elaboration order exists*
+
+ In this case a compiler must diagnose the situation, and refuse to build an
+ executable program.
+
+* *One or more incorrect elaboration orders exist*
+
+ In this case a compiler can build an executable program, but
+ ``Program_Error`` will be raised when the program is run.
+
+* *Several elaboration orders exist, some correct, some incorrect*
+
+ In this case the programmer has not controlled the elaboration order. As a
+ result, a compiler may or may not pick one of the correct orders, and the
+ program may or may not raise ``Program_Error`` when it is run. This is the
+ worst possible state because the program may fail on another compiler, or
+ even another version of the same compiler.
+
+* *One or more correct orders exist*
+
+ In this case a compiler can build an executable program, and the program is
+ run successfully. This state may be guaranteed by following the outlined
+ rules, or may be the result of good program architecture.
+
+Note that one additional advantage of using ``Elaborate`` and ``Elaborate_All``
+is that the program continues to stay in the last state (one or more correct
+orders exist) even if maintenance changes the bodies of targets.
+
+.. _Controlling_the_Elaboration_Order_in_GNAT:
+
+Controlling the Elaboration Order in GNAT
+=========================================
+
+In addition to Ada semantics and rules synthesized from them, GNAT offers
+three elaboration models to aid the programmer with specifying the correct
+elaboration order and to diagnose elaboration problems.
+
+.. index:: Dynamic elaboration model
+
+* *Dynamic elaboration model*
+
+ This is the most permissive of the three elaboration models. When the
+ dynamic model is in effect, GNAT assumes that all code within all units in
+ a partition is elaboration code. GNAT performs very few diagnostics and
+ generates run-time checks to verify the elaboration order of a program. This
+ behavior is identical to that specified by the Ada Reference Manual. The
+ dynamic model is enabled with compilation switch :switch:`-gnatE`.
+
+.. index:: Static elaboration model
+
+* *Static elaboration model*
+
+ This is the middle ground of the three models. When the static model is in
+ effect, GNAT performs extensive diagnostics on a unit-by-unit basis for all
+ scenarios that elaborate or execute internal targets. GNAT also generates
+ run-time checks for all external targets and for all scenarios that may
+ exhibit ABE problems. Finally, GNAT installs implicit ``Elaborate`` and
+ ``Elaborate_All`` pragmas for server units based on the dependencies of
+ client units. The static model is the default model in GNAT.
+
+.. index:: SPARK elaboration model
+
+* *SPARK elaboration model*
+
+ This is the most conservative of the three models and enforces the SPARK
+ rules of elaboration as defined in the SPARK Reference Manual, section 7.7.
+ The SPARK model is in effect only when a scenario and a target reside in a
+ region subject to SPARK_Mode On, otherwise the dynamic or static model is in
+ effect.
+
+.. _Common_Elaboration_Model_Traits":
+
+Common Elaboration-model Traits
+===============================
+
+All three GNAT models are able to detect elaboration problems related to
+dispatching calls and a particular kind of ABE referred to as *guaranteed ABE*.
+
+* *Dispatching calls*
+
+ GNAT installs run-time checks for each primitive subprogram of each tagged
+ type defined in a partition on the assumption that a dispatching call
+ invoked at elaboration time will execute one of these primitives. As a
+ result, a dispatching call that executes a primitive whose body has not
+ been elaborated yet will raise exception ``Program_Error`` at run time. The
+ checks can be suppressed using pragma ``Suppress (Elaboration_Check)``.
+
+* *Guaranteed ABE*
+
+ A guaranteed ABE arises when the body of a target is not elaborated early
+ enough, and causes all scenarios that directly execute the target to fail.
+
+ ::
+
+ package body Guaranteed_ABE is
+ function ABE return Integer;
+
+ Val : constant Integer := ABE;
+
+ function ABE return Integer is
begin
- return M;
- end Ident;
- end Decls;
+ ...
+ end ABE;
+ end Guaranteed_ABE;
+
+ In the example above, the elaboration of ``Guaranteed_ABE``'s body elaborates
+ the declaration of ``Val``. This invokes function ``ABE``, however the body
+ of ``ABE`` has not been elaborated yet. GNAT emits similar diagnostics in all
+ three models:
+
+ ::
+
+ 1. package body Guaranteed_ABE is
+ 2. function ABE return Integer;
+ 3.
+ 4. Val : constant Integer := ABE;
+ |
+ >>> warning: cannot call "ABE" before body seen
+ >>> warning: Program_Error will be raised at run time
+
+ 5.
+ 6. function ABE return Integer is
+ 7. begin
+ 8. ...
+ 9. end ABE;
+ 10. end Guaranteed_ABE;
+
+Note that GNAT emits warnings rather than hard errors whenever it encounters an
+elaboration problem. This is because the elaboration model in effect may be too
+conservative, or a particular scenario may not be elaborated or executed due to
+data and control flow. The warnings can be suppressed with compiler switch
+:switch:`-gnatws`.
+
+.. _Dynamic_Elaboration_Model_in_GNAT:
+
+Dynamic Elaboration Model in GNAT
+=================================
- with Decls;
- package Utils is
- procedure Put_Val (Arg : Decls.My_Int);
- end Utils;
+The dynamic model assumes that all code within all units in a partition is
+elaboration code. As a result, run-time checks are installed for each scenario
+regardless of whether the target is internal or external. The checks can be
+suppressed using pragma ``Suppress (Elaboration_Check)``. This behavior is
+identical to that specified by the Ada Reference Manual. The following example
+showcases run-time checks installed by GNAT to verify the elaboration state of
+package ``Dynamic_Model``.
- with Text_IO;
- package body Utils is
- procedure Put_Val (Arg : Decls.My_Int) is
+::
+
+ with Server;
+ package body Dynamic_Model is
+ procedure API is
+ begin
+ ...
+ end API;
+
+ <check that the body of Server.Gen is elaborated>
+ package Inst is new Server.Gen;
+
+ T : Server.Task_Type;
+
+ begin
+ <check that the body of Server.Task_Type is elaborated>
+
+ <check that the body of Server.Proc is elaborated>
+ Server.Proc;
+ end Dynamic_Model;
+
+The checks verify that the body of a target has been successfully elaborated
+before a scenario activates, calls, or instantiates a target.
+
+Note that no scenario within package ``Dynamic_Model`` calls procedure ``API``.
+In fact, procedure ``API`` may not be invoked by elaboration code within the
+partition, however the dynamic model assumes that this can happen.
+
+The dynamic model emits very few diagnostics, but can make suggestions on
+missing ``Elaborate`` and ``Elaborate_All`` pragmas for library-level
+scenarios. This information is available when compiler switch :switch:`-gnatel`
+is in effect.
+
+::
+
+ 1. with Server;
+ 2. package body Dynamic_Model is
+ 3. Val : constant Integer := Server.Func;
+ |
+ >>> info: call to "Func" during elaboration
+ >>> info: missing pragma "Elaborate_All" for unit "Server"
+
+ 4. end Dynamic_Model;
+
+.. _Static_Elaboration_Model_in_GNAT:
+
+Static Elaboration Model in GNAT
+================================
+
+In contrast to the dynamic model, the static model is more precise in its
+analysis of elaboration code. The model makes a clear distinction between
+internal and external targets, and resorts to different diagnostics and
+run-time checks based on the nature of the target.
+
+* *Internal targets*
+
+ The static model performs extensive diagnostics on scenarios which elaborate
+ or execute internal targets. The warnings resulting from these diagnostics
+ are enabled by default, but can be suppressed using compiler switch
+ :switch:`-gnatws`.
+
+ ::
+
+ 1. package body Static_Model is
+ 2. generic
+ 3. with function Func return Integer;
+ 4. package Gen is
+ 5. Val : constant Integer := Func;
+ 6. end Gen;
+ 7.
+ 8. function ABE return Integer;
+ 9.
+ 10. function Cause_ABE return Boolean is
+ 11. package Inst is new Gen (ABE);
+ |
+ >>> warning: in instantiation at line 5
+ >>> warning: cannot call "ABE" before body seen
+ >>> warning: Program_Error may be raised at run time
+ >>> warning: body of unit "Static_Model" elaborated
+ >>> warning: function "Cause_ABE" called at line 16
+ >>> warning: function "ABE" called at line 5, instance at line 11
+
+ 12. begin
+ 13. ...
+ 14. end Cause_ABE;
+ 15.
+ 16. Val : constant Boolean := Cause_ABE;
+ 17.
+ 18. function ABE return Integer is
+ 19. begin
+ 20. ...
+ 21. end ABE;
+ 22. end Static_Model;
+
+ The example above illustrates an ABE problem within package ``Static_Model``,
+ which is hidden by several layers of indirection. The elaboration of package
+ body ``Static_Model`` elaborates the declaration of ``Val``. This invokes
+ function ``Cause_ABE``, which instantiates generic unit ``Gen`` as ``Inst``.
+ The elaboration of ``Inst`` invokes function ``ABE``, however the body of
+ ``ABE`` has not been elaborated yet.
+
+* *External targets*
+
+ The static model installs run-time checks to verify the elaboration status
+ of server targets only when the scenario that elaborates or executes that
+ target is part of the elaboration code of the client unit. The checks can be
+ suppressed using pragma ``Suppress (Elaboration_Check)``.
+
+ ::
+
+ with Server;
+ package body Static_Model is
+ generic
+ with function Func return Integer;
+ package Gen is
+ Val : constant Integer := Func;
+ end Gen;
+
+ function Call_Func return Boolean is
+ <check that the body of Server.Func is elaborated>
+ package Inst is new Gen (Server.Func);
begin
- Text_IO.Put_Line (Decls.My_Int'Image (Decls.Ident (Arg)));
- end Put_Val;
- end Utils;
+ ...
+ end Call_Func;
+
+ Val : constant Boolean := Call_Func;
+ end Static_Model;
+
+ In the example above, the elaboration of package body ``Static_Model``
+ elaborates the declaration of ``Val``. This invokes function ``Call_Func``,
+ which instantiates generic unit ``Gen`` as ``Inst``. The elaboration of
+ ``Inst`` invokes function ``Server.Func``. Since ``Server.Func`` is an
+ external target, GNAT installs a run-time check to verify that its body has
+ been elaborated.
+
+ In addition to checks, the static model installs implicit ``Elaborate`` and
+ ``Elaborate_All`` pragmas to guarantee safe elaboration use of server units.
+ This information is available when compiler switch :switch:`-gnatel` is in
+ effect.
+
+ ::
+
+ 1. with Server;
+ 2. package body Static_Model is
+ 3. generic
+ 4. with function Func return Integer;
+ 5. package Gen is
+ 6. Val : constant Integer := Func;
+ 7. end Gen;
+ 8.
+ 9. function Call_Func return Boolean is
+ 10. package Inst is new Gen (Server.Func);
+ |
+ >>> info: instantiation of "Gen" during elaboration
+ >>> info: in instantiation at line 6
+ >>> info: call to "Func" during elaboration
+ >>> info: in instantiation at line 6
+ >>> info: implicit pragma "Elaborate_All" generated for unit "Server"
+ >>> info: body of unit "Static_Model" elaborated
+ >>> info: function "Call_Func" called at line 15
+ >>> info: function "Func" called at line 6, instance at line 10
+
+ 11. begin
+ 12. ...
+ 13. end Call_Func;
+ 14.
+ 15. Val : constant Boolean := Call_Func;
+ |
+ >>> info: call to "Call_Func" during elaboration
+
+ 16. end Static_Model;
+
+ In the example above, the elaboration of package body ``Static_Model``
+ elaborates the declaration of ``Val``. This invokes function ``Call_Func``,
+ which instantiates generic unit ``Gen`` as ``Inst``. The elaboration of
+ ``Inst`` invokes function ``Server.Func``. Since ``Server.Func`` is an
+ external target, GNAT installs an implicit ``Elaborate_All`` pragma for unit
+ ``Server``. The pragma guarantees that both the spec and body of ``Server``,
+ along with any additional dependencies that ``Server`` may require, are
+ elaborated prior to the body of ``Static_Model``.
+
+.. _SPARK_Elaboration_Model_in_GNAT:
+
+SPARK Elaboration Model in GNAT
+===============================
+
+The SPARK model is identical to the static model in its handling of internal
+targets. The SPARK model, however, requires explicit ``Elaborate`` or
+``Elaborate_All`` pragmas to be present in the program when a target is
+external, and emits hard errors instead of warnings:
+
+::
+
+ 1. with Server;
+ 2. package body SPARK_Model with SPARK_Mode is
+ 3. Val : constant Integer := Server.Func;
+ |
+ >>> call to "Func" during elaboration in SPARK
+ >>> unit "SPARK_Model" requires pragma "Elaborate_All" for "Server"
+ >>> body of unit "SPARK_Model" elaborated
+ >>> function "Func" called at line 3
+
+ 4. end SPARK_Model;
+
+.. _Mixing_Elaboration_Models:
+
+Mixing Elaboration Models
+=========================
+
+It is possible to mix units compiled with a different elaboration model,
+however the following rules must be observed:
+
+* A client unit compiled with the dynamic model can only |with| a server unit
+ that meets at least one of the following criteria:
+
+ - The server unit is compiled with the dynamic model.
+
+ - The server unit is a GNAT implementation unit from the Ada, GNAT,
+ Interfaces, or System hierarchies.
+
+ - The server unit has pragma ``Pure`` or ``Preelaborate``.
+
+ - The client unit has an explicit ``Elaborate_All`` pragma for the server
+ unit.
+
+These rules ensure that elaboration checks are not omitted. If the rules are
+violated, the binder emits a warning:
+
+::
+
+ warning: "x.ads" has dynamic elaboration checks and with's
+ warning: "y.ads" which has static elaboration checks
+
+The warnings can be suppressed by binder switch :switch:`-ws`.
- with Decls;
- procedure Main is
+.. _Elaboration_Circularities:
+
+Elaboration Circularities
+=========================
+
+If the binder cannot find an acceptable elaboration order, it outputs detailed
+diagnostics describing an **elaboration circularity**.
+
+::
+
+ package Server is
+ function Func return Integer;
+ end Server;
+
+::
+
+ with Client;
+ package body Server is
+ function Func return Integer is
+ begin
+ ...
+ end Func;
+ end Server;
+
+::
+
+ with Server;
+ package Client is
+ Val : constant Integer := Server.Func;
+ end Client;
+
+::
+
+ with Client;
+ procedure Main is begin null; end Main;
+
+::
+
+ error: elaboration circularity detected
+ info: "server (body)" must be elaborated before "client (spec)"
+ info: reason: implicit Elaborate_All in unit "client (spec)"
+ info: recompile "client (spec)" with -gnatel for full details
+ info: "server (body)"
+ info: must be elaborated along with its spec:
+ info: "server (spec)"
+ info: which is withed by:
+ info: "client (spec)"
+ info: "client (spec)" must be elaborated before "server (body)"
+ info: reason: with clause
+
+In the example above, ``Client`` must be elaborated prior to ``Main`` by virtue
+of a |with| clause. The elaboration of ``Client`` invokes ``Server.Func``, and
+static model generates an implicit ``Elaborate_All`` pragma for ``Server``. The
+pragma implies that both the spec and body of ``Server``, along with any units
+they |with|, must be elaborated prior to ``Client``. However, ``Server``'s body
+|withs| ``Client``, implying that ``Client`` must be elaborated prior to
+``Server``. The end result is that ``Client`` must be elaborated prior to
+``Client``, and this leads to a circularity.
+
+.. _Resolving_Elaboration_Circularities:
+
+Resolving Elaboration Circularities
+===================================
+
+When faced with an elaboration circularity, a programmer has several options
+available.
+
+* *Fix the program*
+
+ The most desirable option from the point of view of long-term maintenance
+ is to rearrange the program so that the elaboration problems are avoided.
+ One useful technique is to place the elaboration code into separate child
+ packages. Another is to move some of the initialization code to explicitly
+ invoked subprograms, where the program controls the order of initialization
+ explicitly. Although this is the most desirable option, it may be impractical
+ and involve too much modification, especially in the case of complex legacy
+ code.
+
+* *Switch to more permissive elaboration model*
+
+ If the compilation was performed using the static model, enable the dynamic
+ model with compilation switch :switch:`-gnatE`. GNAT will no longer generate
+ implicit ``Elaborate`` and ``Elaborate_All`` pragmas, resulting in a behavior
+ identical to that specified by the Ada Reference Manual. The binder will
+ generate an executable program that may or may not raise ``Program_Error``,
+ and it is the programmer's responsibility to ensure that it does not raise
+ ``Program_Error``.
+
+* *Suppress all elaboration checks*
+
+ The drawback of run-time checks is that they generate overhead at run time,
+ both in space and time. If the programmer is absolutely sure that a program
+ will not raise an elaboration-related ``Program_Error``, then using the
+ pragma ``Suppress (Elaboration_Check)`` globally (as a configuration pragma)
+ will eliminate all run-time checks.
+
+* *Suppress elaboration checks selectively*
+
+ If a scenario cannot possibly lead to an elaboration ``Program_Error``,
+ and the binder nevertheless complains about implicit ``Elaborate`` and
+ ``Elaborate_All`` pragmas that lead to elaboration circularities, it
+ is possible to suppress the generation of implicit ``Elaborate`` and
+ ``Elaborate_All`` pragmas, as well as run-time checks. Clearly this can
+ be unsafe, and it is the responsibility of the programmer to make sure
+ that the resulting program has no elaboration anomalies. Pragma
+ ``Suppress (Elaboration_Check)`` can be used with different levels of
+ granularity to achieve these effects.
+
+ - *Target suppression*
+
+ When the pragma is placed in a declarative part, without a second argument
+ naming an entity, it will suppress implicit ``Elaborate`` and
+ ``Elaborate_All`` pragma generation, as well as run-time checks, on all
+ targets within the region.
+
+ ::
+
+ package Range_Suppress is
+ pragma Suppress (Elaboration_Check);
+
+ function Func return Integer;
+
+ generic
+ procedure Gen;
+
+ pragma Unsuppress (Elaboration_Check);
+
+ task type Tsk;
+ end Range_Suppress;
+
+ In the example above, a pair of Suppress/Unsuppress pragmas define a region
+ of suppression within package ``Range_Suppress``. As a result, no implicit
+ ``Elaborate`` and ``Elaborate_All`` pragmas, nor any run-time checks, will
+ be generated by callers of ``Func`` and instantiators of ``Gen``. Note that
+ task type ``Tsk`` is not within this region.
+
+ An alternative to the region-based suppression is to use multiple
+ ``Suppress`` pragmas with arguments naming specific entities for which
+ elaboration checks should be suppressed:
+
+ ::
+
+ package Range_Suppress is
+ function Func return Integer;
+ pragma Suppress (Elaboration_Check, Func);
+
+ generic
+ procedure Gen;
+ pragma Suppress (Elaboration_Check, Gen);
+
+ task type Tsk;
+ end Range_Suppress;
+
+ - *Scenario suppression*
+
+ When the pragma ``Suppress`` is placed in a declarative or statement
+ part, without an entity argument, it will suppress implicit ``Elaborate``
+ and ``Elaborate_All`` pragma generation, as well as run-time checks, on
+ all scenarios within the region.
+
+ ::
+
+ with Server;
+ package body Range_Suppress is
+ pragma Suppress (Elaboration_Check);
+
+ function Func return Integer is
+ begin
+ return Server.Func;
+ end Func;
+
+ procedure Gen is
+ begin
+ Server.Proc;
+ end Gen;
+
+ pragma Unsuppress (Elaboration_Check);
+
+ task body Tsk is
+ begin
+ Server.Proc;
+ end Tsk;
+ end Range_Suppress;
+
+ In the example above, a pair of Suppress/Unsuppress pragmas define a region
+ of suppression within package body ``Range_Suppress``. As a result, the
+ calls to ``Server.Func`` in ``Func`` and ``Server.Proc`` in ``Gen`` will
+ not generate any implicit ``Elaborate`` and ``Elaborate_All`` pragmas or
+ run-time checks.
+
+.. _Resolving_Task_Issues:
+
+Resolving Task Issues
+=====================
+
+The model of execution in Ada dictates that elaboration must first take place,
+and only then can the main program be started. Tasks which are activated during
+elaboration violate this model and may lead to serious concurrent problems at
+elaboration time.
+
+A task can be activated in two different ways:
+
+* The task is created by an allocator in which case it is activated immediately
+ after the allocator is evaluated.
+
+* The task is declared at the library level or within some nested master in
+ which case it is activated before starting execution of the statement
+ sequence of the master defining the task.
+
+Since the elaboration of a partition is performed by the environment task
+servicing that partition, any tasks activated during elaboration may be in
+a race with the environment task, and lead to unpredictable state and behavior.
+The static model seeks to avoid such interactions by assuming that all code in
+the task body is executed at elaboration time, if the task was activated by
+elaboration code.
+
+::
+
+ package Decls is
+ task Lib_Task is
+ entry Start;
+ end Lib_Task;
+
+ type My_Int is new Integer;
+
+ function Ident (M : My_Int) return My_Int;
+ end Decls;
+
+::
+
+ with Utils;
+ package body Decls is
+ task body Lib_Task is
+ begin
+ accept Start;
+ Utils.Put_Val (2);
+ end Lib_Task;
+
+ function Ident (M : My_Int) return My_Int is
+ begin
+ return M;
+ end Ident;
+ end Decls;
+
+::
+
+ with Decls;
+ package Utils is
+ procedure Put_Val (Arg : Decls.My_Int);
+ end Utils;
+
+::
+
+ with Ada.Text_IO; use Ada.Text_IO;
+ package body Utils is
+ procedure Put_Val (Arg : Decls.My_Int) is
begin
- Decls.Lib_Task.Start;
- end;
-
-If the above example is compiled in the default static elaboration
-mode, then a circularity occurs. The circularity comes from the call
-``Utils.Put_Val`` in the task body of ``Decls.Lib_Task``. Since
-this call occurs in elaboration code, we need an implicit pragma
-``Elaborate_All`` for ``Utils``. This means that not only must
-the spec and body of ``Utils`` be elaborated before the body
-of ``Decls``, but also the spec and body of any unit that is
-|withed| by the body of ``Utils`` must also be elaborated before
-the body of ``Decls``. This is the transitive implication of
-pragma ``Elaborate_All`` and it makes sense, because in general
-the body of ``Put_Val`` might have a call to something in a
-|withed| unit.
-
-In this case, the body of Utils (actually its spec) |withs|
-``Decls``. Unfortunately this means that the body of ``Decls``
-must be elaborated before itself, in case there is a call from the
-body of ``Utils``.
-
-Here is the exact chain of events we are worrying about:
-
-* In the body of ``Decls`` a call is made from within the body of a library
- task to a subprogram in the package ``Utils``. Since this call may
- occur at elaboration time (given that the task is activated at elaboration
- time), we have to assume the worst, i.e., that the
- call does happen at elaboration time.
-
-* This means that the body and spec of ``Util`` must be elaborated before
- the body of ``Decls`` so that this call does not cause an access before
- elaboration.
-
-* Within the body of ``Util``, specifically within the body of
- ``Util.Put_Val`` there may be calls to any unit |withed|
- by this package.
-
-* One such |withed| package is package ``Decls``, so there
- might be a call to a subprogram in ``Decls`` in ``Put_Val``.
- In fact there is such a call in this example, but we would have to
- assume that there was such a call even if it were not there, since
- we are not supposed to write the body of ``Decls`` knowing what
- is in the body of ``Utils``; certainly in the case of the
- static elaboration model, the compiler does not know what is in
- other bodies and must assume the worst.
-
-* This means that the spec and body of ``Decls`` must also be
- elaborated before we elaborate the unit containing the call, but
- that unit is ``Decls``! This means that the body of ``Decls``
- must be elaborated before itself, and that's a circularity.
-
-Indeed, if you add an explicit pragma ``Elaborate_All`` for ``Utils`` in
-the body of ``Decls`` you will get a true Ada Reference Manual
-circularity that makes the program illegal.
-
-In practice, we have found that problems with the static model of
-elaboration in existing code often arise from library tasks, so
-we must address this particular situation.
-
-Note that if we compile and run the program above, using the dynamic model of
-elaboration (that is to say use the :switch:`-gnatE` switch),
-then it compiles, binds,
-links, and runs, printing the expected result of 2. Therefore in some sense
-the circularity here is only apparent, and we need to capture
-the properties of this program that distinguish it from other library-level
-tasks that have real elaboration problems.
-
-We have four possible answers to this question:
-
-
-* Use the dynamic model of elaboration.
-
- If we use the :switch:`-gnatE` switch, then as noted above, the program works.
- Why is this? If we examine the task body, it is apparent that the task cannot
- proceed past the
- ``accept`` statement until after elaboration has been completed, because
- the corresponding entry call comes from the main program, not earlier.
- This is why the dynamic model works here. But that's really giving
- up on a precise analysis, and we prefer to take this approach only if we cannot
- solve the
- problem in any other manner. So let us examine two ways to reorganize
- the program to avoid the potential elaboration problem.
-
-* Split library tasks into separate packages.
-
- Write separate packages, so that library tasks are isolated from
- other declarations as much as possible. Let us look at a variation on
- the above program.
-
-
- .. code-block:: ada
-
- package Decls1 is
+ Put_Line (Arg'Img);
+ end Put_Val;
+ end Utils;
+
+::
+
+ with Decls;
+ procedure Main is
+ begin
+ Decls.Lib_Task.Start;
+ end Main;
+
+When the above example is compiled with the static model, an elaboration
+circularity arises:
+
+::
+
+ error: elaboration circularity detected
+ info: "decls (body)" must be elaborated before "decls (body)"
+ info: reason: implicit Elaborate_All in unit "decls (body)"
+ info: recompile "decls (body)" with -gnatel for full details
+ info: "decls (body)"
+ info: must be elaborated along with its spec:
+ info: "decls (spec)"
+ info: which is withed by:
+ info: "utils (spec)"
+ info: which is withed by:
+ info: "decls (body)"
+
+In the above example, ``Decls`` must be elaborated prior to ``Main`` by virtue
+of a with clause. The elaboration of ``Decls`` activates task ``Lib_Task``. The
+static model conservatibely assumes that all code within the body of
+``Lib_Task`` is executed, and generates an implicit ``Elaborate_All`` pragma
+for ``Units`` due to the call to ``Utils.Put_Val``. The pragma implies that
+both the spec and body of ``Utils``, along with any units they |with|,
+must be elaborated prior to ``Decls``. However, ``Utils``'s spec |withs|
+``Decls``, implying that ``Decls`` must be elaborated before ``Utils``. The end
+result is that ``Utils`` must be elaborated prior to ``Utils``, and this
+leads to a circularity.
+
+In reality, the example above will not exhibit an ABE problem at run time.
+When the body of task ``Lib_Task`` is activated, execution will wait for entry
+``Start`` to be accepted, and the call to ``Utils.Put_Val`` will not take place
+at elaboration time. Task ``Lib_Task`` will resume its execution after the main
+program is executed because ``Main`` performs a rendezvous with
+``Lib_Task.Start``, and at that point all units have already been elaborated.
+As a result, the static model may seem overly conservative, partly because it
+does not take control and data flow into account.
+
+When faced with a task elaboration circularity, a programmer has several
+options available:
+
+* *Use the dynamic model*
+
+ The dynamic model does not generate implicit ``Elaborate`` and
+ ``Elaborate_All`` pragmas. Instead, it will install checks prior to every
+ call in the example above, thus verifying the successful elaboration of
+ ``Utils.Put_Val`` in case the call to it takes place at elaboration time.
+ The dynamic model is enabled with compiler switch :switch:`-gnatE`.
+
+* *Isolate the tasks*
+
+ Relocating tasks in their own separate package could decouple them from
+ dependencies that would otherwise cause an elaboration circularity. The
+ example above can be rewritten as follows:
+
+ ::
+
+ package Decls1 is -- new
task Lib_Task is
entry Start;
end Lib_Task;
- end Decls1;
+ end Decls1;
+
+ ::
- with Utils;
- package body Decls1 is
+ with Utils;
+ package body Decls1 is -- new
task body Lib_Task is
begin
accept Start;
Utils.Put_Val (2);
end Lib_Task;
- end Decls1;
+ end Decls1;
- package Decls2 is
+ ::
+
+ package Decls2 is -- new
type My_Int is new Integer;
function Ident (M : My_Int) return My_Int;
- end Decls2;
+ end Decls2;
+
+ ::
- with Utils;
- package body Decls2 is
+ with Utils;
+ package body Decls2 is -- new
function Ident (M : My_Int) return My_Int is
begin
return M;
end Ident;
- end Decls2;
+ end Decls2;
+
+ ::
- with Decls2;
- package Utils is
+ with Decls2;
+ package Utils is
procedure Put_Val (Arg : Decls2.My_Int);
- end Utils;
+ end Utils;
- with Text_IO;
- package body Utils is
+ ::
+
+ with Ada.Text_IO; use Ada.Text_IO;
+ package body Utils is
procedure Put_Val (Arg : Decls2.My_Int) is
begin
- Text_IO.Put_Line (Decls2.My_Int'Image (Decls2.Ident (Arg)));
+ Put_Line (Arg'Img);
end Put_Val;
- end Utils;
-
- with Decls1;
- procedure Main is
- begin
- Decls1.Lib_Task.Start;
- end;
+ end Utils;
+ ::
- All we have done is to split ``Decls`` into two packages, one
- containing the library task, and one containing everything else. Now
- there is no cycle, and the program compiles, binds, links and executes
- using the default static model of elaboration.
-
-* Declare separate task types.
+ with Decls1;
+ procedure Main is
+ begin
+ Decls1.Lib_Task.Start;
+ end Main;
+
+* *Declare the tasks*
- A significant part of the problem arises because of the use of the
- single task declaration form. This means that the elaboration of
- the task type, and the elaboration of the task itself (i.e., the
- creation of the task) happen at the same time. A good rule
- of style in Ada is to always create explicit task types. By
- following the additional step of placing task objects in separate
- packages from the task type declaration, many elaboration problems
- are avoided. Here is another modified example of the example program:
+ The original example uses a single task declaration for ``Lib_Task``. An
+ explicit task type declaration and a properly placed task object could avoid
+ the dependencies that would otherwise cause an elaboration circularity. The
+ example can be rewritten as follows:
- .. code-block:: ada
+ ::
- package Decls is
- task type Lib_Task_Type is
+ package Decls is
+ task type Lib_Task is -- new
entry Start;
- end Lib_Task_Type;
+ end Lib_Task;
type My_Int is new Integer;
function Ident (M : My_Int) return My_Int;
- end Decls;
+ end Decls;
- with Utils;
- package body Decls is
- task body Lib_Task_Type is
+ ::
+
+ with Utils;
+ package body Decls is
+ task body Lib_Task is
begin
accept Start;
Utils.Put_Val (2);
- end Lib_Task_Type;
+ end Lib_Task;
function Ident (M : My_Int) return My_Int is
begin
return M;
end Ident;
- end Decls;
+ end Decls;
- with Decls;
- package Utils is
+ ::
+
+ with Decls;
+ package Utils is
procedure Put_Val (Arg : Decls.My_Int);
- end Utils;
+ end Utils;
+
+ ::
- with Text_IO;
- package body Utils is
+ with Ada.Text_IO; use Ada.Text_IO;
+ package body Utils is
procedure Put_Val (Arg : Decls.My_Int) is
begin
- Text_IO.Put_Line (Decls.My_Int'Image (Decls.Ident (Arg)));
+ Put_Line (Arg'Img);
end Put_Val;
- end Utils;
+ end Utils;
- with Decls;
- package Declst is
- Lib_Task : Decls.Lib_Task_Type;
- end Declst;
+ ::
- with Declst;
- procedure Main is
- begin
- Declst.Lib_Task.Start;
- end;
-
-
- What we have done here is to replace the ``task`` declaration in
- package ``Decls`` with a ``task type`` declaration. Then we
- introduce a separate package ``Declst`` to contain the actual
- task object. This separates the elaboration issues for
- the ``task type``
- declaration, which causes no trouble, from the elaboration issues
- of the task object, which is also unproblematic, since it is now independent
- of the elaboration of ``Utils``.
- This separation of concerns also corresponds to
- a generally sound engineering principle of separating declarations
- from instances. This version of the program also compiles, binds, links,
- and executes, generating the expected output.
-
-.. index:: No_Entry_Calls_In_Elaboration_Code restriction
-
-* Use No_Entry_Calls_In_Elaboration_Code restriction.
-
- The previous two approaches described how a program can be restructured
- to avoid the special problems caused by library task bodies. in practice,
- however, such restructuring may be difficult to apply to existing legacy code,
- so we must consider solutions that do not require massive rewriting.
-
- Let us consider more carefully why our original sample program works
- under the dynamic model of elaboration. The reason is that the code
- in the task body blocks immediately on the ``accept``
- statement. Now of course there is nothing to prohibit elaboration
- code from making entry calls (for example from another library level task),
- so we cannot tell in isolation that
- the task will not execute the accept statement during elaboration.
-
- However, in practice it is very unusual to see elaboration code
- make any entry calls, and the pattern of tasks starting
- at elaboration time and then immediately blocking on ``accept`` or
- ``select`` statements is very common. What this means is that
- the compiler is being too pessimistic when it analyzes the
- whole package body as though it might be executed at elaboration
- time.
-
- If we know that the elaboration code contains no entry calls, (a very safe
- assumption most of the time, that could almost be made the default
- behavior), then we can compile all units of the program under control
- of the following configuration pragma:
-
- .. code-block:: ada
-
- pragma Restrictions (No_Entry_Calls_In_Elaboration_Code);
-
- This pragma can be placed in the :file:`gnat.adc` file in the usual
- manner. If we take our original unmodified program and compile it
- in the presence of a :file:`gnat.adc` containing the above pragma,
- then once again, we can compile, bind, link, and execute, obtaining
- the expected result. In the presence of this pragma, the compiler does
- not trace calls in a task body, that appear after the first ``accept``
- or ``select`` statement, and therefore does not report a potential
- circularity in the original program.
-
- The compiler will check to the extent it can that the above
- restriction is not violated, but it is not always possible to do a
- complete check at compile time, so it is important to use this
- pragma only if the stated restriction is in fact met, that is to say
- no task receives an entry call before elaboration of all units is completed.
+ with Decls;
+ package Obj_Decls is -- new
+ Task_Obj : Decls.Lib_Task;
+ end Obj_Decls;
+ ::
-.. _Mixing_Elaboration_Models:
+ with Obj_Decls;
+ procedure Main is
+ begin
+ Obj_Decls.Task_Obj.Start; -- new
+ end Main;
-Mixing Elaboration Models
-=========================
+* *Use restriction No_Entry_Calls_In_Elaboration_Code*
-So far, we have assumed that the entire program is either compiled
-using the dynamic model or static model, ensuring consistency. It
-is possible to mix the two models, but rules have to be followed
-if this mixing is done to ensure that elaboration checks are not
-omitted.
+ The issue exhibited in the original example under this section revolves
+ around the body of ``Lib_Task`` blocking on an accept statement. There is
+ no rule to prevent elaboration code from performing entry calls, however in
+ practice this is highly unusual. In addition, the pattern of starting tasks
+ at elaboration time and then immediately blocking on accept or select
+ statements is quite common.
-The basic rule is that
-**a unit compiled with the static model cannot
-be |withed| by a unit compiled with the dynamic model**.
-The reason for this is that in the static model, a unit assumes that
-its clients guarantee to use (the equivalent of) pragma
-``Elaborate_All`` so that no elaboration checks are required
-in inner subprograms, and this assumption is violated if the
-client is compiled with dynamic checks.
+ If a programmer knows that elaboration code will not perform any entry
+ calls, then the programmer can indicate that the static model should not
+ process the remainder of a task body once an accept or select statement has
+ been encountered. This behavior can be specified by a configuration pragma:
-The precise rule is as follows. A unit that is compiled with dynamic
-checks can only |with| a unit that meets at least one of the
-following criteria:
+ ::
+ pragma Restrictions (No_Entry_Calls_In_Elaboration_Code);
-* The |withed| unit is itself compiled with dynamic elaboration
- checks (that is with the :switch:`-gnatE` switch.
+ In addition to the change in behavior with respect to task bodies, the
+ static model will verify that no entry calls take place at elaboration time.
-* The |withed| unit is an internal GNAT implementation unit from
- the System, Interfaces, Ada, or GNAT hierarchies.
+.. _Elaboration_Related_Compiler_Switches:
-* The |withed| unit has pragma Preelaborate or pragma Pure.
+Elaboration-related Compiler Switches
+=====================================
-* The |withing| unit (that is the client) has an explicit pragma
- ``Elaborate_All`` for the |withed| unit.
+GNAT has several switches that affect the elaboration model and consequently
+the elaboration order chosen by the binder.
+.. index:: -gnatdE (gnat)
-If this rule is violated, that is if a unit with dynamic elaboration
-checks |withs| a unit that does not meet one of the above four
-criteria, then the binder (``gnatbind``) will issue a warning
-similar to that in the following example::
+:switch:`-gnatdE`
+ Elaboration checks on predefined units
- warning: "x.ads" has dynamic elaboration checks and with's
- warning: "y.ads" which has static elaboration checks
+ When this switch is in effect, GNAT will consider scenarios and targets that
+ come from the Ada, GNAT, Interfaces, and System hierarchies. This switch is
+ useful when a programmer has defined a custom grandchild of those packages.
-These warnings indicate that the rule has been violated, and that as a result
-elaboration checks may be missed in the resulting executable file.
-This warning may be suppressed using the :switch:`-ws` binder switch
-in the usual manner.
+.. index:: -gnatd.G (gnat)
-One useful application of this mixing rule is in the case of a subsystem
-which does not itself |with| units from the remainder of the
-application. In this case, the entire subsystem can be compiled with
-dynamic checks to resolve a circularity in the subsystem, while
-allowing the main application that uses this subsystem to be compiled
-using the more reliable default static model.
+:switch:`-gnatd.G`
+ Ignore calls through generic formal parameters for elaboration
+ When this switch is in effect, GNAT will ignore calls that invoke generic
+ actual entries, operators, or subprograms via generic formal subprograms. As
+ a result, GNAT will not generate implicit ``Elaborate`` and ``Elaborate_All``
+ pragmas, and run-time checks for such calls. Note that this switch does not
+ overlap with :switch:`-gnatdL`.
-.. _What_to_Do_If_the_Default_Elaboration_Behavior_Fails:
+ ::
-What to Do If the Default Elaboration Behavior Fails
-====================================================
+ package body Ignore_Calls is
+ function ABE return Integer;
-If the binder cannot find an acceptable order, it outputs detailed
-diagnostics. For example::
+ generic
+ with function Gen_Formal return Integer;
+ package Gen is
+ Val : constant Integer := Gen_Formal;
+ end Gen;
- error: elaboration circularity detected
- info: "proc (body)" must be elaborated before "pack (body)"
- info: reason: Elaborate_All probably needed in unit "pack (body)"
- info: recompile "pack (body)" with -gnatel
- info: for full details
- info: "proc (body)"
- info: is needed by its spec:
- info: "proc (spec)"
- info: which is withed by:
- info: "pack (body)"
- info: "pack (body)" must be elaborated before "proc (body)"
- info: reason: pragma Elaborate in unit "proc (body)"
+ package Inst is new Gen (ABE);
-In this case we have a cycle that the binder cannot break. On the one
-hand, there is an explicit pragma Elaborate in ``proc`` for
-``pack``. This means that the body of ``pack`` must be elaborated
-before the body of ``proc``. On the other hand, there is elaboration
-code in ``pack`` that calls a subprogram in ``proc``. This means
-that for maximum safety, there should really be a pragma
-Elaborate_All in ``pack`` for ``proc`` which would require that
-the body of ``proc`` be elaborated before the body of
-``pack``. Clearly both requirements cannot be satisfied.
-Faced with a circularity of this kind, you have three different options.
+ function ABE return Integer is
+ begin
+ ...
+ end ABE;
+ end Ignore_Calls;
+ In the example above, the call to function ``ABE`` will be ignored because it
+ occurs during the elaboration of instance ``Inst``, through a call to generic
+ formal subprogram ``Gen_Formal``.
-* *Fix the program*
+.. index:: -gnatdL (gnat)
- The most desirable option from the point of view of long-term maintenance
- is to rearrange the program so that the elaboration problems are avoided.
- One useful technique is to place the elaboration code into separate
- child packages. Another is to move some of the initialization code to
- explicitly called subprograms, where the program controls the order
- of initialization explicitly. Although this is the most desirable option,
- it may be impractical and involve too much modification, especially in
- the case of complex legacy code.
-
-* *Perform dynamic checks*
-
- If the compilations are done using the :switch:`-gnatE`
- (dynamic elaboration check) switch, then GNAT behaves in a quite different
- manner. Dynamic checks are generated for all calls that could possibly result
- in raising an exception. With this switch, the compiler does not generate
- implicit ``Elaborate`` or ``Elaborate_All`` pragmas. The behavior then is
- exactly as specified in the :title:`Ada Reference Manual`.
- The binder will generate
- an executable program that may or may not raise ``Program_Error``, and then
- it is the programmer's job to ensure that it does not raise an exception. Note
- that it is important to compile all units with the switch, it cannot be used
- selectively.
-
-* *Suppress checks*
-
- The drawback of dynamic checks is that they generate a
- significant overhead at run time, both in space and time. If you
- are absolutely sure that your program cannot raise any elaboration
- exceptions, and you still want to use the dynamic elaboration model,
- then you can use the configuration pragma
- ``Suppress (Elaboration_Check)`` to suppress all such checks. For
- example this pragma could be placed in the :file:`gnat.adc` file.
-
-* *Suppress checks selectively*
-
- When you know that certain calls or instantiations in elaboration code cannot
- possibly lead to an elaboration error, and the binder nevertheless complains
- about implicit ``Elaborate`` and ``Elaborate_All`` pragmas that lead to
- elaboration circularities, it is possible to remove those warnings locally and
- obtain a program that will bind. Clearly this can be unsafe, and it is the
- responsibility of the programmer to make sure that the resulting program has no
- elaboration anomalies. The pragma ``Suppress (Elaboration_Check)`` can be
- used with different granularity to suppress warnings and break elaboration
- circularities:
-
- * Place the pragma that names the called subprogram in the declarative part
- that contains the call.
-
- * Place the pragma in the declarative part, without naming an entity. This
- disables warnings on all calls in the corresponding declarative region.
-
- * Place the pragma in the package spec that declares the called subprogram,
- and name the subprogram. This disables warnings on all elaboration calls to
- that subprogram.
-
- * Place the pragma in the package spec that declares the called subprogram,
- without naming any entity. This disables warnings on all elaboration calls to
- all subprograms declared in this spec.
-
- * Use Pragma Elaborate.
-
- As previously described in section :ref:`Treatment_of_Pragma_Elaborate`,
- GNAT in static mode assumes that a ``pragma`` Elaborate indicates correctly
- that no elaboration checks are required on calls to the designated unit.
- There may be cases in which the caller knows that no transitive calls
- can occur, so that a ``pragma Elaborate`` will be sufficient in a
- case where ``pragma Elaborate_All`` would cause a circularity.
-
- These five cases are listed in order of decreasing safety, and therefore
- require increasing programmer care in their application. Consider the
- following program:
-
- .. code-block:: ada
-
- package Pack1 is
- function F1 return Integer;
- X1 : Integer;
- end Pack1;
-
- package Pack2 is
- function F2 return Integer;
- function Pure (x : integer) return integer;
- -- pragma Suppress (Elaboration_Check, On => Pure); -- (3)
- -- pragma Suppress (Elaboration_Check); -- (4)
- end Pack2;
-
- with Pack2;
- package body Pack1 is
- function F1 return Integer is
- begin
- return 100;
- end F1;
- Val : integer := Pack2.Pure (11); -- Elab. call (1)
+:switch:`-gnatdL`
+ Ignore external calls from instances for elaboration
+
+ When this switch is in effect, GNAT will ignore calls that originate from
+ within an instance and directly target an entry, operator, or subprogram
+ defined outside the instance. As a result, GNAT will not generate implicit
+ ``Elaborate`` and ``Elaborate_All`` pragmas, and run-time checks for such
+ calls. Note that this switch does not overlap with :switch:`-gnatd.G`.
+
+ ::
+
+ package body Ignore_Calls is
+ function ABE return Integer;
+
+ generic
+ package Gen is
+ Val : constant Integer := ABE;
+ end Gen;
+
+ package Inst is new Gen;
+
+ function ABE return Integer is
begin
- declare
- -- pragma Suppress(Elaboration_Check, Pack2.F2); -- (1)
- -- pragma Suppress(Elaboration_Check); -- (2)
- begin
- X1 := Pack2.F2 + 1; -- Elab. call (2)
- end;
- end Pack1;
+ ...
+ end ABE;
+ end Ignore_Calls;
- with Pack1;
- package body Pack2 is
- function F2 return Integer is
- begin
- return Pack1.F1;
- end F2;
- function Pure (x : integer) return integer is
- begin
- return x ** 3 - 3 * x;
- end;
- end Pack2;
+ In the example above, the call to function ``ABE`` will be ignored because it
+ originates from within an instance and targets a subprogram defined outside
+ the instance.
+
+.. index:: -gnatd.o (gnat)
+
+:switch:`-gnatd.o`
+ Conservative elaboration order for indirect calls
+
+ When this switch is in effect, GNAT will treat ``'Access`` of an entry,
+ operator, or subprogram as an immediate call to that target. As a result,
+ GNAT will generate implicit ``Elaborate`` and ``Elaborate_All`` pragmas as
+ well as run-time checks for such attribute references.
+
+ ::
- with Pack1, Ada.Text_IO;
- procedure Proc3 is
+ 1. package body Attribute_Call is
+ 2. function Func return Integer;
+ 3. type Func_Ptr is access function return Integer;
+ 4.
+ 5. Ptr : constant Func_Ptr := Func'Access;
+ |
+ >>> warning: cannot call "Func" before body seen
+ >>> warning: Program_Error may be raised at run time
+ >>> warning: body of unit "Attribute_Call" elaborated
+ >>> warning: "Access" of "Func" taken at line 5
+ >>> warning: function "Func" called at line 5
+
+ 6.
+ 7. function Func return Integer is
+ 8. begin
+ 9. ...
+ 10. end Func;
+ 11. end Attribute_Call;
+
+ In the example above, the elaboration of declaration ``Ptr`` is assigned
+ ``Func'Access`` before the body of ``Func`` has been elaborated.
+
+.. index:: -gnatd.U (gnat)
+
+:switch:`-gnatd.U`
+ Ignore indirect calls for static elaboration
+
+ When this switch is in effect, GNAT will ignore ``'Access`` of an entry,
+ operator, or subprogram when the static model is in effect.
+
+.. index:: -gnatd.y (gnat)
+
+:switch:`-gnatd.y`
+ Disable implicit pragma Elaborate[_All] on task bodies
+
+ When this switch is in effect, GNAT will not generate ``Elaborate`` and
+ ``Elaborate_All`` pragmas if the need for the pragma came directly or
+ indirectly from a task body.
+
+ ::
+
+ with Server;
+ package body Disable_Task is
+ task T;
+
+ task body T is
begin
- Ada.Text_IO.Put_Line(Pack1.X1'Img); -- 101
- end Proc3;
-
- In the absence of any pragmas, an attempt to bind this program produces
- the following diagnostics::
-
- error: elaboration circularity detected
- info: "pack1 (body)" must be elaborated before "pack1 (body)"
- info: reason: Elaborate_All probably needed in unit "pack1 (body)"
- info: recompile "pack1 (body)" with -gnatel for full details
- info: "pack1 (body)"
- info: must be elaborated along with its spec:
- info: "pack1 (spec)"
- info: which is withed by:
- info: "pack2 (body)"
- info: which must be elaborated along with its spec:
- info: "pack2 (spec)"
- info: which is withed by:
- info: "pack1 (body)"
-
- The sources of the circularity are the two calls to ``Pack2.Pure`` and
- ``Pack2.F2`` in the body of ``Pack1``. We can see that the call to
- F2 is safe, even though F2 calls F1, because the call appears after the
- elaboration of the body of F1. Therefore the pragma (1) is safe, and will
- remove the warning on the call. It is also possible to use pragma (2)
- because there are no other potentially unsafe calls in the block.
-
- The call to ``Pure`` is safe because this function does not depend on the
- state of ``Pack2``. Therefore any call to this function is safe, and it
- is correct to place pragma (3) in the corresponding package spec.
-
- Finally, we could place pragma (4) in the spec of ``Pack2`` to disable
- warnings on all calls to functions declared therein. Note that this is not
- necessarily safe, and requires more detailed examination of the subprogram
- bodies involved. In particular, a call to ``F2`` requires that ``F1``
- be already elaborated.
-
-It is hard to generalize on which of these four approaches should be
-taken. Obviously if it is possible to fix the program so that the default
-treatment works, this is preferable, but this may not always be practical.
-It is certainly simple enough to use :switch:`-gnatE`
-but the danger in this case is that, even if the GNAT binder
-finds a correct elaboration order, it may not always do so,
-and certainly a binder from another Ada compiler might not. A
-combination of testing and analysis (for which the
-information messages generated with the :switch:`-gnatel`
-switch can be useful) must be used to ensure that the program is free
-of errors. One switch that is useful in this testing is the
-:switch:`-p` (pessimistic elaboration order) switch for ``gnatbind``.
-Normally the binder tries to find an order that has the best chance
-of avoiding elaboration problems. However, if this switch is used, the binder
-plays a devil's advocate role, and tries to choose the order that
-has the best chance of failing. If your program works even with this
-switch, then it has a better chance of being error free, but this is still
-not a guarantee.
-
-For an example of this approach in action, consider the C-tests (executable
-tests) from the ACATS suite. If these are compiled and run with the default
-treatment, then all but one of them succeed without generating any error
-diagnostics from the binder. However, there is one test that fails, and
-this is not surprising, because the whole point of this test is to ensure
-that the compiler can handle cases where it is impossible to determine
-a correct order statically, and it checks that an exception is indeed
-raised at run time.
-
-This one test must be compiled and run using the :switch:`-gnatE`
-switch, and then it passes. Alternatively, the entire suite can
-be run using this switch. It is never wrong to run with the dynamic
-elaboration switch if your code is correct, and we assume that the
-C-tests are indeed correct (it is less efficient, but efficiency is
-not a factor in running the ACATS tests.)
-
-
-.. _Elaboration_for_Indirect_Calls:
-
-Elaboration for Indirect Calls
-==============================
+ Server.Proc;
+ end T;
+ end Disable_Task;
+
+ In the example above, the activation of single task ``T`` invokes
+ ``Server.Proc``, which implies that ``Server`` requires ``Elaborate_All``,
+ however GNAT will not generate the pragma.
+
+.. index:: -gnatE (gnat)
+
+:switch:`-gnatE`
+ Dynamic elaboration checking mode enabled
+
+ When this switch is in effect, GNAT activates the dynamic elaboration model.
+
+.. index:: -gnatel (gnat)
+
+:switch:`-gnatel`
+ Turn on info messages on generated Elaborate[_All] pragmas
+
+ When this switch is in effect, GNAT will emit the following supplementary
+ information depending on the elaboration model in effect.
+
+ - *Dynamic model*
+
+ GNAT will indicate missing ``Elaborate`` and ``Elaborate_All`` pragmas for
+ all library-level scenarios within the partition.
-.. index:: Dispatching calls
-.. index:: Indirect calls
+ - *Static model*
-In rare cases, the static elaboration model fails to prevent
-dispatching calls to not-yet-elaborated subprograms. In such cases, we
-fall back to run-time checks; premature calls to any primitive
-operation of a tagged type before the body of the operation has been
-elaborated will raise ``Program_Error``.
+ GNAT will indicate all scenarios executed during elaboration. In addition,
+ it will provide detailed traceback when an implicit ``Elaborate`` or
+ ``Elaborate_All`` pragma is generated.
-Access-to-subprogram types, however, are handled conservatively in many
-cases. This was not true in earlier versions of the compiler; you can use
-the :switch:`-gnatd.U` debug switch to revert to the old behavior if the new
-conservative behavior causes elaboration cycles. Here, 'conservative' means
-that if you do ``P'Access`` during elaboration, the compiler will normally
-assume that you might call ``P`` indirectly during elaboration, so it adds an
-implicit ``pragma Elaborate_All`` on the library unit containing ``P``. The
-:switch:`-gnatd.U` switch is safe if you know there are no such calls. If the
-program worked before, it will continue to work with :switch:`-gnatd.U`. But beware
-that code modifications such as adding an indirect call can cause erroneous
-behavior in the presence of :switch:`-gnatd.U`.
+ - *SPARK model*
-These implicit Elaborate_All pragmas are not added in all cases, because
-they cause elaboration cycles in certain common code patterns. If you want
-even more conservative handling of P'Access, you can use the :switch:`-gnatd.o`
-switch.
+ GNAT will indicate how an elaboration requirement is met by the context of
+ a unit.
-See :file:`debug.adb` for documentation on the :switch:`-gnatd...` debug switches.
+ ::
+ 1. with Server; pragma Elaborate_All (Server);
+ 2. package Client with SPARK_Mode is
+ 3. Val : constant Integer := Server.Func;
+ |
+ >>> info: call to "Func" during elaboration in SPARK
+ >>> info: "Elaborate_All" requirement for unit "Server" met by pragma at line 1
+
+ 4. end Client;
+
+.. index:: -gnatw.f (gnat)
+
+:switch:`-gnatw.f`
+ Turn on warnings for suspicious Subp'Access
+
+ When this switch is in effect, GNAT will treat ``'Access`` of an entry,
+ operator, or subprogram as a potential call to the target and issue warnings:
+
+ ::
+
+ 1. package body Attribute_Call is
+ 2. function Func return Integer;
+ 3. type Func_Ptr is access function return Integer;
+ 4.
+ 5. Ptr : constant Func_Ptr := Func'Access;
+ |
+ >>> warning: "Access" attribute of "Func" before body seen
+ >>> warning: possible Program_Error on later references
+ >>> warning: body of unit "Attribute_Call" elaborated
+ >>> warning: "Access" of "Func" taken at line 5
+
+ 6.
+ 7. function Func return Integer is
+ 8. begin
+ 9. ...
+ 10. end Func;
+ 11. end Attribute_Call;
+
+ In the example above, the elaboration of declaration ``Ptr`` is assigned
+ ``Func'Access`` before the body of ``Func`` has been elaborated.
.. _Summary_of_Procedures_for_Elaboration_Control:
Summary of Procedures for Elaboration Control
=============================================
-.. index:: Elaboration control
+A programmer should first compile the program with the default options, using
+none of the binder or compiler switches. If the binder succeeds in finding an
+elaboration order, then apart from possible cases involing dispatching calls
+and access-to-subprogram types, the program is free of elaboration errors.
+If it is important for the program to be portable to compilers other than GNAT,
+then the programmer should use compilation switch :switch:`-gnatel` and
+consider the messages about missing or implicitly created ``Elaborate`` and
+``Elaborate_All`` pragmas.
-First, compile your program with the default options, using none of
-the special elaboration-control switches. If the binder successfully
-binds your program, then you can be confident that, apart from issues
-raised by the use of access-to-subprogram types and dynamic dispatching,
-the program is free of elaboration errors. If it is important that the
-program be portable to other compilers than GNAT, then use the
-:switch:`-gnatel`
-switch to generate messages about missing ``Elaborate`` or
-``Elaborate_All`` pragmas, and supply the missing pragmas.
-
-If the program fails to bind using the default static elaboration
-handling, then you can fix the program to eliminate the binder
-message, or recompile the entire program with the
-:switch:`-gnatE` switch to generate dynamic elaboration checks,
-and, if you are sure there really are no elaboration problems,
-use a global pragma ``Suppress (Elaboration_Check)``.
-
-
-.. _Other_Elaboration_Order_Considerations:
-
-Other Elaboration Order Considerations
-======================================
-
-This section has been entirely concerned with the issue of finding a valid
-elaboration order, as defined by the Ada Reference Manual. In a case
-where several elaboration orders are valid, the task is to find one
-of the possible valid elaboration orders (and the static model in GNAT
-will ensure that this is achieved).
-
-The purpose of the elaboration rules in the Ada Reference Manual is to
-make sure that no entity is accessed before it has been elaborated. For
-a subprogram, this means that the spec and body must have been elaborated
-before the subprogram is called. For an object, this means that the object
-must have been elaborated before its value is read or written. A violation
-of either of these two requirements is an access before elaboration order,
-and this section has been all about avoiding such errors.
-
-In the case where more than one order of elaboration is possible, in the
-sense that access before elaboration errors are avoided, then any one of
-the orders is 'correct' in the sense that it meets the requirements of
-the Ada Reference Manual, and no such error occurs.
-
-However, it may be the case for a given program, that there are
-constraints on the order of elaboration that come not from consideration
-of avoiding elaboration errors, but rather from extra-lingual logic
-requirements. Consider this example:
-
-.. code-block:: ada
-
- with Init_Constants;
- package Constants is
- X : Integer := 0;
- Y : Integer := 0;
- end Constants;
-
- package Init_Constants is
- procedure P; --* require a body*
- end Init_Constants;
-
- with Constants;
- package body Init_Constants is
- procedure P is begin null; end;
- begin
- Constants.X := 3;
- Constants.Y := 4;
- end Init_Constants;
+If the binder reports an elaboration circularity, the programmer has several
+options:
- with Constants;
- package Calc is
- Z : Integer := Constants.X + Constants.Y;
- end Calc;
+* Ensure that warnings are enabled. This will allow the static model to output
+ trace information of elaboration issues. The trace information could shed
+ light on previously unforeseen dependencies, as well as their origins.
- with Calc;
- with Text_IO; use Text_IO;
- procedure Main is
- begin
- Put_Line (Calc.Z'Img);
- end Main;
+* Use switch :switch:`-gnatel` to obtain messages on generated implicit
+ ``Elaborate`` and ``Elaborate_All`` pragmas. The trace information could
+ indicate why a server unit must be elaborated prior to a client unit.
+
+* If the warnings produced by the static model indicate that a task is
+ involved, consider the options in the section on resolving task issues as
+ well as compiler switch :switch:`-gnatd.y`.
-In this example, there is more than one valid order of elaboration. For
-example both the following are correct orders::
+* If the warnings produced by the static model indicate that an generic
+ instantiations are involved, consider using compiler switches
+ :switch:`-gnatd.G` and :switch:`-gnatdL`.
- Init_Constants spec
- Constants spec
- Calc spec
- Init_Constants body
- Main body
+* If none of the steps outlined above resolve the circularity, recompile the
+ program using the dynamic model by using compiler switch :switch:`-gnatE`.
-and
+.. _Inspecting_the_Chosen_Elaboration_Order:
+
+Inspecting the Chosen Elaboration Order
+=======================================
+
+To see the elaboration order chosen by the binder, inspect the contents of file
+`b~xxx.adb`. On certain targets, this file appears as `b_xxx.adb`. The
+elaboration order appears as a sequence of calls to ``Elab_Body`` and
+``Elab_Spec``, interspersed with assignments to `Exxx` which indicates that a
+particular unit is elaborated. For example:
::
- Init_Constants spec
- Constants spec
- Init_Constants body
- Calc spec
- Main body
-
-There is no language rule to prefer one or the other, both are correct
-from an order of elaboration point of view. But the programmatic effects
-of the two orders are very different. In the first, the elaboration routine
-of ``Calc`` initializes ``Z`` to zero, and then the main program
-runs with this value of zero. But in the second order, the elaboration
-routine of ``Calc`` runs after the body of Init_Constants has set
-``X`` and ``Y`` and thus ``Z`` is set to 7 before ``Main`` runs.
-
-One could perhaps by applying pretty clever non-artificial intelligence
-to the situation guess that it is more likely that the second order of
-elaboration is the one desired, but there is no formal linguistic reason
-to prefer one over the other. In fact in this particular case, GNAT will
-prefer the second order, because of the rule that bodies are elaborated
-as soon as possible, but it's just luck that this is what was wanted
-(if indeed the second order was preferred).
-
-If the program cares about the order of elaboration routines in a case like
-this, it is important to specify the order required. In this particular
-case, that could have been achieved by adding to the spec of Calc:
-
-.. code-block:: ada
-
- pragma Elaborate_All (Constants);
-
-which requires that the body (if any) and spec of ``Constants``,
-as well as the body and spec of any unit |withed| by
-``Constants`` be elaborated before ``Calc`` is elaborated.
-
-Clearly no automatic method can always guess which alternative you require,
-and if you are working with legacy code that had constraints of this kind
-which were not properly specified by adding ``Elaborate`` or
-``Elaborate_All`` pragmas, then indeed it is possible that two different
-compilers can choose different orders.
-
-However, GNAT does attempt to diagnose the common situation where there
-are uninitialized variables in the visible part of a package spec, and the
-corresponding package body has an elaboration block that directly or
-indirectly initializes one or more of these variables. This is the situation
-in which a pragma Elaborate_Body is usually desirable, and GNAT will generate
-a warning that suggests this addition if it detects this situation.
-
-The ``gnatbind` :switch:`-p` switch may be useful in smoking
-out problems. This switch causes bodies to be elaborated as late as possible
-instead of as early as possible. In the example above, it would have forced
-the choice of the first elaboration order. If you get different results
-when using this switch, and particularly if one set of results is right,
-and one is wrong as far as you are concerned, it shows that you have some
-missing ``Elaborate`` pragmas. For the example above, we have the
-following output:
-
-.. code-block:: sh
-
- $ gnatmake -f -q main
- $ main
- 7
- $ gnatmake -f -q main -bargs -p
- $ main
- 0
-
-It is of course quite unlikely that both these results are correct, so
-it is up to you in a case like this to investigate the source of the
-difference, by looking at the two elaboration orders that are chosen,
-and figuring out which is correct, and then adding the necessary
-``Elaborate`` or ``Elaborate_All`` pragmas to ensure the desired order.
-
-
-.. _Determining_the_Chosen_Elaboration_Order:
-
-Determining the Chosen Elaboration Order
-========================================
+ System.Soft_Links'Elab_Body;
+ E14 := True;
+ System.Secondary_Stack'Elab_Body;
+ E18 := True;
+ System.Exception_Table'Elab_Body;
+ E24 := True;
+ Ada.Io_Exceptions'Elab_Spec;
+ E67 := True;
+ Ada.Tags'Elab_Spec;
+ Ada.Streams'Elab_Spec;
+ E43 := True;
+ Interfaces.C'Elab_Spec;
+ E69 := True;
+ System.Finalization_Root'Elab_Spec;
+ E60 := True;
+ System.Os_Lib'Elab_Body;
+ E71 := True;
+ System.Finalization_Implementation'Elab_Spec;
+ System.Finalization_Implementation'Elab_Body;
+ E62 := True;
+ Ada.Finalization'Elab_Spec;
+ E58 := True;
+ Ada.Finalization.List_Controller'Elab_Spec;
+ E76 := True;
+ System.File_Control_Block'Elab_Spec;
+ E74 := True;
+ System.File_Io'Elab_Body;
+ E56 := True;
+ Ada.Tags'Elab_Body;
+ E45 := True;
+ Ada.Text_Io'Elab_Spec;
+ Ada.Text_Io'Elab_Body;
+ E07 := True;
+
+Note also binder switch :switch:`-l`, which outputs the chosen elaboration
+order and provides a more readable form of the above:
+
+::
-To see the elaboration order that the binder chooses, you can look at
-the last part of the file:`b~xxx.adb` binder output file. Here is an example::
-
- System.Soft_Links'Elab_Body;
- E14 := True;
- System.Secondary_Stack'Elab_Body;
- E18 := True;
- System.Exception_Table'Elab_Body;
- E24 := True;
- Ada.Io_Exceptions'Elab_Spec;
- E67 := True;
- Ada.Tags'Elab_Spec;
- Ada.Streams'Elab_Spec;
- E43 := True;
- Interfaces.C'Elab_Spec;
- E69 := True;
- System.Finalization_Root'Elab_Spec;
- E60 := True;
- System.Os_Lib'Elab_Body;
- E71 := True;
- System.Finalization_Implementation'Elab_Spec;
- System.Finalization_Implementation'Elab_Body;
- E62 := True;
- Ada.Finalization'Elab_Spec;
- E58 := True;
- Ada.Finalization.List_Controller'Elab_Spec;
- E76 := True;
- System.File_Control_Block'Elab_Spec;
- E74 := True;
- System.File_Io'Elab_Body;
- E56 := True;
- Ada.Tags'Elab_Body;
- E45 := True;
- Ada.Text_Io'Elab_Spec;
- Ada.Text_Io'Elab_Body;
- E07 := True;
-
-Here Elab_Spec elaborates the spec
-and Elab_Body elaborates the body. The assignments to the :samp:`E{xx}` flags
-flag that the corresponding body is now elaborated.
-
-You can also ask the binder to generate a more
-readable list of the elaboration order using the
-:switch:`-l` switch when invoking the binder. Here is
-an example of the output generated by this switch::
-
- ada (spec)
- interfaces (spec)
- system (spec)
- system.case_util (spec)
- system.case_util (body)
- system.concat_2 (spec)
- system.concat_2 (body)
- system.concat_3 (spec)
- system.concat_3 (body)
- system.htable (spec)
- system.parameters (spec)
- system.parameters (body)
- system.crtl (spec)
- interfaces.c_streams (spec)
- interfaces.c_streams (body)
- system.restrictions (spec)
- system.restrictions (body)
- system.standard_library (spec)
- system.exceptions (spec)
- system.exceptions (body)
- system.storage_elements (spec)
- system.storage_elements (body)
- system.secondary_stack (spec)
- system.stack_checking (spec)
- system.stack_checking (body)
- system.string_hash (spec)
- system.string_hash (body)
- system.htable (body)
- system.strings (spec)
- system.strings (body)
- system.traceback (spec)
- system.traceback (body)
- system.traceback_entries (spec)
- system.traceback_entries (body)
- ada.exceptions (spec)
- ada.exceptions.last_chance_handler (spec)
- system.soft_links (spec)
- system.soft_links (body)
- ada.exceptions.last_chance_handler (body)
- system.secondary_stack (body)
- system.exception_table (spec)
- system.exception_table (body)
- ada.io_exceptions (spec)
- ada.tags (spec)
- ada.streams (spec)
- interfaces.c (spec)
- interfaces.c (body)
- system.finalization_root (spec)
- system.finalization_root (body)
- system.memory (spec)
- system.memory (body)
- system.standard_library (body)
- system.os_lib (spec)
- system.os_lib (body)
- system.unsigned_types (spec)
- system.stream_attributes (spec)
- system.stream_attributes (body)
- system.finalization_implementation (spec)
- system.finalization_implementation (body)
- ada.finalization (spec)
- ada.finalization (body)
- ada.finalization.list_controller (spec)
- ada.finalization.list_controller (body)
- system.file_control_block (spec)
- system.file_io (spec)
- system.file_io (body)
- system.val_uns (spec)
- system.val_util (spec)
- system.val_util (body)
- system.val_uns (body)
- system.wch_con (spec)
- system.wch_con (body)
- system.wch_cnv (spec)
- system.wch_jis (spec)
- system.wch_jis (body)
- system.wch_cnv (body)
- system.wch_stw (spec)
- system.wch_stw (body)
- ada.tags (body)
- ada.exceptions (body)
- ada.text_io (spec)
- ada.text_io (body)
- text_io (spec)
- gdbstr (body)
+ ada (spec)
+ interfaces (spec)
+ system (spec)
+ system.case_util (spec)
+ system.case_util (body)
+ system.concat_2 (spec)
+ system.concat_2 (body)
+ system.concat_3 (spec)
+ system.concat_3 (body)
+ system.htable (spec)
+ system.parameters (spec)
+ system.parameters (body)
+ system.crtl (spec)
+ interfaces.c_streams (spec)
+ interfaces.c_streams (body)
+ system.restrictions (spec)
+ system.restrictions (body)
+ system.standard_library (spec)
+ system.exceptions (spec)
+ system.exceptions (body)
+ system.storage_elements (spec)
+ system.storage_elements (body)
+ system.secondary_stack (spec)
+ system.stack_checking (spec)
+ system.stack_checking (body)
+ system.string_hash (spec)
+ system.string_hash (body)
+ system.htable (body)
+ system.strings (spec)
+ system.strings (body)
+ system.traceback (spec)
+ system.traceback (body)
+ system.traceback_entries (spec)
+ system.traceback_entries (body)
+ ada.exceptions (spec)
+ ada.exceptions.last_chance_handler (spec)
+ system.soft_links (spec)
+ system.soft_links (body)
+ ada.exceptions.last_chance_handler (body)
+ system.secondary_stack (body)
+ system.exception_table (spec)
+ system.exception_table (body)
+ ada.io_exceptions (spec)
+ ada.tags (spec)
+ ada.streams (spec)
+ interfaces.c (spec)
+ interfaces.c (body)
+ system.finalization_root (spec)
+ system.finalization_root (body)
+ system.memory (spec)
+ system.memory (body)
+ system.standard_library (body)
+ system.os_lib (spec)
+ system.os_lib (body)
+ system.unsigned_types (spec)
+ system.stream_attributes (spec)
+ system.stream_attributes (body)
+ system.finalization_implementation (spec)
+ system.finalization_implementation (body)
+ ada.finalization (spec)
+ ada.finalization (body)
+ ada.finalization.list_controller (spec)
+ ada.finalization.list_controller (body)
+ system.file_control_block (spec)
+ system.file_io (spec)
+ system.file_io (body)
+ system.val_uns (spec)
+ system.val_util (spec)
+ system.val_util (body)
+ system.val_uns (body)
+ system.wch_con (spec)
+ system.wch_con (body)
+ system.wch_cnv (spec)
+ system.wch_jis (spec)
+ system.wch_jis (body)
+ system.wch_cnv (body)
+ system.wch_stw (spec)
+ system.wch_stw (body)
+ ada.tags (body)
+ ada.exceptions (body)
+ ada.text_io (spec)
+ ada.text_io (body)
+ text_io (spec)
+ gdbstr (body)
-- Extra_Accessibility_Of_Result Node19
-- Non_Limited_View Node19
-- Parent_Subtype Node19
+ -- Receiving_Entry Node19
-- Size_Check_Code Node19
-- Spec_Entity Node19
-- Underlying_Full_View Node19
-- Validated_Object Node36
-- Class_Wide_Clone Node38
+
+ -- Protected_Subprogram Node39
+
-- SPARK_Pragma Node40
-- Original_Protected_Subprogram Node41
-- Strict_Alignment Flag145
-- Is_Abstract_Type Flag146
-- Needs_Debug_Info Flag147
- -- Suppress_Elaboration_Warnings Flag148
+ -- Is_Elaboration_Checks_OK_Id Flag148
-- Is_Compilation_Unit Flag149
-- Has_Pragma_Elaborate_Body Flag150
-- Has_Private_Extension Flag300
-- Ignore_SPARK_Mode_Pragmas Flag301
- -- (unused) Flag302
+ -- Is_Initial_Condition_Procedure Flag302
+
-- (unused) Flag303
-- (unused) Flag304
-- (unused) Flag305
return Flag6 (Id);
end Is_Dispatching_Operation;
+ function Is_Elaboration_Checks_OK_Id (Id : E) return B is
+ begin
+ pragma Assert
+ (Ekind_In (Id, E_Constant, E_Variable)
+ or else Is_Entry (Id)
+ or else Is_Generic_Unit (Id)
+ or else Is_Subprogram (Id)
+ or else Is_Task_Type (Id));
+ return Flag148 (Id);
+ end Is_Elaboration_Checks_OK_Id;
+
function Is_Eliminated (Id : E) return B is
begin
return Flag124 (Id);
return Flag268 (Id);
end Is_Independent;
+ function Is_Initial_Condition_Procedure (Id : E) return B is
+ begin
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ return Flag302 (Id);
+ end Is_Initial_Condition_Procedure;
+
function Is_Inlined (Id : E) return B is
begin
return Flag11 (Id);
function Is_Inlined_Always (Id : E) return B is
begin
- pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
return Flag1 (Id);
end Is_Inlined_Always;
return Node22 (Id);
end Protected_Formal;
+ function Protected_Subprogram (Id : E) return N is
+ begin
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ return Node39 (Id);
+ end Protected_Subprogram;
+
function Protection_Object (Id : E) return E is
begin
- pragma Assert
- (Ekind_In (Id, E_Entry, E_Entry_Family, E_Function, E_Procedure));
+ pragma Assert (Ekind_In (Id, E_Entry,
+ E_Entry_Family,
+ E_Function,
+ E_Procedure));
return Node23 (Id);
end Protection_Object;
return Flag49 (Id);
end Reachable;
+ function Receiving_Entry (Id : E) return E is
+ begin
+ pragma Assert (Ekind (Id) = E_Procedure);
+ return Node19 (Id);
+ end Receiving_Entry;
+
function Referenced (Id : E) return B is
begin
return Flag156 (Id);
E_Task_Body,
E_Task_Type)
or else
+ Ekind_In (Id, E_Constant, -- object variants
+ E_Variable)
+ or else
Ekind_In (Id, E_Entry, -- overloadable variants
E_Entry_Family,
E_Function,
E_Package,
E_Package_Body)
or else
- Ekind (Id) = E_Variable); -- variable
+ Ekind (Id) = E_Void); -- special purpose
return Node40 (Id);
end SPARK_Pragma;
E_Protected_Type,
E_Task_Body,
E_Task_Type)
- or else
+ or else
+ Ekind_In (Id, E_Constant, -- object variants
+ E_Variable)
+ or else
Ekind_In (Id, E_Entry, -- overloadable variants
E_Entry_Family,
E_Function,
E_Package,
E_Package_Body)
or else
- Ekind (Id) = E_Variable); -- variable
+ Ekind (Id) = E_Void); -- special purpose
return Flag265 (Id);
end SPARK_Pragma_Inherited;
return Uint24 (Id);
end Subps_Index;
- function Suppress_Elaboration_Warnings (Id : E) return B is
- begin
- return Flag148 (Id);
- end Suppress_Elaboration_Warnings;
-
function Suppress_Initialization (Id : E) return B is
begin
pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Variable);
Set_Flag6 (Id, V);
end Set_Is_Dispatching_Operation;
+ procedure Set_Is_Elaboration_Checks_OK_Id (Id : E; V : B := True) is
+ begin
+ pragma Assert
+ (Ekind_In (Id, E_Constant, E_Variable)
+ or else Is_Entry (Id)
+ or else Is_Generic_Unit (Id)
+ or else Is_Subprogram (Id)
+ or else Is_Task_Type (Id));
+ Set_Flag148 (Id, V);
+ end Set_Is_Elaboration_Checks_OK_Id;
+
procedure Set_Is_Eliminated (Id : E; V : B := True) is
begin
Set_Flag124 (Id, V);
Set_Flag268 (Id, V);
end Set_Is_Independent;
+ procedure Set_Is_Initial_Condition_Procedure (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ Set_Flag302 (Id, V);
+ end Set_Is_Initial_Condition_Procedure;
+
procedure Set_Is_Inlined (Id : E; V : B := True) is
begin
Set_Flag11 (Id, V);
procedure Set_Is_Inlined_Always (Id : E; V : B := True) is
begin
- pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
Set_Flag1 (Id, V);
end Set_Is_Inlined_Always;
Set_Node22 (Id, V);
end Set_Protected_Formal;
+ procedure Set_Protected_Subprogram (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ Set_Node39 (Id, V);
+ end Set_Protected_Subprogram;
+
procedure Set_Protection_Object (Id : E; V : E) is
begin
pragma Assert (Ekind_In (Id, E_Entry,
Set_Flag49 (Id, V);
end Set_Reachable;
+ procedure Set_Receiving_Entry (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind (Id) = E_Procedure);
+ Set_Node19 (Id, V);
+ end Set_Receiving_Entry;
+
procedure Set_Referenced (Id : E; V : B := True) is
begin
Set_Flag156 (Id, V);
E_Protected_Type,
E_Task_Body,
E_Task_Type)
- or else
+ or else
+ Ekind_In (Id, E_Constant, -- object variants
+ E_Variable)
+ or else
Ekind_In (Id, E_Entry, -- overloadable variants
E_Entry_Family,
E_Function,
E_Package,
E_Package_Body)
or else
- Ekind (Id) = E_Variable); -- variable
+ Ekind (Id) = E_Void); -- special purpose
Set_Node40 (Id, V);
end Set_SPARK_Pragma;
E_Protected_Type,
E_Task_Body,
E_Task_Type)
- or else
+ or else
+ Ekind_In (Id, E_Constant, -- object variants
+ E_Variable)
+ or else
Ekind_In (Id, E_Entry, -- overloadable variants
E_Entry_Family,
E_Function,
E_Package,
E_Package_Body)
or else
- Ekind (Id) = E_Variable); -- variable
+ Ekind (Id) = E_Void); -- special purpose
Set_Flag265 (Id, V);
end Set_SPARK_Pragma_Inherited;
Set_Uint24 (Id, V);
end Set_Subps_Index;
- procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True) is
- begin
- Set_Flag148 (Id, V);
- end Set_Suppress_Elaboration_Warnings;
-
procedure Set_Suppress_Initialization (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Variable);
W ("Is_Discriminant_Check_Function", Flag264 (Id));
W ("Is_Dispatch_Table_Entity", Flag234 (Id));
W ("Is_Dispatching_Operation", Flag6 (Id));
+ W ("Is_Elaboration_Checks_OK_Id", Flag148 (Id));
W ("Is_Eliminated", Flag124 (Id));
W ("Is_Entry_Formal", Flag52 (Id));
W ("Is_Exception_Handler", Flag286 (Id));
W ("Is_Implementation_Defined", Flag254 (Id));
W ("Is_Imported", Flag24 (Id));
W ("Is_Independent", Flag268 (Id));
+ W ("Is_Initial_Condition_Procedure", Flag302 (Id));
W ("Is_Inlined", Flag11 (Id));
W ("Is_Inlined_Always", Flag1 (Id));
W ("Is_Instantiated", Flag126 (Id));
W ("Static_Elaboration_Desired", Flag77 (Id));
W ("Stores_Attribute_Old_Prefix", Flag270 (Id));
W ("Strict_Alignment", Flag145 (Id));
- W ("Suppress_Elaboration_Warnings", Flag148 (Id));
W ("Suppress_Initialization", Flag105 (Id));
W ("Suppress_Style_Checks", Flag165 (Id));
W ("Suppress_Value_Tracking_On_Call", Flag217 (Id));
when E_Record_Type =>
Write_Str ("Parent_Subtype");
+ when E_Procedure =>
+ Write_Str ("Receiving_Entry");
+
when E_Constant
| E_Variable
=>
procedure Write_Field39_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
+ when E_Function
+ | E_Procedure
+ =>
+ Write_Str ("Protected_Subprogram");
+
when others =>
Write_Str ("Field39??");
end case;
procedure Write_Field40_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Entry
+ when E_Constant
+ | E_Entry
| E_Entry_Family
| E_Function
| E_Generic_Function
| E_Task_Body
| E_Task_Type
| E_Variable
+ | E_Void
=>
Write_Str ("SPARK_Pragma");
-- Rep_Item chain mechanism, because a single pragma Import can apply
-- to multiple subprogram entities).
--- Incomplete_Actuals (Elist24)
--- Defined on package entities that are instances. Indicates the actuals
--- types in the instantiation that are limited views. If this list is
--- not empty, the instantiation, which appears in a package declaration,
--- is relocated to the corresponding package body, which must have a
--- corresponding nonlimited with_clause.
-
-- In_Package_Body (Flag48)
-- Defined in package entities. Set on the entity that denotes the
-- package (the defining occurrence of the package declaration) while
-- the end of the package declaration. For objects it indicates that the
-- declaration of the object occurs in the private part of a package.
+-- Incomplete_Actuals (Elist24)
+-- Defined on package entities that are instances. Indicates the actuals
+-- types in the instantiation that are limited views. If this list is
+-- not empty, the instantiation, which appears in a package declaration,
+-- is relocated to the corresponding package body, which must have a
+-- corresponding nonlimited with_clause.
+
-- Initialization_Statements (Node28)
-- Defined in constants and variables. For a composite object initialized
-- initialized with an aggregate that has been converted to a sequence
-- Is_Dynamic_Scope (synthesized)
-- Applies to all Entities. Returns True if the entity is a dynamic
--- scope (i.e. a block, subprogram, task_type, entry
--- or extended return statement).
+-- scope (i.e. a block, subprogram, task_type, entry or extended return
+-- statement).
+
+-- Is_Elaboration_Checks_OK_Id (Flag148)
+-- Defined in elaboration targets (see terminology in Sem_Elab). Set when
+-- the target appears in a region which is subject to elabled elaboration
+-- checks. Such targets are allowed to generate run-time conditional ABE
+-- checks or guaranteed ABE failures.
-- Is_Elementary_Type (synthesized)
--- Applies to all entities, true for all elementary types and
--- subtypes. Either Is_Composite_Type or Is_Elementary_Type (but
--- not both) is true of any type.
+-- Applies to all entities, true for all elementary types and subtypes.
+-- Either Is_Composite_Type or Is_Elementary_Type (but not both) is true
+-- of any type.
-- Is_Eliminated (Flag124)
-- Defined in type entities, subprogram entities, and object entities.
-- and incomplete types, this flag is set in both the partial view and
-- the full view.
+-- Is_Initial_Condition_Procedure (Flag302)
+-- Defined in functions and procedures. Set for a generated procedure
+-- which verifies the assumption of pragma Initial_Condition at run time.
+
-- Is_Inlined (Flag11)
-- Defined in all entities. Set for functions and procedures which are
-- to be inlined. For subprograms created during expansion, this flag
-- formal parameter in the unprotected version of the operation that
-- is created during expansion.
+-- Protected_Subprogram (Node39)
+-- Defined in functions and procedures. Set for the pair of subprograms
+-- which emulate the runtime semantics of a protected subprogram. Denotes
+-- the entity of the origial protected subprogram.
+
-- Protection_Object (Node23)
-- Applies to protected entries, entry families and subprograms. Denotes
-- the entity which is used to rename the _object component of protected
-- Defined in labels. The flag is set over the range of statements in
-- which a goto to that label is legal.
+-- Receiving_Entry (Node19)
+-- Defined in procedures. Set for an internally generated procedure which
+-- wraps the original statements of an accept alternative. Designates the
+-- entity of the task entry being accepted.
+
-- Referenced (Flag156)
-- Defined in all entities. Set if the entity is referenced, except for
-- the case of an appearance of a simple variable that is not a renaming
-- in a Relative_Deadline pragma for a task type.
-- Renamed_Entity (Node18)
--- Defined in exceptions, packages, subprograms, and generic units. Set
--- for entities that are defined by a renaming declaration. Denotes the
--- renamed entity, or transitively the ultimate renamed entity if
--- there is a chain of renaming declarations. Empty if no renaming.
+-- Defined in exception, generic unit, package, and subprogram entities.
+-- Set when the entity is defined by a renaming declaration. Denotes the
+-- renamed entity, or transitively the ultimate renamed entity if there
+-- is a chain of renaming declarations. Empty if no renaming.
-- Renamed_In_Spec (Flag231)
-- Defined in package entities. If a package renaming occurs within
-- inherited, rather than a local one.
-- SPARK_Pragma (Node40)
--- Present in concurrent type, entry, operator, [generic] package,
--- package body, [generic] subprogram, subprogram body and variable
--- entities. Points to the N_Pragma node that applies to the initial
--- declaration or body. This is either set by a local SPARK_Mode pragma
--- or is inherited from the context (from an outer scope for the spec
--- case or from the spec for the body case). In the case where it is
--- inherited the flag SPARK_Pragma_Inherited is set. Empty if no
+-- Present in concurrent type, constant, entry, operator, [generic]
+-- package, package body, [generic] subprogram, subprogram body and
+-- variable entities. Points to the N_Pragma node that applies to the
+-- initial declaration or body. This is either set by a local SPARK_Mode
+-- pragma or is inherited from the context (from an outer scope for the
+-- spec case or from the spec for the body case). In the case where it
+-- is inherited the flag SPARK_Pragma_Inherited is set. Empty if no
-- SPARK_Mode pragma is applicable.
-- SPARK_Pragma_Inherited (Flag265)
--- Present in concurrent type, entry, operator, [generic] package,
--- package body, [generic] subprogram, subprogram body and variable
--- entities. Set if the SPARK_Pragma attribute points to a pragma that is
--- inherited, rather than a local one.
+-- Present in concurrent type, constant, entry, operator, [generic]
+-- package, package body, [generic] subprogram, subprogram body and
+-- variable entities. Set if the SPARK_Pragma attribute points to a
+-- pragma that is inherited, rather than a local one.
-- Spec_Entity (Node19)
-- Defined in package body entities. Points to corresponding package
-- for the outer level subprogram, this is the starting index in the Subp
-- table for the entries for this subprogram.
--- Suppress_Elaboration_Warnings (Flag148)
--- Defined in all entities, can be set only for subprogram entities and
--- for variables. If this flag is set then Sem_Elab will not generate
--- elaboration warnings for the subprogram or variable. Suppression of
--- such warnings is automatic for subprograms for which elaboration
--- checks are suppressed (without the need to set this flag), but the
--- flag is also set for various internal entities (such as init procs)
--- which are known not to generate any possible access before
--- elaboration, and it is set on variables when a warning is given to
--- avoid multiple elaboration warnings for the same variable.
-
-- Suppress_Initialization (Flag105)
-- Defined in all variable, type and subtype entities. If set for a base
-- type, then the generation of initialization procedures is suppressed
-- Referenced (Flag156)
-- Referenced_As_LHS (Flag36)
-- Referenced_As_Out_Parameter (Flag227)
- -- Suppress_Elaboration_Warnings (Flag148)
-- Suppress_Style_Checks (Flag165)
-- Suppress_Value_Tracking_On_Call (Flag217)
-- Used_As_Generic_Actual (Flag222)
-- Encapsulating_State (Node32) (constants only)
-- Linker_Section_Pragma (Node33)
-- Contract (Node34) (constants only)
+ -- SPARK_Pragma (Node40) (constants only)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
-- Has_Thunks (Flag228) (constants only)
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
+ -- Is_Elaboration_Checks_OK_Id (Flag148) (constants only)
-- Is_Eliminated (Flag124)
-- Is_Finalized_Transient (Flag252)
-- Is_Ignored_Transient (Flag295)
-- Is_Volatile_Full_Access (Flag285)
-- Optimize_Alignment_Space (Flag241) (constants only)
-- Optimize_Alignment_Time (Flag242) (constants only)
+ -- SPARK_Pragma_Inherited (Flag265) (constants only)
-- Stores_Attribute_Old_Prefix (Flag270) (constants only)
-- Treat_As_Volatile (Flag41)
-- Address_Clause (synth)
-- Entry_Accepted (Flag152)
-- Has_Expanded_Contract (Flag240)
-- Ignore_SPARK_Mode_Pragmas (Flag301)
+ -- Is_Elaboration_Checks_OK_Id (Flag148)
-- Is_Entry_Wrapper (Flag297)
-- Needs_No_Actuals (Flag22)
-- Sec_Stack_Needed_For_Return (Flag167)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
-- Class_Wide_Clone (Node38)
+ -- Protected_Subprogram (Node39) (non-generic case only)
-- SPARK_Pragma (Node40)
-- Original_Protected_Subprogram (Node41)
-- Body_Needed_For_SAL (Flag40)
-- Is_DIC_Procedure (Flag132) (non-generic case only)
-- Is_Discrim_SO_Function (Flag176)
-- Is_Discriminant_Check_Function (Flag264)
+ -- Is_Elaboration_Checks_OK_Id (Flag148)
-- Is_Eliminated (Flag124)
-- Is_Generic_Actual_Subprogram (Flag274) (non-generic case only)
-- Is_Hidden_Non_Overridden_Subpgm (Flag2) (non-generic case only)
+ -- Is_Initial_Condition_Procedure (Flag302) (non-generic case only)
-- Is_Inlined_Always (Flag1) (non-generic case only)
-- Is_Instantiated (Flag126) (generic case only)
-- Is_Intrinsic_Subprogram (Flag64)
-- Default_Expressions_Processed (Flag108)
-- Has_Nested_Subprogram (Flag282)
-- Ignore_SPARK_Mode_Pragmas (Flag301)
+ -- Is_Elaboration_Checks_OK_Id (Flag148)
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Machine_Code_Subprogram (Flag137)
-- Is_Primitive (Flag218)
-- Ignore_SPARK_Mode_Pragmas (Flag301)
-- In_Package_Body (Flag48)
-- In_Use (Flag8)
+ -- Is_Elaboration_Checks_OK_Id (Flag148)
-- Is_Instantiated (Flag126)
-- Is_Private_Descendant (Flag53)
-- Is_Visible_Lib_Unit (Flag116)
-- First_Entity (Node17)
-- Alias (Node18) (non-generic case only)
-- Renamed_Entity (Node18) (generic case only)
+ -- Receiving_Entry (Node19) (non-generic case only)
-- Last_Entity (Node20)
-- Interface_Name (Node21)
-- Scope_Depth_Value (Uint22)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
-- Class_Wide_Clone (Node38)
+ -- Protected_Subprogram (Node39) (non-generic case only)
-- SPARK_Pragma (Node40)
-- Original_Protected_Subprogram (Node41)
-- Body_Needed_For_SAL (Flag40)
-- Is_Called (Flag102) (non-generic case only)
-- Is_Constructor (Flag76)
-- Is_DIC_Procedure (Flag132) (non-generic case only)
+ -- Is_Elaboration_Checks_OK_Id (Flag148)
-- Is_Eliminated (Flag124)
-- Is_Generic_Actual_Subprogram (Flag274) (non-generic case only)
-- Is_Hidden_Non_Overridden_Subpgm (Flag2) (non-generic case only)
+ -- Is_Initial_Condition_Procedure (Flag302) (non-generic case only)
-- Is_Inlined_Always (Flag1) (non-generic case only)
-- Is_Instantiated (Flag126) (generic case only)
-- Is_Interrupt_Handler (Flag89)
-- Has_Master_Entity (Flag21)
-- Has_Storage_Size_Clause (Flag23) (base type only)
-- Ignore_SPARK_Mode_Pragmas (Flag301)
+ -- Is_Elaboration_Checks_OK_Id (Flag148)
-- SPARK_Aux_Pragma_Inherited (Flag266)
-- SPARK_Pragma_Inherited (Flag265)
-- First_Component (synth)
-- Has_Size_Clause (Flag29)
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
+ -- Is_Elaboration_Checks_OK_Id (Flag148)
-- Is_Eliminated (Flag124)
-- Is_Finalized_Transient (Flag252)
-- Is_Ignored_Transient (Flag295)
function Is_Discriminant_Check_Function (Id : E) return B;
function Is_Dispatch_Table_Entity (Id : E) return B;
function Is_Dispatching_Operation (Id : E) return B;
+ function Is_Elaboration_Checks_OK_Id (Id : E) return B;
function Is_Eliminated (Id : E) return B;
function Is_Entry_Formal (Id : E) return B;
function Is_Entry_Wrapper (Id : E) return B;
function Is_Implementation_Defined (Id : E) return B;
function Is_Imported (Id : E) return B;
function Is_Independent (Id : E) return B;
+ function Is_Initial_Condition_Procedure (Id : E) return B;
function Is_Inlined (Id : E) return B;
function Is_Inlined_Always (Id : E) return B;
function Is_Instantiated (Id : E) return B;
function Private_View (Id : E) return N;
function Protected_Body_Subprogram (Id : E) return E;
function Protected_Formal (Id : E) return E;
+ function Protected_Subprogram (Id : E) return N;
function Protection_Object (Id : E) return E;
function Reachable (Id : E) return B;
+ function Receiving_Entry (Id : E) return E;
function Referenced (Id : E) return B;
function Referenced_As_LHS (Id : E) return B;
function Referenced_As_Out_Parameter (Id : E) return B;
function String_Literal_Low_Bound (Id : E) return N;
function Subprograms_For_Type (Id : E) return L;
function Subps_Index (Id : E) return U;
- function Suppress_Elaboration_Warnings (Id : E) return B;
function Suppress_Initialization (Id : E) return B;
function Suppress_Style_Checks (Id : E) return B;
function Suppress_Value_Tracking_On_Call (Id : E) return B;
procedure Set_Is_Discriminant_Check_Function (Id : E; V : B := True);
procedure Set_Is_Dispatch_Table_Entity (Id : E; V : B := True);
procedure Set_Is_Dispatching_Operation (Id : E; V : B := True);
+ procedure Set_Is_Elaboration_Checks_OK_Id (Id : E; V : B := True);
procedure Set_Is_Eliminated (Id : E; V : B := True);
procedure Set_Is_Entry_Formal (Id : E; V : B := True);
procedure Set_Is_Entry_Wrapper (Id : E; V : B := True);
procedure Set_Is_Implementation_Defined (Id : E; V : B := True);
procedure Set_Is_Imported (Id : E; V : B := True);
procedure Set_Is_Independent (Id : E; V : B := True);
+ procedure Set_Is_Initial_Condition_Procedure (Id : E; V : B := True);
procedure Set_Is_Inlined (Id : E; V : B := True);
procedure Set_Is_Inlined_Always (Id : E; V : B := True);
procedure Set_Is_Instantiated (Id : E; V : B := True);
procedure Set_Private_View (Id : E; V : N);
procedure Set_Protected_Body_Subprogram (Id : E; V : E);
procedure Set_Protected_Formal (Id : E; V : E);
+ procedure Set_Protected_Subprogram (Id : E; V : N);
procedure Set_Protection_Object (Id : E; V : E);
procedure Set_Reachable (Id : E; V : B := True);
+ procedure Set_Receiving_Entry (Id : E; V : E);
procedure Set_Referenced (Id : E; V : B := True);
procedure Set_Referenced_As_LHS (Id : E; V : B := True);
procedure Set_Referenced_As_Out_Parameter (Id : E; V : B := True);
procedure Set_String_Literal_Low_Bound (Id : E; V : N);
procedure Set_Subprograms_For_Type (Id : E; V : L);
procedure Set_Subps_Index (Id : E; V : U);
- procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True);
procedure Set_Suppress_Initialization (Id : E; V : B := True);
procedure Set_Suppress_Style_Checks (Id : E; V : B := True);
procedure Set_Suppress_Value_Tracking_On_Call (Id : E; V : B := True);
pragma Inline (Is_Discriminant_Check_Function);
pragma Inline (Is_Dispatch_Table_Entity);
pragma Inline (Is_Dispatching_Operation);
+ pragma Inline (Is_Elaboration_Checks_OK_Id);
pragma Inline (Is_Elementary_Type);
pragma Inline (Is_Eliminated);
pragma Inline (Is_Entry);
pragma Inline (Is_Incomplete_Or_Private_Type);
pragma Inline (Is_Incomplete_Type);
pragma Inline (Is_Independent);
+ pragma Inline (Is_Initial_Condition_Procedure);
pragma Inline (Is_Inlined);
pragma Inline (Is_Inlined_Always);
pragma Inline (Is_Instantiated);
pragma Inline (Private_View);
pragma Inline (Protected_Body_Subprogram);
pragma Inline (Protected_Formal);
+ pragma Inline (Protected_Subprogram);
pragma Inline (Protection_Object);
pragma Inline (Reachable);
+ pragma Inline (Receiving_Entry);
pragma Inline (Referenced);
pragma Inline (Referenced_As_LHS);
pragma Inline (Referenced_As_Out_Parameter);
pragma Inline (String_Literal_Low_Bound);
pragma Inline (Subprograms_For_Type);
pragma Inline (Subps_Index);
- pragma Inline (Suppress_Elaboration_Warnings);
pragma Inline (Suppress_Initialization);
pragma Inline (Suppress_Style_Checks);
pragma Inline (Suppress_Value_Tracking_On_Call);
pragma Inline (Set_Is_Discriminant_Check_Function);
pragma Inline (Set_Is_Dispatch_Table_Entity);
pragma Inline (Set_Is_Dispatching_Operation);
+ pragma Inline (Set_Is_Elaboration_Checks_OK_Id);
pragma Inline (Set_Is_Eliminated);
pragma Inline (Set_Is_Entry_Formal);
pragma Inline (Set_Is_Entry_Wrapper);
pragma Inline (Set_Is_Implementation_Defined);
pragma Inline (Set_Is_Imported);
pragma Inline (Set_Is_Independent);
+ pragma Inline (Set_Is_Initial_Condition_Procedure);
pragma Inline (Set_Is_Inlined);
pragma Inline (Set_Is_Inlined_Always);
pragma Inline (Set_Is_Instantiated);
pragma Inline (Set_Private_View);
pragma Inline (Set_Protected_Body_Subprogram);
pragma Inline (Set_Protected_Formal);
+ pragma Inline (Set_Protected_Subprogram);
pragma Inline (Set_Protection_Object);
pragma Inline (Set_Reachable);
+ pragma Inline (Set_Receiving_Entry);
pragma Inline (Set_Referenced);
pragma Inline (Set_Referenced_As_LHS);
pragma Inline (Set_Referenced_As_Out_Parameter);
pragma Inline (Set_String_Literal_Low_Bound);
pragma Inline (Set_Subprograms_For_Type);
pragma Inline (Set_Subps_Index);
- pragma Inline (Set_Suppress_Elaboration_Warnings);
pragma Inline (Set_Suppress_Initialization);
pragma Inline (Set_Suppress_Style_Checks);
pragma Inline (Set_Suppress_Value_Tracking_On_Call);
and then not Restriction_Active (No_Exception_Propagation)
then
declare
- DF_Call : Node_Id;
- DF_Id : Entity_Id;
+ DF_Id : Entity_Id;
begin
-- Create a local version of Deep_Finalize which has indication
-- of partial initialization state.
- DF_Id := Make_Temporary (Loc, 'F');
+ DF_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Name_uFinalizer));
Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id));
- DF_Call :=
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (DF_Id, Loc),
- Parameter_Associations => New_List (
- Make_Identifier (Loc, Name_uInit),
- New_Occurrence_Of (Standard_False, Loc)));
-
- -- Do not emit warnings related to the elaboration order when a
- -- controlled object is declared before the body of Finalize is
- -- seen.
-
- Set_No_Elaboration_Check (DF_Call);
-
Set_Exception_Handlers (Handled_Stmt_Node, New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (
Make_Others_Choice (Loc)),
Statements => New_List (
- DF_Call,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (DF_Id, Loc),
+ Parameter_Associations => New_List (
+ Make_Identifier (Loc, Name_uInit),
+ New_Occurrence_Of (Standard_False, Loc))),
+
Make_Raise_Statement (Loc)))));
end;
else
Aggr_Init : Node_Id;
Comp_Init : List_Id := No_List;
+ Fin_Block : Node_Id;
Fin_Call : Node_Id;
Init_Stmts : List_Id := No_List;
Obj_Init : Node_Id := Empty;
Skip_Self => True);
if Present (Fin_Call) then
-
- -- Do not emit warnings related to the elaboration order when a
- -- controlled object is declared before the body of Finalize is
- -- seen.
-
- Set_No_Elaboration_Check (Fin_Call);
-
- Append_To (Init_Stmts,
+ Fin_Block :=
Make_Block_Statement (Loc,
Declarations => No_List,
Statements => New_List (
Fin_Call,
- Make_Raise_Statement (Loc)))))));
+ Make_Raise_Statement (Loc))))));
+
+ -- Signal the ABE mechanism that the block carries out
+ -- initialization actions.
+
+ Set_Is_Initialization_Block (Fin_Block);
+
+ Append_To (Init_Stmts, Fin_Block);
end if;
-- Otherwise finalization is not required, the initialization calls
Function_Call : Node_Id)
is
Acc_Type : constant Entity_Id := Etype (Allocator);
- Loc : Source_Ptr;
+ Loc : constant Source_Ptr := Sloc (Function_Call);
Func_Call : Node_Id := Function_Call;
Ref_Func_Call : Node_Id;
Function_Id : Entity_Id;
pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call));
Set_Is_Expanded_Build_In_Place_Call (Func_Call);
- Loc := Sloc (Function_Call);
-
if Is_Entity_Name (Name (Func_Call)) then
Function_Id := Entity (Name (Func_Call));
Rewrite (Allocator, New_Allocator);
-- Initial value of the temp is the result of the uninitialized
- -- allocator
+ -- allocator. Unchecked_Convert is needed for T'Input where T is
+ -- derived from a controlled type.
Temp_Init := Relocate_Node (Allocator);
+ if Nkind_In
+ (Function_Call, N_Type_Conversion, N_Unchecked_Type_Conversion)
+ then
+ Temp_Init := Unchecked_Convert_To (Acc_Type, Temp_Init);
+ end if;
+
-- Indicate that caller allocates, and pass in the return object
Alloc_Form := Caller_Allocation;
Rewrite
(Ref_Func_Call,
OK_Convert_To (Acc_Type, Ref_Func_Call));
+
+ -- If the types are incompatible, we need an unchecked conversion. Note
+ -- that the full types will be compatible, but the types not visibly
+ -- compatible.
+
+ elsif Nkind_In
+ (Function_Call, N_Type_Conversion, N_Unchecked_Type_Conversion)
+ then
+ Ref_Func_Call := Unchecked_Convert_To (Acc_Type, Ref_Func_Call);
end if;
declare
-- caller-allocates case, this is overwriting the temp with its
-- initial value, which has no effect. In the callee-allocates case,
-- this is setting the temp to point to the object allocated by the
- -- callee.
+ -- callee. Unchecked_Convert is needed for T'Input where T is derived
+ -- from a controlled type.
Actions : List_Id;
-- Actions to be inserted. If there are no tasks, this is just the
procedure Make_Build_In_Place_Call_In_Anonymous_Context
(Function_Call : Node_Id)
is
- Loc : Source_Ptr;
+ Loc : constant Source_Ptr := Sloc (Function_Call);
Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
Function_Id : Entity_Id;
Result_Subt : Entity_Id;
Set_Is_Expanded_Build_In_Place_Call (Func_Call);
- Loc := Sloc (Function_Call);
-
if Is_Entity_Name (Name (Func_Call)) then
Function_Id := Entity (Name (Func_Call));
New_Occurrence_Of (Designated_Type, Obj_Loc),
Name => Call_Deref));
- Set_Renamed_Object (Obj_Def_Id, Call_Deref);
+ -- At this point, Defining_Identifier (Obj_Decl) is no longer equal
+ -- to Obj_Def_Id.
+
+ Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref);
-- If the original entity comes from source, then mark the new
-- entity as needing debug information, even though it's defined
-- Debug_Renaming_Declaration is called during analysis.
if Comes_From_Source (Obj_Def_Id) then
- Set_Debug_Info_Needed (Obj_Def_Id);
+ Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl));
end if;
Analyze (Obj_Decl);
-- procedures of types Init_Typ or Obj_Typ.
function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
- -- Given a statement which is part of a list, return the next
- -- statement while skipping over dynamic elab checks.
+ -- Obtain the next statement which follows list member Stmt while
+ -- ignoring artifacts related to access-before-elaboration checks.
-----------------------------
-- Find_Last_Init_In_Block --
-----------------------------
function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
- Result : Node_Id := Next (Stmt);
+ Result : Node_Id;
begin
- -- Skip over access-before-elaboration checks
+ -- Skip call markers and Program_Error raises installed by the
+ -- ABE mechanism.
+
+ Result := Next (Stmt);
+ while Present (Result) loop
+ if not Nkind_In (Result, N_Call_Marker,
+ N_Raise_Program_Error)
+ then
+ exit;
+ end if;
- if Dynamic_Elaboration_Checks
- and then Nkind (Result) = N_Raise_Program_Error
- then
Result := Next (Result);
- end if;
+ end loop;
return Result;
end Next_Suitable_Statement;
-- This is done only for non-generic packages
if Ekind (Spec_Id) = E_Package then
- Push_Scope (Corresponding_Spec (N));
+ Push_Scope (Spec_Id);
-- Build dispatch tables of library level tagged types
Build_Task_Activation_Call (N);
- -- When the package is subject to pragma Initial_Condition, the
- -- assertion expression must be verified at the end of the body
- -- statements.
+ -- Verify the run-time semantics of pragma Initial_Condition at the
+ -- end of the body statements.
- if Present (Get_Pragma (Spec_Id, Pragma_Initial_Condition)) then
- Expand_Pragma_Initial_Condition (N);
- end if;
+ Expand_Pragma_Initial_Condition (Spec_Id, N);
Pop_Scope;
end if;
- Set_Elaboration_Flag (N, Corresponding_Spec (N));
+ Set_Elaboration_Flag (N, Spec_Id);
Set_In_Package_Body (Spec_Id, False);
-- Set to encode entity names in package body before gigi is called
Build_Task_Activation_Call (N);
end if;
- -- When the package is subject to pragma Initial_Condition and lacks
- -- a body, the assertion expression must be verified at the end of
- -- the visible declarations. Otherwise the check is performed at the
- -- end of the body statements (see Expand_N_Package_Body).
+ -- Verify the run-time semantics of pragma Initial_Condition at the
+ -- end of the private declarations when the package lacks a body.
- if Present (Get_Pragma (Id, Pragma_Initial_Condition)) then
- Expand_Pragma_Initial_Condition (N);
- end if;
+ Expand_Pragma_Initial_Condition (Id, N);
Pop_Scope;
end if;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch9; use Sem_Ch9;
with Sem_Ch11; use Sem_Ch11;
-with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
Set_Original_Protected_Subprogram (New_Id, Def_Id);
end if;
+ -- Link the protected or unprotected version to the original subprogram
+ -- it emulates.
+
+ Set_Ekind (New_Id, Ekind (Def_Id));
+ Set_Protected_Subprogram (New_Id, Def_Id);
+
-- The unprotected operation carries the user code, and debugging
-- information must be generated for it, even though this spec does
-- not come from source. It is also convenient to allow gdb to step
--------------------------------
procedure Build_Task_Activation_Call (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
+ function Activation_Call_Loc return Source_Ptr;
+ -- Find a suitable source location for the activation call
+
+ -------------------------
+ -- Activation_Call_Loc --
+ -------------------------
+
+ function Activation_Call_Loc return Source_Ptr is
+ begin
+ -- The activation call must carry the location of the "end" keyword
+ -- when the context is a package declaration.
+
+ if Nkind (N) = N_Package_Declaration then
+ return End_Keyword_Location (N);
+
+ -- Otherwise the activation call must carry the location of the
+ -- "begin" keyword.
+
+ else
+ return Begin_Keyword_Location (N);
+ end if;
+ end Activation_Call_Loc;
+
+ -- Local variables
+
Chain : Entity_Id;
Call : Node_Id;
+ Loc : Source_Ptr;
Name : Node_Id;
- P : Node_Id;
+ Owner : Node_Id;
+ Stmt : Node_Id;
+
+ -- Start of processing for Build_Task_Activation_Call
begin
-- For sequential elaboration policy, all the tasks will be activated at
if Partition_Elaboration_Policy = 'S' then
return;
- end if;
- -- Get the activation chain entity. Except in the case of a package
- -- body, this is in the node that was passed. For a package body, we
- -- have to find the corresponding package declaration node.
+ -- Do not create an activation call for a package spec if the package
+ -- has a completing body. The activation call will be inserted after
+ -- the "begin" of the body.
- if Nkind (N) = N_Package_Body then
- P := Corresponding_Spec (N);
- loop
- P := Parent (P);
- exit when Nkind (P) = N_Package_Declaration;
- end loop;
+ elsif Nkind (N) = N_Package_Declaration
+ and then Present (Corresponding_Body (N))
+ then
+ return;
+ end if;
- Chain := Activation_Chain_Entity (P);
+ -- Obtain the activation chain entity. Block statements, entry bodies,
+ -- subprogram bodies, and task bodies keep the entity in their nodes.
+ -- Package bodies on the other hand store it in the declaration of the
+ -- corresponding package spec.
- else
- Chain := Activation_Chain_Entity (N);
+ Owner := N;
+
+ if Nkind (Owner) = N_Package_Body then
+ Owner := Unit_Declaration_Node (Corresponding_Spec (Owner));
end if;
- if Present (Chain) then
- if Restricted_Profile then
- Name := New_Occurrence_Of
- (RTE (RE_Activate_Restricted_Tasks), Loc);
- else
- Name := New_Occurrence_Of
- (RTE (RE_Activate_Tasks), Loc);
- end if;
+ Chain := Activation_Chain_Entity (Owner);
- Call :=
- Make_Procedure_Call_Statement (Loc,
- Name => Name,
- Parameter_Associations =>
- New_List (Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Chain, Loc),
- Attribute_Name => Name_Unchecked_Access)));
+ -- Nothing to do when there are no tasks to activate. This is indicated
+ -- by a missing activation chain entity.
- if Nkind (N) = N_Package_Declaration then
- if Present (Corresponding_Body (N)) then
- null;
+ if No (Chain) then
+ return;
+ end if;
- elsif Present (Private_Declarations (Specification (N))) then
- Append (Call, Private_Declarations (Specification (N)));
+ -- The location of the activation call must be as close as possible to
+ -- the intended semantic location of the activation because the ABE
+ -- mechanism relies heavily on accurate locations.
- else
- Append (Call, Visible_Declarations (Specification (N)));
- end if;
+ Loc := Activation_Call_Loc;
- else
- if Present (Handled_Statement_Sequence (N)) then
+ if Restricted_Profile then
+ Name := New_Occurrence_Of (RTE (RE_Activate_Restricted_Tasks), Loc);
+ else
+ Name := New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc);
+ end if;
- -- The call goes at the start of the statement sequence after
- -- the start of exception range label if one is present.
+ Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name => Name,
+ Parameter_Associations =>
+ New_List (Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Chain, Loc),
+ Attribute_Name => Name_Unchecked_Access)));
- declare
- Stm : Node_Id;
+ if Nkind (N) = N_Package_Declaration then
+ if Present (Private_Declarations (Specification (N))) then
+ Append (Call, Private_Declarations (Specification (N)));
+ else
+ Append (Call, Visible_Declarations (Specification (N)));
+ end if;
- begin
- Stm := First (Statements (Handled_Statement_Sequence (N)));
+ else
+ -- The call goes at the start of the statement sequence after the
+ -- start of exception range label if one is present.
- -- A special case, skip exception range label if one is
- -- present (from front end zcx processing).
+ if Present (Handled_Statement_Sequence (N)) then
+ Stmt := First (Statements (Handled_Statement_Sequence (N)));
- if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then
- Next (Stm);
- end if;
+ -- A special case, skip exception range label if one is present
+ -- (from front end zcx processing).
- -- Another special case, if the first statement is a block
- -- from optimization of a local raise to a goto, then the
- -- call goes inside this block.
+ if Nkind (Stmt) = N_Label and then Exception_Junk (Stmt) then
+ Next (Stmt);
+ end if;
- if Nkind (Stm) = N_Block_Statement
- and then Exception_Junk (Stm)
- then
- Stm :=
- First (Statements (Handled_Statement_Sequence (Stm)));
- end if;
+ -- Another special case, if the first statement is a block from
+ -- optimization of a local raise to a goto, then the call goes
+ -- inside this block.
- -- Insertion point is after any exception label pushes,
- -- since we want it covered by any local handlers.
+ if Nkind (Stmt) = N_Block_Statement
+ and then Exception_Junk (Stmt)
+ then
+ Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
+ end if;
- while Nkind (Stm) in N_Push_xxx_Label loop
- Next (Stm);
- end loop;
+ -- Insertion point is after any exception label pushes, since we
+ -- want it covered by any local handlers.
- -- Now we have the proper insertion point
+ while Nkind (Stmt) in N_Push_xxx_Label loop
+ Next (Stmt);
+ end loop;
- Insert_Before (Stm, Call);
- end;
+ -- Now we have the proper insertion point
- else
- Set_Handled_Statement_Sequence (N,
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Call)));
- end if;
- end if;
+ Insert_Before (Stmt, Call);
- Analyze (Call);
- Check_Task_Activation (N);
+ else
+ Set_Handled_Statement_Sequence (N,
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Call)));
+ end if;
end if;
+
+ Analyze (Call);
end Build_Task_Activation_Call;
-------------------------------
Make_Defining_Identifier (Eloc,
New_External_Name (Chars (Ename), 'A', Num_Accept));
+ -- Link the acceptor to the original receiving entry
+
+ Set_Ekind (PB_Ent, E_Procedure);
+ Set_Receiving_Entry (PB_Ent, Eent);
+
if Comes_From_Source (Alt) then
Set_Debug_Info_Needed (PB_Ent);
end if;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
-- Expand_Pragma_Initial_Condition --
-------------------------------------
- procedure Expand_Pragma_Initial_Condition (Spec_Or_Body : Node_Id) is
- Loc : constant Source_Ptr := Sloc (Spec_Or_Body);
+ procedure Expand_Pragma_Initial_Condition
+ (Pack_Id : Entity_Id;
+ N : Node_Id)
+ is
+ procedure Extract_Package_Body_Lists
+ (Pack_Body : Node_Id;
+ Body_List : out List_Id;
+ Call_List : out List_Id;
+ Spec_List : out List_Id);
+ -- Obtain the various declarative and statement lists of package body
+ -- Pack_Body needed to insert the initial condition procedure and the
+ -- call to it. The lists are as follows:
+ --
+ -- * Body_List - used to insert the initial condition procedure body
+ --
+ -- * Call_List - used to insert the call to the initial condition
+ -- procedure.
+ --
+ -- * Spec_List - used to insert the initial condition procedure spec
+
+ procedure Extract_Package_Declaration_Lists
+ (Pack_Decl : Node_Id;
+ Body_List : out List_Id;
+ Call_List : out List_Id;
+ Spec_List : out List_Id);
+ -- Obtain the various declarative lists of package declaration Pack_Decl
+ -- needed to insert the initial condition procedure and the call to it.
+ -- The lists are as follows:
+ --
+ -- * Body_List - used to insert the initial condition procedure body
+ --
+ -- * Call_List - used to insert the call to the initial condition
+ -- procedure.
+ --
+ -- * Spec_List - used to insert the initial condition procedure spec
+
+ --------------------------------
+ -- Extract_Package_Body_Lists --
+ --------------------------------
+
+ procedure Extract_Package_Body_Lists
+ (Pack_Body : Node_Id;
+ Body_List : out List_Id;
+ Call_List : out List_Id;
+ Spec_List : out List_Id)
+ is
+ Pack_Spec : constant Entity_Id := Corresponding_Spec (Pack_Body);
- Check : Node_Id;
- Expr : Node_Id;
- Init_Cond : Node_Id;
- List : List_Id;
- Pack_Id : Entity_Id;
+ Dummy_1 : List_Id;
+ Dummy_2 : List_Id;
+ HSS : Node_Id;
- begin
- if Nkind (Spec_Or_Body) = N_Package_Body then
- Pack_Id := Corresponding_Spec (Spec_Or_Body);
+ begin
+ pragma Assert (Present (Pack_Spec));
- if Present (Handled_Statement_Sequence (Spec_Or_Body)) then
- List := Statements (Handled_Statement_Sequence (Spec_Or_Body));
+ -- The different parts of the invariant procedure are inserted as
+ -- follows:
- -- The package body lacks statements, create an empty list
+ -- package Pack is package body Pack is
+ -- <IC spec> <IC body>
+ -- private begin
+ -- ... <IC call>
+ -- end Pack; end Pack;
- else
- List := New_List;
+ -- The initial condition procedure spec is inserted in the visible
+ -- declaration of the corresponding package spec.
+
+ Extract_Package_Declaration_Lists
+ (Pack_Decl => Unit_Declaration_Node (Pack_Spec),
+ Body_List => Dummy_1,
+ Call_List => Dummy_2,
+ Spec_List => Spec_List);
+
+ -- The initial condition procedure body is added to the declarations
+ -- of the package body.
+
+ Body_List := Declarations (Pack_Body);
- Set_Handled_Statement_Sequence (Spec_Or_Body,
- Make_Handled_Sequence_Of_Statements (Loc, Statements => List));
+ if No (Body_List) then
+ Body_List := New_List;
+ Set_Declarations (Pack_Body, Body_List);
end if;
- elsif Nkind (Spec_Or_Body) = N_Package_Declaration then
- Pack_Id := Defining_Entity (Spec_Or_Body);
+ -- The call to the initial condition procedure is inserted in the
+ -- statements of the package body.
- if Present (Visible_Declarations (Specification (Spec_Or_Body))) then
- List := Visible_Declarations (Specification (Spec_Or_Body));
+ HSS := Handled_Statement_Sequence (Pack_Body);
- -- The package lacks visible declarations, create an empty list
+ if No (HSS) then
+ HSS :=
+ Make_Handled_Sequence_Of_Statements (Sloc (Pack_Body),
+ Statements => New_List);
+ Set_Handled_Statement_Sequence (Pack_Body, HSS);
+ end if;
- else
- List := New_List;
+ Call_List := Statements (HSS);
+ end Extract_Package_Body_Lists;
+
+ ---------------------------------------
+ -- Extract_Package_Declaration_Lists --
+ ---------------------------------------
+
+ procedure Extract_Package_Declaration_Lists
+ (Pack_Decl : Node_Id;
+ Body_List : out List_Id;
+ Call_List : out List_Id;
+ Spec_List : out List_Id)
+ is
+ Pack_Spec : constant Node_Id := Specification (Pack_Decl);
+
+ begin
+ -- The different parts of the invariant procedure are inserted as
+ -- follows:
- Set_Visible_Declarations (Specification (Spec_Or_Body), List);
+ -- package Pack is
+ -- <IC spec>
+ -- <IC body>
+ -- private
+ -- <IC call>
+ -- end Pack;
+
+ -- The initial condition procedure spec and body are inserted in the
+ -- visible declarations of the package spec.
+
+ Body_List := Visible_Declarations (Pack_Spec);
+
+ if No (Body_List) then
+ Body_List := New_List;
+ Set_Visible_Declarations (Pack_Spec, Body_List);
+ end if;
+
+ Spec_List := Body_List;
+
+ -- The call to the initial procedure is inserted in the private
+ -- declarations of the package spec.
+
+ Call_List := Private_Declarations (Pack_Spec);
+
+ if No (Call_List) then
+ Call_List := New_List;
+ Set_Private_Declarations (Pack_Spec, Call_List);
end if;
+ end Extract_Package_Declaration_Lists;
+
+ -- Local variables
+
+ IC_Prag : constant Node_Id :=
+ Get_Pragma (Pack_Id, Pragma_Initial_Condition);
+
+ Body_List : List_Id;
+ Call : Node_Id;
+ Call_List : List_Id;
+ Call_Loc : Source_Ptr;
+ Expr : Node_Id;
+ Loc : Source_Ptr;
+ Proc_Body : Node_Id;
+ Proc_Body_Id : Entity_Id;
+ Proc_Decl : Node_Id;
+ Proc_Id : Entity_Id;
+ Spec_List : List_Id;
+
+ -- Start of processing for Expand_Pragma_Initial_Condition
+
+ begin
+ -- Nothing to do when the package is not subject to an Initial_Condition
+ -- pragma.
+
+ if No (IC_Prag) then
+ return;
+ end if;
+
+ Expr := Get_Pragma_Arg (First (Pragma_Argument_Associations (IC_Prag)));
+ Loc := Sloc (IC_Prag);
+
+ -- Nothing to do when the pragma or its argument are illegal because
+ -- there is no valid expression to check.
+
+ if Error_Posted (IC_Prag) or else Error_Posted (Expr) then
+ return;
+ end if;
+
+ -- Obtain the various lists of the context where the individual pieces
+ -- of the initial condition procedure are to be inserted.
+
+ if Nkind (N) = N_Package_Body then
+ Extract_Package_Body_Lists
+ (Pack_Body => N,
+ Body_List => Body_List,
+ Call_List => Call_List,
+ Spec_List => Spec_List);
+
+ elsif Nkind (N) = N_Package_Declaration then
+ Extract_Package_Declaration_Lists
+ (Pack_Decl => N,
+ Body_List => Body_List,
+ Call_List => Call_List,
+ Spec_List => Spec_List);
-- This routine should not be used on anything other than packages
else
- raise Program_Error;
+ pragma Assert (False);
+ return;
end if;
- Init_Cond := Get_Pragma (Pack_Id, Pragma_Initial_Condition);
+ Proc_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Pack_Id), "Initial_Condition"));
- -- The caller should check whether the package is subject to pragma
- -- Initial_Condition.
+ Set_Ekind (Proc_Id, E_Procedure);
+ Set_Is_Initial_Condition_Procedure (Proc_Id);
- pragma Assert (Present (Init_Cond));
+ -- Generate:
+ -- procedure <Pack_Id>Initial_Condition;
- Expr :=
- Get_Pragma_Arg (First (Pragma_Argument_Associations (Init_Cond)));
+ Proc_Decl :=
+ Make_Subprogram_Declaration (Loc,
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Proc_Id));
- -- The assertion expression was found to be illegal, do not generate the
- -- runtime check as it will repeat the illegality.
+ Append_To (Spec_List, Proc_Decl);
- if Error_Posted (Init_Cond) or else Error_Posted (Expr) then
- return;
+ -- The initial condition procedure requires debug info when initial
+ -- condition is subject to Source Coverage Obligations.
+
+ if Generate_SCO then
+ Set_Needs_Debug_Info (Proc_Id);
end if;
-- Generate:
- -- pragma Check (Initial_Condition, <Expr>);
+ -- procedure <Pack_Id>Initial_Condition is
+ -- begin
+ -- pragma Check (Initial_Condition, <Expr>);
+ -- end <Pack_Id>Initial_Condition;
+
+ Proc_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Copy_Subprogram_Spec (Specification (Proc_Decl)),
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Pragma (Loc,
+ Chars => Name_Check,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression =>
+ Make_Identifier (Loc, Name_Initial_Condition)),
+ Make_Pragma_Argument_Association (Loc,
+ Expression => New_Copy_Tree (Expr)))))));
- Check :=
- Make_Pragma (Loc,
- Chars => Name_Check,
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression => Make_Identifier (Loc, Name_Initial_Condition)),
- Make_Pragma_Argument_Association (Loc,
- Expression => New_Copy_Tree (Expr))));
+ Append_To (Body_List, Proc_Body);
+
+ -- The initial condition procedure requires debug info when initial
+ -- condition is subject to Source Coverage Obligations.
+
+ Proc_Body_Id := Defining_Entity (Proc_Body);
+
+ if Generate_SCO then
+ Set_Needs_Debug_Info (Proc_Body_Id);
+ end if;
+
+ -- The location of the initial condition procedure call must be as close
+ -- as possible to the intended semantic location of the check because
+ -- the ABE mechanism relies heavily on accurate locations.
+
+ Call_Loc := End_Keyword_Location (N);
+
+ -- Generate:
+ -- <Pack_Id>Initial_Condition;
+
+ Call :=
+ Make_Procedure_Call_Statement (Call_Loc,
+ Name => New_Occurrence_Of (Proc_Id, Call_Loc));
+
+ Append_To (Call_List, Call);
- Append_To (List, Check);
- Analyze (Check);
+ Analyze (Proc_Decl);
+ Analyze (Proc_Body);
+ Analyze (Call);
end Expand_Pragma_Initial_Condition;
------------------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Subp_Id's body. All generated code is added to list Stmts. If Stmts is
-- No_List on entry, a new list is created.
- procedure Expand_Pragma_Initial_Condition (Spec_Or_Body : Node_Id);
- -- Generate a runtime check needed to verify the assumption of introduced
- -- by pragma Initial_Condition. Spec_Or_Body denotes the spec or body of
- -- the package where the pragma appears. The check is inserted according
- -- to the following precedence rules:
- -- 1) If the package has a body with a statement sequence, the check is
- -- inserted at the end of the statments.
- -- 2) If the package has a body, the check is inserted at the end of the
- -- body declarations.
- -- 3) The check is inserted at the end of the visible declarations.
+ procedure Expand_Pragma_Initial_Condition
+ (Pack_Id : Entity_Id;
+ N : Node_Id);
+ -- Verify the run-time semantics of pragma Initial_Condition when it
+ -- applies to package Pack_Id. N denotes the related package spec or
+ -- body.
end Exp_Prag;
procedure Expand_SPARK_Indexed_Component (N : Node_Id);
-- Insert explicit dereference if required
+ procedure Expand_SPARK_N_Loop_Statement (N : Node_Id);
+ -- Perform loop statement-specific expansion
+
procedure Expand_SPARK_N_Object_Declaration (N : Node_Id);
-- Perform object-declaration-specific expansion
procedure Expand_SPARK_N_Object_Renaming_Declaration (N : Node_Id);
-- Perform name evaluation for a renamed object
- procedure Expand_SPARK_Op_Ne (N : Node_Id);
+ procedure Expand_SPARK_N_Op_Ne (N : Node_Id);
-- Rewrite operator /= based on operator = when defined explicitly
procedure Expand_SPARK_Selected_Component (N : Node_Id);
-- dealt with specially in GNATprove.
when N_Loop_Statement =>
- declare
- Scheme : constant Node_Id := Iteration_Scheme (N);
- begin
- if Present (Scheme)
- and then Present (Iterator_Specification (Scheme))
- and then
- Is_Iterator_Over_Array (Iterator_Specification (Scheme))
- then
- Expand_Iterator_Loop_Over_Array (N);
- end if;
- end;
+ Expand_SPARK_N_Loop_Statement (N);
when N_Object_Declaration =>
Expand_SPARK_N_Object_Declaration (N);
Expand_SPARK_N_Object_Renaming_Declaration (N);
when N_Op_Ne =>
- Expand_SPARK_Op_Ne (N);
+ Expand_SPARK_N_Op_Ne (N);
when N_Freeze_Entity =>
if Is_Type (Entity (N)) then
end case;
end Expand_SPARK;
+ ------------------------------
+ -- Expand_SPARK_Freeze_Type --
+ ------------------------------
+
+ procedure Expand_SPARK_Freeze_Type (E : Entity_Id) is
+ begin
+ -- When a DIC is inherited by a tagged type, it may need to be
+ -- specialized to the descendant type, hence build a separate DIC
+ -- procedure for it as done during regular expansion for compilation.
+
+ if Has_DIC (E) and then Is_Tagged_Type (E) then
+ Build_DIC_Procedure_Body (E, For_Freeze => True);
+ end if;
+ end Expand_SPARK_Freeze_Type;
+
----------------------------------------
-- Expand_SPARK_N_Attribute_Reference --
----------------------------------------
end if;
end Expand_SPARK_N_Attribute_Reference;
- ------------------------------
- -- Expand_SPARK_Freeze_Type --
- ------------------------------
+ -----------------------------------
+ -- Expand_SPARK_N_Loop_Statement --
+ -----------------------------------
- procedure Expand_SPARK_Freeze_Type (E : Entity_Id) is
- begin
- -- When a DIC is inherited by a tagged type, it may need to be
- -- specialized to the descendant type, hence build a separate DIC
- -- procedure for it as done during regular expansion for compilation.
+ procedure Expand_SPARK_N_Loop_Statement (N : Node_Id) is
+ Scheme : constant Node_Id := Iteration_Scheme (N);
- if Has_DIC (E) and then Is_Tagged_Type (E) then
- Build_DIC_Procedure_Body (E, For_Freeze => True);
+ begin
+ -- Loop iterations over arrays need to be expanded, to avoid getting
+ -- two names referring to the same object in memory (the array and the
+ -- iterator) in GNATprove, especially since both can be written (thus
+ -- possibly leading to interferences due to aliasing). No such problem
+ -- arises with quantified expressions over arrays, which are dealt with
+ -- specially in GNATprove.
+
+ if Present (Scheme)
+ and then Present (Iterator_Specification (Scheme))
+ and then Is_Iterator_Over_Array (Iterator_Specification (Scheme))
+ then
+ Expand_Iterator_Loop_Over_Array (N);
end if;
- end Expand_SPARK_Freeze_Type;
+ end Expand_SPARK_N_Loop_Statement;
------------------------------------
-- Expand_SPARK_Indexed_Component --
---------------------------------------
procedure Expand_SPARK_N_Object_Declaration (N : Node_Id) is
- Def_Id : constant Entity_Id := Defining_Identifier (N);
Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (Def_Id);
+ Obj_Id : constant Entity_Id := Defining_Identifier (N);
+ Typ : constant Entity_Id := Etype (Obj_Id);
+
+ Call : Node_Id;
begin
-- If the object declaration denotes a variable without initialization
-- and analyze a dummy call to the DIC procedure of the type in order
-- to detect potential elaboration issues.
- if Comes_From_Source (Def_Id)
+ if Comes_From_Source (Obj_Id)
+ and then Ekind (Obj_Id) = E_Variable
and then Has_DIC (Typ)
and then Present (DIC_Procedure (Typ))
and then not Has_Init_Expression (N)
then
- Analyze (Build_DIC_Call (Loc, Def_Id, Typ));
+ Call := Build_DIC_Call (Loc, Obj_Id, Typ);
+
+ -- Partially insert the call into the tree by setting its parent
+ -- pointer.
+
+ Set_Parent (Call, N);
+ Analyze (Call);
end if;
end Expand_SPARK_N_Object_Declaration;
end if;
end Expand_SPARK_N_Object_Renaming_Declaration;
- ------------------------
- -- Expand_SPARK_Op_Ne --
- ------------------------
+ --------------------------
+ -- Expand_SPARK_N_Op_Ne --
+ --------------------------
- procedure Expand_SPARK_Op_Ne (N : Node_Id) is
+ procedure Expand_SPARK_N_Op_Ne (N : Node_Id) is
Typ : constant Entity_Id := Etype (Left_Opnd (N));
begin
else
Exp_Ch4.Expand_N_Op_Ne (N);
end if;
- end Expand_SPARK_Op_Ne;
+ end Expand_SPARK_N_Op_Ne;
-------------------------------------
-- Expand_SPARK_Potential_Renaming --
with Sem_Ch12; use Sem_Ch12;
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
+with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
-- Perform minor decoration in case the body is not analyzed
- Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
- Set_Etype (Proc_Body_Id, Standard_Void_Type);
- Set_Scope (Proc_Body_Id, Current_Scope);
+ Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
+ Set_Etype (Proc_Body_Id, Standard_Void_Type);
+ Set_Scope (Proc_Body_Id, Current_Scope);
+ Set_SPARK_Pragma (Proc_Body_Id, SPARK_Pragma (Proc_Id));
+ Set_SPARK_Pragma_Inherited
+ (Proc_Body_Id, SPARK_Pragma_Inherited (Proc_Id));
-- Link both spec and body to avoid generating duplicates
-- Perform minor decoration in case the declaration is not analyzed
- Set_Ekind (Proc_Id, E_Procedure);
- Set_Etype (Proc_Id, Standard_Void_Type);
- Set_Scope (Proc_Id, Current_Scope);
+ Set_Ekind (Proc_Id, E_Procedure);
+ Set_Etype (Proc_Id, Standard_Void_Type);
+ Set_Is_DIC_Procedure (Proc_Id);
+ Set_Scope (Proc_Id, Current_Scope);
+ Set_SPARK_Pragma (Proc_Id, SPARK_Mode_Pragma);
+ Set_SPARK_Pragma_Inherited (Proc_Id);
- Set_Is_DIC_Procedure (Proc_Id);
Set_DIC_Procedure (Work_Typ, Proc_Id);
-- The DIC procedure requires debug info when the assertion expression
-- is subject to Source Coverage Obligations.
- if Opt.Generate_SCO then
+ if Generate_SCO then
Set_Needs_Debug_Info (Proc_Id);
end if;
-- The invariant procedure requires debug info when the invariants are
-- subject to Source Coverage Obligations.
- if Opt.Generate_SCO then
+ if Generate_SCO then
Set_Needs_Debug_Info (Proc_Id);
end if;
null;
end if;
- -- Another special case, an attribute denoting a procedure call
+ -- Special case: an attribute denoting a procedure call
when N_Attribute_Reference =>
if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
null;
end if;
+ -- Special case: a call marker
+
+ when N_Call_Marker =>
+ if Is_List_Member (P) then
+ Insert_List_Before_And_Analyze (P, Ins_Actions);
+ return;
+ end if;
+
-- A contract node should not belong to the tree
when N_Contract =>
if Present (N) then
Remove_Warning_Messages (N);
+ -- Update the internal structures of the ABE mechanism in case the
+ -- dead node is an elaboration scenario.
+
+ Kill_Elaboration_Scenario (N);
+
-- Generate warning if appropriate
if W then
Lo : constant Node_Id :=
New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
Index : constant Entity_Id := Etype (Lo);
-
- Hi : Node_Id;
Length_Expr : constant Node_Id :=
Make_Op_Subtract (Loc,
- Left_Opnd =>
+ Left_Opnd =>
Make_Integer_Literal (Loc,
Intval => String_Literal_Length (Literal_Typ)),
- Right_Opnd =>
- Make_Integer_Literal (Loc, 1));
+ Right_Opnd => Make_Integer_Literal (Loc, 1));
+
+ Hi : Node_Id;
begin
Set_Analyzed (Lo, False);
- if Is_Integer_Type (Index) then
- Hi :=
- Make_Op_Add (Loc,
- Left_Opnd => New_Copy_Tree (Lo),
- Right_Opnd => Length_Expr);
- else
- Hi :=
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Val,
- Prefix => New_Occurrence_Of (Index, Loc),
- Expressions => New_List (
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Pos,
- Prefix => New_Occurrence_Of (Index, Loc),
- Expressions => New_List (New_Copy_Tree (Lo))),
- Right_Opnd => Length_Expr)));
- end if;
+ if Is_Integer_Type (Index) then
+ Hi :=
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Copy_Tree (Lo),
+ Right_Opnd => Length_Expr);
+ else
+ Hi :=
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Val,
+ Prefix => New_Occurrence_Of (Index, Loc),
+ Expressions => New_List (
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Pos,
+ Prefix => New_Occurrence_Of (Index, Loc),
+ Expressions => New_List (New_Copy_Tree (Lo))),
+ Right_Opnd => Length_Expr)));
+ end if;
- return
- Make_Range (Loc,
- Low_Bound => Lo,
- High_Bound => Hi);
+ return
+ Make_Range (Loc,
+ Low_Bound => Lo,
+ High_Bound => Hi);
end Make_Literal_Range;
--------------------------
-- False means that it is not known if the value is positive or negative.
function Make_Invariant_Call (Expr : Node_Id) return Node_Id;
- -- Expr is an object of a type which Has_Invariants set (and which thus
- -- also has an Invariant_Procedure set). If invariants are enabled, this
- -- function returns a call to the Invariant procedure passing Expr as the
- -- argument, and returns it unanalyzed. If invariants are not enabled,
- -- returns a null statement.
+ -- Generate a call to the Invariant_Procedure associated with the type of
+ -- expression Expr. Expr is passed as an actual parameter in the call.
function Make_Predicate_Call
(Typ : Entity_Id;
Checks.Initialize;
Sem_Warn.Initialize;
Prep.Initialize;
+ Sem_Elab.Initialize;
if Generate_SCIL then
SCIL_LL.Initialize;
Instantiate_Bodies;
end if;
- -- Analyze inlined bodies and check elaboration rules in GNATprove
- -- mode as well as during compilation.
+ -- Analyze all inlined bodies, check access-before-elaboration
+ -- rules, and remove ignored Ghost code when generating code or
+ -- compiling for GNATprove.
if Operating_Mode = Generate_Code or else GNATprove_Mode then
if Inline_Processing_Required then
Collect_Garbage_Entities;
end if;
- Check_Elab_Calls;
+ -- Examine all top level scenarios collected during analysis
+ -- and resolution. Diagnose conditional and guaranteed ABEs,
+ -- install run-time checks to catch ABEs, and guarantee the
+ -- prior elaboration of external units.
+
+ Check_Elaboration_Scenarios;
-- Remove any ignored Ghost code as it must not appear in the
-- executable.
Remove_Ignored_Ghost_Code;
+
+ -- Otherwise check the access-before-elaboration rules even when
+ -- previous errors were detected or the compilation is verifying
+ -- semantics.
+
+ else
+ Check_Elaboration_Scenarios;
end if;
-- At this stage we can unnest subprogram bodies if required
/* Added Nodes */
/****************/
+ /* Call markers are created by the ABE mechanism to capture the target of
+ a call along with other elaboration-related attributes which are either
+ unavailable of expensive to recompute. Call markers do not have static
+ and runtime semantics, and should be ignored. */
+
+ case N_Call_Marker:
+ gnu_result = alloc_stmt_list ();
+ break;
+
case N_Expression_With_Actions:
/* This construct doesn't define a scope so we don't push a binding
level around the statement list, but we wrap it in a SAVE_EXPR to
@copying
@quotation
-GNAT User's Guide for Native Platforms , Sep 29, 2017
+GNAT User's Guide for Native Platforms , Oct 09, 2017
AdaCore
Elaboration Order Handling in GNAT
* Elaboration Code::
+* Elaboration Order::
* Checking the Elaboration Order::
-* Controlling the Elaboration Order::
-* Controlling Elaboration in GNAT - Internal Calls::
-* Controlling Elaboration in GNAT - External Calls::
-* Default Behavior in GNAT - Ensuring Safety::
-* Treatment of Pragma Elaborate::
-* Elaboration Issues for Library Tasks::
+* Controlling the Elaboration Order in Ada::
+* Controlling the Elaboration Order in GNAT::
+* Common Elaboration-model Traits::
+* Dynamic Elaboration Model in GNAT::
+* Static Elaboration Model in GNAT::
+* SPARK Elaboration Model in GNAT::
* Mixing Elaboration Models::
-* What to Do If the Default Elaboration Behavior Fails::
-* Elaboration for Indirect Calls::
+* Elaboration Circularities::
+* Resolving Elaboration Circularities::
+* Resolving Task Issues::
+* Elaboration-related Compiler Switches::
* Summary of Procedures for Elaboration Control::
-* Other Elaboration Order Considerations::
-* Determining the Chosen Elaboration Order::
+* Inspecting the Chosen Elaboration Order::
Inline Assembler
@geindex Elaboration control
-This appendix describes the handling of elaboration code in Ada and
-in GNAT, and discusses how the order of elaboration of program units can
-be controlled in GNAT, either automatically or with explicit programming
-features.
+This appendix describes the handling of elaboration code in Ada and GNAT, and
+discusses how the order of elaboration of program units can be controlled in
+GNAT, either automatically or with explicit programming features.
@menu
* Elaboration Code::
+* Elaboration Order::
* Checking the Elaboration Order::
-* Controlling the Elaboration Order::
-* Controlling Elaboration in GNAT - Internal Calls::
-* Controlling Elaboration in GNAT - External Calls::
-* Default Behavior in GNAT - Ensuring Safety::
-* Treatment of Pragma Elaborate::
-* Elaboration Issues for Library Tasks::
+* Controlling the Elaboration Order in Ada::
+* Controlling the Elaboration Order in GNAT::
+* Common Elaboration-model Traits::
+* Dynamic Elaboration Model in GNAT::
+* Static Elaboration Model in GNAT::
+* SPARK Elaboration Model in GNAT::
* Mixing Elaboration Models::
-* What to Do If the Default Elaboration Behavior Fails::
-* Elaboration for Indirect Calls::
+* Elaboration Circularities::
+* Resolving Elaboration Circularities::
+* Resolving Task Issues::
+* Elaboration-related Compiler Switches::
* Summary of Procedures for Elaboration Control::
-* Other Elaboration Order Considerations::
-* Determining the Chosen Elaboration Order::
+* Inspecting the Chosen Elaboration Order::
@end menu
-@node Elaboration Code,Checking the Elaboration Order,,Elaboration Order Handling in GNAT
+@node Elaboration Code,Elaboration Order,,Elaboration Order Handling in GNAT
@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-code}@anchor{22e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id2}@anchor{22f}
@section Elaboration Code
-Ada provides rather general mechanisms for executing code at elaboration
-time, that is to say before the main program starts executing. Such code arises
-in three contexts:
+Ada defines the term @emph{execution} as the process by which a construct achieves
+its run-time effect. This process is also referred to as @strong{elaboration} for
+declarations and @emph{evaluation} for expressions.
+
+The execution model in Ada allows for certain sections of an Ada program to be
+executed prior to execution of the program itself, primarily with the intent of
+initializing data. These sections are referred to as @strong{elaboration code}.
+Elaboration code is executed as follows:
@itemize *
@item
-@emph{Initializers for variables}
+All partitions of an Ada program are executed in parallel with one another,
+possibly in a separate address space, and possibly on a separate computer.
-Variables declared at the library level, in package specs or bodies, can
-require initialization that is performed at elaboration time, as in:
+@item
+The execution of a partition involves running the environment task for that
+partition.
+
+@item
+The environment task executes all elaboration code (if available) for all
+units within that partition. This code is said to be executed at
+@strong{elaboration time}.
+
+@item
+The environment task executes the Ada program (if available) for that
+partition.
+@end itemize
+
+In addition to the Ada terminology, this appendix defines the following terms:
-@example
-Sqrt_Half : Float := Sqrt (0.5);
-@end example
+
+@itemize *
+
+@item
+@emph{Scenario}
+
+A construct that is elaborated or executed by elaboration code is referred to
+as an @emph{elaboration scenario} or simply a @strong{scenario}. GNAT recognizes the
+following scenarios:
+
+
+@itemize -
@item
-@emph{Package initialization code}
+@code{'Access} of entries, operators, and subprograms
-Code in a @code{begin} ... `@w{`} end`@w{`} section at the outer level of a package body is
-executed as part of the package body elaboration code.
+@item
+Activation of tasks
@item
-@emph{Library level task allocators}
+Calls to entries, operators, and subprograms
-Tasks that are declared using task allocators at the library level
-start executing immediately and hence can execute at elaboration time.
+@item
+Instantiations of generic templates
@end itemize
-Subprogram calls are possible in any of these contexts, which means that
-any arbitrary part of the program may be executed as part of the elaboration
-code. It is even possible to write a program which does all its work at
-elaboration time, with a null main program, although stylistically this
-would usually be considered an inappropriate way to structure
-a program.
+@item
+@emph{Target}
+
+A construct elaborated by a scenario is referred to as @emph{elaboration target}
+or simply @strong{target}. GNAT recognizes the following targets:
+
+
+@itemize -
-An important concern arises in the context of elaboration code:
-we have to be sure that it is executed in an appropriate order. What we
-have is a series of elaboration code sections, potentially one section
-for each unit in the program. It is important that these execute
-in the correct order. Correctness here means that, taking the above
-example of the declaration of @code{Sqrt_Half},
-if some other piece of
-elaboration code references @code{Sqrt_Half},
-then it must run after the
-section of elaboration code that contains the declaration of
-@code{Sqrt_Half}.
+@item
+For @code{'Access} of entries, operators, and subprograms, the target is the
+entry, operator, or subprogram being aliased.
+
+@item
+For activation of tasks, the target is the task body
+
+@item
+For calls to entries, operators, and subprograms, the target is the entry,
+operator, or subprogram being invoked.
-There would never be any order of elaboration problem if we made a rule
-that whenever you @emph{with} a unit, you must elaborate both the spec and body
-of that unit before elaborating the unit doing the @emph{with}ing:
+@item
+For instantiations of generic templates, the target is the generic template
+being instantiated.
+@end itemize
+@end itemize
+
+Elaboration code may appear in two distinct contexts:
+
+
+@itemize *
+
+@item
+@emph{Library level}
+
+A scenario appears at the library level when it is encapsulated by a package
+[body] compilation unit, ignoring any other package [body] declarations in
+between.
@example
-with Unit_1;
-package Unit_2 is ...
+with Server;
+package Client is
+ procedure Proc;
+
+ package Nested is
+ Val : ... := Server.Func;
+ end Nested;
+end Client;
@end example
-would require that both the body and spec of @code{Unit_1} be elaborated
-before the spec of @code{Unit_2}. However, a rule like that would be far too
-restrictive. In particular, it would make it impossible to have routines
-in separate packages that were mutually recursive.
+In the example above, the call to @code{Server.Func} is an elaboration scenario
+because it appears at the library level of package @code{Client}. Note that the
+declaration of package @code{Nested} is ignored according to the definition
+given above. As a result, the call to @code{Server.Func} will be executed when
+the spec of unit @code{Client} is elaborated.
-You might think that a clever enough compiler could look at the actual
-elaboration code and determine an appropriate correct order of elaboration,
-but in the general case, this is not possible. Consider the following
-example.
+@item
+@emph{Package body statements}
-In the body of @code{Unit_1}, we have a procedure @code{Func_1}
-that references
-the variable @code{Sqrt_1}, which is declared in the elaboration code
-of the body of @code{Unit_1}:
+A scenario appears within the statement sequence of a package body when it is
+bounded by the region starting from the @code{begin} keyword of the package body
+and ending at the @code{end} keyword of the package body.
@example
-Sqrt_1 : Float := Sqrt (0.1);
+package body Client is
+ procedure Proc is
+ begin
+ ...
+ end Proc;
+begin
+ Proc;
+end Client;
@end example
-The elaboration code of the body of @code{Unit_1} also contains:
+In the example above, the call to @code{Proc} is an elaboration scenario because
+it appears within the statement sequence of package body @code{Client}. As a
+result, the call to @code{Proc} will be executed when the body of @code{Client} is
+elaborated.
+@end itemize
+
+@node Elaboration Order,Checking the Elaboration Order,Elaboration Code,Elaboration Order Handling in GNAT
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order}@anchor{230}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{231}
+@section Elaboration Order
+
+
+The sequence by which the elaboration code of all units within a partition is
+executed is referred to as @strong{elaboration order}. The elaboration order depends
+on the following factors:
+
+
+@itemize *
+
+@item
+@emph{with}ed units
+
+@item
+purity of units
+
+@item
+preelaborability of units
+
+@item
+presence of elaboration control pragmas
+@end itemize
+
+A program may have several elaboration orders depending on its structure.
@example
-if expression_1 = 1 then
- Q := Unit_2.Func_2;
-end if;
+package Server is
+ function Func (Index : Integer) return Integer;
+end Server;
@end example
-@code{Unit_2} is exactly parallel,
-it has a procedure @code{Func_2} that references
-the variable @code{Sqrt_2}, which is declared in the elaboration code of
-the body @code{Unit_2}:
-
@example
-Sqrt_2 : Float := Sqrt (0.1);
+package body Server is
+ Results : array (1 .. 5) of Integer := (1, 2, 3, 4, 5);
+
+ function Func (Index : Integer) return Integer is
+ begin
+ return Results (Index);
+ end Func;
+end Server;
@end example
-The elaboration code of the body of @code{Unit_2} also contains:
+@example
+with Server;
+package Client is
+ Val : constant Integer := Server.Func (3);
+end Client;
+@end example
@example
-if expression_2 = 2 then
- Q := Unit_1.Func_1;
-end if;
+with Client;
+procedure Main is begin null; end Main;
@end example
-Now the question is, which of the following orders of elaboration is
-acceptable:
+The following elaboration order exhibits a fundamental problem referred to as
+@emph{access-before-elaboration} or simply @strong{ABE}.
@example
-Spec of Unit_1
-Spec of Unit_2
-Body of Unit_1
-Body of Unit_2
+spec of Server
+spec of Client
+body of Server
+body of Main
@end example
-or
+The elaboration of @code{Server}'s spec materializes function @code{Func}, making it
+callable. The elaboration of @code{Client}'s spec elaborates the declaration of
+@code{Val}. This invokes function @code{Server.Func}, however the body of
+@code{Server.Func} has not been elaborated yet because @code{Server}'s body comes
+after @code{Client}'s spec in the elaboration order. As a result, the value of
+constant @code{Val} is now undefined.
+
+Without any guarantees from the language, an undetected ABE problem may hinder
+proper initialization of data, which in turn may lead to undefined behavior at
+run time. To prevent such ABE problems, Ada employs dynamic checks in the same
+vein as index or null exclusion checks. A failed ABE check raises exception
+@code{Program_Error}.
+
+The following elaboration order avoids the ABE problem and the program can be
+successfully elaborated.
@example
-Spec of Unit_2
-Spec of Unit_1
-Body of Unit_2
-Body of Unit_1
-@end example
-
-If you carefully analyze the flow here, you will see that you cannot tell
-at compile time the answer to this question.
-If @code{expression_1} is not equal to 1,
-and @code{expression_2} is not equal to 2,
-then either order is acceptable, because neither of the function calls is
-executed. If both tests evaluate to true, then neither order is acceptable
-and in fact there is no correct order.
-
-If one of the two expressions is true, and the other is false, then one
-of the above orders is correct, and the other is incorrect. For example,
-if @code{expression_1} /= 1 and @code{expression_2} = 2,
-then the call to @code{Func_1}
-will occur, but not the call to @code{Func_2.}
-This means that it is essential
-to elaborate the body of @code{Unit_1} before
-the body of @code{Unit_2}, so the first
-order of elaboration is correct and the second is wrong.
-
-By making @code{expression_1} and @code{expression_2}
-depend on input data, or perhaps
-the time of day, we can make it impossible for the compiler or binder
-to figure out which of these expressions will be true, and hence it
-is impossible to guarantee a safe order of elaboration at run time.
-
-@node Checking the Elaboration Order,Controlling the Elaboration Order,Elaboration Code,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{230}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{231}
+spec of Server
+body of Server
+spec of Client
+body of Main
+@end example
+
+Ada states that a total elaboration order must exist, but it does not define
+what this order is. A compiler is thus tasked with choosing a suitable
+elaboration order which satisfies the dependencies imposed by @emph{with} clauses,
+unit categorization, and elaboration control pragmas. Ideally an order which
+avoids ABE problems should be chosen, however a compiler may not always find
+such an order due to complications with respect to control and data flow.
+
+@node Checking the Elaboration Order,Controlling the Elaboration Order in Ada,Elaboration Order,Elaboration Order Handling in GNAT
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{232}@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{233}
@section Checking the Elaboration Order
-In some languages that involve the same kind of elaboration problems,
-e.g., Java and C++, the programmer needs to take these
-ordering problems into account, and it is common to
-write a program in which an incorrect elaboration order gives
-surprising results, because it references variables before they
-are initialized.
-Ada is designed to be a safe language, and a programmer-beware approach is
-clearly not sufficient. Consequently, the language provides three lines
-of defense:
+To avoid placing the entire elaboration order burden on the programmer, Ada
+provides three lines of defense:
@itemize *
@item
-@emph{Standard rules}
+@emph{Static semantics}
-Some standard rules restrict the possible choice of elaboration
-order. In particular, if you @emph{with} a unit, then its spec is always
-elaborated before the unit doing the @emph{with}. Similarly, a parent
-spec is always elaborated before the child spec, and finally
-a spec is always elaborated before its corresponding body.
-@end itemize
+Static semantic rules restrict the possible choice of elaboration order. For
+instance, if unit Client @emph{with}s unit Server, then the spec of Server is
+always elaborated prior to Client. The same principle applies to child units
+- the spec of a parent unit is always elaborated prior to the child unit.
-@geindex Elaboration checks
+@item
+@emph{Dynamic semantics}
-@geindex Checks
-@geindex elaboration
+Dynamic checks are performed at run time, to ensure that a target is
+elaborated prior to a scenario that executes it, thus avoiding ABE problems.
+A failed run-time check raises exception @code{Program_Error}. The following
+restrictions apply:
-@itemize *
+@itemize -
@item
-@emph{Dynamic elaboration checks}
+@emph{Restrictions on calls}
-Dynamic checks are made at run time, so that if some entity is accessed
-before it is elaborated (typically by means of a subprogram call)
-then the exception (@code{Program_Error}) is raised.
+An entry, operator, or subprogram can be called from elaboration code only
+when the corresponding body has been elaborated.
@item
-@emph{Elaboration control}
-
-Facilities are provided for the programmer to specify the desired order
-of elaboration.
-@end itemize
+@emph{Restrictions on instantiations}
-Let's look at these facilities in more detail. First, the rules for
-dynamic checking. One possible rule would be simply to say that the
-exception is raised if you access a variable which has not yet been
-elaborated. The trouble with this approach is that it could require
-expensive checks on every variable reference. Instead Ada has two
-rules which are a little more restrictive, but easier to check, and
-easier to state:
+A generic unit can be instantiated by elaboration code only when the
+corresponding body has been elaborated.
+@item
+@emph{Restrictions on task activation}
-@itemize *
+A task can be activated by elaboration code only when the body of the
+associated task type has been elaborated.
+@end itemize
-@item
-@emph{Restrictions on calls}
+The restrictions above can be summarized by the following rule:
-A subprogram can only be called at elaboration time if its body
-has been elaborated. The rules for elaboration given above guarantee
-that the spec of the subprogram has been elaborated before the
-call, but not the body. If this rule is violated, then the
-exception @code{Program_Error} is raised.
+@emph{If a target has a body, then this body must be elaborated prior to the
+execution of the scenario that invokes, instantiates, or activates the
+target.}
@item
-@emph{Restrictions on instantiations}
+@emph{Elaboration control}
-A generic unit can only be instantiated if the body of the generic
-unit has been elaborated. Again, the rules for elaboration given above
-guarantee that the spec of the generic unit has been elaborated
-before the instantiation, but not the body. If this rule is
-violated, then the exception @code{Program_Error} is raised.
+Pragmas are provided for the programmer to specify the desired elaboration
+order.
@end itemize
-The idea is that if the body has been elaborated, then any variables
-it references must have been elaborated; by checking for the body being
-elaborated we guarantee that none of its references causes any
-trouble. As we noted above, this is a little too restrictive, because a
-subprogram that has no non-local references in its body may in fact be safe
-to call. However, it really would be unsafe to rely on this, because
-it would mean that the caller was aware of details of the implementation
-in the body. This goes against the basic tenets of Ada.
-
-A plausible implementation can be described as follows.
-A Boolean variable is associated with each subprogram
-and each generic unit. This variable is initialized to False, and is set to
-True at the point body is elaborated. Every call or instantiation checks the
-variable, and raises @code{Program_Error} if the variable is False.
-
-Note that one might think that it would be good enough to have one Boolean
-variable for each package, but that would not deal with cases of trying
-to call a body in the same package as the call
-that has not been elaborated yet.
-Of course a compiler may be able to do enough analysis to optimize away
-some of the Boolean variables as unnecessary, and GNAT indeed
-does such optimizations, but still the easiest conceptual model is to
-think of there being one variable per subprogram.
-
-@node Controlling the Elaboration Order,Controlling Elaboration in GNAT - Internal Calls,Checking the Elaboration Order,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{232}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order}@anchor{233}
-@section Controlling the Elaboration Order
-
-
-In the previous section we discussed the rules in Ada which ensure
-that @code{Program_Error} is raised if an incorrect elaboration order is
-chosen. This prevents erroneous executions, but we need mechanisms to
-specify a correct execution and avoid the exception altogether.
-To achieve this, Ada provides a number of features for controlling
-the order of elaboration. We discuss these features in this section.
-
-First, there are several ways of indicating to the compiler that a given
-unit has no elaboration problems:
+@node Controlling the Elaboration Order in Ada,Controlling the Elaboration Order in GNAT,Checking the Elaboration Order,Elaboration Order Handling in GNAT
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-ada}@anchor{234}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{235}
+@section Controlling the Elaboration Order in Ada
+
+
+Ada provides several idioms and pragmas to aid the programmer with specifying
+the desired elaboration order and avoiding ABE problems altogether.
@itemize *
@item
-@emph{packages that do not require a body}
+@emph{Packages without a body}
-A library package that does not require a body does not permit
-a body (this rule was introduced in Ada 95).
-Thus if we have a such a package, as in:
+A library package which does not require a completing body does not suffer
+from ABE problems.
@example
-package Definitions is
+package Pack is
generic
- type m is new integer;
- package Subp is
- type a is array (1 .. 10) of m;
- type b is array (1 .. 20) of m;
- end Subp;
-end Definitions;
+ type Element is private;
+ package Containers is
+ type Element_Array is array (1 .. 10) of Element;
+ end Containers;
+end Pack;
@end example
-A package that @emph{with}s @code{Definitions} may safely instantiate
-@code{Definitions.Subp} because the compiler can determine that there
-definitely is no package body to worry about in this case
+In the example above, package @code{Pack} does not require a body because it
+does not contain any constructs which require completion in a body. As a
+result, generic @code{Pack.Containers} can be instantiated without encountering
+any ABE problems.
@end itemize
@geindex pragma Pure
@item
@emph{pragma Pure}
-This pragma places sufficient restrictions on a unit to guarantee that
-no call to any subprogram in the unit can result in an
-elaboration problem. This means that the compiler does not need
-to worry about the point of elaboration of such units, and in
-particular, does not need to check any calls to any subprograms
-in this unit.
+Pragma @code{Pure} places sufficient restrictions on a unit to guarantee that no
+scenario within the unit can result in an ABE problem.
@end itemize
@geindex pragma Preelaborate
@item
@emph{pragma Preelaborate}
-This pragma places slightly less stringent restrictions on a unit than
-does pragma Pure,
-but these restrictions are still sufficient to ensure that there
-are no elaboration problems with any calls to the unit.
+Pragma @code{Preelaborate} is slightly less restrictive than pragma @code{Pure},
+but still strong enough to prevent ABE problems within a unit.
@end itemize
@geindex pragma Elaborate_Body
@item
@emph{pragma Elaborate_Body}
-This pragma requires that the body of a unit be elaborated immediately
-after its spec. Suppose a unit @code{A} has such a pragma,
-and unit @code{B} does
-a @emph{with} of unit @code{A}. Recall that the standard rules require
-the spec of unit @code{A}
-to be elaborated before the @emph{with}ing unit; given the pragma in
-@code{A}, we also know that the body of @code{A}
-will be elaborated before @code{B}, so
-that calls to @code{A} are safe and do not need a check.
-
-Note that, unlike pragma @code{Pure} and pragma @code{Preelaborate},
-the use of @code{Elaborate_Body} does not guarantee that the program is
-free of elaboration problems, because it may not be possible
-to satisfy the requested elaboration order.
-Let's go back to the example with @code{Unit_1} and @code{Unit_2}.
-If a programmer marks @code{Unit_1} as @code{Elaborate_Body},
-and not @code{Unit_2,} then the order of
-elaboration will be:
-
-@example
-Spec of Unit_2
-Spec of Unit_1
-Body of Unit_1
-Body of Unit_2
-@end example
-
-Now that means that the call to @code{Func_1} in @code{Unit_2}
-need not be checked,
-it must be safe. But the call to @code{Func_2} in
-@code{Unit_1} may still fail if
-@code{Expression_1} is equal to 1,
-and the programmer must still take
-responsibility for this not being the case.
-
-If all units carry a pragma @code{Elaborate_Body}, then all problems are
-eliminated, except for calls entirely within a body, which are
-in any case fully under programmer control. However, using the pragma
-everywhere is not always possible.
-In particular, for our @code{Unit_1}/@cite{Unit_2} example, if
-we marked both of them as having pragma @code{Elaborate_Body}, then
-clearly there would be no possible elaboration order.
+Pragma @code{Elaborate_Body} requires that the body of a unit is elaborated
+immediately after its spec. This restriction guarantees that no client
+scenario can execute a server target before the target body has been
+elaborated because the spec and body are effectively "glued" together.
+
+@example
+package Server is
+ pragma Elaborate_Body;
+
+ function Func return Integer;
+end Server;
+@end example
+
+@example
+package body Server is
+ function Func return Integer is
+ begin
+ ...
+ end Func;
+end Server;
+@end example
+
+@example
+with Server;
+package Client is
+ Val : constant Integer := Server.Func;
+end Client;
+@end example
+
+In the example above, pragma @code{Elaborate_Body} guarantees the following
+elaboration order:
+
+@example
+spec of Server
+body of Server
+spec of Client
+@end example
+
+because the spec of @code{Server} must be elaborated prior to @code{Client} by
+virtue of the @emph{with} clause, and in addition the body of @code{Server} must be
+elaborated immediately after the spec of @code{Server}.
+
+Removing pragma @code{Elaborate_Body} could result in the following incorrect
+elaboration order:
+
+@example
+spec of Server
+spec of Client
+body of Server
+@end example
+
+where @code{Client} invokes @code{Server.Func}, but the body of @code{Server.Func} has
+not been elaborated yet.
@end itemize
-The above pragmas allow a server to guarantee safe use by clients, and
-clearly this is the preferable approach. Consequently a good rule
-is to mark units as @code{Pure} or @code{Preelaborate} if possible,
-and if this is not possible,
-mark them as @code{Elaborate_Body} if possible.
-As we have seen, there are situations where neither of these
-three pragmas can be used.
-So we also provide methods for clients to control the
-order of elaboration of the servers on which they depend:
+The pragmas outlined above allow a server unit to guarantee safe elaboration
+use by client units. Thus it is a good rule to mark units as @code{Pure} or
+@code{Preelaborate}, and if this is not possible, mark them as @code{Elaborate_Body}.
+
+There are however situations where @code{Pure}, @code{Preelaborate}, and
+@code{Elaborate_Body} are not applicable. Ada provides another set of pragmas for
+use by client units to help ensure the elaboration safety of server units they
+depend on.
-@geindex pragma Elaborate
+@geindex pragma Elaborate (Unit)
@itemize *
@item
-@emph{pragma Elaborate (unit)}
+@emph{pragma Elaborate (Unit)}
+
+Pragma @code{Elaborate} can be placed in the context clauses of a unit, after a
+@emph{with} clause. It guarantees that both the spec and body of its argument will
+be elaborated prior to the unit with the pragma. Note that other unrelated
+units may be elaborated in between the spec and the body.
+
+@example
+package Server is
+ function Func return Integer;
+end Server;
+@end example
+
+@example
+package body Server is
+ function Func return Integer is
+ begin
+ ...
+ end Func;
+end Server;
+@end example
+
+@example
+with Server;
+pragma Elaborate (Server);
+package Client is
+ Val : constant Integer := Server.Func;
+end Client;
+@end example
+
+In the example above, pragma @code{Elaborate} guarantees the following
+elaboration order:
+
+@example
+spec of Server
+body of Server
+spec of Client
+@end example
+
+Removing pragma @code{Elaborate} could result in the following incorrect
+elaboration order:
+
+@example
+spec of Server
+spec of Client
+body of Server
+@end example
-This pragma is placed in the context clause, after a @emph{with} clause,
-and it requires that the body of the named unit be elaborated before
-the unit in which the pragma occurs. The idea is to use this pragma
-if the current unit calls at elaboration time, directly or indirectly,
-some subprogram in the named unit.
+where @code{Client} invokes @code{Server.Func}, but the body of @code{Server.Func}
+has not been elaborated yet.
@end itemize
-@geindex pragma Elaborate_All
+@geindex pragma Elaborate_All (Unit)
@itemize *
@item
-@emph{pragma Elaborate_All (unit)}
+@emph{pragma Elaborate_All (Unit)}
-This is a stronger version of the Elaborate pragma. Consider the
-following example:
+Pragma @code{Elaborate_All} is placed in the context clauses of a unit, after
+a @emph{with} clause. It guarantees that both the spec and body of its argument
+will be elaborated prior to the unit with the pragma, as well as all units
+@emph{with}ed by the spec and body of the argument, recursively. Note that other
+unrelated units may be elaborated in between the spec and the body.
@example
-Unit A |withs| unit B and calls B.Func in elab code
-Unit B |withs| unit C, and B.Func calls C.Func
+package Math is
+ function Factorial (Val : Natural) return Natural;
+end Math;
@end example
-Now if we put a pragma @code{Elaborate (B)}
-in unit @code{A}, this ensures that the
-body of @code{B} is elaborated before the call, but not the
-body of @code{C}, so
-the call to @code{C.Func} could still cause @code{Program_Error} to
-be raised.
+@example
+package body Math is
+ function Factorial (Val : Natural) return Natural is
+ begin
+ ...;
+ end Factorial;
+end Math;
+@end example
-The effect of a pragma @code{Elaborate_All} is stronger, it requires
-not only that the body of the named unit be elaborated before the
-unit doing the @emph{with}, but also the bodies of all units that the
-named unit uses, following @emph{with} links transitively. For example,
-if we put a pragma @code{Elaborate_All (B)} in unit @code{A},
-then it requires not only that the body of @code{B} be elaborated before @code{A},
-but also the body of @code{C}, because @code{B} @emph{with}s @code{C}.
-@end itemize
+@example
+package Computer is
+ type Operation_Kind is (None, Op_Factorial);
-We are now in a position to give a usage rule in Ada for avoiding
-elaboration problems, at least if dynamic dispatching and access to
-subprogram values are not used. We will handle these cases separately
-later.
+ function Compute
+ (Val : Natural;
+ Op : Operation_Kind) return Natural;
+end Computer;
+@end example
-The rule is simple:
+@example
+with Math;
+package body Computer is
+ function Compute
+ (Val : Natural;
+ Op : Operation_Kind) return Natural
+ is
+ if Op = Op_Factorial then
+ return Math.Factorial (Val);
+ end if;
+
+ return 0;
+ end Compute;
+end Computer;
+@end example
+
+@example
+with Computer;
+pragma Elaborate_All (Computer);
+package Client is
+ Val : constant Natural :=
+ Computer.Compute (123, Computer.Op_Factorial);
+end Client;
+@end example
+
+In the example above, pragma @code{Elaborate_All} can result in the following
+elaboration order:
+
+@example
+spec of Math
+body of Math
+spec of Computer
+body of Computer
+spec of Client
+@end example
+
+Note that there are several allowable suborders for the specs and bodies of
+@code{Math} and @code{Computer}, but the point is that these specs and bodies will
+be elaborated prior to @code{Client}.
+
+Removing pragma @code{Elaborate_All} could result in the following incorrect
+elaboration order
-@emph{If a unit has elaboration code that can directly or
-indirectly make a call to a subprogram in a |withed| unit, or instantiate
-a generic package in a |withed| unit,
-then if the |withed| unit does not have
-pragma `@w{`}Pure`@w{`} or `@w{`}Preelaborate`@w{`}, then the client should have
-a pragma `@w{`}Elaborate_All`@w{`}for the |withed| unit.*}
+@example
+spec of Math
+spec of Computer
+body of Computer
+spec of Client
+body of Math
+@end example
-By following this rule a client is
-assured that calls can be made without risk of an exception.
+where @code{Client} invokes @code{Computer.Compute}, which in turn invokes
+@code{Math.Factorial}, but the body of @code{Math.Factorial} has not been
+elaborated yet.
+@end itemize
-For generic subprogram instantiations, the rule can be relaxed to
-require only a pragma @code{Elaborate} since elaborating the body
-of a subprogram cannot cause any transitive elaboration (we are
-not calling the subprogram in this case, just elaborating its
-declaration).
+All pragmas shown above can be summarized by the following rule:
-If this rule is not followed, then a program may be in one of four
-states:
+@emph{If a client unit elaborates a server target directly or indirectly, then if
+the server unit requires a body and does not have pragma Pure, Preelaborate,
+or Elaborate_Body, then the client unit should have pragma Elaborate or
+Elaborate_All for the server unit.}
+
+If the rule outlined above is not followed, then a program may fall in one of
+the following states:
@itemize *
@item
-@emph{No order exists}
+@emph{No elaboration order exists}
-No order of elaboration exists which follows the rules, taking into
-account any @code{Elaborate}, @code{Elaborate_All},
-or @code{Elaborate_Body} pragmas. In
-this case, an Ada compiler must diagnose the situation at bind
-time, and refuse to build an executable program.
+In this case a compiler must diagnose the situation, and refuse to build an
+executable program.
@item
-@emph{One or more orders exist, all incorrect}
+@emph{One or more incorrect elaboration orders exist}
-One or more acceptable elaboration orders exist, and all of them
-generate an elaboration order problem. In this case, the binder
-can build an executable program, but @code{Program_Error} will be raised
-when the program is run.
+In this case a compiler can build an executable program, but
+@code{Program_Error} will be raised when the program is run.
@item
-@emph{Several orders exist, some right, some incorrect}
+@emph{Several elaboration orders exist, some correct, some incorrect}
-One or more acceptable elaboration orders exists, and some of them
-work, and some do not. The programmer has not controlled
-the order of elaboration, so the binder may or may not pick one of
-the correct orders, and the program may or may not raise an
-exception when it is run. This is the worst case, because it means
-that the program may fail when moved to another compiler, or even
-another version of the same compiler.
+In this case the programmer has not controlled the elaboration order. As a
+result, a compiler may or may not pick one of the correct orders, and the
+program may or may not raise @code{Program_Error} when it is run. This is the
+worst possible state because the program may fail on another compiler, or
+even another version of the same compiler.
@item
-@emph{One or more orders exists, all correct}
+@emph{One or more correct orders exist}
-One ore more acceptable elaboration orders exist, and all of them
-work. In this case the program runs successfully. This state of
-affairs can be guaranteed by following the rule we gave above, but
-may be true even if the rule is not followed.
+In this case a compiler can build an executable program, and the program is
+run successfully. This state may be guaranteed by following the outlined
+rules, or may be the result of good program architecture.
@end itemize
-Note that one additional advantage of following our rules on the use
-of @code{Elaborate} and @code{Elaborate_All}
-is that the program continues to stay in the ideal (all orders OK) state
-even if maintenance
-changes some bodies of some units. Conversely, if a program that does
-not follow this rule happens to be safe at some point, this state of affairs
-may deteriorate silently as a result of maintenance changes.
+Note that one additional advantage of using @code{Elaborate} and @code{Elaborate_All}
+is that the program continues to stay in the last state (one or more correct
+orders exist) even if maintenance changes the bodies of targets.
+
+@node Controlling the Elaboration Order in GNAT,Common Elaboration-model Traits,Controlling the Elaboration Order in Ada,Elaboration Order Handling in GNAT
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{236}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-gnat}@anchor{237}
+@section Controlling the Elaboration Order in GNAT
+
+
+In addition to Ada semantics and rules synthesized from them, GNAT offers
+three elaboration models to aid the programmer with specifying the correct
+elaboration order and to diagnose elaboration problems.
+
+@geindex Dynamic elaboration model
-You may have noticed that the above discussion did not mention
-the use of @code{Elaborate_Body}. This was a deliberate omission. If you
-@emph{with} an @code{Elaborate_Body} unit, it still may be the case that
-code in the body makes calls to some other unit, so it is still necessary
-to use @code{Elaborate_All} on such units.
-@node Controlling Elaboration in GNAT - Internal Calls,Controlling Elaboration in GNAT - External Calls,Controlling the Elaboration Order,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{234}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-elaboration-in-gnat-internal-calls}@anchor{235}
-@section Controlling Elaboration in GNAT - Internal Calls
+@itemize *
+
+@item
+@emph{Dynamic elaboration model}
+
+This is the most permissive of the three elaboration models. When the
+dynamic model is in effect, GNAT assumes that all code within all units in
+a partition is elaboration code. GNAT performs very few diagnostics and
+generates run-time checks to verify the elaboration order of a program. This
+behavior is identical to that specified by the Ada Reference Manual. The
+dynamic model is enabled with compilation switch @code{-gnatE}.
+@end itemize
+@geindex Static elaboration model
-In the case of internal calls, i.e., calls within a single package, the
-programmer has full control over the order of elaboration, and it is up
-to the programmer to elaborate declarations in an appropriate order. For
-example writing:
+
+@itemize *
+
+@item
+@emph{Static elaboration model}
+
+This is the middle ground of the three models. When the static model is in
+effect, GNAT performs extensive diagnostics on a unit-by-unit basis for all
+scenarios that elaborate or execute internal targets. GNAT also generates
+run-time checks for all external targets and for all scenarios that may
+exhibit ABE problems. Finally, GNAT installs implicit @code{Elaborate} and
+@code{Elaborate_All} pragmas for server units based on the dependencies of
+client units. The static model is the default model in GNAT.
+@end itemize
+
+@geindex SPARK elaboration model
+
+
+@itemize *
+
+@item
+@emph{SPARK elaboration model}
+
+This is the most conservative of the three models and enforces the SPARK
+rules of elaboration as defined in the SPARK Reference Manual, section 7.7.
+The SPARK model is in effect only when a scenario and a target reside in a
+region subject to SPARK_Mode On, otherwise the dynamic or static model is in
+effect.
+@end itemize
+
+@node Common Elaboration-model Traits,Dynamic Elaboration Model in GNAT,Controlling the Elaboration Order in GNAT,Elaboration Order Handling in GNAT
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat common-elaboration-model-traits}@anchor{238}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{239}
+@section Common Elaboration-model Traits
+
+
+All three GNAT models are able to detect elaboration problems related to
+dispatching calls and a particular kind of ABE referred to as @emph{guaranteed ABE}.
+
+
+@itemize *
+
+@item
+@emph{Dispatching calls}
+
+GNAT installs run-time checks for each primitive subprogram of each tagged
+type defined in a partition on the assumption that a dispatching call
+invoked at elaboration time will execute one of these primitives. As a
+result, a dispatching call that executes a primitive whose body has not
+been elaborated yet will raise exception @code{Program_Error} at run time. The
+checks can be suppressed using pragma @code{Suppress (Elaboration_Check)}.
+
+@item
+@emph{Guaranteed ABE}
+
+A guaranteed ABE arises when the body of a target is not elaborated early
+enough, and causes all scenarios that directly execute the target to fail.
@example
-function One return Float;
+package body Guaranteed_ABE is
+ function ABE return Integer;
-Q : Float := One;
+ Val : constant Integer := ABE;
-function One return Float is
-begin
- return 1.0;
-end One;
+ function ABE return Integer is
+ begin
+ ...
+ end ABE;
+end Guaranteed_ABE;
@end example
-will obviously raise @code{Program_Error} at run time, because function
-One will be called before its body is elaborated. In this case GNAT will
-generate a warning that the call will raise @code{Program_Error}:
+In the example above, the elaboration of @code{Guaranteed_ABE}'s body elaborates
+the declaration of @code{Val}. This invokes function @code{ABE}, however the body
+of @code{ABE} has not been elaborated yet. GNAT emits similar diagnostics in all
+three models:
@example
- 1. procedure y is
- 2. function One return Float;
- 3.
- 4. Q : Float := One;
- |
- >>> warning: cannot call "One" before body is elaborated
- >>> warning: Program_Error will be raised at run time
+1. package body Guaranteed_ABE is
+2. function ABE return Integer;
+3.
+4. Val : constant Integer := ABE;
+ |
+ >>> warning: cannot call "ABE" before body seen
+ >>> warning: Program_Error will be raised at run time
- 5.
- 6. function One return Float is
- 7. begin
- 8. return 1.0;
- 9. end One;
-10.
-11. begin
-12. null;
-13. end;
+5.
+6. function ABE return Integer is
+7. begin
+8. ...
+9. end ABE;
+10. end Guaranteed_ABE;
@end example
+@end itemize
+
+Note that GNAT emits warnings rather than hard errors whenever it encounters an
+elaboration problem. This is because the elaboration model in effect may be too
+conservative, or a particular scenario may not be elaborated or executed due to
+data and control flow. The warnings can be suppressed with compiler switch
+@code{-gnatws}.
+
+@node Dynamic Elaboration Model in GNAT,Static Elaboration Model in GNAT,Common Elaboration-model Traits,Elaboration Order Handling in GNAT
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat dynamic-elaboration-model-in-gnat}@anchor{23a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{23b}
+@section Dynamic Elaboration Model in GNAT
-Note that in this particular case, it is likely that the call is safe, because
-the function @code{One} does not access any global variables.
-Nevertheless in Ada, we do not want the validity of the check to depend on
-the contents of the body (think about the separate compilation case), so this
-is still wrong, as we discussed in the previous sections.
-The error is easily corrected by rearranging the declarations so that the
-body of @code{One} appears before the declaration containing the call
-(note that in Ada 95 as well as later versions of the Ada standard,
-declarations can appear in any order, so there is no restriction that
-would prevent this reordering, and if we write:
+The dynamic model assumes that all code within all units in a partition is
+elaboration code. As a result, run-time checks are installed for each scenario
+regardless of whether the target is internal or external. The checks can be
+suppressed using pragma @code{Suppress (Elaboration_Check)}. This behavior is
+identical to that specified by the Ada Reference Manual. The following example
+showcases run-time checks installed by GNAT to verify the elaboration state of
+package @code{Dynamic_Model}.
@example
-function One return Float;
+with Server;
+package body Dynamic_Model is
+ procedure API is
+ begin
+ ...
+ end API;
+
+ <check that the body of Server.Gen is elaborated>
+ package Inst is new Server.Gen;
+
+ T : Server.Task_Type;
-function One return Float is
begin
- return 1.0;
-end One;
+ <check that the body of Server.Task_Type is elaborated>
-Q : Float := One;
+ <check that the body of Server.Proc is elaborated>
+ Server.Proc;
+end Dynamic_Model;
@end example
-then all is well, no warning is generated, and no
-@code{Program_Error} exception
-will be raised.
-Things are more complicated when a chain of subprograms is executed:
+The checks verify that the body of a target has been successfully elaborated
+before a scenario activates, calls, or instantiates a target.
+
+Note that no scenario within package @code{Dynamic_Model} calls procedure @code{API}.
+In fact, procedure @code{API} may not be invoked by elaboration code within the
+partition, however the dynamic model assumes that this can happen.
+
+The dynamic model emits very few diagnostics, but can make suggestions on
+missing @code{Elaborate} and @code{Elaborate_All} pragmas for library-level
+scenarios. This information is available when compiler switch @code{-gnatel}
+is in effect.
@example
-function A return Integer;
-function B return Integer;
-function C return Integer;
+1. with Server;
+2. package body Dynamic_Model is
+3. Val : constant Integer := Server.Func;
+ |
+ >>> info: call to "Func" during elaboration
+ >>> info: missing pragma "Elaborate_All" for unit "Server"
+
+4. end Dynamic_Model;
+@end example
+
+@node Static Elaboration Model in GNAT,SPARK Elaboration Model in GNAT,Dynamic Elaboration Model in GNAT,Elaboration Order Handling in GNAT
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat static-elaboration-model-in-gnat}@anchor{23c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{23d}
+@section Static Elaboration Model in GNAT
+
-function B return Integer is begin return A; end;
-function C return Integer is begin return B; end;
+In contrast to the dynamic model, the static model is more precise in its
+analysis of elaboration code. The model makes a clear distinction between
+internal and external targets, and resorts to different diagnostics and
+run-time checks based on the nature of the target.
-X : Integer := C;
-function A return Integer is begin return 1; end;
+@itemize *
+
+@item
+@emph{Internal targets}
+
+The static model performs extensive diagnostics on scenarios which elaborate
+or execute internal targets. The warnings resulting from these diagnostics
+are enabled by default, but can be suppressed using compiler switch
+@code{-gnatws}.
+
+@example
+ 1. package body Static_Model is
+ 2. generic
+ 3. with function Func return Integer;
+ 4. package Gen is
+ 5. Val : constant Integer := Func;
+ 6. end Gen;
+ 7.
+ 8. function ABE return Integer;
+ 9.
+10. function Cause_ABE return Boolean is
+11. package Inst is new Gen (ABE);
+ |
+ >>> warning: in instantiation at line 5
+ >>> warning: cannot call "ABE" before body seen
+ >>> warning: Program_Error may be raised at run time
+ >>> warning: body of unit "Static_Model" elaborated
+ >>> warning: function "Cause_ABE" called at line 16
+ >>> warning: function "ABE" called at line 5, instance at line 11
+
+12. begin
+13. ...
+14. end Cause_ABE;
+15.
+16. Val : constant Boolean := Cause_ABE;
+17.
+18. function ABE return Integer is
+19. begin
+20. ...
+21. end ABE;
+22. end Static_Model;
+@end example
+
+The example above illustrates an ABE problem within package @code{Static_Model},
+which is hidden by several layers of indirection. The elaboration of package
+body @code{Static_Model} elaborates the declaration of @code{Val}. This invokes
+function @code{Cause_ABE}, which instantiates generic unit @code{Gen} as @code{Inst}.
+The elaboration of @code{Inst} invokes function @code{ABE}, however the body of
+@code{ABE} has not been elaborated yet.
+
+@item
+@emph{External targets}
+
+The static model installs run-time checks to verify the elaboration status
+of server targets only when the scenario that elaborates or executes that
+target is part of the elaboration code of the client unit. The checks can be
+suppressed using pragma @code{Suppress (Elaboration_Check)}.
+
+@example
+with Server;
+package body Static_Model is
+ generic
+ with function Func return Integer;
+ package Gen is
+ Val : constant Integer := Func;
+ end Gen;
+
+ function Call_Func return Boolean is
+ <check that the body of Server.Func is elaborated>
+ package Inst is new Gen (Server.Func);
+ begin
+ ...
+ end Call_Func;
+
+ Val : constant Boolean := Call_Func;
+end Static_Model;
@end example
-Now the call to @code{C}
-at elaboration time in the declaration of @code{X} is correct, because
-the body of @code{C} is already elaborated,
-and the call to @code{B} within the body of
-@code{C} is correct, but the call
-to @code{A} within the body of @code{B} is incorrect, because the body
-of @code{A} has not been elaborated, so @code{Program_Error}
-will be raised on the call to @code{A}.
-In this case GNAT will generate a
-warning that @code{Program_Error} may be
-raised at the point of the call. Let's look at the warning:
+In the example above, the elaboration of package body @code{Static_Model}
+elaborates the declaration of @code{Val}. This invokes function @code{Call_Func},
+which instantiates generic unit @code{Gen} as @code{Inst}. The elaboration of
+@code{Inst} invokes function @code{Server.Func}. Since @code{Server.Func} is an
+external target, GNAT installs a run-time check to verify that its body has
+been elaborated.
-@example
- 1. procedure x is
- 2. function A return Integer;
- 3. function B return Integer;
- 4. function C return Integer;
- 5.
- 6. function B return Integer is begin return A; end;
- |
- >>> warning: call to "A" before body is elaborated may
- raise Program_Error
- >>> warning: "B" called at line 7
- >>> warning: "C" called at line 9
+In addition to checks, the static model installs implicit @code{Elaborate} and
+@code{Elaborate_All} pragmas to guarantee safe elaboration use of server units.
+This information is available when compiler switch @code{-gnatel} is in
+effect.
- 7. function C return Integer is begin return B; end;
+@example
+ 1. with Server;
+ 2. package body Static_Model is
+ 3. generic
+ 4. with function Func return Integer;
+ 5. package Gen is
+ 6. Val : constant Integer := Func;
+ 7. end Gen;
8.
- 9. X : Integer := C;
-10.
-11. function A return Integer is begin return 1; end;
-12.
-13. begin
-14. null;
-15. end;
+ 9. function Call_Func return Boolean is
+10. package Inst is new Gen (Server.Func);
+ |
+ >>> info: instantiation of "Gen" during elaboration
+ >>> info: in instantiation at line 6
+ >>> info: call to "Func" during elaboration
+ >>> info: in instantiation at line 6
+ >>> info: implicit pragma "Elaborate_All" generated for unit "Server"
+ >>> info: body of unit "Static_Model" elaborated
+ >>> info: function "Call_Func" called at line 15
+ >>> info: function "Func" called at line 6, instance at line 10
+
+11. begin
+12. ...
+13. end Call_Func;
+14.
+15. Val : constant Boolean := Call_Func;
+ |
+ >>> info: call to "Call_Func" during elaboration
+
+16. end Static_Model;
+@end example
+
+In the example above, the elaboration of package body @code{Static_Model}
+elaborates the declaration of @code{Val}. This invokes function @code{Call_Func},
+which instantiates generic unit @code{Gen} as @code{Inst}. The elaboration of
+@code{Inst} invokes function @code{Server.Func}. Since @code{Server.Func} is an
+external target, GNAT installs an implicit @code{Elaborate_All} pragma for unit
+@code{Server}. The pragma guarantees that both the spec and body of @code{Server},
+along with any additional dependencies that @code{Server} may require, are
+elaborated prior to the body of @code{Static_Model}.
+@end itemize
+
+@node SPARK Elaboration Model in GNAT,Mixing Elaboration Models,Static Elaboration Model in GNAT,Elaboration Order Handling in GNAT
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{23e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat spark-elaboration-model-in-gnat}@anchor{23f}
+@section SPARK Elaboration Model in GNAT
+
+
+The SPARK model is identical to the static model in its handling of internal
+targets. The SPARK model, however, requires explicit @code{Elaborate} or
+@code{Elaborate_All} pragmas to be present in the program when a target is
+external, and emits hard errors instead of warnings:
+
+@example
+1. with Server;
+2. package body SPARK_Model with SPARK_Mode is
+3. Val : constant Integer := Server.Func;
+ |
+ >>> call to "Func" during elaboration in SPARK
+ >>> unit "SPARK_Model" requires pragma "Elaborate_All" for "Server"
+ >>> body of unit "SPARK_Model" elaborated
+ >>> function "Func" called at line 3
+
+4. end SPARK_Model;
@end example
-Note that the message here says 'may raise', instead of the direct case,
-where the message says 'will be raised'. That's because whether
-@code{A} is
-actually called depends in general on run-time flow of control.
-For example, if the body of @code{B} said
+@node Mixing Elaboration Models,Elaboration Circularities,SPARK Elaboration Model in GNAT,Elaboration Order Handling in GNAT
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{240}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{241}
+@section Mixing Elaboration Models
+
+
+It is possible to mix units compiled with a different elaboration model,
+however the following rules must be observed:
+
+
+@itemize *
+
+@item
+A client unit compiled with the dynamic model can only @emph{with} a server unit
+that meets at least one of the following criteria:
+
+
+@itemize -
+
+@item
+The server unit is compiled with the dynamic model.
+
+@item
+The server unit is a GNAT implementation unit from the Ada, GNAT,
+Interfaces, or System hierarchies.
+
+@item
+The server unit has pragma @code{Pure} or @code{Preelaborate}.
+
+@item
+The client unit has an explicit @code{Elaborate_All} pragma for the server
+unit.
+@end itemize
+@end itemize
+
+These rules ensure that elaboration checks are not omitted. If the rules are
+violated, the binder emits a warning:
@example
-function B return Integer is
-begin
- if some-condition-depending-on-input-data then
- return A;
- else
- return 1;
- end if;
-end B;
-@end example
-
-then we could not know until run time whether the incorrect call to A would
-actually occur, so @code{Program_Error} might
-or might not be raised. It is possible for a compiler to
-do a better job of analyzing bodies, to
-determine whether or not @code{Program_Error}
-might be raised, but it certainly
-couldn't do a perfect job (that would require solving the halting problem
-and is provably impossible), and because this is a warning anyway, it does
-not seem worth the effort to do the analysis. Cases in which it
-would be relevant are rare.
-
-In practice, warnings of either of the forms given
-above will usually correspond to
-real errors, and should be examined carefully and eliminated.
-In the rare case where a warning is bogus, it can be suppressed by any of
-the following methods:
+warning: "x.ads" has dynamic elaboration checks and with's
+warning: "y.ads" which has static elaboration checks
+@end example
+
+The warnings can be suppressed by binder switch @code{-ws}.
+
+@node Elaboration Circularities,Resolving Elaboration Circularities,Mixing Elaboration Models,Elaboration Order Handling in GNAT
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{242}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{243}
+@section Elaboration Circularities
+
+
+If the binder cannot find an acceptable elaboration order, it outputs detailed
+diagnostics describing an @strong{elaboration circularity}.
+
+@example
+package Server is
+ function Func return Integer;
+end Server;
+@end example
+
+@example
+with Client;
+package body Server is
+ function Func return Integer is
+ begin
+ ...
+ end Func;
+end Server;
+@end example
+
+@example
+with Server;
+package Client is
+ Val : constant Integer := Server.Func;
+end Client;
+@end example
+
+@example
+with Client;
+procedure Main is begin null; end Main;
+@end example
+
+@example
+error: elaboration circularity detected
+info: "server (body)" must be elaborated before "client (spec)"
+info: reason: implicit Elaborate_All in unit "client (spec)"
+info: recompile "client (spec)" with -gnatel for full details
+info: "server (body)"
+info: must be elaborated along with its spec:
+info: "server (spec)"
+info: which is withed by:
+info: "client (spec)"
+info: "client (spec)" must be elaborated before "server (body)"
+info: reason: with clause
+@end example
+
+In the example above, @code{Client} must be elaborated prior to @code{Main} by virtue
+of a @emph{with} clause. The elaboration of @code{Client} invokes @code{Server.Func}, and
+static model generates an implicit @code{Elaborate_All} pragma for @code{Server}. The
+pragma implies that both the spec and body of @code{Server}, along with any units
+they @emph{with}, must be elaborated prior to @code{Client}. However, @code{Server}'s body
+@emph{with}s @code{Client}, implying that @code{Client} must be elaborated prior to
+@code{Server}. The end result is that @code{Client} must be elaborated prior to
+@code{Client}, and this leads to a circularity.
+
+@node Resolving Elaboration Circularities,Resolving Task Issues,Elaboration Circularities,Elaboration Order Handling in GNAT
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{244}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-elaboration-circularities}@anchor{245}
+@section Resolving Elaboration Circularities
+
+
+When faced with an elaboration circularity, a programmer has several options
+available.
+
+
+@itemize *
+
+@item
+@emph{Fix the program}
+
+The most desirable option from the point of view of long-term maintenance
+is to rearrange the program so that the elaboration problems are avoided.
+One useful technique is to place the elaboration code into separate child
+packages. Another is to move some of the initialization code to explicitly
+invoked subprograms, where the program controls the order of initialization
+explicitly. Although this is the most desirable option, it may be impractical
+and involve too much modification, especially in the case of complex legacy
+code.
+@item
+@emph{Switch to more permissive elaboration model}
-@itemize *
+If the compilation was performed using the static model, enable the dynamic
+model with compilation switch @code{-gnatE}. GNAT will no longer generate
+implicit @code{Elaborate} and @code{Elaborate_All} pragmas, resulting in a behavior
+identical to that specified by the Ada Reference Manual. The binder will
+generate an executable program that may or may not raise @code{Program_Error},
+and it is the programmer's responsibility to ensure that it does not raise
+@code{Program_Error}.
@item
-Compile with the @code{-gnatws} switch set
+@emph{Suppress all elaboration checks}
-@item
-Suppress @code{Elaboration_Check} for the called subprogram
+The drawback of run-time checks is that they generate overhead at run time,
+both in space and time. If the programmer is absolutely sure that a program
+will not raise an elaboration-related @code{Program_Error}, then using the
+pragma @code{Suppress (Elaboration_Check)} globally (as a configuration pragma)
+will eliminate all run-time checks.
@item
-Use pragma @code{Warnings_Off} to turn warnings off for the call
-@end itemize
+@emph{Suppress elaboration checks selectively}
-For the internal elaboration check case,
-GNAT by default generates the
-necessary run-time checks to ensure
-that @code{Program_Error} is raised if any
-call fails an elaboration check. Of course this can only happen if a
-warning has been issued as described above. The use of pragma
-@code{Suppress (Elaboration_Check)} may (but is not guaranteed to) suppress
-some of these checks, meaning that it may be possible (but is not
-guaranteed) for a program to be able to call a subprogram whose body
-is not yet elaborated, without raising a @code{Program_Error} exception.
+If a scenario cannot possibly lead to an elaboration @code{Program_Error},
+and the binder nevertheless complains about implicit @code{Elaborate} and
+@code{Elaborate_All} pragmas that lead to elaboration circularities, it
+is possible to suppress the generation of implicit @code{Elaborate} and
+@code{Elaborate_All} pragmas, as well as run-time checks. Clearly this can
+be unsafe, and it is the responsibility of the programmer to make sure
+that the resulting program has no elaboration anomalies. Pragma
+@code{Suppress (Elaboration_Check)} can be used with different levels of
+granularity to achieve these effects.
-@node Controlling Elaboration in GNAT - External Calls,Default Behavior in GNAT - Ensuring Safety,Controlling Elaboration in GNAT - Internal Calls,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{236}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-elaboration-in-gnat-external-calls}@anchor{237}
-@section Controlling Elaboration in GNAT - External Calls
+@itemize -
+
+@item
+@emph{Target suppression}
-The previous section discussed the case in which the execution of a
-particular thread of elaboration code occurred entirely within a
-single unit. This is the easy case to handle, because a programmer
-has direct and total control over the order of elaboration, and
-furthermore, checks need only be generated in cases which are rare
-and which the compiler can easily detect.
-The situation is more complex when separate compilation is taken into account.
-Consider the following:
+When the pragma is placed in a declarative part, without a second argument
+naming an entity, it will suppress implicit @code{Elaborate} and
+@code{Elaborate_All} pragma generation, as well as run-time checks, on all
+targets within the region.
@example
-package Math is
- function Sqrt (Arg : Float) return Float;
-end Math;
+package Range_Suppress is
+ pragma Suppress (Elaboration_Check);
-package body Math is
- function Sqrt (Arg : Float) return Float is
- begin
- ...
- end Sqrt;
-end Math;
+ function Func return Integer;
-with Math;
-package Stuff is
- X : Float := Math.Sqrt (0.5);
-end Stuff;
+ generic
+ procedure Gen;
-with Stuff;
-procedure Main is
-begin
- ...
-end Main;
+ pragma Unsuppress (Elaboration_Check);
+
+ task type Tsk;
+end Range_Suppress;
@end example
-where @code{Main} is the main program. When this program is executed, the
-elaboration code must first be executed, and one of the jobs of the
-binder is to determine the order in which the units of a program are
-to be elaborated. In this case we have four units: the spec and body
-of @code{Math},
-the spec of @code{Stuff} and the body of @code{Main}).
-In what order should the four separate sections of elaboration code
-be executed?
+In the example above, a pair of Suppress/Unsuppress pragmas define a region
+of suppression within package @code{Range_Suppress}. As a result, no implicit
+@code{Elaborate} and @code{Elaborate_All} pragmas, nor any run-time checks, will
+be generated by callers of @code{Func} and instantiators of @code{Gen}. Note that
+task type @code{Tsk} is not within this region.
-There are some restrictions in the order of elaboration that the binder
-can choose. In particular, if unit U has a @emph{with}
-for a package @code{X}, then you
-are assured that the spec of @code{X}
-is elaborated before U , but you are
-not assured that the body of @code{X}
-is elaborated before U.
-This means that in the above case, the binder is allowed to choose the
-order:
+An alternative to the region-based suppression is to use multiple
+@code{Suppress} pragmas with arguments naming specific entities for which
+elaboration checks should be suppressed:
@example
-spec of Math
-spec of Stuff
-body of Math
-body of Main
+package Range_Suppress is
+ function Func return Integer;
+ pragma Suppress (Elaboration_Check, Func);
+
+ generic
+ procedure Gen;
+ pragma Suppress (Elaboration_Check, Gen);
+
+ task type Tsk;
+end Range_Suppress;
@end example
-but that's not good, because now the call to @code{Math.Sqrt}
-that happens during
-the elaboration of the @code{Stuff}
-spec happens before the body of @code{Math.Sqrt} is
-elaborated, and hence causes @code{Program_Error} exception to be raised.
-At first glance, one might say that the binder is misbehaving, because
-obviously you want to elaborate the body of something you @emph{with} first, but
-that is not a general rule that can be followed in all cases. Consider
-
-@example
-package X is ...
-
-package Y is ...
-
-with X;
-package body Y is ...
-
-with Y;
-package body X is ...
-@end example
-
-This is a common arrangement, and, apart from the order of elaboration
-problems that might arise in connection with elaboration code, this works fine.
-A rule that says that you must first elaborate the body of anything you
-@emph{with} cannot work in this case:
-the body of @code{X} @emph{with}s @code{Y},
-which means you would have to
-elaborate the body of @code{Y} first, but that @emph{with}s @code{X},
-which means
-you have to elaborate the body of @code{X} first, but ... and we have a
-loop that cannot be broken.
-
-It is true that the binder can in many cases guess an order of elaboration
-that is unlikely to cause a @code{Program_Error}
-exception to be raised, and it tries to do so (in the
-above example of @code{Math/Stuff/Spec}, the GNAT binder will
-by default
-elaborate the body of @code{Math} right after its spec, so all will be well).
-
-However, a program that blindly relies on the binder to be helpful can
-get into trouble, as we discussed in the previous sections, so GNAT
-provides a number of facilities for assisting the programmer in
-developing programs that are robust with respect to elaboration order.
-
-@node Default Behavior in GNAT - Ensuring Safety,Treatment of Pragma Elaborate,Controlling Elaboration in GNAT - External Calls,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{238}@anchor{gnat_ugn/elaboration_order_handling_in_gnat default-behavior-in-gnat-ensuring-safety}@anchor{239}
-@section Default Behavior in GNAT - Ensuring Safety
-
-
-The default behavior in GNAT ensures elaboration safety. In its
-default mode GNAT implements the
-rule we previously described as the right approach. Let's restate it:
-
-@emph{If a unit has elaboration code that can directly or indirectly make a
-call to a subprogram in a |withed| unit, or instantiate a generic
-package in a |withed| unit, then if the |withed| unit
-does not have pragma `@w{`}Pure`@w{`} or `@w{`}Preelaborate`@w{`}, then the client should have an
-`@w{`}Elaborate_All`@w{`} pragma for the |withed| unit.}
-
-@emph{In the case of instantiating a generic subprogram, it is always
-sufficient to have only an `@w{`}Elaborate`@w{`} pragma for the
-|withed| unit.}
-
-By following this rule a client is assured that calls and instantiations
-can be made without risk of an exception.
-
-In this mode GNAT traces all calls that are potentially made from
-elaboration code, and puts in any missing implicit @code{Elaborate}
-and @code{Elaborate_All} pragmas.
-The advantage of this approach is that no elaboration problems
-are possible if the binder can find an elaboration order that is
-consistent with these implicit @code{Elaborate} and
-@code{Elaborate_All} pragmas. The
-disadvantage of this approach is that no such order may exist.
-
-If the binder does not generate any diagnostics, then it means that it has
-found an elaboration order that is guaranteed to be safe. However, the binder
-may still be relying on implicitly generated @code{Elaborate} and
-@code{Elaborate_All} pragmas so portability to other compilers than GNAT is not
-guaranteed.
-
-If it is important to guarantee portability, then the compilations should
-use the @code{-gnatel}
-(info messages for elaboration pragmas) switch. This will cause info messages
-to be generated indicating the missing @code{Elaborate} and
-@code{Elaborate_All} pragmas.
-Consider the following source program:
+@item
+@emph{Scenario suppression}
+
+When the pragma @code{Suppress} is placed in a declarative or statement
+part, without an entity argument, it will suppress implicit @code{Elaborate}
+and @code{Elaborate_All} pragma generation, as well as run-time checks, on
+all scenarios within the region.
@example
-with k;
-package j is
- m : integer := k.r;
-end;
+with Server;
+package body Range_Suppress is
+ pragma Suppress (Elaboration_Check);
+
+ function Func return Integer is
+ begin
+ return Server.Func;
+ end Func;
+
+ procedure Gen is
+ begin
+ Server.Proc;
+ end Gen;
+
+ pragma Unsuppress (Elaboration_Check);
+
+ task body Tsk is
+ begin
+ Server.Proc;
+ end Tsk;
+end Range_Suppress;
@end example
-where it is clear that there
-should be a pragma @code{Elaborate_All}
-for unit @code{k}. An implicit pragma will be generated, and it is
-likely that the binder will be able to honor it. However, if you want
-to port this program to some other Ada compiler than GNAT.
-it is safer to include the pragma explicitly in the source. If this
-unit is compiled with the @code{-gnatel}
-switch, then the compiler outputs an information message:
-
-@example
-1. with k;
-2. package j is
-3. m : integer := k.r;
- |
- >>> info: call to "r" may raise Program_Error
- >>> info: missing pragma Elaborate_All for "k"
-
-4. end;
-@end example
-
-and these messages can be used as a guide for supplying manually
-the missing pragmas. It is usually a bad idea to use this
-option during development. That's because it will tell you when
-you need to put in a pragma, but cannot tell you when it is time
-to take it out. So the use of pragma @code{Elaborate_All} may lead to
-unnecessary dependencies and even false circularities.
-
-This default mode is more restrictive than the Ada Reference
-Manual, and it is possible to construct programs which will compile
-using the dynamic model described there, but will run into a
-circularity using the safer static model we have described.
-
-Of course any Ada compiler must be able to operate in a mode
-consistent with the requirements of the Ada Reference Manual,
-and in particular must have the capability of implementing the
-standard dynamic model of elaboration with run-time checks.
-
-In GNAT, this standard mode can be achieved either by the use of
-the @code{-gnatE} switch on the compiler (@code{gcc} or
-@code{gnatmake}) command, or by the use of the configuration pragma:
-
-@example
-pragma Elaboration_Checks (DYNAMIC);
-@end example
-
-Either approach will cause the unit affected to be compiled using the
-standard dynamic run-time elaboration checks described in the Ada
-Reference Manual. The static model is generally preferable, since it
-is clearly safer to rely on compile and link time checks rather than
-run-time checks. However, in the case of legacy code, it may be
-difficult to meet the requirements of the static model. This
-issue is further discussed in
-@ref{23a,,What to Do If the Default Elaboration Behavior Fails}.
-
-Note that the static model provides a strict subset of the allowed
-behavior and programs of the Ada Reference Manual, so if you do
-adhere to the static model and no circularities exist,
-then you are assured that your program will
-work using the dynamic model, providing that you remove any
-pragma Elaborate statements from the source.
-
-@node Treatment of Pragma Elaborate,Elaboration Issues for Library Tasks,Default Behavior in GNAT - Ensuring Safety,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat treatment-of-pragma-elaborate}@anchor{23b}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{23c}
-@section Treatment of Pragma Elaborate
-
-
-@geindex Pragma Elaborate
-
-The use of @code{pragma Elaborate}
-should generally be avoided in Ada 95 and Ada 2005 programs,
-since there is no guarantee that transitive calls
-will be properly handled. Indeed at one point, this pragma was placed
-in Annex J (Obsolescent Features), on the grounds that it is never useful.
-
-Now that's a bit restrictive. In practice, the case in which
-@code{pragma Elaborate} is useful is when the caller knows that there
-are no transitive calls, or that the called unit contains all necessary
-transitive @code{pragma Elaborate} statements, and legacy code often
-contains such uses.
-
-Strictly speaking the static mode in GNAT should ignore such pragmas,
-since there is no assurance at compile time that the necessary safety
-conditions are met. In practice, this would cause GNAT to be incompatible
-with correctly written Ada 83 code that had all necessary
-@code{pragma Elaborate} statements in place. Consequently, we made the
-decision that GNAT in its default mode will believe that if it encounters
-a @code{pragma Elaborate} then the programmer knows what they are doing,
-and it will trust that no elaboration errors can occur.
-
-The result of this decision is two-fold. First to be safe using the
-static mode, you should remove all @code{pragma Elaborate} statements.
-Second, when fixing circularities in existing code, you can selectively
-use @code{pragma Elaborate} statements to convince the static mode of
-GNAT that it need not generate an implicit @code{pragma Elaborate_All}
-statement.
-
-When using the static mode with @code{-gnatwl}, any use of
-@code{pragma Elaborate} will generate a warning about possible
-problems.
+In the example above, a pair of Suppress/Unsuppress pragmas define a region
+of suppression within package body @code{Range_Suppress}. As a result, the
+calls to @code{Server.Func} in @code{Func} and @code{Server.Proc} in @code{Gen} will
+not generate any implicit @code{Elaborate} and @code{Elaborate_All} pragmas or
+run-time checks.
+@end itemize
+@end itemize
+
+@node Resolving Task Issues,Elaboration-related Compiler Switches,Resolving Elaboration Circularities,Elaboration Order Handling in GNAT
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{246}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-task-issues}@anchor{247}
+@section Resolving Task Issues
-@node Elaboration Issues for Library Tasks,Mixing Elaboration Models,Treatment of Pragma Elaborate,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-issues-for-library-tasks}@anchor{23d}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{23e}
-@section Elaboration Issues for Library Tasks
+The model of execution in Ada dictates that elaboration must first take place,
+and only then can the main program be started. Tasks which are activated during
+elaboration violate this model and may lead to serious concurrent problems at
+elaboration time.
-@geindex Library tasks
-@geindex elaboration issues
+A task can be activated in two different ways:
-@geindex Elaboration of library tasks
-In this section we examine special elaboration issues that arise for
-programs that declare library level tasks.
+@itemize *
-Generally the model of execution of an Ada program is that all units are
-elaborated, and then execution of the program starts. However, the
-declaration of library tasks definitely does not fit this model. The
-reason for this is that library tasks start as soon as they are declared
-(more precisely, as soon as the statement part of the enclosing package
-body is reached), that is to say before elaboration
-of the program is complete. This means that if such a task calls a
-subprogram, or an entry in another task, the callee may or may not be
-elaborated yet, and in the standard
-Reference Manual model of dynamic elaboration checks, you can even
-get timing dependent Program_Error exceptions, since there can be
-a race between the elaboration code and the task code.
+@item
+The task is created by an allocator in which case it is activated immediately
+after the allocator is evaluated.
-The static model of elaboration in GNAT seeks to avoid all such
-dynamic behavior, by being conservative, and the conservative
-approach in this particular case is to assume that all the code
-in a task body is potentially executed at elaboration time if
-a task is declared at the library level.
+@item
+The task is declared at the library level or within some nested master in
+which case it is activated before starting execution of the statement
+sequence of the master defining the task.
+@end itemize
-This can definitely result in unexpected circularities. Consider
-the following example
+Since the elaboration of a partition is performed by the environment task
+servicing that partition, any tasks activated during elaboration may be in
+a race with the environment task, and lead to unpredictable state and behavior.
+The static model seeks to avoid such interactions by assuming that all code in
+the task body is executed at elaboration time, if the task was activated by
+elaboration code.
@example
package Decls is
- task Lib_Task is
- entry Start;
- end Lib_Task;
+ task Lib_Task is
+ entry Start;
+ end Lib_Task;
- type My_Int is new Integer;
+ type My_Int is new Integer;
- function Ident (M : My_Int) return My_Int;
+ function Ident (M : My_Int) return My_Int;
end Decls;
+@end example
+@example
with Utils;
package body Decls is
- task body Lib_Task is
- begin
- accept Start;
- Utils.Put_Val (2);
- end Lib_Task;
-
- function Ident (M : My_Int) return My_Int is
- begin
- return M;
- end Ident;
+ task body Lib_Task is
+ begin
+ accept Start;
+ Utils.Put_Val (2);
+ end Lib_Task;
+
+ function Ident (M : My_Int) return My_Int is
+ begin
+ return M;
+ end Ident;
end Decls;
+@end example
+@example
with Decls;
package Utils is
- procedure Put_Val (Arg : Decls.My_Int);
+ procedure Put_Val (Arg : Decls.My_Int);
end Utils;
+@end example
-with Text_IO;
+@example
+with Ada.Text_IO; use Ada.Text_IO;
package body Utils is
- procedure Put_Val (Arg : Decls.My_Int) is
- begin
- Text_IO.Put_Line (Decls.My_Int'Image (Decls.Ident (Arg)));
- end Put_Val;
+ procedure Put_Val (Arg : Decls.My_Int) is
+ begin
+ Put_Line (Arg'Img);
+ end Put_Val;
end Utils;
+@end example
+@example
with Decls;
procedure Main is
begin
Decls.Lib_Task.Start;
-end;
+end Main;
@end example
-If the above example is compiled in the default static elaboration
-mode, then a circularity occurs. The circularity comes from the call
-@code{Utils.Put_Val} in the task body of @code{Decls.Lib_Task}. Since
-this call occurs in elaboration code, we need an implicit pragma
-@code{Elaborate_All} for @code{Utils}. This means that not only must
-the spec and body of @code{Utils} be elaborated before the body
-of @code{Decls}, but also the spec and body of any unit that is
-@emph{with}ed by the body of @code{Utils} must also be elaborated before
-the body of @code{Decls}. This is the transitive implication of
-pragma @code{Elaborate_All} and it makes sense, because in general
-the body of @code{Put_Val} might have a call to something in a
-@emph{with}ed unit.
-
-In this case, the body of Utils (actually its spec) @emph{with}s
-@code{Decls}. Unfortunately this means that the body of @code{Decls}
-must be elaborated before itself, in case there is a call from the
-body of @code{Utils}.
-
-Here is the exact chain of events we are worrying about:
-
+When the above example is compiled with the static model, an elaboration
+circularity arises:
-@itemize *
-
-@item
-In the body of @code{Decls} a call is made from within the body of a library
-task to a subprogram in the package @code{Utils}. Since this call may
-occur at elaboration time (given that the task is activated at elaboration
-time), we have to assume the worst, i.e., that the
-call does happen at elaboration time.
-
-@item
-This means that the body and spec of @code{Util} must be elaborated before
-the body of @code{Decls} so that this call does not cause an access before
-elaboration.
-
-@item
-Within the body of @code{Util}, specifically within the body of
-@code{Util.Put_Val} there may be calls to any unit @emph{with}ed
-by this package.
-
-@item
-One such @emph{with}ed package is package @code{Decls}, so there
-might be a call to a subprogram in @code{Decls} in @code{Put_Val}.
-In fact there is such a call in this example, but we would have to
-assume that there was such a call even if it were not there, since
-we are not supposed to write the body of @code{Decls} knowing what
-is in the body of @code{Utils}; certainly in the case of the
-static elaboration model, the compiler does not know what is in
-other bodies and must assume the worst.
-
-@item
-This means that the spec and body of @code{Decls} must also be
-elaborated before we elaborate the unit containing the call, but
-that unit is @code{Decls}! This means that the body of @code{Decls}
-must be elaborated before itself, and that's a circularity.
-@end itemize
-
-Indeed, if you add an explicit pragma @code{Elaborate_All} for @code{Utils} in
-the body of @code{Decls} you will get a true Ada Reference Manual
-circularity that makes the program illegal.
+@example
+error: elaboration circularity detected
+info: "decls (body)" must be elaborated before "decls (body)"
+info: reason: implicit Elaborate_All in unit "decls (body)"
+info: recompile "decls (body)" with -gnatel for full details
+info: "decls (body)"
+info: must be elaborated along with its spec:
+info: "decls (spec)"
+info: which is withed by:
+info: "utils (spec)"
+info: which is withed by:
+info: "decls (body)"
+@end example
-In practice, we have found that problems with the static model of
-elaboration in existing code often arise from library tasks, so
-we must address this particular situation.
+In the above example, @code{Decls} must be elaborated prior to @code{Main} by virtue
+of a with clause. The elaboration of @code{Decls} activates task @code{Lib_Task}. The
+static model conservatibely assumes that all code within the body of
+@code{Lib_Task} is executed, and generates an implicit @code{Elaborate_All} pragma
+for @code{Units} due to the call to @code{Utils.Put_Val}. The pragma implies that
+both the spec and body of @code{Utils}, along with any units they @emph{with},
+must be elaborated prior to @code{Decls}. However, @code{Utils}'s spec @emph{with}s
+@code{Decls}, implying that @code{Decls} must be elaborated before @code{Utils}. The end
+result is that @code{Utils} must be elaborated prior to @code{Utils}, and this
+leads to a circularity.
-Note that if we compile and run the program above, using the dynamic model of
-elaboration (that is to say use the @code{-gnatE} switch),
-then it compiles, binds,
-links, and runs, printing the expected result of 2. Therefore in some sense
-the circularity here is only apparent, and we need to capture
-the properties of this program that distinguish it from other library-level
-tasks that have real elaboration problems.
+In reality, the example above will not exhibit an ABE problem at run time.
+When the body of task @code{Lib_Task} is activated, execution will wait for entry
+@code{Start} to be accepted, and the call to @code{Utils.Put_Val} will not take place
+at elaboration time. Task @code{Lib_Task} will resume its execution after the main
+program is executed because @code{Main} performs a rendezvous with
+@code{Lib_Task.Start}, and at that point all units have already been elaborated.
+As a result, the static model may seem overly conservative, partly because it
+does not take control and data flow into account.
-We have four possible answers to this question:
+When faced with a task elaboration circularity, a programmer has several
+options available:
@itemize *
@item
-Use the dynamic model of elaboration.
+@emph{Use the dynamic model}
-If we use the @code{-gnatE} switch, then as noted above, the program works.
-Why is this? If we examine the task body, it is apparent that the task cannot
-proceed past the
-@code{accept} statement until after elaboration has been completed, because
-the corresponding entry call comes from the main program, not earlier.
-This is why the dynamic model works here. But that's really giving
-up on a precise analysis, and we prefer to take this approach only if we cannot
-solve the
-problem in any other manner. So let us examine two ways to reorganize
-the program to avoid the potential elaboration problem.
+The dynamic model does not generate implicit @code{Elaborate} and
+@code{Elaborate_All} pragmas. Instead, it will install checks prior to every
+call in the example above, thus verifying the successful elaboration of
+@code{Utils.Put_Val} in case the call to it takes place at elaboration time.
+The dynamic model is enabled with compiler switch @code{-gnatE}.
@item
-Split library tasks into separate packages.
+@emph{Isolate the tasks}
-Write separate packages, so that library tasks are isolated from
-other declarations as much as possible. Let us look at a variation on
-the above program.
+Relocating tasks in their own separate package could decouple them from
+dependencies that would otherwise cause an elaboration circularity. The
+example above can be rewritten as follows:
@example
-package Decls1 is
- task Lib_Task is
- entry Start;
- end Lib_Task;
+package Decls1 is -- new
+ task Lib_Task is
+ entry Start;
+ end Lib_Task;
end Decls1;
+@end example
+@example
with Utils;
-package body Decls1 is
- task body Lib_Task is
- begin
- accept Start;
- Utils.Put_Val (2);
- end Lib_Task;
+package body Decls1 is -- new
+ task body Lib_Task is
+ begin
+ accept Start;
+ Utils.Put_Val (2);
+ end Lib_Task;
end Decls1;
+@end example
-package Decls2 is
- type My_Int is new Integer;
- function Ident (M : My_Int) return My_Int;
+@example
+package Decls2 is -- new
+ type My_Int is new Integer;
+ function Ident (M : My_Int) return My_Int;
end Decls2;
+@end example
+@example
with Utils;
-package body Decls2 is
- function Ident (M : My_Int) return My_Int is
- begin
- return M;
- end Ident;
+package body Decls2 is -- new
+ function Ident (M : My_Int) return My_Int is
+ begin
+ return M;
+ end Ident;
end Decls2;
+@end example
+@example
with Decls2;
package Utils is
- procedure Put_Val (Arg : Decls2.My_Int);
+ procedure Put_Val (Arg : Decls2.My_Int);
end Utils;
+@end example
-with Text_IO;
+@example
+with Ada.Text_IO; use Ada.Text_IO;
package body Utils is
- procedure Put_Val (Arg : Decls2.My_Int) is
- begin
- Text_IO.Put_Line (Decls2.My_Int'Image (Decls2.Ident (Arg)));
- end Put_Val;
+ procedure Put_Val (Arg : Decls2.My_Int) is
+ begin
+ Put_Line (Arg'Img);
+ end Put_Val;
end Utils;
+@end example
+@example
with Decls1;
procedure Main is
begin
Decls1.Lib_Task.Start;
-end;
+end Main;
@end example
-All we have done is to split @code{Decls} into two packages, one
-containing the library task, and one containing everything else. Now
-there is no cycle, and the program compiles, binds, links and executes
-using the default static model of elaboration.
-
@item
-Declare separate task types.
+@emph{Declare the tasks}
-A significant part of the problem arises because of the use of the
-single task declaration form. This means that the elaboration of
-the task type, and the elaboration of the task itself (i.e., the
-creation of the task) happen at the same time. A good rule
-of style in Ada is to always create explicit task types. By
-following the additional step of placing task objects in separate
-packages from the task type declaration, many elaboration problems
-are avoided. Here is another modified example of the example program:
+The original example uses a single task declaration for @code{Lib_Task}. An
+explicit task type declaration and a properly placed task object could avoid
+the dependencies that would otherwise cause an elaboration circularity. The
+example can be rewritten as follows:
@example
package Decls is
- task type Lib_Task_Type is
- entry Start;
- end Lib_Task_Type;
+ task type Lib_Task is -- new
+ entry Start;
+ end Lib_Task;
- type My_Int is new Integer;
+ type My_Int is new Integer;
- function Ident (M : My_Int) return My_Int;
+ function Ident (M : My_Int) return My_Int;
end Decls;
+@end example
+@example
with Utils;
package body Decls is
- task body Lib_Task_Type is
- begin
- accept Start;
- Utils.Put_Val (2);
- end Lib_Task_Type;
-
- function Ident (M : My_Int) return My_Int is
- begin
- return M;
- end Ident;
+ task body Lib_Task is
+ begin
+ accept Start;
+ Utils.Put_Val (2);
+ end Lib_Task;
+
+ function Ident (M : My_Int) return My_Int is
+ begin
+ return M;
+ end Ident;
end Decls;
+@end example
+@example
with Decls;
package Utils is
- procedure Put_Val (Arg : Decls.My_Int);
+ procedure Put_Val (Arg : Decls.My_Int);
end Utils;
+@end example
-with Text_IO;
+@example
+with Ada.Text_IO; use Ada.Text_IO;
package body Utils is
- procedure Put_Val (Arg : Decls.My_Int) is
- begin
- Text_IO.Put_Line (Decls.My_Int'Image (Decls.Ident (Arg)));
- end Put_Val;
+ procedure Put_Val (Arg : Decls.My_Int) is
+ begin
+ Put_Line (Arg'Img);
+ end Put_Val;
end Utils;
+@end example
+@example
with Decls;
-package Declst is
- Lib_Task : Decls.Lib_Task_Type;
-end Declst;
+package Obj_Decls is -- new
+ Task_Obj : Decls.Lib_Task;
+end Obj_Decls;
+@end example
-with Declst;
+@example
+with Obj_Decls;
procedure Main is
begin
- Declst.Lib_Task.Start;
-end;
+ Obj_Decls.Task_Obj.Start; -- new
+end Main;
@end example
-What we have done here is to replace the @code{task} declaration in
-package @code{Decls} with a @code{task type} declaration. Then we
-introduce a separate package @code{Declst} to contain the actual
-task object. This separates the elaboration issues for
-the @code{task type}
-declaration, which causes no trouble, from the elaboration issues
-of the task object, which is also unproblematic, since it is now independent
-of the elaboration of @code{Utils}.
-This separation of concerns also corresponds to
-a generally sound engineering principle of separating declarations
-from instances. This version of the program also compiles, binds, links,
-and executes, generating the expected output.
-@end itemize
-
-@geindex No_Entry_Calls_In_Elaboration_Code restriction
-
-
-@itemize *
-
@item
-Use No_Entry_Calls_In_Elaboration_Code restriction.
-
-The previous two approaches described how a program can be restructured
-to avoid the special problems caused by library task bodies. in practice,
-however, such restructuring may be difficult to apply to existing legacy code,
-so we must consider solutions that do not require massive rewriting.
+@emph{Use restriction No_Entry_Calls_In_Elaboration_Code}
-Let us consider more carefully why our original sample program works
-under the dynamic model of elaboration. The reason is that the code
-in the task body blocks immediately on the @code{accept}
-statement. Now of course there is nothing to prohibit elaboration
-code from making entry calls (for example from another library level task),
-so we cannot tell in isolation that
-the task will not execute the accept statement during elaboration.
-
-However, in practice it is very unusual to see elaboration code
-make any entry calls, and the pattern of tasks starting
-at elaboration time and then immediately blocking on @code{accept} or
-@code{select} statements is very common. What this means is that
-the compiler is being too pessimistic when it analyzes the
-whole package body as though it might be executed at elaboration
-time.
+The issue exhibited in the original example under this section revolves
+around the body of @code{Lib_Task} blocking on an accept statement. There is
+no rule to prevent elaboration code from performing entry calls, however in
+practice this is highly unusual. In addition, the pattern of starting tasks
+at elaboration time and then immediately blocking on accept or select
+statements is quite common.
-If we know that the elaboration code contains no entry calls, (a very safe
-assumption most of the time, that could almost be made the default
-behavior), then we can compile all units of the program under control
-of the following configuration pragma:
+If a programmer knows that elaboration code will not perform any entry
+calls, then the programmer can indicate that the static model should not
+process the remainder of a task body once an accept or select statement has
+been encountered. This behavior can be specified by a configuration pragma:
@example
pragma Restrictions (No_Entry_Calls_In_Elaboration_Code);
@end example
-This pragma can be placed in the @code{gnat.adc} file in the usual
-manner. If we take our original unmodified program and compile it
-in the presence of a @code{gnat.adc} containing the above pragma,
-then once again, we can compile, bind, link, and execute, obtaining
-the expected result. In the presence of this pragma, the compiler does
-not trace calls in a task body, that appear after the first @code{accept}
-or @code{select} statement, and therefore does not report a potential
-circularity in the original program.
-
-The compiler will check to the extent it can that the above
-restriction is not violated, but it is not always possible to do a
-complete check at compile time, so it is important to use this
-pragma only if the stated restriction is in fact met, that is to say
-no task receives an entry call before elaboration of all units is completed.
+In addition to the change in behavior with respect to task bodies, the
+static model will verify that no entry calls take place at elaboration time.
@end itemize
-@node Mixing Elaboration Models,What to Do If the Default Elaboration Behavior Fails,Elaboration Issues for Library Tasks,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{23f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{240}
-@section Mixing Elaboration Models
+@node Elaboration-related Compiler Switches,Summary of Procedures for Elaboration Control,Resolving Task Issues,Elaboration Order Handling in GNAT
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{248}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id15}@anchor{249}
+@section Elaboration-related Compiler Switches
-So far, we have assumed that the entire program is either compiled
-using the dynamic model or static model, ensuring consistency. It
-is possible to mix the two models, but rules have to be followed
-if this mixing is done to ensure that elaboration checks are not
-omitted.
+GNAT has several switches that affect the elaboration model and consequently
+the elaboration order chosen by the binder.
-The basic rule is that
-@strong{a unit compiled with the static model cannot
-be |withed| by a unit compiled with the dynamic model}.
-The reason for this is that in the static model, a unit assumes that
-its clients guarantee to use (the equivalent of) pragma
-@code{Elaborate_All} so that no elaboration checks are required
-in inner subprograms, and this assumption is violated if the
-client is compiled with dynamic checks.
+@geindex -gnatdE (gnat)
-The precise rule is as follows. A unit that is compiled with dynamic
-checks can only @emph{with} a unit that meets at least one of the
-following criteria:
+@table @asis
-@itemize *
+@item @code{-gnatdE}
-@item
-The @emph{with}ed unit is itself compiled with dynamic elaboration
-checks (that is with the @code{-gnatE} switch.
+Elaboration checks on predefined units
-@item
-The @emph{with}ed unit is an internal GNAT implementation unit from
-the System, Interfaces, Ada, or GNAT hierarchies.
+When this switch is in effect, GNAT will consider scenarios and targets that
+come from the Ada, GNAT, Interfaces, and System hierarchies. This switch is
+useful when a programmer has defined a custom grandchild of those packages.
+@end table
-@item
-The @emph{with}ed unit has pragma Preelaborate or pragma Pure.
+@geindex -gnatd.G (gnat)
-@item
-The @emph{with}ing unit (that is the client) has an explicit pragma
-@code{Elaborate_All} for the @emph{with}ed unit.
-@end itemize
-If this rule is violated, that is if a unit with dynamic elaboration
-checks @emph{with}s a unit that does not meet one of the above four
-criteria, then the binder (@code{gnatbind}) will issue a warning
-similar to that in the following example:
+@table @asis
+
+@item @code{-gnatd.G}
+
+Ignore calls through generic formal parameters for elaboration
+
+When this switch is in effect, GNAT will ignore calls that invoke generic
+actual entries, operators, or subprograms via generic formal subprograms. As
+a result, GNAT will not generate implicit @code{Elaborate} and @code{Elaborate_All}
+pragmas, and run-time checks for such calls. Note that this switch does not
+overlap with @code{-gnatdL}.
@example
-warning: "x.ads" has dynamic elaboration checks and with's
-warning: "y.ads" which has static elaboration checks
+package body Ignore_Calls is
+ function ABE return Integer;
+
+ generic
+ with function Gen_Formal return Integer;
+ package Gen is
+ Val : constant Integer := Gen_Formal;
+ end Gen;
+
+ package Inst is new Gen (ABE);
+
+ function ABE return Integer is
+ begin
+ ...
+ end ABE;
+end Ignore_Calls;
@end example
-These warnings indicate that the rule has been violated, and that as a result
-elaboration checks may be missed in the resulting executable file.
-This warning may be suppressed using the @code{-ws} binder switch
-in the usual manner.
+In the example above, the call to function @code{ABE} will be ignored because it
+occurs during the elaboration of instance @code{Inst}, through a call to generic
+formal subprogram @code{Gen_Formal}.
+@end table
+
+@geindex -gnatdL (gnat)
+
-One useful application of this mixing rule is in the case of a subsystem
-which does not itself @emph{with} units from the remainder of the
-application. In this case, the entire subsystem can be compiled with
-dynamic checks to resolve a circularity in the subsystem, while
-allowing the main application that uses this subsystem to be compiled
-using the more reliable default static model.
+@table @asis
-@node What to Do If the Default Elaboration Behavior Fails,Elaboration for Indirect Calls,Mixing Elaboration Models,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{241}@anchor{gnat_ugn/elaboration_order_handling_in_gnat what-to-do-if-the-default-elaboration-behavior-fails}@anchor{23a}
-@section What to Do If the Default Elaboration Behavior Fails
+@item @code{-gnatdL}
+Ignore external calls from instances for elaboration
-If the binder cannot find an acceptable order, it outputs detailed
-diagnostics. For example:
+When this switch is in effect, GNAT will ignore calls that originate from
+within an instance and directly target an entry, operator, or subprogram
+defined outside the instance. As a result, GNAT will not generate implicit
+@code{Elaborate} and @code{Elaborate_All} pragmas, and run-time checks for such
+calls. Note that this switch does not overlap with @code{-gnatd.G}.
@example
-error: elaboration circularity detected
-info: "proc (body)" must be elaborated before "pack (body)"
-info: reason: Elaborate_All probably needed in unit "pack (body)"
-info: recompile "pack (body)" with -gnatel
-info: for full details
-info: "proc (body)"
-info: is needed by its spec:
-info: "proc (spec)"
-info: which is withed by:
-info: "pack (body)"
-info: "pack (body)" must be elaborated before "proc (body)"
-info: reason: pragma Elaborate in unit "proc (body)"
-@end example
-
-In this case we have a cycle that the binder cannot break. On the one
-hand, there is an explicit pragma Elaborate in @code{proc} for
-@code{pack}. This means that the body of @code{pack} must be elaborated
-before the body of @code{proc}. On the other hand, there is elaboration
-code in @code{pack} that calls a subprogram in @code{proc}. This means
-that for maximum safety, there should really be a pragma
-Elaborate_All in @code{pack} for @code{proc} which would require that
-the body of @code{proc} be elaborated before the body of
-@code{pack}. Clearly both requirements cannot be satisfied.
-Faced with a circularity of this kind, you have three different options.
+package body Ignore_Calls is
+ function ABE return Integer;
+ generic
+ package Gen is
+ Val : constant Integer := ABE;
+ end Gen;
-@itemize *
+ package Inst is new Gen;
-@item
-@emph{Fix the program}
+ function ABE return Integer is
+ begin
+ ...
+ end ABE;
+end Ignore_Calls;
+@end example
-The most desirable option from the point of view of long-term maintenance
-is to rearrange the program so that the elaboration problems are avoided.
-One useful technique is to place the elaboration code into separate
-child packages. Another is to move some of the initialization code to
-explicitly called subprograms, where the program controls the order
-of initialization explicitly. Although this is the most desirable option,
-it may be impractical and involve too much modification, especially in
-the case of complex legacy code.
+In the example above, the call to function @code{ABE} will be ignored because it
+originates from within an instance and targets a subprogram defined outside
+the instance.
+@end table
-@item
-@emph{Perform dynamic checks}
+@geindex -gnatd.o (gnat)
-If the compilations are done using the @code{-gnatE}
-(dynamic elaboration check) switch, then GNAT behaves in a quite different
-manner. Dynamic checks are generated for all calls that could possibly result
-in raising an exception. With this switch, the compiler does not generate
-implicit @code{Elaborate} or @code{Elaborate_All} pragmas. The behavior then is
-exactly as specified in the @cite{Ada Reference Manual}.
-The binder will generate
-an executable program that may or may not raise @code{Program_Error}, and then
-it is the programmer's job to ensure that it does not raise an exception. Note
-that it is important to compile all units with the switch, it cannot be used
-selectively.
-@item
-@emph{Suppress checks}
+@table @asis
-The drawback of dynamic checks is that they generate a
-significant overhead at run time, both in space and time. If you
-are absolutely sure that your program cannot raise any elaboration
-exceptions, and you still want to use the dynamic elaboration model,
-then you can use the configuration pragma
-@code{Suppress (Elaboration_Check)} to suppress all such checks. For
-example this pragma could be placed in the @code{gnat.adc} file.
+@item @code{-gnatd.o}
-@item
-@emph{Suppress checks selectively}
+Conservative elaboration order for indirect calls
-When you know that certain calls or instantiations in elaboration code cannot
-possibly lead to an elaboration error, and the binder nevertheless complains
-about implicit @code{Elaborate} and @code{Elaborate_All} pragmas that lead to
-elaboration circularities, it is possible to remove those warnings locally and
-obtain a program that will bind. Clearly this can be unsafe, and it is the
-responsibility of the programmer to make sure that the resulting program has no
-elaboration anomalies. The pragma @code{Suppress (Elaboration_Check)} can be
-used with different granularity to suppress warnings and break elaboration
-circularities:
+When this switch is in effect, GNAT will treat @code{'Access} of an entry,
+operator, or subprogram as an immediate call to that target. As a result,
+GNAT will generate implicit @code{Elaborate} and @code{Elaborate_All} pragmas as
+well as run-time checks for such attribute references.
+@example
+ 1. package body Attribute_Call is
+ 2. function Func return Integer;
+ 3. type Func_Ptr is access function return Integer;
+ 4.
+ 5. Ptr : constant Func_Ptr := Func'Access;
+ |
+ >>> warning: cannot call "Func" before body seen
+ >>> warning: Program_Error may be raised at run time
+ >>> warning: body of unit "Attribute_Call" elaborated
+ >>> warning: "Access" of "Func" taken at line 5
+ >>> warning: function "Func" called at line 5
-@itemize *
+ 6.
+ 7. function Func return Integer is
+ 8. begin
+ 9. ...
+10. end Func;
+11. end Attribute_Call;
+@end example
-@item
-Place the pragma that names the called subprogram in the declarative part
-that contains the call.
+In the example above, the elaboration of declaration @code{Ptr} is assigned
+@code{Func'Access} before the body of @code{Func} has been elaborated.
+@end table
-@item
-Place the pragma in the declarative part, without naming an entity. This
-disables warnings on all calls in the corresponding declarative region.
+@geindex -gnatd.U (gnat)
-@item
-Place the pragma in the package spec that declares the called subprogram,
-and name the subprogram. This disables warnings on all elaboration calls to
-that subprogram.
-@item
-Place the pragma in the package spec that declares the called subprogram,
-without naming any entity. This disables warnings on all elaboration calls to
-all subprograms declared in this spec.
+@table @asis
-@item
-Use Pragma Elaborate.
+@item @code{-gnatd.U}
-As previously described in section @ref{23b,,Treatment of Pragma Elaborate},
-GNAT in static mode assumes that a @code{pragma} Elaborate indicates correctly
-that no elaboration checks are required on calls to the designated unit.
-There may be cases in which the caller knows that no transitive calls
-can occur, so that a @code{pragma Elaborate} will be sufficient in a
-case where @code{pragma Elaborate_All} would cause a circularity.
-@end itemize
+Ignore indirect calls for static elaboration
-These five cases are listed in order of decreasing safety, and therefore
-require increasing programmer care in their application. Consider the
-following program:
+When this switch is in effect, GNAT will ignore @code{'Access} of an entry,
+operator, or subprogram when the static model is in effect.
+@end table
-@example
-package Pack1 is
- function F1 return Integer;
- X1 : Integer;
-end Pack1;
+@geindex -gnatd.y (gnat)
-package Pack2 is
- function F2 return Integer;
- function Pure (x : integer) return integer;
- -- pragma Suppress (Elaboration_Check, On => Pure); -- (3)
- -- pragma Suppress (Elaboration_Check); -- (4)
-end Pack2;
-with Pack2;
-package body Pack1 is
- function F1 return Integer is
- begin
- return 100;
- end F1;
- Val : integer := Pack2.Pure (11); -- Elab. call (1)
-begin
- declare
- -- pragma Suppress(Elaboration_Check, Pack2.F2); -- (1)
- -- pragma Suppress(Elaboration_Check); -- (2)
- begin
- X1 := Pack2.F2 + 1; -- Elab. call (2)
- end;
-end Pack1;
+@table @asis
-with Pack1;
-package body Pack2 is
- function F2 return Integer is
- begin
- return Pack1.F1;
- end F2;
- function Pure (x : integer) return integer is
- begin
- return x ** 3 - 3 * x;
- end;
-end Pack2;
+@item @code{-gnatd.y}
-with Pack1, Ada.Text_IO;
-procedure Proc3 is
-begin
- Ada.Text_IO.Put_Line(Pack1.X1'Img); -- 101
-end Proc3;
-@end example
+Disable implicit pragma Elaborate[_All] on task bodies
-In the absence of any pragmas, an attempt to bind this program produces
-the following diagnostics:
+When this switch is in effect, GNAT will not generate @code{Elaborate} and
+@code{Elaborate_All} pragmas if the need for the pragma came directly or
+indirectly from a task body.
@example
-error: elaboration circularity detected
-info: "pack1 (body)" must be elaborated before "pack1 (body)"
-info: reason: Elaborate_All probably needed in unit "pack1 (body)"
-info: recompile "pack1 (body)" with -gnatel for full details
-info: "pack1 (body)"
-info: must be elaborated along with its spec:
-info: "pack1 (spec)"
-info: which is withed by:
-info: "pack2 (body)"
-info: which must be elaborated along with its spec:
-info: "pack2 (spec)"
-info: which is withed by:
-info: "pack1 (body)"
+with Server;
+package body Disable_Task is
+ task T;
+
+ task body T is
+ begin
+ Server.Proc;
+ end T;
+end Disable_Task;
@end example
-The sources of the circularity are the two calls to @code{Pack2.Pure} and
-@code{Pack2.F2} in the body of @code{Pack1}. We can see that the call to
-F2 is safe, even though F2 calls F1, because the call appears after the
-elaboration of the body of F1. Therefore the pragma (1) is safe, and will
-remove the warning on the call. It is also possible to use pragma (2)
-because there are no other potentially unsafe calls in the block.
+In the example above, the activation of single task @code{T} invokes
+@code{Server.Proc}, which implies that @code{Server} requires @code{Elaborate_All},
+however GNAT will not generate the pragma.
+@end table
-The call to @code{Pure} is safe because this function does not depend on the
-state of @code{Pack2}. Therefore any call to this function is safe, and it
-is correct to place pragma (3) in the corresponding package spec.
+@geindex -gnatE (gnat)
-Finally, we could place pragma (4) in the spec of @code{Pack2} to disable
-warnings on all calls to functions declared therein. Note that this is not
-necessarily safe, and requires more detailed examination of the subprogram
-bodies involved. In particular, a call to @code{F2} requires that @code{F1}
-be already elaborated.
-@end itemize
-It is hard to generalize on which of these four approaches should be
-taken. Obviously if it is possible to fix the program so that the default
-treatment works, this is preferable, but this may not always be practical.
-It is certainly simple enough to use @code{-gnatE}
-but the danger in this case is that, even if the GNAT binder
-finds a correct elaboration order, it may not always do so,
-and certainly a binder from another Ada compiler might not. A
-combination of testing and analysis (for which the
-information messages generated with the @code{-gnatel}
-switch can be useful) must be used to ensure that the program is free
-of errors. One switch that is useful in this testing is the
-@code{-p} (pessimistic elaboration order) switch for @code{gnatbind}.
-Normally the binder tries to find an order that has the best chance
-of avoiding elaboration problems. However, if this switch is used, the binder
-plays a devil's advocate role, and tries to choose the order that
-has the best chance of failing. If your program works even with this
-switch, then it has a better chance of being error free, but this is still
-not a guarantee.
-
-For an example of this approach in action, consider the C-tests (executable
-tests) from the ACATS suite. If these are compiled and run with the default
-treatment, then all but one of them succeed without generating any error
-diagnostics from the binder. However, there is one test that fails, and
-this is not surprising, because the whole point of this test is to ensure
-that the compiler can handle cases where it is impossible to determine
-a correct order statically, and it checks that an exception is indeed
-raised at run time.
-
-This one test must be compiled and run using the @code{-gnatE}
-switch, and then it passes. Alternatively, the entire suite can
-be run using this switch. It is never wrong to run with the dynamic
-elaboration switch if your code is correct, and we assume that the
-C-tests are indeed correct (it is less efficient, but efficiency is
-not a factor in running the ACATS tests.)
-
-@node Elaboration for Indirect Calls,Summary of Procedures for Elaboration Control,What to Do If the Default Elaboration Behavior Fails,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{242}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-for-indirect-calls}@anchor{243}
-@section Elaboration for Indirect Calls
-
-
-@geindex Dispatching calls
-
-@geindex Indirect calls
-
-In rare cases, the static elaboration model fails to prevent
-dispatching calls to not-yet-elaborated subprograms. In such cases, we
-fall back to run-time checks; premature calls to any primitive
-operation of a tagged type before the body of the operation has been
-elaborated will raise @code{Program_Error}.
-
-Access-to-subprogram types, however, are handled conservatively in many
-cases. This was not true in earlier versions of the compiler; you can use
-the @code{-gnatd.U} debug switch to revert to the old behavior if the new
-conservative behavior causes elaboration cycles. Here, 'conservative' means
-that if you do @code{P'Access} during elaboration, the compiler will normally
-assume that you might call @code{P} indirectly during elaboration, so it adds an
-implicit @code{pragma Elaborate_All} on the library unit containing @code{P}. The
-@code{-gnatd.U} switch is safe if you know there are no such calls. If the
-program worked before, it will continue to work with @code{-gnatd.U}. But beware
-that code modifications such as adding an indirect call can cause erroneous
-behavior in the presence of @code{-gnatd.U}.
-
-These implicit Elaborate_All pragmas are not added in all cases, because
-they cause elaboration cycles in certain common code patterns. If you want
-even more conservative handling of P'Access, you can use the @code{-gnatd.o}
-switch.
+@table @asis
-See @code{debug.adb} for documentation on the @code{-gnatd...} debug switches.
+@item @code{-gnatE}
-@node Summary of Procedures for Elaboration Control,Other Elaboration Order Considerations,Elaboration for Indirect Calls,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{244}@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{245}
-@section Summary of Procedures for Elaboration Control
+Dynamic elaboration checking mode enabled
+When this switch is in effect, GNAT activates the dynamic elaboration model.
+@end table
-@geindex Elaboration control
+@geindex -gnatel (gnat)
-First, compile your program with the default options, using none of
-the special elaboration-control switches. If the binder successfully
-binds your program, then you can be confident that, apart from issues
-raised by the use of access-to-subprogram types and dynamic dispatching,
-the program is free of elaboration errors. If it is important that the
-program be portable to other compilers than GNAT, then use the
-@code{-gnatel}
-switch to generate messages about missing @code{Elaborate} or
-@code{Elaborate_All} pragmas, and supply the missing pragmas.
-
-If the program fails to bind using the default static elaboration
-handling, then you can fix the program to eliminate the binder
-message, or recompile the entire program with the
-@code{-gnatE} switch to generate dynamic elaboration checks,
-and, if you are sure there really are no elaboration problems,
-use a global pragma @code{Suppress (Elaboration_Check)}.
-
-@node Other Elaboration Order Considerations,Determining the Chosen Elaboration Order,Summary of Procedures for Elaboration Control,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{246}@anchor{gnat_ugn/elaboration_order_handling_in_gnat other-elaboration-order-considerations}@anchor{247}
-@section Other Elaboration Order Considerations
-
-
-This section has been entirely concerned with the issue of finding a valid
-elaboration order, as defined by the Ada Reference Manual. In a case
-where several elaboration orders are valid, the task is to find one
-of the possible valid elaboration orders (and the static model in GNAT
-will ensure that this is achieved).
-
-The purpose of the elaboration rules in the Ada Reference Manual is to
-make sure that no entity is accessed before it has been elaborated. For
-a subprogram, this means that the spec and body must have been elaborated
-before the subprogram is called. For an object, this means that the object
-must have been elaborated before its value is read or written. A violation
-of either of these two requirements is an access before elaboration order,
-and this section has been all about avoiding such errors.
-
-In the case where more than one order of elaboration is possible, in the
-sense that access before elaboration errors are avoided, then any one of
-the orders is 'correct' in the sense that it meets the requirements of
-the Ada Reference Manual, and no such error occurs.
-
-However, it may be the case for a given program, that there are
-constraints on the order of elaboration that come not from consideration
-of avoiding elaboration errors, but rather from extra-lingual logic
-requirements. Consider this example:
-
-@example
-with Init_Constants;
-package Constants is
- X : Integer := 0;
- Y : Integer := 0;
-end Constants;
-
-package Init_Constants is
- procedure P; --* require a body*
-end Init_Constants;
-
-with Constants;
-package body Init_Constants is
- procedure P is begin null; end;
-begin
- Constants.X := 3;
- Constants.Y := 4;
-end Init_Constants;
-with Constants;
-package Calc is
- Z : Integer := Constants.X + Constants.Y;
-end Calc;
+@table @asis
+
+@item @code{-gnatel}
-with Calc;
-with Text_IO; use Text_IO;
-procedure Main is
-begin
- Put_Line (Calc.Z'Img);
-end Main;
-@end example
+Turn on info messages on generated Elaborate[_All] pragmas
-In this example, there is more than one valid order of elaboration. For
-example both the following are correct orders:
+When this switch is in effect, GNAT will emit the following supplementary
+information depending on the elaboration model in effect.
-@example
-Init_Constants spec
-Constants spec
-Calc spec
-Init_Constants body
-Main body
-@end example
-and
+@itemize -
-@example
-Init_Constants spec
-Constants spec
-Init_Constants body
-Calc spec
-Main body
-@end example
+@item
+@emph{Dynamic model}
+
+GNAT will indicate missing @code{Elaborate} and @code{Elaborate_All} pragmas for
+all library-level scenarios within the partition.
+
+@item
+@emph{Static model}
-There is no language rule to prefer one or the other, both are correct
-from an order of elaboration point of view. But the programmatic effects
-of the two orders are very different. In the first, the elaboration routine
-of @code{Calc} initializes @code{Z} to zero, and then the main program
-runs with this value of zero. But in the second order, the elaboration
-routine of @code{Calc} runs after the body of Init_Constants has set
-@code{X} and @code{Y} and thus @code{Z} is set to 7 before @code{Main} runs.
+GNAT will indicate all scenarios executed during elaboration. In addition,
+it will provide detailed traceback when an implicit @code{Elaborate} or
+@code{Elaborate_All} pragma is generated.
-One could perhaps by applying pretty clever non-artificial intelligence
-to the situation guess that it is more likely that the second order of
-elaboration is the one desired, but there is no formal linguistic reason
-to prefer one over the other. In fact in this particular case, GNAT will
-prefer the second order, because of the rule that bodies are elaborated
-as soon as possible, but it's just luck that this is what was wanted
-(if indeed the second order was preferred).
+@item
+@emph{SPARK model}
-If the program cares about the order of elaboration routines in a case like
-this, it is important to specify the order required. In this particular
-case, that could have been achieved by adding to the spec of Calc:
+GNAT will indicate how an elaboration requirement is met by the context of
+a unit.
@example
-pragma Elaborate_All (Constants);
+1. with Server; pragma Elaborate_All (Server);
+2. package Client with SPARK_Mode is
+3. Val : constant Integer := Server.Func;
+ |
+ >>> info: call to "Func" during elaboration in SPARK
+ >>> info: "Elaborate_All" requirement for unit "Server" met by pragma at line 1
+
+4. end Client;
@end example
+@end itemize
+@end table
-which requires that the body (if any) and spec of @code{Constants},
-as well as the body and spec of any unit @emph{with}ed by
-@code{Constants} be elaborated before @code{Calc} is elaborated.
+@geindex -gnatw.f (gnat)
-Clearly no automatic method can always guess which alternative you require,
-and if you are working with legacy code that had constraints of this kind
-which were not properly specified by adding @code{Elaborate} or
-@code{Elaborate_All} pragmas, then indeed it is possible that two different
-compilers can choose different orders.
-However, GNAT does attempt to diagnose the common situation where there
-are uninitialized variables in the visible part of a package spec, and the
-corresponding package body has an elaboration block that directly or
-indirectly initializes one or more of these variables. This is the situation
-in which a pragma Elaborate_Body is usually desirable, and GNAT will generate
-a warning that suggests this addition if it detects this situation.
+@table @asis
+
+@item @code{-gnatw.f}
-The @code{gnatbind` :switch:`-p` switch may be useful in smoking
-out problems. This switch causes bodies to be elaborated as late as possible
-instead of as early as possible. In the example above, it would have forced
-the choice of the first elaboration order. If you get different results
-when using this switch, and particularly if one set of results is right,
-and one is wrong as far as you are concerned, it shows that you have some
-missing `@w{`}Elaborate} pragmas. For the example above, we have the
-following output:
+Turn on warnings for suspicious Subp'Access
+
+When this switch is in effect, GNAT will treat @code{'Access} of an entry,
+operator, or subprogram as a potential call to the target and issue warnings:
@example
-$ gnatmake -f -q main
-$ main
- 7
-$ gnatmake -f -q main -bargs -p
-$ main
- 0
+ 1. package body Attribute_Call is
+ 2. function Func return Integer;
+ 3. type Func_Ptr is access function return Integer;
+ 4.
+ 5. Ptr : constant Func_Ptr := Func'Access;
+ |
+ >>> warning: "Access" attribute of "Func" before body seen
+ >>> warning: possible Program_Error on later references
+ >>> warning: body of unit "Attribute_Call" elaborated
+ >>> warning: "Access" of "Func" taken at line 5
+
+ 6.
+ 7. function Func return Integer is
+ 8. begin
+ 9. ...
+10. end Func;
+11. end Attribute_Call;
@end example
-It is of course quite unlikely that both these results are correct, so
-it is up to you in a case like this to investigate the source of the
-difference, by looking at the two elaboration orders that are chosen,
-and figuring out which is correct, and then adding the necessary
-@code{Elaborate} or @code{Elaborate_All} pragmas to ensure the desired order.
+In the example above, the elaboration of declaration @code{Ptr} is assigned
+@code{Func'Access} before the body of @code{Func} has been elaborated.
+@end table
+
+@node Summary of Procedures for Elaboration Control,Inspecting the Chosen Elaboration Order,Elaboration-related Compiler Switches,Elaboration Order Handling in GNAT
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{24a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id16}@anchor{24b}
+@section Summary of Procedures for Elaboration Control
+
+
+A programmer should first compile the program with the default options, using
+none of the binder or compiler switches. If the binder succeeds in finding an
+elaboration order, then apart from possible cases involing dispatching calls
+and access-to-subprogram types, the program is free of elaboration errors.
+If it is important for the program to be portable to compilers other than GNAT,
+then the programmer should use compilation switch @code{-gnatel} and
+consider the messages about missing or implicitly created @code{Elaborate} and
+@code{Elaborate_All} pragmas.
+
+If the binder reports an elaboration circularity, the programmer has several
+options:
+
+
+@itemize *
+
+@item
+Ensure that warnings are enabled. This will allow the static model to output
+trace information of elaboration issues. The trace information could shed
+light on previously unforeseen dependencies, as well as their origins.
+
+@item
+Use switch @code{-gnatel} to obtain messages on generated implicit
+@code{Elaborate} and @code{Elaborate_All} pragmas. The trace information could
+indicate why a server unit must be elaborated prior to a client unit.
+
+@item
+If the warnings produced by the static model indicate that a task is
+involved, consider the options in the section on resolving task issues as
+well as compiler switch @code{-gnatd.y}.
+
+@item
+If the warnings produced by the static model indicate that an generic
+instantiations are involved, consider using compiler switches
+@code{-gnatd.G} and @code{-gnatdL}.
+
+@item
+If none of the steps outlined above resolve the circularity, recompile the
+program using the dynamic model by using compiler switch @code{-gnatE}.
+@end itemize
-@node Determining the Chosen Elaboration Order,,Other Elaboration Order Considerations,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat determining-the-chosen-elaboration-order}@anchor{248}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id15}@anchor{249}
-@section Determining the Chosen Elaboration Order
+@node Inspecting the Chosen Elaboration Order,,Summary of Procedures for Elaboration Control,Elaboration Order Handling in GNAT
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat inspecting-the-chosen-elaboration-order}@anchor{24c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id17}@anchor{24d}
+@section Inspecting the Chosen Elaboration Order
-To see the elaboration order that the binder chooses, you can look at
-the last part of the file:@cite{b~xxx.adb} binder output file. Here is an example:
+To see the elaboration order chosen by the binder, inspect the contents of file
+@cite{b~xxx.adb}. On certain targets, this file appears as @cite{b_xxx.adb}. The
+elaboration order appears as a sequence of calls to @code{Elab_Body} and
+@code{Elab_Spec}, interspersed with assignments to @cite{Exxx} which indicates that a
+particular unit is elaborated. For example:
@example
System.Soft_Links'Elab_Body;
E07 := True;
@end example
-Here Elab_Spec elaborates the spec
-and Elab_Body elaborates the body. The assignments to the @code{E@emph{xx}} flags
-flag that the corresponding body is now elaborated.
-
-You can also ask the binder to generate a more
-readable list of the elaboration order using the
-@code{-l} switch when invoking the binder. Here is
-an example of the output generated by this switch:
+Note also binder switch @code{-l}, which outputs the chosen elaboration
+order and provides a more readable form of the above:
@example
ada (spec)
@end example
@node Inline Assembler,GNU Free Documentation License,Elaboration Order Handling in GNAT,Top
-@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10}@anchor{gnat_ugn/inline_assembler doc}@anchor{24a}@anchor{gnat_ugn/inline_assembler id1}@anchor{24b}
+@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10}@anchor{gnat_ugn/inline_assembler doc}@anchor{24e}@anchor{gnat_ugn/inline_assembler id1}@anchor{24f}
@chapter Inline Assembler
@end menu
@node Basic Assembler Syntax,A Simple Example of Inline Assembler,,Inline Assembler
-@anchor{gnat_ugn/inline_assembler id2}@anchor{24c}@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{24d}
+@anchor{gnat_ugn/inline_assembler id2}@anchor{250}@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{251}
@section Basic Assembler Syntax
@node A Simple Example of Inline Assembler,Output Variables in Inline Assembler,Basic Assembler Syntax,Inline Assembler
-@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{24e}@anchor{gnat_ugn/inline_assembler id3}@anchor{24f}
+@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{252}@anchor{gnat_ugn/inline_assembler id3}@anchor{253}
@section A Simple Example of Inline Assembler
@code{nothing.out}.
@node Output Variables in Inline Assembler,Input Variables in Inline Assembler,A Simple Example of Inline Assembler,Inline Assembler
-@anchor{gnat_ugn/inline_assembler id4}@anchor{250}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{251}
+@anchor{gnat_ugn/inline_assembler id4}@anchor{254}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{255}
@section Output Variables in Inline Assembler
@end quotation
@node Input Variables in Inline Assembler,Inlining Inline Assembler Code,Output Variables in Inline Assembler,Inline Assembler
-@anchor{gnat_ugn/inline_assembler id5}@anchor{252}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{253}
+@anchor{gnat_ugn/inline_assembler id5}@anchor{256}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{257}
@section Input Variables in Inline Assembler
@end quotation
@node Inlining Inline Assembler Code,Other Asm Functionality,Input Variables in Inline Assembler,Inline Assembler
-@anchor{gnat_ugn/inline_assembler id6}@anchor{254}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{255}
+@anchor{gnat_ugn/inline_assembler id6}@anchor{258}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{259}
@section Inlining Inline Assembler Code
thus saving the overhead of stack frame setup and an out-of-line call.
@node Other Asm Functionality,,Inlining Inline Assembler Code,Inline Assembler
-@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{256}@anchor{gnat_ugn/inline_assembler id7}@anchor{257}
+@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{25a}@anchor{gnat_ugn/inline_assembler id7}@anchor{25b}
@section Other @code{Asm} Functionality
@end menu
@node The Clobber Parameter,The Volatile Parameter,,Other Asm Functionality
-@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{258}@anchor{gnat_ugn/inline_assembler id8}@anchor{259}
+@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{25c}@anchor{gnat_ugn/inline_assembler id8}@anchor{25d}
@subsection The @code{Clobber} Parameter
@end itemize
@node The Volatile Parameter,,The Clobber Parameter,Other Asm Functionality
-@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{25a}@anchor{gnat_ugn/inline_assembler id9}@anchor{25b}
+@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{25e}@anchor{gnat_ugn/inline_assembler id9}@anchor{25f}
@subsection The @code{Volatile} Parameter
problems.
@node GNU Free Documentation License,Index,Inline Assembler,Top
-@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{25c}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{25d}
+@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{260}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{261}
@chapter GNU Free Documentation License
Yes_After, -- S1 is in same extended unit as S2, and appears after it
No); -- S2 is not in same extended unit as S2
- function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result;
+ function Check_Same_Extended_Unit
+ (S1 : Source_Ptr;
+ S2 : Source_Ptr) return SEU_Result;
-- Used by In_Same_Extended_Unit and Earlier_In_Extended_Unit. Returns
-- value as described above.
-- Check_Same_Extended_Unit --
------------------------------
- function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result is
+ function Check_Same_Extended_Unit
+ (S1 : Source_Ptr;
+ S2 : Source_Ptr) return SEU_Result
+ is
Max_Iterations : constant Nat := Maximum_Instantiations * 2;
-- Limit to prevent a potential infinite loop
-- Prevent looping forever
if Counter > Max_Iterations then
+
-- ??? Not quite right, but return a value to be able to generate
-- SCIL files and hope for the best.
-- Earlier_In_Extended_Unit --
------------------------------
- function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is
+ function Earlier_In_Extended_Unit
+ (S1 : Source_Ptr;
+ S2 : Source_Ptr) return Boolean
+ is
begin
return Check_Same_Extended_Unit (S1, S2) = Yes_Before;
end Earlier_In_Extended_Unit;
+ function Earlier_In_Extended_Unit
+ (N1 : Node_Or_Entity_Id;
+ N2 : Node_Or_Entity_Id) return Boolean
+ is
+ begin
+ return Earlier_In_Extended_Unit (Sloc (N1), Sloc (N2));
+ end Earlier_In_Extended_Unit;
+
-----------------------
-- Exact_Source_Name --
-----------------------
begin
return
Get_Code_Or_Source_Unit
- (S, Unwind_Instances => True, Unwind_Subunits => False);
+ (S => S,
+ Unwind_Instances => True,
+ Unwind_Subunits => False);
end Get_Source_Unit;
function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is
-- Node may be in spec (or subunit etc) of main unit
else
- return
- In_Same_Extended_Unit (N, Cunit (Main_Unit));
+ return In_Same_Extended_Unit (N, Cunit (Main_Unit));
end if;
end In_Extended_Main_Code_Unit;
-- Location may be in spec (or subunit etc) of main unit
else
- return
- In_Same_Extended_Unit (Loc, Sloc (Cunit (Main_Unit)));
+ return In_Same_Extended_Unit (Loc, Sloc (Cunit (Main_Unit)));
end if;
end In_Extended_Main_Code_Unit;
-- avoid registering switches added automatically by the gcc driver at the
-- end of the command line.
- function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean;
+ function Earlier_In_Extended_Unit
+ (S1 : Source_Ptr;
+ S2 : Source_Ptr) return Boolean;
-- Given two Sloc values for which In_Same_Extended_Unit is true, determine
-- if S1 appears before S2. Returns True if S1 appears before S2, and False
-- otherwise. The result is undefined if S1 and S2 are not in the same
-- extended unit. Note: this routine will not give reliable results if
-- called after Sprint has been called with -gnatD set.
+ function Earlier_In_Extended_Unit
+ (N1 : Node_Or_Entity_Id;
+ N2 : Node_Or_Entity_Id) return Boolean;
+ -- Same as above, but the inputs denote nodes or entities
+
procedure Enable_Switch_Storing;
-- Enable registration of switches by Store_Compilation_Switch. Used to
-- avoid registering switches added automatically by the gcc driver at the
when N_With_Clause =>
Analyze_With_Clause (N);
+ -- A call to analyze a call marker is ignored because the node does
+ -- not have any static and run-time semantics.
+
+ when N_Call_Marker =>
+ null;
+
-- A call to analyze the Empty node is an error, but most likely it
-- is an error caused by an attempt to analyze a malformed piece of
-- tree caused by some other error, so if there have been any other
Scope_Stack.Locked := True;
end Lock;
+ ------------------------
+ -- Preanalysis_Active --
+ ------------------------
+
+ function Preanalysis_Active return Boolean is
+ begin
+ return not Full_Analysis and not Expander_Active;
+ end Preanalysis_Active;
+
----------------
-- Preanalyze --
----------------
-- This function returns True if an explicit pragma Suppress for check C
-- is present in the package defining E.
+ function Preanalysis_Active return Boolean;
+ pragma Inline (Preanalysis_Active);
+ -- Determine whether preanalysis is active at the point of invocation
+
procedure Preanalyze (N : Node_Id);
-- Performs a pre-analysis of node N. During pre-analysis no expansion is
-- carried out for N or its children. For more info on pre-analysis read
with Atree; use Atree;
with Casing; use Casing;
with Checks; use Checks;
-with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
("prefix of % attribute cannot be enumeration literal");
end if;
+ -- Preserve relevant elaboration-related attributes of the context
+ -- which are no longer available or very expensive to recompute once
+ -- analysis, resolution, and expansion are over.
+
+ Mark_Elaboration_Attributes
+ (N_Id => N,
+ Checks => True,
+ Modes => True);
+
+ -- Save the scenario for later examination by the ABE Processing
+ -- phase.
+
+ Record_Elaboration_Scenario (N);
+
-- Case of access to subprogram
if Is_Entity_Name (P) and then Is_Overloadable (Entity (P)) then
Kill_Current_Values;
end if;
- -- In the static elaboration model, treat the attribute reference
- -- as a call for elaboration purposes. Suppress this treatment
- -- under debug flag. In any case, we are all done.
-
- if not Dynamic_Elaboration_Checks and not Debug_Flag_Dot_UU then
- Check_Elab_Call (N);
- end if;
-
return;
-- Component is an operation of a protected type
-- 'Unrestricted_Access or in case of a subprogram.
if Is_Entity_Name (P)
- and then (Attr_Id = Attribute_Unrestricted_Access
- or else Is_Subprogram (Entity (P)))
+ and then (Attr_Id = Attribute_Unrestricted_Access
+ or else Is_Subprogram (Entity (P)))
then
Set_Address_Taken (Entity (P));
end if;
-- entity is marked as having a limited_view actual when some actual is
-- a limited view. This is used to place the instance body properly.
+ procedure Provide_Completing_Bodies (N : Node_Id);
+ -- Generate completing bodies for all subprograms found within package or
+ -- subprogram declaration N.
+
procedure Remove_Parent (In_Body : Boolean := False);
-- Reverse effect after instantiation of child is complete
Set_SPARK_Pragma_Inherited (Id);
Set_SPARK_Aux_Pragma_Inherited (Id);
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ Mark_Elaboration_Attributes
+ (N_Id => Id,
+ Checks => True);
+
-- Analyze aspects now, so that generated pragmas appear in the
-- declarations before building and analyzing the generic copy.
Create_Generic_Contract (N);
Spec := Specification (N);
- Id := Defining_Entity (Spec);
+ Id := Defining_Entity (Spec);
Generate_Definition (Id);
if Nkind (Id) = N_Defining_Operator_Symbol then
Analyze_Generic_Formal_Part (N);
- Formals := Parameter_Specifications (Spec);
-
if Nkind (Spec) = N_Function_Specification then
Set_Ekind (Id, E_Generic_Function);
else
Set_Ekind (Id, E_Generic_Procedure);
end if;
+ -- Set SPARK_Mode from context
+
+ Set_SPARK_Pragma (Id, SPARK_Mode_Pragma);
+ Set_SPARK_Pragma_Inherited (Id);
+
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ Mark_Elaboration_Attributes
+ (N_Id => Id,
+ Checks => True);
+
+ Formals := Parameter_Specifications (Spec);
+
if Present (Formals) then
Process_Formals (Formals, Spec);
end if;
-- Start of processing for Analyze_Package_Instantiation
begin
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ Mark_Elaboration_Attributes
+ (N_Id => N,
+ Checks => True,
+ Level => True,
+ Modes => True);
+
Check_SPARK_05_Restriction ("generic is not allowed", N);
-- Very first thing: check for Text_IO special unit in case we are
Analyze (Act_Decl);
Set_Unit (Parent (N), N);
Set_Body_Required (Parent (N), False);
+ end if;
- -- We never need elaboration checks on instantiations, since by
- -- definition, the body instantiation is elaborated at the same
- -- time as the spec instantiation.
+ -- Save the scenario for later examination by the ABE Processing
+ -- phase.
- Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
- Set_Kill_Elaboration_Checks (Act_Decl_Id);
- end if;
+ Record_Elaboration_Scenario (N);
+
+ -- The instantiation results in a guaranteed ABE
- Check_Elab_Instantiation (N);
+ if Is_Known_Guaranteed_ABE (N) and then Needs_Body then
+
+ -- Do not instantiate the corresponding body because gigi cannot
+ -- handle certain types of premature instantiations.
- if ABE_Is_Certain (N) and then Needs_Body then
Pending_Instantiations.Decrement_Last;
+
+ -- Create completing bodies for all subprogram declarations since
+ -- their real bodies will not be instantiated.
+
+ Provide_Completing_Bodies (Instance_Spec (N));
end if;
Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
-- No point in inlining if ABE is inevitable
- and then not ABE_Is_Certain (N)
+ and then not Is_Known_Guaranteed_ABE (N)
-- Or if subprogram is eliminated
Check_Eliminated (Act_Decl_Id);
Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id));
- -- In compilation unit case, kill elaboration checks on the
- -- instantiation, since they are never needed -- the body is
- -- instantiated at the same point as the spec.
-
if Nkind (Parent (N)) = N_Compilation_Unit then
- Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
Set_Kill_Elaboration_Checks (Act_Decl_Id);
Set_Is_Compilation_Unit (Anon_Id);
-- Start of processing for Analyze_Subprogram_Instantiation
begin
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ Mark_Elaboration_Attributes
+ (N_Id => N,
+ Checks => True,
+ Level => True,
+ Modes => True);
+
Check_SPARK_05_Restriction ("generic is not allowed", N);
-- Very first thing: check for special Text_IO unit in case we are
Set_Ignore_SPARK_Mode_Pragmas (Anon_Id);
end if;
- if not Is_Intrinsic_Subprogram (Gen_Unit) then
- Check_Elab_Instantiation (N);
+ -- Save the scenario for later examination by the ABE Processing
+ -- phase.
+
+ Record_Elaboration_Scenario (N);
+
+ -- The instantiation results in a guaranteed ABE. Create a completing
+ -- body for the subprogram declaration because the real body will not
+ -- be instantiated.
+
+ if Is_Known_Guaranteed_ABE (N) then
+ Provide_Completing_Bodies (Instance_Spec (N));
end if;
if Is_Dispatching_Operation (Act_Decl_Id)
-- The parent was a premature instantiation. Insert freeze node at
-- the end the current declarative part.
- if ABE_Is_Certain (Get_Unit_Instantiation_Node (Par)) then
+ if Is_Known_Guaranteed_ABE (Get_Unit_Instantiation_Node (Par)) then
Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
-- Handle the following case:
end if;
end Preanalyze_Actuals;
+ -------------------------------
+ -- Provide_Completing_Bodies --
+ -------------------------------
+
+ procedure Provide_Completing_Bodies (N : Node_Id) is
+ procedure Build_Completing_Body (Subp_Decl : Node_Id);
+ -- Generate the completing body for subprogram declaration Subp_Decl
+
+ procedure Provide_Completing_Bodies_In (Decls : List_Id);
+ -- Generating completing bodies for all subprograms found in declarative
+ -- list Decls.
+
+ ---------------------------
+ -- Build_Completing_Body --
+ ---------------------------
+
+ procedure Build_Completing_Body (Subp_Decl : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Subp_Decl);
+ Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
+ Spec : Node_Id;
+
+ begin
+ -- Nothing to do if the subprogram already has a completing body
+
+ if Present (Corresponding_Body (Subp_Decl)) then
+ return;
+
+ -- Mark the function as having a valid return statement even though
+ -- the body contains a single raise statement.
+
+ elsif Ekind (Subp_Id) = E_Function then
+ Set_Return_Present (Subp_Id);
+ end if;
+
+ -- Clone the specification to obtain new entities and reset the only
+ -- semantic field.
+
+ Spec := Copy_Subprogram_Spec (Specification (Subp_Decl));
+ Set_Generic_Parent (Spec, Empty);
+
+ -- Generate:
+ -- function Func ... return ... is
+ -- <or>
+ -- procedure Proc ... is
+ -- begin
+ -- raise Program_Error with "access before elaboration";
+ -- edn Proc;
+
+ Insert_After_And_Analyze (Subp_Decl,
+ Make_Subprogram_Body (Loc,
+ Specification => Spec,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Access_Before_Elaboration)))));
+ end Build_Completing_Body;
+
+ ----------------------------------
+ -- Provide_Completing_Bodies_In --
+ ----------------------------------
+
+ procedure Provide_Completing_Bodies_In (Decls : List_Id) is
+ Decl : Node_Id;
+
+ begin
+ if Present (Decls) then
+ Decl := First (Decls);
+ while Present (Decl) loop
+ Provide_Completing_Bodies (Decl);
+ Next (Decl);
+ end loop;
+ end if;
+ end Provide_Completing_Bodies_In;
+
+ -- Local variables
+
+ Spec : Node_Id;
+
+ -- Start of processing for Provide_Completing_Bodies
+
+ begin
+ if Nkind (N) = N_Package_Declaration then
+ Spec := Specification (N);
+
+ Push_Scope (Defining_Entity (N));
+ Provide_Completing_Bodies_In (Visible_Declarations (Spec));
+ Provide_Completing_Bodies_In (Private_Declarations (Spec));
+ Pop_Scope;
+
+ elsif Nkind (N) = N_Subprogram_Declaration then
+ Build_Completing_Body (N);
+ end if;
+ end Provide_Completing_Bodies;
+
-------------------
-- Remove_Parent --
-------------------
end if;
end if;
+ -- Set the SPARK mode from the current context (may be overwritten later
+ -- with explicit pragma).
+
+ Set_SPARK_Pragma (Id, SPARK_Mode_Pragma);
+ Set_SPARK_Pragma_Inherited (Id);
+
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ Mark_Elaboration_Attributes
+ (N_Id => Id,
+ Checks => True);
+
-- Initialize alignment and size and capture alignment setting
Init_Alignment (Id);
begin
Mark_Coextensions (N, Rhs);
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ Mark_Elaboration_Attributes
+ (N_Id => N,
+ Checks => True,
+ Modes => True);
+
-- Analyze the target of the assignment first in case the expression
-- contains references to Ghost entities. The checks that verify the
-- proper use of a Ghost entity need to know the enclosing context.
Error_Msg_CRT ("composite assignment", N);
end if;
- -- Check elaboration warning for left side if not in elab code
+ -- Save the scenario for later examination by the ABE Processing phase
- if not In_Subprogram_Or_Concurrent_Unit then
- Check_Elab_Assign (Lhs);
- end if;
+ Record_Elaboration_Scenario (N);
-- Set Referenced_As_LHS if appropriate. We only set this flag if the
-- assignment is a source assignment in the extended main source unit.
begin
if No (Iterator) then
- null; -- error reported below.
+ null; -- error reported below
elsif not Is_Overloaded (Iterator) then
Check_Reverse_Iteration (Etype (Iterator));
- -- If Iterator is overloaded, use reversible iterator if
- -- one is available.
+ -- If Iterator is overloaded, use reversible iterator if one is
+ -- available.
elsif Is_Overloaded (Iterator) then
Get_First_Interp (Iterator, I, It);
end if;
else
-
- -- Pre-Ada2012 for-loops and while loops.
+ -- Pre-Ada2012 for-loops and while loops
Analyze_Statements (Statements (N));
end if;
Generate_Definition (Subp_Id);
+ -- Set the SPARK mode from the current context (may be overwritten later
+ -- with explicit pragma).
+
+ Set_SPARK_Pragma (Subp_Id, SPARK_Mode_Pragma);
+ Set_SPARK_Pragma_Inherited (Subp_Id);
+
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ Mark_Elaboration_Attributes
+ (N_Id => Subp_Id,
+ Checks => True);
+
Set_Is_Abstract_Subprogram (Subp_Id);
New_Overloaded_Entity (Subp_Id);
Check_Delayed_Subprogram (Subp_Id);
Set_Actual_Subtypes (N, Current_Scope);
- Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma);
+ Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Body_Id);
-- Analyze any aspect specifications that appear on the generic
if Analyzed (N) then
return;
- end if;
-- If there is an error analyzing the name (which may have been
-- rewritten if the original call was in prefix notation) then error
-- has been emitted already, mark node and return.
- if Error_Posted (N) or else Etype (Name (N)) = Any_Type then
+ elsif Error_Posted (N) or else Etype (Name (N)) = Any_Type then
Set_Etype (N, Any_Type);
return;
end if;
New_N :=
Make_Indexed_Component (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc),
+ Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc),
Selector_Name => New_Occurrence_Of (Entity (P), Loc)),
Expressions => Actuals);
Set_Name (N, New_N);
then
New_N :=
Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc),
+ Prefix =>
+ New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc),
Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc));
Rewrite (Prefix (P), New_N);
Analyze (P);
-- between the spec and body.
elsif No (SPARK_Pragma (Body_Id)) then
- Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma);
+ Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Body_Id);
end if;
Stm : Node_Id;
begin
- -- Skip initial labels (for one thing this occurs when we are in
- -- front-end ZCX mode, but in any case it is irrelevant), and also
- -- initial Push_xxx_Error_Label nodes, which are also irrelevant.
+ -- Skip call markers installed by the ABE mechanism, labels, and
+ -- Push_xxx_Error_Label to find the first real statement.
Stm := First (Statements (HSS));
- while Nkind (Stm) = N_Label
+ while Nkind_In (Stm, N_Call_Marker, N_Label)
or else Nkind (Stm) in N_Push_xxx_Label
loop
Next (Stm);
and then Is_Entry_Barrier_Function (N)
then
null;
+
else
- Set_SPARK_Pragma (Designator, SPARK_Mode_Pragma);
+ Set_SPARK_Pragma (Designator, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Designator);
end if;
Set_Ignore_SPARK_Mode_Pragmas (Designator);
end if;
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ Mark_Elaboration_Attributes
+ (N_Id => Designator,
+ Checks => True);
+
if Debug_Flag_C then
Write_Str ("==> subprogram spec ");
Write_Name (Chars (Designator));
end if;
end if;
- if Is_Comp_Unit then
-
- -- Set Body_Required indication on the compilation unit node, and
- -- determine whether elaboration warnings may be meaningful on it.
+ -- Set Body_Required indication on the compilation unit node
+ if Is_Comp_Unit then
Set_Body_Required (Parent (N), Body_Required);
-
- if not Body_Required then
- Set_Suppress_Elaboration_Warnings (Id);
- end if;
end if;
End_Package_Scope (Id);
with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
+with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
Statements => New_List (Attr_Node)));
end if;
+ -- Signal the ABE mechanism that the generated subprogram body has not
+ -- ABE ramifications.
+
+ Set_Was_Attribute_Reference (Body_Node);
+
-- In case of tagged types we add the body of the generated function to
-- the freezing actions of the type (because in the general case such
-- type is still not frozen). We exclude from this processing generic
Error_Msg_N
("a library unit can only rename another library unit", N);
end if;
-
- -- We suppress elaboration warnings for the resulting entity, since
- -- clearly they are not needed, and more particularly, in the case
- -- of a generic formal subprogram, the resulting entity can appear
- -- after the instantiation itself, and thus look like a bogus case
- -- of access before elaboration.
-
- Set_Suppress_Elaboration_Warnings (New_S);
-
end Attribute_Renaming;
----------------------
return;
end if;
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ if Nkind (N) = N_Identifier then
+ Mark_Elaboration_Attributes
+ (N_Id => N,
+ Modes => True);
+ end if;
+
-- Here if Entity pointer was not set, we need full visibility analysis
-- First we generate debugging output if the debug E flag is set.
<<Done>>
Check_Restriction_No_Use_Of_Entity (N);
+
+ -- Save the scenario for later examination by the ABE Processing phase
+
+ Record_Elaboration_Scenario (N);
end Find_Direct_Name;
------------------------
Change_Selected_Component_To_Expanded_Name (N);
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ Mark_Elaboration_Attributes
+ (N_Id => N,
+ Modes => True);
+
-- Set appropriate type
if Is_Type (Id) then
end if;
Check_Restriction_No_Use_Of_Entity (N);
+
+ -- Save the scenario for later examination by the ABE Processing phase
+
+ Record_Elaboration_Scenario (N);
end Find_Expanded_Name;
--------------------
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
+with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
Set_SPARK_Pragma_Inherited (Def_Id);
end if;
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ Mark_Elaboration_Attributes
+ (N_Id => Def_Id,
+ Checks => True);
+
-- Process formals
if Present (Formals) then
Synch_Type : Entity_Id;
begin
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ Mark_Elaboration_Attributes
+ (N_Id => N,
+ Checks => True,
+ Modes => True);
+
Tasking_Used := True;
Check_SPARK_05_Restriction ("requeue statement is not allowed", N);
Check_Restriction (No_Requeue_Statements, N);
Error_Msg_N
("target protected object of requeue must be a variable", N);
end if;
+
+ -- A requeue statement is treated as a call for purposes of ABE checks
+ -- and diagnostics. Annotate the tree by creating a call marker in case
+ -- the requeue statement is transformed by expansion.
+
+ Build_Call_Marker (N);
end Analyze_Requeue;
------------------------------
Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Obj_Id);
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ Mark_Elaboration_Attributes
+ (N_Id => Obj_Id,
+ Checks => True);
+
-- Instead of calling Analyze on the new node, call the proper analysis
-- procedure directly. Otherwise the node would be expanded twice, with
-- disastrous result.
Set_SPARK_Pragma_Inherited (T);
Set_SPARK_Aux_Pragma_Inherited (T);
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ Mark_Elaboration_Attributes
+ (N_Id => T,
+ Checks => True);
+
Push_Scope (T);
if Ada_Version >= Ada_2005 then
------------------------------------------------------------------------------
with Atree; use Atree;
-with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
-with Elists; use Elists;
with Errout; use Errout;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
-with Expander; use Expander;
with Lib; use Lib;
with Lib.Load; use Lib.Load;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
-with Output; use Output;
with Restrict; use Restrict;
with Rident; use Rident;
+with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
-with Sem_Cat; use Sem_Cat;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
-with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
with Table;
with Uintp; use Uintp;
with Uname; use Uname;
+with GNAT.HTable; use GNAT.HTable;
+
package body Sem_Elab is
- -- The following table records the recursive call chain for output in the
- -- Output routine. Each entry records the call node and the entity of the
- -- called routine. The number of entries in the table (i.e. the value of
- -- Elab_Call.Last) indicates the current depth of recursion and is used to
- -- identify the outer level.
+ -----------------------------------------
+ -- Access-before-elaboration mechanism --
+ -----------------------------------------
+
+ -- The access-before-elaboration (ABE) mechanism implemented in this unit
+ -- has the following objectives:
+ --
+ -- * Diagnose at compile-time or install run-time checks to prevent ABE
+ -- access to data and behaviour.
+ --
+ -- The high level idea is to accurately diagnose ABE issues within a
+ -- single unit because the ABE mechanism can inspect the whole unit.
+ -- As soon as the elaboration graph extends to an external unit, the
+ -- diagnostics stop because the body of the unit may not be available.
+ -- Due to control and data flow, the ABE mechanism cannot accurately
+ -- determine whether a particular scenario will be elaborated or not.
+ -- Conditional ABE checks are therefore used to verify the elaboration
+ -- status of a local and external target at run time.
+ --
+ -- * Supply elaboration dependencies for a unit to binde
+ --
+ -- The ABE mechanism registers each outgoing elaboration edge for the
+ -- main unit in its ALI file. GNATbind and binde can then reconstruct
+ -- the full elaboration graph and determine the proper elaboration
+ -- order for all units in the compilation.
+ --
+ -- The ABE mechanism supports three models of elaboration:
+ --
+ -- * Dynamic model - This is the most permissive of the three models.
+ -- When the dynamic model is in effect, the mechanism performs very
+ -- little diagnostics and generates run-time checks to detect ABE
+ -- issues. The behaviour of this model is identical to that specified
+ -- by the Ada RM. This model is enabled with switch -gnatE.
+ --
+ -- * Static model - This is the middle ground of the three models. When
+ -- the static model is in effect, the mechanism diagnoses and installs
+ -- run-time checks to detect ABE issues in the main unit. In addition,
+ -- the mechanism generates implicit Elaborate or Elaborate_All pragmas
+ -- to ensure the prior elaboration of withed units. The model employs
+ -- textual order, with clause context, and elaboration-related source
+ -- pragmas. This is the default model.
+ --
+ -- * SPARK model - This is the most conservative of the three models and
+ -- impelements the semantics defined in SPARK RM 7.7. The SPARK model
+ -- is in effect only when a context resides in a SPARK_Mode On region,
+ -- otherwise the mechanism falls back to one of the previous models.
+ --
+ -- The ABE mechanism consists of a "recording" phase and a "processing"
+ -- phase.
+
+ -----------------
+ -- Terminology --
+ -----------------
+
+ -- * Bridge target - A type of target. A bridge target is a link between
+ -- scenarios. It is usually a byproduct of expansion and does not have
+ -- any direct ABE ramifications.
+ --
+ -- * Call marker - A special node used to indicate the presence of a call
+ -- in the tree in case expansion transforms or eliminates the original
+ -- call. N_Call_Marker nodes do not have static and run-time semantics.
+ --
+ -- * Conditional ABE - A type of ABE. A conditional ABE occurs when the
+ -- elaboration or invocation of a target by a scenario within the main
+ -- unit causes an ABE, but does not cause an ABE for another scenarios
+ -- within the main unit.
+ --
+ -- * Declaration level - A type of enclosing level. A scenario or target is
+ -- at the declaration level when it appears within the declarations of a
+ -- block statement, entry body, subprogram body, or task body, ignoring
+ -- enclosing packges.
+ --
+ -- * Generic library level - A type of enclosing level. A scenario or
+ -- target is at the generic library level if it appears in a generic
+ -- package library unit, ignoring enclosing packages.
+ --
+ -- * Guaranteed ABE - A type of ABE. A guaranteed ABE occurs when the
+ -- elaboration or invocation of a target by all scenarios within the
+ -- main unit causes an ABE.
+ --
+ -- * Instantiation library level - A type of enclosing level. A scenario
+ -- or target is at the instantiation library level if it appears in an
+ -- instantiation library unit, ignoring enclosing packages.
+ --
+ -- * Library level - A type of enclosing level. A scenario or target is at
+ -- the library level if it appears in a package library unit, ignoring
+ -- enclosng packages.
+ --
+ -- * Non-library level encapsulator - A construct that cannot be elaborated
+ -- on its own and requires elaboration by a top level scenario.
+ --
+ -- * Scenario - A construct or context which may be elaborated or executed
+ -- by elaboration code. The scenarios recognized by the ABE mechanism are
+ -- as follows:
+ --
+ -- - '[Unrestricted_]Access of entries, operators, and subprograms
+ --
+ -- - Assignments to variables
+ --
+ -- - Calls to entries, operators, and subprograms
+ --
+ -- - Instantiations
+ --
+ -- - References to variables
+ --
+ -- - Task activation
+ --
+ -- * Target - A construct referenced by a scenario. The targets recognized
+ -- by the ABE mechanism are as follows:
+ --
+ -- - For '[Unrestricted_]Access of entries, operators, and subprograms,
+ -- the target is the entry, operator, or subprogram.
+ --
+ -- - For assignments to variables, the target is the variable
+ --
+ -- - For calls, the target is the entry, operator, or subprogram
+ --
+ -- - For instantiations, the target is the generic template
+ --
+ -- - For references to variables, the target is the variable
+ --
+ -- - For task activation, the target is the task body
+ --
+ -- * Top level scenario - A scenario which appears in a non-generic main
+ -- unit. Depending on the elaboration model is in effect, the following
+ -- addotional restrictions apply:
+ --
+ -- - Dynamic model - No restrictions
+ --
+ -- - SPARK model - Falls back to either the dynamic or static model
+ --
+ -- - Static model - The scenario must be at the library level
+
+ ---------------------
+ -- Recording phase --
+ ---------------------
+
+ -- The Recording phase coincides with the analysis/resolution phase of the
+ -- compiler. It has the following objectives:
+ --
+ -- * Record all top level scenarios for examination by the Processing
+ -- phase.
+ --
+ -- Saving only a certain number of nodes improves the performance of
+ -- the ABE mechanism. This eliminates the need to examine the whole
+ -- tree in a separate pass.
+ --
+ -- * Detect and diagnose calls in preelaborable or pure units, including
+ -- generic bodies.
+ --
+ -- This diagnostic is carried out during the Recording phase because it
+ -- does not need the heavy recursive traversal done by the Processing
+ -- phase.
+ --
+ -- * Detect and diagnose guaranteed ABEs caused by instantiations,
+ -- calls, and task activation.
+ --
+ -- The issues detected by the ABE mechanism are reported as warnings
+ -- because they do not violate Ada semantics. Forward instantiations
+ -- may thus reach gigi, however gigi cannot handle certain kinds of
+ -- premature instantiations and may crash. To avoid this limitation,
+ -- the ABE mechanism must identify forward instantiations as early as
+ -- possible and suppress their bodies. Calls and task activations are
+ -- included in this category for completeness.
+
+ ----------------------
+ -- Processing phase --
+ ----------------------
+
+ -- The Processing phase is a separate pass which starts after instantiating
+ -- and/or inlining of bodies, but before the removal of Ghost code. It has
+ -- the following objectives:
+ --
+ -- * Examine all top level scenarios saved during the Recording phase
+ --
+ -- The top level scenarios act as roots for depth-first traversal of
+ -- the call/instantiation/task activation graph. The traversal stops
+ -- when an outgoing edge leaves the main unit.
+ --
+ -- * Depending on the elaboration model in effect, perform the following
+ -- actions:
+ --
+ -- - Dynamic model - Diagnose guaranteed ABEs and install run-time
+ -- conditional ABE checks.
+ --
+ -- - SPARK model - Enforce the SPARK elaboration rules
+ --
+ -- - Static model - Diagnose conditional/guaranteed ABEs, install
+ -- run-time conditional ABE checks, and guarantee the elaboration
+ -- of external units.
+ --
+ -- * Examine nested scenarios
+ --
+ -- Nested scenarios discovered during the depth-first traversal are
+ -- in turn subjected to the same actions outlined above and examined
+ -- for the next level of nested scenarios.
+
+ ------------------
+ -- Architecture --
+ ------------------
+
+ -- +------------------------ Recording phase ---------------------------+
+ -- | |
+ -- | Record_Elaboration_Scenario |
+ -- | | |
+ -- | +--> Check_Preelaborated_Call |
+ -- | | |
+ -- | +--> Process_Guaranteed_ABE |
+ -- | | |
+ -- +------------------------- | --------------------------------------+
+ -- |
+ -- |
+ -- v
+ -- Top_Level_Scenarios
+ -- +-----------+-----------+ .. +-----------+
+ -- | Scenario1 | Scenario2 | .. | ScenarioN |
+ -- +-----------+-----------+ .. +-----------+
+ -- |
+ -- |
+ -- +------------------------- | --------------------------------------+
+ -- | | |
+ -- | Check_Elaboration_Scenarios |
+ -- | | |
+ -- | v |
+ -- | +----------- Process_Scenario <-----------+ |
+ -- | | | |
+ -- | +--> Process_Access Is_Suitable_Scenario |
+ -- | | ^ |
+ -- | +--> Process_Activation_Call --+ | |
+ -- | | +---> Traverse_Body |
+ -- | +--> Process_Call -------------+ |
+ -- | | |
+ -- | +--> Process_Instantiation |
+ -- | | |
+ -- | +--> Process_Variable_Assignment |
+ -- | | |
+ -- | +--> Process_Variable_Reference |
+ -- | |
+ -- +------------------------- Processing phase -------------------------+
+
+ ----------------------
+ -- Important points --
+ ----------------------
+
+ -- The Processing phase starts after the analysis, resolution, expansion
+ -- phase has completed. As a result, no current semantic information is
+ -- available. The scope stack is empty, global flags such as In_Instance
+ -- or Inside_A_Generic become useless. To remedy this, the ABE mechanism
+ -- must either save or recompute semantic information.
+
+ -- Expansion heavily transforms calls and to some extent instantiations. To
+ -- remedy this, the ABE mechanism generates N_Call_Marker nodes in order to
+ -- capture the target and relevant attributes of the original call.
+
+ -- The diagnostics of the ABE mechanism depend on accurate source locations
+ -- to determine the spacial relation of nodes.
+
+ --------------
+ -- Switches --
+ --------------
+
+ -- The following switches may be used to control the behavior of the ABE
+ -- mechanism.
+ --
+ -- -gnatdE elaboration checks on predefined units
+ --
+ -- The ABE mechanism considers scenarios which appear in internal
+ -- units (Ada, GNAT, Interfaces, System).
+ --
+ -- -gnatd.G ignore calls through generic formal parameters for elaboration
+ --
+ -- The ABE mechanism does not generate N_Call_Marker nodes for
+ -- calls which occur in expanded instances, and invoke generic
+ -- actual subprograms through generic formal subprograms. As a
+ -- result, the calls are not recorded or processed.
+ --
+ -- If switches -gnatd.G and -gnatdL are used together, then the
+ -- ABE mechanism effectively ignores all calls which cause the
+ -- elaboration flow to "leave" the instance.
+ --
+ -- -gnatdL ignore external calls from instances for elaboration
+ --
+ -- The ABE mechanism does not generate N_Call_Marker nodes for
+ -- calls which occur in expanded instances, do not invoke generic
+ -- actual subprograms through formal subprograms, and the target
+ -- is external to the instance. As a result, the calls are not
+ -- recorded or processed.
+ --
+ -- If switches -gnatd.G and -gnatdL are used together, then the
+ -- ABE mechanism effectively ignores all calls which cause the
+ -- elaboration flow to "leave" the instance.
+ --
+ -- -gnatd.o conservarive elaboration order for indirect calls
+ --
+ -- The ABE mechanism treats '[Unrestricted_]Access of an entry,
+ -- operator, or subprogram as an immediate invocation of the
+ -- target. As a result, it performs ABE checks and diagnostics on
+ -- the immediate call.
+ --
+ -- -gnatd.U ignore indirect calls for static elaboration
+ --
+ -- The ABE mechanism does not consider '[Unrestricted_]Access of
+ -- entries, operators, and subprograms. As a result, the scenarios
+ -- are not recorder or processed.
+ --
+ -- -gnatd.y disable implicit pragma Elaborate_All on task bodies
+ --
+ -- The ABE mechanism does not generate implicit Elaborate_All when
+ -- the need for the pragma came from a task body.
+ --
+ -- -gnatE dynamic elaboration checking mode enabled
+ --
+ -- The ABE mechanism assumes that any scenario is elaborated or
+ -- invoked by elaboration code. The ABE mechanism performs very
+ -- little diagnostics and generates condintional ABE checks to
+ -- detect ABE issues at run-time.
+ --
+ -- -gnatel turn on info messages on generated Elaborate[_All] pragmas
+ --
+ -- The ABE mechanism produces information messages on generated
+ -- implicit Elabote[_All] pragmas along with traceback showing
+ -- why the pragma was generated. In addition, the ABE mechanism
+ -- produces information messages for each scenario elaborated or
+ -- invoked by elaboration code.
+ --
+ -- -gnateL turn off info messages on generated Elaborate[_All] pragmas
+ --
+ -- The complimentary switch for -gnatel.
+ --
+ -- -gnatwl turn on warnings for elaboration problems
+ --
+ -- The ABE mechanism produces warnings on detected ABEs along with
+ -- traceback showing the graph of the ABE.
+ --
+ -- -gnatwL turn off warnings for elaboration problems
+ --
+ -- The complimentary switch for -gnatwl.
+ --
+ -- -gnatw.f turn on warnings for suspicious Subp'Access
+ --
+ -- The ABE mechanism treats '[Unrestricted_]Access of an entry,
+ -- operator, or subprogram as a pseudo invocation of the target.
+ -- As a result, it performs ABE diagnostics on the pseudo call.
+ --
+ -- -gnatw.F turn off warnings for suspicious Subp'Access
+ --
+ -- The complimentary switch for -gnatw.f.
+
+ ---------------------------
+ -- Adding a new scenario --
+ ---------------------------
+
+ -- The following steps describe how to add a new elaboration scenario and
+ -- preserve the existing architecture.
+ --
+ -- 1) If necessary, update predicates Is_Check_Emitting_Scenario and
+ -- Is_Scenario.
+ --
+ -- 2) Add predicate Is_Suitable_xxx. Include a call to it in predicate
+ -- Is_Suitable_Scenario.
+ --
+ -- 3) Update routine Record_Elaboration_Scenario
+ --
+ -- 4) Add routine Process_xxx. Include a call to it in Process_Scenario.
+ --
+ -- 5) Add routine Info_xxx. Include a call to it in Process_xxx.
+ --
+ -- 6) Add routine Output_xxx. Include a call to it in routine
+ -- Output_Active_Scenarios.
+ --
+ -- 7) If necessary, add a new Extract_xxx_Attributes routine
+ --
+ -- 8) If necessary, update routine Is_Potential_Scenario
+
+ -------------------------
+ -- Adding a new target --
+ -------------------------
+
+ -- The following steps describe how to add a new elaboration target and
+ -- preserve the existing architecture.
+ --
+ -- 1) Add predicate Is_xxx.
+ --
+ -- 2) Update predicates Is_Ada_Semantic_Target, Is_Bridge_Target, or
+ -- Is_SPARK_Semantic_Target. If necessary, create a new category.
+ --
+ -- 3) Update the appropriate Info_xxx routine.
+ --
+ -- 4) Update the appropriate Output_xxx routine.
+ --
+ -- 5) Update routine Extract_Target_Attributes. If necessary, create a
+ -- new Extract_xxx routine.
+
+ --------------------------
+ -- Debugging ABE issues --
+ --------------------------
+
+ -- * If the issue involves a call, ensure that the call is eligible for ABE
+ -- processing and receives a corresponding call marker. The routines of
+ -- interest are
+ --
+ -- Build_Call_Marker
+ -- Record_Elaboration_Scenario
+
+ -- * If the issue involves an arbitrary scenario, ensure that the scenario
+ -- is either recorded, or is successfully recognized while traversing a
+ -- body. The routines of interest are
+ --
+ -- Record_Elaboration_Scenario
+ -- Process_Scenario
+ -- Traverse_Body
+
+ -- * If the issue involves a circularity in the elaboration order, examine
+ -- the ALI files and look for the following encodings next to units:
+ --
+ -- E indicates a source Elaborate
+ --
+ -- EA indicates a source Elaborate_All
+ --
+ -- AD indicates an implicit Elaborate_All
+ --
+ -- ED indicates an implicit Elaborate
+ --
+ -- If possible, compare these encodings with those generated by the old
+ -- ABE mechanism. The routines of interest are
+ --
+ -- Ensure_Prior_Elaboration
+
+ ----------------
+ -- Attributes --
+ ----------------
+
+ -- The following type captures relevant attributes which pertain to a call
+
+ type Call_Attributes is record
+ Elab_Checks_OK : Boolean;
+ -- This flag is set when the call has elaboration checks enabled
+
+ From_Source : Boolean;
+ -- This flag is set when the call comes from source
+
+ Ghost_Mode_Ignore : Boolean;
+ -- This flag is set when the call appears in a region subject to pragma
+ -- Ghost with policy Ignore.
+
+ In_Declarations : Boolean;
+ -- This flag is set when the call appears at the declaration level
+
+ Is_Dispatching : Boolean;
+ -- This flag is set when the call is dispatching
+
+ SPARK_Mode_On : Boolean;
+ -- This flag is set when the call appears in a region subject to pragma
+ -- SPARK_Mode with value On.
+ end record;
+
+ -- The following type captures relevant attributes which pertain to the
+ -- prior elaboration of a unit. This type is coupled together with a unit
+ -- to form a key -> value relationship.
+
+ type Elaboration_Attributes is record
+ Source_Pragma : Node_Id;
+ -- This attribute denotes a source Elaborate or Elaborate_All pragma
+ -- which guarantees the prior elaboration of some unit with respect
+ -- to the main unit. The pragma may come from the following contexts:
+
+ -- * The main unit
+ -- * The spec of the main unit (if applicable)
+ -- * Any parent spec of the main unit (if applicable)
+ -- * Any parent subunit of the main unit (if applicable)
+
+ -- The attribute remains Empty if no such pragma is available. Source
+ -- pragmas play a role in satisfying SPARK elaboration requirements.
+
+ With_Clause : Node_Id;
+ -- This attribute denotes an internally generated or source with clause
+ -- for some unit withed by the main unit. With clauses carry flags which
+ -- represent implicit Elaborate or Elaborate_All pragmas. These clauses
+ -- play a role in supplying the elaboration dependencies to binde.
+ end record;
+
+ No_Elaboration_Attributes : constant Elaboration_Attributes :=
+ (Source_Pragma => Empty,
+ With_Clause => Empty);
+
+ -- The following type captures relevant attributes which pertain to an
+ -- instantiation.
+
+ type Instantiation_Attributes is record
+ Elab_Checks_OK : Boolean;
+ -- This flag is set when the instantiation has elaboration checks
+ -- 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.
+
+ In_Declarations : Boolean;
+ -- This flag is set when the instantiation appears at the declaration
+ -- level.
+
+ SPARK_Mode_On : Boolean;
+ -- This flag is set when the instantiation appears in a region subject
+ -- to pragma SPARK_Mode with value On, or starts one such region.
+ end record;
+
+ -- The following type captures relevant attributes which pertain to a
+ -- target.
+
+ type Target_Attributes is record
+ Elab_Checks_OK : Boolean;
+ -- This flag is set when the target has elaboration checks enabled
+
+ From_Source : Boolean;
+ -- This flag is set when the target comes from source
+
+ Ghost_Mode_Ignore : Boolean;
+ -- This flag is set when the target appears in a region subject to
+ -- pragma Ghost with policy ignore, or starts one such region.
+
+ SPARK_Mode_On : Boolean;
+ -- This flag is set when the target appears in a region subject to
+ -- pragma SPARK_Mode with value On, or starts one such region.
+
+ Spec_Decl : Node_Id;
+ -- This attribute denotes the declaration of Spec_Id
+
+ Unit_Id : Entity_Id;
+ -- This attribute denotes the top unit where Spec_Id resides
+
+ -- The semantics of the following attributes depend on the target
+
+ Body_Barf : Node_Id;
+ Body_Decl : Node_Id;
+ Spec_Id : Entity_Id;
+
+ -- The target is a generic package or a subprogram
+ --
+ -- * Body_Barf - Empty
+ --
+ -- * Body_Decl - This attribute denotes the generic or subprogram
+ -- body.
+ --
+ -- * Spec_Id - This attribute denotes the entity of the generic
+ -- package or subprogram.
+
+ -- The target is a protected entry
+ --
+ -- * Body_Barf - This attribute denotes the body of the barrier
+ -- function if expansion took place, otherwise it is Empty.
+ --
+ -- * Body_Decl - This attribute denotes the body of the procedure
+ -- which emulates the entry if expansion took place, otherwise it
+ -- denotes the body of the protected entry.
+ --
+ -- * Spec_Id - This attribute denotes the entity of the procedure
+ -- which emulates the entry if expansion took place, otherwise it
+ -- denotes the protected entry.
+
+ -- The target is a protected subprogram
+ --
+ -- * Body_Barf - Empty
+ --
+ -- * Body_Decl - This attribute denotes the body of the protected or
+ -- unprotected version of the protected subprogram if expansion took
+ -- place, otherwise it denotes the body of the protected subprogram.
+ --
+ -- * Spec_Id - This attribute denotes the entity of the protected or
+ -- unprotected version of the protected subprogram if expansion took
+ -- place, otherwise it is the entity of the protected subprogram.
+
+ -- The target is a task entry
+ --
+ -- * Body_Barf - Empty
+ --
+ -- * Body_Decl - This attribute denotes the body of the procedure
+ -- which emulates the task body if expansion took place, otherwise
+ -- it denotes the body of the task type.
+ --
+ -- * Spec_Id - This attribute denotes the entity of the procedure
+ -- which emulates the task body if expansion took place, otherwise
+ -- it denotes the entity of the task type.
+ end record;
+
+ -- The following type captures relevant attributes which pertain to a task
+ -- type.
+
+ type Task_Attributes is record
+ Body_Decl : Node_Id;
+ -- This attribute denotes the declaration of the procedure body which
+ -- emulates the behaviour of the task body.
+
+ Elab_Checks_OK : Boolean;
+ -- This flag is set when the task type has elaboration checks 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.
+
+ SPARK_Mode_On : Boolean;
+ -- This flag is set when the task type appears in a region subject to
+ -- pragma SPARK_Mode with value On, or starts one such region.
+
+ Spec_Id : Entity_Id;
+ -- This attribute denotes the entity of the initial declaration of the
+ -- procedure body which emulates the behaviour of the task body.
+
+ Task_Decl : Node_Id;
+ -- This attribute denotes the declaration of the task type
+
+ Unit_Id : Entity_Id;
+ -- This attribute denotes the entity of the compilation unit where the
+ -- task type resides.
+ end record;
+
+ -- The following type captures relevant attributes which pertain to a
+ -- 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.
+ end record;
+
+ ---------------------
+ -- Data structures --
+ ---------------------
+
+ -- The following table stores the elaboration status of all units withed by
+ -- the main unit.
+
+ Elaboration_Context_Max : constant := 1009;
+
+ type Elaboration_Context_Index is range 0 .. Elaboration_Context_Max - 1;
+
+ function Elaboration_Context_Hash
+ (Key : Entity_Id) return Elaboration_Context_Index;
+ -- Obtain the hash value of entity Key
+
+ package Elaboration_Context is new Simple_HTable
+ (Header_Num => Elaboration_Context_Index,
+ Element => Elaboration_Attributes,
+ No_Element => No_Elaboration_Attributes,
+ Key => Entity_Id,
+ Hash => Elaboration_Context_Hash,
+ Equal => "=");
+
+ -- The following table stores all active scenarios in a recursive traversal
+ -- starting from a top level scenario. This table must be maintained in a
+ -- FIFO fashion.
+
+ package Scenario_Stack is new Table.Table
+ (Table_Component_Type => Node_Id,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 1,
+ Table_Initial => 50,
+ Table_Increment => 100,
+ Table_Name => "Scenario_Stack");
+
+ -- The following table stores all top level scenario saved during the
+ -- Recording phase. The contents of this table act as traversal roots
+ -- later in the Processing phase. This table must be maintained in a
+ -- LIFO fashion.
+
+ package Top_Level_Scenarios is new Table.Table
+ (Table_Component_Type => Node_Id,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 1,
+ Table_Initial => 1000,
+ Table_Increment => 100,
+ Table_Name => "Top_Level_Scenarios");
+
+ -- The following table stores the bodies of all eligible scenarios visited
+ -- during a traversal starting from a top level scenario. The contents of
+ -- this table must be reset upon each new traversal.
+
+ Visited_Bodies_Max : constant := 511;
+
+ type Visited_Bodies_Index is range 0 .. Visited_Bodies_Max - 1;
+
+ function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index;
+ -- Obtain the hash value of node Key
+
+ package Visited_Bodies is new Simple_HTable
+ (Header_Num => Visited_Bodies_Index,
+ Element => Boolean,
+ No_Element => False,
+ Key => Node_Id,
+ Hash => Visited_Bodies_Hash,
+ Equal => "=");
+
+ -----------------------
+ -- Local subprograms --
+ -----------------------
+
+ procedure Check_Preelaborated_Call (Call : Node_Id);
+ -- Determine whether entry, operator, or subprogram call Call appears at
+ -- the library level of a preelaborated unit. Emit an error if this is the
+ -- case.
+
+ function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id;
+ pragma Inline (Compilation_Unit);
+ -- Return the N_Compilation_Unit node of unit Unit_Id
+
+ procedure Elab_Msg_NE
+ (Msg : String;
+ N : Node_Id;
+ Id : Entity_Id;
+ Info_Msg : Boolean;
+ In_SPARK : Boolean);
+ pragma Inline (Elab_Msg_NE);
+ -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary node
+ -- N and entity. If flag Info_Msg is set, the routine emits an information
+ -- message, otherwise it emits an error. If flag In_SPARK is set, then
+ -- string " in SPARK" is added to the end of the message.
+
+ procedure Ensure_Dynamic_Prior_Elaboration
+ (N : Node_Id;
+ Unit_Id : Entity_Id;
+ Prag_Nam : Name_Id);
+ -- Guarantee the elaboration of unit Unit_Id with respect to the main unit
+ -- by suggesting the use of Elaborate[_All] with name Prag_Nam. N denotes
+ -- the related scenario.
+
+ procedure Ensure_Prior_Elaboration
+ (N : Node_Id;
+ Unit_Id : Entity_Id;
+ In_Task_Body : Boolean);
+ -- Guarantee the elaboration of unit Unit_Id with respect to the main unit.
+ -- N denotes the related scenario. Flag In_Task_Body should be set when the
+ -- need for elaboration is initiated from a task body.
+
+ procedure Ensure_Static_Prior_Elaboration
+ (N : Node_Id;
+ Unit_Id : Entity_Id;
+ Prag_Nam : Name_Id);
+ -- Guarantee the elaboration of unit Unit_Id with respect to the main unit
+ -- by installing an implicit Elaborate[_All] pragma with name Prag_Nam. N
+ -- denotes the related scenario.
+
+ function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id;
+ pragma Inline (Extract_Assignment_Name);
+ -- Obtain the Name attribute of assignment statement Asmt
+
+ procedure Extract_Call_Attributes
+ (Call : Node_Id;
+ Target_Id : out Entity_Id;
+ Attrs : out Call_Attributes);
+ -- Obtain attributes Attrs associated with call Call. Target_Id is the
+ -- entity of the call target.
+
+ function Extract_Call_Name (Call : Node_Id) return Node_Id;
+ pragma Inline (Extract_Call_Name);
+ -- Obtain the Name attribute of entry or subprogram call Call
+
+ procedure Extract_Instance_Attributes
+ (Exp_Inst : Node_Id;
+ Inst_Body : out Node_Id;
+ Inst_Decl : out Node_Id);
+ pragma Inline (Extract_Instance_Attributes);
+ -- Obtain body Inst_Body and spec Inst_Decl of expanded instance Exp_Inst
+
+ procedure Extract_Instantiation_Attributes
+ (Exp_Inst : Node_Id;
+ Inst : out Node_Id;
+ Inst_Id : out Entity_Id;
+ Gen_Id : out Entity_Id;
+ Attrs : out Instantiation_Attributes);
+ -- Obtain attributes Attrs associated with expanded instantiation Exp_Inst.
+ -- Inst is the instantiation. Inst_Id is the entity of the instance. Gen_Id
+ -- is the entity of the generic unit being instantiated.
+
+ procedure Extract_Target_Attributes
+ (Target_Id : Entity_Id;
+ Attrs : out Target_Attributes);
+ -- Obtain attributes Attrs associated with an entry, package, or subprogram
+ -- denoted by Target_Id.
+
+ procedure Extract_Task_Attributes
+ (Typ : Entity_Id;
+ Attrs : out Task_Attributes);
+ -- Obtain attributes Attrs associated with task type Typ
+
+ procedure Extract_Variable_Reference_Attributes
+ (Ref : Node_Id;
+ Var_Id : out Entity_Id;
+ Attrs : out Variable_Attributes);
+ -- Obtain attributes Attrs associated with reference Ref which mentions
+ -- variable Var_Id.
+
+ function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id;
+ pragma Inline (Find_Code_Unit);
+ -- Return the code unit which contains arbitrary node or entity N. This
+ -- is the unit of the file which physically contains the related construct
+ -- denoted by N except when N is within an instantiation. In that case the
+ -- unit is that of the top level instantiation.
+
+ procedure Find_Elaborated_Units;
+ -- Populate table Elaboration_Context with all units which have prior
+ -- elaboration with respect to the main unit.
+
+ function Find_Enclosing_Instance (N : Node_Id) return Node_Id;
+ pragma Inline (Find_Enclosing_Instance);
+ -- Find the declaration or body of the nearest expanded instance which
+ -- encloses arbitrary node N. Return Empty if no such instance exists.
+
+ function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id;
+ pragma Inline (Find_Top_Unit);
+ -- Return the top unit which contains arbitrary node or entity N. The unit
+ -- is obtained by logically unwinding instantiations and subunits when N
+ -- resides within one.
+
+ function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id;
+ pragma Inline (First_Formal_Type);
+ -- Return the type of subprogram Subp_Id's first formal parameter. If the
+ -- subprogram lacks formal parameters, return Empty.
+
+ function Has_Body (Pack_Decl : Node_Id) return Boolean;
+ -- Determine whether package declaration Pack_Decl has a corresponding body
+ -- or would eventually have one.
+
+ function Has_Prior_Elaboration
+ (Unit_Id : Entity_Id;
+ Context_OK : Boolean := False;
+ Elab_Body_OK : Boolean := False;
+ Same_Unit_OK : Boolean := False) return Boolean;
+ pragma Inline (Has_Prior_Elaboration);
+ -- Determine whether unit Unit_Id is elaborated prior to the main unit.
+ -- If flag Context_OK is set, the routine considers the following case
+ -- as valid prior elaboration:
+ --
+ -- * Unit_Id is in the elaboration context of the main unit
+ --
+ -- If flag Elab_Body_OK is set, the routine considers the following case
+ -- as valid prior elaboration:
+ --
+ -- * Unit_Id has pragma Elaborate_Body and is not the main unit
+ --
+ -- If flag Same_Unit_OK is set, the routine considers the following cases
+ -- as valid prior elaboration:
+ --
+ -- * Unit_Id is the main unit
+ --
+ -- * Unit_Id denotes the spec of the main unit body
+
+ function In_External_Instance
+ (N : Node_Id;
+ Target_Decl : Node_Id) return Boolean;
+ -- Determine whether a target desctibed by its declaration Target_Decl
+ -- resides in a package instance which is external to scenario N.
+
+ function In_Main_Context (N : Node_Id) return Boolean;
+ pragma Inline (In_Main_Context);
+ -- Determine whether arbitrary node N appears within the main compilation
+ -- unit.
+
+ function In_Same_Context
+ (N1 : Node_Id;
+ N2 : Node_Id;
+ Nested_OK : Boolean := False) return Boolean;
+ -- Determine whether two arbitrary nodes N1 and N2 appear within the same
+ -- context ignoring enclosing library levels. Nested_OK should be set when
+ -- the context of N1 can enclose that of N2.
+
+ procedure Info_Call
+ (Call : Node_Id;
+ Target_Id : Entity_Id;
+ Info_Msg : Boolean;
+ In_SPARK : Boolean);
+ -- Output information concerning call Call which invokes target Target_Id.
+ -- If flag Info_Msg is set, the routine emits an information message,
+ -- otherwise it emits an error. If flag In_SPARK is set, then string " in
+ -- SPARK" is added to the end of the message.
+
+ procedure Info_Instantiation
+ (Inst : Node_Id;
+ Gen_Id : Entity_Id;
+ Info_Msg : Boolean;
+ In_SPARK : Boolean);
+ -- Output information concerning instantiation Inst which instantiates
+ -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an
+ -- information message, otherwise it emits an error. If flag In_SPARK
+ -- is set, then string " in SPARK" is added to the end of the message.
+
+ procedure Info_Variable_Reference
+ (Ref : Node_Id;
+ Var_Id : Entity_Id;
+ Info_Msg : Boolean;
+ In_SPARK : Boolean);
+ -- Output information concerning reference Ref which mentions variable
+ -- Var_Id. If flag Info_Msg is set, the routine emits an information
+ -- message, otherwise it emits an error. If flag In_SPARK is set, then
+ -- string " in SPARK" is added to the end of the message.
+
+ function Insertion_Node (N : Node_Id; Ins_Nod : Node_Id) return Node_Id;
+ pragma Inline (Insertion_Node);
+ -- Obtain the proper insertion node of an ABE check or failure for scenario
+ -- N and candidate insertion node Ins_Nod.
+
+ procedure Install_ABE_Check
+ (N : Node_Id;
+ Id : Entity_Id;
+ Ins_Nod : Node_Id);
+ -- Insert a run-time ABE check for elaboration scenario N which verifies
+ -- whether arbitrary entity Id is elaborated. The check in inserted prior
+ -- to node Ins_Nod.
+
+ procedure Install_ABE_Check
+ (N : Node_Id;
+ Target_Id : Entity_Id;
+ Target_Decl : Node_Id;
+ Target_Body : Node_Id;
+ Ins_Nod : Node_Id);
+ -- Insert a run-time ABE check for elaboration scenario N which verifies
+ -- whether target Target_Id with initial declaration Target_Decl and body
+ -- Target_Body is elaborated. The check is inserted prior to node Ins_Nod.
+
+ procedure Install_ABE_Failure (N : Node_Id; Ins_Nod : Node_Id);
+ -- Insert a Program_Error concerning a guaranteed ABE for elaboration
+ -- scenario N. The failure is inserted prior to node Node_Id.
+
+ function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Accept_Alternative_Proc);
+ -- Determine whether arbitrary entity Id denotes an internally generated
+ -- procedure which encapsulates the statements of an accept alternative.
+
+ function Is_Activation_Proc (Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Activation_Proc);
+ -- Determine whether arbitrary entity Id denotes a runtime procedure in
+ -- charge with activating tasks.
+
+ function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Ada_Semantic_Target);
+ -- Determine whether arbitrary entity Id nodes a source or internally
+ -- generated subprogram which emulates Ada semantics.
+
+ function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Bodiless_Subprogram);
+ -- Determine whether subprogram Subp_Id will never have a body
+
+ function Is_Check_Emitting_Scenario (N : Node_Id) return Boolean;
+ pragma Inline (Is_Check_Emitting_Scenario);
+ -- Determine whether arbitrary node N denotes a scenario which may emit a
+ -- conditional ABE check.
+
+ function Is_Controlled_Proc
+ (Subp_Id : Entity_Id;
+ Subp_Nam : Name_Id) return Boolean;
+ pragma Inline (Is_Controlled_Proc);
+ -- Determine whether subprogram Subp_Id denotes controlled type primitives
+ -- Adjust, Finalize, or Initialize as denoted by name Subp_Nam.
+
+ function Is_Default_Initial_Condition_Proc (Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Default_Initial_Condition_Proc);
+ -- Determine whether arbitrary entity Id denotes internally generated
+ -- routine Default_Initial_Condition.
+
+ function Is_Finalizer_Proc (Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Finalizer_Proc);
+ -- Determine whether arbitrary entity Id denotes internally generated
+ -- routine _Finalizer.
+
+ function Is_Guaranteed_ABE
+ (N : Node_Id;
+ Target_Decl : Node_Id;
+ Target_Body : Node_Id) return Boolean;
+ -- Determine whether scenario N with a target described by its initial
+ -- declaration Target_Decl and body Target_Decl results in a guaranteed
+ -- ABE.
+
+ function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Initial_Condition_Proc);
+ -- Determine whether arbitrary entity Id denotes internally generated
+ -- routine Initial_Condition.
+
+ function Is_Invariant_Proc (Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Invariant_Proc);
+ -- Determine whether arbitrary entity Id denotes an invariant procedure
+
+ function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean;
+ pragma Inline (Is_Non_Library_Level_Encapsulator);
+ -- Determine whether arbitrary node N is a non-library encapsulator
+
+ function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Partial_Invariant_Proc);
+ -- Determine whether arbitrary entity Id denotes a partial invariant
+ -- procedure.
+
+ function Is_Postconditions_Proc (Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Postconditions_Proc);
+ -- Determine whether arbitrary entity Id denotes internally generated
+ -- routine _Postconditions.
+
+ function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Preelaborated_Unit);
+ -- Determine whether arbitrary entity Id denotes a unit which is subject to
+ -- one of the following pragmas:
+ --
+ -- * Preelaborable
+ -- * Pure
+ -- * Remote_Call_Interface
+ -- * Remote_Types
+ -- * Shared_Passive
+
+ function Is_Protected_Entry (Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Protected_Entry);
+ -- Determine whether arbitrary entity Id denotes a protected entry
+
+ function Is_Protected_Subp (Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Protected_Subp);
+ -- Determine whether entity Id denotes a protected subprogram
+
+ function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Protected_Body_Subp);
+ -- Determine whether entity Id denotes the protected or unprotected version
+ -- of a protected subprogram.
+
+ function Is_Safe_Activation
+ (Call : Node_Id;
+ Task_Decl : Node_Id) return Boolean;
+ pragma Inline (Is_Safe_Activation);
+ -- Determine whether call Call which activates a task object described by
+ -- declaration Task_Decl is always ABE-safe.
+
+ function Is_Safe_Call
+ (Call : Node_Id;
+ Target_Attrs : Target_Attributes) return Boolean;
+ pragma Inline (Is_Safe_Call);
+ -- Determine whether call Call which invokes a target described by
+ -- attributes Target_Attrs is always ABE-safe.
+
+ function Is_Safe_Instantiation
+ (Inst : Node_Id;
+ Gen_Attrs : Target_Attributes) return Boolean;
+ pragma Inline (Is_Safe_Instantiation);
+ -- Determine whether instance Inst which instantiates a generic unit
+ -- described by attributes Gen_Attrs is always ABE-safe.
+
+ function Is_Same_Unit
+ (Unit_1 : Entity_Id;
+ Unit_2 : Entity_Id) return Boolean;
+ pragma Inline (Is_Same_Unit);
+ -- Determine whether entities Unit_1 and Unit_2 denote the same unit
+
+ function Is_Scenario (N : Node_Id) return Boolean;
+ pragma Inline (Is_Scenario);
+ -- Determine whether attribute node N denotes a scenario. The scenario may
+ -- not necessarily be eligible for ABE processing.
+
+ function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean;
+ pragma Inline (Is_SPARK_Semantic_Target);
+ -- Determine whether arbitrary entity Id nodes a source or internally
+ -- generated subprogram which emulates SPARK semantics.
+
+ function Is_Suitable_Access (N : Node_Id) return Boolean;
+ pragma Inline (Is_Suitable_Access);
+ -- Determine whether arbitrary node N denotes a suitable attribute for ABE
+ -- processing.
+
+ function Is_Suitable_Call (N : Node_Id) return Boolean;
+ pragma Inline (Is_Suitable_Call);
+ -- Determine whether arbitrary node N denotes a suitable call for ABE
+ -- processing.
+
+ function Is_Suitable_Instantiation (N : Node_Id) return Boolean;
+ pragma Inline (Is_Suitable_Instantiation);
+ -- Determine whether arbitrary node N is a suitable instantiation for ABE
+ -- processing.
+
+ function Is_Suitable_Scenario (N : Node_Id) return Boolean;
+ pragma Inline (Is_Suitable_Scenario);
+ -- Determine whether arbitrary node N is a suitable scenario for ABE
+ -- processing.
+
+ function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean;
+ pragma Inline (Is_Suitable_Variable_Assignment);
+ -- Determine whether arbitrary node N denotes a suitable assignment for ABE
+ -- processing.
+
+ function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean;
+ pragma Inline (Is_Suitable_Variable_Reference);
+ -- Determine whether arbitrary node N is a suitable reference to a variable
+ -- for ABE processing.
+
+ function Is_Task_Entry (Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Task_Entry);
+ -- Determine whether arbitrary entity Id denotes a task entry
+
+ function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean;
+ pragma Inline (Is_Up_Level_Target);
+ -- Determine whether the current root resides at the declaration level. If
+ -- this is the case, determine whether a target described by declaration
+ -- Target_Decl is within a context which encloses the current root or is in
+ -- a different unit.
+
+ procedure Meet_Elaboration_Requirement
+ (N : Node_Id;
+ Target_Id : Entity_Id;
+ Req_Nam : Name_Id);
+ -- Determine whether elaboration requirement Req_Nam for scenario N with
+ -- target Target_Id is met by the context of the main unit using the SPARK
+ -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an
+ -- error if this is not the case.
+
+ function Non_Private_View (Typ : Entity_Id) return Entity_Id;
+ pragma Inline (Non_Private_View);
+ -- Return the full view of private type Typ if available, otherwise return
+ -- type Typ.
+
+ procedure Output_Active_Scenarios (Error_Nod : Node_Id);
+ -- Output the contents of the active scenario stack from earliest to latest
+ -- to supplement an earlier error emitted for node Error_Nod.
+
+ procedure Pop_Active_Scenario (N : Node_Id);
+ pragma Inline (Pop_Active_Scenario);
+ -- Pop the top of the scenario stack. A check is made to ensure that the
+ -- scenario being removed is the same as N.
+
+ procedure Process_Access (Attr : Node_Id; In_Task_Body : Boolean);
+ -- Perform ABE checks and diagnostics for 'Access to entry, operator, or
+ -- subprogram denoted by Attr. Flag In_Task_Body should be set when the
+ -- processing is initiated from a task body.
+
+ generic
+ with procedure Process_Single_Activation
+ (Call : Node_Id;
+ Call_Attrs : Call_Attributes;
+ Obj_Id : Entity_Id;
+ Task_Attrs : Task_Attributes;
+ In_Task_Body : Boolean);
+ -- Perform ABE checks and diagnostics for task activation call Call
+ -- which activates task Obj_Id. Call_Attrs are the attributes of the
+ -- activation call. Task_Attrs are the attributes of the task type.
+ -- Flag In_Task_Body should be set when the processing is initiated
+ -- from a task body.
+
+ procedure Process_Activation_Call
+ (Call : Node_Id;
+ Call_Attrs : Call_Attributes;
+ In_Task_Body : Boolean);
+ -- Perform ABE checks and diagnostics for activation call Call by invoking
+ -- routine Process_Single_Activation on each task object being activated.
+ -- Call_Attrs are the attributes of the activation call. Flag In_Task_Body
+ -- should be set when the processing is initiated from a task body.
+
+ procedure Process_Activation_Conditional_ABE_Impl
+ (Call : Node_Id;
+ Call_Attrs : Call_Attributes;
+ Obj_Id : Entity_Id;
+ Task_Attrs : Task_Attributes;
+ In_Task_Body : Boolean);
+ -- Perform common conditional ABE checks and diagnostics for call Call
+ -- which activates task Obj_Id ignoring the Ada or SPARK rules. CAll_Attrs
+ -- are the attributes of the activation call. Task_Attrs are the attributes
+ -- of the task type. Flag In_Task_Body should be set when the processing is
+ -- initiated from a task body.
+
+ procedure Process_Activation_Guaranteed_ABE_Impl
+ (Call : Node_Id;
+ Call_Attrs : Call_Attributes;
+ Obj_Id : Entity_Id;
+ Task_Attrs : Task_Attributes;
+ In_Task_Body : Boolean);
+ -- Perform common guaranteed ABE checks and diagnostics for call Call
+ -- which activates task Obj_Id ignoring the Ada or SPARK rules. CAll_Attrs
+ -- are the attributes of the activation call. Task_Attrs are the attributes
+ -- of the task type. Flag In_Task_Body should be set when the processing is
+ -- initiated from a task body.
+
+ procedure Process_Call
+ (Call : Node_Id;
+ Call_Attrs : Call_Attributes;
+ Target_Id : Entity_Id;
+ In_Task_Body : Boolean);
+ -- Top level dispatcher for processing of calls. Perform ABE checks and
+ -- diagnostics for call Call which invokes target Target_Id. Call_Attrs
+ -- are the attributes of the call. Flag In_Task_Body should be set when
+ -- the processing is initiated from a task body.
+
+ procedure Process_Call_Ada
+ (Call : Node_Id;
+ Call_Attrs : Call_Attributes;
+ Target_Id : Entity_Id;
+ Target_Attrs : Target_Attributes;
+ In_Task_Body : Boolean);
+ -- Perform ABE checks and diagnostics for call Call which invokes target
+ -- Target_Id using the Ada rules. Call_Attrs are the attributes of the
+ -- call. Target_Attrs are attributes of the target. Flag In_Task_Body
+ -- should be set when the processing is initiated from a task body.
+
+ procedure Process_Call_Conditional_ABE
+ (Call : Node_Id;
+ Call_Attrs : Call_Attributes;
+ Target_Id : Entity_Id;
+ Target_Attrs : Target_Attributes);
+ -- Perform common conditional ABE checks and diagnostics for call Call that
+ -- invokes target Target_Id ignoring the Ada or SPARK rules. Call_Attrs are
+ -- the attributes of the call. Target_Attrs are attributes of the target.
+
+ procedure Process_Call_Guaranteed_ABE
+ (Call : Node_Id;
+ Call_Attrs : Call_Attributes;
+ Target_Id : Entity_Id);
+ -- Perform common guaranteed ABE checks and diagnostics for call Call which
+ -- invokes target Target_Id ignoring the Ada or SPARK rules. Call_Attrs are
+ -- the attributes of the call.
+
+ procedure Process_Call_SPARK
+ (Call : Node_Id;
+ Call_Attrs : Call_Attributes;
+ Target_Id : Entity_Id;
+ Target_Attrs : Target_Attributes);
+ -- Perform ABE checks and diagnostics for call Call which invokes target
+ -- Target_Id using the SPARK rules. Call_Attrs are the attributes of the
+ -- call. Target_Attrs are attributes of the target.
+
+ procedure Process_Guaranteed_ABE (N : Node_Id);
+ -- Top level dispatcher for processing of scenarios which result in a
+ -- guaranteed ABE.
+
+ procedure Process_Instantiation
+ (Exp_Inst : Node_Id;
+ In_Task_Body : Boolean);
+ -- Top level dispatcher for processing of instantiations. Perform ABE
+ -- checks and diagnostics for expanded instantiation Exp_Inst. Flag
+ -- In_Task_Body should be set when the processing is initiated from a
+ -- task body.
+
+ procedure Process_Instantiation_Ada
+ (Exp_Inst : Node_Id;
+ Inst : Node_Id;
+ Inst_Attrs : Instantiation_Attributes;
+ Gen_Id : Entity_Id;
+ Gen_Attrs : Target_Attributes;
+ In_Task_Body : Boolean);
+ -- Perform ABE checks and diagnostics for expanded instantiation Exp_Inst
+ -- of generic Gen_Id using the Ada rules. Inst is the instantiation node.
+ -- Inst_Attrs are the attributes of the instance. Gen_Attrs are the
+ -- attributes of the generic. Flag In_Task_Body should be set when the
+ -- processing is initiated from a task body.
+
+ procedure Process_Instantiation_Conditional_ABE
+ (Exp_Inst : Node_Id;
+ Inst : Node_Id;
+ Inst_Attrs : Instantiation_Attributes;
+ Gen_Id : Entity_Id;
+ Gen_Attrs : Target_Attributes);
+ -- Perform common conditional ABE checks and diagnostics for expanded
+ -- instantiation Exp_Inst of generic Gen_Id ignoring the Ada or SPARK
+ -- rules. Inst is the instantiation node. Inst_Attrs are the attributes
+ -- of the instance. Gen_Attrs are the attributes of the generic.
+
+ procedure Process_Instantiation_Guaranteed_ABE (Exp_Inst : Node_Id);
+ -- Perform common guaranteed ABE checks and diagnostics for expanded
+ -- instantiation Exp_Inst of generic Gen_Id ignoring the Ada or SPARK
+ -- rules.
+
+ procedure Process_Instantiation_SPARK
+ (Exp_Inst : Node_Id;
+ Inst : Node_Id;
+ Inst_Attrs : Instantiation_Attributes;
+ Gen_Id : Entity_Id;
+ Gen_Attrs : Target_Attributes);
+ -- Perform ABE checks and diagnostics for expanded instantiation Exp_Inst
+ -- of generic Gen_Id using the SPARK rules. Inst is the instantiation node.
+ -- Inst_Attrs are the attributes of the instance. Gen_Attrs are the
+ -- attributes of the generic.
+
+ procedure Process_Scenario (N : Node_Id; In_Task_Body : Boolean := False);
+ -- Top level dispatcher for processing of various elaboration scenarios.
+ -- Perform ABE checks and diagnostics for scenario N. Flag In_Task_Body
+ -- should be set when the processing is initiated from a task body.
+
+ procedure Process_Variable_Assignment (Asmt : Node_Id);
+ -- Perform ABE checks and diagnostics for assignment statement Asmt
+
+ procedure Process_Variable_Reference (Ref : Node_Id);
+ -- Perform ABE checks and diagnostics for variable reference Ref
+
+ procedure Push_Active_Scenario (N : Node_Id);
+ pragma Inline (Push_Active_Scenario);
+ -- Push scenario N on top of the scenario stack
+
+ function Root_Scenario return Node_Id;
+ pragma Inline (Root_Scenario);
+ -- Return the top level scenario which started a recursive search for other
+ -- scenarios. It is assumed that there is a valid top level scenario on the
+ -- active scenario stack.
+
+ function Static_Elaboration_Checks return Boolean;
+ pragma Inline (Static_Elaboration_Checks);
+ -- Determine whether the static model is in effect
+
+ procedure Traverse_Body (N : Node_Id; In_Task_Body : Boolean);
+ -- Inspect the declarations and statements of subprogram body N for
+ -- suitable elaboration scenarios and process them. Flag In_Task_Body
+ -- should be set when the traversal is initiated from a task body.
+
+ procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id);
+ -- Update all relevant internal data structures when scenario Old_N is
+ -- transformed into scenario New_N by Atree.Rewrite.
+
+ -----------------------
+ -- Build_Call_Marker --
+ -----------------------
+
+ procedure Build_Call_Marker (N : Node_Id) is
+ function In_External_Context
+ (Call : Node_Id;
+ Target_Id : Entity_Id) return Boolean;
+ pragma Inline (In_External_Context);
+ -- Determine whether target Target_Id is external to call N which must
+ -- reside within an instance.
+
+ function In_Premature_Context (Call : Node_Id) return Boolean;
+ -- Determine whether call Call appears within a premature context
+
+ function Is_Bridge_Target (Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Bridge_Target);
+ -- Determine whether arbitrary entity Id denotes a bridge target
+
+ function Is_Default_Expression (Call : Node_Id) return Boolean;
+ pragma Inline (Is_Default_Expression);
+ -- Determine whether call Call acts as the expression of a defaulted
+ -- parameter within a source call.
+
+ function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Generic_Formal_Subp);
+ -- Determine whether subprogram Subp_Id denotes a generic formal
+ -- subprogram which appears in the "prologue" of an instantiation.
+
+ -------------------------
+ -- In_External_Context --
+ -------------------------
+
+ function In_External_Context
+ (Call : Node_Id;
+ Target_Id : Entity_Id) return Boolean
+ is
+ Target_Decl : constant Node_Id := Unit_Declaration_Node (Target_Id);
+
+ Inst : Node_Id;
+ Inst_Body : Node_Id;
+ Inst_Decl : Node_Id;
+
+ begin
+ -- Performance note: parent traversal
+
+ Inst := Find_Enclosing_Instance (Call);
+
+ -- The call appears within an instance
+
+ if Present (Inst) then
+
+ -- The call comes from the main unit and the target does not
+
+ if In_Extended_Main_Code_Unit (Call)
+ and then not In_Extended_Main_Code_Unit (Target_Decl)
+ then
+ return True;
+
+ -- Otherwise the target declaration must not appear within the
+ -- instance spec or body.
+
+ else
+ Extract_Instance_Attributes
+ (Exp_Inst => Inst,
+ Inst_Decl => Inst_Decl,
+ Inst_Body => Inst_Body);
+
+ -- Performance note: parent traversal
+
+ return not In_Subtree
+ (N => Target_Decl,
+ Root1 => Inst_Decl,
+ Root2 => Inst_Body);
+ end if;
+ end if;
+
+ return False;
+ end In_External_Context;
+
+ --------------------------
+ -- In_Premature_Context --
+ --------------------------
+
+ function In_Premature_Context (Call : Node_Id) return Boolean is
+ Par : Node_Id;
+
+ begin
+ -- Climb the parent chain looking for premature contexts
+
+ Par := Parent (Call);
+ while Present (Par) loop
+
+ -- Aspect specifications and generic associations are premature
+ -- contexts because nested calls has not been relocated to their
+ -- final context.
+
+ if Nkind_In (Par, N_Aspect_Specification,
+ N_Generic_Association)
+ then
+ return True;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (Par) then
+ exit;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ return False;
+ end In_Premature_Context;
+
+ ----------------------
+ -- Is_Bridge_Target --
+ ----------------------
+
+ function Is_Bridge_Target (Id : Entity_Id) return Boolean is
+ begin
+ return
+ Is_Accept_Alternative_Proc (Id)
+ or else Is_Finalizer_Proc (Id)
+ or else Is_Partial_Invariant_Proc (Id)
+ or else Is_Postconditions_Proc (Id)
+ or else Is_TSS (Id, TSS_Deep_Adjust)
+ or else Is_TSS (Id, TSS_Deep_Finalize)
+ or else Is_TSS (Id, TSS_Deep_Initialize);
+ end Is_Bridge_Target;
+
+ ---------------------------
+ -- Is_Default_Expression --
+ ---------------------------
+
+ function Is_Default_Expression (Call : Node_Id) return Boolean is
+ Outer_Call : constant Node_Id := Parent (Call);
+ Outer_Nam : Node_Id;
+
+ begin
+ -- To qualify, the node must appear immediately within a source call
+ -- which invokes a source target.
+
+ if Nkind_In (Outer_Call, N_Entry_Call_Statement,
+ N_Function_Call,
+ N_Procedure_Call_Statement)
+ and then Comes_From_Source (Outer_Call)
+ then
+ Outer_Nam := Extract_Call_Name (Outer_Call);
+
+ return
+ Is_Entity_Name (Outer_Nam)
+ and then Present (Entity (Outer_Nam))
+ and then Is_Subprogram_Or_Entry (Entity (Outer_Nam))
+ and then Comes_From_Source (Entity (Outer_Nam));
+ end if;
+
+ return False;
+ end Is_Default_Expression;
+
+ ----------------------------
+ -- Is_Generic_Formal_Subp --
+ ----------------------------
+
+ function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean is
+ Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id);
+ Context : constant Node_Id := Parent (Subp_Decl);
+
+ begin
+ -- To qualify, the subprogram must rename a generic actual subprogram
+ -- where the enclosing context is an instantiation.
+
+ return
+ Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
+ and then not Comes_From_Source (Subp_Decl)
+ and then Nkind_In (Context, N_Function_Specification,
+ N_Package_Specification,
+ N_Procedure_Specification)
+ and then Present (Generic_Parent (Context));
+ end Is_Generic_Formal_Subp;
+
+ -- Local variables
+
+ Call_Attrs : Call_Attributes;
+ Call_Nam : Node_Id;
+ Marker : Node_Id;
+ Target_Id : Entity_Id;
+
+ -- Start of processing for Build_Call_Marker
+
+ begin
+ -- Nothing to do for ASIS. As a result, ABE checks and diagnostics are
+ -- not performed in this mode.
+
+ if ASIS_Mode then
+ return;
+
+ -- Nothing to do when the input does not denote a call or a requeue
+
+ elsif not Nkind_In (N, N_Entry_Call_Statement,
+ N_Function_Call,
+ N_Procedure_Call_Statement,
+ N_Requeue_Statement)
+ then
+ return;
+
+ -- Nothing to do when the call is being preanalyzed as the marker will
+ -- be inserted in the wrong place.
+
+ elsif Preanalysis_Active then
+ return;
+
+ -- Nothing to do when the call is analyzed/resolved too early within an
+ -- intermediate context.
+
+ -- Performance note: parent traversal
+
+ elsif In_Premature_Context (N) then
+ return;
+ end if;
+
+ Call_Nam := Extract_Call_Name (N);
+
+ -- Nothing to do when the call is erroneous or left in a bad state
+
+ if not (Is_Entity_Name (Call_Nam)
+ and then Present (Entity (Call_Nam))
+ and then Is_Subprogram_Or_Entry (Entity (Call_Nam)))
+ then
+ return;
+
+ -- Nothing to do when the call invokes a generic formal subprogram and
+ -- switch -gnatd.G (ignore calls through generic formal parameters for
+ -- elaboration) is in effect. This check must be performed with the
+ -- direct target of the call to avoid the side effects of mapping
+ -- actuals to formals using renamings.
+
+ elsif Debug_Flag_Dot_GG
+ and then Is_Generic_Formal_Subp (Entity (Call_Nam))
+ then
+ return;
+ end if;
+
+ Extract_Call_Attributes
+ (Call => N,
+ Target_Id => Target_Id,
+ Attrs => Call_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.
+
+ if Debug_Flag_LL
+ and then not Is_Generic_Formal_Subp (Entity (Call_Nam))
+
+ -- Performance note: parent traversal
+
+ and then In_External_Context
+ (Call => N,
+ Target_Id => Target_Id)
+ then
+ return;
+
+ -- Source calls to source targets are always considered because they
+ -- reflect the original call graph.
+
+ elsif Comes_From_Source (Target_Id) and then Call_Attrs.From_Source then
+ null;
+
+ -- A call to a source function which acts as the default expression in
+ -- another call requires special detection.
+
+ elsif Comes_From_Source (Target_Id)
+ and then Nkind (N) = N_Function_Call
+ and then Is_Default_Expression (N)
+ then
+ null;
+
+ -- The target emulates Ada semantics
+
+ elsif Is_Ada_Semantic_Target (Target_Id) then
+ null;
+
+ -- The target acts as a link between scenarios
+
+ elsif Is_Bridge_Target (Target_Id) then
+ null;
+
+ -- The target emulates SPARK semantics
+
+ elsif Is_SPARK_Semantic_Target (Target_Id) then
+ null;
+
+ -- Otherwise the call is not suitable for ABE processing. This prevents
+ -- the generation of call markers which will never play a role in ABE
+ -- diagnostics.
+
+ else
+ return;
+ end if;
+
+ -- At this point it is known that the call will play some role in ABE
+ -- checks and diagnostics. Create a corresponding call marker in case
+ -- the original call is heavily transformed by expansion later on.
+
+ Marker := Make_Call_Marker (Sloc (N));
+
+ -- 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);
+
+ -- The marker is inserted prior to the original call. This placement has
+ -- several desirable effects:
+
+ -- 1) The marker appears in the same context, in close proximity to
+ -- the call.
+
+ -- <marker>
+ -- <call>
+
+ -- 2) Inserting the marker prior to the call ensures that an ABE check
+ -- will take effect prior to the call.
+
+ -- <ABE check>
+ -- <marker>
+ -- <call>
+
+ -- 3) The above two properties are preserved even when the call is a
+ -- function which is subsequently relocated in order to capture its
+ -- result. Note that if the call is relocated to a new context, the
+ -- relocated call will receive a marker of its own.
+
+ -- <ABE check>
+ -- <maker>
+ -- Temp : ... := Func_Call ...;
+ -- ... Temp ...
+
+ -- The insertion must take place even when the call does not occur in
+ -- the main unit to keep the tree symmetric. This ensures that internal
+ -- name serialization is consistent in case the call marker causes the
+ -- tree to transform in some way.
+
+ Insert_Action (N, Marker);
+
+ -- The marker becomes the "corresponding" scenario for the call. Save
+ -- the marker for later processing by the ABE phase.
+
+ Record_Elaboration_Scenario (Marker);
+ end Build_Call_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;
+
+ -- Examine the context of the main unit and record all units with prior
+ -- elaboration with respect to it.
+
+ Find_Elaborated_Units;
+
+ -- Examine each top level scenario saved during the Recording phase and
+ -- perform various actions depending on the elaboration model in effect.
+
+ for Index in Top_Level_Scenarios.First .. Top_Level_Scenarios.Last loop
+
+ -- Clear the table of visited scenario bodies for each new top level
+ -- scenario.
+
+ Visited_Bodies.Reset;
+
+ Process_Scenario (Top_Level_Scenarios.Table (Index));
+ end loop;
+ end Check_Elaboration_Scenarios;
+
+ ------------------------------
+ -- Check_Preelaborated_Call --
+ ------------------------------
+
+ procedure Check_Preelaborated_Call (Call : Node_Id) is
+ function In_Preelaborated_Context (N : Node_Id) return Boolean;
+ -- Determine whether arbitrary node appears in a preelaborated context
+
+ ------------------------------
+ -- In_Preelaborated_Context --
+ ------------------------------
+
+ function In_Preelaborated_Context (N : Node_Id) return Boolean is
+ Body_Id : constant Entity_Id := Find_Code_Unit (N);
+ Spec_Id : constant Entity_Id := Unique_Entity (Body_Id);
+
+ begin
+ -- The node appears within a package body whose corresponding spec is
+ -- subject to pragma Remote_Call_Interface or Remote_Types. This does
+ -- not result in a preelaborated context because the package body may
+ -- be on another machine.
+
+ if Ekind (Body_Id) = E_Package_Body
+ and then Ekind (Spec_Id) = E_Package
+ and then (Is_Remote_Call_Interface (Spec_Id)
+ or else Is_Remote_Types (Spec_Id))
+ then
+ return False;
+
+ -- Otherwise the node appears within a preelaborated context when the
+ -- associated unit is preelaborated.
+
+ else
+ return Is_Preelaborated_Unit (Spec_Id);
+ end if;
+ end In_Preelaborated_Context;
+
+ -- Local variables
+
+ Call_Attrs : Call_Attributes;
+ Level : Enclosing_Level_Kind;
+ Target_Id : Entity_Id;
+
+ -- Start of processing for Check_Preelaborated_Call
+
+ begin
+ Extract_Call_Attributes
+ (Call => Call,
+ Target_Id => Target_Id,
+ Attrs => Call_Attrs);
+
+ -- Nothing to do when the call is internally generated because it is
+ -- assumed that it will never violate preelaboration.
+
+ if not Call_Attrs.From_Source then
+ return;
+ end if;
+
+ -- Performance note: parent traversal
+
+ Level := Find_Enclosing_Level (Call);
+
+ -- Library level calls are always considered because they are part of
+ -- the associated unit's elaboration actions.
+
+ if Level in Library_Level then
+ null;
+
+ -- Calls at the library level of a generic package body must be checked
+ -- because they would render an instantiation illegal if the template is
+ -- marked as preelaborated. Note that this does not apply to calls at
+ -- the library level of a generic package spec.
+
+ elsif Level = Generic_Package_Body then
+ null;
+
+ -- Otherwise the call does not appear at the proper level and must not
+ -- be considered for this check.
+
+ else
+ return;
+ end if;
+
+ -- The call appears within a preelaborated unit. Emit a warning only for
+ -- internal uses, otherwise this is an error.
+
+ if In_Preelaborated_Context (Call) then
+ Error_Msg_Warn := GNAT_Mode;
+ Error_Msg_N
+ ("<<non-static call not allowed in preelaborated unit", Call);
+ end if;
+ end Check_Preelaborated_Call;
+
+ ----------------------
+ -- Compilation_Unit --
+ ----------------------
+
+ function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is
+ Comp_Unit : Node_Id;
+
+ begin
+ Comp_Unit := Parent (Unit_Id);
+
+ -- Handle the case where a concurrent subunit is rewritten as a null
+ -- statement due to expansion activities.
+
+ if Nkind (Comp_Unit) = N_Null_Statement
+ and then Nkind_In (Original_Node (Comp_Unit), N_Protected_Body,
+ N_Task_Body)
+ then
+ Comp_Unit := Parent (Comp_Unit);
+ pragma Assert (Nkind (Comp_Unit) = N_Subunit);
+
+ -- Otherwise use the declaration node of the unit
+
+ else
+ Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id));
+ end if;
+
+ if Nkind (Comp_Unit) = N_Subunit then
+ Comp_Unit := Parent (Comp_Unit);
+ end if;
+
+ pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit);
+
+ return Comp_Unit;
+ end Compilation_Unit;
+
+ -----------------
+ -- Elab_Msg_NE --
+ -----------------
+
+ procedure Elab_Msg_NE
+ (Msg : String;
+ N : Node_Id;
+ Id : Entity_Id;
+ Info_Msg : Boolean;
+ In_SPARK : Boolean)
+ is
+ function Prefix return String;
+ -- Obtain the prefix of the message
+
+ function Suffix return String;
+ -- Obtain the suffix of the message
+
+ ------------
+ -- Prefix --
+ ------------
+
+ function Prefix return String is
+ begin
+ if Info_Msg then
+ return "info: ";
+ else
+ return "";
+ end if;
+ end Prefix;
+
+ ------------
+ -- Suffix --
+ ------------
+
+ function Suffix return String is
+ begin
+ if In_SPARK then
+ return " in SPARK";
+ else
+ return "";
+ end if;
+ end Suffix;
+
+ -- Start of processing for Elab_Msg_NE
+
+ begin
+ Error_Msg_NE (Prefix & Msg & Suffix, N, Id);
+ end Elab_Msg_NE;
+
+ ------------------------------
+ -- Elaboration_Context_Hash --
+ ------------------------------
+
+ function Elaboration_Context_Hash
+ (Key : Entity_Id) return Elaboration_Context_Index
+ is
+ begin
+ return Elaboration_Context_Index (Key mod Elaboration_Context_Max);
+ end Elaboration_Context_Hash;
+
+ --------------------------------------
+ -- Ensure_Dynamic_Prior_Elaboration --
+ --------------------------------------
+
+ procedure Ensure_Dynamic_Prior_Elaboration
+ (N : Node_Id;
+ Unit_Id : Entity_Id;
+ Prag_Nam : Name_Id)
+ is
+ procedure Info_Missing_Pragma;
+ pragma Inline (Info_Missing_Pragma);
+ -- Output information concerning missing Elaborate or Elaborate_All
+ -- pragma with name Prag_Nam for scenario N which ensures the prior
+ -- elaboration of Unit_Id.
+
+ -------------------------
+ -- Info_Missing_Pragma --
+ -------------------------
+
+ procedure Info_Missing_Pragma is
+ begin
+ -- Internal units are ignored as they cause unnecessary noise
+
+ if not In_Internal_Unit (Unit_Id) then
+
+ -- The name of the unit subjected to the elaboration pragma is
+ -- fully qualified to improve the clarity of the info message.
+
+ Error_Msg_Name_1 := Prag_Nam;
+ Error_Msg_Qual_Level := Nat'Last;
+
+ Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id);
+ Error_Msg_Qual_Level := 0;
+ end if;
+ end Info_Missing_Pragma;
+
+ -- Local variables
+
+ Elab_Attrs : Elaboration_Attributes;
+ Level : Enclosing_Level_Kind;
+
+ -- Start of processing for Ensure_Dynamic_Prior_Elaboration
+
+ begin
+ Elab_Attrs := Elaboration_Context.Get (Unit_Id);
+
+ -- Nothing to do when the unit is guaranteed prior elaboration by means
+ -- of a source Elaborate[_All] pragma.
+
+ if Present (Elab_Attrs.Source_Pragma) then
+ return;
+ end if;
+
+ -- Output extra information on a missing Elaborate[_All] pragma when
+ -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas
+ -- is in effect.
+
+ if Elab_Info_Messages then
+
+ -- Performance note: parent traversal
+
+ Level := Find_Enclosing_Level (N);
+
+ -- Declaration level scenario
+
+ if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N))
+ and then Level = Declaration_Level
+ then
+ null;
+
+ -- Library level scenario
+
+ elsif Level in Library_Level then
+ null;
+
+ -- Instantiation library level scenario
+
+ elsif Level = Instantiation then
+ null;
+
+ -- Otherwise the scenario does not appear at the proper level and
+ -- cannot possibly act as a top level scenario.
+
+ else
+ return;
+ end if;
+
+ Info_Missing_Pragma;
+ end if;
+ end Ensure_Dynamic_Prior_Elaboration;
+
+ ------------------------------
+ -- Ensure_Prior_Elaboration --
+ ------------------------------
+
+ procedure Ensure_Prior_Elaboration
+ (N : Node_Id;
+ Unit_Id : Entity_Id;
+ In_Task_Body : Boolean)
+ is
+ Prag_Nam : Name_Id;
+
+ begin
+ -- Instantiating an external generic unit requires an implicit Elaborate
+ -- because Elaborate_All is too strong and could introduce non-existent
+ -- elaboration cycles.
+
+ -- package External is
+ -- function Func ...;
+ -- end External;
+
+ -- with External;
+ -- generic
+ -- package Gen is
+ -- X : ... := External.Func;
+ -- end Gen;
+
+ -- [with External;] -- implicit with for External
+ -- [pragma Elaborate_All (External);] -- Elaborate_All for External
+ -- with Gen;
+ -- [pragma Elaborate (Gen);] -- Elaborate for generic
+ -- procedure Main is
+ -- package Inst is new Gen; -- calls External.Func
+ -- ...
+ -- end Main;
+
+ if Nkind (N) in N_Generic_Instantiation then
+ Prag_Nam := Name_Elaborate;
+
+ -- Otherwise generate an implicit Elaborate_All
+
+ else
+ Prag_Nam := Name_Elaborate_All;
+ end if;
+
+ -- 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
+ return;
+
+ -- Nothing to do when the unit is elaborated prior to the main unit.
+ -- This check must also consider the following cases:
+
+ -- * No check is made against the context of the main unit because this
+ -- is specific to the elaboration model in effect and requires custom
+ -- handling (see Ensure_xxx_Prior_Elaboration).
+
+ -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma
+ -- Elaborate[_All] MUST be generated even though Unit_Id is always
+ -- elaborated prior to the main unit. This is a conservative strategy
+ -- which ensures that other units withed by Unit_Id will not lead to
+ -- an ABE.
+
+ -- package A is package body A is
+ -- procedure ABE; procedure ABE is ... end ABE;
+ -- end A; end A;
+
+ -- with A;
+ -- package B is package body B is
+ -- pragma Elaborate_Body; procedure Proc is
+ -- begin
+ -- procedure Proc; A.ABE;
+ -- package B; end Proc;
+ -- end B;
+
+ -- with B;
+ -- package C is package body C is
+ -- ... ...
+ -- end C; begin
+ -- B.Proc;
+ -- end C;
+
+ -- In the example above, the elaboration of C invokes B.Proc. B is
+ -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] is
+ -- generated for B in C, then the following elaboratio order will lead
+ -- to an ABE:
+
+ -- spec of A elaborated
+ -- spec of B elaborated
+ -- body of B elaborated
+ -- spec of C elaborated
+ -- body of C elaborated <-- calls B.Proc which calls A.ABE
+ -- body of A elaborated <-- problem
+
+ -- The generation of an implicit pragma Elaborate_All (B) ensures that
+ -- the elaboration order mechanism will not pick the above order.
+
+ -- An implicit Elaborate is NOT generated when the unit is subject to
+ -- Elaborate_Body because both pragmas have the exact same effect.
+
+ -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] MUST
+ -- NOT be generated in this case because a unit cannot depend on its
+ -- own elaboration. This case is therefore treated as valid prior
+ -- elaboration.
+
+ elsif Has_Prior_Elaboration
+ (Unit_Id => Unit_Id,
+ Same_Unit_OK => True,
+ Elab_Body_OK => Prag_Nam = Name_Elaborate)
+ then
+ return;
+
+ -- Suggest the use of pragma Prag_Nam when the dynamic model is in
+ -- effect.
+
+ elsif Dynamic_Elaboration_Checks then
+ Ensure_Dynamic_Prior_Elaboration
+ (N => N,
+ Unit_Id => Unit_Id,
+ Prag_Nam => Prag_Nam);
+
+ -- Install an implicit pragma Prag_Nam when the static model is in
+ -- effect.
+
+ else
+ pragma Assert (Static_Elaboration_Checks);
+
+ Ensure_Static_Prior_Elaboration
+ (N => N,
+ Unit_Id => Unit_Id,
+ Prag_Nam => Prag_Nam);
+ end if;
+ end Ensure_Prior_Elaboration;
+
+ -------------------------------------
+ -- Ensure_Static_Prior_Elaboration --
+ -------------------------------------
+
+ procedure Ensure_Static_Prior_Elaboration
+ (N : Node_Id;
+ Unit_Id : Entity_Id;
+ Prag_Nam : Name_Id)
+ is
+ function Find_With_Clause
+ (Items : List_Id;
+ Withed_Id : Entity_Id) return Node_Id;
+ -- Find a non-limited with clause in the list of context items Items
+ -- which withs unit Withed_Id. Return Empty if no such clause is found.
+
+ procedure Info_Implicit_Pragma;
+ pragma Inline (Info_Implicit_Pragma);
+ -- Output information concerning an implicitly generated Elaborate or
+ -- Elaborate_All pragma with name Prag_Nam for scenario N which ensures
+ -- the prior elaboration of unit Unit_Id.
+
+ ----------------------
+ -- Find_With_Clause --
+ ----------------------
+
+ function Find_With_Clause
+ (Items : List_Id;
+ Withed_Id : Entity_Id) return Node_Id
+ is
+ Item : Node_Id;
+
+ begin
+ -- Examine the context clauses looking for a suitable with. Note that
+ -- limited clauses do not affect the elaboration order.
+
+ Item := First (Items);
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then not Error_Posted (Item)
+ and then not Limited_Present (Item)
+ and then Entity (Name (Item)) = Withed_Id
+ then
+ return Item;
+ end if;
+
+ Next (Item);
+ end loop;
+
+ return Empty;
+ end Find_With_Clause;
+
+ --------------------------
+ -- Info_Implicit_Pragma --
+ --------------------------
+
+ procedure Info_Implicit_Pragma is
+ begin
+ -- Internal units are ignored as they cause unnecessary noise
+
+ if not In_Internal_Unit (Unit_Id) then
+
+ -- The name of the unit subjected to the elaboration pragma is
+ -- fully qualified to improve the clarity of the info message.
+
+ Error_Msg_Name_1 := Prag_Nam;
+ Error_Msg_Qual_Level := Nat'Last;
+
+ Error_Msg_NE
+ ("info: implicit pragma % generated for unit &", N, Unit_Id);
+
+ Error_Msg_Qual_Level := 0;
+ Output_Active_Scenarios (N);
+ end if;
+ end Info_Implicit_Pragma;
+
+ -- Local variables
+
+ Main_Cunit : constant Node_Id := Cunit (Main_Unit);
+ Loc : constant Source_Ptr := Sloc (Main_Cunit);
+ Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id);
+
+ Is_Instantiation : constant Boolean :=
+ Nkind (N) in N_Generic_Instantiation;
+
+ Clause : Node_Id;
+ Elab_Attrs : Elaboration_Attributes;
+ Items : List_Id;
+
+ -- Start of processing for Ensure_Static_Prior_Elaboration
+
+ begin
+ Elab_Attrs := Elaboration_Context.Get (Unit_Id);
+
+ -- Nothing to do when the unit is guaranteed prior elaboration by means
+ -- of a source Elaborate[_All] pragma.
+
+ if Present (Elab_Attrs.Source_Pragma) then
+ return;
+
+ -- Nothing to do when the unit has an existing implicit Elaborate[_All]
+ -- pragma installed by a previous scenario.
+
+ elsif Present (Elab_Attrs.With_Clause) then
+
+ -- The unit is already guaranteed prior elaboration by means of an
+ -- implicit Elaborate pragma, however the current scenario imposes
+ -- a stronger requirement of Elaborate_All. "Upgrade" the existing
+ -- pragma to match this new requirement.
+
+ if Elaborate_Desirable (Elab_Attrs.With_Clause)
+ and then Prag_Nam = Name_Elaborate_All
+ then
+ Set_Elaborate_All_Desirable (Elab_Attrs.With_Clause);
+ Set_Elaborate_Desirable (Elab_Attrs.With_Clause, False);
+ end if;
+
+ return;
+ end if;
+
+ -- At this point it is known that the unit has no prior elaboration
+ -- according to pragmas and hierarchical relationships.
+
+ Items := Context_Items (Main_Cunit);
+
+ if No (Items) then
+ Items := New_List;
+ Set_Context_Items (Main_Cunit, Items);
+ end if;
+
+ -- Locate the with clause for the unit. Note that there may not be a
+ -- clause if the unit is visible through a subunit-body, body-spec, or
+ -- spec-parent relationship.
+
+ Clause :=
+ Find_With_Clause
+ (Items => Items,
+ Withed_Id => Unit_Id);
+
+ -- Generate:
+ -- with Id;
+
+ -- Note that adding implicit with clauses is safe because analysis,
+ -- resolution, and expansion have already taken place and it is not
+ -- possible to interfere with visibility.
+
+ if No (Clause) then
+ Clause :=
+ Make_With_Clause (Loc,
+ Name => New_Occurrence_Of (Unit_Id, Loc));
+
+ Set_Implicit_With (Clause);
+ Set_Library_Unit (Clause, Unit_Cunit);
+
+ Append_To (Items, Clause);
+ end if;
+
+ -- Instantiations require an implicit Elaborate because Elaborate_All is
+ -- too conservative and may introduce non-existent elaboration cycles.
+
+ if Is_Instantiation then
+ Set_Elaborate_Desirable (Clause);
+
+ -- Otherwise generate an implicit Elaborate_All
+
+ else
+ Set_Elaborate_All_Desirable (Clause);
+ end if;
+
+ -- The implicit Elaborate[_All] ensures the prior elaboration of the
+ -- unit. Include the unit in the elaboration context of the main unit.
+
+ Elaboration_Context.Set (Unit_Id,
+ Elaboration_Attributes'(Source_Pragma => Empty,
+ With_Clause => Clause));
+
+ -- Output extra information on an implicit Elaborate[_All] pragma when
+ -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas is
+ -- in effect.
+
+ if Elab_Info_Messages then
+ Info_Implicit_Pragma;
+ end if;
+ end Ensure_Static_Prior_Elaboration;
+
+ -----------------------------
+ -- Extract_Assignment_Name --
+ -----------------------------
+
+ function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id is
+ Nam : Node_Id;
+
+ begin
+ Nam := Name (Asmt);
+
+ -- When the name denotes an array or record component, find the whole
+ -- object.
+
+ while Nkind_In (Nam, N_Explicit_Dereference,
+ N_Indexed_Component,
+ N_Selected_Component,
+ N_Slice)
+ loop
+ Nam := Prefix (Nam);
+ end loop;
+
+ return Nam;
+ end Extract_Assignment_Name;
+
+ -----------------------------
+ -- Extract_Call_Attributes --
+ -----------------------------
+
+ procedure Extract_Call_Attributes
+ (Call : Node_Id;
+ Target_Id : out Entity_Id;
+ Attrs : out Call_Attributes)
+ is
+ From_Source : Boolean;
+ In_Declarations : Boolean;
+ Is_Dispatching : Boolean;
+
+ begin
+ -- Extraction for call markers
+
+ if Nkind (Call) = N_Call_Marker then
+ Target_Id := Target (Call);
+ From_Source := Is_Source_Call (Call);
+ In_Declarations := Is_Declaration_Level_Node (Call);
+ Is_Dispatching := Is_Dispatching_Call (Call);
+
+ -- Extraction for entry calls, requeue, and subprogram calls
+
+ else
+ pragma Assert (Nkind_In (Call, N_Entry_Call_Statement,
+ N_Function_Call,
+ N_Procedure_Call_Statement,
+ N_Requeue_Statement));
+
+ Target_Id := Entity (Extract_Call_Name (Call));
+ From_Source := Comes_From_Source (Call);
+
+ -- Performance note: parent traversal
+
+ In_Declarations := Find_Enclosing_Level (Call) = Declaration_Level;
+ Is_Dispatching :=
+ Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement)
+ and then Present (Controlling_Argument (Call));
+ end if;
+
+ -- Obtain the original entry or subprogram which the target may rename
+ -- except when the target is an instantiation. In this case the alias
+ -- is the internally generated subprogram which appears within the the
+ -- anonymous package created for the instantiation. Such an alias is not
+ -- a suitable target.
+
+ if not (Is_Subprogram (Target_Id)
+ and then Is_Generic_Instance (Target_Id))
+ then
+ Target_Id := Get_Renamed_Entity (Target_Id);
+ end if;
+
+ -- Set all attributes
+
+ Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call);
+ Attrs.From_Source := From_Source;
+ Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Call);
+ Attrs.In_Declarations := In_Declarations;
+ Attrs.Is_Dispatching := Is_Dispatching;
+ Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Call);
+ end Extract_Call_Attributes;
+
+ -----------------------
+ -- Extract_Call_Name --
+ -----------------------
+
+ function Extract_Call_Name (Call : Node_Id) return Node_Id is
+ Nam : Node_Id;
+
+ begin
+ Nam := Name (Call);
+
+ -- When the call invokes an entry family, the name appears as an indexed
+ -- component.
+
+ if Nkind (Nam) = N_Indexed_Component then
+ Nam := Prefix (Nam);
+ end if;
+
+ -- When the call employs the object.operation form, the name appears as
+ -- a selected component.
+
+ if Nkind (Nam) = N_Selected_Component then
+ Nam := Selector_Name (Nam);
+ end if;
+
+ return Nam;
+ end Extract_Call_Name;
+
+ ---------------------------------
+ -- Extract_Instance_Attributes --
+ ---------------------------------
+
+ procedure Extract_Instance_Attributes
+ (Exp_Inst : Node_Id;
+ Inst_Body : out Node_Id;
+ Inst_Decl : out Node_Id)
+ is
+ Body_Id : Entity_Id;
+
+ begin
+ -- Assume that the attributes are unavailable
+
+ Inst_Body := Empty;
+ Inst_Decl := Empty;
+
+ -- Generic package or subprogram spec
+
+ if Nkind_In (Exp_Inst, N_Package_Declaration,
+ N_Subprogram_Declaration)
+ then
+ Inst_Decl := Exp_Inst;
+ Body_Id := Corresponding_Body (Inst_Decl);
+
+ if Present (Body_Id) then
+ Inst_Body := Unit_Declaration_Node (Body_Id);
+ end if;
+
+ -- Generic package or subprogram body
+
+ else
+ pragma Assert
+ (Nkind_In (Exp_Inst, N_Package_Body, N_Subprogram_Body));
+
+ Inst_Body := Exp_Inst;
+ Inst_Decl := Unit_Declaration_Node (Corresponding_Spec (Inst_Body));
+ end if;
+ end Extract_Instance_Attributes;
+
+ --------------------------------------
+ -- Extract_Instantiation_Attributes --
+ --------------------------------------
+
+ procedure Extract_Instantiation_Attributes
+ (Exp_Inst : Node_Id;
+ Inst : out Node_Id;
+ Inst_Id : out Entity_Id;
+ Gen_Id : out Entity_Id;
+ Attrs : out Instantiation_Attributes)
+ is
+ begin
+ Inst := Original_Node (Exp_Inst);
+ Inst_Id := Defining_Entity (Inst);
+
+ -- Traverse a possible chain of renamings to obtain the original generic
+ -- being instantiatied.
+
+ Gen_Id := Get_Renamed_Entity (Entity (Name (Inst)));
+
+ -- Set all attributes
+
+ Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst);
+ Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Inst);
+ Attrs.In_Declarations := Is_Declaration_Level_Node (Inst);
+ Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Inst);
+ end Extract_Instantiation_Attributes;
+
+ -------------------------------
+ -- Extract_Target_Attributes --
+ -------------------------------
+
+ procedure Extract_Target_Attributes
+ (Target_Id : Entity_Id;
+ Attrs : out Target_Attributes)
+ is
+ procedure Extract_Package_Or_Subprogram_Attributes
+ (Spec_Id : out Entity_Id;
+ Body_Decl : out Node_Id);
+ -- Obtain the attributes associated with a package or a subprogram.
+ -- Spec_Id is the package or subprogram. Body_Decl is the declaration
+ -- of the corresponding package or subprogram body.
+
+ procedure Extract_Protected_Entry_Attributes
+ (Spec_Id : out Entity_Id;
+ Body_Decl : out Node_Id;
+ Body_Barf : out Node_Id);
+ -- Obtain the attributes associated with a protected entry [family].
+ -- Spec_Id is the entity of the protected body subprogram. Body_Decl
+ -- is the declaration of Spec_Id's corresponding body. Body_Barf is
+ -- the declaration of the barrier function body.
+
+ procedure Extract_Protected_Subprogram_Attributes
+ (Spec_Id : out Entity_Id;
+ Body_Decl : out Node_Id);
+ -- Obtain the attributes associated with a protected subprogram. Formal
+ -- Spec_Id is the entity of the protected body subprogram. Body_Decl is
+ -- the declaration of Spec_Id's corresponding body.
+
+ procedure Extract_Task_Entry_Attributes
+ (Spec_Id : out Entity_Id;
+ Body_Decl : out Node_Id);
+ -- Obtain the attributes associated with a task entry [family]. Formal
+ -- Spec_Id is the entity of the task body procedure. Body_Decl is the
+ -- declaration of Spec_Id's corresponding body.
+
+ ----------------------------------------------
+ -- Extract_Package_Or_Subprogram_Attributes --
+ ----------------------------------------------
+
+ procedure Extract_Package_Or_Subprogram_Attributes
+ (Spec_Id : out Entity_Id;
+ Body_Decl : out Node_Id)
+ is
+ Body_Id : Entity_Id;
+ Init_Id : Entity_Id;
+ Spec_Decl : Node_Id;
+
+ begin
+ -- Assume that the body is not available
+
+ Body_Decl := Empty;
+ Spec_Id := Target_Id;
+
+ -- For body retrieval purposes, the entity of the initial declaration
+ -- is that of the spec.
+
+ Init_Id := Spec_Id;
+
+ -- The only exception to the above is a function which returns a
+ -- constrained array type in a SPARK-to-C compilation. In this case
+ -- the function receives a corresponding procedure which has an out
+ -- parameter. The proper body for ABE checks and diagnostics is that
+ -- of the procedure.
+
+ if Ekind (Init_Id) = E_Function
+ and then Rewritten_For_C (Init_Id)
+ then
+ Init_Id := Corresponding_Procedure (Init_Id);
+ end if;
+
+ -- Extract the attributes of the body
+
+ Spec_Decl := Unit_Declaration_Node (Init_Id);
+
+ -- The initial declaration is a stand alone subprogram body
+
+ if Nkind (Spec_Decl) = N_Subprogram_Body then
+ Body_Decl := Spec_Decl;
+
+ -- Otherwise the package or subprogram has a spec and a completing
+ -- body.
+
+ elsif Nkind_In (Spec_Decl, N_Generic_Package_Declaration,
+ N_Generic_Subprogram_Declaration,
+ N_Package_Declaration,
+ N_Subprogram_Body_Stub,
+ N_Subprogram_Declaration)
+ then
+ Body_Id := Corresponding_Body (Spec_Decl);
+
+ if Present (Body_Id) then
+ Body_Decl := Unit_Declaration_Node (Body_Id);
+ end if;
+ end if;
+ end Extract_Package_Or_Subprogram_Attributes;
+
+ ----------------------------------------
+ -- Extract_Protected_Entry_Attributes --
+ ----------------------------------------
+
+ procedure Extract_Protected_Entry_Attributes
+ (Spec_Id : out Entity_Id;
+ Body_Decl : out Node_Id;
+ Body_Barf : out Node_Id)
+ is
+ Barf_Id : Entity_Id;
+ Body_Id : Entity_Id;
+
+ begin
+ -- Assume that the bodies are not available
+
+ Body_Barf := Empty;
+ Body_Decl := Empty;
+
+ -- When the entry [family] has already been expanded, it carries both
+ -- the procedure which emulates the behavior of the entry [family] as
+ -- well as the barrier function.
+
+ if Present (Protected_Body_Subprogram (Target_Id)) then
+ Spec_Id := Protected_Body_Subprogram (Target_Id);
+
+ -- Extract the attributes of the barrier function
+
+ Barf_Id :=
+ Corresponding_Body
+ (Unit_Declaration_Node (Barrier_Function (Target_Id)));
+
+ if Present (Barf_Id) then
+ Body_Barf := Unit_Declaration_Node (Barf_Id);
+ end if;
+
+ -- Otherwise no expansion took place
+
+ else
+ Spec_Id := Target_Id;
+ end if;
+
+ -- Extract the attributes of the entry body
+
+ Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
+
+ if Present (Body_Id) then
+ Body_Decl := Unit_Declaration_Node (Body_Id);
+ end if;
+ end Extract_Protected_Entry_Attributes;
+
+ ---------------------------------------------
+ -- Extract_Protected_Subprogram_Attributes --
+ ---------------------------------------------
+
+ procedure Extract_Protected_Subprogram_Attributes
+ (Spec_Id : out Entity_Id;
+ Body_Decl : out Node_Id)
+ is
+ Body_Id : Entity_Id;
+
+ begin
+ -- Assume that the body is not available
+
+ Body_Decl := Empty;
+
+ -- When the protected subprogram has already been expanded, it
+ -- carries the subprogram which seizes the lock and invokes the
+ -- original statements.
+
+ if Present (Protected_Subprogram (Target_Id)) then
+ Spec_Id :=
+ Protected_Body_Subprogram (Protected_Subprogram (Target_Id));
+
+ -- Otherwise no expansion took place
+
+ else
+ Spec_Id := Target_Id;
+ end if;
+
+ -- Extract the attributes of the body
+
+ Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
+
+ if Present (Body_Id) then
+ Body_Decl := Unit_Declaration_Node (Body_Id);
+ end if;
+ end Extract_Protected_Subprogram_Attributes;
+
+ -----------------------------------
+ -- Extract_Task_Entry_Attributes --
+ -----------------------------------
+
+ procedure Extract_Task_Entry_Attributes
+ (Spec_Id : out Entity_Id;
+ Body_Decl : out Node_Id)
+ is
+ Task_Typ : constant Entity_Id := Non_Private_View (Scope (Target_Id));
+ Body_Id : Entity_Id;
+
+ begin
+ -- Assume that the body is not available
+
+ Body_Decl := Empty;
+
+ -- The the task type has already been expanded, it carries the
+ -- procedure which emulates the behavior of the task body.
+
+ if Present (Task_Body_Procedure (Task_Typ)) then
+ Spec_Id := Task_Body_Procedure (Task_Typ);
+
+ -- Otherwise no expansion took place
+
+ else
+ Spec_Id := Task_Typ;
+ end if;
+
+ -- Extract the attributes of the body
+
+ Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
+
+ if Present (Body_Id) then
+ Body_Decl := Unit_Declaration_Node (Body_Id);
+ end if;
+ end Extract_Task_Entry_Attributes;
+
+ -- Local variables
+
+ Prag : constant Node_Id := SPARK_Pragma (Target_Id);
+ Body_Barf : Node_Id;
+ Body_Decl : Node_Id;
+ Spec_Id : Entity_Id;
+
+ -- Start of processing for Extract_Target_Attributes
+
+ begin
+ -- Assume that the body of the barrier function is not available
+
+ Body_Barf := Empty;
+
+ -- The target is a protected entry [family]
+
+ if Is_Protected_Entry (Target_Id) then
+ Extract_Protected_Entry_Attributes
+ (Spec_Id => Spec_Id,
+ Body_Decl => Body_Decl,
+ Body_Barf => Body_Barf);
+
+ -- The target is a protected subprogram
+
+ elsif Is_Protected_Subp (Target_Id)
+ or else Is_Protected_Body_Subp (Target_Id)
+ then
+ Extract_Protected_Subprogram_Attributes
+ (Spec_Id => Spec_Id,
+ Body_Decl => Body_Decl);
+
+ -- The target is a task entry [family]
+
+ elsif Is_Task_Entry (Target_Id) then
+ Extract_Task_Entry_Attributes
+ (Spec_Id => Spec_Id,
+ Body_Decl => Body_Decl);
+
+ -- Otherwise the target is a package or a subprogram
+
+ else
+ Extract_Package_Or_Subprogram_Attributes
+ (Spec_Id => Spec_Id,
+ Body_Decl => Body_Decl);
+ end if;
+
+ -- Set all attributes
+
+ Attrs.Body_Barf := Body_Barf;
+ Attrs.Body_Decl := Body_Decl;
+ Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Target_Id);
+ Attrs.From_Source := Comes_From_Source (Target_Id);
+ Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Target_Id);
+ Attrs.SPARK_Mode_On :=
+ Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On;
+ Attrs.Spec_Decl := Unit_Declaration_Node (Spec_Id);
+ Attrs.Spec_Id := Spec_Id;
+ Attrs.Unit_Id := Find_Top_Unit (Target_Id);
+
+ -- At this point certain attributes should always be available
+
+ pragma Assert (Present (Attrs.Spec_Decl));
+ pragma Assert (Present (Attrs.Spec_Id));
+ pragma Assert (Present (Attrs.Unit_Id));
+ end Extract_Target_Attributes;
+
+ -----------------------------
+ -- Extract_Task_Attributes --
+ -----------------------------
+
+ procedure Extract_Task_Attributes
+ (Typ : Entity_Id;
+ Attrs : out Task_Attributes)
+ is
+ Task_Typ : constant Entity_Id := Non_Private_View (Typ);
+
+ Body_Decl : Node_Id;
+ Body_Id : Entity_Id;
+ Prag : Node_Id;
+ Spec_Id : Entity_Id;
+
+ begin
+ -- Assume that the body of the task procedure is not available
+
+ Body_Decl := Empty;
+
+ -- The initial declaration is that of the task body procedure
+
+ Spec_Id := Get_Task_Body_Procedure (Task_Typ);
+ Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
+
+ if Present (Body_Id) then
+ Body_Decl := Unit_Declaration_Node (Body_Id);
+ end if;
+
+ Prag := SPARK_Pragma (Task_Typ);
+
+ -- Set all attributes
+
+ Attrs.Body_Decl := Body_Decl;
+ Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Task_Typ);
+ Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Task_Typ);
+ Attrs.SPARK_Mode_On :=
+ Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On;
+ Attrs.Spec_Id := Spec_Id;
+ Attrs.Task_Decl := Declaration_Node (Task_Typ);
+ Attrs.Unit_Id := Find_Top_Unit (Task_Typ);
+
+ -- At this point certain attributes should always be available
+
+ pragma Assert (Present (Attrs.Spec_Id));
+ pragma Assert (Present (Attrs.Task_Decl));
+ pragma Assert (Present (Attrs.Unit_Id));
+ end Extract_Task_Attributes;
+
+ -------------------------------------------
+ -- Extract_Variable_Reference_Attributes --
+ -------------------------------------------
+
+ procedure Extract_Variable_Reference_Attributes
+ (Ref : Node_Id;
+ Var_Id : out Entity_Id;
+ Attrs : out Variable_Attributes)
+ is
+ begin
+ -- Traverse a possible chain of renamings to obtain the original
+ -- variable being referenced.
+
+ Var_Id := Get_Renamed_Entity (Entity (Ref));
+
+ Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Ref);
+ Attrs.Unit_Id := Find_Top_Unit (Var_Id);
+
+ -- At this point certain attributes should always be available
+
+ pragma Assert (Present (Attrs.Unit_Id));
+ end Extract_Variable_Reference_Attributes;
+
+ --------------------
+ -- Find_Code_Unit --
+ --------------------
+
+ function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id is
+ N_Unit : constant Node_Id := Unit (Cunit (Get_Code_Unit (N)));
+
+ begin
+ return Defining_Entity (N_Unit, Concurrent_Subunit => True);
+ end Find_Code_Unit;
+
+ ---------------------------
+ -- Find_Elaborated_Units --
+ ---------------------------
+
+ procedure Find_Elaborated_Units is
+ procedure Add_Pragma (Prag : Node_Id);
+ -- Determine whether pragma Prag denotes a legal Elaborate[_All] pragma.
+ -- If this is the case, add the related unit to the elaboration context.
+ -- For pragma Elaborate_All, include recursively all units withed by the
+ -- related unit.
+
+ procedure Add_Unit
+ (Unit_Id : Entity_Id;
+ Prag : Node_Id;
+ Full_Context : Boolean);
+ -- Add unit Unit_Id to the elaboration context. Prag denotes the pragma
+ -- which prompted the inclusion of the unit to the elaboration context.
+ -- If flag Full_Context is set, examine the non-limited clauses of unit
+ -- Unit_Id and add each withed unit to the context.
+
+ procedure Find_Elaboration_Context (Comp_Unit : Node_Id);
+ -- Examine the context items of compilation unit Comp_Unit for suitable
+ -- elaboration-related pragmas and add all related units to the context.
+
+ ----------------
+ -- Add_Pragma --
+ ----------------
+
+ procedure Add_Pragma (Prag : Node_Id) is
+ Prag_Args : constant List_Id := Pragma_Argument_Associations (Prag);
+ Prag_Nam : constant Name_Id := Pragma_Name (Prag);
+ Unit_Arg : Node_Id;
+
+ begin
+ -- Nothing to do if the pragma is not related to elaboration
+
+ if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then
+ return;
+
+ -- Nothing to do when the pragma is illegal
+
+ elsif Error_Posted (Prag) then
+ return;
+ end if;
+
+ Unit_Arg := Get_Pragma_Arg (First (Prag_Args));
+
+ -- The argument of the pragma may appear in package.package form
+
+ if Nkind (Unit_Arg) = N_Selected_Component then
+ Unit_Arg := Selector_Name (Unit_Arg);
+ end if;
+
+ Add_Unit
+ (Unit_Id => Entity (Unit_Arg),
+ Prag => Prag,
+ Full_Context => Prag_Nam = Name_Elaborate_All);
+ end Add_Pragma;
+
+ --------------
+ -- Add_Unit --
+ --------------
+
+ procedure Add_Unit
+ (Unit_Id : Entity_Id;
+ Prag : Node_Id;
+ Full_Context : Boolean)
+ is
+ Clause : Node_Id;
+ Elab_Attrs : Elaboration_Attributes;
+
+ begin
+ -- Nothing to do when some previous error left a with clause or a
+ -- pragma in a bad state.
+
+ if No (Unit_Id) then
+ return;
+ end if;
+
+ Elab_Attrs := Elaboration_Context.Get (Unit_Id);
+
+ -- The current unit is not part of the context. Prepare a new set of
+ -- attributes.
+
+ if Elab_Attrs = No_Elaboration_Attributes then
+ Elab_Attrs :=
+ Elaboration_Attributes'(Source_Pragma => Prag,
+ With_Clause => Empty);
+
+ -- 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);
+
+ -- Includes all units withed by the current one when computing the
+ -- full context.
+
+ if Full_Context then
+
+ -- Process all non-limited with clauses found in the context of
+ -- the current unit. Note that limited clauses do not impose an
+ -- elaboration order.
+
+ Clause := First (Context_Items (Compilation_Unit (Unit_Id)));
+ while Present (Clause) loop
+ if Nkind (Clause) = N_With_Clause
+ and then not Error_Posted (Clause)
+ and then not Limited_Present (Clause)
+ then
+ Add_Unit
+ (Unit_Id => Entity (Name (Clause)),
+ Prag => Prag,
+ Full_Context => Full_Context);
+ end if;
+
+ Next (Clause);
+ end loop;
+ end if;
+ end Add_Unit;
+
+ ------------------------------
+ -- Find_Elaboration_Context --
+ ------------------------------
+
+ procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is
+ Prag : Node_Id;
+
+ begin
+ pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit);
+
+ -- Process all elaboration-related pragmas found in the context of
+ -- the compilation unit.
+
+ Prag := First (Context_Items (Comp_Unit));
+ while Present (Prag) loop
+ if Nkind (Prag) = N_Pragma then
+ Add_Pragma (Prag);
+ end if;
+
+ Next (Prag);
+ end loop;
+ end Find_Elaboration_Context;
+
+ -- Local variables
+
+ Par_Id : Entity_Id;
+ Unt : Node_Id;
+
+ -- Start of processing for Find_Elaborated_Units
+
+ begin
+ -- Perform a traversal which examines the context of the main unit and
+ -- populates the Elaboration_Context table with all units elaborated
+ -- prior to the main unit. The traversal performs the following jumps:
+
+ -- subunit -> parent subunit
+ -- parent subunit -> body
+ -- body -> spec
+ -- spec -> parent spec
+ -- parent spec -> grandparent spec and so on
+
+ -- The traversal relies on units rather than scopes because the scope of
+ -- a subunit is some spec, while this traversal must process the body as
+ -- well. Given that protected and task bodies can also be subunits, this
+ -- complicates the scope approach even further.
+
+ Unt := Unit (Cunit (Main_Unit));
+
+ -- Perform the following traversals when the main unit is a subunit
+
+ -- subunit -> parent subunit
+ -- parent subunit -> body
+
+ while Present (Unt) and then Nkind (Unt) = N_Subunit loop
+ Find_Elaboration_Context (Parent (Unt));
+
+ -- Continue the traversal by going to the unit which contains the
+ -- corresponding stub.
+
+ if Present (Corresponding_Stub (Unt)) then
+ Unt := Unit (Cunit (Get_Source_Unit (Corresponding_Stub (Unt))));
+
+ -- Otherwise the subunit may be erroneous or left in a bad state
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ -- Perform the following traversal now that subunits have been taken
+ -- care of, or the main unit is a body.
+
+ -- body -> spec
+
+ if Present (Unt)
+ and then Nkind_In (Unt, N_Package_Body, N_Subprogram_Body)
+ then
+ Find_Elaboration_Context (Parent (Unt));
+
+ -- Continue the traversal by going to the unit which contains the
+ -- corresponding spec.
+
+ if Present (Corresponding_Spec (Unt)) then
+ Unt := Unit (Cunit (Get_Source_Unit (Corresponding_Spec (Unt))));
+ end if;
+ end if;
+
+ -- Perform the following traversals now that the body has been taken
+ -- care of, or the main unit is a spec.
+
+ -- spec -> parent spec
+ -- parent spec -> grandparent spec and so on
+
+ if Present (Unt)
+ and then Nkind_In (Unt, N_Generic_Package_Declaration,
+ N_Generic_Subprogram_Declaration,
+ N_Package_Declaration,
+ N_Subprogram_Declaration)
+ then
+ Find_Elaboration_Context (Parent (Unt));
+
+ -- Process a potential chain of parent units which ends with the
+ -- main unit spec. The traversal can now safely rely on the scope
+ -- chain.
+
+ Par_Id := Scope (Defining_Entity (Unt));
+ while Present (Par_Id) and then Par_Id /= Standard_Standard loop
+ Find_Elaboration_Context (Compilation_Unit (Par_Id));
+
+ Par_Id := Scope (Par_Id);
+ end loop;
+ end if;
+ end Find_Elaborated_Units;
+
+ -----------------------------
+ -- Find_Enclosing_Instance --
+ -----------------------------
+
+ function Find_Enclosing_Instance (N : Node_Id) return Node_Id is
+ Par : Node_Id;
+ Spec_Id : Entity_Id;
+
+ begin
+ -- Climb the parent chain looking for an enclosing instance spec or body
+
+ Par := N;
+ while Present (Par) loop
+
+ -- Generic package or subprogram spec
+
+ if Nkind_In (Par, N_Package_Declaration,
+ N_Subprogram_Declaration)
+ and then Is_Generic_Instance (Defining_Entity (Par))
+ then
+ return Par;
+
+ -- Generic package or subprogram body
+
+ elsif Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then
+ Spec_Id := Corresponding_Spec (Par);
+
+ if Present (Spec_Id) and then Is_Generic_Instance (Spec_Id) then
+ return Par;
+ end if;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ return Empty;
+ end Find_Enclosing_Instance;
+
+ --------------------------
+ -- Find_Enclosing_Level --
+ --------------------------
+
+ function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind is
+ function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind;
+ -- Obtain the corresponding level of unit Unit
+
+ --------------
+ -- Level_Of --
+ --------------
+
+ function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind is
+ Spec_Id : Entity_Id;
+
+ begin
+ if Nkind (Unit) in N_Generic_Instantiation then
+ return Instantiation;
+
+ elsif Nkind (Unit) = N_Generic_Package_Declaration then
+ return Generic_Package_Spec;
+
+ elsif Nkind (Unit) = N_Package_Declaration then
+ return Package_Spec;
+
+ elsif Nkind (Unit) = N_Package_Body then
+ Spec_Id := Corresponding_Spec (Unit);
+
+ -- The body belongs to a generic package
+
+ if Present (Spec_Id)
+ and then Ekind (Spec_Id) = E_Generic_Package
+ then
+ return Generic_Package_Body;
+
+ -- Otherwise the body belongs to a non-generic package. This also
+ -- treats an illegal package body without a corresponding spec as
+ -- a non-generic package body.
+
+ else
+ return Package_Body;
+ end if;
+ end if;
+
+ return No_Level;
+ end Level_Of;
+
+ -- Local variables
+
+ Context : Node_Id;
+ Curr : Node_Id;
+ Prev : Node_Id;
+
+ -- Start of processing for Find_Enclosing_Level
+
+ begin
+ -- Call markers and instantiations which appear at the declaration level
+ -- but are later relocated in a different context retain their original
+ -- declaration level.
+
+ if Nkind_In (N, N_Call_Marker,
+ N_Function_Instantiation,
+ N_Package_Instantiation,
+ N_Procedure_Instantiation)
+ and then Is_Declaration_Level_Node (N)
+ then
+ return Declaration_Level;
+ end if;
+
+ -- Climb the parent chain looking at the enclosing levels
+
+ Prev := N;
+ Curr := Parent (Prev);
+ while Present (Curr) loop
+
+ -- A traversal from a subunit continues via the corresponding stub
+
+ if Nkind (Curr) = N_Subunit then
+ Curr := Corresponding_Stub (Curr);
+
+ -- The current construct is a package. Packages are ignored because
+ -- they are always elaborated when the enclosing context is invoked
+ -- or elaborated.
+
+ elsif Nkind_In (Curr, N_Package_Body, N_Package_Declaration) then
+ null;
+
+ -- The current construct is a block statement
+
+ elsif Nkind (Curr) = N_Block_Statement then
+
+ -- Ignore internally generated blocks created by the expander for
+ -- various purposes such as abort defer/undefer.
+
+ if not Comes_From_Source (Curr) then
+ null;
+
+ -- If the traversal came from the handled sequence of statments,
+ -- then the node appears at the level of the enclosing construct.
+ -- This is a more reliable test because transients scopes within
+ -- the declarative region of the encapsulator are hard to detect.
+
+ elsif Nkind (Prev) = N_Handled_Sequence_Of_Statements
+ and then Handled_Statement_Sequence (Curr) = Prev
+ then
+ return Find_Enclosing_Level (Parent (Curr));
+
+ -- Otherwise the traversal came from the declarations, the node is
+ -- at the declaration level.
+
+ else
+ return Declaration_Level;
+ end if;
+
+ -- The current construct is a declaration level encapsulator
+
+ elsif Nkind_In (Curr, N_Entry_Body,
+ N_Subprogram_Body,
+ N_Task_Body)
+ then
+ -- If the traversal came from the handled sequence of statments,
+ -- then the node cannot possibly appear at any level. This is
+ -- a more reliable test because transients scopes within the
+ -- declarative region of the encapsulator are hard to detect.
+
+ if Nkind (Prev) = N_Handled_Sequence_Of_Statements
+ and then Handled_Statement_Sequence (Curr) = Prev
+ then
+ return No_Level;
+
+ -- Otherwise the traversal came from the declarations, the node is
+ -- at the declaration level.
+
+ else
+ return Declaration_Level;
+ end if;
+
+ -- The current construct is a non-library level encapsulator which
+ -- indicates that the node cannot possibly appear at any level.
+ -- Note that this check must come after the declaration level check
+ -- because both predicates share certain nodes.
+
+ elsif Is_Non_Library_Level_Encapsulator (Curr) then
+ Context := Parent (Curr);
+
+ -- The sole exception is when the encapsulator is the compilation
+ -- utit itself because the compilation unit node requires special
+ -- processing (see below).
+
+ if Present (Context)
+ and then Nkind (Context) = N_Compilation_Unit
+ then
+ null;
+
+ -- Otherwise the node is not at any level
+
+ else
+ return No_Level;
+ end if;
+
+ -- The current construct is a compilation unit. The node appears at
+ -- the [generic] library level when the unit is a [generic] package.
+
+ elsif Nkind (Curr) = N_Compilation_Unit then
+ return Level_Of (Unit (Curr));
+ end if;
+
+ Prev := Curr;
+ Curr := Parent (Prev);
+ end loop;
+
+ return No_Level;
+ end Find_Enclosing_Level;
+
+ -------------------
+ -- Find_Top_Unit --
+ -------------------
+
+ function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id is
+ N_Unit : constant Node_Id := Unit (Cunit (Get_Top_Level_Code_Unit (N)));
+
+ begin
+ return Defining_Entity (N_Unit, Concurrent_Subunit => True);
+ end Find_Top_Unit;
+
+ -----------------------
+ -- First_Formal_Type --
+ -----------------------
+
+ function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id is
+ Formal_Id : constant Entity_Id := First_Formal (Subp_Id);
+ Typ : Entity_Id;
+
+ begin
+ if Present (Formal_Id) then
+ Typ := Etype (Formal_Id);
+
+ -- Handle various combinations of concurrent and private types
+
+ loop
+ if Ekind_In (Typ, E_Protected_Type, E_Task_Type)
+ and then Present (Anonymous_Object (Typ))
+ then
+ Typ := Anonymous_Object (Typ);
+
+ elsif Is_Concurrent_Record_Type (Typ) then
+ Typ := Corresponding_Concurrent_Type (Typ);
+
+ elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
+ Typ := Full_View (Typ);
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ return Typ;
+ end if;
+
+ return Empty;
+ end First_Formal_Type;
+
+ --------------
+ -- Has_Body --
+ --------------
+
+ function Has_Body (Pack_Decl : Node_Id) return Boolean is
+ function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id;
+ -- Try to locate the corresponding body of spec Spec_Id. If no body is
+ -- found, return Empty.
+
+ function Find_Body
+ (Spec_Id : Entity_Id;
+ From : Node_Id) return Node_Id;
+ -- Try to locate the corresponding body of spec Spec_Id in the node list
+ -- which follows arbitrary node From. If no body is found, return Empty.
+
+ function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id;
+ -- Attempt to load the body of unit Unit_Nam. If the load failed, return
+ -- Empty. If the compilation will not generate code, return Empty.
+
+ -----------------------------
+ -- Find_Corresponding_Body --
+ -----------------------------
+
+ function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id is
+ Context : constant Entity_Id := Scope (Spec_Id);
+ Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
+ Body_Decl : Node_Id;
+ Body_Id : Entity_Id;
+
+ begin
+ if Is_Compilation_Unit (Spec_Id) then
+ Body_Id := Corresponding_Body (Spec_Decl);
+
+ if Present (Body_Id) then
+ return Unit_Declaration_Node (Body_Id);
+
+ -- The package is at the library and requires a body. Load the
+ -- corresponding body because the optional body may be declared
+ -- there.
+
+ elsif Unit_Requires_Body (Spec_Id) then
+ return
+ Load_Package_Body
+ (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec_Decl))));
+
+ -- Otherwise there is no optional body
+
+ else
+ return Empty;
+ end if;
+
+ -- The immediate context is a package. The optional body may be
+ -- within the body of that package.
+
+ -- procedure Proc is
+ -- package Nested_1 is
+ -- package Nested_2 is
+ -- generic
+ -- package Pack is
+ -- end Pack;
+ -- end Nested_2;
+ -- end Nested_1;
+
+ -- package body Nested_1 is
+ -- package body Nested_2 is separate;
+ -- end Nested_1;
+
+ -- separate (Proc.Nested_1.Nested_2)
+ -- package body Nested_2 is
+ -- package body Pack is -- optional body
+ -- ...
+ -- end Pack;
+ -- end Nested_2;
+
+ elsif Is_Package_Or_Generic_Package (Context) then
+ Body_Decl := Find_Corresponding_Body (Context);
+
+ -- The optional body is within the body of the enclosing package
+
+ if Present (Body_Decl) then
+ return
+ Find_Body
+ (Spec_Id => Spec_Id,
+ From => First (Declarations (Body_Decl)));
+
+ -- Otherwise the enclosing package does not have a body. This may
+ -- be the result of an error or a genuine lack of a body.
+
+ else
+ return Empty;
+ end if;
+
+ -- Otherwise the immediate context is a body. The optional body may
+ -- be within the same list as the spec.
+
+ -- procedure Proc is
+ -- generic
+ -- package Pack is
+ -- end Pack;
+
+ -- package body Pack is -- optional body
+ -- ...
+ -- end Pack;
+
+ else
+ return
+ Find_Body
+ (Spec_Id => Spec_Id,
+ From => Next (Spec_Decl));
+ end if;
+ end Find_Corresponding_Body;
+
+ ---------------
+ -- Find_Body --
+ ---------------
+
+ function Find_Body
+ (Spec_Id : Entity_Id;
+ From : Node_Id) return Node_Id
+ is
+ Spec_Nam : constant Name_Id := Chars (Spec_Id);
+ Item : Node_Id;
+ Lib_Unit : Node_Id;
+
+ begin
+ Item := From;
+ while Present (Item) loop
+
+ -- The current item denotes the optional body
+
+ if Nkind (Item) = N_Package_Body
+ and then Chars (Defining_Entity (Item)) = Spec_Nam
+ then
+ return Item;
+
+ -- The current item denotes a stub, the optional body may be in
+ -- the subunit.
+
+ elsif Nkind (Item) = N_Package_Body_Stub
+ and then Chars (Defining_Entity (Item)) = Spec_Nam
+ then
+ Lib_Unit := Library_Unit (Item);
+
+ -- The corresponding subunit was previously loaded
+
+ if Present (Lib_Unit) then
+ return Lib_Unit;
+
+ -- Otherwise attempt to load the corresponding subunit
+
+ else
+ return Load_Package_Body (Get_Unit_Name (Item));
+ end if;
+ end if;
+
+ Next (Item);
+ end loop;
+
+ return Empty;
+ end Find_Body;
+
+ -----------------------
+ -- Load_Package_Body --
+ -----------------------
+
+ function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id is
+ Body_Decl : Node_Id;
+ Unit_Num : Unit_Number_Type;
+
+ begin
+ -- The load is performed only when the compilation will generate code
+
+ if Operating_Mode = Generate_Code then
+ Unit_Num :=
+ Load_Unit
+ (Load_Name => Unit_Nam,
+ Required => False,
+ Subunit => False,
+ Error_Node => Pack_Decl);
+
+ -- The load failed most likely because the physical file is
+ -- missing.
+
+ if Unit_Num = No_Unit then
+ return Empty;
+
+ -- Otherwise the load was successful, return the body of the unit
+
+ else
+ Body_Decl := Unit (Cunit (Unit_Num));
+
+ -- If the unit is a subunit with an available proper body,
+ -- return the proper body.
+
+ if Nkind (Body_Decl) = N_Subunit
+ and then Present (Proper_Body (Body_Decl))
+ then
+ Body_Decl := Proper_Body (Body_Decl);
+ end if;
+
+ return Body_Decl;
+ end if;
+ end if;
+
+ return Empty;
+ end Load_Package_Body;
+
+ -- Local variables
+
+ Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
+
+ -- Start of processing for Has_Body
+
+ begin
+ -- The body is available
+
+ if Present (Corresponding_Body (Pack_Decl)) then
+ return True;
+
+ -- The body is required if the package spec contains a construct which
+ -- requires a completion in a body.
+
+ elsif Unit_Requires_Body (Pack_Id) then
+ return True;
+
+ -- The body may be optional
+
+ else
+ return Present (Find_Corresponding_Body (Pack_Id));
+ end if;
+ end Has_Body;
+
+ ---------------------------
+ -- Has_Prior_Elaboration --
+ ---------------------------
+
+ function Has_Prior_Elaboration
+ (Unit_Id : Entity_Id;
+ Context_OK : Boolean := False;
+ Elab_Body_OK : Boolean := False;
+ Same_Unit_OK : Boolean := False) return Boolean
+ is
+ Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit);
+
+ begin
+ -- A preelaborated unit is always elaborated prior to the main unit
+
+ if Is_Preelaborated_Unit (Unit_Id) then
+ return True;
+
+ -- An internal unit is always elaborated prior to a non-internal main
+ -- unit.
+
+ elsif In_Internal_Unit (Unit_Id)
+ and then not In_Internal_Unit (Main_Id)
+ then
+ return True;
+
+ -- A unit has prior elaboration if it appears within the context of the
+ -- main unit. Consider this case only when requested by the caller.
+
+ elsif Context_OK
+ and then Elaboration_Context.Get (Unit_Id) /= No_Elaboration_Attributes
+ then
+ return True;
+
+ -- A unit whose body is elaborated together with its spec has prior
+ -- elaboration except with respect to itself. Consider this case only
+ -- when requested by the caller.
+
+ elsif Elab_Body_OK
+ and then Has_Pragma_Elaborate_Body (Unit_Id)
+ and then not Is_Same_Unit (Unit_Id, Main_Id)
+ then
+ return True;
+
+ -- A unit has no prior elaboration with respect to itself, but does not
+ -- require any means of ensuring its own elaboration either. Treat this
+ -- case as valid prior elaboration only when requested by the caller.
+
+ elsif Same_Unit_OK and then Is_Same_Unit (Unit_Id, Main_Id) then
+ return True;
+ end if;
+
+ return False;
+ end Has_Prior_Elaboration;
+
+ --------------------------
+ -- In_External_Instance --
+ --------------------------
+
+ function In_External_Instance
+ (N : Node_Id;
+ Target_Decl : Node_Id) return Boolean
+ is
+ Dummy : Node_Id;
+ Inst_Body : Node_Id;
+ Inst_Decl : Node_Id;
+
+ begin
+ -- Performance note: parent traversal
+
+ Inst_Decl := Find_Enclosing_Instance (Target_Decl);
+
+ -- The target declaration appears within an instance spec. Visibility is
+ -- ignored because internally generated primitives for private types may
+ -- reside in the private declarations and still be invoked from outside.
+
+ if Present (Inst_Decl)
+ and then Nkind (Inst_Decl) = N_Package_Declaration
+ then
+ -- The scenario comes from the main unit and the instance does not
+
+ if In_Extended_Main_Code_Unit (N)
+ and then not In_Extended_Main_Code_Unit (Inst_Decl)
+ then
+ return True;
+
+ -- Otherwise the scenario must not appear within the instance spec or
+ -- body.
+
+ else
+ Extract_Instance_Attributes
+ (Exp_Inst => Inst_Decl,
+ Inst_Body => Inst_Body,
+ Inst_Decl => Dummy);
+
+ -- Performance note: parent traversal
+
+ return not In_Subtree
+ (N => N,
+ Root1 => Inst_Decl,
+ Root2 => Inst_Body);
+ end if;
+ end if;
+
+ return False;
+ end In_External_Instance;
+
+ ---------------------
+ -- In_Main_Context --
+ ---------------------
+
+ function In_Main_Context (N : Node_Id) return Boolean is
+ begin
+ -- Scenarios outside the main unit are not considered because the ALI
+ -- information supplied to binde is for the main unit only.
+
+ if not In_Extended_Main_Code_Unit (N) then
+ return False;
+
+ -- Scenarios within internal units are not considered unless switch
+ -- -gnatdE (elaboration checks on predefined units) is in effect.
+
+ elsif not Debug_Flag_EE and then In_Internal_Unit (N) then
+ return False;
+ end if;
+
+ return True;
+ end In_Main_Context;
+
+ ---------------------
+ -- In_Same_Context --
+ ---------------------
+
+ function In_Same_Context
+ (N1 : Node_Id;
+ N2 : Node_Id;
+ 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
+ -- node which which encapsulates arbitrary node N. Return Empty is no
+ -- such context is available.
+
+ function In_Nested_Context
+ (Outer : Node_Id;
+ Inner : Node_Id) return Boolean;
+ -- Determine whether arbitrary node Outer encapsulates arbitrary node
+ -- Inner.
+
+ ----------------------------
+ -- Find_Enclosing_Context --
+ ----------------------------
+
+ function Find_Enclosing_Context (N : Node_Id) return Node_Id is
+ Context : Node_Id;
+ Par : Node_Id;
+
+ begin
+ Par := Parent (N);
+ while Present (Par) loop
+
+ -- A traversal from a subunit continues via the corresponding stub
+
+ if Nkind (Par) = N_Subunit then
+ Par := Corresponding_Stub (Par);
+
+ -- Stop the traversal when the nearest enclosing non-library level
+ -- encapsulator has been reached.
+
+ elsif Is_Non_Library_Level_Encapsulator (Par) then
+ Context := Parent (Par);
+
+ -- The sole exception is when the encapsulator is the unit of
+ -- compilation because this case requires special processing
+ -- (see below).
+
+ if Present (Context)
+ and then Nkind (Context) = N_Compilation_Unit
+ then
+ null;
+
+ else
+ return Par;
+ end if;
+
+ -- 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.
+
+ elsif Nkind (Par) = N_Compilation_Unit then
+ return Par;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ return Empty;
+ end Find_Enclosing_Context;
+
+ -----------------------
+ -- In_Nested_Context --
+ -----------------------
+
+ function In_Nested_Context
+ (Outer : Node_Id;
+ Inner : Node_Id) return Boolean
+ is
+ Par : Node_Id;
+
+ begin
+ Par := Inner;
+ while Present (Par) loop
+
+ -- A traversal from a subunit continues via the corresponding stub
+
+ if Nkind (Par) = N_Subunit then
+ Par := Corresponding_Stub (Par);
+
+ elsif Par = Outer then
+ return True;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ return False;
+ end In_Nested_Context;
+
+ -- Local variables
+
+ Context_1 : constant Node_Id := Find_Enclosing_Context (N1);
+ Context_2 : constant Node_Id := Find_Enclosing_Context (N2);
+
+ -- Start of processing for In_Same_Context
+
+ begin
+ -- Both nodes appear within the same context
+
+ if Context_1 = Context_2 then
+ return True;
+
+ -- Both nodes appear in compilation units. Determine whether one unit
+ -- is the body of the other.
+
+ elsif Nkind (Context_1) = N_Compilation_Unit
+ and then Nkind (Context_2) = N_Compilation_Unit
+ then
+ return
+ Is_Same_Unit
+ (Unit_1 => Defining_Entity (Unit (Context_1)),
+ Unit_2 => Defining_Entity (Unit (Context_2)));
+
+ -- The context of N1 encloses the context of N2
+
+ elsif Nested_OK and then In_Nested_Context (Context_1, Context_2) then
+ return True;
+ end if;
+
+ return False;
+ end In_Same_Context;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ -- Set the soft link which enables Atree.Rewrite to update a top level
+ -- scenario each time it is transformed into another node.
+
+ Set_Rewriting_Proc (Update_Elaboration_Scenario'Access);
+ end Initialize;
+
+ ---------------
+ -- Info_Call --
+ ---------------
+
+ procedure Info_Call
+ (Call : Node_Id;
+ Target_Id : Entity_Id;
+ Info_Msg : Boolean;
+ In_SPARK : Boolean)
+ is
+ procedure Info_Accept_Alternative;
+ pragma Inline (Info_Accept_Alternative);
+ -- Output information concerning an accept alternative
+
+ procedure Info_Simple_Call;
+ pragma Inline (Info_Simple_Call);
+ -- Output information concerning the call
+
+ procedure Info_Type_Actions (Action : String);
+ pragma Inline (Info_Type_Actions);
+ -- Output information concerning action Action of a type
+
+ procedure Info_Verification_Call
+ (Pred : String;
+ Id : Entity_Id;
+ Id_Kind : String);
+ pragma Inline (Info_Verification_Call);
+ -- Output information concerning the verification of predicate Pred
+ -- applied to related entity Id with kind Id_Kind.
+
+ -----------------------------
+ -- Info_Accept_Alternative --
+ -----------------------------
+
+ procedure Info_Accept_Alternative is
+ Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id);
+
+ begin
+ pragma Assert (Present (Entry_Id));
+
+ Elab_Msg_NE
+ (Msg => "accept for entry & during elaboration",
+ N => Call,
+ Id => Entry_Id,
+ Info_Msg => Info_Msg,
+ In_SPARK => In_SPARK);
+ end Info_Accept_Alternative;
+
+ ----------------------
+ -- Info_Simple_Call --
+ ----------------------
+
+ procedure Info_Simple_Call is
+ begin
+ Elab_Msg_NE
+ (Msg => "call to & during elaboration",
+ N => Call,
+ Id => Target_Id,
+ Info_Msg => Info_Msg,
+ In_SPARK => In_SPARK);
+ end Info_Simple_Call;
+
+ -----------------------
+ -- Info_Type_Actions --
+ -----------------------
+
+ procedure Info_Type_Actions (Action : String) is
+ Typ : constant Entity_Id := First_Formal_Type (Target_Id);
+
+ begin
+ pragma Assert (Present (Typ));
+
+ Elab_Msg_NE
+ (Msg => Action & " actions for type & during elaboration",
+ N => Call,
+ Id => Typ,
+ Info_Msg => Info_Msg,
+ In_SPARK => In_SPARK);
+ end Info_Type_Actions;
+
+ ----------------------------
+ -- Info_Verification_Call --
+ ----------------------------
+
+ procedure Info_Verification_Call
+ (Pred : String;
+ Id : Entity_Id;
+ Id_Kind : String)
+ is
+ begin
+ pragma Assert (Present (Id));
+
+ Elab_Msg_NE
+ (Msg =>
+ "verification of " & Pred & " of " & Id_Kind & " & during "
+ & "elaboration",
+ N => Call,
+ Id => Id,
+ Info_Msg => Info_Msg,
+ In_SPARK => In_SPARK);
+ end Info_Verification_Call;
+
+ -- Start of processing for Info_Call
+
+ begin
+ -- Do not output anything for targets defined in internal units because
+ -- this creates noise.
+
+ if not In_Internal_Unit (Target_Id) then
+
+ -- Accept alternative
+
+ if Is_Accept_Alternative_Proc (Target_Id) then
+ Info_Accept_Alternative;
+
+ -- Adjustment
+
+ elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then
+ Info_Type_Actions ("adjustment");
+
+ -- Default_Initial_Condition
+
+ elsif Is_Default_Initial_Condition_Proc (Target_Id) then
+ Info_Verification_Call
+ (Pred => "Default_Initial_Condition",
+ Id => First_Formal_Type (Target_Id),
+ Id_Kind => "type");
+
+ -- Entries
+
+ elsif Is_Protected_Entry (Target_Id) then
+ Info_Simple_Call;
+
+ -- Task entry calls are never processed because the entry being
+ -- invoked does not have a corresponding "body", it has a select.
+
+ elsif Is_Task_Entry (Target_Id) then
+ null;
+
+ -- Finalization
+
+ elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then
+ Info_Type_Actions ("finalization");
+
+ -- Calls to _Finalizer procedures must not appear in the output
+ -- because this creates confusing noise.
+
+ elsif Is_Finalizer_Proc (Target_Id) then
+ null;
+
+ -- Initial_Condition
+
+ elsif Is_Initial_Condition_Proc (Target_Id) then
+ Info_Verification_Call
+ (Pred => "Initial_Condition",
+ Id => Find_Enclosing_Scope (Call),
+ Id_Kind => "package");
+
+ -- Initialization
+
+ elsif Is_Init_Proc (Target_Id)
+ or else Is_TSS (Target_Id, TSS_Deep_Initialize)
+ then
+ Info_Type_Actions ("initialization");
+
+ -- Invariant
+
+ elsif Is_Invariant_Proc (Target_Id) then
+ Info_Verification_Call
+ (Pred => "invariants",
+ Id => First_Formal_Type (Target_Id),
+ Id_Kind => "type");
+
+ -- Partial invariant calls must not appear in the output because this
+ -- creates confusing noise.
+
+ elsif Is_Partial_Invariant_Proc (Target_Id) then
+ null;
+
+ -- _Postconditions
+
+ elsif Is_Postconditions_Proc (Target_Id) then
+ Info_Verification_Call
+ (Pred => "postconditions",
+ Id => Find_Enclosing_Scope (Call),
+ Id_Kind => "subprogram");
+
+ -- Subprograms must come last because some of the previous cases fall
+ -- under this category.
+
+ elsif Ekind (Target_Id) = E_Function then
+ Info_Simple_Call;
+
+ elsif Ekind (Target_Id) = E_Procedure then
+ Info_Simple_Call;
+
+ else
+ pragma Assert (False);
+ null;
+ end if;
+ end if;
+ end Info_Call;
+
+ ------------------------
+ -- Info_Instantiation --
+ ------------------------
+
+ procedure Info_Instantiation
+ (Inst : Node_Id;
+ Gen_Id : Entity_Id;
+ Info_Msg : Boolean;
+ In_SPARK : Boolean)
+ is
+ begin
+ Elab_Msg_NE
+ (Msg => "instantiation of & during elaboration",
+ N => Inst,
+ Id => Gen_Id,
+ Info_Msg => Info_Msg,
+ In_SPARK => In_SPARK);
+ end Info_Instantiation;
+
+ -----------------------------
+ -- Info_Variable_Reference --
+ -----------------------------
+
+ procedure Info_Variable_Reference
+ (Ref : Node_Id;
+ Var_Id : Entity_Id;
+ Info_Msg : Boolean;
+ In_SPARK : Boolean)
+ is
+ begin
+ Elab_Msg_NE
+ (Msg => "reference to variable & during elaboration",
+ N => Ref,
+ Id => Var_Id,
+ Info_Msg => Info_Msg,
+ In_SPARK => In_SPARK);
+ end Info_Variable_Reference;
+
+ --------------------
+ -- Insertion_Node --
+ --------------------
+
+ function Insertion_Node (N : Node_Id; Ins_Nod : Node_Id) return Node_Id is
+ begin
+ -- When the scenario denotes an instantiation, the proper insertion node
+ -- is the instance spec. This ensures that the generic actuals will not
+ -- be evaluated prior to a potential ABE.
+
+ if Nkind (N) in N_Generic_Instantiation
+ and then Present (Instance_Spec (N))
+ then
+ return Instance_Spec (N);
+
+ -- Otherwise the proper insertion node is the candidate insertion node
+
+ else
+ return Ins_Nod;
+ end if;
+ end Insertion_Node;
+
+ -----------------------
+ -- Install_ABE_Check --
+ -----------------------
+
+ procedure Install_ABE_Check
+ (N : Node_Id;
+ Id : Entity_Id;
+ Ins_Nod : Node_Id)
+ is
+ Check_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod);
+ -- Insert the check prior to this node
+
+ Loc : constant Source_Ptr := Sloc (N);
+ Spec_Id : constant Entity_Id := Unique_Entity (Id);
+ Unit_Id : constant Entity_Id := Find_Top_Unit (Id);
+ Scop_Id : Entity_Id;
+
+ begin
+ -- Nothing to do when the compilation will not produce an executable
+
+ if Serious_Errors_Detected > 0 then
+ return;
+
+ -- Nothing to do for a compilation unit because there is no executable
+ -- environment at that level.
+
+ elsif Nkind (Parent (Check_Ins_Nod)) = N_Compilation_Unit then
+ return;
+
+ -- Nothing to do when the unit is elaborated prior to the main unit.
+ -- This check must also consider the following cases:
+
+ -- * Id's unit appears in the context of the main unit
+
+ -- * Id's unit is subject to pragma Elaborate_Body. An ABE check MUST
+ -- NOT be generated because Id's unit is always elaborated prior to
+ -- the main unit.
+
+ -- * Id's unit is the main unit. An ABE check MUST be generated in this
+ -- case because a conditional ABE may be raised depending on the flow
+ -- of execution within the main unit (flag Same_Unit_OK is False).
+
+ elsif Has_Prior_Elaboration
+ (Unit_Id => Unit_Id,
+ Context_OK => True,
+ Elab_Body_OK => True)
+ then
+ return;
+ end if;
+
+ -- Prevent multiple scenarios from installing the same ABE check
+
+ Set_Is_Elaboration_Checks_OK_Node (N, False);
+
+ -- Install the nearest enclosing scope of the scenario as there must be
+ -- something on the scope stack.
+
+ -- Performance note: parent traversal
+
+ Scop_Id := Find_Enclosing_Scope (Check_Ins_Nod);
+ pragma Assert (Present (Scop_Id));
+
+ Push_Scope (Scop_Id);
+
+ -- Generate:
+ -- if not Spec_Id'Elaborated then
+ -- raise Program_Error with "access before elaboration";
+ -- end if;
+
+ Insert_Action (Check_Ins_Nod,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Spec_Id, Loc),
+ Attribute_Name => Name_Elaborated)),
+ Reason => PE_Access_Before_Elaboration));
+
+ Pop_Scope;
+ end Install_ABE_Check;
+
+ -----------------------
+ -- Install_ABE_Check --
+ -----------------------
+
+ procedure Install_ABE_Check
+ (N : Node_Id;
+ Target_Id : Entity_Id;
+ Target_Decl : Node_Id;
+ Target_Body : Node_Id;
+ Ins_Nod : Node_Id)
+ is
+ procedure Build_Elaboration_Entity;
+ pragma Inline (Build_Elaboration_Entity);
+ -- Create a new elaboration flag for Target_Id, insert it prior to
+ -- Target_Decl, and set it after Body_Decl.
+
+ ------------------------------
+ -- Build_Elaboration_Entity --
+ ------------------------------
+
+ procedure Build_Elaboration_Entity is
+ Loc : constant Source_Ptr := Sloc (Target_Id);
+ Flag_Id : Entity_Id;
+
+ begin
+ -- Create the declaration of the elaboration flag. The name carries a
+ -- unique counter in case of name overloading.
+
+ Flag_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Target_Id), 'E', -1));
+
+ Set_Elaboration_Entity (Target_Id, Flag_Id);
+ Set_Elaboration_Entity_Required (Target_Id);
+
+ Push_Scope (Scope (Target_Id));
+
+ -- Generate:
+ -- Enn : Short_Integer := 0;
+
+ Insert_Action (Target_Decl,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Flag_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Short_Integer, Loc),
+ Expression => Make_Integer_Literal (Loc, Uint_0)));
+
+ -- Generate:
+ -- Enn := 1;
+
+ Set_Elaboration_Flag (Target_Body, Target_Id);
+
+ Pop_Scope;
+ end Build_Elaboration_Entity;
+
+ -- Local variables
+
+ Target_Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id);
+
+ -- Start for processing for Install_ABE_Check
+
+ begin
+ -- Nothing to do when the compilation will not produce an executable
+
+ if Serious_Errors_Detected > 0 then
+ return;
+
+ -- Nothing to do when the target is a protected subprogram because the
+ -- check is associated with the protected body subprogram.
+
+ elsif Is_Protected_Subp (Target_Id) then
+ return;
+
+ -- Nothing to do when the target is elaborated prior to the main unit.
+ -- This check must also consider the following cases:
+
+ -- * The unit of the target appears in the context of the main unit
+
+ -- * The unit of the target is subject to pragma Elaborate_Body. An ABE
+ -- check MUST NOT be generated because the unit is always elaborated
+ -- prior to the main unit.
+
+ -- * The unit of the target is the main unit. An ABE check MUST be added
+ -- in this case because a conditional ABE may be raised depending on
+ -- the flow of execution within the main unit (flag Same_Unit_OK is
+ -- False).
+
+ elsif Has_Prior_Elaboration
+ (Unit_Id => Target_Unit_Id,
+ Context_OK => True,
+ Elab_Body_OK => True)
+ then
+ return;
+
+ -- Create an elaboration flag for the target when it does not have one
+
+ elsif No (Elaboration_Entity (Target_Id)) then
+ Build_Elaboration_Entity;
+ end if;
+
+ Install_ABE_Check
+ (N => N,
+ Ins_Nod => Ins_Nod,
+ Id => Target_Id);
+ end Install_ABE_Check;
+
+ -------------------------
+ -- Install_ABE_Failure --
+ -------------------------
+
+ procedure Install_ABE_Failure (N : Node_Id; Ins_Nod : Node_Id) is
+ Fail_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod);
+ -- Insert the failure prior to this node
+
+ Loc : constant Source_Ptr := Sloc (N);
+ Scop_Id : Entity_Id;
+
+ begin
+ -- Nothing to do when the compilation will not produce an executable
+
+ if Serious_Errors_Detected > 0 then
+ return;
+
+ -- Do not install an ABE check for a compilation unit because there is
+ -- no executable environment at that level.
+
+ elsif Nkind (Parent (Fail_Ins_Nod)) = N_Compilation_Unit then
+ return;
+ end if;
+
+ -- Prevent multiple scenarios from installing the same ABE failure
+
+ Set_Is_Elaboration_Checks_OK_Node (N, False);
+
+ -- Install the nearest enclosing scope of the scenario as there must be
+ -- something on the scope stack.
+
+ -- Performance note: parent traversal
+
+ Scop_Id := Find_Enclosing_Scope (Fail_Ins_Nod);
+ pragma Assert (Present (Scop_Id));
+
+ Push_Scope (Scop_Id);
+
+ -- Generate:
+ -- raise Program_Error with "access before elaboration";
+
+ Insert_Action (Fail_Ins_Nod,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Access_Before_Elaboration));
+
+ Pop_Scope;
+ end Install_ABE_Failure;
+
+ --------------------------------
+ -- Is_Accept_Alternative_Proc --
+ --------------------------------
+
+ function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is
+ begin
+ -- To qualify, the entity must denote a procedure with a receiving entry
+
+ return Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id));
+ end Is_Accept_Alternative_Proc;
+
+ ------------------------
+ -- Is_Activation_Proc --
+ ------------------------
+
+ function Is_Activation_Proc (Id : Entity_Id) return Boolean is
+ begin
+ -- To qualify, the entity must denote one of the runtime procedures in
+ -- charge of task activation.
+
+ if Ekind (Id) = E_Procedure then
+ if Restricted_Profile then
+ return Is_RTE (Id, RE_Activate_Restricted_Tasks);
+ else
+ return Is_RTE (Id, RE_Activate_Tasks);
+ end if;
+ end if;
+
+ return False;
+ end Is_Activation_Proc;
+
+ ----------------------------
+ -- Is_Ada_Semantic_Target --
+ ----------------------------
+
+ function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean is
+ begin
+ return
+ Is_Activation_Proc (Id)
+ or else Is_Controlled_Proc (Id, Name_Adjust)
+ or else Is_Controlled_Proc (Id, Name_Finalize)
+ or else Is_Controlled_Proc (Id, Name_Initialize)
+ or else Is_Init_Proc (Id)
+ or else Is_Invariant_Proc (Id)
+ or else Is_Protected_Entry (Id)
+ or else Is_Protected_Subp (Id)
+ or else Is_Protected_Body_Subp (Id)
+ or else Is_Task_Entry (Id);
+ end Is_Ada_Semantic_Target;
+
+ ----------------------------
+ -- Is_Bodiless_Subprogram --
+ ----------------------------
+
+ function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is
+ begin
+ -- An abstract subprogram does not have a body
+
+ if Ekind_In (Subp_Id, E_Function,
+ E_Operator,
+ E_Procedure)
+ and then Is_Abstract_Subprogram (Subp_Id)
+ then
+ return True;
+
+ -- A formal subprogram does not have a body
+
+ elsif Is_Formal_Subprogram (Subp_Id) then
+ return True;
+
+ -- An imported subprogram may have a body, however it is not known at
+ -- compile or bind time where the body resides and whether it will be
+ -- elaborated on time.
+
+ elsif Is_Imported (Subp_Id) then
+ return True;
+ end if;
+
+ 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 --
+ ------------------------
+
+ function Is_Controlled_Proc
+ (Subp_Id : Entity_Id;
+ Subp_Nam : Name_Id) return Boolean
+ is
+ Formal_Id : Entity_Id;
+
+ begin
+ pragma Assert (Nam_In (Subp_Nam, Name_Adjust,
+ Name_Finalize,
+ Name_Initialize));
+
+ -- To qualify, the subprogram must denote a source procedure with name
+ -- Adjust, Finalize, or Initialize where the sole formal is controlled.
+
+ if Comes_From_Source (Subp_Id)
+ and then Ekind (Subp_Id) = E_Procedure
+ and then Chars (Subp_Id) = Subp_Nam
+ then
+ Formal_Id := First_Formal (Subp_Id);
+
+ return
+ Present (Formal_Id)
+ and then Is_Controlled (Etype (Formal_Id))
+ and then No (Next_Formal (Formal_Id));
+ end if;
+
+ return False;
+ end Is_Controlled_Proc;
+
+ ---------------------------------------
+ -- Is_Default_Initial_Condition_Proc --
+ ---------------------------------------
+
+ function Is_Default_Initial_Condition_Proc
+ (Id : Entity_Id) return Boolean
+ is
+ begin
+ -- To qualify, the entity must denote a Default_Initial_Condition
+ -- procedure.
+
+ return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id);
+ end Is_Default_Initial_Condition_Proc;
+
+ -----------------------
+ -- Is_Finalizer_Proc --
+ -----------------------
+
+ function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is
+ begin
+ -- To qualify, the entity must denote a _Finalizer procedure
+
+ return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer;
+ end Is_Finalizer_Proc;
+
+ -----------------------
+ -- Is_Guaranteed_ABE --
+ -----------------------
+
+ function Is_Guaranteed_ABE
+ (N : Node_Id;
+ Target_Decl : Node_Id;
+ Target_Body : Node_Id) return Boolean
+ is
+ begin
+ -- Avoid cascaded errors if there were previous serious infractions.
+ -- As a result the scenario will not be treated as a guaranteed ABE.
+ -- This behaviour parallels that of the old ABE mechanism.
+
+ if Serious_Errors_Detected > 0 then
+ return False;
+
+ -- The scenario and the target appear within the same context ignoring
+ -- enclosing library levels.
+
+ -- Performance note: parent traversal
+
+ elsif In_Same_Context (N, Target_Decl) then
+
+ -- The target body has already been encountered. The scenario results
+ -- in a guaranteed ABE if it appears prior to the body.
+
+ if Present (Target_Body) then
+ return Earlier_In_Extended_Unit (N, Target_Body);
+
+ -- Otherwise the body has not been encountered yet. The scenario is
+ -- a guaranteed ABE since the body will appear later. It is assumed
+ -- that the caller has already checked whether the scenario is ABE-
+ -- safe as optional bodies are not considered here.
+
+ else
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_Guaranteed_ABE;
+
+ -------------------------------
+ -- Is_Initial_Condition_Proc --
+ -------------------------------
+
+ function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is
+ begin
+ -- To qualify, the entity must denote an Initial_Condition procedure
+
+ return
+ Ekind (Id) = E_Procedure and then Is_Initial_Condition_Procedure (Id);
+ end Is_Initial_Condition_Proc;
+
+ -----------------------
+ -- Is_Invariant_Proc --
+ -----------------------
+
+ function Is_Invariant_Proc (Id : Entity_Id) return Boolean is
+ begin
+ -- To qualify, the entity must denote the "full" invariant procedure
+
+ return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id);
+ end Is_Invariant_Proc;
+
+ ---------------------------------------
+ -- Is_Non_Library_Level_Encapsulator --
+ ---------------------------------------
+
+ function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean is
+ begin
+ case Nkind (N) is
+ when N_Abstract_Subprogram_Declaration
+ | N_Aspect_Specification
+ | N_Component_Declaration
+ | N_Entry_Body
+ | N_Entry_Declaration
+ | N_Expression_Function
+ | N_Formal_Abstract_Subprogram_Declaration
+ | N_Formal_Concrete_Subprogram_Declaration
+ | N_Formal_Object_Declaration
+ | N_Formal_Package_Declaration
+ | N_Formal_Type_Declaration
+ | N_Generic_Association
+ | N_Implicit_Label_Declaration
+ | N_Incomplete_Type_Declaration
+ | N_Private_Extension_Declaration
+ | N_Private_Type_Declaration
+ | N_Protected_Body
+ | N_Protected_Type_Declaration
+ | N_Single_Protected_Declaration
+ | N_Single_Task_Declaration
+ | N_Subprogram_Body
+ | N_Subprogram_Declaration
+ | N_Task_Body
+ | N_Task_Type_Declaration
+ =>
+ return True;
+
+ when others =>
+ return Is_Generic_Declaration_Or_Body (N);
+ end case;
+ end Is_Non_Library_Level_Encapsulator;
+
+ -------------------------------
+ -- Is_Partial_Invariant_Proc --
+ -------------------------------
+
+ function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is
+ begin
+ -- To qualify, the entity must denote the "partial" invariant procedure
+
+ return
+ Ekind (Id) = E_Procedure and then Is_Partial_Invariant_Procedure (Id);
+ end Is_Partial_Invariant_Proc;
+
+ ----------------------------
+ -- Is_Postconditions_Proc --
+ ----------------------------
+
+ function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is
+ begin
+ -- To qualify, the entity must denote a _Postconditions procedure
+
+ return
+ Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions;
+ end Is_Postconditions_Proc;
+
+ ---------------------------
+ -- Is_Preelaborated_Unit --
+ ---------------------------
+
+ function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean is
+ begin
+ return
+ Is_Preelaborated (Id)
+ or else Is_Pure (Id)
+ or else Is_Remote_Call_Interface (Id)
+ or else Is_Remote_Types (Id)
+ or else Is_Shared_Passive (Id);
+ end Is_Preelaborated_Unit;
+
+ ------------------------
+ -- Is_Protected_Entry --
+ ------------------------
+
+ function Is_Protected_Entry (Id : Entity_Id) return Boolean is
+ begin
+ -- To qualify, the entity must denote an entry defined in a protected
+ -- type.
+
+ return
+ Is_Entry (Id)
+ and then Is_Protected_Type (Non_Private_View (Scope (Id)));
+ end Is_Protected_Entry;
+
+ -----------------------
+ -- Is_Protected_Subp --
+ -----------------------
+
+ function Is_Protected_Subp (Id : Entity_Id) return Boolean is
+ begin
+ -- To qualify, the entity must denote a subprogram defined within a
+ -- protected type.
+
+ return
+ Ekind_In (Id, E_Function, E_Procedure)
+ and then Is_Protected_Type (Non_Private_View (Scope (Id)));
+ end Is_Protected_Subp;
+
+ ----------------------------
+ -- Is_Protected_Body_Subp --
+ ----------------------------
+
+ function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean is
+ begin
+ -- To qualify, the entity must denote a subprogram with attribute
+ -- Protected_Subprogram set.
+
+ return
+ Ekind_In (Id, E_Function, E_Procedure)
+ and then Present (Protected_Subprogram (Id));
+ end Is_Protected_Body_Subp;
+
+ ------------------------
+ -- Is_Safe_Activation --
+ ------------------------
+
+ function Is_Safe_Activation
+ (Call : Node_Id;
+ Task_Decl : Node_Id) return Boolean
+ is
+ begin
+ -- The activation of a task coming from an external instance cannot
+ -- cause an ABE because the generic was already instantiated. Note
+ -- that the instantiation itself may lead to an ABE.
+
+ return
+ In_External_Instance
+ (N => Call,
+ Target_Decl => Task_Decl);
+ end Is_Safe_Activation;
+
+ ------------------
+ -- Is_Safe_Call --
+ ------------------
+
+ function Is_Safe_Call
+ (Call : Node_Id;
+ Target_Attrs : Target_Attributes) return Boolean
+ is
+ begin
+ -- The target is either an abstract subprogram, formal subprogram, or
+ -- imported, in which case it does not have a body at compile or bind
+ -- time. Assume that the call is ABE-safe.
+
+ if Is_Bodiless_Subprogram (Target_Attrs.Spec_Id) then
+ return True;
+
+ -- The target is an instantiation of a generic subprogram. The call
+ -- cannot cause an ABE because the generic was already instantiated.
+ -- Note that the instantiation itself may lead to an ABE.
+
+ elsif Is_Generic_Instance (Target_Attrs.Spec_Id) then
+ return True;
+
+ -- The invocation of a target coming from an external instance cannot
+ -- cause an ABE because the generic was already instantiated. Note that
+ -- the instantiation itself may lead to an ABE.
+
+ elsif In_External_Instance
+ (N => Call,
+ Target_Decl => Target_Attrs.Spec_Decl)
+ then
+ return True;
+
+ -- The target is a subprogram body without a previous declaration. The
+ -- call cannot cause an ABE because the body has already been seen.
+
+ elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body
+ and then No (Corresponding_Spec (Target_Attrs.Spec_Decl))
+ then
+ return True;
+
+ -- The target is a subprogram body stub without a prior declaration.
+ -- The call cannot cause an ABE because the proper body substitutes
+ -- the stub.
+
+ elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body_Stub
+ and then No (Corresponding_Spec_Of_Stub (Target_Attrs.Spec_Decl))
+ then
+ return True;
+
+ -- Subprogram bodies which wrap attribute references used as actuals
+ -- in instantiations are always ABE-safe. These bodies are artifacts
+ -- of expansion.
+
+ elsif Present (Target_Attrs.Body_Decl)
+ and then Nkind (Target_Attrs.Body_Decl) = N_Subprogram_Body
+ and then Was_Attribute_Reference (Target_Attrs.Body_Decl)
+ then
+ return True;
+ end if;
+
+ return False;
+ end Is_Safe_Call;
+
+ ---------------------------
+ -- Is_Safe_Instantiation --
+ ---------------------------
+
+ function Is_Safe_Instantiation
+ (Inst : Node_Id;
+ Gen_Attrs : Target_Attributes) return Boolean
+ is
+ begin
+ -- The generic is an intrinsic subprogram in which case it does not
+ -- have a body at compile or bind time. Assume that the instantiation
+ -- is ABE-safe.
+
+ if Is_Bodiless_Subprogram (Gen_Attrs.Spec_Id) then
+ return True;
+
+ -- The instantiation of an external nested generic cannot cause an ABE
+ -- if the outer generic was already instantiated. Note that the instance
+ -- of the outer generic may lead to an ABE.
+
+ elsif In_External_Instance
+ (N => Inst,
+ Target_Decl => Gen_Attrs.Spec_Decl)
+ then
+ return True;
+
+ -- The generic is a package. The instantiation cannot cause an ABE when
+ -- the package has no body.
+
+ elsif Ekind (Gen_Attrs.Spec_Id) = E_Generic_Package
+ and then not Has_Body (Gen_Attrs.Spec_Decl)
+ then
+ return True;
+ end if;
+
+ return False;
+ end Is_Safe_Instantiation;
+
+ ------------------
+ -- Is_Same_Unit --
+ ------------------
+
+ function Is_Same_Unit
+ (Unit_1 : Entity_Id;
+ Unit_2 : Entity_Id) return Boolean
+ is
+ function Is_Subunit (Unit_Id : Entity_Id) return Boolean;
+ pragma Inline (Is_Subunit);
+ -- Determine whether unit Unit_Id is a subunit
+
+ function Normalize_Unit (Unit_Id : Entity_Id) return Entity_Id;
+ -- Strip a potential subunit chain ending with unit Unit_Id and return
+ -- the corresponding spec.
+
+ ----------------
+ -- Is_Subunit --
+ ----------------
+
+ function Is_Subunit (Unit_Id : Entity_Id) return Boolean is
+ begin
+ return Nkind (Parent (Unit_Declaration_Node (Unit_Id))) = N_Subunit;
+ end Is_Subunit;
+
+ --------------------
+ -- Normalize_Unit --
+ --------------------
+
+ function Normalize_Unit (Unit_Id : Entity_Id) return Entity_Id is
+ Result : Entity_Id;
+
+ begin
+ -- Eliminate a potential chain of subunits to reach to proper body
+
+ 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);
+ end Is_Same_Unit;
+
+ -----------------
+ -- Is_Scenario --
+ -----------------
- type Elab_Call_Element is record
- Cloc : Source_Ptr;
- Ent : Entity_Id;
- end record;
+ function Is_Scenario (N : Node_Id) return Boolean is
+ begin
+ case Nkind (N) is
+ when N_Assignment_Statement
+ | N_Attribute_Reference
+ | N_Call_Marker
+ | N_Entry_Call_Statement
+ | N_Expanded_Name
+ | N_Function_Call
+ | N_Function_Instantiation
+ | N_Identifier
+ | N_Package_Instantiation
+ | N_Procedure_Call_Statement
+ | N_Procedure_Instantiation
+ | N_Requeue_Statement
+ =>
+ return True;
- 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");
+ when others =>
+ return False;
+ end case;
+ end Is_Scenario;
- -- 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:
+ ------------------------------
+ -- Is_SPARK_Semantic_Target --
+ ------------------------------
- -- 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;
+ function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean is
+ begin
+ return
+ Is_Default_Initial_Condition_Proc (Id)
+ or else Is_Initial_Condition_Proc (Id);
+ end Is_SPARK_Semantic_Target;
- -- Call; -- requires a check, different context
+ ------------------------
+ -- Is_Suitable_Access --
+ ------------------------
- type Visited_Element is record
+ function Is_Suitable_Access (N : Node_Id) return Boolean is
+ Nam : Name_Id;
+ Pref : Node_Id;
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");
+ begin
+ if Nkind (N) /= N_Attribute_Reference then
+ return False;
- -- The following table records delayed calls which must be examined after
- -- all generic bodies have been instantiated.
+ -- Internally-generated attributes are assumed to be ABE safe
- 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).
+ elsif not Comes_From_Source (N) then
+ return False;
+ end if;
- E : Entity_Id;
- -- The parameter E from the call to Check_Internal_Call
+ Nam := Attribute_Name (N);
+ Pref := Prefix (N);
- Orig_Ent : Entity_Id;
- -- The parameter Orig_Ent from the call to Check_Internal_Call
+ -- Sanitize the prefix of the attribute
- 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.
+ if not Is_Entity_Name (Pref) then
+ return False;
- Outer_Scope : Entity_Id;
- -- Save scope of outer level call
+ elsif No (Entity (Pref)) then
+ return False;
+ end if;
- From_Elab_Code : Boolean;
- -- Save indication of whether this call is from elaboration code
+ Subp_Id := Entity (Pref);
- 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.
+ if not Is_Subprogram_Or_Entry (Subp_Id) then
+ return False;
+ end if;
- From_SPARK_Code : Boolean;
- -- Save indication of whether this call is under SPARK_Mode => On
- end record;
+ -- Traverse a possible chain of renamings to obtain the original entry
+ -- or subprogram which the prefix may rename.
- 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.
+ Subp_Id := Get_Renamed_Entity (Subp_Id);
- -----------------------
- -- Local Subprograms --
- -----------------------
+ -- To qualify, the attribute must meet the following prerequisites:
- -- 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 Has_Generic_Body (N : Node_Id) return Boolean;
- -- N is a generic package instantiation node, and this routine determines
- -- if this package spec does in fact have a generic body. If so, then
- -- True is returned, otherwise False. Note that this is not at all the
- -- same as checking if the unit requires a body, since it deals with
- -- the case of optional bodies accurately (i.e. if a body is optional,
- -- then it looks to see if a body is actually present). Note: this
- -- function can only do a fully correct job if in generating code mode
- -- where all bodies have to be present. If we are operating in semantics
- -- check only mode, then in some cases of optional bodies, a result of
- -- False may incorrectly be given. In practice this simply means that
- -- some cases of warnings for incorrect order of elaboration will only
- -- be given when generating code, which is not a big problem (and is
- -- inevitable, given the optional body semantics of Ada).
-
- procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty);
- -- Given code for an elaboration check (or unconditional raise if the check
- -- is not needed), inserts the code in the appropriate place. N is the call
- -- or instantiation node for which the check code is required. C is the
- -- test whose failure triggers the raise.
-
- function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean;
- -- Returns True if node N is a call to a generic formal subprogram
-
- function Is_Finalization_Procedure (Id : Entity_Id) return Boolean;
- -- Determine whether entity Id denotes a [Deep_]Finalize procedure
-
- procedure Output_Calls
- (N : Node_Id;
- Check_Elab_Flag : Boolean);
- -- Outputs chain of calls stored in the Elab_Call table. The caller has
- -- already generated the main warning message, so the warnings generated
- -- are all continuation messages. The argument is the call node at which
- -- the messages are to be placed. When Check_Elab_Flag is set, calls are
- -- enumerated only when flag Elab_Warning is set for the dynamic case or
- -- when flag Elab_Info_Messages is set for the static case.
-
- function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean;
- -- Given two scopes, determine whether they are the same scope from an
- -- elaboration point of view, i.e. packages and blocks are ignored.
-
- procedure Set_C_Scope;
- -- On entry C_Scope is set to some scope. On return, C_Scope is reset
- -- to be the enclosing compilation unit of this scope.
-
- function Get_Referenced_Ent (N : Node_Id) return Entity_Id;
- -- N is either a function or procedure call or an access attribute that
- -- references a subprogram. This call retrieves the relevant entity. If
- -- this is a call to a protected subprogram, the entity is a selected
- -- component. The callable entity may be absent, in which case Empty is
- -- returned. This happens with non-analyzed calls in nested generics.
- --
- -- If SPARK_Mode is On, then N can also be a reference to an E_Variable
- -- entity, in which case, the value returned is simply this entity.
-
- procedure Set_Elaboration_Constraint
- (Call : Node_Id;
- Subp : Entity_Id;
- Scop : Entity_Id);
- -- The current unit U may depend semantically on some unit P that is not
- -- in the current context. If there is an elaboration call that reaches P,
- -- we need to indicate that P requires an Elaborate_All, but this is not
- -- effective in U's ali file, if there is no with_clause for P. In this
- -- case we add the Elaborate_All on the unit Q that directly or indirectly
- -- makes P available. This can happen in two cases:
- --
- -- a) Q declares a subtype of a type declared in P, and the call is an
- -- initialization call for an object of that subtype.
- --
- -- b) Q declares an object of some tagged type whose root type is
- -- declared in P, and the initialization call uses object notation on
- -- that object to reach a primitive operation or a classwide operation
- -- declared in P.
- --
- -- If P appears in the context of U, the current processing is correct.
- -- Otherwise we must identify these two cases to retrieve Q and place the
- -- Elaborate_All_Desirable on it.
-
- function Spec_Entity (E : Entity_Id) return Entity_Id;
- -- Given a compilation unit entity, if it is a spec entity, it is returned
- -- unchanged. If it is a body entity, then the spec for the corresponding
- -- spec is returned
-
- procedure Supply_Bodies (N : Node_Id);
- -- Given a node, N, that is either a subprogram declaration or a package
- -- declaration, this procedure supplies dummy bodies for the subprogram
- -- or for all subprograms in the package. If the given node is not one of
- -- these two possibilities, then Supply_Bodies does nothing. The dummy body
- -- contains a single Raise statement.
-
- procedure Supply_Bodies (L : List_Id);
- -- Calls Supply_Bodies for all elements of the given list L
-
- function Within (E1, E2 : Entity_Id) return Boolean;
- -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one
- -- of its contained scopes, False otherwise.
-
- function Within_Elaborate_All
- (Unit : Unit_Number_Type;
- E : Entity_Id) return Boolean;
- -- Return True if we are within the scope of an Elaborate_All for E, or if
- -- we are within the scope of an Elaborate_All for some other unit U, and U
- -- with's E. This prevents spurious warnings when the called entity is
- -- renamed within U, or in case of generic instances.
+ return
- --------------------------------------
- -- Activate_Elaborate_All_Desirable --
- --------------------------------------
+ -- This particular scenario is relevant only in the static model when
+ -- switch -gnatd.U (ignore 'Access) is not in effect.
- 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;
+ Static_Elaboration_Checks
+ and then not Debug_Flag_Dot_UU
- 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.
+ -- The prefix must denote an entry, operator, or subprogram which is
+ -- not imported.
- 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.
+ and then Comes_From_Source (Subp_Id)
+ and then Is_Subprogram_Or_Entry (Subp_Id)
+ and then not Is_Bodiless_Subprogram (Subp_Id)
- procedure Set_Elab_Flag (Itm : Node_Id);
- -- Sets Elaborate_[All_]Desirable as appropriate on Itm
+ -- The attribute name must be one of the 'Access forms. Note that
+ -- 'Unchecked_Access cannot apply to a subprogram.
- -----------------------------
- -- Add_To_Context_And_Mark --
- -----------------------------
+ and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access);
+ end Is_Suitable_Access;
- procedure Add_To_Context_And_Mark (Itm : Node_Id) is
- CW : constant Node_Id :=
- Make_With_Clause (Sloc (Itm),
- Name => Name (Itm));
+ ----------------------
+ -- Is_Suitable_Call --
+ ----------------------
- begin
- Set_Library_Unit (CW, Library_Unit (Itm));
- Set_Implicit_With (CW, True);
+ function Is_Suitable_Call (N : Node_Id) return Boolean is
+ begin
+ -- Entry and subprogram calls are intentionally ignored because they
+ -- may undergo expansion depending on the compilation mode, previous
+ -- errors, generic context, etc. Call markers play the role of calls
+ -- and provide a uniform foundation for ABE processing.
- -- Set elaborate all desirable on copy and then append the copy to
- -- the list of body with's and we are done.
+ return Nkind (N) = N_Call_Marker;
+ end Is_Suitable_Call;
- Set_Elab_Flag (CW);
- Append_To (CI, CW);
- end Add_To_Context_And_Mark;
+ -------------------------------
+ -- Is_Suitable_Instantiation --
+ -------------------------------
- -----------------
- -- In_Withs_Of --
- -----------------
+ function Is_Suitable_Instantiation (N : Node_Id) return Boolean is
+ Orig_N : constant Node_Id := Original_Node (N);
+ -- Use the original node in case an instantiation library unit is
+ -- rewritten as a package or subprogram.
- 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
+ -- To qualify, the instantiation must come from source
- 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)));
+ return
+ Comes_From_Source (Orig_N)
+ and then Nkind (Orig_N) in N_Generic_Instantiation;
+ end Is_Suitable_Instantiation;
- if U = Ent then
- return True;
- end if;
- end if;
+ --------------------------
+ -- Is_Suitable_Scenario --
+ --------------------------
- Next (Itm);
- end loop;
+ function Is_Suitable_Scenario (N : Node_Id) return Boolean is
+ begin
+ return
+ Is_Suitable_Access (N)
+ or else Is_Suitable_Call (N)
+ or else Is_Suitable_Instantiation (N)
+ or else Is_Suitable_Variable_Assignment (N)
+ or else Is_Suitable_Variable_Reference (N);
+ end Is_Suitable_Scenario;
+
+ -------------------------------------
+ -- Is_Suitable_Variable_Assignment --
+ -------------------------------------
+
+ function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean is
+ N_Unit : Node_Id;
+ N_Unit_Id : Entity_Id;
+ Nam : Node_Id;
+ Var_Decl : Node_Id;
+ Var_Id : Entity_Id;
+ Var_Unit : Node_Id;
+ Var_Unit_Id : Entity_Id;
+ begin
+ if Nkind (N) /= N_Assignment_Statement then
return False;
- 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;
+ -- Internally-generated assigments are assumed to be ABE safe
- -- Start of processing for Activate_Elaborate_All_Desirable
+ elsif not Comes_From_Source (N) then
+ return False;
- begin
- -- Do not set binder indication if expansion is disabled, as when
- -- compiling a generic unit.
+ -- Assignments are ignored in GNAT mode on the assumption that they are
+ -- ABE-safe. This behaviour parallels that of the old ABE mechanism.
- if not Expander_Active then
- return;
+ elsif GNAT_Mode then
+ return False;
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.
+ Nam := Extract_Assignment_Name (N);
- if U = Main_Unit_Entity then
- return;
+ -- Sanitize the left hand side of the assignment
+
+ if not Is_Entity_Name (Nam) then
+ return False;
+
+ elsif No (Entity (Nam)) then
+ return False;
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)));
+ Var_Id := Entity (Nam);
- -- If we find it, then mark elaborate all desirable and return
+ -- Sanitize the variable
- if U = Ent then
- Set_Elab_Flag (Itm);
- return;
- end if;
- end if;
+ if Var_Id = Any_Id then
+ return False;
- Next (Itm);
- end loop;
+ elsif Ekind (Var_Id) /= E_Variable then
+ return False;
+ end if;
- -- 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.
+ Var_Decl := Declaration_Node (Var_Id);
- if Is_Body_Name (Unm)
- and then In_Withs_Of (Spec_Entity (UE))
- then
- Add_To_Context_And_Mark (Itm);
- return;
+ if Nkind (Var_Decl) /= N_Object_Declaration then
+ return False;
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.
+ N_Unit_Id := Find_Top_Unit (N);
+ N_Unit := Unit_Declaration_Node (N_Unit_Id);
- if Is_Child_Name (Unm) then
- declare
- Pkg : Entity_Id;
+ Var_Unit_Id := Find_Top_Unit (Var_Decl);
+ Var_Unit := Unit_Declaration_Node (Var_Unit_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;
+ -- To qualify, the assignment must meet the following prerequisites:
- -- 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;
+ return
+ Comes_From_Source (Var_Id)
- ------------------
- -- Check_A_Call --
- ------------------
+ -- The variable must be susceptible to warnings
- 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.
+ and then not Has_Warnings_Off (Var_Id)
- -----------------------------------
- -- Call_To_Instance_From_Outside --
- -----------------------------------
+ -- The variable must be declared in the spec of compilation unit U
- function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean is
- Scop : Entity_Id := Id;
+ and then Nkind (Var_Unit) = N_Package_Declaration
- begin
- loop
- if Scop = Standard_Standard then
- return False;
- end if;
+ -- Performance note: parent traversal
- if Is_Generic_Instance (Scop) then
- return not In_Open_Scopes (Scop);
- end if;
+ and then Find_Enclosing_Level (Var_Decl) = Package_Spec
- Scop := Scope (Scop);
- end loop;
- end Call_To_Instance_From_Outside;
+ -- The variable must lack initialization
- ------------------
- -- Elab_Warning --
- ------------------
+ and then not Has_Init_Expression (Var_Decl)
+ and then No (Expression (Var_Decl))
- procedure Elab_Warning
- (Msg_D : String;
- Msg_S : String;
- Ent : Node_Or_Entity_Id)
- is
- begin
- -- Dynamic elaboration checks, real warning
+ -- The assignment must occur in the body of compilation unit U
- 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;
+ and then Nkind (N_Unit) = N_Package_Body
+ and then Present (Corresponding_Body (Var_Unit))
+ and then Corresponding_Body (Var_Unit) = N_Unit_Id
- -- In the access case emit first warning message as well,
- -- otherwise list of calls will appear as errors.
+ -- The package spec must lack pragma Elaborate_Body
- elsif Elab_Warnings then
- Error_Msg_NE (Msg_S, N, Ent);
- end if;
+ and then not Has_Pragma_Elaborate_Body (Var_Unit_Id);
+ end Is_Suitable_Variable_Assignment;
- -- Static elaboration checks, info message
+ ------------------------------------
+ -- Is_Suitable_Variable_Reference --
+ ------------------------------------
- else
- if Elab_Info_Messages then
- Error_Msg_NE (Msg_S, N, Ent);
- end if;
- end if;
- end Elab_Warning;
+ function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean is
+ function In_Pragma (Nod : Node_Id) return Boolean;
+ -- Determine whether arbitrary node N appears within a pragma
- ------------------
- -- Find_W_Scope --
- ------------------
+ ---------------
+ -- In_Pragma --
+ ---------------
- function Find_W_Scope return Entity_Id is
- Refed_Ent : constant Entity_Id := Get_Referenced_Ent (N);
- W_Scope : Entity_Id;
+ function In_Pragma (Nod : Node_Id) return Boolean is
+ Par : Node_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;
+ Par := Nod;
+ while Present (Par) loop
+ if Nkind (Par) = N_Pragma then
+ return True;
- -- Now loop through scopes to get to the enclosing compilation unit
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (Par) then
+ exit;
+ end if;
- while not Is_Compilation_Unit (W_Scope) loop
- W_Scope := Scope (W_Scope);
+ Par := Parent (Par);
end loop;
- return W_Scope;
- end Find_W_Scope;
+ return False;
+ end In_Pragma;
-- 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.
+ Prag : Node_Id;
+ Var_Id : Entity_Id;
- elsif Nkind (Original_Node (N)) = N_Attribute_Reference
- and then Attribute_Name (Original_Node (N)) = Name_Valid_Scalars
- then
- return;
+ -- Start of processing for Is_Suitable_Variable_Reference
- -- Intrinsics such as instances of Unchecked_Deallocation do not have
- -- any body, so elaboration checking is not needed, and would be wrong.
+ begin
+ -- Attributes and operator sumbols are not considered to be suitable
+ -- references to variables even though they are part of predicate
+ -- Is_Entity_Name.
- elsif Is_Intrinsic_Subprogram (E) then
- return;
+ if not Nkind_In (N, N_Expanded_Name, N_Identifier) then
+ return False;
- -- Do not consider references to internal variables for SPARK semantics
+ -- Internally generated references are assumed to be ABE safe
- elsif Variable_Case and then not Comes_From_Source (E) then
- return;
+ elsif not Comes_From_Source (N) then
+ return False;
end if;
- -- Proceed with check
-
- Ent := E;
+ -- Sanitize the reference
- -- For a variable reference, just set Body_Acts_As_Spec to False
+ Var_Id := Entity (N);
- if Variable_Case then
- Body_Acts_As_Spec := False;
+ if No (Var_Id) then
+ return False;
- -- Additional checks for all other cases
+ elsif Var_Id = Any_Id then
+ return False;
- else
- -- Go to parent for derived subprogram, or to original subprogram in
- -- the case of a renaming (Alias covers both these cases).
+ elsif Ekind (Var_Id) /= E_Variable then
+ return False;
+ end if;
- loop
- if (Suppress_Elaboration_Warnings (Ent)
- or else Elaboration_Checks_Suppressed (Ent))
- and then (Inst_Case or else No (Alias (Ent)))
- then
- return;
- end if;
+ Prag := SPARK_Pragma (Var_Id);
- -- Nothing to do for imported entities
+ -- To qualify, the reference must meet the following prerequisites:
- if Is_Imported (Ent) then
- return;
- end if;
+ return
+ Comes_From_Source (Var_Id)
- exit when Inst_Case or else No (Alias (Ent));
- Ent := Alias (Ent);
- end loop;
+ -- Both the variable and the reference must appear in SPARK_Mode On
+ -- regions because this scenario falls under the SPARK rules.
- Decl := Unit_Declaration_Node (Ent);
+ and then Present (Prag)
+ and then Get_SPARK_Mode_From_Annotation (Prag) = On
+ and then Is_SPARK_Mode_On_Node (N)
- if Nkind (Decl) = N_Subprogram_Body then
- Body_Acts_As_Spec := True;
+ -- The reference must not be considered when it appears in a pragma.
+ -- If the pragma has run-time semantics, then the reference will be
+ -- reconsidered once the pragma is expanded.
- elsif Nkind_In (Decl, N_Subprogram_Declaration,
- N_Subprogram_Body_Stub)
- or else Inst_Case
- then
- Body_Acts_As_Spec := False;
+ -- Performance note: parent traversal
- -- 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).
+ and then not In_Pragma (N);
+ end Is_Suitable_Variable_Reference;
- else
- return;
- end if;
- end if;
+ -------------------
+ -- Is_Task_Entry --
+ -------------------
- E_Scope := Ent;
- loop
- if Elaboration_Checks_Suppressed (E_Scope)
- or else Suppress_Elaboration_Warnings (E_Scope)
- then
- Cunit_SC := True;
- end if;
+ function Is_Task_Entry (Id : Entity_Id) return Boolean is
+ begin
+ -- To qualify, the entity must denote an entry defined in a task type
- -- Exit when we get to compilation unit, not counting subunits
+ return
+ Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id)));
+ end Is_Task_Entry;
- exit when Is_Compilation_Unit (E_Scope)
- and then (Is_Child_Unit (E_Scope)
- or else Scope (E_Scope) = Standard_Standard);
+ ------------------------
+ -- Is_Up_Level_Target --
+ ------------------------
- pragma Assert (E_Scope /= Standard_Standard);
+ function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean is
+ Root : constant Node_Id := Root_Scenario;
- -- Move up a scope looking for compilation unit
+ begin
+ -- The root appears within the declaratons of a block statement, entry
+ -- body, subprogram body, or task body ignoring enclosing packages. The
+ -- root is always within the main unit. An up level target is a notion
+ -- applicable only to the static model because scenarios are reached by
+ -- means of graph traversal started from a fixed declarative or library
+ -- level.
- E_Scope := Scope (E_Scope);
- end loop;
+ -- Performance note: parent traversal
- -- No checks needed for pure or preelaborated compilation units
+ if Static_Elaboration_Checks
+ and then Find_Enclosing_Level (Root) = Declaration_Level
+ then
+ -- The target is within the main unit. It acts as an up level target
+ -- when it appears within a context which encloses the root.
- if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then
- return;
- end if;
+ -- package body Main_Unit is
+ -- function Func ...; -- target
- -- 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.
+ -- procedure Proc is
+ -- X : ... := Func; -- root scenario
- if not Dynamic_Elaboration_Checks
- and then
- Instantiation_Depth (Sloc (Ent)) > Instantiation_Depth (Sloc (N))
- then
- return;
- end if;
+ if In_Extended_Main_Code_Unit (Target_Decl) then
- -- Do not give a warning for a package with no body
+ -- Performance note: parent traversal
- if Ekind (Ent) = E_Generic_Package and then not Has_Generic_Body (N) then
- return;
- end if;
+ return not In_Same_Context (Root, Target_Decl, Nested_OK => True);
- -- 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.
+ -- Otherwise the target is external to the main unit which makes it
+ -- an up level target.
- if W_Scope = C_Scope then
- if not Inter_Unit_Only then
- Check_Internal_Call (N, Ent, Outer_Scope, E);
+ else
+ return True;
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.
+ return False;
+ end Is_Up_Level_Target;
- if not From_Elab_Code and then not Dynamic_Elaboration_Checks then
- return;
- end if;
+ -------------------------------
+ -- Kill_Elaboration_Scenario --
+ -------------------------------
- -- Nothing to do if some scope said that no checks were required
+ 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.
- if Cunit_SC then
- return;
+ if Is_Scenario (N) then
+ Set_Is_Elaboration_Checks_OK_Node (N, False);
end if;
+ end Kill_Elaboration_Scenario;
- -- 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.
+ ----------------------------------
+ -- Meet_Elaboration_Requirement --
+ ----------------------------------
- if Call_To_Instance_From_Outside (Ent) then
- return;
- end if;
+ procedure Meet_Elaboration_Requirement
+ (N : Node_Id;
+ Target_Id : Entity_Id;
+ Req_Nam : Name_Id)
+ is
+ Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit);
+ Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id);
+
+ function Find_Preelaboration_Pragma
+ (Prag_Nam : Name_Id) return Node_Id;
+ pragma Inline (Find_Preelaboration_Pragma);
+ -- Traverse the visible declarations of unit Unit_Id and locate a source
+ -- preelaboration-related pragma with name Prag_Nam.
+
+ procedure Info_Requirement_Met (Prag : Node_Id);
+ pragma Inline (Info_Requirement_Met);
+ -- Output information concerning pragma Prag which meets requirement
+ -- Req_Nam.
+
+ procedure Info_Scenario;
+ pragma Inline (Info_Scenario);
+ -- Output information concerning scenario N
+
+ --------------------------------
+ -- Find_Preelaboration_Pragma --
+ --------------------------------
+
+ function Find_Preelaboration_Pragma
+ (Prag_Nam : Name_Id) return Node_Id
+ is
+ Spec : constant Node_Id := Parent (Unit_Id);
+ Decl : Node_Id;
- -- 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.
+ begin
+ -- A preelaboration-related pragma comes from source and appears at
+ -- the top of the visible declarations of a package.
- 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;
+ if Nkind (Spec) = N_Package_Specification then
+ Decl := First (Visible_Declarations (Spec));
+ while Present (Decl) loop
+ if Comes_From_Source (Decl) then
+ if Nkind (Decl) = N_Pragma
+ and then Pragma_Name (Decl) = Prag_Nam
+ then
+ return Decl;
- begin
- if not Is_Controlled (Typ) then
- return;
- else
- Init := Find_Prim_Op (Typ, Name_Initialize);
+ -- Otherwise the construct terminates the region where the
+ -- preelabortion-related pragma may appear.
- if Comes_From_Source (Init) then
- Ent := Init;
else
- return;
+ exit;
end if;
end if;
- end;
+
+ Next (Decl);
+ end loop;
+ end if;
+
+ return Empty;
+ end Find_Preelaboration_Pragma;
+
+ --------------------------
+ -- Info_Requirement_Met --
+ --------------------------
+
+ procedure Info_Requirement_Met (Prag : Node_Id) is
+ begin
+ pragma Assert (Present (Prag));
+
+ Error_Msg_Name_1 := Req_Nam;
+ Error_Msg_Sloc := Sloc (Prag);
+ Error_Msg_NE
+ ("\\% requirement for unit & met by pragma #", N, Unit_Id);
+ end Info_Requirement_Met;
+
+ -------------------
+ -- Info_Scenario --
+ -------------------
+
+ procedure Info_Scenario is
+ begin
+ if Is_Suitable_Call (N) then
+ Info_Call
+ (Call => N,
+ Target_Id => Target_Id,
+ Info_Msg => False,
+ In_SPARK => True);
+
+ elsif Is_Suitable_Instantiation (N) then
+ Info_Instantiation
+ (Inst => N,
+ Gen_Id => Target_Id,
+ Info_Msg => False,
+ In_SPARK => True);
+
+ elsif Is_Suitable_Variable_Reference (N) then
+ Info_Variable_Reference
+ (Ref => N,
+ Var_Id => Target_Id,
+ Info_Msg => False,
+ In_SPARK => True);
+
+ -- No other scenario may impose a requirement on the context of the
+ -- main unit.
else
- return;
+ pragma Assert (False);
+ null;
end if;
- end if;
+ end Info_Scenario;
- -- Check cases of internal units
+ -- Local variables
- Callee_Unit_Internal := In_Internal_Unit (E_Scope);
+ Elab_Attrs : Elaboration_Attributes;
+ Elab_Nam : Name_Id;
+ Req_Met : Boolean;
- -- 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)
+ -- Start of processing for Meet_Elaboration_Requirement
- if Callee_Unit_Internal and Inst_Case then
- return;
- end if;
+ begin
+ pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All));
- if C_Scope = Standard_Standard then
- Caller_Unit_Internal := False;
- else
- Caller_Unit_Internal := In_Internal_Unit (C_Scope);
- end if;
+ -- Assume that the requirement has not been met
- -- 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).
+ Req_Met := False;
- if Callee_Unit_Internal and not Caller_Unit_Internal then
- return;
- end if;
+ -- If the target is within the main unit, either at the source level or
+ -- through an instantiation, then there is no real requirement to meet
+ -- because the main unit cannot force its own elaboration by means of an
+ -- Elaborate[_All] pragma. Treat this case as valid coverage.
+
+ if In_Extended_Main_Code_Unit (Target_Id) then
+ Req_Met := True;
- -- 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 ???
+ -- Otherwise the target resides in an external unit
- if (Callee_Unit_Internal and Caller_Unit_Internal)
- and not Debug_Flag_EE
+ -- The requirement is met when the target comes from an internal unit
+ -- because such a unit is elaborated prior to a non-internal unit.
+
+ elsif In_Internal_Unit (Unit_Id)
+ and then not In_Internal_Unit (Main_Id)
then
- return;
- end if;
+ Req_Met := True;
- if Is_TSS (E, TSS_Deep_Initialize) then
- Ent := E;
- end if;
+ -- The requirement is met when the target comes from a preelaborated
+ -- unit. This portion must parallel predicate Is_Preelaborated_Unit.
+
+ elsif Is_Preelaborated_Unit (Unit_Id) then
+ Req_Met := True;
+
+ -- Output extra information when switch -gnatel (info messages on
+ -- implicit Elaborate[_All] pragmas.
- -- 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.
+ if Elab_Info_Messages then
+ if Is_Preelaborated (Unit_Id) then
+ Elab_Nam := Name_Preelaborate;
- -- However, if we are doing dynamic elaboration, we need to chase the
- -- call in the usual manner.
+ elsif Is_Pure (Unit_Id) then
+ Elab_Nam := Name_Pure;
+
+ elsif Is_Remote_Call_Interface (Unit_Id) then
+ Elab_Nam := Name_Remote_Call_Interface;
+
+ elsif Is_Remote_Types (Unit_Id) then
+ Elab_Nam := Name_Remote_Types;
+
+ else
+ pragma Assert (Is_Shared_Passive (Unit_Id));
+ Elab_Nam := Name_Shared_Passive;
+ end if;
- -- 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.
+ Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam));
+ end if;
- Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N)));
- Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent)));
+ -- Determine whether the context of the main unit has a pragma strong
+ -- enough to meet the requirement.
- if Inst_Caller = No_Location then
- Unit_Caller := No_Unit;
else
- Unit_Caller := Get_Source_Unit (N);
+ Elab_Attrs := Elaboration_Context.Get (Unit_Id);
+
+ -- The pragma must be either Elaborate_All or be as strong as the
+ -- requirement.
+
+ if Present (Elab_Attrs.Source_Pragma)
+ and then Nam_In (Pragma_Name (Elab_Attrs.Source_Pragma),
+ Name_Elaborate_All,
+ Req_Nam)
+ then
+ Req_Met := True;
+
+ -- Output extra information when switch -gnatel (info messages on
+ -- implicit Elaborate[_All] pragmas.
+
+ if Elab_Info_Messages then
+ Info_Requirement_Met (Elab_Attrs.Source_Pragma);
+ end if;
+ end if;
end if;
- if Inst_Callee = No_Location then
- Unit_Callee := No_Unit;
- else
- Unit_Callee := Get_Source_Unit (Ent);
+ -- The requirement was not met by the context of the main unit, issue an
+ -- error.
+
+ if not Req_Met then
+ Info_Scenario;
+
+ Error_Msg_Name_1 := Req_Nam;
+ Error_Msg_Node_2 := Unit_Id;
+ Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id);
+
+ Output_Active_Scenarios (N);
end if;
+ end Meet_Elaboration_Requirement;
- 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));
+ ----------------------
+ -- Non_Private_View --
+ ----------------------
- -- If we don't get a spec entity, just ignore call. Not quite
- -- clear why this check is necessary. ???
+ function Non_Private_View (Typ : Entity_Id) return Entity_Id is
+ Result : Entity_Id;
- if No (E_Scope) then
- return;
- end if;
+ begin
+ Result := Typ;
- -- Otherwise step to enclosing compilation unit
+ if Is_Private_Type (Result) and then Present (Full_View (Result)) then
+ Result := Full_View (Result);
+ end if;
- while not Is_Compilation_Unit (E_Scope) loop
- E_Scope := Scope (E_Scope);
- end loop;
+ return Result;
+ end Non_Private_View;
+
+ -----------------------------
+ -- Output_Active_Scenarios --
+ -----------------------------
- -- 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.
+ procedure Output_Active_Scenarios (Error_Nod : Node_Id) is
+ procedure Output_Access (N : Node_Id);
+ -- Emit a specific diagnostic message for 'Access denote by N
- else
- -- Loop to carefully follow renamings and derivations one step
- -- outside the current unit, but not further.
+ procedure Output_Activation_Call (N : Node_Id);
+ -- Emit a specific diagnostic message for task activation N
- if not (Inst_Case or Variable_Case)
- and then Present (Alias (Ent))
- then
- E_Scope := Alias (Ent);
- else
- E_Scope := Ent;
- end if;
+ procedure Output_Call (N : Node_Id; Target_Id : Entity_Id);
+ -- Emit a specific diagnostic message for call N which invokes target
+ -- Target_Id.
+
+ procedure Output_Header;
+ -- Emit a specific diagnostic message for the unit of the root scenario
+
+ procedure Output_Instantiation (N : Node_Id);
+ -- Emit a specific diagnostic message for instantiation N
- loop
- while not Is_Compilation_Unit (E_Scope) loop
- E_Scope := Scope (E_Scope);
- end loop;
+ procedure Output_Variable_Assignment (N : Node_Id);
+ -- Emit a specific diagnostic message for assignment statement N
- -- 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.
+ procedure Output_Variable_Reference (N : Node_Id);
+ -- Emit a specific diagnostic message for variable reference N
- exit when E_Scope /= C_Scope;
- Ent := Alias (Ent);
- E_Scope := Ent;
+ -------------------
+ -- Output_Access --
+ -------------------
- -- If no alias, there could be a previous error, but not if we've
- -- already reached the outermost level (Standard).
+ procedure Output_Access (N : Node_Id) is
+ Subp_Id : constant Entity_Id := Entity (Prefix (N));
- if No (Ent) then
- return;
- end if;
- end loop;
- end if;
+ begin
+ Error_Msg_Name_1 := Attribute_Name (N);
+ Error_Msg_Sloc := Sloc (N);
+ Error_Msg_NE ("\\ % of & taken #", Error_Nod, Subp_Id);
+ end Output_Access;
- if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then
- return;
- end if;
+ ----------------------------
+ -- Output_Activation_Call --
+ ----------------------------
- -- Determine whether the Default_Initial_Condition procedure of some
- -- type is being invoked.
+ procedure Output_Activation_Call (N : Node_Id) is
+ function Find_Activator (Call : Node_Id) return Entity_Id;
+ -- Find the nearest enclosing construct which houses call Call
- Is_DIC := Ekind (Ent) = E_Procedure and then Is_DIC_Procedure (Ent);
+ --------------------
+ -- Find_Activator --
+ --------------------
- -- Checks related to Default_Initial_Condition fall under the SPARK
- -- umbrella because this is a SPARK-specific annotation.
+ function Find_Activator (Call : Node_Id) return Entity_Id is
+ Par : Node_Id;
- SPARK_Elab_Errors :=
- SPARK_Mode = On and (Is_DIC or Dynamic_Elaboration_Checks);
+ begin
+ -- Climb the parent chain looking for a package [body] or a
+ -- construct with a statement sequence.
- -- Now check if an Elaborate_All (or dynamic check) is needed
+ Par := Parent (Call);
+ while Present (Par) loop
+ if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then
+ return Defining_Entity (Par);
- 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
+ elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then
+ return Defining_Entity (Parent (Par));
+ end if;
- 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;
+ Par := Parent (Par);
+ end loop;
- -- 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.
+ return Empty;
+ end Find_Activator;
- elsif Access_Case then
- Elab_Warning ("", "info: access to & during elaboration?$?", Ent);
+ -- Local variables
- -- Variable reference in SPARK mode
+ Activator : constant Entity_Id := Find_Activator (N);
- 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;
+ -- Start of processing for Output_Activation_Call
- -- Subprogram call case
+ begin
+ pragma Assert (Present (Activator));
- 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;
+ Error_Msg_NE ("\\ local tasks of & activated", Error_Nod, Activator);
+ end Output_Activation_Call;
- else
- Elab_Warning
- ("call to & may raise Program_Error?l?",
- "info: call to & during elaboration?$?",
- Ent);
- end if;
- end if;
+ -----------------
+ -- Output_Call --
+ -----------------
- Error_Msg_Qual_Level := Nat'Last;
+ procedure Output_Call (N : Node_Id; Target_Id : Entity_Id) is
+ procedure Output_Accept_Alternative;
+ pragma Inline (Output_Accept_Alternative);
+ -- Emit a specific diagnostic message concerning an accept
+ -- alternative.
- -- Case of Elaborate_All not present and required, for SPARK this
- -- is an error, so give an error message.
+ procedure Output_Call (Kind : String);
+ pragma Inline (Output_Call);
+ -- Emit a specific diagnostic message concerning a call of kind Kind
- if SPARK_Elab_Errors then
- Error_Msg_NE -- CODEFIX
- ("\Elaborate_All pragma required for&", N, W_Scope);
+ procedure Output_Type_Actions (Action : String);
+ pragma Inline (Output_Type_Actions);
+ -- Emit a specific diagnostic message concerning action Action of a
+ -- type.
- -- 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.
+ procedure Output_Verification_Call
+ (Pred : String;
+ Id : Entity_Id;
+ Id_Kind : String);
+ pragma Inline (Output_Verification_Call);
+ -- Emit a specific diagnostic message concerning the verification of
+ -- predicate Pred applied to related entity Id with kind Id_Kind.
- elsif Nkind (N) in N_Subprogram_Instantiation then
- Elab_Warning
- ("\missing pragma Elaborate for&?l?",
- "\implicit pragma Elaborate for& generated?$?",
- W_Scope);
+ -------------------------------
+ -- Output_Accept_Alternative --
+ -------------------------------
- -- For all other cases, we need an implicit Elaborate_All
+ procedure Output_Accept_Alternative is
+ Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id);
- else
- Elab_Warning
- ("\missing pragma Elaborate_All for&?l?",
- "\implicit pragma Elaborate_All for & generated?$?",
- W_Scope);
- end if;
+ begin
+ pragma Assert (Present (Entry_Id));
- Error_Msg_Qual_Level := 0;
+ Error_Msg_NE ("\\ entry & selected #", Error_Nod, Entry_Id);
+ end Output_Accept_Alternative;
- -- 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_Call --
+ -----------------
- Output_Calls (N, Check_Elab_Flag => True);
+ procedure Output_Call (Kind : String) is
+ begin
+ Error_Msg_NE ("\\ " & Kind & " & called #", Error_Nod, Target_Id);
+ end Output_Call;
- -- Set flag to prevent further warnings for same unit unless in
- -- All_Errors_Mode.
+ -------------------------
+ -- Output_Type_Actions --
+ -------------------------
- if not All_Errors_Mode and not Dynamic_Elaboration_Checks then
- Set_Suppress_Elaboration_Warnings (W_Scope);
- end if;
- end if;
+ procedure Output_Type_Actions (Action : String) is
+ Typ : constant Entity_Id := First_Formal_Type (Target_Id);
- -- Check for runtime elaboration check required
+ begin
+ pragma Assert (Present (Typ));
- 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.
+ Error_Msg_NE
+ ("\\ " & Action & " actions for type & #", Error_Nod, Typ);
+ end Output_Type_Actions;
+
+ ------------------------------
+ -- Output_Verification_Call --
+ ------------------------------
+
+ procedure Output_Verification_Call
+ (Pred : String;
+ Id : Entity_Id;
+ Id_Kind : String)
+ is
+ begin
+ pragma Assert (Present (Id));
- -- Note that for this case, we do check the real unit (the one
- -- from following renamings, since that is the issue).
+ Error_Msg_NE
+ ("\\ " & Pred & " of " & Id_Kind & " & verified #",
+ Error_Nod, Id);
+ end Output_Verification_Call;
- -- Could this possibly miss a useless but required PE???
+ -- Start of processing for Output_Call
- Insert_Elab_Check (N,
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Elaborated,
- Prefix =>
- New_Occurrence_Of (Spec_Entity (E_Scope), Loc)));
+ begin
+ Error_Msg_Sloc := Sloc (N);
- -- 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.
+ -- Accept alternative
- if Nkind (N) in N_Subprogram_Call then
- Set_No_Elaboration_Check (N);
- end if;
- end if;
+ if Is_Accept_Alternative_Proc (Target_Id) then
+ Output_Accept_Alternative;
- -- Case of static elaboration model
+ -- Adjustment
- 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;
+ elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then
+ Output_Type_Actions ("adjustment");
- -- Do not generate an Elaborate_All for finalization routines
- -- that perform partial clean up as part of initialization.
+ -- Default_Initial_Condition
- elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then
- null;
+ elsif Is_Default_Initial_Condition_Proc (Target_Id) then
+ Output_Verification_Call
+ (Pred => "Default_Initial_Condition",
+ Id => First_Formal_Type (Target_Id),
+ Id_Kind => "type");
- -- Here we need to generate an implicit elaborate all
+ -- Entries
- else
- -- Generate Elaborate_All warning unless suppressed
+ elsif Is_Protected_Entry (Target_Id) then
+ Output_Call ("entry");
- 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;
+ -- Task entry calls are never processed because the entry being
+ -- invoked does not have a corresponding "body", it has a select. A
+ -- task entry call appears in the stack of active scenarios for the
+ -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and
+ -- nothing more.
- -- Set indication for binder to generate Elaborate_All
+ elsif Is_Task_Entry (Target_Id) then
+ null;
- Set_Elaboration_Constraint (N, E, W_Scope);
- end if;
- end if;
- end Check_A_Call;
+ -- Finalization
- -----------------------------
- -- Check_Bad_Instantiation --
- -----------------------------
+ elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then
+ Output_Type_Actions ("finalization");
- procedure Check_Bad_Instantiation (N : Node_Id) is
- Ent : Entity_Id;
+ -- Calls to _Finalizer procedures must not appear in the output
+ -- because this creates confusing noise.
- begin
- -- Nothing to do if we do not have an instantiation (happens in some
- -- error cases, and also in the formal package declaration case)
+ elsif Is_Finalizer_Proc (Target_Id) then
+ null;
- if Nkind (N) not in N_Generic_Instantiation then
- return;
+ -- Initial_Condition
- -- Nothing to do if serious errors detected (avoid cascaded errors)
+ elsif Is_Initial_Condition_Proc (Target_Id) then
+ Output_Verification_Call
+ (Pred => "Initial_Condition",
+ Id => Find_Enclosing_Scope (N),
+ Id_Kind => "package");
- elsif Serious_Errors_Detected /= 0 then
- return;
+ -- Initialization
- -- Nothing to do if not in full analysis mode
+ elsif Is_Init_Proc (Target_Id)
+ or else Is_TSS (Target_Id, TSS_Deep_Initialize)
+ then
+ Output_Type_Actions ("initialization");
- elsif not Full_Analysis then
- return;
+ -- Invariant
- -- Nothing to do if inside a generic template
+ elsif Is_Invariant_Proc (Target_Id) then
+ Output_Verification_Call
+ (Pred => "invariants",
+ Id => First_Formal_Type (Target_Id),
+ Id_Kind => "type");
- elsif Inside_A_Generic then
- return;
+ -- Partial invariant calls must not appear in the output because this
+ -- creates confusing noise. Note that a partial invariant is always
+ -- invoked by the "full" invariant which is already placed on the
+ -- stack.
- -- Nothing to do if a library level instantiation
+ elsif Is_Partial_Invariant_Proc (Target_Id) then
+ null;
- elsif Nkind (Parent (N)) = N_Compilation_Unit then
- return;
+ -- _Postconditions
- -- Nothing to do if we are compiling a proper body for semantic
- -- purposes only. The generic body may be in another proper body.
+ elsif Is_Postconditions_Proc (Target_Id) then
+ Output_Verification_Call
+ (Pred => "postconditions",
+ Id => Find_Enclosing_Scope (N),
+ Id_Kind => "subprogram");
- elsif
- Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit
- then
- return;
- end if;
+ -- Subprograms must come last because some of the previous cases fall
+ -- under this category.
- Ent := Get_Generic_Entity (N);
+ elsif Ekind (Target_Id) = E_Function then
+ Output_Call ("function");
- -- The case we are interested in is when the generic spec is in the
- -- current declarative part
+ elsif Ekind (Target_Id) = E_Procedure then
+ Output_Call ("procedure");
- if not Same_Elaboration_Scope (Current_Scope, Scope (Ent))
- or else not In_Same_Extended_Unit (N, Ent)
- then
- return;
- end if;
+ else
+ pragma Assert (False);
+ null;
+ end if;
+ end Output_Call;
- -- 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.
+ -------------------
+ -- Output_Header --
+ -------------------
- declare
- D1 : constant Nat := Instantiation_Depth (Sloc (Ent));
- D2 : constant Nat := Instantiation_Depth (Sloc (N));
+ procedure Output_Header is
+ Unit_Id : constant Entity_Id := Find_Top_Unit (Root_Scenario);
begin
- if D1 > D2 then
- return;
+ if Ekind (Unit_Id) = E_Package then
+ Error_Msg_NE ("\\ spec of unit & elaborated", Error_Nod, Unit_Id);
- elsif D1 = D2
- and then Is_Generic_Instance (Scope (Ent))
- and then not In_Open_Scopes (Scope (Ent))
- then
- return;
+ elsif Ekind (Unit_Id) = E_Package_Body then
+ Error_Msg_NE ("\\ body of unit & elaborated", Error_Nod, Unit_Id);
+
+ else
+ Error_Msg_NE ("\\ in body of unit &", Error_Nod, Unit_Id);
end if;
- end;
+ end Output_Header;
- -- Now we can proceed, if the entity being called has a completion,
- -- then we are definitely OK, since we have already seen the body.
+ --------------------------
+ -- Output_Instantiation --
+ --------------------------
- if Has_Completion (Ent) then
- return;
- end if;
+ procedure Output_Instantiation (N : Node_Id) is
+ procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String);
+ pragma Inline (Output_Instantiation);
+ -- Emit a specific diagnostic message concerning an instantiation of
+ -- generic unit Gen_Id. Kind denotes the kind of the instantiation.
- -- If there is no body, then nothing to do
+ --------------------------
+ -- Output_Instantiation --
+ --------------------------
- if not Has_Generic_Body (N) then
- return;
- end if;
+ procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String) is
+ begin
+ Error_Msg_NE
+ ("\\ " & Kind & " & instantiated as & #", Error_Nod, Gen_Id);
+ end Output_Instantiation;
- -- Here we definitely have a bad instantiation
+ -- Local variables
- Error_Msg_Warn := SPARK_Mode /= On;
- Error_Msg_NE ("cannot instantiate& before body seen<<", N, Ent);
+ Inst : Node_Id;
+ Inst_Attrs : Instantiation_Attributes;
+ Inst_Id : Entity_Id;
+ Gen_Id : Entity_Id;
- if Present (Instance_Spec (N)) then
- Supply_Bodies (Instance_Spec (N));
- end if;
+ -- Start of processing for Output_Instantiation
- Error_Msg_N ("\Program_Error [<<", N);
- Insert_Elab_Check (N);
- Set_ABE_Is_Certain (N);
- end Check_Bad_Instantiation;
+ begin
+ Extract_Instantiation_Attributes
+ (Exp_Inst => N,
+ Inst => Inst,
+ Inst_Id => Inst_Id,
+ Gen_Id => Gen_Id,
+ Attrs => Inst_Attrs);
- ---------------------
- -- Check_Elab_Call --
- ---------------------
+ Error_Msg_Node_2 := Inst_Id;
+ Error_Msg_Sloc := Sloc (Inst);
- procedure Check_Elab_Call
- (N : Node_Id;
- Outer_Scope : Entity_Id := Empty;
- In_Init_Proc : Boolean := False)
- is
- Ent : Entity_Id;
- P : Node_Id;
+ if Nkind (Inst) = N_Function_Instantiation then
+ Output_Instantiation (Gen_Id, "function");
- begin
- -- If the reference is not in the main unit, there is nothing to check.
- -- Elaboration call from units in the context of the main unit will lead
- -- to semantic dependencies when those units are compiled.
+ elsif Nkind (Inst) = N_Package_Instantiation then
+ Output_Instantiation (Gen_Id, "package");
- if not In_Extended_Main_Code_Unit (N) then
- return;
- end if;
+ elsif Nkind (Inst) = N_Procedure_Instantiation then
+ Output_Instantiation (Gen_Id, "procedure");
- -- For an entry call, check relevant restriction
+ else
+ pragma Assert (False);
+ null;
+ end if;
+ end Output_Instantiation;
- 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);
+ --------------------------------
+ -- Output_Variable_Assignment --
+ --------------------------------
- -- Nothing to do if this is not an expected type of reference (happens
- -- in some error conditions, and in some cases where rewriting occurs).
+ procedure Output_Variable_Assignment (N : Node_Id) is
+ Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (N));
- 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;
+ begin
+ Error_Msg_Sloc := Sloc (N);
+ Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id);
+ end Output_Variable_Assignment;
- -- Nothing to do if this is a call already rewritten for elab checking.
- -- Such calls appear as the targets of If_Expressions.
+ -------------------------------
+ -- Output_Variable_Reference --
+ -------------------------------
- -- This check MUST be wrong, it catches far too much
+ procedure Output_Variable_Reference (N : Node_Id) is
+ Dummy : Variable_Attributes;
+ Var_Id : Entity_Id;
- elsif Nkind (Parent (N)) = N_If_Expression then
- return;
+ begin
+ Extract_Variable_Reference_Attributes
+ (Ref => N,
+ Var_Id => Var_Id,
+ Attrs => Dummy);
- -- Nothing to do if inside a generic template
+ Error_Msg_Sloc := Sloc (N);
+ Error_Msg_NE ("\\ variable & referenced #", Error_Nod, Var_Id);
+ end Output_Variable_Reference;
- elsif Inside_A_Generic
- and then No (Enclosing_Generic_Body (N))
- then
- return;
+ -- Local variables
- -- Nothing to do if call is being pre-analyzed, as when within a
- -- pre/postcondition, a predicate, or an invariant.
+ package Stack renames Scenario_Stack;
- elsif In_Spec_Expression then
- return;
- end if;
+ Dummy : Call_Attributes;
+ N : Node_Id;
+ Posted : Boolean;
+ Target_Id : Entity_Id;
- -- 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.
+ -- Start of processing for Output_Active_Scenarios
- if Nkind (N) = N_Procedure_Call_Statement
- and then Is_Entity_Name (Name (N))
- and then Chars (Entity (Name (N))) = Name_uPostconditions
- then
+ begin
+ -- Active scenarios are emitted only when the static model is in effect
+ -- because there is an inherent order by which all these scenarios were
+ -- reached from the declaration or library level.
+
+ if not Static_Elaboration_Checks then
return;
end if;
- -- Here we have a reference at elaboration time that must be checked
+ Posted := False;
- if Debug_Flag_LL then
- Write_Str (" Check_Elab_Ref: ");
+ for Index in Stack.First .. Stack.Last loop
+ N := Stack.Table (Index);
+
+ if not Posted then
+ Posted := True;
+ Output_Header;
+ end if;
+
+ -- 'Access
if Nkind (N) = N_Attribute_Reference then
- if not Is_Entity_Name (Prefix (N)) then
- Write_Str ("<<not entity name>>");
- else
- Write_Name (Chars (Entity (Prefix (N))));
- end if;
+ Output_Access (N);
- Write_Str ("'Access");
+ -- Calls
- elsif No (Name (N)) or else not Is_Entity_Name (Name (N)) then
- Write_Str ("<<not entity name>> ");
+ elsif Is_Suitable_Call (N) then
+ Extract_Call_Attributes
+ (Call => N,
+ Target_Id => Target_Id,
+ Attrs => Dummy);
- else
- Write_Name (Chars (Entity (Name (N))));
- end if;
+ if Is_Activation_Proc (Target_Id) then
+ Output_Activation_Call (N);
+ else
+ Output_Call (N, Target_Id);
+ end if;
- Write_Str (" reference at ");
- Write_Location (Sloc (N));
- Write_Eol;
- end if;
+ -- Instantiations
- -- 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).
+ elsif Is_Suitable_Instantiation (N) then
+ Output_Instantiation (N);
- -- 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.
+ -- Variable assignments
- P := Parent (N);
- while Present (P) loop
- if Nkind_In (P, N_Parameter_Specification,
- N_Component_Declaration)
- then
- return;
+ elsif Nkind (N) = N_Assignment_Statement then
+ Output_Variable_Assignment (N);
- -- The reference occurs within the constraint of a component,
- -- so it must be checked.
+ -- Variable references
- elsif Nkind (P) = N_Component_Definition then
- exit;
+ elsif Is_Suitable_Variable_Reference (N) then
+ Output_Variable_Reference (N);
else
- P := Parent (P);
+ pragma Assert (False);
+ null;
end if;
end loop;
+ end Output_Active_Scenarios;
- -- 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;
+ -------------------------
+ -- Pop_Active_Scenario --
+ -------------------------
- if C_Scope = Standard_Standard then
- return;
- end if;
+ procedure Pop_Active_Scenario (N : Node_Id) is
+ Top : Node_Id renames Scenario_Stack.Table (Scenario_Stack.Last);
- -- First case, we are in elaboration code
+ begin
+ pragma Assert (Top = N);
+ Scenario_Stack.Decrement_Last;
+ end Pop_Active_Scenario;
- From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
+ --------------------
+ -- Process_Access --
+ --------------------
- if From_Elab_Code then
+ 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
- -- Complain if ref that comes from source in preelaborated unit
- -- and we are not inside a subprogram (i.e. we are in elab code).
+ -------------------------
+ -- Build_Access_Marker --
+ -------------------------
- 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.
+ function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id is
+ Marker : Node_Id;
- Error_Msg_Warn := GNAT_Mode;
- Error_Msg_N
- ("<<non-static call not allowed in preelaborated unit", N);
- return;
- end if;
+ begin
+ Marker := Make_Call_Marker (Sloc (Attr));
- -- Second case, we are inside a subprogram or concurrent unit, which
- -- means we are not in elaboration code.
+ -- Inherit relevant attributes from the attribute
- 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;
+ -- Performance note: parent traversal
- if Is_List_Member (P) then
- L := List_Containing (P);
- P := Parent (L);
- else
- L := No_List;
- P := Parent (P);
- end if;
+ 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));
- exit when Nkind (P) = N_Subunit;
+ -- Partially insert the call marker into the tree by setting its
+ -- parent pointer.
- -- Filter out case of default expressions, where we do not
- -- do the check at this stage.
+ Set_Parent (Marker, Attr);
- if Nkind_In (P, N_Parameter_Specification,
- N_Component_Declaration)
- then
- return;
- end if;
+ return Marker;
+ end Build_Access_Marker;
- -- A protected body has no elaboration code and contains
- -- only other bodies.
+ -- Local variables
- if Nkind (P) = N_Protected_Body then
- return;
+ Root : constant Node_Id := Root_Scenario;
+ Target_Id : constant Entity_Id := Entity (Prefix (Attr));
- elsif Nkind_In (P, N_Subprogram_Body,
- N_Task_Body,
- N_Block_Statement,
- N_Entry_Body)
- then
- if L = Declarations (P) then
- exit;
+ Target_Attrs : Target_Attributes;
- -- 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.
+ -- Start of processing for Process_Access
- elsif Dynamic_Elaboration_Checks then
+ begin
+ -- Output relevant information when switch -gnatel (info messages on
+ -- implicit Elaborate[_All] pragmas) is in effect.
- -- 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 Elab_Info_Messages then
+ Error_Msg_NE
+ ("info: access to & during elaboration", Attr, Target_Id);
+ end if;
- if Debug_Flag_DD then
- return;
- 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);
- -- Do the check in this case
+ Output_Active_Scenarios (Attr);
+ end if;
- exit;
+ -- Treat the attribute as an immediate invocation of the target when
+ -- switch -gnatd.o (conservarive elaboration order for indirect calls)
+ -- is in effect. Note that the prior elaboration of the unit containing
+ -- the target is ensured processing the corresponding call marker.
- elsif Nkind (P) = N_Task_Body then
+ if Debug_Flag_Dot_O then
+ Process_Scenario
+ (N => Build_Access_Marker (Target_Id),
+ In_Task_Body => In_Task_Body);
- -- The check is deferred until Check_Task_Activation
- -- but we need to capture local suppress pragmas
- -- that may inhibit checks on this call.
+ -- Otherwise ensure that the unit with the corresponding body is
+ -- elaborated prior to the main unit.
- Ent := Get_Referenced_Ent (N);
+ else
+ Ensure_Prior_Elaboration
+ (N => Attr,
+ Unit_Id => Target_Attrs.Unit_Id,
+ In_Task_Body => In_Task_Body);
+ end if;
+ end Process_Access;
- if No (Ent) then
- return;
+ -----------------------------
+ -- Process_Activation_Call --
+ -----------------------------
- 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;
+ procedure Process_Activation_Call
+ (Call : Node_Id;
+ Call_Attrs : Call_Attributes;
+ In_Task_Body : Boolean)
+ is
+ procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id);
+ -- Perform ABE checks and diagnostics for object Obj_Id with type Typ.
+ -- Typ may be a task type or a composite type with at least one task
+ -- component.
- return;
+ procedure Process_Task_Objects (List : List_Id);
+ -- Perform ABE checks and diagnostics for all task objects found in
+ -- the list List.
- -- 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.
+ -------------------------
+ -- Process_Task_Object --
+ -------------------------
- else
- return;
- end if;
- end if;
- end loop;
- end;
- end if;
- end if;
+ procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id) is
+ Base_Typ : constant Entity_Id := Base_Type (Typ);
- Ent := Get_Referenced_Ent (N);
+ Comp_Id : Entity_Id;
+ Task_Attrs : Task_Attributes;
- if No (Ent) then
- return;
- end if;
+ begin
+ if Is_Task_Type (Typ) then
+ Extract_Task_Attributes
+ (Typ => Base_Typ,
+ Attrs => Task_Attrs);
- -- 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.
+ Process_Single_Activation
+ (Call => Call,
+ Call_Attrs => Call_Attrs,
+ Obj_Id => Obj_Id,
+ Task_Attrs => Task_Attrs,
+ In_Task_Body => In_Task_Body);
- declare
- Self : constant Visited_Element :=
- (Subp_Id => Ent, Context => Parent (N));
+ -- Examine the component type when the object is an array
- begin
- for Index in 1 .. Elab_Visited.Last loop
- if Self = Elab_Visited.Table (Index) then
- return;
- end if;
- end loop;
- end;
+ elsif Is_Array_Type (Typ) and then Has_Task (Base_Typ) then
+ Process_Task_Object (Obj_Id, Component_Type (Typ));
- -- See if we need to analyze this reference. We analyze it if either of
- -- the following conditions is met:
+ -- Examine individual component types when the object is a record
- -- 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.
+ elsif Is_Record_Type (Typ) and then Has_Task (Base_Typ) then
+ Comp_Id := First_Component (Typ);
+ while Present (Comp_Id) loop
+ Process_Task_Object (Obj_Id, Etype (Comp_Id));
+ Next_Component (Comp_Id);
+ end loop;
+ end if;
+ end Process_Task_Object;
- -- It is an outer level reference from elaboration code, or a call to
- -- an entity is in the same elaboration scope.
+ --------------------------
+ -- Process_Task_Objects --
+ --------------------------
- -- And in these cases, we will check both inter-unit calls and
- -- intra-unit (within a single unit) calls.
+ procedure Process_Task_Objects (List : List_Id) is
+ Item : Node_Id;
+ Item_Id : Entity_Id;
+ Item_Typ : Entity_Id;
- C_Scope := Current_Scope;
+ begin
+ -- Examine the contents of the list looking for an object declaration
+ -- of a task type or one that contains a task within.
- -- If not outer level reference, then we follow it if it is within the
- -- original scope of the outer reference.
+ Item := First (List);
+ while Present (Item) loop
+ if Nkind (Item) = N_Object_Declaration then
+ Item_Id := Defining_Entity (Item);
+ Item_Typ := Etype (Item_Id);
- if 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;
+ if Has_Task (Item_Typ) then
+ Process_Task_Object (Item_Id, Item_Typ);
+ end if;
+ end if;
- elsif From_Elab_Code then
- Set_C_Scope;
- Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False);
+ Next (Item);
+ end loop;
+ end Process_Task_Objects;
- elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then
- Set_C_Scope;
- Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
+ -- Local variables
- -- 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.
+ Context : Node_Id;
+ Spec : Node_Id;
- elsif Dynamic_Elaboration_Checks then
- Set_C_Scope;
- Check_A_Call
- (N,
- Ent,
- Standard_Standard,
- Inter_Unit_Only => True,
- Generate_Warnings => False);
+ -- Start of processing for Process_Activation_Call
- -- Otherwise nothing to do
+ begin
+ -- Nothing to do when the activation is a guaranteed ABE
- else
+ if Is_Known_Guaranteed_ABE (Call) then
return;
end if;
- -- A call to an Init_Proc in elaboration code may bring additional
- -- dependencies, if some of the record components thereof have
- -- initializations that are function calls that come from source. We
- -- treat the current node as a call to each of these functions, to check
- -- their elaboration impact.
+ -- Find the proper context of the activation call where all task objects
+ -- being activated are declared. This is usually the immediate parent of
+ -- the call.
- if Is_Init_Proc (Ent) and then From_Elab_Code then
- Process_Init_Proc : declare
- Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent);
+ Context := Parent (Call);
- function Check_Init_Call (Nod : Node_Id) return Traverse_Result;
- -- Find subprogram calls within body of Init_Proc for Traverse
- -- instantiation below.
+ -- In the case of package bodies, the activation call is in the handled
+ -- sequence of statements, but the task objects are in the declaration
+ -- list of the body.
- procedure Traverse_Body is new Traverse_Proc (Check_Init_Call);
- -- Traversal procedure to find all calls with body of Init_Proc
+ if Nkind (Context) = N_Handled_Sequence_Of_Statements
+ and then Nkind (Parent (Context)) = N_Package_Body
+ then
+ Context := Parent (Context);
+ end if;
- ---------------------
- -- Check_Init_Call --
- ---------------------
+ -- Process all task objects defined in both the spec and body when the
+ -- activation call precedes the "begin" of a package body.
- function Check_Init_Call (Nod : Node_Id) return Traverse_Result is
- Func : Entity_Id;
+ if Nkind (Context) = N_Package_Body then
+ Spec :=
+ Specification
+ (Unit_Declaration_Node (Corresponding_Spec (Context)));
- begin
- if Nkind (Nod) in N_Subprogram_Call
- and then Is_Entity_Name (Name (Nod))
- then
- Func := Entity (Name (Nod));
+ Process_Task_Objects (Visible_Declarations (Spec));
+ Process_Task_Objects (Private_Declarations (Spec));
+ Process_Task_Objects (Declarations (Context));
- if Comes_From_Source (Func) then
- Check_A_Call
- (N, Func, Standard_Standard, Inter_Unit_Only => True);
- end if;
+ -- Process all task objects defined in the spec when the activation call
+ -- appears at the end of a package spec.
- return OK;
+ elsif Nkind (Context) = N_Package_Specification then
+ Process_Task_Objects (Visible_Declarations (Context));
+ Process_Task_Objects (Private_Declarations (Context));
- else
- return OK;
- end if;
- end Check_Init_Call;
+ -- Otherwise the context of the activation is some construct with a
+ -- declarative part. Note that the corresponding record type of a task
+ -- type is controlled. Because of this, the finalization machinery must
+ -- relocate the task object to the handled statements of the construct
+ -- to perform proper finalization in case of an exception. Examine the
+ -- statements of the construct rather than the declarations.
- -- Start of processing for Process_Init_Proc
+ else
+ pragma Assert (Nkind (Context) = N_Handled_Sequence_Of_Statements);
- begin
- if Nkind (Unit_Decl) = N_Subprogram_Body then
- Traverse_Body (Handled_Statement_Sequence (Unit_Decl));
- end if;
- end Process_Init_Proc;
+ Process_Task_Objects (Statements (Context));
end if;
- end Check_Elab_Call;
-
- -----------------------
- -- Check_Elab_Assign --
- -----------------------
-
- procedure Check_Elab_Assign (N : Node_Id) is
- Ent : Entity_Id;
- Scop : Entity_Id;
+ end Process_Activation_Call;
+
+ ---------------------------------------------
+ -- Process_Activation_Conditional_ABE_Impl --
+ ---------------------------------------------
+
+ procedure Process_Activation_Conditional_ABE_Impl
+ (Call : Node_Id;
+ Call_Attrs : Call_Attributes;
+ Obj_Id : Entity_Id;
+ Task_Attrs : Task_Attributes;
+ In_Task_Body : Boolean)
+ is
+ Check_OK : constant Boolean :=
+ not Is_Ignored_Ghost_Entity (Obj_Id)
+ and then not Task_Attrs.Ghost_Mode_Ignore
+ and then Is_Elaboration_Checks_OK_Id (Obj_Id)
+ and then Task_Attrs.Elab_Checks_OK;
+ -- A run-time ABE check may be installed only when the object and the
+ -- task type have active elaboration checks, and both are not ignored
+ -- Ghost constructs.
- Pkg_Spec : Entity_Id;
- Pkg_Body : Entity_Id;
+ Root : constant Node_Id := Root_Scenario;
begin
- -- For record or array component, check prefix. If it is an access type,
- -- then there is nothing to do (we do not know what is being assigned),
- -- but otherwise this is an assignment to the prefix.
-
- 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;
+ -- Output relevant information when switch -gnatel (info messages on
+ -- implicit Elaborate[_All] pragmas) is in effect.
- return;
+ if Elab_Info_Messages then
+ Error_Msg_NE
+ ("info: activation of & during elaboration", Call, Obj_Id);
end if;
- -- For type conversion, check expression
+ -- Nothing to do when the activation is a guaranteed ABE
- if Nkind (N) = N_Type_Conversion then
- Check_Elab_Assign (Expression (N));
+ if Is_Known_Guaranteed_ABE (Call) then
return;
- end if;
- -- Nothing to do if this is not an entity reference otherwise get entity
+ -- Nothing to do when the root scenario appears at the declaration
+ -- level and the task is in the same unit, but outside this context.
- if Is_Entity_Name (N) then
- Ent := Entity (N);
- else
- return;
- end if;
+ -- task type Task_Typ; -- task declaration
- -- 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.
+ -- procedure Proc is
+ -- function A ... is
+ -- begin
+ -- if Some_Condition then
+ -- declare
+ -- T : Task_Typ;
+ -- begin
+ -- <activation call> -- activation site
+ -- end;
+ -- ...
+ -- end A;
- 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;
+ -- X : ... := A; -- root scenario
+ -- ...
- -- Here Scop points to the containing library package
+ -- task body Task_Typ is
+ -- ...
+ -- end Task_Typ;
- Pkg_Spec := Scop;
- Pkg_Body := Body_Entity (Pkg_Spec);
+ -- 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.
- -- All OK if the package has an Elaborate_Body pragma
+ -- Performance note: parent traversal
- if Has_Pragma_Elaborate_Body (Scop) then
- return;
- end if;
+ elsif Is_Up_Level_Target (Task_Attrs.Task_Decl) then
+ return;
- -- OK if entity being modified is not in containing package spec
+ -- Nothing to do when the activation is ABE-safe
- if not In_Same_Source_Unit (Scop, Ent) then
- return;
- end if;
+ -- generic
+ -- package Gen is
+ -- task type Task_Typ;
+ -- end Gen;
- -- 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.
+ -- package body Gen is
+ -- task body Task_Typ is
+ -- begin
+ -- ...
+ -- end Task_Typ;
+ -- end Gen;
- 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;
+ -- with Gen;
+ -- procedure Main is
+ -- package Nested is
+ -- ...
+ -- end Nested;
- Scop := Scope (Scop);
- end loop;
+ -- package body Nested is
+ -- package Inst is new Gen;
+ -- T : Inst.Task_Typ;
+ -- [begin]
+ -- <activation call> -- safe activation
+ -- end Nested;
+ -- ...
- -- All OK if in task, don't issue warnings there
+ elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then
- if In_Task_Activation then
- return;
- end if;
+ -- Note that the task body must still be examined for any nested
+ -- scenarios.
- -- OK if no package body
+ null;
- if No (Pkg_Body) then
- return;
- end if;
+ -- The activation call and the task body are both in the main unit
- -- OK if reference is not in package body
+ elsif Present (Task_Attrs.Body_Decl)
+ and then In_Extended_Main_Code_Unit (Task_Attrs.Body_Decl)
+ then
+ -- If the root scenario appears prior to the task body, then this is
+ -- a possible ABE with respect to the root scenario.
- if not In_Same_Source_Unit (Pkg_Body, N) then
- return;
- end if;
+ -- task type Task_Typ;
- -- OK if package body has no handled statement sequence
+ -- function A ... is
+ -- begin
+ -- if Some_Condition then
+ -- declare
+ -- package Pack is
+ -- ...
+ -- end Pack;
- 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;
+ -- package body Pack is
+ -- T : Task_Typ;
+ -- [begin]
+ -- <activation call> -- activation of T
+ -- end Pack;
+ -- ...
+ -- end A;
- -- 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.
+ -- X : ... := A; -- root scenario
- Set_Elaborate_Body_Desirable (Pkg_Spec);
+ -- task body Task_Typ is -- task body
+ -- ...
+ -- end Task_Typ;
- -- All OK in gnat mode (we know what we are doing)
+ -- Y : ... := A; -- root scenario
- if GNAT_Mode then
- return;
- end if;
+ -- IMPORTANT: The activation of T is a possible ABE for X, but
+ -- not for Y. Intalling an unconditional ABE raise prior to the
+ -- activation call would be wrong as it will fail for Y as well
+ -- but in Y's case the activation of T is never an ABE.
- -- All OK if all warnings suppressed
+ if Earlier_In_Extended_Unit (Root, Task_Attrs.Body_Decl) then
- if Warning_Mode = Suppress then
- return;
- end if;
+ -- 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.
- -- All OK if elaboration checks suppressed for entity
+ if Static_Elaboration_Checks then
+ Error_Msg_Sloc := Sloc (Call);
+ Error_Msg_N
+ ("??task & will be activated # before elaboration of its "
+ & "body", Obj_Id);
+ Error_Msg_N
+ ("\Program_Error may be raised at run time", Obj_Id);
- if Checks_May_Be_Suppressed (Ent)
- and then Is_Check_Suppressed (Ent, Elaboration_Check)
- then
- return;
- end if;
+ Output_Active_Scenarios (Obj_Id);
+ 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.
+ -- Install a conditional run-time ABE check to verify that the
+ -- task body has been elaborated prior to the activation call.
- 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;
+ if Check_OK then
+ Install_ABE_Check
+ (N => Call,
+ Ins_Nod => Call,
+ Target_Id => Task_Attrs.Spec_Id,
+ Target_Decl => Task_Attrs.Task_Decl,
+ Target_Body => Task_Attrs.Body_Decl);
end if;
- end;
+ end if;
- -- Here is where we give the warning
+ -- Otherwise the task body is not available in this compilation or it
+ -- resides in an external unit. Install a run-time ABE check to verify
+ -- that the task body has been elaborated prior to the activation call
+ -- when the dynamic model is in effect.
- -- All OK if warnings suppressed on the entity
+ elsif Dynamic_Elaboration_Checks and then Check_OK then
+ Install_ABE_Check
+ (N => Call,
+ Ins_Nod => Call,
+ Id => Task_Attrs.Unit_Id);
+ end if;
- if not Has_Warnings_Off (Ent) then
- Error_Msg_Sloc := Sloc (Ent);
+ -- Both the activation call and task type are subject to SPARK_Mode
+ -- On, this triggers the SPARK rules for task activation. Compared to
+ -- calls and instantiations, task activation in SPARK does not require
+ -- the presence of Elaborate[_All] pragmas in case the task type is
+ -- defined outside the main unit. This is because SPARK utilizes a
+ -- special policy which activates all tasks after the main unit has
+ -- finished its elaboration.
- 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 Call_Attrs.SPARK_Mode_On and Task_Attrs.SPARK_Mode_On then
+ null;
- if not All_Errors_Mode then
- Set_Suppress_Elaboration_Warnings (Ent);
- end if;
+ -- Otherwise the Ada rules are in effect. Ensure that the unit with the
+ -- task body is elaborated prior to the main unit.
+
+ else
+ Ensure_Prior_Elaboration
+ (N => Call,
+ Unit_Id => Task_Attrs.Unit_Id,
+ In_Task_Body => In_Task_Body);
end if;
- end Check_Elab_Assign;
- ----------------------
- -- Check_Elab_Calls --
- ----------------------
+ Traverse_Body (Task_Attrs.Body_Decl, In_Task_Body => True);
+ end Process_Activation_Conditional_ABE_Impl;
- -- WARNING: This routine manages SPARK regions
+ procedure Process_Activation_Conditional_ABE is
+ new Process_Activation_Call (Process_Activation_Conditional_ABE_Impl);
- procedure Check_Elab_Calls is
- Saved_SM : SPARK_Mode_Type;
- Saved_SMP : Node_Id;
+ --------------------------------------------
+ -- 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
- -- 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.
+ -- 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;
- if (not Expander_Active and not GNATprove_Mode)
- or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
- or else Subunits_Missing
- then
+ -- 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;
- end if;
- -- Skip delayed calls if we had any errors
+ -- 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.
- if Serious_Errors_Detected = 0 then
- Delaying_Elab_Checks := False;
- Expander_Mode_Save_And_Set (True);
+ -- procedure Guaranteed_ABE is
+ -- task type Task_Typ;
- 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;
+ -- package Nested is
+ -- ...
+ -- end Nested;
- Saved_SM := SPARK_Mode;
- Saved_SMP := SPARK_Mode_Pragma;
+ -- package body Nested is
+ -- T : Task_Typ;
+ -- [begin]
+ -- <activation call> -- guaranteed ABE
+ -- end Nested;
- -- Set appropriate value of SPARK_Mode
+ -- task body Task_Typ is
+ -- ...
+ -- end Task_Typ;
+ -- ...
- if Delay_Check.Table (J).From_SPARK_Code then
- SPARK_Mode := On;
- end if;
+ -- Performance note: parent traversal
- 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);
+ 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);
- Restore_SPARK_Mode (Saved_SM, Saved_SMP);
- Pop_Scope;
- end loop;
+ -- Mark the activation call as a guaranteed ABE
- -- Set Delaying_Elab_Checks back on for next main compilation
+ Set_Is_Known_Guaranteed_ABE (Call);
- Expander_Mode_Restore;
- Delaying_Elab_Checks := True;
+ -- 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 Check_Elab_Calls;
+ end Process_Activation_Guaranteed_ABE_Impl;
- ------------------------------
- -- Check_Elab_Instantiation --
- ------------------------------
+ procedure Process_Activation_Guaranteed_ABE is
+ new Process_Activation_Call (Process_Activation_Guaranteed_ABE_Impl);
- procedure Check_Elab_Instantiation
- (N : Node_Id;
- Outer_Scope : Entity_Id := Empty)
+ ------------------
+ -- Process_Call --
+ ------------------
+
+ procedure Process_Call
+ (Call : Node_Id;
+ Call_Attrs : Call_Attributes;
+ Target_Id : Entity_Id;
+ In_Task_Body : Boolean)
is
- Ent : Entity_Id;
+ SPARK_Rules_On : Boolean;
+ Target_Attrs : Target_Attributes;
begin
- -- Check for and deal with bad instantiation case. There is some
- -- duplicated code here, but we will worry about this later ???
+ Extract_Target_Attributes
+ (Target_Id => Target_Id,
+ Attrs => Target_Attrs);
- Check_Bad_Instantiation (N);
+ -- The SPARK rules are in effect when both the call and target are
+ -- subject to SPARK_Mode On.
- if ABE_Is_Certain (N) then
- return;
- end if;
+ SPARK_Rules_On :=
+ Call_Attrs.SPARK_Mode_On and Target_Attrs.SPARK_Mode_On;
- -- Nothing to do if we do not have an instantiation (happens in some
- -- error cases, and also in the formal package declaration case)
+ -- Output relevant information when switch -gnatel (info messages on
+ -- implicit Elaborate[_All] pragmas) is in effect.
- if Nkind (N) not in N_Generic_Instantiation then
- return;
+ if Elab_Info_Messages then
+ Info_Call
+ (Call => Call,
+ Target_Id => Target_Id,
+ Info_Msg => True,
+ In_SPARK => SPARK_Rules_On);
end if;
- -- Nothing to do if inside a generic template
+ -- 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.
- if Inside_A_Generic then
return;
end if;
- -- Nothing to do if the instantiation is not in the main unit
+ -- Nothing to do when the call is a guaranteed ABE
- if not In_Extended_Main_Code_Unit (N) then
+ if Is_Known_Guaranteed_ABE (Call) then
return;
- end if;
- Ent := Get_Generic_Entity (N);
- From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
+ -- Nothing to do when the root scenario appears at the declaration level
+ -- and the target is in the same unit, but outside this context.
- -- See if we need to analyze this instantiation. We analyze it if
- -- either of the following conditions is met:
+ -- function B ...; -- target declaration
- -- 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.
+ -- procedure Proc is
+ -- function A ... is
+ -- begin
+ -- if Some_Condition then
+ -- return B; -- call site
+ -- ...
+ -- end A;
- -- It is an outer level instantiation from elaboration code, or the
- -- instantiated entity is in the same elaboration scope.
+ -- X : ... := A; -- root scenario
+ -- ...
- -- And in these cases, we will check both the inter-unit case and
- -- the intra-unit (within a single unit) case.
+ -- function B ... is
+ -- ...
+ -- end B;
- C_Scope := Current_Scope;
+ -- In the example above, the context of X is the declarative region of
+ -- Proc. The "elaboration" of X may eventually reach B which is defined
+ -- outside of X's context. B is relevant only when Proc is invoked, but
+ -- this happens only by means of "normal" elaboration, therefore B must
+ -- not be considered if this is not the case.
- if 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);
+ -- Performance note: parent traversal
- elsif From_Elab_Code then
- Set_C_Scope;
- Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False);
+ elsif Is_Up_Level_Target (Target_Attrs.Spec_Decl) then
+ return;
- elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then
- Set_C_Scope;
- Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
+ -- The SPARK rules are in effect
- -- 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 SPARK_Rules_On then
+ Process_Call_SPARK
+ (Call => Call,
+ Call_Attrs => Call_Attrs,
+ Target_Id => Target_Id,
+ Target_Attrs => Target_Attrs);
- elsif Dynamic_Elaboration_Checks then
- Set_C_Scope;
- Check_A_Call
- (N,
- Ent,
- Standard_Standard,
- Inter_Unit_Only => True,
- Generate_Warnings => False);
+ -- Otherwise the Ada rules are in effect
else
- return;
+ 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;
- end Check_Elab_Instantiation;
- -------------------------
- -- Check_Internal_Call --
- -------------------------
+ -- Inspect the target body (and barried function) for other suitable
+ -- elaboration scenarios.
- procedure Check_Internal_Call
- (N : Node_Id;
- E : Entity_Id;
- Outer_Scope : Entity_Id;
- Orig_Ent : Entity_Id)
+ 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)
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.
+ function In_Initialization_Context (N : Node_Id) return Boolean;
+ -- Determine whether arbitrary node N appears within a type init proc or
+ -- primitive [Deep_]Initialize.
- ------------------------------
- -- Within_Initial_Condition --
- ------------------------------
+ -------------------------------
+ -- In_Initialization_Context --
+ -------------------------------
- function Within_Initial_Condition (Call : Node_Id) return Boolean is
- Args : List_Id;
- Nam : Name_Id;
- Par : Node_Id;
+ function In_Initialization_Context (N : Node_Id) return Boolean is
+ Par : Node_Id;
+ Spec_Id : Entity_Id;
begin
- -- Traverse the parent chain looking for an enclosing pragma
+ -- Climb the parent chain looking for initialization actions
- Par := Call;
+ Par := Parent (N);
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, ...).
+ -- A block may be part of the initialization actions of a default
+ -- initialized object.
- if Nam = Name_Check then
- Args := Pragma_Argument_Associations (Par);
-
- -- Pragma Check should have at least two arguments
+ if Nkind (Par) = N_Block_Statement
+ and then Is_Initialization_Block (Par)
+ then
+ return True;
- pragma Assert (Present (Args));
+ -- A subprogram body may denote an initialization routine
- return
- Chars (Expression (First (Args))) = Name_Initial_Condition;
+ elsif Nkind (Par) = N_Subprogram_Body then
+ Spec_Id := Unique_Defining_Entity (Par);
- -- Direct match
+ -- The current subprogram body denotes a type init proc or
+ -- primitive [Deep_]Initialize.
- elsif Nam = Name_Initial_Condition then
+ if Is_Init_Proc (Spec_Id)
+ or else Is_Controlled_Proc (Spec_Id, Name_Initialize)
+ or else Is_TSS (Spec_Id, TSS_Deep_Initialize)
+ then
return True;
-
- -- Since pragmas are never nested within other pragmas, stop
- -- the traversal.
-
- else
- return False;
end if;
-- Prevent the search from going too far
end if;
Par := Parent (Par);
-
- -- If assertions are not enabled, the check pragma is rewritten
- -- as an if_statement in sem_prag, to generate various warnings
- -- on boolean expressions. Retrieve the original pragma.
-
- if Nkind (Original_Node (Par)) = N_Pragma then
- Par := Original_Node (Par);
- end if;
end loop;
return False;
- end Within_Initial_Condition;
+ end In_Initialization_Context;
-- Local variables
- Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
+ 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.
- -- Start of processing for Check_Internal_Call
+ -- Start of processing for Process_Call_Ada
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.
+ -- Nothing to do for an Ada dispatching call because there are no ABE
+ -- diagnostics for either models. ABE checks for the dynamic model are
+ -- handled by Install_Primitive_Elaboration_Check.
- elsif Nkind (N) /= N_Attribute_Reference and then ABE_Is_Certain (N) then
+ if Call_Attrs.Is_Dispatching then
return;
- -- Nothing to do if errors already detected (avoid cascaded errors)
+ -- Nothing to do when the call is ABE-safe
- elsif Serious_Errors_Detected /= 0 then
- return;
-
- -- Nothing to do if not in full analysis mode
+ -- generic
+ -- function Gen ...;
- elsif not Full_Analysis then
- return;
+ -- function Gen ... is
+ -- begin
+ -- ...
+ -- end Gen;
- -- Nothing to do if analyzing in special spec-expression mode, since the
- -- call is not actually being made at this time.
+ -- with Gen;
+ -- procedure Main is
+ -- function Inst is new Gen;
+ -- X : ... := Inst; -- safe call
+ -- ...
- elsif In_Spec_Expression then
+ elsif Is_Safe_Call (Call, Target_Attrs) then
return;
- -- Nothing to do for call to intrinsic subprogram
-
- elsif Is_Intrinsic_Subprogram (E) then
- return;
+ -- The call and the target body are both in the main unit
- -- Nothing to do if call is within a generic 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. Install a run-time ABE check to verify
+ -- that the target body has been elaborated prior to the call site when
+ -- the dynamic model is in effect.
+
+ elsif Dynamic_Elaboration_Checks and then Check_OK then
+ Install_ABE_Check
+ (N => Call,
+ Ins_Nod => Call,
+ Id => Target_Attrs.Unit_Id);
+ end if;
- elsif Inside_A_Generic then
- return;
+ -- No implicit pragma Elaborate[_All] is generated when the call has
+ -- elaboration checks suppressed. This behaviour parallels that of the
+ -- old ABE mechanism.
- -- 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.
+ if not Call_Attrs.Elab_Checks_OK then
+ null;
- elsif Within_Initial_Condition (N) then
- return;
- end if;
+ -- 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.
- -- Delay this call if we are still delaying calls
+ -- Performance note: parent traversal
- 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;
+ 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;
- -- Otherwise, call phase 2 continuation right now
+ -- Otherwise ensure that the unit with the target body is elaborated
+ -- prior to the main unit.
else
- Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent);
+ Ensure_Prior_Elaboration
+ (N => Call,
+ Unit_Id => Target_Attrs.Unit_Id,
+ In_Task_Body => In_Task_Body);
end if;
- end Check_Internal_Call;
+ end Process_Call_Ada;
----------------------------------
- -- Check_Internal_Call_Continue --
+ -- Process_Call_Conditional_ABE --
----------------------------------
- procedure Check_Internal_Call_Continue
- (N : Node_Id;
- E : Entity_Id;
- Outer_Scope : Entity_Id;
- Orig_Ent : Entity_Id)
+ procedure Process_Call_Conditional_ABE
+ (Call : Node_Id;
+ Call_Attrs : Call_Attributes;
+ Target_Id : Entity_Id;
+ Target_Attrs : Target_Attributes)
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
+ 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.
- elsif Nkind (N) = N_Function_Call then
- Check_Elab_Call (N, Outer_Scope);
- return OK;
+ Root : constant Node_Id := Root_Scenario;
- -- 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.
+ begin
+ -- If the root scenario appears prior to the target body, then this is a
+ -- possible ABE with respect to the root scenario.
- 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;
+ -- function B ...;
- -- In SPARK mode, if we have an entity reference to a variable, then
- -- check it. For now we consider any reference.
+ -- function A ... is
+ -- begin
+ -- if Some_Condition then
+ -- return B; -- call site
+ -- ...
+ -- end A;
- 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;
+ -- X : ... := A; -- root scenario
- -- If we have a generic instantiation, check it
+ -- function B ... is -- target body
+ -- ...
+ -- end B;
- elsif Nkind (N) in N_Generic_Instantiation then
- Check_Elab_Instantiation (N, Outer_Scope);
- return OK;
+ -- Y : ... := A; -- root scenario
- -- 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.
+ -- 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.
- -- 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.
+ if Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) then
- elsif Nkind (N) = N_Subprogram_Body
- and then Comes_From_Source (N)
- then
- return Skip;
+ -- 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 Nkind (N) = N_Assignment_Statement
- and then Comes_From_Source (N)
- then
- Check_Elab_Assign (Name (N));
- return OK;
+ 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);
- else
- return OK;
+ Output_Active_Scenarios (Call);
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
+ -- Install a conditional run-time ABE check to verify that the target
+ -- body has been elaborated prior to the call.
- begin
- -- Save outer level call if at outer level
-
- if Elab_Call.Last = 0 then
- Outer_Level_Sloc := Loc;
+ 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;
- -- If the call is to a function that renames a literal, no check needed
+ ---------------------------------
+ -- Process_Call_Guaranteed_ABE --
+ ---------------------------------
- if Ekind (E) = E_Enumeration_Literal then
- return;
- end if;
+ procedure Process_Call_Guaranteed_ABE
+ (Call : Node_Id;
+ Call_Attrs : Call_Attributes;
+ Target_Id : Entity_Id)
+ is
+ Target_Attrs : Target_Attributes;
- -- 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.
+ begin
+ Extract_Target_Attributes
+ (Target_Id => Target_Id,
+ Attrs => Target_Attrs);
- Elab_Visited.Append ((Subp_Id => E, Context => Parent (N)));
+ -- Nothing to do when the root scenario appears at the declaration level
+ -- and the target is in the same unit, but outside this context.
- Sbody := Unit_Declaration_Node (E);
+ -- function B ...; -- target declaration
- if not Nkind_In (Sbody, N_Subprogram_Body, N_Package_Body) then
- Ebody := Corresponding_Body (Sbody);
+ -- procedure Proc is
+ -- function A ... is
+ -- begin
+ -- if Some_Condition then
+ -- return B; -- call site
+ -- ...
+ -- end A;
- if No (Ebody) then
- return;
- else
- Sbody := Unit_Declaration_Node (Ebody);
- end if;
- end if;
+ -- X : ... := A; -- root scenario
+ -- ...
- -- If the body appears after the outer level call or instantiation then
- -- we have an error case handled below.
+ -- function B ... is
+ -- ...
+ -- end B;
- if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody))
- and then not In_Task_Activation
- then
- null;
+ -- In the example above, the context of X is the declarative region of
+ -- Proc. The "elaboration" of X may eventually reach B which is defined
+ -- outside of X's context. B is relevant only when Proc is invoked, but
+ -- this happens only by means of "normal" elaboration, therefore B must
+ -- not be considered if this is not the case.
- -- If we have the instantiation case we are done, since we now know that
- -- the body of the generic appeared earlier.
+ -- Performance note: parent traversal
- elsif Inst_Case then
+ if Is_Up_Level_Target (Target_Attrs.Spec_Decl) 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_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;
+ -- Nothing to do when the call is ABE-safe
- -- Now traverse declarations and statements of subprogram body. Note
- -- that we cannot simply Traverse (Sbody), since traverse does not
- -- normally visit subprogram bodies.
+ -- generic
+ -- function Gen ...;
- declare
- Decl : Node_Id;
- begin
- Decl := First (Declarations (Sbody));
- while Present (Decl) loop
- Traverse (Decl);
- Next (Decl);
- end loop;
- end;
+ -- function Gen ... is
+ -- begin
+ -- ...
+ -- end Gen;
- Traverse (Handled_Statement_Sequence (Sbody));
+ -- with Gen;
+ -- procedure Main is
+ -- function Inst is new Gen;
+ -- X : ... := Inst; -- safe call
+ -- ...
- Elab_Call.Decrement_Last;
+ elsif Is_Safe_Call (Call, Target_Attrs) then
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).
+ -- 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.
- exit when not Nkind_In (P, N_If_Statement, N_Null_Statement);
+ -- procedure Guaranteed_ABE is
+ -- function Func ...;
- -- Our special case will be indicated either by the pragma
- -- coming from an aspect ...
+ -- package Nested is
+ -- Obj : ... := Func; -- guaranteed ABE
+ -- end Nested;
- if Present (Corresponding_Aspect (O)) then
- return;
+ -- function Func ... is
+ -- ...
+ -- end Func;
+ -- ...
- -- Or, in the case of an initial condition, specifically by a
- -- Check pragma specifying an Initial_Condition check.
+ -- Performance note: parent traversal
- elsif Pragma_Name (O) = Name_Check
- and then
- Chars
- (Expression (First (Pragma_Argument_Associations (O)))) =
- Name_Initial_Condition
- then
- return;
+ 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);
- -- For anything else, we have an error
+ -- Mark the call as a guarnateed ABE
- else
- exit;
- end if;
- end if;
- end loop;
- end;
+ Set_Is_Known_Guaranteed_ABE (Call);
- -- Not that special case, warning and dynamic check is required
+ -- 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 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 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;
- if Elab_Call.Last = 0 then
- Error_Msg_Warn := SPARK_Mode /= On;
+ ------------------------
+ -- Process_Call_SPARK --
+ ------------------------
- declare
- Insert_Check : Boolean := True;
- -- This flag is set to True if an elaboration check should be
- -- inserted.
+ 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;
- begin
- if In_Task_Activation then
- Insert_Check := False;
+ -- Nothing to do when the call is ABE-safe
- elsif Inst_Case then
- Error_Msg_NE
- ("cannot instantiate& before body seen<<", N, Orig_Ent);
+ -- generic
+ -- function Gen ...;
- 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;
+ -- function Gen ... is
+ -- begin
+ -- ...
+ -- end Gen;
- elsif Nkind (Unit_Declaration_Node (Orig_Ent)) /=
- N_Subprogram_Renaming_Declaration
- then
- Error_Msg_NE
- ("cannot call& before body seen<<", N, Orig_Ent);
+ -- with Gen;
+ -- procedure Main is
+ -- function Inst is new Gen;
+ -- X : ... := Inst; -- safe call
+ -- ...
- elsif not Is_Generic_Actual_Subprogram (Orig_Ent) then
- Insert_Check := False;
- end if;
+ if Is_Safe_Call (Call, Target_Attrs) then
+ return;
- if Insert_Check then
- Error_Msg_N ("\Program_Error [<<", N);
- Insert_Elab_Check (N);
- end if;
- end;
+ -- The call and the target body are both in the main unit
- -- Call is not at outer level
+ 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
- -- 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
+ null;
+ end if;
+ end Process_Call_SPARK;
- if not Suppress_Elaboration_Warnings (E)
- and then not Elaboration_Checks_Suppressed (E)
+ ----------------------------
+ -- Process_Guaranteed_ABE --
+ ----------------------------
- -- 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.
+ procedure Process_Guaranteed_ABE (N : Node_Id) is
+ Call_Attrs : Call_Attributes;
+ Target_Id : Entity_Id;
- 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;
+ begin
+ -- Add the current scenario to the stack of active scenarios
- 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.
+ Push_Active_Scenario (N);
- 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;
+ -- Only calls, instantiations, and task activations may result in a
+ -- guaranteed ABE.
- -- Go ahead and give warning if not this special case
+ if Is_Suitable_Call (N) then
+ Extract_Call_Attributes
+ (Call => N,
+ Target_Id => Target_Id,
+ Attrs => Call_Attrs);
- Error_Msg_NE
- ("call to& may occur before body is seen<l<", N, Orig_Ent);
- end if;
+ if Is_Activation_Proc (Target_Id) then
+ Process_Activation_Guaranteed_ABE
+ (Call => N,
+ Call_Attrs => Call_Attrs,
+ In_Task_Body => False);
- Error_Msg_N ("\Program_Error ]<l<", N);
+ else
+ Process_Call_Guaranteed_ABE
+ (Call => N,
+ Call_Attrs => Call_Attrs,
+ Target_Id => Target_Id);
+ end if;
- -- There is no need to query the elaboration warning message flags
- -- because the main message is an error, not a warning, therefore
- -- all the clarification messages produces by Output_Calls must be
- -- emitted unconditionally.
+ elsif Is_Suitable_Instantiation (N) then
+ Process_Instantiation_Guaranteed_ABE (N);
+ end if;
- <<Output>>
+ -- Remove the current scenario from the stack of active scenarios once
+ -- all ABE diagnostics and checks have been performed.
- Output_Calls (N, Check_Elab_Flag => False);
- end if;
- end if;
- end Check_Internal_Call_Continue;
+ Pop_Active_Scenario (N);
+ end Process_Guaranteed_ABE;
---------------------------
- -- Check_Task_Activation --
+ -- Process_Instantiation --
---------------------------
- 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.
+ procedure Process_Instantiation
+ (Exp_Inst : Node_Id;
+ In_Task_Body : Boolean)
+ is
+ Gen_Attrs : Target_Attributes;
+ Gen_Id : Entity_Id;
+ Inst : Node_Id;
+ Inst_Attrs : Instantiation_Attributes;
+ Inst_Id : Entity_Id;
- -------------------
- -- Add_Task_Proc --
- -------------------
+ SPARK_Rules_On : Boolean;
+ -- This flag is set when the SPARK rules are in effect
- procedure Add_Task_Proc (Typ : Entity_Id) is
- Comp : Entity_Id;
- Proc : Entity_Id := Empty;
+ begin
+ Extract_Instantiation_Attributes
+ (Exp_Inst => Exp_Inst,
+ Inst => Inst,
+ Inst_Id => Inst_Id,
+ Gen_Id => Gen_Id,
+ Attrs => Inst_Attrs);
- begin
- if Is_Task_Type (Typ) then
- Proc := Get_Task_Body_Procedure (Typ);
+ Extract_Target_Attributes (Gen_Id, Gen_Attrs);
- elsif Is_Array_Type (Typ)
- and then Has_Task (Base_Type (Typ))
- then
- Add_Task_Proc (Component_Type (Typ));
+ -- The SPARK rules are in effect when both the instantiation and generic
+ -- are subject to SPARK_Mode On.
- 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;
+ SPARK_Rules_On := Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On;
- -- If the task type is another unit, we will perform the usual
- -- elaboration check on its enclosing unit. If the type is in the
- -- same unit, we can trace the task body as for an internal call,
- -- but we only need to examine other external calls, because at
- -- the point the task is activated, internal subprogram bodies
- -- will have been elaborated already. We keep separate lists for
- -- each kind of task.
+ -- Output relevant information when switch -gnatel (info messages on
+ -- implicit Elaborate[_All] pragmas) is in effect.
- -- Skip this test if errors have occurred, since in this case
- -- we can get false indications.
+ if Elab_Info_Messages then
+ Info_Instantiation
+ (Inst => Inst,
+ Gen_Id => Gen_Id,
+ Info_Msg => True,
+ In_SPARK => SPARK_Rules_On);
+ end if;
- if Serious_Errors_Detected /= 0 then
- return;
- end if;
+ -- Nothing to do when the instantiation is a guaranteed ABE
- if Present (Proc) then
- if Outer_Unit (Scope (Proc)) = Enclosing then
+ if Is_Known_Guaranteed_ABE (Inst) then
+ return;
- 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;
+ -- Nothing to do when the root scenario appears at the declaration level
+ -- and the generic is in the same unit, but outside this context.
- else
- -- No need for multiple entries of the same type
+ -- generic
+ -- procedure Gen is ...; -- generic declaration
- Elmt := First_Elmt (Inter_Procs);
- while Present (Elmt) loop
- if Node (Elmt) = Proc then
- return;
- end if;
+ -- procedure Proc is
+ -- function A ... is
+ -- begin
+ -- if Some_Condition then
+ -- declare
+ -- procedure I is new Gen; -- instantiation site
+ -- ...
+ -- ...
+ -- end A;
- Next_Elmt (Elmt);
- end loop;
+ -- X : ... := A; -- root scenario
+ -- ...
- Append_Elmt (Proc, Inter_Procs);
- end if;
- end if;
- end Add_Task_Proc;
+ -- procedure Gen is
+ -- ...
+ -- end Gen;
- -------------------
- -- Collect_Tasks --
- -------------------
+ -- 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.
- 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;
+ -- Performance note: parent traversal
- Next (Decl);
- end loop;
- end if;
- end Collect_Tasks;
+ elsif Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then
+ return;
- ----------------
- -- Outer_Unit --
- ----------------
+ -- The SPARK rules are in effect
- function Outer_Unit (E : Entity_Id) return Entity_Id is
- Outer : Entity_Id;
+ elsif SPARK_Rules_On then
+ Process_Instantiation_SPARK
+ (Exp_Inst => Exp_Inst,
+ Inst => Inst,
+ Inst_Attrs => Inst_Attrs,
+ Gen_Id => Gen_Id,
+ Gen_Attrs => Gen_Attrs);
- begin
- Outer := E;
- while Present (Outer) loop
- if Elaboration_Checks_Suppressed (Outer) then
- Cunit_SC := True;
- end if;
+ -- Otherwise the Ada rules are in effect
- exit when Is_Child_Unit (Outer)
- or else Scope (Outer) = Standard_Standard
- or else Ekind (Outer) /= E_Package;
- Outer := Scope (Outer);
- end loop;
+ 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;
- return Outer;
- end Outer_Unit;
+ -------------------------------
+ -- Process_Instantiation_Ada --
+ -------------------------------
- -- Start of processing for Check_Task_Activation
+ procedure Process_Instantiation_Ada
+ (Exp_Inst : Node_Id;
+ Inst : Node_Id;
+ Inst_Attrs : Instantiation_Attributes;
+ Gen_Id : Entity_Id;
+ Gen_Attrs : Target_Attributes;
+ In_Task_Body : Boolean)
+ is
+ Check_OK : constant Boolean :=
+ not Inst_Attrs.Ghost_Mode_Ignore
+ and then not Gen_Attrs.Ghost_Mode_Ignore
+ and then Inst_Attrs.Elab_Checks_OK
+ and then Gen_Attrs.Elab_Checks_OK;
+ -- A run-time ABE check may be installed only when both the instance and
+ -- the generic have active elaboration checks and both are not ignored
+ -- Ghost constructs.
begin
- Enclosing := Outer_Unit (Current_Scope);
+ -- Nothing to do when the instantiation is ABE-safe
- -- Find all tasks declared in the current unit
+ -- generic
+ -- package Gen is
+ -- ...
+ -- end Gen;
- if Nkind (N) = N_Package_Body then
- P := Unit_Declaration_Node (Corresponding_Spec (N));
+ -- package body Gen is
+ -- ...
+ -- end Gen;
- Collect_Tasks (Declarations (N));
- Collect_Tasks (Visible_Declarations (Specification (P)));
- Collect_Tasks (Private_Declarations (Specification (P)));
+ -- with Gen;
+ -- procedure Main is
+ -- package Inst is new Gen (ABE); -- safe instantiation
+ -- ...
- elsif Nkind (N) = N_Package_Declaration then
- Collect_Tasks (Visible_Declarations (Specification (N)));
- Collect_Tasks (Private_Declarations (Specification (N)));
+ if Is_Safe_Instantiation (Inst, Gen_Attrs) then
+ return;
- else
- Collect_Tasks (Declarations (N));
- end if;
+ -- The instantiation and the generic body are both in the main unit
- -- 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.
+ elsif Present (Gen_Attrs.Body_Decl)
+ and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl)
+ then
+ Process_Instantiation_Conditional_ABE
+ (Exp_Inst => Exp_Inst,
+ Inst => Inst,
+ Inst_Attrs => Inst_Attrs,
+ Gen_Id => Gen_Id,
+ Gen_Attrs => Gen_Attrs);
+
+ -- Otherwise the generic body is not available in this compilation or it
+ -- resides in an external unit. Install a run-time ABE check to verify
+ -- that the generic body has been elaborated prior to the instantiation
+ -- when the dynamic model is in effect.
+
+ elsif Dynamic_Elaboration_Checks and then Check_OK then
+ Install_ABE_Check
+ (N => Inst,
+ Ins_Nod => Exp_Inst,
+ Id => Gen_Attrs.Unit_Id);
+ end if;
- -- Should dynamic checks be added in the more general case???
+ -- 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.
- if Ekind (Enclosing) /= E_Package then
- return;
+ 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.
- -- For task types defined in other units, we want the unit containing
- -- the task body to be elaborated before the current one.
+ Root : constant Node_Id := Root_Scenario;
- Elmt := First_Elmt (Inter_Procs);
- while Present (Elmt) loop
- Ent := Node (Elmt);
- Task_Scope := Outer_Unit (Scope (Ent));
+ begin
+ -- If the root scenario appears prior to the generic body, then this is
+ -- a possible ABE with respect to the root scenario.
- if not Is_Compilation_Unit (Task_Scope) then
- null;
+ -- generic
+ -- package Gen is
+ -- ...
+ -- end Gen;
- elsif Suppress_Elaboration_Warnings (Task_Scope)
- or else Elaboration_Checks_Suppressed (Task_Scope)
- then
- null;
+ -- function A ... is
+ -- begin
+ -- if Some_Condition then
+ -- declare
+ -- package Inst is new Gen; -- instantiation site
+ -- ...
+ -- end A;
- 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;
+ -- X : ... := A; -- root scenario
- else
- -- Force the binder to elaborate other unit first
+ -- package body Gen is -- generic body
+ -- ...
+ -- end Gen;
- 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;
+ -- Y : ... := A; -- root scenario
- Activate_Elaborate_All_Desirable (N, Task_Scope);
- Set_Suppress_Elaboration_Warnings (Task_Scope);
- end if;
+ -- 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.
- Next_Elmt (Elmt);
- end loop;
+ 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.
- -- For tasks declared in the current unit, trace other calls within the
- -- task procedure bodies, which are available.
+ 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);
- if not Debug_Flag_Dot_Y then
- In_Task_Activation := True;
+ Output_Active_Scenarios (Inst);
+ end if;
- 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;
+ -- Install a conditional run-time ABE check to verify that the
+ -- generic body has been elaborated prior to the instantiation.
- In_Task_Activation := False;
+ 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 Check_Task_Activation;
+ end Process_Instantiation_Conditional_ABE;
- -------------------------------
- -- Is_Call_Of_Generic_Formal --
- -------------------------------
+ ------------------------------------------
+ -- Process_Instantiation_Guaranteed_ABE --
+ ------------------------------------------
- function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean is
- begin
- return Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
+ 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;
- -- Always return False if debug flag -gnatd.G is set
+ 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;
- and then not Debug_Flag_Dot_GG
+ -- Nothing to do when the instantiation is ABE-safe
- -- 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.
+ -- generic
+ -- package Gen is
+ -- ...
+ -- end Gen;
- and then Nkind (Name (N)) = N_Identifier
- and then Chars (Name (N)) /= Chars (Entity (Name (N)));
- end Is_Call_Of_Generic_Formal;
+ -- package body Gen is
+ -- ...
+ -- end Gen;
- --------------------------------
- -- Set_Elaboration_Constraint --
- --------------------------------
+ -- with Gen;
+ -- procedure Main is
+ -- package Inst is new Gen (ABE); -- safe instantiation
+ -- ...
- procedure Set_Elaboration_Constraint
- (Call : Node_Id;
- Subp : Entity_Id;
- Scop : Entity_Id)
- is
- Elab_Unit : Entity_Id;
+ elsif Is_Safe_Instantiation (Inst, Gen_Attrs) then
+ return;
- -- 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.
+ -- 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.
- 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)));
+ -- procedure Guaranteed_ABE is
+ -- generic
+ -- procedure Gen;
- begin
- -- If the unit is mentioned in a with_clause of the current unit, it is
- -- visible, and we can set the elaboration flag.
+ -- package Nested is
+ -- procedure Inst is new Gen; -- guaranteed ABE
+ -- end Nested;
- 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;
+ -- procedure Gen is
+ -- ...
+ -- end Gen;
+ -- ...
- -- 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.
+ -- Performance note: parent traversal
- if Is_Init_Proc (Subp)
- or else Init_Call
- or else Nkind (Original_Node (Call)) = N_Selected_Component
+ elsif Is_Guaranteed_ABE
+ (N => Inst,
+ Target_Decl => Gen_Attrs.Spec_Decl,
+ Target_Body => Gen_Attrs.Body_Decl)
then
- null; -- detailed processing follows.
+ Error_Msg_NE
+ ("??cannot instantiate & before body seen", Inst, Gen_Id);
+ Error_Msg_N ("\Program_Error will be raised at run time", Inst);
- else
- Activate_Elaborate_All_Desirable (Call, Scop);
- Set_Suppress_Elaboration_Warnings (Scop);
- return;
- end if;
+ -- Mark the instantiation as a guarantee ABE. This automatically
+ -- suppresses the instantiation of the generic body.
- -- 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.
+ Set_Is_Known_Guaranteed_ABE (Inst);
- if Is_Init_Proc (Subp) or else Init_Call then
+ -- 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.
- -- 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.
+ if Inst_Attrs.Elab_Checks_OK
+ and then Gen_Attrs.Elab_Checks_OK
+ and then not Inst_Attrs.Ghost_Mode_Ignore
+ and then not Gen_Attrs.Ghost_Mode_Ignore
+ then
+ Install_ABE_Failure
+ (N => Inst,
+ Ins_Nod => Exp_Inst);
+ end if;
+ end if;
+ end Process_Instantiation_Guaranteed_ABE;
+
+ ---------------------------------
+ -- Process_Instantiation_SPARK --
+ ---------------------------------
+
+ procedure Process_Instantiation_SPARK
+ (Exp_Inst : Node_Id;
+ Inst : Node_Id;
+ Inst_Attrs : Instantiation_Attributes;
+ Gen_Id : Entity_Id;
+ Gen_Attrs : Target_Attributes)
+ is
+ Req_Nam : Name_Id;
- 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;
+ begin
+ -- 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 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.
+ if Nkind (Inst) = N_Package_Instantiation then
+ Req_Nam := Name_Elaborate;
+ else
+ Req_Nam := Name_Elaborate_All;
+ end if;
- elsif Nkind (Original_Node (Call)) = N_Selected_Component then
- Elab_Unit := Scope (Etype (First (Parameter_Associations (Call))));
+ Meet_Elaboration_Requirement
+ (N => Inst,
+ Target_Id => Gen_Id,
+ Req_Nam => Req_Nam);
- -- Not one of special cases above
+ -- Nothing to do when the instantiation is ABE-safe
- 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.
+ -- generic
+ -- package Gen is
+ -- ...
+ -- end Gen;
- Elab_Unit := Scop;
- end if;
+ -- package body Gen is
+ -- ...
+ -- end Gen;
- Activate_Elaborate_All_Desirable (Call, Elab_Unit);
- Set_Suppress_Elaboration_Warnings (Elab_Unit);
- end Set_Elaboration_Constraint;
+ -- with Gen;
+ -- procedure Main is
+ -- package Inst is new Gen (ABE); -- safe instantiation
+ -- ...
- ------------------------
- -- Get_Referenced_Ent --
- ------------------------
+ if Is_Safe_Instantiation (Inst, Gen_Attrs) then
+ return;
- function Get_Referenced_Ent (N : Node_Id) return Entity_Id is
- Nam : Node_Id;
+ -- The instantiation and the generic body are both in the main unit
- begin
- if Nkind (N) in N_Has_Entity
- and then Present (Entity (N))
- and then Ekind (Entity (N)) = E_Variable
+ elsif Present (Gen_Attrs.Body_Decl)
+ and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl)
then
- return Entity (N);
- end if;
+ 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.
- if Nkind (N) = N_Attribute_Reference then
- Nam := Prefix (N);
else
- Nam := Name (N);
+ null;
end if;
+ end Process_Instantiation_SPARK;
- 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;
+ ---------------------------------
+ -- Process_Variable_Assignment --
+ ---------------------------------
- ----------------------
- -- Has_Generic_Body --
- ----------------------
+ procedure Process_Variable_Assignment (Asmt : Node_Id) is
+ Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (Asmt));
+ Spec_Id : Entity_Id;
- 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
+ -- Output relevant information when switch -gnatel (info messages on
+ -- implicit Elaborate[_All] pragmas) is in effect.
- begin
- Nod := N;
- while Present (Nod) loop
+ if Elab_Info_Messages then
+ Error_Msg_NE
+ ("info: assignment to & during elaboration", Asmt, Var_Id);
+ end if;
- -- If we found the package body we are looking for, return it
+ Spec_Id := Find_Top_Unit (Var_Id);
- if Nkind (Nod) = N_Package_Body
- and then Chars (Defining_Unit_Name (Nod)) = Chars (E)
- then
- return Nod;
+ -- Generate an implicit Elaborate_Body in the spec
- -- If we found the stub for the body, go after the subunit,
- -- loading it if necessary.
+ Set_Elaborate_Body_Desirable (Spec_Id);
- 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));
+ -- No warning is emitted for internal uses. This behaviour parallels
+ -- that of the old ABE mechanism.
- else
- return Load_Package_Body (Get_Unit_Name (Nod));
- end if;
+ if GNAT_Mode then
+ null;
- -- If neither package body nor stub, keep looking on chain
+ else
+ Error_Msg_NE
+ ("??variable & can be accessed by clients before this "
+ & "initialization", Asmt, Var_Id);
- else
- Next (Nod);
- end if;
- end loop;
+ Error_Msg_NE
+ ("\add pragma ""Elaborate_Body"" to spec & to ensure proper "
+ & "initialization", Asmt, Spec_Id);
- return Empty;
- end Find_Body_In;
+ Output_Active_Scenarios (Asmt);
+ end if;
+ end Process_Variable_Assignment;
- -----------------------
- -- Load_Package_Body --
- -----------------------
+ --------------------------------
+ -- Process_Variable_Reference --
+ --------------------------------
- function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is
- U : Unit_Number_Type;
+ procedure Process_Variable_Reference (Ref : Node_Id) is
+ Var_Attrs : Variable_Attributes;
+ Var_Id : Entity_Id;
- begin
- if Operating_Mode /= Generate_Code then
- return Empty;
- else
- U :=
- Load_Unit
- (Load_Name => Nam,
- Required => False,
- Subunit => False,
- Error_Node => N);
+ begin
+ Extract_Variable_Reference_Attributes
+ (Ref => Ref,
+ Var_Id => Var_Id,
+ Attrs => Var_Attrs);
+
+ -- Output relevant information when switch -gnatel (info messages on
+ -- implicit Elaborate[_All] pragmas) is in effect.
+
+ if Elab_Info_Messages then
+ Elab_Msg_NE
+ (Msg => "reference to variable & during elaboration",
+ N => Ref,
+ Id => Var_Id,
+ Info_Msg => True,
+ In_SPARK => True);
+ end if;
- if U = No_Unit then
- return Empty;
- else
- return Unit (Cunit (U));
- end if;
- end if;
- end Load_Package_Body;
+ -- A source variable reference imposes an Elaborate_All requirement on
+ -- the context of the main unit. Determine whethe the context has a
+ -- pragma strong enough to meet the requirement.
- -------------------------------
- -- Locate_Corresponding_Body --
- -------------------------------
+ Meet_Elaboration_Requirement
+ (N => Ref,
+ Target_Id => Var_Id,
+ Req_Nam => Name_Elaborate_All);
+ end Process_Variable_Reference;
- 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;
+ --------------------------
+ -- Push_Active_Scenario --
+ --------------------------
- begin
- if Is_Library_Level_Entity (PE) then
+ procedure Push_Active_Scenario (N : Node_Id) is
+ begin
+ Scenario_Stack.Append (N);
+ end Push_Active_Scenario;
- -- 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.
+ ----------------------
+ -- Process_Scenario --
+ ----------------------
- if Unit_Requires_Body (PE) then
+ procedure Process_Scenario (N : Node_Id; In_Task_Body : Boolean := False) is
+ Call_Attrs : Call_Attributes;
+ Target_Id : Entity_Id;
- -- 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.
+ begin
+ -- Add the current scenario to the stack of active scenarios
- return
- Load_Package_Body
- (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec))));
+ Push_Active_Scenario (N);
- -- 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.
+ -- 'Access
- else
- return Empty;
- end if;
+ if Is_Suitable_Access (N) then
+ Process_Access (N, In_Task_Body);
- -- Otherwise look and see if we are embedded in a further package
+ -- Calls
- elsif Is_Package_Or_Generic_Package (Scop) then
+ elsif Is_Suitable_Call (N) then
- -- If so, get the body of the enclosing package, and look in
- -- its package body for the package body we are looking for.
+ -- In general, only calls found within the main unit are processed
+ -- because the ALI information supplied to binde is for the main
+ -- unit only. However, to preserve the consistency of the tree and
+ -- ensure proper serialization of internal names, external calls
+ -- also receive corresponding call markers (see Build_Call_Marker).
+ -- Regardless of the reason, external calls must not be processed.
- PBody := Locate_Corresponding_Body (Scop);
+ if In_Main_Context (N) then
+ Extract_Call_Attributes
+ (Call => N,
+ Target_Id => Target_Id,
+ Attrs => Call_Attrs);
+
+ if Is_Activation_Proc (Target_Id) then
+ Process_Activation_Conditional_ABE
+ (Call => N,
+ Call_Attrs => Call_Attrs,
+ In_Task_Body => In_Task_Body);
- if No (PBody) then
- return Empty;
else
- return Find_Body_In (PE, First (Declarations (PBody)));
+ Process_Call
+ (Call => N,
+ Call_Attrs => Call_Attrs,
+ Target_Id => Target_Id,
+ In_Task_Body => In_Task_Body);
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;
+ -- Instantiations
- -- Compilation units cannot have optional bodies
+ elsif Is_Suitable_Instantiation (N) then
+ Process_Instantiation (N, In_Task_Body);
- elsif Is_Compilation_Unit (Ent) then
- return False;
-
- -- Otherwise look at what scope we are in
+ -- Variable assignments
- else
- Scop := Scope (Ent);
+ elsif Is_Suitable_Variable_Assignment (N) then
+ Process_Variable_Assignment (N);
- -- Case of entity is in other than a package spec, in this case
- -- the body, if present, must be in the same declarative part.
+ -- Variable references
- if not Is_Package_Or_Generic_Package (Scop) then
- declare
- P : Node_Id;
+ elsif Is_Suitable_Variable_Reference (N) then
+ Process_Variable_Reference (N);
+ end if;
- begin
- -- Declaration node may get us a spec, so if so, go to
- -- the parent declaration.
+ -- Remove the current scenario from the stack of active scenarios once
+ -- all ABE diagnostics and checks have been performed.
- P := Declaration_Node (Ent);
- while not Is_List_Member (P) loop
- P := Parent (P);
- end loop;
+ Pop_Active_Scenario (N);
+ end Process_Scenario;
- return Present (Find_Body_In (Ent, Next (P)));
- end;
+ ---------------------------------
+ -- Record_Elaboration_Scenario --
+ ---------------------------------
- -- If the entity is in a package spec, then we have to locate
- -- the corresponding package body, and look there.
+ procedure Record_Elaboration_Scenario (N : Node_Id) is
+ Level : Enclosing_Level_Kind;
- else
- declare
- PBody : constant Node_Id := Locate_Corresponding_Body (Scop);
+ Declaration_Level_OK : Boolean;
+ -- This flag is set when a particular scenario is allowed to appear at
+ -- the declaration level.
- 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;
+ begin
+ -- Assume that the scenario must not appear at the declaration level
- -----------------------
- -- Insert_Elab_Check --
- -----------------------
+ Declaration_Level_OK := False;
- procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is
- Nod : Node_Id;
- Loc : constant Source_Ptr := Sloc (N);
+ -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics
+ -- are performed in this mode.
- Chk : Node_Id;
- -- The check (N_Raise_Program_Error) node to be inserted
+ if ASIS_Mode then
+ return;
- 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.
+ -- Nothing to do when the scenario is being preanalyzed
- if not Expander_Active or else Subunits_Missing then
+ elsif Preanalysis_Active 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.
+ -- Ensure that a library level call does not appear in a preelaborated
+ -- unit. The check must come before ignoring scenarios within external
+ -- units or inside generics because calls in those context must also be
+ -- verified.
- if Nkind (N) in N_Generic_Instantiation
- and then Present (Instance_Spec (N))
- then
- Nod := Instance_Spec (N);
- else
- Nod := N;
+ if Is_Suitable_Call (N) then
+ Check_Preelaborated_Call (N);
end if;
- -- Build check node, possibly with condition
+ -- Nothing to do when the scenario does not appear within the main unit
- Chk :=
- Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration);
+ if not In_Main_Context (N) then
+ return;
- if Present (C) then
- Set_Condition (Chk, Make_Op_Not (Loc, Right_Opnd => C));
- end if;
+ -- Scenarios within a generic unit are never considered because generics
+ -- cannot be elaborated.
- -- If we are inserting at the top level, insert in Aux_Decls
+ elsif Inside_A_Generic then
+ return;
- if Nkind (Parent (Nod)) = N_Compilation_Unit then
- declare
- ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod));
+ -- Scenarios which do not fall in one of the elaboration categories
+ -- listed below are not considered. The categories are:
- begin
- if No (Declarations (ADN)) then
- Set_Declarations (ADN, New_List (Chk));
- else
- Append_To (Declarations (ADN), Chk);
- end if;
+ -- 'Access for entries, operators, and subprograms
+ -- Calls (includes task activation)
+ -- Instantiations
+ -- Variable assignments
+ -- Variable references
+
+ elsif Is_Suitable_Access (N)
+ or else Is_Suitable_Variable_Assignment (N)
+ or else Is_Suitable_Variable_Reference (N)
+ then
+ null;
- Analyze (Chk);
- end;
+ elsif Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N) then
+ Declaration_Level_OK := True;
- -- Otherwise just insert as an action on the node in question
+ -- Otherwise the input does not denote a suitable scenario
else
- Insert_Action (Nod, Chk);
+ return;
end if;
- end Insert_Elab_Check;
-
- -------------------------------
- -- 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:
+ -- The static model imposes additional restrictions on the placement of
+ -- scenarios. In contrast, the dynamic model assumes that every scenario
+ -- will be elaborated or invoked at some point.
- -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]);
+ if Static_Elaboration_Checks then
- -- Recover the two possible versions of [Deep_]Finalize using the
- -- type of the first parameter and compare with the input.
+ -- Performance note: parent traversal
- Deep_Fin := TSS (Typ, TSS_Deep_Finalize);
+ Level := Find_Enclosing_Level (N);
- if Is_Controlled (Typ) then
- Fin := Find_Prim_Op (Typ, Name_Finalize);
- end if;
+ -- Declaration level scenario
- return (Present (Deep_Fin) and then Id = Deep_Fin)
- or else (Present (Fin) and then Id = Fin);
- end;
- end if;
+ if Declaration_Level_OK and then Level = Declaration_Level then
+ null;
- return False;
- end Is_Finalization_Procedure;
+ -- Library level scenario
- ------------------
- -- Output_Calls --
- ------------------
+ elsif Level in Library_Level then
+ null;
- 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.
+ -- Instantiation library level scenario
- 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).
+ elsif Level = Instantiation then
+ null;
- ----------
- -- Emit --
- ----------
+ -- Otherwise the scenario does not appear at the proper level and
+ -- cannot possibly act as a top level scenario.
- function Emit (Flag : Boolean) return Boolean is
- begin
- if Check_Elab_Flag then
- return Flag;
else
- return True;
+ return;
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;
+ end if;
- elsif Name_Len = 1 then
- return False;
+ -- Perform early detection of guaranteed ABEs in order to suppress the
+ -- instantiation of generic bodies as gigi cannot handle certain types
+ -- of premature instantiations.
- else
- Name_Len := Name_Len - 1;
- return not Is_Internal_Name;
- end if;
- end Is_Printable_Error_Name;
+ Process_Guaranteed_ABE (N);
- -- Local variables
+ -- At this point all checks have been performed. Record the scenario for
+ -- later processing by the ABE phase.
- Ent : Entity_Id;
+ Top_Level_Scenarios.Append (N);
- -- Start of processing for Output_Calls
+ -- Mark a scenario which may produce run-time conditional ABE checks or
+ -- guaranteed ABE failures as recorded. The flag ensures that scenario
+ -- rewritting performed by Atree.Rewrite will be properly reflected in
+ -- all relevant internal data structures.
- begin
- for J in reverse 1 .. Elab_Call.Last loop
- Error_Msg_Sloc := Elab_Call.Table (J).Cloc;
+ if Is_Check_Emitting_Scenario (N) then
+ Set_Is_Recorded_Scenario (N);
+ end if;
+ end Record_Elaboration_Scenario;
- Ent := Elab_Call.Table (J).Ent;
- Get_Name_String (Chars (Ent));
+ -------------------
+ -- Root_Scenario --
+ -------------------
- -- Dynamic elaboration model, warnings controlled by -gnatwl
+ function Root_Scenario return Node_Id is
+ package Stack renames Scenario_Stack;
- 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;
+ begin
+ -- Ensure that the scenario stack has at least one active scenario in
+ -- it. The one at the bottom (index First) is the root scenario.
- -- Static elaboration model, info messages controlled by -gnatel
+ pragma Assert (Stack.Last >= Stack.First);
+ return Stack.Table (Stack.First);
+ end Root_Scenario;
- 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;
+ -------------------------------
+ -- Static_Elaboration_Checks --
+ -------------------------------
- ----------------------------
- -- Same_Elaboration_Scope --
- ----------------------------
+ function Static_Elaboration_Checks return Boolean is
+ begin
+ return not Dynamic_Elaboration_Checks;
+ end Static_Elaboration_Checks;
- function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is
- S1 : Entity_Id;
- S2 : Entity_Id;
+ -------------------
+ -- Traverse_Body --
+ -------------------
- begin
- -- Find elaboration scope for Scop1
- -- This is either a subprogram or a compilation unit.
+ 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.
- S1 := Scop1;
- while S1 /= Standard_Standard
- and then not Is_Compilation_Unit (S1)
- and then Ekind_In (S1, E_Package, E_Protected_Type, E_Block)
- loop
- S1 := Scope (S1);
- end loop;
+ procedure Traverse_Potential_Scenarios is
+ new Traverse_Proc (Is_Potential_Scenario);
- -- Find elaboration scope for Scop2
+ procedure Traverse_List (List : List_Id);
+ -- Inspect list List for suitable elaboration scenarios and process them
- 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;
+ ---------------------------
+ -- Is_Potential_Scenario --
+ ---------------------------
- return S1 = S2;
- end Same_Elaboration_Scope;
+ function Is_Potential_Scenario (Nod : Node_Id) return Traverse_Result is
+ begin
+ -- Special cases
- -----------------
- -- Set_C_Scope --
- -----------------
+ -- Skip constructs which do not have elaboration of their own and
+ -- need to be elaborated by other means such as invocation, task
+ -- activation, etc.
- 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;
+ if Is_Non_Library_Level_Encapsulator (Nod) then
+ return Skip;
- -----------------
- -- Spec_Entity --
- -----------------
+ -- 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.
- function Spec_Entity (E : Entity_Id) return Entity_Id is
- Decl : Node_Id;
+ 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;
- begin
- -- Check for case of body entity
- -- Why is the check for E_Void needed???
+ -- 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.
- if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then
- Decl := E;
+ elsif Nkind_In (Nod, N_And_Then, N_Or_Else) then
+ Traverse_List (Actions (Nod));
- loop
- Decl := Parent (Decl);
- exit when Nkind (Decl) in N_Proper_Body;
- end loop;
+ elsif Nkind_In (Nod, N_Elsif_Part, N_Iteration_Scheme) then
+ Traverse_List (Condition_Actions (Nod));
- return Corresponding_Spec (Decl);
+ elsif Nkind (Nod) = N_If_Expression then
+ Traverse_List (Then_Actions (Nod));
+ Traverse_List (Else_Actions (Nod));
- else
- return E;
- end if;
- end Spec_Entity;
+ elsif Nkind_In (Nod, N_Component_Association,
+ N_Iterated_Component_Association)
+ then
+ Traverse_List (Loop_Actions (Nod));
- -------------------
- -- Supply_Bodies --
- -------------------
+ -- General case
- procedure Supply_Bodies (N : Node_Id) is
- begin
- if Nkind (N) = N_Subprogram_Declaration then
- declare
- Ent : constant Entity_Id := Defining_Unit_Name (Specification (N));
+ elsif Is_Suitable_Scenario (Nod) then
+ Process_Scenario (Nod, In_Task_Body);
+ end if;
- begin
- -- Internal subprograms will already have a generated body, so
- -- there is no need to provide a stub for them.
-
- if No (Corresponding_Body (N)) then
- declare
- Loc : constant Source_Ptr := Sloc (N);
- Formals : constant List_Id := Copy_Parameter_List (Ent);
- Nam : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Chars (Ent));
- Stats : constant List_Id :=
- New_List (
- Make_Raise_Program_Error (Loc,
- Reason => PE_Access_Before_Elaboration));
- Spec : Node_Id;
-
- begin
- if Ekind (Ent) = E_Function then
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => Nam,
- Parameter_Specifications => Formals,
- Result_Definition =>
- New_Copy_Tree
- (Result_Definition (Specification (N))));
-
- -- We cannot reliably make a return statement for this
- -- body, but none is needed because the call raises
- -- program error.
-
- Set_Return_Present (Ent);
+ return OK;
+ end Is_Potential_Scenario;
- else
- Spec :=
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Nam,
- Parameter_Specifications => Formals);
- end if;
+ -------------------
+ -- Traverse_List --
+ -------------------
- Insert_After_And_Analyze (N,
- Make_Subprogram_Body (Loc,
- Specification => Spec,
- Declarations => New_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Stats)));
- end;
- end if;
- end;
+ procedure Traverse_List (List : List_Id) is
+ Item : Node_Id;
- elsif Nkind (N) = N_Package_Declaration then
- declare
- Spec : constant Node_Id := Specification (N);
- begin
- Push_Scope (Defining_Unit_Name (Spec));
- Supply_Bodies (Visible_Declarations (Spec));
- Supply_Bodies (Private_Declarations (Spec));
- Pop_Scope;
- end;
- end if;
- end Supply_Bodies;
-
- procedure Supply_Bodies (L : List_Id) is
- Elmt : Node_Id;
- begin
- if Present (L) then
- Elmt := First (L);
- while Present (Elmt) loop
- Supply_Bodies (Elmt);
- Next (Elmt);
+ begin
+ Item := First (List);
+ while Present (Item) loop
+ Traverse_Potential_Scenarios (Item);
+ Next (Item);
end loop;
- end if;
- end Supply_Bodies;
+ end Traverse_List;
- ------------
- -- Within --
- ------------
+ -- Start of processing for Traverse_Body
- 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);
+ -- Nothing to do when there is no body
- 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.
+ if No (N) then
+ return;
- Result : Boolean := False;
+ elsif Nkind (N) /= N_Subprogram_Body then
+ return;
+ end if;
- 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.
+ -- Nothing to do if the body was already traversed during the processing
+ -- of the same top level scenario.
- ------------
- -- Helper --
- ------------
+ if Visited_Bodies.Get (N) then
+ return;
- procedure Helper (Unit : Unit_Number_Type) is
- CU : constant Node_Id := Cunit (Unit);
+ -- Otherwise mark the body as traversed
- Item : Node_Id;
- Item2 : Node_Id;
- Elab_Id : Entity_Id;
- Par : Node_Id;
+ else
+ Visited_Bodies.Set (N, True);
+ end if;
- begin
- if Seen (Unit) then
- return;
- else
- Seen (Unit) := True;
- end if;
+ -- Examine the declarations for suitable scenarios
- -- First, check for Elaborate_Alls on this unit
+ Traverse_List (Declarations (N));
- 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.
+ -- Examine the handled sequence of statements. This also includes any
+ -- exceptions handlers.
- if Error_Posted (Item) or else not Analyzed (Item) then
- return;
- end if;
+ Traverse_Potential_Scenarios (Handled_Statement_Sequence (N));
+ end Traverse_Body;
- Elab_Id :=
- Entity
- (Expression (First (Pragma_Argument_Associations (Item))));
+ ---------------------------------
+ -- Update_Elaboration_Scenario --
+ ---------------------------------
- if E = Elab_Id then
- Result := True;
- return;
- end if;
+ procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id) is
+ package Scenarios renames Top_Level_Scenarios;
- Par := Parent (Unit_Declaration_Node (Elab_Id));
+ begin
+ -- A scenario is being transformed by Atree.Rewrite. Update all relevant
+ -- internal data structures to reflect this change. This ensures that a
+ -- potential run-time conditional ABE check or a guaranteed ABE failure
+ -- is inserted at the proper place in the tree.
+
+ if Is_Check_Emitting_Scenario (Old_N)
+ and then Is_Recorded_Scenario (Old_N)
+ and then Old_N /= New_N
+ then
+ -- Performance note: list traversal
- 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;
+ for Index in Scenarios.First .. Scenarios.Last loop
+ if Scenarios.Table (Index) = Old_N then
+ Scenarios.Table (Index) := New_N;
- Next (Item2);
- end loop;
+ Set_Is_Recorded_Scenario (Old_N, False);
+ Set_Is_Recorded_Scenario (New_N);
+ return;
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;
+ -- A recorded scenario must be in the table of recorded scenarios
- Next (Item);
- end loop;
- end if;
- end Helper;
+ pragma Assert (False);
+ end if;
+ end Update_Elaboration_Scenario;
- -- Start of processing for Within_Elaborate_All
+ -------------------------
+ -- Visited_Bodies_Hash --
+ -------------------------
+ function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index is
begin
- Helper (Unit);
- return Result;
- end Within_Elaborate_All;
+ return Visited_Bodies_Index (Key mod Visited_Bodies_Max);
+ end Visited_Bodies_Hash;
end Sem_Elab;
-- --
------------------------------------------------------------------------------
--- This package contains the routines used to deal with issuing warnings
--- for cases of calls that may require warnings about possible access
--- before elaboration.
+-- This package contains routines which handle access-before-elaboration
+-- run-time checks and compile-time diagnostics. See the body for details.
with Types; use Types;
package Sem_Elab is
- -----------------------------
- -- Description of Approach --
- -----------------------------
-
- -- Every non-static call that is encountered by Sem_Res results in a call
- -- to Check_Elab_Call, with N being the call node, and Outer set to its
- -- default value of True. In addition X'Access is treated like a call
- -- for the access-to-procedure case, and in SPARK mode only we also
- -- check variable references.
-
- -- The goal of Check_Elab_Call is to determine whether or not the reference
- -- in question can generate an access before elaboration error (raising
- -- Program_Error) either by directly calling a subprogram whose body
- -- has not yet been elaborated, or indirectly, by calling a subprogram
- -- whose body has been elaborated, but which contains a call to such a
- -- subprogram.
-
- -- In addition, in SPARK mode, we are checking for a variable reference in
- -- another package, which requires an explicit Elaborate_All pragma.
-
- -- The only references that we need to look at the outer level are
- -- references that occur in elaboration code. There are two cases. The
- -- reference can be at the outer level of elaboration code, or it can
- -- be within another unit, e.g. the elaboration code of a subprogram.
-
- -- In the case of an elaboration call at the outer level, we must trace
- -- all calls to outer level routines either within the current unit or to
- -- other units that are with'ed. For calls within the current unit, we can
- -- determine if the body has been elaborated or not, and if it has not,
- -- then a warning is generated.
-
- -- Note that there are two subcases. If the original call directly calls a
- -- subprogram whose body has not been elaborated, then we know that an ABE
- -- will take place, and we replace the call by a raise of Program_Error.
- -- If the call is indirect, then we don't know that the PE will be raised,
- -- since the call might be guarded by a conditional. In this case we set
- -- Do_Elab_Check on the call so that a dynamic check is generated, and
- -- output a warning.
-
- -- For calls to a subprogram in a with'ed unit or a 'Access or variable
- -- reference (SPARK mode case), we require that a pragma Elaborate_All
- -- or pragma Elaborate be present, or that the referenced unit have a
- -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none
- -- of these conditions is met, then a warning is generated that a pragma
- -- Elaborate_All may be needed (error in the SPARK case), or an implicit
- -- pragma is generated.
-
- -- For the case of an elaboration call at some inner level, we are
- -- interested in tracing only calls to subprograms at the same level,
- -- i.e. those that can be called during elaboration. Any calls to
- -- outer level routines cannot cause ABE's as a result of the original
- -- call (there might be an outer level call to the subprogram from
- -- outside that causes the ABE, but that gets analyzed separately).
-
- -- Note that we never trace calls to inner level subprograms, since
- -- these cannot result in ABE's unless there is an elaboration problem
- -- at a lower level, which will be separately detected.
-
- -- Note on pragma Elaborate. The checking here assumes that a pragma
- -- Elaborate on a with'ed unit guarantees that subprograms within the
- -- unit can be called without causing an ABE. This is not in fact the
- -- case since pragma Elaborate does not guarantee the transitive
- -- coverage guaranteed by Elaborate_All. However, we decide to trust
- -- the user in this case.
-
- --------------------------------------
- -- Instantiation Elaboration Errors --
- --------------------------------------
-
- -- A special case arises when an instantiation appears in a context
- -- that is known to be before the body is elaborated, e.g.
-
- -- generic package x is ...
- -- ...
- -- package xx is new x;
- -- ...
- -- package body x is ...
-
- -- In this situation it is certain that an elaboration error will
- -- occur, and an unconditional raise Program_Error statement is
- -- inserted before the instantiation, and a warning generated.
-
- -- The problem is that in this case we have no place to put the
- -- body of the instantiation. We can't put it in the normal place,
- -- because it is too early, and will cause errors to occur as a
- -- result of referencing entities before they are declared.
-
- -- Our approach in this case is simply to avoid creating the body
- -- of the instantiation in such a case. The instantiation spec is
- -- modified to include dummy bodies for all subprograms, so that
- -- the resulting code does not contain subprogram specs with no
- -- corresponding bodies.
-
- procedure Check_Elab_Call
- (N : Node_Id;
- Outer_Scope : Entity_Id := Empty;
- In_Init_Proc : Boolean := False);
- -- Check a call for possible elaboration problems. The node N is either an
- -- N_Function_Call or N_Procedure_Call_Statement node or an access
- -- attribute reference whose prefix is a subprogram.
- --
- -- If SPARK_Mode is On, then N can also be a variable reference, since
- -- SPARK requires the use of Elaborate_All for references to variables
- -- in other packages.
-
- -- The Outer_Scope argument indicates whether this is an outer level
- -- call from Sem_Res (Outer_Scope set to Empty), or an internal recursive
- -- call (Outer_Scope set to entity of outermost call, see body). The flag
- -- In_Init_Proc should be set whenever the current context is a type
- -- init proc.
-
- -- Note: this might better be called Check_Elab_Reference (to recognize
- -- the SPARK case), but we prefer to keep the original name, since this
- -- is primarily used for checking for calls that could generate an ABE).
-
- procedure Check_Elab_Calls;
- -- Not all the processing for Check_Elab_Call can be done at the time
- -- of calls to Check_Elab_Call. This is because for internal calls, we
- -- need to wait to complete the check until all generic bodies have been
- -- instantiated. The Check_Elab_Calls procedure cleans up these waiting
- -- checks. It is called once after the completion of instantiation.
-
- procedure Check_Elab_Assign (N : Node_Id);
- -- N is either the left side of an assignment, or a procedure argument for
- -- a mode OUT or IN OUT formal. This procedure checks for a possible case
- -- of access to an entity from elaboration code before the entity has been
- -- initialized, and issues appropriate warnings.
-
- procedure Check_Elab_Instantiation
- (N : Node_Id;
- Outer_Scope : Entity_Id := Empty);
- -- Check an instantiation for possible elaboration problems. N is an
- -- instantiation node (N_Package_Instantiation, N_Function_Instantiation,
- -- or N_Procedure_Instantiation), and Outer_Scope indicates if this is
- -- an outer level call from Sem_Ch12 (Outer_Scope set to Empty), or an
- -- internal recursive call (Outer_Scope set to scope of outermost call,
- -- see body for further details). The returned value is relevant only
- -- for an outer level call, and is set to False if an elaboration error
- -- is bound to occur on the instantiation, and True otherwise. This is
- -- used by the caller to signal that the body of the instance should
- -- not be generated (see detailed description in body).
-
- procedure Check_Task_Activation (N : Node_Id);
- -- At the point at which tasks are activated in a package body, check
- -- that the bodies of the tasks are elaborated.
+ procedure Build_Call_Marker (N : Node_Id);
+ -- Create a call marker for call or requeue statement N and record it for
+ -- later processing by the ABE mechanism.
+
+ procedure Check_Elaboration_Scenarios;
+ -- Examine each scenario recorded during analysis/resolution and apply the
+ -- Ada or SPARK elaboration rules taking into account the model in effect.
+ -- This processing detects and diagnoses ABE issues, installs conditional
+ -- ABE checks or guaranteed ABE failures, and ensures the elaboration of
+ -- units.
+
+ -- The following type classifies the various enclosing levels used in ABE
+ -- diagnostics.
+
+ type Enclosing_Level_Kind is
+ (Declaration_Level,
+ -- A construct is at the "declaration level" when it appears within the
+ -- declarations of a block statement, an entry body, a subprogram body,
+ -- or a task body, ignoring enclosing packages. Example:
+
+ -- package Pack is
+ -- procedure Proc is -- subprogram body
+ -- package Nested is -- enclosing package ignored
+ -- X ... -- at declaration level
+
+ Generic_Package_Spec,
+ Generic_Package_Body,
+ -- A construct is at the "generic library level" when it appears in a
+ -- generic package library unit, ignoring enclosing packages. Example:
+
+ -- generic
+ -- package Pack is -- generic package spec
+ -- package Nested is -- enclosing package ignored
+ -- X ... -- at generic library level
+
+ Instantiation,
+ -- A construct is at the "instantiation library level" when it appears
+ -- in a library unit which is also an instantiation. Example:
+
+ -- package Inst is new Gen; -- at instantiation level
+
+ Package_Spec,
+ Package_Body,
+ -- A construct is at the "library level" when it appears in a package
+ -- library unit, ignoring enclosing packages. Example:
+
+ -- package body Pack is -- package body
+ -- package Nested is -- enclosing package ignored
+ -- X ... -- at library level
+
+ No_Level);
+ -- This value is used to indicate that none of the levels above are in
+ -- effect.
+
+ subtype Generic_Library_Level is Enclosing_Level_Kind range
+ Generic_Package_Spec ..
+ Generic_Package_Body;
+
+ subtype Library_Level is Enclosing_Level_Kind range
+ Package_Spec ..
+ Package_Body;
+
+ subtype Any_Library_Level is Enclosing_Level_Kind range
+ Generic_Package_Spec ..
+ Package_Body;
+
+ function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind;
+ -- Determine the enclosing level of arbitrary node N
+
+ procedure Initialize;
+ -- Initialize the internal structures of this unit
+
+ procedure Kill_Elaboration_Scenario (N : Node_Id);
+ -- Determine whether arbitrary node N denotes a scenario which requires
+ -- ABE diagnostics or runtime checks and eliminate it from a region with
+ -- dead code.
+
+ procedure Record_Elaboration_Scenario (N : Node_Id);
+ -- Determine whether atribtray node N denotes a scenario which requires
+ -- ABE diagnostics or runtime checks. If this is the case, store N into
+ -- a table for later processing.
end Sem_Elab;
Call := Get_Pragma_Arg (Arg1);
end if;
- if Nkind_In (Call,
- N_Indexed_Component,
- N_Function_Call,
- N_Identifier,
- N_Expanded_Name,
- N_Selected_Component)
+ if Nkind_In (Call, N_Expanded_Name,
+ N_Function_Call,
+ N_Identifier,
+ N_Indexed_Component,
+ N_Selected_Component)
then
-- If this pragma Debug comes from source, its argument was
-- parsed as a name form (which is syntactically identical).
Set_Elaborate_Present (Citem, True);
Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
- -- With the pragma present, elaboration calls on
- -- subprograms from the named unit need no further
- -- checks, as long as the pragma appears in the current
- -- compilation unit. If the pragma appears in some unit
- -- in the context, there might still be a need for an
- -- Elaborate_All_Desirable from the current compilation
- -- to the named unit, so we keep the check enabled.
-
- if In_Extended_Main_Source_Unit (N) then
-
- -- This does not apply in SPARK mode, where we allow
- -- pragma Elaborate, but we don't trust it to be right
- -- so we will still insist on the Elaborate_All.
-
- if SPARK_Mode /= On then
- Set_Suppress_Elaboration_Warnings
- (Entity (Name (Citem)));
- end if;
- end if;
-
exit Inner;
end if;
Set_Elaborate_All_Present (Citem, True);
Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
- -- Suppress warnings and elaboration checks on the named
- -- unit if the pragma is in the current compilation, as
- -- for pragma Elaborate.
-
- if In_Extended_Main_Source_Unit (N) then
- Set_Suppress_Elaboration_Warnings
- (Entity (Name (Citem)));
- end if;
exit Innr;
end if;
then
Error_Pragma ("pragma% must refer to a spec, not a body");
else
- Set_Body_Required (Cunit_Node, True);
+ Set_Body_Required (Cunit_Node);
Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
-
- -- If we are in dynamic elaboration mode, then we suppress
- -- elaboration warnings for the unit, since it is definitely
- -- fine NOT to do dynamic checks at the first level (and such
- -- checks will be suppressed because no elaboration boolean
- -- is created for Elaborate_Body packages).
-
- -- But in the static model of elaboration, Elaborate_Body is
- -- definitely NOT good enough to ensure elaboration safety on
- -- its own, since the body may WITH other units that are not
- -- safe from an elaboration point of view, so a client must
- -- still do an Elaborate_All on such units.
-
- -- Debug flag -gnatdD restores the old behavior of 3.13, where
- -- Elaborate_Body always suppressed elab warnings.
-
- if Dynamic_Elaboration_Checks or Debug_Flag_DD then
- Set_Suppress_Elaboration_Warnings (Cunit_Ent);
- end if;
end if;
end Elaborate_Body;
else
if not Debug_Flag_U then
Set_Is_Preelaborated (Ent);
- Set_Suppress_Elaboration_Warnings (Ent);
end if;
end if;
end if;
if not Debug_Flag_U then
Set_Is_Pure (Ent);
Set_Has_Pragma_Pure (Ent);
- Set_Suppress_Elaboration_Warnings (Ent);
end if;
end Pure;
with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
-with Sem_Elim; use Sem_Elim;
with Sem_Elab; use Sem_Elab;
+with Sem_Elim; use Sem_Elim;
with Sem_Eval; use Sem_Eval;
with Sem_Intr; use Sem_Intr;
with Sem_Util; use Sem_Util;
begin
Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N));
+ -- Ensure that the corresponding operator has the same parent as the
+ -- original call. This guarantees that parent traversals performed by
+ -- the ABE mechanism succeed.
+
+ Set_Parent (Op_Node, Parent (N));
+
-- Binary operator
if Is_Binary then
-- Start of processing for Resolve_Call
begin
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ Mark_Elaboration_Attributes
+ (N_Id => N,
+ Checks => True,
+ Modes => True);
+
-- The context imposes a unique interpretation with type Typ on a
-- procedure or function call. Find the entity of the subprogram that
-- yields the expected type, and propagate the corresponding formal
elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component)
or else (Is_Entity_Name (Subp)
- and then Ekind (Entity (Subp)) = E_Entry)
+ and then Ekind_In (Entity (Subp), E_Entry, E_Entry_Family))
then
Resolve_Entry_Call (N, Typ);
- Check_Elab_Call (N);
+
+ -- Annotate the tree by creating a call marker in case the original
+ -- call is transformed by expansion. The call marker is automatically
+ -- saved for later examination by the ABE Processing phase.
+
+ Build_Call_Marker (N);
-- Kill checks and constant values, as above for indirect case
-- Who knows what happens when another task is activated?
-- the proper indexed component.
Index_Node :=
- Make_Indexed_Component (Loc,
- Prefix =>
- Make_Function_Call (Loc,
- Name => New_Subp,
- Parameter_Associations =>
- New_List
- (Remove_Head (Parameter_Associations (N)))),
- Expressions => Parameter_Associations (N));
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name => New_Subp,
+ Parameter_Associations =>
+ New_List
+ (Remove_Head (Parameter_Associations (N)))),
+ Expressions => Parameter_Associations (N));
end if;
-- Preserve the parenthesis count of the node
Set_Etype (Prefix (N), Ret_Type);
Set_Etype (N, Typ);
Resolve_Indexed_Component (N, Typ);
- Check_Elab_Call (Prefix (N));
+
+ -- Annotate the tree by creating a call marker in case
+ -- the original call is transformed by expansion. The call
+ -- marker is automatically saved for later examination by
+ -- the ABE Processing phase.
+
+ Build_Call_Marker (Prefix (N));
end if;
end if;
-- All done, evaluate call and deal with elaboration issues
Eval_Call (N);
- Check_Elab_Call (N);
+
+ -- Annotate the tree by creating a call marker in case the original call
+ -- is transformed by expansion. The call marker is automatically saved
+ -- for later examination by the ABE Processing phase.
+
+ Build_Call_Marker (N);
-- In GNATprove mode, expansion is disabled, but we want to inline some
-- subprograms to facilitate formal verification. Indirect calls through
else
Error_Msg_N
- ("invalid use of subtype mark in expression or call", N);
+ ("invalid use of subtype mark in expression or call", N);
end if;
-- Check discriminant use if entity is discriminant in current scope,
& "(SPARK RM 7.1.3(12))", N);
end if;
- -- Check for possible elaboration issues with respect to reads of
- -- variables. The act of renaming the variable is not considered a
- -- read as it simply establishes an alias.
-
- if Ekind (E) = E_Variable
- and then Dynamic_Elaboration_Checks
- and then Nkind (Par) /= N_Object_Renaming_Declaration
- then
- Check_Elab_Call (N);
- end if;
-
-- The variable may eventually become a constituent of a single
-- protected/task type. Record the reference now and verify its
-- legality when analyzing the contract of the variable
------------------------
procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is
- Entry_Name : constant Node_Id := Name (N);
- Loc : constant Source_Ptr := Sloc (Entry_Name);
- Actuals : List_Id;
- First_Named : Node_Id;
- Nam : Entity_Id;
- Norm_OK : Boolean;
- Obj : Node_Id;
- Was_Over : Boolean;
+ Entry_Name : constant Node_Id := Name (N);
+ Loc : constant Source_Ptr := Sloc (Entry_Name);
+
+ Nam : Entity_Id;
+ Norm_OK : Boolean;
+ Obj : Node_Id;
+ Was_Over : Boolean;
begin
-- We kill all checks here, because it does not seem worth the effort to
and then Present (Contract_Wrapper (Nam))
and then Current_Scope /= Contract_Wrapper (Nam)
then
-
-- Note the entity being called before rewriting the call, so that
-- it appears used at this point.
Entry_Name);
end if;
- Actuals := Parameter_Associations (N);
- First_Named := First_Named_Actual (N);
+ declare
+ Entry_Call : Node_Id;
+
+ begin
+ Entry_Call :=
+ Make_Entry_Call_Statement (Loc,
+ Name => Entry_Name,
+ Parameter_Associations => Parameter_Associations (N));
- Rewrite (N,
- Make_Entry_Call_Statement (Loc,
- Name => Entry_Name,
- Parameter_Associations => Actuals));
+ -- Inherit relevant attributes from the original call
- Set_First_Named_Actual (N, First_Named);
- Set_Analyzed (N, True);
+ Set_First_Named_Actual
+ (Entry_Call, First_Named_Actual (N));
+
+ Set_Is_Elaboration_Checks_OK_Node
+ (Entry_Call, Is_Elaboration_Checks_OK_Node (N));
+
+ Set_Is_SPARK_Mode_On_Node
+ (Entry_Call, Is_SPARK_Mode_On_Node (N));
+
+ Rewrite (N, Entry_Call);
+ Set_Analyzed (N, True);
+ end;
-- Protected functions can return on the secondary stack, in which
-- case we must trigger the transient scope mechanism.
when N_Abstract_Subprogram_Declaration
| N_At_Clause
| N_Attribute_Definition_Clause
+ | N_Call_Marker
| N_Delta_Constraint
| N_Digits_Constraint
| N_Empty
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Disp; use Sem_Disp;
+with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
and then not In_Same_Extended_Unit (N, T);
end Bad_Unordered_Enumeration_Reference;
+ ----------------------------
+ -- Begin_Keyword_Location --
+ ----------------------------
+
+ function Begin_Keyword_Location (N : Node_Id) return Source_Ptr is
+ HSS : Node_Id;
+
+ begin
+ pragma Assert (Nkind_In (N, N_Block_Statement,
+ N_Entry_Body,
+ N_Package_Body,
+ N_Subprogram_Body,
+ N_Task_Body));
+
+ HSS := Handled_Statement_Sequence (N);
+
+ -- When the handled sequence of statements comes from source, the
+ -- location of the "begin" keyword is that of the sequence itself.
+ -- Note that an internal construct may inherit a source sequence.
+
+ if Comes_From_Source (HSS) then
+ return Sloc (HSS);
+
+ -- The parser generates an internal handled sequence of statements to
+ -- capture the location of the "begin" keyword if present in the source.
+ -- Since there are no source statements, the location of the "begin"
+ -- keyword is effectively that of the "end" keyword.
+
+ elsif Comes_From_Source (N) then
+ return Sloc (HSS);
+
+ -- Otherwise the construct is internal and should carry the location of
+ -- the original construct which prompted its creation.
+
+ else
+ return Sloc (N);
+ end if;
+ end Begin_Keyword_Location;
+
--------------------------
-- Build_Actual_Subtype --
--------------------------
---------------------
function Defining_Entity
- (N : Node_Id;
- Empty_On_Errors : Boolean := False) return Entity_Id
+ (N : Node_Id;
+ Empty_On_Errors : Boolean := False;
+ Concurrent_Subunit : Boolean := False) return Entity_Id
is
- Err : Entity_Id := Empty;
-
begin
case Nkind (N) is
when N_Abstract_Subprogram_Declaration
return Defining_Identifier (N);
when N_Subunit =>
- return Defining_Entity (Proper_Body (N));
+ declare
+ Bod : constant Node_Id := Proper_Body (N);
+ Orig_Bod : constant Node_Id := Original_Node (Bod);
+
+ begin
+ -- Retrieve the entity of the original protected or task body
+ -- if requested by the caller.
+
+ if Concurrent_Subunit
+ and then Nkind (Bod) = N_Null_Statement
+ and then Nkind_In (Orig_Bod, N_Protected_Body, N_Task_Body)
+ then
+ return Defining_Entity (Orig_Bod);
+ else
+ return Defining_Entity (Bod);
+ end if;
+ end;
when N_Function_Instantiation
| N_Function_Specification
=>
declare
Nam : constant Node_Id := Defining_Unit_Name (N);
+ Err : Entity_Id := Empty;
begin
if Nkind (Nam) in N_Entity then
end if;
end Enclosing_Subprogram;
+ --------------------------
+ -- End_Keyword_Location --
+ --------------------------
+
+ function End_Keyword_Location (N : Node_Id) return Source_Ptr is
+ function End_Label_Loc (Nod : Node_Id) return Source_Ptr;
+ -- Return the source location of Nod's end label according to the
+ -- following precedence rules:
+ --
+ -- 1) If the end label exists, return its location
+ -- 2) If Nod exists, return its location
+ -- 3) Return the location of N
+
+ -------------------
+ -- End_Label_Loc --
+ -------------------
+
+ function End_Label_Loc (Nod : Node_Id) return Source_Ptr is
+ Label : Node_Id;
+
+ begin
+ if Present (Nod) then
+ Label := End_Label (Nod);
+
+ if Present (Label) then
+ return Sloc (Label);
+ else
+ return Sloc (Nod);
+ end if;
+
+ else
+ return Sloc (N);
+ end if;
+ end End_Label_Loc;
+
+ -- Local variables
+
+ Owner : Node_Id;
+
+ -- Start of processing for End_Keyword_Location
+
+ begin
+ if Nkind_In (N, N_Block_Statement,
+ N_Entry_Body,
+ N_Package_Body,
+ N_Subprogram_Body,
+ N_Task_Body)
+ then
+ Owner := Handled_Statement_Sequence (N);
+
+ elsif Nkind (N) = N_Package_Declaration then
+ Owner := Specification (N);
+
+ elsif Nkind (N) = N_Protected_Body then
+ Owner := N;
+
+ elsif Nkind_In (N, N_Protected_Type_Declaration,
+ N_Single_Protected_Declaration)
+ then
+ Owner := Protected_Definition (N);
+
+ elsif Nkind_In (N, N_Single_Task_Declaration,
+ N_Task_Type_Declaration)
+ then
+ Owner := Task_Definition (N);
+
+ -- This routine should not be called with other contexts
+
+ else
+ pragma Assert (False);
+ null;
+ end if;
+
+ return End_Label_Loc (Owner);
+ end End_Keyword_Location;
+
------------------------
-- Ensure_Freeze_Node --
------------------------
return Empty;
end Find_Enclosing_Iterator_Loop;
+ --------------------------
+ -- Find_Enclosing_Scope --
+ --------------------------
+
+ function Find_Enclosing_Scope (N : Node_Id) return Entity_Id is
+ Par : Node_Id;
+ Spec_Id : Entity_Id;
+
+ begin
+ -- Examine the parent chain looking for a construct which defines a
+ -- scope.
+
+ Par := Parent (N);
+ while Present (Par) loop
+ case Nkind (Par) is
+
+ -- The construct denotes a declaration, the proper scope is its
+ -- entity.
+
+ when N_Entry_Declaration
+ | N_Expression_Function
+ | N_Full_Type_Declaration
+ | N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Package_Declaration
+ | N_Private_Extension_Declaration
+ | N_Protected_Type_Declaration
+ | N_Single_Protected_Declaration
+ | N_Single_Task_Declaration
+ | N_Subprogram_Declaration
+ | N_Task_Type_Declaration
+ =>
+ return Defining_Entity (Par);
+
+ -- The construct denotes a body, the proper scope is the entity of
+ -- the corresponding spec.
+
+ when N_Entry_Body
+ | N_Package_Body
+ | N_Protected_Body
+ | N_Subprogram_Body
+ | N_Task_Body
+ =>
+ Spec_Id := Corresponding_Spec (Par);
+
+ -- The defining entity of a stand-alone subprogram body defines
+ -- a scope.
+
+ if Nkind (Par) = N_Subprogram_Body and then No (Spec_Id) then
+ return Defining_Entity (Par);
+
+ -- Otherwise there should be corresponding spec which defines a
+ -- scope.
+
+ else
+ pragma Assert (Present (Spec_Id));
+
+ return Spec_Id;
+ end if;
+
+ -- Special cases
+
+ -- Blocks, loops, and return statements have artificial scopes
+
+ when N_Block_Statement
+ | N_Loop_Statement
+ =>
+ return Entity (Identifier (Par));
+
+ when N_Extended_Return_Statement =>
+ return Return_Statement_Entity (Par);
+
+ -- A traversal from a subunit continues via the corresponding stub
+
+ when N_Subunit =>
+ Par := Corresponding_Stub (Par);
+
+ when others =>
+ null;
+ end case;
+
+ Par := Parent (Par);
+ end loop;
+
+ return Standard_Standard;
+ end Find_Enclosing_Scope;
+
------------------------------------
-- Find_Loop_In_Conditional_Block --
------------------------------------
-- Get_Task_Body_Procedure --
-----------------------------
- function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
+ function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is
begin
-- Note: A task type may be the completion of a private type with
-- discriminants. When performing elaboration checks on a task
-- Has_Non_Trivial_Precondition --
----------------------------------
- function Has_Non_Trivial_Precondition (P : Entity_Id) return Boolean is
- Cont : constant Node_Id := Find_Aspect (P, Aspect_Pre);
+ function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is
+ Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre);
+
begin
- return Present (Cont)
- and then Class_Present (Cont)
- and then not Is_Entity_Name (Expression (Cont));
+ return
+ Present (Pre)
+ and then Class_Present (Pre)
+ and then not Is_Entity_Name (Expression (Pre));
end Has_Non_Trivial_Precondition;
-------------------
Ent : Entity_Id;
Exp : Node_Id;
- function Is_Preelaborable_Expression (N : Node_Id) return Boolean;
- -- Returns True if and only if the expression denoted by N does not
- -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
-
- ---------------------------------
- -- Is_Preelaborable_Expression --
- ---------------------------------
-
- function Is_Preelaborable_Expression (N : Node_Id) return Boolean is
- Exp : Node_Id;
- Assn : Node_Id;
- Choice : Node_Id;
- Comp_Type : Entity_Id;
- Is_Array_Aggr : Boolean;
-
- begin
- if Is_OK_Static_Expression (N) then
- return True;
-
- elsif Nkind (N) = N_Null then
- return True;
-
- -- Attributes are allowed in general, even if their prefix is a
- -- formal type. (It seems that certain attributes known not to be
- -- static might not be allowed, but there are no rules to prevent
- -- them.)
-
- elsif Nkind (N) = N_Attribute_Reference then
- return True;
-
- -- The name of a discriminant evaluated within its parent type is
- -- defined to be preelaborable (10.2.1(8)). Note that we test for
- -- names that denote discriminals as well as discriminants to
- -- catch references occurring within init procs.
-
- elsif Is_Entity_Name (N)
- and then
- (Ekind (Entity (N)) = E_Discriminant
- or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter)
- and then Present (Discriminal_Link (Entity (N)))))
- then
- return True;
-
- elsif Nkind (N) = N_Qualified_Expression then
- return Is_Preelaborable_Expression (Expression (N));
-
- -- For aggregates we have to check that each of the associations
- -- is preelaborable.
-
- elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
- Is_Array_Aggr := Is_Array_Type (Etype (N));
-
- if Is_Array_Aggr then
- Comp_Type := Component_Type (Etype (N));
- end if;
-
- -- Check the ancestor part of extension aggregates, which must
- -- be either the name of a type that has preelaborable init or
- -- an expression that is preelaborable.
-
- if Nkind (N) = N_Extension_Aggregate then
- declare
- Anc_Part : constant Node_Id := Ancestor_Part (N);
-
- begin
- if Is_Entity_Name (Anc_Part)
- and then Is_Type (Entity (Anc_Part))
- then
- if not Has_Preelaborable_Initialization
- (Entity (Anc_Part))
- then
- return False;
- end if;
-
- elsif not Is_Preelaborable_Expression (Anc_Part) then
- return False;
- end if;
- end;
- end if;
-
- -- Check positional associations
-
- Exp := First (Expressions (N));
- while Present (Exp) loop
- if not Is_Preelaborable_Expression (Exp) then
- return False;
- end if;
-
- Next (Exp);
- end loop;
-
- -- Check named associations
-
- Assn := First (Component_Associations (N));
- while Present (Assn) loop
- Choice := First (Choices (Assn));
- while Present (Choice) loop
- if Is_Array_Aggr then
- if Nkind (Choice) = N_Others_Choice then
- null;
-
- elsif Nkind (Choice) = N_Range then
- if not Is_OK_Static_Range (Choice) then
- return False;
- end if;
-
- elsif not Is_OK_Static_Expression (Choice) then
- return False;
- end if;
-
- else
- Comp_Type := Etype (Choice);
- end if;
-
- Next (Choice);
- end loop;
-
- -- If the association has a <> at this point, then we have
- -- to check whether the component's type has preelaborable
- -- initialization. Note that this only occurs when the
- -- association's corresponding component does not have a
- -- default expression, the latter case having already been
- -- expanded as an expression for the association.
-
- if Box_Present (Assn) then
- if not Has_Preelaborable_Initialization (Comp_Type) then
- return False;
- end if;
-
- -- In the expression case we check whether the expression
- -- is preelaborable.
-
- elsif
- not Is_Preelaborable_Expression (Expression (Assn))
- then
- return False;
- end if;
-
- Next (Assn);
- end loop;
-
- -- If we get here then aggregate as a whole is preelaborable
-
- return True;
-
- -- All other cases are not preelaborable
-
- else
- return False;
- end if;
- end Is_Preelaborable_Expression;
-
- -- Start of processing for Check_Components
-
begin
-- Loop through entities of record or protected type
-- Require the default expression to be preelaborable
- elsif not Is_Preelaborable_Expression (Exp) then
+ elsif not Is_Preelaborable_Construct (Exp) then
Has_PE := False;
exit;
end if;
-- In_Instance_Visible_Part --
------------------------------
- function In_Instance_Visible_Part return Boolean is
- S : Entity_Id;
+ function In_Instance_Visible_Part
+ (Id : Entity_Id := Current_Scope) return Boolean
+ is
+ Inst : Entity_Id;
begin
- S := Current_Scope;
- while Present (S) and then S /= Standard_Standard loop
- if Ekind (S) = E_Package
- and then Is_Generic_Instance (S)
- and then not In_Package_Body (S)
- and then not In_Private_Part (S)
+ Inst := Id;
+ while Present (Inst) and then Inst /= Standard_Standard loop
+ if Ekind (Inst) = E_Package
+ and then Is_Generic_Instance (Inst)
+ and then not In_Package_Body (Inst)
+ and then not In_Private_Part (Inst)
then
return True;
end if;
- S := Scope (S);
+ Inst := Scope (Inst);
end loop;
return False;
-- In_Subtree --
----------------
- function In_Subtree (Root : Node_Id; N : Node_Id) return Boolean is
+ function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is
Curr : Node_Id;
begin
return False;
end In_Subtree;
+ ----------------
+ -- In_Subtree --
+ ----------------
+
+ function In_Subtree
+ (N : Node_Id;
+ Root1 : Node_Id;
+ Root2 : Node_Id) return Boolean
+ is
+ Curr : Node_Id;
+
+ begin
+ Curr := N;
+ while Present (Curr) loop
+ if Curr = Root1 or else Curr = Root2 then
+ return True;
+ end if;
+
+ Curr := Parent (Curr);
+ end loop;
+
+ return False;
+ end In_Subtree;
+
---------------------
-- In_Visible_Part --
---------------------
end if;
end Is_Potentially_Unevaluated;
- ---------------------------------
- -- Is_Protected_Self_Reference --
- ---------------------------------
+ --------------------------------
+ -- Is_Preelaborable_Aggregate --
+ --------------------------------
- function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
+ function Is_Preelaborable_Aggregate (Aggr : Node_Id) return Boolean is
+ Aggr_Typ : constant Entity_Id := Etype (Aggr);
+ Array_Aggr : constant Boolean := Is_Array_Type (Aggr_Typ);
- function In_Access_Definition (N : Node_Id) return Boolean;
- -- Returns true if N belongs to an access definition
+ Anc_Part : Node_Id;
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Comp_Typ : Entity_Id;
+ Expr : Node_Id;
- --------------------------
- -- In_Access_Definition --
- --------------------------
+ begin
+ if Array_Aggr then
+ Comp_Typ := Component_Type (Aggr_Typ);
+ end if;
- function In_Access_Definition (N : Node_Id) return Boolean is
- P : Node_Id;
+ -- Inspect the ancestor part
- begin
- P := Parent (N);
- while Present (P) loop
- if Nkind (P) = N_Access_Definition then
- return True;
- end if;
+ if Nkind (Aggr) = N_Extension_Aggregate then
+ Anc_Part := Ancestor_Part (Aggr);
- P := Parent (P);
- end loop;
+ -- The ancestor denotes a subtype mark
- return False;
- end In_Access_Definition;
+ if Is_Entity_Name (Anc_Part)
+ and then Is_Type (Entity (Anc_Part))
+ then
+ if not Has_Preelaborable_Initialization (Entity (Anc_Part)) then
+ return False;
+ end if;
- -- Start of processing for Is_Protected_Self_Reference
+ -- Otherwise the ancestor denotes an expression
- begin
- -- Verify that prefix is analyzed and has the proper form. Note that
- -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also
- -- produce the address of an entity, do not analyze their prefix
- -- because they denote entities that are not necessarily visible.
- -- Neither of them can apply to a protected type.
+ elsif not Is_Preelaborable_Construct (Anc_Part) then
+ return False;
+ end if;
+ end if;
- return Ada_Version >= Ada_2005
- and then Is_Entity_Name (N)
- and then Present (Entity (N))
- and then Is_Protected_Type (Entity (N))
- and then In_Open_Scopes (Entity (N))
- and then not In_Access_Definition (N);
- end Is_Protected_Self_Reference;
+ -- Inspect the positional associations
+
+ Expr := First (Expressions (Aggr));
+ while Present (Expr) loop
+ if not Is_Preelaborable_Construct (Expr) then
+ return False;
+ end if;
+
+ Next (Expr);
+ end loop;
+
+ -- Inspect the named associations
+
+ Assoc := First (Component_Associations (Aggr));
+ while Present (Assoc) loop
+
+ -- Inspect the choices of the current named association
+
+ Choice := First (Choices (Assoc));
+ while Present (Choice) loop
+ if Array_Aggr then
+
+ -- For a choice to be preelaborable, it must denote either a
+ -- static range or a static expression.
+
+ if Nkind (Choice) = N_Others_Choice then
+ null;
+
+ elsif Nkind (Choice) = N_Range then
+ if not Is_OK_Static_Range (Choice) then
+ return False;
+ end if;
+
+ elsif not Is_OK_Static_Expression (Choice) then
+ return False;
+ end if;
+
+ else
+ Comp_Typ := Etype (Choice);
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ -- The type of the choice must have preelaborable initialization if
+ -- the association carries a <>.
+
+ if Box_Present (Assoc) then
+ if not Has_Preelaborable_Initialization (Comp_Typ) then
+ return False;
+ end if;
+
+ -- The type of the expression must have preelaborable initialization
+
+ elsif not Is_Preelaborable_Construct (Expression (Assoc)) then
+ return False;
+ end if;
+
+ Next (Assoc);
+ end loop;
+
+ -- At this point the aggregate is preelaborable
+
+ return True;
+ end Is_Preelaborable_Aggregate;
+
+ --------------------------------
+ -- Is_Preelaborable_Construct --
+ --------------------------------
+
+ function Is_Preelaborable_Construct (N : Node_Id) return Boolean is
+ begin
+ -- Aggregates
+
+ if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
+ return Is_Preelaborable_Aggregate (N);
+
+ -- Attributes are allowed in general, even if their prefix is a formal
+ -- type. It seems that certain attributes known not to be static might
+ -- not be allowed, but there are no rules to prevent them.
+
+ elsif Nkind (N) = N_Attribute_Reference then
+ return True;
+
+ -- Expressions
+
+ elsif Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then
+ return True;
+
+ elsif Nkind (N) = N_Qualified_Expression then
+ return Is_Preelaborable_Construct (Expression (N));
+
+ -- Names are preelaborable when they denote a discriminant of an
+ -- enclosing type. Discriminals are also considered for this check.
+
+ elsif Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then
+ (Ekind (Entity (N)) = E_Discriminant
+ or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter)
+ and then Present (Discriminal_Link (Entity (N)))))
+ then
+ return True;
+
+ -- Statements
+
+ elsif Nkind (N) = N_Null then
+ return True;
+
+ -- Otherwise the construct is not preelaborable
+
+ else
+ return False;
+ end if;
+ end Is_Preelaborable_Construct;
+
+ ---------------------------------
+ -- Is_Protected_Self_Reference --
+ ---------------------------------
+
+ function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
+
+ function In_Access_Definition (N : Node_Id) return Boolean;
+ -- Returns true if N belongs to an access definition
+
+ --------------------------
+ -- In_Access_Definition --
+ --------------------------
+
+ function In_Access_Definition (N : Node_Id) return Boolean is
+ P : Node_Id;
+
+ begin
+ P := Parent (N);
+ while Present (P) loop
+ if Nkind (P) = N_Access_Definition then
+ return True;
+ end if;
+
+ P := Parent (P);
+ end loop;
+
+ return False;
+ end In_Access_Definition;
+
+ -- Start of processing for Is_Protected_Self_Reference
+
+ begin
+ -- Verify that prefix is analyzed and has the proper form. Note that
+ -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also
+ -- produce the address of an entity, do not analyze their prefix
+ -- because they denote entities that are not necessarily visible.
+ -- Neither of them can apply to a protected type.
+
+ return Ada_Version >= Ada_2005
+ and then Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then Is_Protected_Type (Entity (N))
+ and then In_Open_Scopes (Entity (N))
+ and then not In_Access_Definition (N);
+ end Is_Protected_Self_Reference;
-----------------------------
-- Is_RCI_Pkg_Spec_Or_Body --
return N;
end Last_Source_Statement;
+ -----------------------
+ -- Mark_Coextensions --
+ -----------------------
+
+ procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
+ Is_Dynamic : Boolean;
+ -- Indicates whether the context causes nested coextensions to be
+ -- dynamic or static
+
+ function Mark_Allocator (N : Node_Id) return Traverse_Result;
+ -- Recognize an allocator node and label it as a dynamic coextension
+
+ --------------------
+ -- Mark_Allocator --
+ --------------------
+
+ function Mark_Allocator (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Allocator then
+ if Is_Dynamic then
+ Set_Is_Dynamic_Coextension (N);
+
+ -- If the allocator expression is potentially dynamic, it may
+ -- be expanded out of order and require dynamic allocation
+ -- anyway, so we treat the coextension itself as dynamic.
+ -- Potential optimization ???
+
+ elsif Nkind (Expression (N)) = N_Qualified_Expression
+ and then Nkind (Expression (Expression (N))) = N_Op_Concat
+ then
+ Set_Is_Dynamic_Coextension (N);
+ else
+ Set_Is_Static_Coextension (N);
+ end if;
+ end if;
+
+ return OK;
+ end Mark_Allocator;
+
+ procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
+
+ -- Start of processing for Mark_Coextensions
+
+ begin
+ -- An allocator that appears on the right-hand side of an assignment is
+ -- treated as a potentially dynamic coextension when the right-hand side
+ -- is an allocator or a qualified expression.
+
+ -- Obj := new ...'(new Coextension ...);
+
+ if Nkind (Context_Nod) = N_Assignment_Statement then
+ Is_Dynamic :=
+ Nkind_In (Expression (Context_Nod), N_Allocator,
+ N_Qualified_Expression);
+
+ -- An allocator that appears within the expression of a simple return
+ -- statement is treated as a potentially dynamic coextension when the
+ -- expression is either aggregate, allocator, or qualified expression.
+
+ -- return (new Coextension ...);
+ -- return new ...'(new Coextension ...);
+
+ elsif Nkind (Context_Nod) = N_Simple_Return_Statement then
+ Is_Dynamic :=
+ Nkind_In (Expression (Context_Nod), N_Aggregate,
+ N_Allocator,
+ N_Qualified_Expression);
+
+ -- An alloctor that appears within the initialization expression of an
+ -- object declaration is considered a potentially dynamic coextension
+ -- when the initialization expression is an allocator or a qualified
+ -- expression.
+
+ -- Obj : ... := new ...'(new Coextension ...);
+
+ -- A similar case arises when the object declaration is part of an
+ -- extended return statement.
+
+ -- return Obj : ... := new ...'(new Coextension ...);
+ -- return Obj : ... := (new Coextension ...);
+
+ elsif Nkind (Context_Nod) = N_Object_Declaration then
+ Is_Dynamic :=
+ Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression)
+ or else
+ Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
+
+ -- This routine should not be called with constructs that cannot contain
+ -- coextensions.
+
+ else
+ raise Program_Error;
+ end if;
+
+ Mark_Allocators (Root_Nod);
+ end Mark_Coextensions;
+
+ ---------------------------------
+ -- Mark_Elaboration_Attributes --
+ ---------------------------------
+
+ procedure Mark_Elaboration_Attributes
+ (N_Id : Node_Or_Entity_Id;
+ Checks : Boolean := False;
+ Level : Boolean := False;
+ Modes : Boolean := False)
+ is
+ function Elaboration_Checks_OK
+ (Target_Id : Entity_Id;
+ Context_Id : Entity_Id) return Boolean;
+ -- Determine whether elaboration checks are enabled for target Target_Id
+ -- which resides within context Context_Id.
+
+ procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id);
+ -- Preserve relevant attributes of the context in arbitrary entity Id
+
+ procedure Mark_Elaboration_Attributes_Node (N : Node_Id);
+ -- Preserve relevant attributes of the context in arbitrary node N
+
+ ---------------------------
+ -- Elaboration_Checks_OK --
+ ---------------------------
+
+ function Elaboration_Checks_OK
+ (Target_Id : Entity_Id;
+ Context_Id : Entity_Id) return Boolean
+ is
+ Encl_Scop : Entity_Id;
+
+ begin
+ -- Elaboration checks are suppressed for the target
+
+ if Elaboration_Checks_Suppressed (Target_Id) then
+ return False;
+ end if;
+
+ -- Otherwise elaboration checks are OK for the target, but may be
+ -- suppressed for the context where the target is declared.
+
+ Encl_Scop := Context_Id;
+ while Present (Encl_Scop) and then Encl_Scop /= Standard_Standard loop
+ if Elaboration_Checks_Suppressed (Encl_Scop) then
+ return False;
+ end if;
+
+ Encl_Scop := Scope (Encl_Scop);
+ end loop;
+
+ -- Neither the target nor its declarative context have elaboration
+ -- checks suppressed.
+
+ return True;
+ end Elaboration_Checks_OK;
+
+ ------------------------------------
+ -- Mark_Elaboration_Attributes_Id --
+ ------------------------------------
+
+ procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id) is
+ begin
+ -- Mark the status of elaboration checks in effect. Do not reset the
+ -- status in case the entity is reanalyzed with checks suppressed.
+
+ if Checks and then not Is_Elaboration_Checks_OK_Id (Id) then
+ Set_Is_Elaboration_Checks_OK_Id (Id,
+ Elaboration_Checks_OK
+ (Target_Id => Id,
+ Context_Id => Scope (Id)));
+
+ -- Entities do not need to capture their enclosing level. The Ghost
+ -- and SPARK modes in effect are already marked during analysis.
+
+ else
+ null;
+ end if;
+ end Mark_Elaboration_Attributes_Id;
+
+ --------------------------------------
+ -- Mark_Elaboration_Attributes_Node --
+ --------------------------------------
+
+ procedure Mark_Elaboration_Attributes_Node (N : Node_Id) is
+ function Extract_Name (N : Node_Id) return Node_Id;
+ -- Obtain the Name attribute of call or instantiation N
+
+ ------------------
+ -- Extract_Name --
+ ------------------
+
+ function Extract_Name (N : Node_Id) return Node_Id is
+ Nam : Node_Id;
+
+ begin
+ Nam := Name (N);
+
+ -- A call to an entry family appears in indexed form
+
+ if Nkind (Nam) = N_Indexed_Component then
+ Nam := Prefix (Nam);
+ end if;
+
+ -- The name may also appear in qualified form
+
+ if Nkind (Nam) = N_Selected_Component then
+ Nam := Selector_Name (Nam);
+ end if;
+
+ return Nam;
+ end Extract_Name;
+
+ -- Local variables
+
+ Context_Id : Entity_Id;
+ Nam : Node_Id;
+
+ -- Start of processing for Mark_Elaboration_Attributes_Node
+
+ begin
+ -- Mark the status of elaboration checks in effect. Do not reset the
+ -- status in case the node is reanalyzed with checks suppressed.
+
+ if Checks and then not Is_Elaboration_Checks_OK_Node (N) then
+
+ -- Assignments, attribute references, and variable references do
+ -- not have a "declarative" context.
+
+ Context_Id := Empty;
+
+ -- The status of elaboration checks for calls and instantiations
+ -- depends on the most recent pragma Suppress/Unsuppress, as well
+ -- as the suppression status of the context where the target is
+ -- defined.
+
+ -- package Pack is
+ -- function Func ...;
+ -- end Pack;
+
+ -- with Pack;
+ -- procedure Main is
+ -- pragma Suppress (Elaboration_Checks, Pack);
+ -- X : ... := Pack.Func;
+ -- ...
+
+ -- In the example above, the call to Func has elaboration checks
+ -- enabled because there is no active general purpose suppression
+ -- pragma, however the elaboration checks of Pack are explicitly
+ -- suppressed. As a result the elaboration checks of the call must
+ -- be disabled in order to preserve this dependency.
+
+ if Nkind_In (N, N_Entry_Call_Statement,
+ N_Function_Call,
+ N_Function_Instantiation,
+ N_Package_Instantiation,
+ N_Procedure_Call_Statement,
+ N_Procedure_Instantiation)
+ then
+ Nam := Extract_Name (N);
+
+ if Is_Entity_Name (Nam) and then Present (Entity (Nam)) then
+ Context_Id := Scope (Entity (Nam));
+ end if;
+ end if;
+
+ Set_Is_Elaboration_Checks_OK_Node (N,
+ Elaboration_Checks_OK
+ (Target_Id => Empty,
+ Context_Id => Context_Id));
+ end if;
+
+ -- Mark the enclosing level of the node. Do not reset the status in
+ -- case the node is relocated and reanalyzed.
+
+ if Level and then not Is_Declaration_Level_Node (N) then
+ Set_Is_Declaration_Level_Node (N,
+ Find_Enclosing_Level (N) = Declaration_Level);
+ end if;
+
+ -- Mark the Ghost and SPARK mode in effect
+
+ if Modes then
+ if Ghost_Mode = Ignore then
+ Set_Is_Ignored_Ghost_Node (N);
+ end if;
+
+ if SPARK_Mode = On then
+ Set_Is_SPARK_Mode_On_Node (N);
+ end if;
+ end if;
+ end Mark_Elaboration_Attributes_Node;
+
+ -- Start of processing for Mark_Elaboration_Attributes
+
+ begin
+ if Nkind (N_Id) in N_Entity then
+ Mark_Elaboration_Attributes_Id (N_Id);
+ else
+ Mark_Elaboration_Attributes_Node (N_Id);
+ end if;
+ end Mark_Elaboration_Attributes;
+
----------------------------------
-- Matching_Static_Array_Bounds --
----------------------------------
end case;
end May_Be_Lvalue;
- -----------------------
- -- Mark_Coextensions --
- -----------------------
-
- procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
- Is_Dynamic : Boolean;
- -- Indicates whether the context causes nested coextensions to be
- -- dynamic or static
-
- function Mark_Allocator (N : Node_Id) return Traverse_Result;
- -- Recognize an allocator node and label it as a dynamic coextension
-
- --------------------
- -- Mark_Allocator --
- --------------------
-
- function Mark_Allocator (N : Node_Id) return Traverse_Result is
- begin
- if Nkind (N) = N_Allocator then
- if Is_Dynamic then
- Set_Is_Dynamic_Coextension (N);
-
- -- If the allocator expression is potentially dynamic, it may
- -- be expanded out of order and require dynamic allocation
- -- anyway, so we treat the coextension itself as dynamic.
- -- Potential optimization ???
-
- elsif Nkind (Expression (N)) = N_Qualified_Expression
- and then Nkind (Expression (Expression (N))) = N_Op_Concat
- then
- Set_Is_Dynamic_Coextension (N);
- else
- Set_Is_Static_Coextension (N);
- end if;
- end if;
-
- return OK;
- end Mark_Allocator;
-
- procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
-
- -- Start of processing for Mark_Coextensions
-
- begin
- -- An allocator that appears on the right-hand side of an assignment is
- -- treated as a potentially dynamic coextension when the right-hand side
- -- is an allocator or a qualified expression.
-
- -- Obj := new ...'(new Coextension ...);
-
- if Nkind (Context_Nod) = N_Assignment_Statement then
- Is_Dynamic :=
- Nkind_In (Expression (Context_Nod), N_Allocator,
- N_Qualified_Expression);
-
- -- An allocator that appears within the expression of a simple return
- -- statement is treated as a potentially dynamic coextension when the
- -- expression is either aggregate, allocator, or qualified expression.
-
- -- return (new Coextension ...);
- -- return new ...'(new Coextension ...);
-
- elsif Nkind (Context_Nod) = N_Simple_Return_Statement then
- Is_Dynamic :=
- Nkind_In (Expression (Context_Nod), N_Aggregate,
- N_Allocator,
- N_Qualified_Expression);
-
- -- An allocator that appears within the initialization expression of an
- -- object declaration is considered a potentially dynamic coextension
- -- when the initialization expression is an allocator or a qualified
- -- expression.
-
- -- Obj : ... := new ...'(new Coextension ...);
-
- -- A similar case arises when the object declaration is part of an
- -- extended return statement.
-
- -- return Obj : ... := new ...'(new Coextension ...);
- -- return Obj : ... := (new Coextension ...);
-
- elsif Nkind (Context_Nod) = N_Object_Declaration then
- Is_Dynamic :=
- Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression)
- or else
- Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
-
- -- This routine should not be called with constructs that cannot contain
- -- coextensions.
-
- else
- raise Program_Error;
- end if;
-
- Mark_Allocators (Root_Nod);
- end Mark_Coextensions;
-
-----------------
-- Might_Raise --
-----------------
-- the subtree being replicated.
elsif not In_Subtree
- (Root => Source,
- N => Declaration_Node (Id))
+ (N => Declaration_Node (Id),
+ Root => Source)
then
return;
end if;
-- the subtree being replicated.
elsif not In_Subtree
- (Root => Source,
- N => Associated_Node_For_Itype (Itype))
+ (N => Associated_Node_For_Itype (Itype),
+ Root => Source)
then
return;
end if;
-- Scope_Within --
------------------
- function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
- Scop : Entity_Id;
+ function Scope_Within
+ (Inner : Entity_Id;
+ Outer : Entity_Id) return Boolean
+ is
+ Curr : Entity_Id;
begin
- Scop := Scope1;
- while Scop /= Standard_Standard loop
- Scop := Scope (Scop);
+ Curr := Inner;
+ while Present (Curr) and then Curr /= Standard_Standard loop
+ Curr := Scope (Curr);
- if Scop = Scope2 then
+ if Curr = Outer then
return True;
end if;
end loop;
-- Scope_Within_Or_Same --
--------------------------
- function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
- Scop : Entity_Id;
+ function Scope_Within_Or_Same
+ (Inner : Entity_Id;
+ Outer : Entity_Id) return Boolean
+ is
+ Curr : Entity_Id;
begin
- Scop := Scope1;
- while Scop /= Standard_Standard loop
- if Scop = Scope2 then
+ Curr := Inner;
+ while Present (Curr) and then Curr /= Standard_Standard loop
+ if Curr = Outer then
return True;
- else
- Scop := Scope (Scop);
end if;
+
+ Curr := Scope (Curr);
end loop;
return False;
-- given, and the reference N is not in the same extended source unit as
-- the declaration of T.
+ function Begin_Keyword_Location (N : Node_Id) return Source_Ptr;
+ -- Given block statement, entry body, package body, subprogram body, or
+ -- task body N, return the closest source location to the "begin" keyword.
+
function Build_Actual_Subtype
(T : Entity_Id;
N : Node_Or_Entity_Id) return Node_Id;
-- instead of 0).
function Defining_Entity
- (N : Node_Id;
- Empty_On_Errors : Boolean := False) return Entity_Id;
+ (N : Node_Id;
+ Empty_On_Errors : Boolean := False;
+ Concurrent_Subunit : Boolean := False) return Entity_Id;
-- Given a declaration N, returns the associated defining entity. If the
-- declaration has a specification, the entity is obtained from the
-- specification. If the declaration has a defining unit name, then the
--
-- The former semantics is appropriate for the back end; the latter
-- semantics is appropriate for the front end.
+ --
+ -- Set flag Concurrent_Subunit to handle rewritings of concurrent bodies
+ -- which act as subunits. Such bodies are generally rewritten as null.
function Denotes_Discriminant
(N : Node_Id;
-- Utility function to return the Ada entity of the subprogram enclosing
-- the entity E, if any. Returns Empty if no enclosing subprogram.
+ function End_Keyword_Location (N : Node_Id) return Source_Ptr;
+ -- Given block statement, entry body, package body, package declaration,
+ -- protected body, [single] protected type declaration, subprogram body,
+ -- task body, or [single] task type declaration N, return the closest
+ -- source location of the "end" keyword.
+
procedure Ensure_Freeze_Node (E : Entity_Id);
-- Make sure a freeze node is allocated for entity E. If necessary, build
-- and initialize a new freeze node and set Has_Delayed_Freeze True for E.
-- Call is set to the node for the corresponding call. If the node N is not
-- an actual parameter then Formal and Call are set to Empty.
- function Find_Specific_Type (CW : Entity_Id) return Entity_Id;
- -- Find specific type of a class-wide type, and handle the case of an
- -- incomplete type coming either from a limited_with clause or from an
- -- incomplete type declaration. If resulting type is private return its
- -- full view.
-
function Find_Body_Discriminal
(Spec_Discriminant : Entity_Id) return Entity_Id;
-- Given a discriminant of the record type that implements a task or
-- discriminant at the same position in this new type.
function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id;
- -- Given an arbitrary entity, try to find the nearest enclosing iterator
- -- loop. If such a loop is found, return the entity of its identifier (the
- -- E_Loop scope), otherwise return Empty.
+ -- Find the nearest iterator loop which encloses arbitrary entity Id. If
+ -- such a loop exists, return the entity of its identifier (E_Loop scope),
+ -- otherwise return Empty.
+
+ function Find_Enclosing_Scope (N : Node_Id) return Entity_Id;
+ -- Find the nearest scope which encloses arbitrary node N
function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id;
-- Find the nested loop statement in a conditional block. Loops subject to
-- If the state space is that of a package, Pack_Id denotes its entity,
-- otherwise Pack_Id is Empty.
+ function Find_Specific_Type (CW : Entity_Id) return Entity_Id;
+ -- Find specific type of a class-wide type, and handle the case of an
+ -- incomplete type coming either from a limited_with clause or from an
+ -- incomplete type declaration. If resulting type is private return its
+ -- full view.
+
function Find_Static_Alternative (N : Node_Id) return Node_Id;
-- N is a case statement whose expression is a compile-time value.
-- Determine the alternative chosen, so that the code of non-selected
-- subprogram or entry and returns it, or if no subprogram can be found,
-- returns Empty.
- function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id;
- pragma Inline (Get_Task_Body_Procedure);
+ function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id;
-- Given an entity for a task type or subtype, retrieves the
-- Task_Body_Procedure field from the corresponding task type declaration.
-- as expressed in pragma Refined_State. This function does not take into
-- account the visible refinement region of abstract state Id.
- function Has_Null_Body (Proc_Id : Entity_Id) return Boolean;
- -- Determine whether the body of procedure Proc_Id contains a sole
- -- null statement, possibly followed by an optional return. Used to
- -- optimize useless calls to assertion checks.
+ function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean;
+ -- Determine whether subprogram Subp has a class-wide precondition that is
+ -- not statically True.
- function Has_Non_Trivial_Precondition (P : Entity_Id) return Boolean;
- -- True if subprogram has a class-wide precondition that is not
- -- statically True.
+ function Has_Null_Body (Proc_Id : Entity_Id) return Boolean;
+ -- Determine whether the body of procedure Proc_Id contains a sole null
+ -- statement, possibly followed by an optional return. Used to optimize
+ -- useless calls to assertion checks.
function Has_Null_Exclusion (N : Node_Id) return Boolean;
-- Determine whether node N has a null exclusion
-- Returns True if current scope is with the private part or the body of
-- an instance. Other semantic checks are suppressed in this context.
- function In_Instance_Visible_Part return Boolean;
- -- Returns True if current scope is within the visible part of a package
- -- instance, where several additional semantic checks apply.
+ function In_Instance_Visible_Part
+ (Id : Entity_Id := Current_Scope) return Boolean;
+ -- Returns True if arbitrary entity Id is within the visible part of a
+ -- package instance, where several additional semantic checks apply.
function In_Package_Body return Boolean;
-- Returns True if current scope is within a package body
-- appearing anywhere within such a construct (that is it does not need
-- to be directly within).
- function In_Subtree (Root : Node_Id; N : Node_Id) return Boolean;
+ function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean;
-- Determine whether node N is within the subtree rooted at Root
+ function In_Subtree
+ (N : Node_Id;
+ Root1 : Node_Id;
+ Root2 : Node_Id) return Boolean;
+ -- Determine whether node N is within the subtree rooted at Root1 or Root2.
+ -- This version is more efficient than calling the single root version of
+ -- Is_Subtree twice.
+
function In_Visible_Part (Scope_Id : Entity_Id) return Boolean;
-- Determine whether a declaration occurs within the visible part of a
-- package specification. The package must be on the scope stack, and the
-- persistent. A private type is potentially persistent if the full type
-- is potentially persistent.
+ function Is_Preelaborable_Aggregate (Aggr : Node_Id) return Boolean;
+ -- Determine whether aggregate Aggr violates the restrictions of
+ -- preelaborable constructs as defined in ARM 10.2.1(5-9).
+
+ function Is_Preelaborable_Construct (N : Node_Id) return Boolean;
+ -- Determine whether arbitrary node N violates the restrictions of
+ -- preelaborable constructs as defined in ARM 10.2.1(5-9).
+
function Is_Protected_Self_Reference (N : Node_Id) return Boolean;
-- Return True if node N denotes a protected type name which represents
-- the current instance of a protected object according to RM 9.4(21/2).
-- statement in Statements (HSS) that has Comes_From_Source set. If no
-- such statement exists, Empty is returned.
+ procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id);
+ -- Given a node which designates the context of analysis and an origin in
+ -- the tree, traverse from Root_Nod and mark all allocators as either
+ -- dynamic or static depending on Context_Nod. Any incorrect marking is
+ -- cleaned up during resolution.
+
+ procedure Mark_Elaboration_Attributes
+ (N_Id : Node_Or_Entity_Id;
+ Checks : Boolean := False;
+ Level : Boolean := False;
+ Modes : Boolean := False);
+ -- Preserve relevant elaboration-related properties of the context in
+ -- arbitrary entity or node N_Id. When flag Checks is set, the routine
+ -- saves the status of Elaboration_Check. When flag Level is set, the
+ -- routine captures the declaration level of N_Id if applicable. When
+ -- flag Modes is set, the routine saves the Ghost and SPARK modes in
+ -- effect if applicable.
+
function Matching_Static_Array_Bounds
(L_Typ : Node_Id;
R_Typ : Node_Id) return Boolean;
-- same number of dimensions, and the same static bounds for each index
-- position.
- procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id);
- -- Given a node which designates the context of analysis and an origin in
- -- the tree, traverse from Root_Nod and mark all allocators as either
- -- dynamic or static depending on Context_Nod. Any incorrect marking is
- -- cleaned up during resolution.
-
function May_Be_Lvalue (N : Node_Id) return Boolean;
-- Determines if N could be an lvalue (e.g. an assignment left hand side).
-- An lvalue is defined as any expression which appears in a context where
-- this is the case, and False if no scalar parts are present (meaning that
-- the result of Valid_Scalars applied to T is always vacuously True).
- function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean;
- -- Determines if the entity Scope1 is the same as Scope2, or if it is
- -- inside it, where both entities represent scopes. Note that scopes
- -- are only partially ordered, so Scope_Within_Or_Same (A,B) and
- -- Scope_Within_Or_Same (B,A) can both be False for a given pair A,B.
-
- function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean;
- -- Like Scope_Within_Or_Same, except that this function returns
- -- False in the case where Scope1 and Scope2 are the same scope.
+ function Scope_Within
+ (Inner : Entity_Id;
+ Outer : Entity_Id) return Boolean;
+ -- Determine whether scope Inner appears within scope Outer. Note that
+ -- scopes are partially ordered, so Scope_Within (A, B) and Scope_Within
+ -- (B, A) may both return False.
+
+ function Scope_Within_Or_Same
+ (Inner : Entity_Id;
+ Outer : Entity_Id) return Boolean;
+ -- Determine whether scope Inner appears within scope Outer or both renote
+ -- the same scope. Note that scopes are partially ordered, so Scope_Within
+ -- (A, B) and Scope_Within (B, A) may both return False.
procedure Set_Convention (E : Entity_Id; Val : Convention_Id);
-- Same as Basic_Set_Convention, but with an extra check for access types.
-- If so, Ref is set to point to the reference node, and Var is set to
-- the referenced Entity.
+ function Has_Condition_Actions (Iter : Node_Id) return Boolean;
+ -- Determine whether iteration scheme Iter has meaningful condition
+ -- actions.
+
function Has_Indirection (T : Entity_Id) return Boolean;
-- If the controlling variable is an access type, or is a record type
-- with access components, assume that it is changed indirectly and
end if;
end Find_Var;
+ ---------------------------
+ -- Has_Condition_Actions --
+ ---------------------------
+
+ function Has_Condition_Actions (Iter : Node_Id) return Boolean is
+ Action : Node_Id;
+
+ begin
+ -- A call marker is not considered a meaningful action because it
+ -- acts as an annotation and has no runtime semantics.
+
+ Action := First (Condition_Actions (Iter));
+ while Present (Action) loop
+ if Nkind (Action) /= N_Call_Marker then
+ return True;
+ end if;
+
+ Next (Action);
+ end loop;
+
+ return False;
+ end Has_Condition_Actions;
+
---------------------
-- Has_Indirection --
---------------------
-- Skip processing for while iteration with conditions actions,
-- since they make it too complicated to get the warning right.
- if Present (Condition_Actions (Iter)) then
+ if Has_Condition_Actions (Iter) then
return;
end if;
-- uniform format of the conditions following this. Note that csinfo
-- expects this uniform format.
- function ABE_Is_Certain
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Procedure_Call_Statement
- or else NT (N).Nkind = N_Procedure_Instantiation);
- return Flag18 (N);
- end ABE_Is_Certain;
-
function Abort_Present
(N : Node_Id) return Boolean is
begin
end Classifications;
function Cleanup_Actions
- (N : Node_Id) return List_Id is
+ (N : Node_Id) return List_Id is
begin
pragma Assert (False
or else NT (N).Nkind = N_Block_Statement);
end Cleanup_Actions;
function Comes_From_Extended_Return_Statement
- (N : Node_Id) return Boolean is
+ (N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Simple_Return_Statement);
or else NT (N).Nkind = N_Assignment_Statement
or else NT (N).Nkind = N_Selected_Component
or else NT (N).Nkind = N_Type_Conversion);
- return Flag1 (N);
+ return Flag3 (N);
end Do_Discriminant_Check;
function Do_Division_Check
return Flag16 (N);
end Is_Controlling_Actual;
- function Is_Disabled
+ function Is_Declaration_Level_Node
(N : Node_Id) return Boolean is
begin
pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification
- or else NT (N).Nkind = N_Pragma);
- return Flag15 (N);
- end Is_Disabled;
+ or else NT (N).Nkind = N_Call_Marker
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Procedure_Instantiation);
+ return Flag5 (N);
+ end Is_Declaration_Level_Node;
function Is_Delayed_Aspect
(N : Node_Id) return Boolean is
return Flag14 (N);
end Is_Delayed_Aspect;
+ function Is_Disabled
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aspect_Specification
+ or else NT (N).Nkind = N_Pragma);
+ return Flag15 (N);
+ end Is_Disabled;
+
+ function Is_Dispatching_Call
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Call_Marker);
+ return Flag3 (N);
+ end Is_Dispatching_Call;
+
function Is_Dynamic_Coextension
(N : Node_Id) return Boolean is
begin
return Flag1 (N);
end Is_Effective_Use_Clause;
+ function Is_Elaboration_Checks_OK_Node
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_Attribute_Reference
+ or else NT (N).Nkind = N_Call_Marker
+ or else NT (N).Nkind = N_Entry_Call_Statement
+ or else NT (N).Nkind = N_Expanded_Name
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Identifier
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Procedure_Call_Statement
+ or else NT (N).Nkind = N_Procedure_Instantiation
+ or else NT (N).Nkind = N_Requeue_Statement);
+ return Flag1 (N);
+ end Is_Elaboration_Checks_OK_Node;
+
function Is_Elsif
- (N : Node_Id) return Boolean is
+ (N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_If_Expression);
return Flag4 (N);
end Is_Inherited_Pragma;
+ function Is_Initialization_Block
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement);
+ return Flag1 (N);
+ end Is_Initialization_Block;
+
+ function Is_Known_Guaranteed_ABE
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Call_Marker
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Procedure_Instantiation);
+ return Flag18 (N);
+ end Is_Known_Guaranteed_ABE;
+
function Is_Machine_Number
(N : Node_Id) return Boolean is
begin
return Flag4 (N);
end Is_Qualified_Universal_Literal;
+ function Is_Recorded_Scenario
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Call_Marker
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Procedure_Instantiation);
+ return Flag6 (N);
+ end Is_Recorded_Scenario;
+
+ function Is_Source_Call
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Call_Marker);
+ return Flag4 (N);
+ end Is_Source_Call;
+
+ function Is_SPARK_Mode_On_Node
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_Attribute_Reference
+ or else NT (N).Nkind = N_Call_Marker
+ or else NT (N).Nkind = N_Entry_Call_Statement
+ or else NT (N).Nkind = N_Expanded_Name
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Identifier
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Procedure_Call_Statement
+ or else NT (N).Nkind = N_Procedure_Instantiation
+ or else NT (N).Nkind = N_Requeue_Statement);
+ return Flag2 (N);
+ end Is_SPARK_Mode_On_Node;
+
function Is_Static_Coextension
(N : Node_Id) return Boolean is
begin
return Flag7 (N);
end No_Ctrl_Actions;
- function No_Elaboration_Check
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Procedure_Call_Statement);
- return Flag14 (N);
- end No_Elaboration_Check;
-
function No_Entities_Ref_In_Spec
(N : Node_Id) return Boolean is
begin
begin
pragma Assert (False
or else NT (N).Nkind = N_Function_Call);
- return Flag1 (N);
+ return Flag17 (N);
end No_Side_Effect_Removal;
function No_Truncation
return Flag15 (N);
end Tagged_Present;
+ function Target
+ (N : Node_Id) return Entity_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Call_Marker);
+ return Node1 (N);
+ end Target;
+
function Target_Type
(N : Node_Id) return Entity_Id is
begin
return Elist2 (N);
end Used_Operations;
+ function Was_Attribute_Reference
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subprogram_Body);
+ return Flag2 (N);
+ end Was_Attribute_Reference;
+
function Was_Expression_Function
(N : Node_Id) return Boolean is
begin
-- Field Set Procedures --
--------------------------
- procedure Set_ABE_Is_Certain
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Function_Instantiation
- or else NT (N).Nkind = N_Package_Instantiation
- or else NT (N).Nkind = N_Procedure_Call_Statement
- or else NT (N).Nkind = N_Procedure_Instantiation);
- Set_Flag18 (N, Val);
- end Set_ABE_Is_Certain;
-
procedure Set_Abort_Present
(N : Node_Id; Val : Boolean := True) is
begin
or else NT (N).Nkind = N_Assignment_Statement
or else NT (N).Nkind = N_Selected_Component
or else NT (N).Nkind = N_Type_Conversion);
- Set_Flag1 (N, Val);
+ Set_Flag3 (N, Val);
end Set_Do_Discriminant_Check;
procedure Set_Do_Division_Check
Set_Flag16 (N, Val);
end Set_Is_Controlling_Actual;
+ procedure Set_Is_Declaration_Level_Node
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Call_Marker
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Procedure_Instantiation);
+ Set_Flag5 (N, Val);
+ end Set_Is_Declaration_Level_Node;
+
procedure Set_Is_Delayed_Aspect
(N : Node_Id; Val : Boolean := True) is
begin
Set_Flag15 (N, Val);
end Set_Is_Disabled;
+ procedure Set_Is_Dispatching_Call
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Call_Marker);
+ Set_Flag3 (N, Val);
+ end Set_Is_Dispatching_Call;
+
procedure Set_Is_Dynamic_Coextension
(N : Node_Id; Val : Boolean := True) is
begin
Set_Flag1 (N, Val);
end Set_Is_Effective_Use_Clause;
+ procedure Set_Is_Elaboration_Checks_OK_Node
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_Attribute_Reference
+ or else NT (N).Nkind = N_Call_Marker
+ or else NT (N).Nkind = N_Entry_Call_Statement
+ or else NT (N).Nkind = N_Expanded_Name
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Identifier
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Procedure_Call_Statement
+ or else NT (N).Nkind = N_Procedure_Instantiation
+ or else NT (N).Nkind = N_Requeue_Statement);
+ Set_Flag1 (N, Val);
+ end Set_Is_Elaboration_Checks_OK_Node;
+
procedure Set_Is_Elsif
- (N : Node_Id; Val : Boolean := True) is
+ (N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_If_Expression);
Set_Flag4 (N, Val);
end Set_Is_Inherited_Pragma;
+ procedure Set_Is_Initialization_Block
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement);
+ Set_Flag1 (N, Val);
+ end Set_Is_Initialization_Block;
+
+ procedure Set_Is_Known_Guaranteed_ABE
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Call_Marker
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Procedure_Instantiation);
+ Set_Flag18 (N, Val);
+ end Set_Is_Known_Guaranteed_ABE;
+
procedure Set_Is_Machine_Number
(N : Node_Id; Val : Boolean := True) is
begin
Set_Flag4 (N, Val);
end Set_Is_Qualified_Universal_Literal;
+ procedure Set_Is_Recorded_Scenario
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Call_Marker
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Procedure_Instantiation);
+ Set_Flag6 (N, Val);
+ end Set_Is_Recorded_Scenario;
+
+ procedure Set_Is_Source_Call
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Call_Marker);
+ Set_Flag4 (N, Val);
+ end Set_Is_Source_Call;
+
+ procedure Set_Is_SPARK_Mode_On_Node
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_Attribute_Reference
+ or else NT (N).Nkind = N_Call_Marker
+ or else NT (N).Nkind = N_Entry_Call_Statement
+ or else NT (N).Nkind = N_Expanded_Name
+ or else NT (N).Nkind = N_Function_Call
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Identifier
+ or else NT (N).Nkind = N_Package_Instantiation
+ or else NT (N).Nkind = N_Procedure_Call_Statement
+ or else NT (N).Nkind = N_Procedure_Instantiation
+ or else NT (N).Nkind = N_Requeue_Statement);
+ Set_Flag2 (N, Val);
+ end Set_Is_SPARK_Mode_On_Node;
+
procedure Set_Is_Static_Coextension
(N : Node_Id; Val : Boolean := True) is
begin
Set_Flag7 (N, Val);
end Set_No_Ctrl_Actions;
- procedure Set_No_Elaboration_Check
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Function_Call
- or else NT (N).Nkind = N_Procedure_Call_Statement);
- Set_Flag14 (N, Val);
- end Set_No_Elaboration_Check;
-
procedure Set_No_Entities_Ref_In_Spec
(N : Node_Id; Val : Boolean := True) is
begin
begin
pragma Assert (False
or else NT (N).Nkind = N_Function_Call);
- Set_Flag1 (N, Val);
+ Set_Flag17 (N, Val);
end Set_No_Side_Effect_Removal;
procedure Set_No_Truncation
Set_Flag15 (N, Val);
end Set_Tagged_Present;
+ procedure Set_Target
+ (N : Node_Id; Val : Entity_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Call_Marker);
+ Set_Node1 (N, Val); -- semantic field, no parent set
+ end Set_Target;
+
procedure Set_Target_Type
(N : Node_Id; Val : Entity_Id) is
begin
Set_Elist2 (N, Val);
end Set_Used_Operations;
+ procedure Set_Was_Attribute_Reference
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subprogram_Body);
+ Set_Flag2 (N, Val);
+ end Set_Was_Attribute_Reference;
+
procedure Set_Was_Expression_Function
(N : Node_Id; Val : Boolean := True) is
begin
-- section describes the usage of the semantic fields, which are used to
-- contain additional information determined during semantic analysis.
- -- ABE_Is_Certain (Flag18-Sem)
- -- This flag is set in an instantiation node or a call node is determined
- -- to be sure to raise an ABE. This is used to trigger special handling
- -- of such cases, particularly in the instantiation case where we avoid
- -- instantiating the body if this flag is set. This flag is also present
- -- in an N_Formal_Package_Declaration node since formal package
- -- declarations are treated like instantiations, but it is always set to
- -- False in this context.
-
-- Accept_Handler_Records (List5-Sem)
-- This field is present only in an N_Accept_Alternative node. It is used
-- to temporarily hold the exception handler records from an accept
-- that an accessibility check is required for the parameter. It is
-- not yet decided who takes care of this check (TBD ???).
- -- Do_Discriminant_Check (Flag1-Sem)
+ -- Do_Discriminant_Check (Flag3-Sem)
-- This flag is set on N_Selected_Component nodes to indicate that a
-- discriminant check is required using the discriminant check routine
-- associated with the selector. The actual check is generated by the
-- place in the various Analyze_xxx_In_Decl_Part routines which perform
-- full analysis. The flag prevents the reanalysis of a delayed pragma.
- -- Is_Expanded_Contract (Flag1-Sem)
- -- Present in N_Contract nodes. Set if the contract has already undergone
- -- expansion activities.
-
-- Is_Asynchronous_Call_Block (Flag7-Sem)
-- A flag set in a Block_Statement node to indicate that it is the
-- expansion of an asynchronous entry call. Such a block needs cleanup
-- a dispatching call. It is off in all other cases. See Sem_Disp for
-- details of its use.
+ -- Is_Declaration_Level_Node (Flag5-Sem)
+ -- Present in call marker and instantiation nodes. Set when the constuct
+ -- appears within the declarations of a block statement, an entry body,
+ -- a subprogram body, or a task body. The flag aids the ABE Processing
+ -- phase to catch certain forms of guaranteed ABEs.
+
-- Is_Delayed_Aspect (Flag14-Sem)
-- Present in N_Pragma and N_Attribute_Definition_Clause nodes which
-- come from aspect specifications, where the evaluation of the aspect
-- If this flag is set, the aspect or policy is not analyzed for semantic
-- correctness, so any expressions etc will not be marked as analyzed.
+ -- Is_Dispatching_Call (Flag3-Sem)
+ -- Present in call marker nodes. Set when the related call which prompted
+ -- the creation of the marker is dispatching.
+
-- Is_Dynamic_Coextension (Flag18-Sem)
-- Present in allocator nodes, to indicate that this is an allocator
-- for an access discriminant of a dynamically allocated object. The
-- Present in both N_Use_Type_Clause and N_Use_Package_Clause to indicate
-- a use clause is "used" in the current source.
+ -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
+ -- Present in nodes which represent an elaboration scenario. Those are
+ -- assignment statement, attribute reference, call marker, entry call
+ -- statement, expanded name, function call, identifier, instantiation,
+ -- procedure call statement, and requeue statement nodes. Set when the
+ -- node appears within a context which allows for the generation of
+ -- run-time ABE checks. This flag detemines whether the ABE Processing
+ -- phase generates conditional ABE checks and guaranteed ABE failures.
+
-- Is_Entry_Barrier_Function (Flag8-Sem)
-- This flag is set on N_Subprogram_Declaration and N_Subprogram_Body
-- nodes which emulate the barrier function of a protected entry body.
-- actuals to support a build-in-place style of call have been added to
-- the call.
+ -- Is_Expanded_Contract (Flag1-Sem)
+ -- Present in N_Contract nodes. Set if the contract has already undergone
+ -- expansion activities.
+
-- Is_Finalization_Wrapper (Flag9-Sem)
-- This flag is present in N_Block_Statement nodes. It is set when the
-- block acts as a wrapper of a handled construct which has controlled
-- This flag is set in an N_Pragma node that appears in a N_Contract node
-- to indicate that the pragma has been inherited from a parent context.
+ -- Is_Initialization_Block (Flag1-Sem)
+ -- Defined in block nodes. Set when the block statement was created by
+ -- the finalization machinery to wrap initialization statements. This
+ -- flag aids the ABE Processing phase to suppress the diagnostics of
+ -- finalization actions in initialization contexts.
+
+ -- Is_Known_Guaranteed_ABE (Flag18-Sem)
+ -- Present in call markers and instantiations. Set when the elaboration
+ -- or evaluation of the scenario results in a guaranteed ABE. The flag
+ -- is used to suppress the instantiation of generic bodies because gigi
+ -- cannot handle certain forms of premature instantiation, as well as to
+ -- prevent the reexamination of the node by the ABE Processing phase.
+
-- Is_Machine_Number (Flag11-Sem)
-- This flag is set in an N_Real_Literal node to indicate that the value
-- is a machine number. This avoids some unnecessary cases of converting
-- the resolution of accidental overloading of binary or unary operators
-- which may occur in instances.
+ -- Is_Recorded_Scenario (Flag6-Sem)
+ -- Present in call marker and instantiation nodes. Set when the scenario
+ -- was saved by the ABE Recording phase. This flag aids the ABE machinery
+ -- to keep its internal data up-to-date in case the node is transformed
+ -- by Atree.Rewrite.
+
+ -- Is_Source_Call (Flag4-Sem)
+ -- Present in call marker nodes. Set when the related call came from
+ -- source.
+
+ -- Is_SPARK_Mode_On_Node (Flag2-Sem)
+ -- Present in nodes which represent an elaboration scenario. Those are
+ -- assignment statement, attribute reference, call marker, entry call
+ -- statement, expanded name, function call, identifier, instantiation,
+ -- procedure call statement, and requeue statement nodes. Set when the
+ -- node appears within a context subject to SPARK_Mode On. This flag
+ -- determines when the SPARK model of elaboration be activated by the
+ -- ABE Processing phase.
+
-- Is_Static_Coextension (Flag14-Sem)
-- Present in N_Allocator nodes. Set if the allocator is a coextension
-- of an object allocated on the stack rather than the heap.
-- expansions where the generated assignments are initializations, not
-- real assignments.
- -- No_Elaboration_Check (Flag14-Sem)
- -- Present in N_Function_Call and N_Procedure_Call_Statement. Indicates
- -- that no elaboration check is needed on the call, because it appears in
- -- the context of a local Suppress pragma. This is used on calls within
- -- task bodies, where the actual elaboration checks are applied after
- -- analysis, when the local scope stack is not present.
-
-- No_Entities_Ref_In_Spec (Flag8-Sem)
-- Present in N_With_Clause nodes. Set if the with clause is on the
-- package or subprogram spec where the main unit is the corresponding
-- It is used to indicate that processing for extended overflow checking
-- modes is not required (this is used to prevent infinite recursion).
- -- No_Side_Effect_Removal (Flag1-Sem)
+ -- No_Side_Effect_Removal (Flag17-Sem)
-- Present in N_Function_Call nodes. Set when a function call does not
-- require side effect removal. This attribute suppresses the generation
-- of a temporary to capture the result of the function which eventually
-- of a FOR loop is known to be null, or is probably null (loop would
-- only execute if invalid values are present).
+ -- Target (Node1-Sem)
+ -- Present in call marker nodes. References the entity of the entry,
+ -- operator, or subprogram invoked by the related call or requeue.
+
-- Target_Type (Node2-Sem)
-- Used in an N_Validate_Unchecked_Conversion node to point to the target
-- type entity for the unchecked conversion instantiation which gigi must
-- on exit from the scope of the use_type_clause, in particular in the
-- case of Use_All_Type, when those operations several scopes.
+ -- Was_Attribute_Reference (Flag2-Sem)
+ -- Present in N_Subprogram_Body. Set to True if the original source is an
+ -- attribute reference which is an actual in a generic instantiation. The
+ -- instantiation prologue renames these attributes, and expansion later
+ -- converts them into subprogram bodies.
+
-- Was_Expression_Function (Flag18-Sem)
-- Present in N_Subprogram_Body. True if the original source had an
-- N_Expression_Function, which was converted to the N_Subprogram_Body
-- Entity (Node4-Sem)
-- Associated_Node (Node4-Sem)
-- Original_Discriminant (Node2-Sem)
+ -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
+ -- Is_SPARK_Mode_On_Node (Flag2-Sem)
+ -- Has_Private_View (Flag11-Sem) (set in generic units)
-- Redundant_Use (Flag13-Sem)
-- Atomic_Sync_Required (Flag14-Sem)
- -- Has_Private_View (Flag11-Sem) (set in generic units)
-- plus fields for expression
--------------------------
-- Corresponding_Aspect (Node3-Sem) (set to Empty if not present)
-- Pragma_Identifier (Node4)
-- Next_Rep_Item (Node5-Sem)
- -- Class_Present (Flag6) set if from Aspect with 'Class
- -- From_Aspect_Specification (Flag13-Sem)
- -- Import_Interface_Present (Flag16-Sem)
+ -- Is_Generic_Contract_Pragma (Flag2-Sem)
+ -- Is_Checked_Ghost_Pragma (Flag3-Sem)
+ -- Is_Inherited_Pragma (Flag4-Sem)
-- Is_Analyzed_Pragma (Flag5-Sem)
+ -- Class_Present (Flag6) set if from Aspect with 'Class
+ -- Uneval_Old_Accept (Flag7-Sem)
+ -- Is_Ignored_Ghost_Pragma (Flag8-Sem)
+ -- Is_Ignored (Flag9-Sem)
-- Is_Checked (Flag11-Sem)
- -- Is_Checked_Ghost_Pragma (Flag3-Sem)
+ -- From_Aspect_Specification (Flag13-Sem)
-- Is_Delayed_Aspect (Flag14-Sem)
-- Is_Disabled (Flag15-Sem)
- -- Is_Generic_Contract_Pragma (Flag2-Sem)
- -- Is_Ignored (Flag9-Sem)
- -- Is_Ignored_Ghost_Pragma (Flag8-Sem)
- -- Is_Inherited_Pragma (Flag4-Sem)
+ -- Import_Interface_Present (Flag16-Sem)
-- Split_PPC (Flag17) set if corresponding aspect had Split_PPC set
- -- Uneval_Old_Accept (Flag7-Sem)
-- Uneval_Old_Warn (Flag18-Sem)
-- Note: we should have a section on what pragmas are passed on to
-- Sloc points to ALL
-- Prefix (Node3)
-- Actual_Designated_Subtype (Node4-Sem)
- -- Atomic_Sync_Required (Flag14-Sem)
-- Has_Dereference_Action (Flag13-Sem)
+ -- Atomic_Sync_Required (Flag14-Sem)
-- plus fields for expression
-------------------------------
-- Prefix (Node3)
-- Selector_Name (Node2)
-- Associated_Node (Node4-Sem)
- -- Do_Discriminant_Check (Flag1-Sem)
+ -- Do_Discriminant_Check (Flag3-Sem)
-- Is_In_Discriminant_Check (Flag11-Sem)
- -- Is_Prefixed_Call (Flag17-Sem)
-- Atomic_Sync_Required (Flag14-Sem)
+ -- Is_Prefixed_Call (Flag17-Sem)
-- plus fields for expression
--------------------------
-- Expressions (List1) (set to No_List if no associated expressions)
-- Entity (Node4-Sem) used if the attribute yields a type
-- Associated_Node (Node4-Sem)
- -- Do_Overflow_Check (Flag17-Sem)
+ -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
+ -- Is_SPARK_Mode_On_Node (Flag2-Sem)
-- Header_Size_Added (Flag11-Sem)
- -- Must_Be_Byte_Aligned (Flag14-Sem)
-- Redundant_Use (Flag13-Sem)
+ -- Must_Be_Byte_Aligned (Flag14-Sem)
-- plus fields for expression
-- Note: in Modify_Tree_For_C mode, Max and Min attributes are expanded
----------------------------------
-- NAMED_ARRAY_AGGREGATE ::=
- -- | (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})
+ -- (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})
-- See Record_Aggregate (4.3.1) for node structure
-- Sloc points to first token of subtype mark
-- Subtype_Mark (Node4)
-- Expression (Node3)
- -- Do_Discriminant_Check (Flag1-Sem)
+ -- Do_Discriminant_Check (Flag3-Sem)
-- Do_Length_Check (Flag4-Sem)
-- Float_Truncate (Flag11-Sem)
-- Do_Tag_Check (Flag13-Sem)
-- Sloc points to :=
-- Name (Node2)
-- Expression (Node3)
- -- Do_Discriminant_Check (Flag1-Sem)
- -- Do_Tag_Check (Flag13-Sem)
+ -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
+ -- Is_SPARK_Mode_On_Node (Flag2-Sem)
+ -- Do_Discriminant_Check (Flag3-Sem)
-- Do_Length_Check (Flag4-Sem)
-- Forwards_OK (Flag5-Sem)
-- Backwards_OK (Flag6-Sem)
-- No_Ctrl_Actions (Flag7-Sem)
-- Has_Target_Names (Flag8-Sem)
+ -- Do_Tag_Check (Flag13-Sem)
-- Componentwise_Assignment (Flag14-Sem)
-- Suppress_Assignment_Checks (Flag18-Sem)
-- Identifier (Node1) block direct name (set to Empty if not present)
-- Declarations (List2) (set to No_List if no DECLARE part)
-- Handled_Statement_Sequence (Node4)
- -- Cleanup_Actions (List5-Sem)
- -- Is_Abort_Block (Flag4-Sem)
- -- Is_Task_Master (Flag5-Sem)
-- Activation_Chain_Entity (Node3-Sem)
+ -- Cleanup_Actions (List5-Sem)
-- Has_Created_Identifier (Flag15)
- -- Is_Task_Allocation_Block (Flag6)
-- Is_Asynchronous_Call_Block (Flag7)
+ -- Is_Task_Allocation_Block (Flag6)
-- Exception_Junk (Flag8-Sem)
+ -- Is_Abort_Block (Flag4-Sem)
-- Is_Finalization_Wrapper (Flag9-Sem)
+ -- Is_Initialization_Block (Flag1-Sem)
+ -- Is_Task_Master (Flag5-Sem)
-------------------------
-- 5.7 Exit Statement --
-- symbol turns out to be a normal string after all.
-- Entity (Node4-Sem)
-- Associated_Node (Node4-Sem)
- -- Has_Private_View (Flag11-Sem) set in generic units.
-- Etype (Node5-Sem)
+ -- Has_Private_View (Flag11-Sem) set in generic units
-- Note: the Strval field may be set to No_String for generated
-- operator symbols that are known not to be string literals
-- Is_Protected_Subprogram_Body (Flag7-Sem)
-- Is_Task_Body_Procedure (Flag1-Sem)
-- Is_Task_Master (Flag5-Sem)
+ -- Was_Attribute_Reference (Flag2-Sem)
-- Was_Expression_Function (Flag18-Sem)
-- Was_Originally_Stub (Flag13-Sem)
-- actual parameter part)
-- First_Named_Actual (Node4-Sem)
-- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
+ -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
+ -- Is_SPARK_Mode_On_Node (Flag2-Sem)
-- Do_Tag_Check (Flag13-Sem)
- -- No_Elaboration_Check (Flag14-Sem)
- -- ABE_Is_Certain (Flag18-Sem)
-- plus fields for expression
-- If any IN parameter requires a range check, then the corresponding
-- actual parameter part)
-- First_Named_Actual (Node4-Sem)
-- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
- -- No_Side_Effect_Removal (Flag1-Sem)
+ -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
+ -- Is_SPARK_Mode_On_Node (Flag2-Sem)
-- Is_Expanded_Build_In_Place_Call (Flag11-Sem)
-- Do_Tag_Check (Flag13-Sem)
- -- No_Elaboration_Check (Flag14-Sem)
- -- ABE_Is_Certain (Flag18-Sem)
+ -- No_Side_Effect_Removal (Flag17-Sem)
-- plus fields for expression
--------------------------------
-- Parameter_Associations (List3) (set to No_List if no
-- actual parameter part)
-- First_Named_Actual (Node4-Sem)
+ -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
+ -- Is_SPARK_Mode_On_Node (Flag2-Sem)
------------------------------
-- 9.5.4 Requeue Statement --
-- Sloc points to REQUEUE
-- Name (Node2)
-- Abort_Present (Flag15)
+ -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
+ -- Is_SPARK_Mode_On_Node (Flag2-Sem)
--------------------------
-- 9.6 Delay Statement --
-- generic actual part)
-- Parent_Spec (Node4-Sem)
-- Instance_Spec (Node5-Sem)
- -- ABE_Is_Certain (Flag18-Sem)
+ -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
+ -- Is_SPARK_Mode_On_Node (Flag2-Sem)
+ -- Is_Declaration_Level_Node (Flag5-Sem)
+ -- Is_Recorded_Scenario (Flag6-Sem)
+ -- Is_Known_Guaranteed_ABE (Flag18-Sem)
-- N_Procedure_Instantiation
-- Sloc points to PROCEDURE
-- Generic_Associations (List3) (set to No_List if no
-- generic actual part)
-- Instance_Spec (Node5-Sem)
+ -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
+ -- Is_SPARK_Mode_On_Node (Flag2-Sem)
+ -- Is_Declaration_Level_Node (Flag5-Sem)
+ -- Is_Recorded_Scenario (Flag6-Sem)
-- Must_Override (Flag14) set if overriding indicator present
-- Must_Not_Override (Flag15) set if not_overriding indicator present
- -- ABE_Is_Certain (Flag18-Sem)
+ -- Is_Known_Guaranteed_ABE (Flag18-Sem)
-- N_Function_Instantiation
-- Sloc points to FUNCTION
-- generic actual part)
-- Parent_Spec (Node4-Sem)
-- Instance_Spec (Node5-Sem)
+ -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
+ -- Is_SPARK_Mode_On_Node (Flag2-Sem)
+ -- Is_Declaration_Level_Node (Flag5-Sem)
+ -- Is_Recorded_Scenario (Flag6-Sem)
-- Must_Override (Flag14) set if overriding indicator present
-- Must_Not_Override (Flag15) set if not_overriding indicator present
- -- ABE_Is_Certain (Flag18-Sem)
+ -- Is_Known_Guaranteed_ABE (Flag18-Sem)
-- Note: overriding indicator is an Ada 2005 feature
-- empty generic actual part)
-- Box_Present (Flag15)
-- Instance_Spec (Node5-Sem)
- -- ABE_Is_Certain (Flag18-Sem)
--------------------------------------
-- 12.7 Formal Package Actual Part --
-- reconstructed tree printed by Sprint, and the node descriptions here
-- show this syntax.
+ -----------------
+ -- Call_Marker --
+ -----------------
+
+ -- This node is created during the analysis/resolution of entry calls,
+ -- requeues, and subprogram calls. It performs several functions:
+
+ -- * Call markers provide a uniform model for handling calls by the
+ -- ABE mechanism, regardless of whether expansion took place.
+
+ -- * The call marker captures the target of the related call along
+ -- with other attributes which are either unavailabe or expensive
+ -- to recompute once analysis, resolution, and expansion are over.
+
+ -- * The call marker aids the ABE Processing phase by signaling the
+ -- presence of a call in case the original call was transformed by
+ -- expansion.
+
+ -- * The call marker acts as a reference point for the insertion of
+ -- run-time conditional ABE checks or guaranteed ABE failures.
+
+ -- Sprint syntax: #target#
+
+ -- The Sprint syntax shown above is not enabled by default
+
+ -- N_Call_Marker
+ -- Sloc points to Sloc of original call
+ -- Target (Node1-Sem)
+ -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
+ -- Is_SPARK_Mode_On_Node (Flag2-Sem)
+ -- Is_Dispatching_Call (Flag3-Sem)
+ -- Is_Source_Call (Flag4-Sem)
+ -- Is_Declaration_Level_Node (Flag5-Sem)
+ -- Is_Recorded_Scenario (Flag6-Sem)
+ -- Is_Known_Guaranteed_ABE (Flag18-Sem)
+
------------------------
-- Compound Statement --
------------------------
-- Selector_Name (Node2)
-- Entity (Node4-Sem)
-- Associated_Node (Node4-Sem)
- -- Has_Private_View (Flag11-Sem) set in generic units.
+ -- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
+ -- Is_SPARK_Mode_On_Node (Flag2-Sem)
+ -- Has_Private_View (Flag11-Sem) set in generic units
-- Redundant_Use (Flag13-Sem)
-- Atomic_Sync_Required (Flag14-Sem)
-- plus fields for expression
-- Empty --
-----------
- -- Used as the contents of the Nkind field of the dummy Empty node
- -- and in some other situations to indicate an uninitialized value.
+ -- Used as the contents of the Nkind field of the dummy Empty node and in
+ -- some other situations to indicate an uninitialized value.
-- N_Empty
-- Chars (Name1) is set to No_Name
N_Access_Definition,
N_Access_To_Object_Definition,
N_Aspect_Specification,
+ N_Call_Marker,
N_Case_Expression_Alternative,
N_Case_Statement_Alternative,
N_Compilation_Unit,
-- these routines check that they are being applied to an appropriate
-- node, as well as checking that the node is in range.
- function ABE_Is_Certain
- (N : Node_Id) return Boolean; -- Flag18
-
function Abort_Present
(N : Node_Id) return Boolean; -- Flag15
(N : Node_Id) return Boolean; -- Flag13
function Do_Discriminant_Check
- (N : Node_Id) return Boolean; -- Flag1
+ (N : Node_Id) return Boolean; -- Flag3
function Do_Division_Check
(N : Node_Id) return Boolean; -- Flag13
function Is_Controlling_Actual
(N : Node_Id) return Boolean; -- Flag16
+ function Is_Declaration_Level_Node
+ (N : Node_Id) return Boolean; -- Flag5
+
function Is_Delayed_Aspect
(N : Node_Id) return Boolean; -- Flag14
function Is_Disabled
(N : Node_Id) return Boolean; -- Flag15
+ function Is_Dispatching_Call
+ (N : Node_Id) return Boolean; -- Flag3
+
function Is_Dynamic_Coextension
(N : Node_Id) return Boolean; -- Flag18
function Is_Effective_Use_Clause
(N : Node_Id) return Boolean; -- Flag1
+ function Is_Elaboration_Checks_OK_Node
+ (N : Node_Id) return Boolean; -- Flag1
+
function Is_Elsif
(N : Node_Id) return Boolean; -- Flag13
function Is_Inherited_Pragma
(N : Node_Id) return Boolean; -- Flag4
+ function Is_Initialization_Block
+ (N : Node_Id) return Boolean; -- Flag1
+
+ function Is_Known_Guaranteed_ABE
+ (N : Node_Id) return Boolean; -- Flag18
+
function Is_Machine_Number
(N : Node_Id) return Boolean; -- Flag11
function Is_Qualified_Universal_Literal
(N : Node_Id) return Boolean; -- Flag4
+ function Is_Recorded_Scenario
+ (N : Node_Id) return Boolean; -- Flag6
+
+ function Is_Source_Call
+ (N : Node_Id) return Boolean; -- Flag4
+
+ function Is_SPARK_Mode_On_Node
+ (N : Node_Id) return Boolean; -- Flag2
+
function Is_Static_Coextension
(N : Node_Id) return Boolean; -- Flag14
function No_Ctrl_Actions
(N : Node_Id) return Boolean; -- Flag7
- function No_Elaboration_Check
- (N : Node_Id) return Boolean; -- Flag14
-
function No_Entities_Ref_In_Spec
(N : Node_Id) return Boolean; -- Flag8
(N : Node_Id) return Boolean; -- Flag17
function No_Side_Effect_Removal
- (N : Node_Id) return Boolean; -- Flag1
+ (N : Node_Id) return Boolean; -- Flag17
function No_Truncation
(N : Node_Id) return Boolean; -- Flag17
function Tagged_Present
(N : Node_Id) return Boolean; -- Flag15
+ function Target
+ (N : Node_Id) return Entity_Id; -- Node1
+
function Target_Type
(N : Node_Id) return Entity_Id; -- Node2
function Used_Operations
(N : Node_Id) return Elist_Id; -- Elist2
+ function Was_Attribute_Reference
+ (N : Node_Id) return Boolean; -- Flag2
+
function Was_Expression_Function
(N : Node_Id) return Boolean; -- Flag18
-- tree pointers (List1-4), the parent pointer of the Val node is set to
-- point back to node N. This automates the setting of the parent pointer.
- procedure Set_ABE_Is_Certain
- (N : Node_Id; Val : Boolean := True); -- Flag18
-
procedure Set_Abort_Present
(N : Node_Id; Val : Boolean := True); -- Flag15
(N : Node_Id; Val : Boolean := True); -- Flag13
procedure Set_Do_Discriminant_Check
- (N : Node_Id; Val : Boolean := True); -- Flag1
+ (N : Node_Id; Val : Boolean := True); -- Flag3
procedure Set_Do_Division_Check
(N : Node_Id; Val : Boolean := True); -- Flag13
procedure Set_Is_Controlling_Actual
(N : Node_Id; Val : Boolean := True); -- Flag16
+ procedure Set_Is_Declaration_Level_Node
+ (N : Node_Id; Val : Boolean := True); -- Flag5
+
procedure Set_Is_Delayed_Aspect
(N : Node_Id; Val : Boolean := True); -- Flag14
procedure Set_Is_Disabled
(N : Node_Id; Val : Boolean := True); -- Flag15
+ procedure Set_Is_Dispatching_Call
+ (N : Node_Id; Val : Boolean := True); -- Flag3
+
procedure Set_Is_Dynamic_Coextension
(N : Node_Id; Val : Boolean := True); -- Flag18
procedure Set_Is_Effective_Use_Clause
(N : Node_Id; Val : Boolean := True); -- Flag1
+ procedure Set_Is_Elaboration_Checks_OK_Node
+ (N : Node_Id; Val : Boolean := True); -- Flag1
+
procedure Set_Is_Elsif
(N : Node_Id; Val : Boolean := True); -- Flag13
procedure Set_Is_Inherited_Pragma
(N : Node_Id; Val : Boolean := True); -- Flag4
+ procedure Set_Is_Initialization_Block
+ (N : Node_Id; Val : Boolean := True); -- Flag1
+
+ procedure Set_Is_Known_Guaranteed_ABE
+ (N : Node_Id; Val : Boolean := True); -- Flag18
+
procedure Set_Is_Machine_Number
(N : Node_Id; Val : Boolean := True); -- Flag11
procedure Set_Is_Qualified_Universal_Literal
(N : Node_Id; Val : Boolean := True); -- Flag4
+ procedure Set_Is_Recorded_Scenario
+ (N : Node_Id; Val : Boolean := True); -- Flag6
+
+ procedure Set_Is_Source_Call
+ (N : Node_Id; Val : Boolean := True); -- Flag4
+
+ procedure Set_Is_SPARK_Mode_On_Node
+ (N : Node_Id; Val : Boolean := True); -- Flag2
+
procedure Set_Is_Static_Coextension
(N : Node_Id; Val : Boolean := True); -- Flag14
procedure Set_No_Ctrl_Actions
(N : Node_Id; Val : Boolean := True); -- Flag7
- procedure Set_No_Elaboration_Check
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
procedure Set_No_Entities_Ref_In_Spec
(N : Node_Id; Val : Boolean := True); -- Flag8
(N : Node_Id; Val : Boolean := True); -- Flag17
procedure Set_No_Side_Effect_Removal
- (N : Node_Id; Val : Boolean := True); -- Flag1
+ (N : Node_Id; Val : Boolean := True); -- Flag17
procedure Set_No_Truncation
(N : Node_Id; Val : Boolean := True); -- Flag17
procedure Set_Tagged_Present
(N : Node_Id; Val : Boolean := True); -- Flag15
+ procedure Set_Target
+ (N : Node_Id; Val : Entity_Id); -- Node1
+
procedure Set_Target_Type
(N : Node_Id; Val : Entity_Id); -- Node2
procedure Set_Used_Operations
(N : Node_Id; Val : Elist_Id); -- Elist2
+ procedure Set_Was_Attribute_Reference
+ (N : Node_Id; Val : Boolean := True); -- Flag2
+
procedure Set_Was_Expression_Function
(N : Node_Id; Val : Boolean := True); -- Flag18
4 => False, -- SCIL_Entity (Node4-Sem)
5 => False), -- SCIL_Tag_Value (Node5-Sem)
+ N_Call_Marker =>
+ (1 => True, -- Target (Node1-Sem)
+ 2 => False, -- unused
+ 3 => False, -- unused
+ 4 => False, -- unused
+ 5 => False), -- unused
+
-- Entries for Empty, Error and Unused. Even thought these have a Chars
-- field for debugging purposes, they are not really syntactic fields, so
-- we mark all fields as unused.
-- Inline Pragmas --
--------------------
- pragma Inline (ABE_Is_Certain);
pragma Inline (Abort_Present);
pragma Inline (Abortable_Part);
pragma Inline (Abstract_Present);
pragma Inline (Do_Range_Check);
pragma Inline (Do_Storage_Check);
pragma Inline (Do_Tag_Check);
- pragma Inline (Elaborate_Present);
pragma Inline (Elaborate_All_Desirable);
pragma Inline (Elaborate_All_Present);
pragma Inline (Elaborate_Desirable);
+ pragma Inline (Elaborate_Present);
pragma Inline (Else_Actions);
pragma Inline (Else_Statements);
pragma Inline (Elsif_Parts);
pragma Inline (Is_Component_Left_Opnd);
pragma Inline (Is_Component_Right_Opnd);
pragma Inline (Is_Controlling_Actual);
+ pragma Inline (Is_Declaration_Level_Node);
pragma Inline (Is_Delayed_Aspect);
pragma Inline (Is_Disabled);
+ pragma Inline (Is_Dispatching_Call);
pragma Inline (Is_Dynamic_Coextension);
pragma Inline (Is_Effective_Use_Clause);
+ pragma Inline (Is_Elaboration_Checks_OK_Node);
pragma Inline (Is_Elsif);
pragma Inline (Is_Entry_Barrier_Function);
pragma Inline (Is_Expanded_Build_In_Place_Call);
pragma Inline (Is_Ignored_Ghost_Pragma);
pragma Inline (Is_In_Discriminant_Check);
pragma Inline (Is_Inherited_Pragma);
+ pragma Inline (Is_Initialization_Block);
+ pragma Inline (Is_Known_Guaranteed_ABE);
pragma Inline (Is_Machine_Number);
pragma Inline (Is_Null_Loop);
pragma Inline (Is_Overloaded);
pragma Inline (Is_Prefixed_Call);
pragma Inline (Is_Protected_Subprogram_Body);
pragma Inline (Is_Qualified_Universal_Literal);
+ pragma Inline (Is_Recorded_Scenario);
+ pragma Inline (Is_Source_Call);
+ pragma Inline (Is_SPARK_Mode_On_Node);
pragma Inline (Is_Static_Coextension);
pragma Inline (Is_Static_Expression);
pragma Inline (Is_Subprogram_Descriptor);
pragma Inline (Next_Rep_Item);
pragma Inline (Next_Use_Clause);
pragma Inline (No_Ctrl_Actions);
- pragma Inline (No_Elaboration_Check);
pragma Inline (No_Entities_Ref_In_Spec);
pragma Inline (No_Initialization);
pragma Inline (No_Minimize_Eliminate);
pragma Inline (Suppress_Loop_Warnings);
pragma Inline (Synchronized_Present);
pragma Inline (Tagged_Present);
+ pragma Inline (Target);
pragma Inline (Target_Type);
pragma Inline (Task_Definition);
pragma Inline (Task_Present);
pragma Inline (Variants);
pragma Inline (Visible_Declarations);
pragma Inline (Used_Operations);
+ pragma Inline (Was_Attribute_Reference);
pragma Inline (Was_Expression_Function);
pragma Inline (Was_Originally_Stub);
pragma Inline (Withed_Body);
- pragma Inline (Set_ABE_Is_Certain);
pragma Inline (Set_Abort_Present);
pragma Inline (Set_Abortable_Part);
pragma Inline (Set_Abstract_Present);
pragma Inline (Set_Is_Component_Left_Opnd);
pragma Inline (Set_Is_Component_Right_Opnd);
pragma Inline (Set_Is_Controlling_Actual);
+ pragma Inline (Set_Is_Declaration_Level_Node);
pragma Inline (Set_Is_Delayed_Aspect);
pragma Inline (Set_Is_Disabled);
+ pragma Inline (Set_Is_Dispatching_Call);
pragma Inline (Set_Is_Dynamic_Coextension);
pragma Inline (Set_Is_Effective_Use_Clause);
+ pragma Inline (Set_Is_Elaboration_Checks_OK_Node);
pragma Inline (Set_Is_Elsif);
pragma Inline (Set_Is_Entry_Barrier_Function);
pragma Inline (Set_Is_Expanded_Build_In_Place_Call);
pragma Inline (Set_Is_Ignored_Ghost_Pragma);
pragma Inline (Set_Is_In_Discriminant_Check);
pragma Inline (Set_Is_Inherited_Pragma);
+ pragma Inline (Set_Is_Initialization_Block);
+ pragma Inline (Set_Is_Known_Guaranteed_ABE);
pragma Inline (Set_Is_Machine_Number);
pragma Inline (Set_Is_Null_Loop);
pragma Inline (Set_Is_Overloaded);
pragma Inline (Set_Is_Prefixed_Call);
pragma Inline (Set_Is_Protected_Subprogram_Body);
pragma Inline (Set_Is_Qualified_Universal_Literal);
+ pragma Inline (Set_Is_Recorded_Scenario);
+ pragma Inline (Set_Is_Source_Call);
+ pragma Inline (Set_Is_SPARK_Mode_On_Node);
pragma Inline (Set_Is_Static_Coextension);
pragma Inline (Set_Is_Static_Expression);
pragma Inline (Set_Is_Subprogram_Descriptor);
pragma Inline (Set_Next_Rep_Item);
pragma Inline (Set_Next_Use_Clause);
pragma Inline (Set_No_Ctrl_Actions);
- pragma Inline (Set_No_Elaboration_Check);
pragma Inline (Set_No_Entities_Ref_In_Spec);
pragma Inline (Set_No_Initialization);
pragma Inline (Set_No_Minimize_Eliminate);
pragma Inline (Set_Synchronized_Present);
pragma Inline (Set_TSS_Elist);
pragma Inline (Set_Tagged_Present);
+ pragma Inline (Set_Target);
pragma Inline (Set_Target_Type);
pragma Inline (Set_Task_Definition);
pragma Inline (Set_Task_Present);
pragma Inline (Set_Variant_Part);
pragma Inline (Set_Variants);
pragma Inline (Set_Visible_Declarations);
+ pragma Inline (Set_Was_Attribute_Reference);
pragma Inline (Set_Was_Expression_Function);
pragma Inline (Set_Was_Originally_Stub);
pragma Inline (Set_Withed_Body);
Write_Char (';');
+ when N_Call_Marker =>
+ null;
+
+ -- Enable the following code for debugging purposes only
+
+ -- Write_Indent_Str ("#");
+ -- Write_Id (Target (Node));
+ -- Write_Char ('#');
+
when N_Case_Expression =>
declare
Has_Parens : constant Boolean := Paren_Count (Node) > 0;
projects / gcc.git / commitdiff