mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-06 02:20:34 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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.

From-SVN: r253559
This commit is contained in:
Pierre-Marie de Rodat 2017-10-09 19:43:32 +00:00
parent 341af81e6e
commit 90e491a773
43 changed files with 13904 additions and 7891 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

225
gcc/ada/ChangeLog
View File

@ -1,3 +1,228 @@
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.

39
gcc/ada/atree.adb
View File

@ -56,6 +56,9 @@ package body Atree is
Reporting_Proc : Report_Proc := null;
-- Record argument to last call to Set_Reporting_Proc
Rewriting_Proc : Rewrite_Proc := null;
-- This soft link captures the procedure invoked during a node rewrite
---------------
-- Debugging --
---------------
@ -1306,16 +1309,6 @@ package body Atree is
Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6, V7, V8, V9, V10, V11);
end Ekind_In;
------------------------
-- Set_Reporting_Proc --
------------------------
procedure Set_Reporting_Proc (P : Report_Proc) is
begin
pragma Assert (Reporting_Proc = null);
Reporting_Proc := P;
end Set_Reporting_Proc;
------------------
-- Error_Posted --
------------------
@ -2253,6 +2246,12 @@ package body Atree is
if Reporting_Proc /= null then
Reporting_Proc.all (Target => Old_Node, Source => New_Node);
end if;
-- Invoke the rewriting procedure (if available)
if Rewriting_Proc /= null then
Rewriting_Proc.all (Target => Old_Node, Source => New_Node);
end if;
end Rewrite;
------------------
@ -2390,6 +2389,16 @@ package body Atree is
Nodes.Table (N).Link := Union_Id (Val);
end Set_Parent;
------------------------
-- Set_Reporting_Proc --
------------------------
procedure Set_Reporting_Proc (Proc : Report_Proc) is
begin
pragma Assert (Reporting_Proc = null);
Reporting_Proc := Proc;
end Set_Reporting_Proc;
--------------
-- Set_Sloc --
--------------
@ -2400,6 +2409,16 @@ package body Atree is
Nodes.Table (N).Sloc := Val;
end Set_Sloc;
------------------------
-- Set_Rewriting_Proc --
------------------------
procedure Set_Rewriting_Proc (Proc : Rewrite_Proc) is
begin
pragma Assert (Rewriting_Proc = null);
Rewriting_Proc := Proc;
end Set_Rewriting_Proc;
----------
-- Sloc --
----------

28
gcc/ada/atree.ads
View File

@ -572,10 +572,15 @@ package Atree is
type Report_Proc is access procedure (Target : Node_Id; Source : Node_Id);
procedure Set_Reporting_Proc (P : Report_Proc);
procedure Set_Reporting_Proc (Proc : Report_Proc);
-- Register a procedure that is invoked when a node is allocated, replaced
-- or rewritten.
type Rewrite_Proc is access procedure (Target : Node_Id; Source : Node_Id);
procedure Set_Rewriting_Proc (Proc : Rewrite_Proc);
-- Register a procedure that is invoked when a node is rewritten
type Traverse_Result is (Abandon, OK, OK_Orig, Skip);
-- This is the type of the result returned by the Process function passed
-- to Traverse_Func and Traverse_Proc. See below for details.
@ -4231,25 +4236,26 @@ package Atree is
-- for extending components are completely unused.
type Flags_Byte is record
Flag0 : Boolean;
Flag0 : Boolean;
-- Note: we don't use Flag0 at the moment. To put Flag0 into use
-- requires some awkward work in Treeprs (treeprs.adt), so for the
-- moment we don't use it.
Flag1 : Boolean;
Flag2 : Boolean;
Flag3 : Boolean;
Flag1 : Boolean;
Flag2 : Boolean;
Flag3 : Boolean;
-- These flags are used in the usual manner in Sinfo and Einfo
Is_Ignored_Ghost_Node : Boolean;
-- Flag denoting whether the node is subject to pragma Ghost with
-- policy Ignore. The name of the flag should be Flag4, however this
-- requires changing the names of all remaining 300+ flags.
-- The flags listed below use explicit names because following the
-- FlagXXX convention would mean reshuffling of over 300+ flags.
Check_Actuals : Boolean;
-- Flag set to indicate that the marked node is subject to the check
-- for writable actuals. See xxx for more details. Again it would be
-- more uniform to use some Flagx here, but that would be disruptive.
-- for writable actuals.
Is_Ignored_Ghost_Node : Boolean;
-- Flag denoting whether the node is subject to pragma Ghost with
-- policy Ignore.
Spare2 : Boolean;
Spare3 : Boolean;

14
gcc/ada/checks.adb
View File

@ -5398,8 +5398,10 @@ package body Checks is
elsif Checks_May_Be_Suppressed (E) then
if Is_Check_Suppressed (E, Elaboration_Check) then
return True;
elsif Dynamic_Elaboration_Checks then
return Is_Check_Suppressed (E, All_Checks);
else
return False;
end if;
@ -5408,8 +5410,10 @@ package body Checks is
if Scope_Suppress.Suppress (Elaboration_Check) then
return True;
elsif Dynamic_Elaboration_Checks then
return Scope_Suppress.Suppress (All_Checks);
else
return False;
end if;
@ -7927,7 +7931,7 @@ package body Checks is
Flag_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Subp_Id), 'F', -1));
Chars => New_External_Name (Chars (Subp_Id), 'E', -1));
Set_Is_Frozen (Flag_Id);
-- Insert the declaration of the elaboration flag in front of the
@ -7936,7 +7940,7 @@ package body Checks is
Push_Scope (Scope (Subp_Id));
-- Generate:
-- F : Boolean := False;
-- E : Boolean := False;
Insert_Action (Subp_Decl,
Make_Object_Declaration (Loc,
@ -7986,7 +7990,7 @@ package body Checks is
end if;
-- Generate:
-- F := True;
-- E := True;
Insert_After_And_Analyze (Set_Ins,
Make_Assignment_Statement (Loc,
@ -8060,12 +8064,14 @@ package body Checks is
-- since it clearly was not overridden at any point). For a predefined
-- check, we test the specific flag. For a user defined check, we check
-- the All_Checks flag. The Overflow flag requires special handling to
-- deal with the General vs Assertion case
-- deal with the General vs Assertion case.
if C = Overflow_Check then
return Overflow_Checks_Suppressed (Empty);
elsif C in Predefined_Check_Id then
return Scope_Suppress.Suppress (C);
else
return Scope_Suppress.Suppress (All_Checks);
end if;

12
gcc/ada/debug.adb
View File

@ -75,7 +75,7 @@ package body Debug is
-- dI Inhibit internal name numbering in gnatG listing
-- dJ Prepend subprogram name in messages
-- dK Kill all error messages
-- dL Output trace information on elaboration checking
-- dL Ignore external calls from instances for elaboration
-- dM Assume all variables are modified (no current values)
-- dN No file name information in exception messages
-- dO Output immediate error messages
@ -414,10 +414,9 @@ package body Debug is
-- of all error messages. It is used in regression tests where the
-- error messages are target dependent and irrelevant.
-- dL Output trace information on elaboration checking. This debug
-- switch causes output to be generated showing each call or
-- instantiation as it is checked, and the progress of the recursive
-- trace through elaboration calls at compile time.
-- dL The compiler ignores calls in instances and invoke subprograms
-- which are external to the instance for the static elaboration
-- model. This switch is orthogonal to d.G.
-- dM Assume all variables have been modified, and ignore current value
-- indications. This debug flag disconnects the tracking of constant
@ -664,7 +663,8 @@ package body Debug is
-- d.G Previously the compiler ignored calls via generic formal parameters
-- when doing the analysis for the static elaboration model. This is
-- now fixed, but we provide this debug flag to revert to the previous
-- situation of ignoring such calls to aid in transition.
-- situation of ignoring such calls to aid in transition. This switch
-- is orthogonal to dL.
-- d.H Sets ASIS_GNSA_Mode to True. This signals the front end to suppress
-- the call to gigi in ASIS_Mode.

3087
gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst
View File

File diff suppressed because it is too large Load Diff

128
gcc/ada/einfo.adb
View File

@ -170,6 +170,7 @@ package body Einfo is
-- Extra_Accessibility_Of_Result Node19
-- Non_Limited_View Node19
-- Parent_Subtype Node19
-- Receiving_Entry Node19
-- Size_Check_Code Node19
-- Spec_Entity Node19
-- Underlying_Full_View Node19
@ -275,6 +276,9 @@ package body Einfo is
-- Validated_Object Node36
-- Class_Wide_Clone Node38
-- Protected_Subprogram Node39
-- SPARK_Pragma Node40
-- Original_Protected_Subprogram Node41
@ -449,7 +453,7 @@ package body Einfo is
-- Strict_Alignment Flag145
-- Is_Abstract_Type Flag146
-- Needs_Debug_Info Flag147
-- Suppress_Elaboration_Warnings Flag148
-- Is_Elaboration_Checks_OK_Id Flag148
-- Is_Compilation_Unit Flag149
-- Has_Pragma_Elaborate_Body Flag150
@ -619,7 +623,8 @@ package body Einfo is
-- Has_Private_Extension Flag300
-- Ignore_SPARK_Mode_Pragmas Flag301
-- (unused) Flag302
-- Is_Initial_Condition_Procedure Flag302
-- (unused) Flag303
-- (unused) Flag304
-- (unused) Flag305
@ -2237,6 +2242,17 @@ package body Einfo is
return Flag6 (Id);
end Is_Dispatching_Operation;
function Is_Elaboration_Checks_OK_Id (Id : E) return B is
begin
pragma Assert
(Ekind_In (Id, E_Constant, E_Variable)
or else Is_Entry (Id)
or else Is_Generic_Unit (Id)
or else Is_Subprogram (Id)
or else Is_Task_Type (Id));
return Flag148 (Id);
end Is_Elaboration_Checks_OK_Id;
function Is_Eliminated (Id : E) return B is
begin
return Flag124 (Id);
@ -2364,6 +2380,12 @@ package body Einfo is
return Flag268 (Id);
end Is_Independent;
function Is_Initial_Condition_Procedure (Id : E) return B is
begin
pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
return Flag302 (Id);
end Is_Initial_Condition_Procedure;
function Is_Inlined (Id : E) return B is
begin
return Flag11 (Id);
@ -2371,7 +2393,7 @@ package body Einfo is
function Is_Inlined_Always (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
return Flag1 (Id);
end Is_Inlined_Always;
@ -3084,10 +3106,18 @@ package body Einfo is
return Node22 (Id);
end Protected_Formal;
function Protected_Subprogram (Id : E) return N is
begin
pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
return Node39 (Id);
end Protected_Subprogram;
function Protection_Object (Id : E) return E is
begin
pragma Assert
(Ekind_In (Id, E_Entry, E_Entry_Family, E_Function, E_Procedure));
pragma Assert (Ekind_In (Id, E_Entry,
E_Entry_Family,
E_Function,
E_Procedure));
return Node23 (Id);
end Protection_Object;
@ -3096,6 +3126,12 @@ package body Einfo is
return Flag49 (Id);
end Reachable;
function Receiving_Entry (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Procedure);
return Node19 (Id);
end Receiving_Entry;
function Referenced (Id : E) return B is
begin
return Flag156 (Id);
@ -3306,6 +3342,9 @@ package body Einfo is
E_Task_Body,
E_Task_Type)
or else
Ekind_In (Id, E_Constant, -- object variants
E_Variable)
or else
Ekind_In (Id, E_Entry, -- overloadable variants
E_Entry_Family,
E_Function,
@ -3319,7 +3358,7 @@ package body Einfo is
E_Package,
E_Package_Body)
or else
Ekind (Id) = E_Variable); -- variable
Ekind (Id) = E_Void); -- special purpose
return Node40 (Id);
end SPARK_Pragma;
@ -3330,7 +3369,10 @@ package body Einfo is
E_Protected_Type,
E_Task_Body,
E_Task_Type)
or else
or else
Ekind_In (Id, E_Constant, -- object variants
E_Variable)
or else
Ekind_In (Id, E_Entry, -- overloadable variants
E_Entry_Family,
E_Function,
@ -3344,7 +3386,7 @@ package body Einfo is
E_Package,
E_Package_Body)
or else
Ekind (Id) = E_Variable); -- variable
Ekind (Id) = E_Void); -- special purpose
return Flag265 (Id);
end SPARK_Pragma_Inherited;
@ -3444,11 +3486,6 @@ package body Einfo is
return Uint24 (Id);
end Subps_Index;
function Suppress_Elaboration_Warnings (Id : E) return B is
begin
return Flag148 (Id);
end Suppress_Elaboration_Warnings;
function Suppress_Initialization (Id : E) return B is
begin
pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Variable);
@ -5397,6 +5434,17 @@ package body Einfo is
Set_Flag6 (Id, V);
end Set_Is_Dispatching_Operation;
procedure Set_Is_Elaboration_Checks_OK_Id (Id : E; V : B := True) is
begin
pragma Assert
(Ekind_In (Id, E_Constant, E_Variable)
or else Is_Entry (Id)
or else Is_Generic_Unit (Id)
or else Is_Subprogram (Id)
or else Is_Task_Type (Id));
Set_Flag148 (Id, V);
end Set_Is_Elaboration_Checks_OK_Id;
procedure Set_Is_Eliminated (Id : E; V : B := True) is
begin
Set_Flag124 (Id, V);
@ -5526,6 +5574,12 @@ package body Einfo is
Set_Flag268 (Id, V);
end Set_Is_Independent;
procedure Set_Is_Initial_Condition_Procedure (Id : E; V : B := True) is
begin
pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
Set_Flag302 (Id, V);
end Set_Is_Initial_Condition_Procedure;
procedure Set_Is_Inlined (Id : E; V : B := True) is
begin
Set_Flag11 (Id, V);
@ -5533,7 +5587,7 @@ package body Einfo is
procedure Set_Is_Inlined_Always (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
Set_Flag1 (Id, V);
end Set_Is_Inlined_Always;
@ -6264,6 +6318,12 @@ package body Einfo is
Set_Node22 (Id, V);
end Set_Protected_Formal;
procedure Set_Protected_Subprogram (Id : E; V : E) is
begin
pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
Set_Node39 (Id, V);
end Set_Protected_Subprogram;
procedure Set_Protection_Object (Id : E; V : E) is
begin
pragma Assert (Ekind_In (Id, E_Entry,
@ -6278,6 +6338,12 @@ package body Einfo is
Set_Flag49 (Id, V);
end Set_Reachable;
procedure Set_Receiving_Entry (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Procedure);
Set_Node19 (Id, V);
end Set_Receiving_Entry;
procedure Set_Referenced (Id : E; V : B := True) is
begin
Set_Flag156 (Id, V);
@ -6491,7 +6557,10 @@ package body Einfo is
E_Protected_Type,
E_Task_Body,
E_Task_Type)
or else
or else
Ekind_In (Id, E_Constant, -- object variants
E_Variable)
or else
Ekind_In (Id, E_Entry, -- overloadable variants
E_Entry_Family,
E_Function,
@ -6505,7 +6574,7 @@ package body Einfo is
E_Package,
E_Package_Body)
or else
Ekind (Id) = E_Variable); -- variable
Ekind (Id) = E_Void); -- special purpose
Set_Node40 (Id, V);
end Set_SPARK_Pragma;
@ -6516,7 +6585,10 @@ package body Einfo is
E_Protected_Type,
E_Task_Body,
E_Task_Type)
or else
or else
Ekind_In (Id, E_Constant, -- object variants
E_Variable)
or else
Ekind_In (Id, E_Entry, -- overloadable variants
E_Entry_Family,
E_Function,
@ -6530,7 +6602,7 @@ package body Einfo is
E_Package,
E_Package_Body)
or else
Ekind (Id) = E_Variable); -- variable
Ekind (Id) = E_Void); -- special purpose
Set_Flag265 (Id, V);
end Set_SPARK_Pragma_Inherited;
@ -6639,11 +6711,6 @@ package body Einfo is
Set_Uint24 (Id, V);
end Set_Subps_Index;
procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True) is
begin
Set_Flag148 (Id, V);
end Set_Suppress_Elaboration_Warnings;
procedure Set_Suppress_Initialization (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Variable);
@ -9562,6 +9629,7 @@ package body Einfo is
W ("Is_Discriminant_Check_Function", Flag264 (Id));
W ("Is_Dispatch_Table_Entity", Flag234 (Id));
W ("Is_Dispatching_Operation", Flag6 (Id));
W ("Is_Elaboration_Checks_OK_Id", Flag148 (Id));
W ("Is_Eliminated", Flag124 (Id));
W ("Is_Entry_Formal", Flag52 (Id));
W ("Is_Exception_Handler", Flag286 (Id));
@ -9584,6 +9652,7 @@ package body Einfo is
W ("Is_Implementation_Defined", Flag254 (Id));
W ("Is_Imported", Flag24 (Id));
W ("Is_Independent", Flag268 (Id));
W ("Is_Initial_Condition_Procedure", Flag302 (Id));
W ("Is_Inlined", Flag11 (Id));
W ("Is_Inlined_Always", Flag1 (Id));
W ("Is_Instantiated", Flag126 (Id));
@ -9696,7 +9765,6 @@ package body Einfo is
W ("Static_Elaboration_Desired", Flag77 (Id));
W ("Stores_Attribute_Old_Prefix", Flag270 (Id));
W ("Strict_Alignment", Flag145 (Id));
W ("Suppress_Elaboration_Warnings", Flag148 (Id));
W ("Suppress_Initialization", Flag105 (Id));
W ("Suppress_Style_Checks", Flag165 (Id));
W ("Suppress_Value_Tracking_On_Call", Flag217 (Id));
@ -10399,6 +10467,9 @@ package body Einfo is
when E_Record_Type =>
Write_Str ("Parent_Subtype");
when E_Procedure =>
Write_Str ("Receiving_Entry");
when E_Constant
| E_Variable
=>
@ -11089,6 +11160,11 @@ package body Einfo is
procedure Write_Field39_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when E_Function
| E_Procedure
=>
Write_Str ("Protected_Subprogram");
when others =>
Write_Str ("Field39??");
end case;
@ -11101,7 +11177,8 @@ package body Einfo is
procedure Write_Field40_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when E_Entry
when E_Constant
| E_Entry
| E_Entry_Family
| E_Function
| E_Generic_Function
@ -11117,6 +11194,7 @@ package body Einfo is
| E_Task_Body
| E_Task_Type
| E_Variable
| E_Void
=>
Write_Str ("SPARK_Pragma");

121
gcc/ada/einfo.ads
View File

@ -2198,13 +2198,6 @@ package Einfo is
-- Rep_Item chain mechanism, because a single pragma Import can apply
-- to multiple subprogram entities).
-- Incomplete_Actuals (Elist24)
-- Defined on package entities that are instances. Indicates the actuals
-- types in the instantiation that are limited views. If this list is
-- not empty, the instantiation, which appears in a package declaration,
-- is relocated to the corresponding package body, which must have a
-- corresponding nonlimited with_clause.
-- In_Package_Body (Flag48)
-- Defined in package entities. Set on the entity that denotes the
-- package (the defining occurrence of the package declaration) while
@ -2218,6 +2211,13 @@ package Einfo is
-- the end of the package declaration. For objects it indicates that the
-- declaration of the object occurs in the private part of a package.
-- Incomplete_Actuals (Elist24)
-- Defined on package entities that are instances. Indicates the actuals
-- types in the instantiation that are limited views. If this list is
-- not empty, the instantiation, which appears in a package declaration,
-- is relocated to the corresponding package body, which must have a
-- corresponding nonlimited with_clause.
-- Initialization_Statements (Node28)
-- Defined in constants and variables. For a composite object initialized
-- initialized with an aggregate that has been converted to a sequence
@ -2504,13 +2504,19 @@ package Einfo is
-- Is_Dynamic_Scope (synthesized)
-- Applies to all Entities. Returns True if the entity is a dynamic
-- scope (i.e. a block, subprogram, task_type, entry
-- or extended return statement).
-- scope (i.e. a block, subprogram, task_type, entry or extended return
-- statement).
-- Is_Elaboration_Checks_OK_Id (Flag148)
-- Defined in elaboration targets (see terminology in Sem_Elab). Set when
-- the target appears in a region which is subject to elabled elaboration
-- checks. Such targets are allowed to generate run-time conditional ABE
-- checks or guaranteed ABE failures.
-- Is_Elementary_Type (synthesized)
-- Applies to all entities, true for all elementary types and
-- subtypes. Either Is_Composite_Type or Is_Elementary_Type (but
-- not both) is true of any type.
-- Applies to all entities, true for all elementary types and subtypes.
-- Either Is_Composite_Type or Is_Elementary_Type (but not both) is true
-- of any type.
-- Is_Eliminated (Flag124)
-- Defined in type entities, subprogram entities, and object entities.
@ -2703,6 +2709,10 @@ package Einfo is
-- and incomplete types, this flag is set in both the partial view and
-- the full view.
-- Is_Initial_Condition_Procedure (Flag302)
-- Defined in functions and procedures. Set for a generated procedure
-- which verifies the assumption of pragma Initial_Condition at run time.
-- Is_Inlined (Flag11)
-- Defined in all entities. Set for functions and procedures which are
-- to be inlined. For subprograms created during expansion, this flag
@ -3958,6 +3968,11 @@ package Einfo is
-- formal parameter in the unprotected version of the operation that
-- is created during expansion.
-- Protected_Subprogram (Node39)
-- Defined in functions and procedures. Set for the pair of subprograms
-- which emulate the runtime semantics of a protected subprogram. Denotes
-- the entity of the origial protected subprogram.
-- Protection_Object (Node23)
-- Applies to protected entries, entry families and subprograms. Denotes
-- the entity which is used to rename the _object component of protected
@ -3967,6 +3982,11 @@ package Einfo is
-- Defined in labels. The flag is set over the range of statements in
-- which a goto to that label is legal.
-- Receiving_Entry (Node19)
-- Defined in procedures. Set for an internally generated procedure which
-- wraps the original statements of an accept alternative. Designates the
-- entity of the task entry being accepted.
-- Referenced (Flag156)
-- Defined in all entities. Set if the entity is referenced, except for
-- the case of an appearance of a simple variable that is not a renaming
@ -4038,10 +4058,10 @@ package Einfo is
-- in a Relative_Deadline pragma for a task type.
-- Renamed_Entity (Node18)
-- Defined in exceptions, packages, subprograms, and generic units. Set
-- for entities that are defined by a renaming declaration. Denotes the
-- renamed entity, or transitively the ultimate renamed entity if
-- there is a chain of renaming declarations. Empty if no renaming.
-- Defined in exception, generic unit, package, and subprogram entities.
-- Set when the entity is defined by a renaming declaration. Denotes the
-- renamed entity, or transitively the ultimate renamed entity if there
-- is a chain of renaming declarations. Empty if no renaming.
-- Renamed_In_Spec (Flag231)
-- Defined in package entities. If a package renaming occurs within
@ -4256,20 +4276,20 @@ package Einfo is
-- inherited, rather than a local one.
-- SPARK_Pragma (Node40)
-- Present in concurrent type, entry, operator, [generic] package,
-- package body, [generic] subprogram, subprogram body and variable
-- entities. Points to the N_Pragma node that applies to the initial
-- declaration or body. This is either set by a local SPARK_Mode pragma
-- or is inherited from the context (from an outer scope for the spec
-- case or from the spec for the body case). In the case where it is
-- inherited the flag SPARK_Pragma_Inherited is set. Empty if no
-- Present in concurrent type, constant, entry, operator, [generic]
-- package, package body, [generic] subprogram, subprogram body and
-- variable entities. Points to the N_Pragma node that applies to the
-- initial declaration or body. This is either set by a local SPARK_Mode
-- pragma or is inherited from the context (from an outer scope for the
-- spec case or from the spec for the body case). In the case where it
-- is inherited the flag SPARK_Pragma_Inherited is set. Empty if no
-- SPARK_Mode pragma is applicable.
-- SPARK_Pragma_Inherited (Flag265)
-- Present in concurrent type, entry, operator, [generic] package,
-- package body, [generic] subprogram, subprogram body and variable
-- entities. Set if the SPARK_Pragma attribute points to a pragma that is
-- inherited, rather than a local one.
-- Present in concurrent type, constant, entry, operator, [generic]
-- package, package body, [generic] subprogram, subprogram body and
-- variable entities. Set if the SPARK_Pragma attribute points to a
-- pragma that is inherited, rather than a local one.
-- Spec_Entity (Node19)
-- Defined in package body entities. Points to corresponding package
@ -4395,17 +4415,6 @@ package Einfo is
-- for the outer level subprogram, this is the starting index in the Subp
-- table for the entries for this subprogram.
-- Suppress_Elaboration_Warnings (Flag148)
-- Defined in all entities, can be set only for subprogram entities and
-- for variables. If this flag is set then Sem_Elab will not generate
-- elaboration warnings for the subprogram or variable. Suppression of
-- such warnings is automatic for subprograms for which elaboration
-- checks are suppressed (without the need to set this flag), but the
-- flag is also set for various internal entities (such as init procs)
-- which are known not to generate any possible access before
-- elaboration, and it is set on variables when a warning is given to
-- avoid multiple elaboration warnings for the same variable.
-- Suppress_Initialization (Flag105)
-- Defined in all variable, type and subtype entities. If set for a base
-- type, then the generation of initialization procedures is suppressed
@ -5565,7 +5574,6 @@ package Einfo is
-- Referenced (Flag156)
-- Referenced_As_LHS (Flag36)
-- Referenced_As_Out_Parameter (Flag227)
-- Suppress_Elaboration_Warnings (Flag148)
-- Suppress_Style_Checks (Flag165)
-- Suppress_Value_Tracking_On_Call (Flag217)
-- Used_As_Generic_Actual (Flag222)
@ -5869,6 +5877,7 @@ package Einfo is
-- Encapsulating_State (Node32) (constants only)
-- Linker_Section_Pragma (Node33)
-- Contract (Node34) (constants only)
-- SPARK_Pragma (Node40) (constants only)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
@ -5878,6 +5887,7 @@ package Einfo is
-- Has_Thunks (Flag228) (constants only)
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Elaboration_Checks_OK_Id (Flag148) (constants only)
-- Is_Eliminated (Flag124)
-- Is_Finalized_Transient (Flag252)
-- Is_Ignored_Transient (Flag295)
@ -5889,6 +5899,7 @@ package Einfo is
-- Is_Volatile_Full_Access (Flag285)
-- Optimize_Alignment_Space (Flag241) (constants only)
-- Optimize_Alignment_Time (Flag242) (constants only)
-- SPARK_Pragma_Inherited (Flag265) (constants only)
-- Stores_Attribute_Old_Prefix (Flag270) (constants only)
-- Treat_As_Volatile (Flag41)
-- Address_Clause (synth)
@ -5953,6 +5964,7 @@ package Einfo is
-- Entry_Accepted (Flag152)
-- Has_Expanded_Contract (Flag240)
-- Ignore_SPARK_Mode_Pragmas (Flag301)
-- Is_Elaboration_Checks_OK_Id (Flag148)
-- Is_Entry_Wrapper (Flag297)
-- Needs_No_Actuals (Flag22)
-- Sec_Stack_Needed_For_Return (Flag167)
@ -6065,6 +6077,7 @@ package Einfo is
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
-- Class_Wide_Clone (Node38)
-- Protected_Subprogram (Node39) (non-generic case only)
-- SPARK_Pragma (Node40)
-- Original_Protected_Subprogram (Node41)
-- Body_Needed_For_SAL (Flag40)
@ -6090,9 +6103,11 @@ package Einfo is
-- Is_DIC_Procedure (Flag132) (non-generic case only)
-- Is_Discrim_SO_Function (Flag176)
-- Is_Discriminant_Check_Function (Flag264)
-- Is_Elaboration_Checks_OK_Id (Flag148)
-- Is_Eliminated (Flag124)
-- Is_Generic_Actual_Subprogram (Flag274) (non-generic case only)
-- Is_Hidden_Non_Overridden_Subpgm (Flag2) (non-generic case only)
-- Is_Initial_Condition_Procedure (Flag302) (non-generic case only)
-- Is_Inlined_Always (Flag1) (non-generic case only)
-- Is_Instantiated (Flag126) (generic case only)
-- Is_Intrinsic_Subprogram (Flag64)
@ -6238,6 +6253,7 @@ package Einfo is
-- Default_Expressions_Processed (Flag108)
-- Has_Nested_Subprogram (Flag282)
-- Ignore_SPARK_Mode_Pragmas (Flag301)
-- Is_Elaboration_Checks_OK_Id (Flag148)
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Machine_Code_Subprogram (Flag137)
-- Is_Primitive (Flag218)
@ -6304,6 +6320,7 @@ package Einfo is
-- Ignore_SPARK_Mode_Pragmas (Flag301)
-- In_Package_Body (Flag48)
-- In_Use (Flag8)
-- Is_Elaboration_Checks_OK_Id (Flag148)
-- Is_Instantiated (Flag126)
-- Is_Private_Descendant (Flag53)
-- Is_Visible_Lib_Unit (Flag116)
@ -6362,6 +6379,7 @@ package Einfo is
-- First_Entity (Node17)
-- Alias (Node18) (non-generic case only)
-- Renamed_Entity (Node18) (generic case only)
-- Receiving_Entry (Node19) (non-generic case only)
-- Last_Entity (Node20)
-- Interface_Name (Node21)
-- Scope_Depth_Value (Uint22)
@ -6381,6 +6399,7 @@ package Einfo is
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
-- Class_Wide_Clone (Node38)
-- Protected_Subprogram (Node39) (non-generic case only)
-- SPARK_Pragma (Node40)
-- Original_Protected_Subprogram (Node41)
-- Body_Needed_For_SAL (Flag40)
@ -6403,9 +6422,11 @@ package Einfo is
-- Is_Called (Flag102) (non-generic case only)
-- Is_Constructor (Flag76)
-- Is_DIC_Procedure (Flag132) (non-generic case only)
-- Is_Elaboration_Checks_OK_Id (Flag148)
-- Is_Eliminated (Flag124)
-- Is_Generic_Actual_Subprogram (Flag274) (non-generic case only)
-- Is_Hidden_Non_Overridden_Subpgm (Flag2) (non-generic case only)
-- Is_Initial_Condition_Procedure (Flag302) (non-generic case only)
-- Is_Inlined_Always (Flag1) (non-generic case only)
-- Is_Instantiated (Flag126) (generic case only)
-- Is_Interrupt_Handler (Flag89)
@ -6614,6 +6635,7 @@ package Einfo is
-- Has_Master_Entity (Flag21)
-- Has_Storage_Size_Clause (Flag23) (base type only)
-- Ignore_SPARK_Mode_Pragmas (Flag301)
-- Is_Elaboration_Checks_OK_Id (Flag148)
-- SPARK_Aux_Pragma_Inherited (Flag266)
-- SPARK_Pragma_Inherited (Flag265)
-- First_Component (synth)
@ -6662,6 +6684,7 @@ package Einfo is
-- Has_Size_Clause (Flag29)
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Elaboration_Checks_OK_Id (Flag148)
-- Is_Eliminated (Flag124)
-- Is_Finalized_Transient (Flag252)
-- Is_Ignored_Transient (Flag295)
@ -7179,6 +7202,7 @@ package Einfo is
function Is_Discriminant_Check_Function (Id : E) return B;
function Is_Dispatch_Table_Entity (Id : E) return B;
function Is_Dispatching_Operation (Id : E) return B;
function Is_Elaboration_Checks_OK_Id (Id : E) return B;
function Is_Eliminated (Id : E) return B;
function Is_Entry_Formal (Id : E) return B;
function Is_Entry_Wrapper (Id : E) return B;
@ -7198,6 +7222,7 @@ package Einfo is
function Is_Implementation_Defined (Id : E) return B;
function Is_Imported (Id : E) return B;
function Is_Independent (Id : E) return B;
function Is_Initial_Condition_Procedure (Id : E) return B;
function Is_Inlined (Id : E) return B;
function Is_Inlined_Always (Id : E) return B;
function Is_Instantiated (Id : E) return B;
@ -7322,8 +7347,10 @@ package Einfo is
function Private_View (Id : E) return N;
function Protected_Body_Subprogram (Id : E) return E;
function Protected_Formal (Id : E) return E;
function Protected_Subprogram (Id : E) return N;
function Protection_Object (Id : E) return E;
function Reachable (Id : E) return B;
function Receiving_Entry (Id : E) return E;
function Referenced (Id : E) return B;
function Referenced_As_LHS (Id : E) return B;
function Referenced_As_Out_Parameter (Id : E) return B;
@ -7376,7 +7403,6 @@ package Einfo is
function String_Literal_Low_Bound (Id : E) return N;
function Subprograms_For_Type (Id : E) return L;
function Subps_Index (Id : E) return U;
function Suppress_Elaboration_Warnings (Id : E) return B;
function Suppress_Initialization (Id : E) return B;
function Suppress_Style_Checks (Id : E) return B;
function Suppress_Value_Tracking_On_Call (Id : E) return B;
@ -7868,6 +7894,7 @@ package Einfo is
procedure Set_Is_Discriminant_Check_Function (Id : E; V : B := True);
procedure Set_Is_Dispatch_Table_Entity (Id : E; V : B := True);
procedure Set_Is_Dispatching_Operation (Id : E; V : B := True);
procedure Set_Is_Elaboration_Checks_OK_Id (Id : E; V : B := True);
procedure Set_Is_Eliminated (Id : E; V : B := True);
procedure Set_Is_Entry_Formal (Id : E; V : B := True);
procedure Set_Is_Entry_Wrapper (Id : E; V : B := True);
@ -7891,6 +7918,7 @@ package Einfo is
procedure Set_Is_Implementation_Defined (Id : E; V : B := True);
procedure Set_Is_Imported (Id : E; V : B := True);
procedure Set_Is_Independent (Id : E; V : B := True);
procedure Set_Is_Initial_Condition_Procedure (Id : E; V : B := True);
procedure Set_Is_Inlined (Id : E; V : B := True);
procedure Set_Is_Inlined_Always (Id : E; V : B := True);
procedure Set_Is_Instantiated (Id : E; V : B := True);
@ -8015,8 +8043,10 @@ package Einfo is
procedure Set_Private_View (Id : E; V : N);
procedure Set_Protected_Body_Subprogram (Id : E; V : E);
procedure Set_Protected_Formal (Id : E; V : E);
procedure Set_Protected_Subprogram (Id : E; V : N);
procedure Set_Protection_Object (Id : E; V : E);
procedure Set_Reachable (Id : E; V : B := True);
procedure Set_Receiving_Entry (Id : E; V : E);
procedure Set_Referenced (Id : E; V : B := True);
procedure Set_Referenced_As_LHS (Id : E; V : B := True);
procedure Set_Referenced_As_Out_Parameter (Id : E; V : B := True);
@ -8069,7 +8099,6 @@ package Einfo is
procedure Set_String_Literal_Low_Bound (Id : E; V : N);
procedure Set_Subprograms_For_Type (Id : E; V : L);
procedure Set_Subps_Index (Id : E; V : U);
procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True);
procedure Set_Suppress_Initialization (Id : E; V : B := True);
procedure Set_Suppress_Style_Checks (Id : E; V : B := True);
procedure Set_Suppress_Value_Tracking_On_Call (Id : E; V : B := True);
@ -8690,6 +8719,7 @@ package Einfo is
pragma Inline (Is_Discriminant_Check_Function);
pragma Inline (Is_Dispatch_Table_Entity);
pragma Inline (Is_Dispatching_Operation);
pragma Inline (Is_Elaboration_Checks_OK_Id);
pragma Inline (Is_Elementary_Type);
pragma Inline (Is_Eliminated);
pragma Inline (Is_Entry);
@ -8725,6 +8755,7 @@ package Einfo is
pragma Inline (Is_Incomplete_Or_Private_Type);
pragma Inline (Is_Incomplete_Type);
pragma Inline (Is_Independent);
pragma Inline (Is_Initial_Condition_Procedure);
pragma Inline (Is_Inlined);
pragma Inline (Is_Inlined_Always);
pragma Inline (Is_Instantiated);
@ -8868,8 +8899,10 @@ package Einfo is
pragma Inline (Private_View);
pragma Inline (Protected_Body_Subprogram);
pragma Inline (Protected_Formal);
pragma Inline (Protected_Subprogram);
pragma Inline (Protection_Object);
pragma Inline (Reachable);
pragma Inline (Receiving_Entry);
pragma Inline (Referenced);
pragma Inline (Referenced_As_LHS);
pragma Inline (Referenced_As_Out_Parameter);
@ -8922,7 +8955,6 @@ package Einfo is
pragma Inline (String_Literal_Low_Bound);
pragma Inline (Subprograms_For_Type);
pragma Inline (Subps_Index);
pragma Inline (Suppress_Elaboration_Warnings);
pragma Inline (Suppress_Initialization);
pragma Inline (Suppress_Style_Checks);
pragma Inline (Suppress_Value_Tracking_On_Call);
@ -9200,6 +9232,7 @@ package Einfo is
pragma Inline (Set_Is_Discriminant_Check_Function);
pragma Inline (Set_Is_Dispatch_Table_Entity);
pragma Inline (Set_Is_Dispatching_Operation);
pragma Inline (Set_Is_Elaboration_Checks_OK_Id);
pragma Inline (Set_Is_Eliminated);
pragma Inline (Set_Is_Entry_Formal);
pragma Inline (Set_Is_Entry_Wrapper);
@ -9223,6 +9256,7 @@ package Einfo is
pragma Inline (Set_Is_Implementation_Defined);
pragma Inline (Set_Is_Imported);
pragma Inline (Set_Is_Independent);
pragma Inline (Set_Is_Initial_Condition_Procedure);
pragma Inline (Set_Is_Inlined);
pragma Inline (Set_Is_Inlined_Always);
pragma Inline (Set_Is_Instantiated);
@ -9348,8 +9382,10 @@ package Einfo is
pragma Inline (Set_Private_View);
pragma Inline (Set_Protected_Body_Subprogram);
pragma Inline (Set_Protected_Formal);
pragma Inline (Set_Protected_Subprogram);
pragma Inline (Set_Protection_Object);
pragma Inline (Set_Reachable);
pragma Inline (Set_Receiving_Entry);
pragma Inline (Set_Referenced);
pragma Inline (Set_Referenced_As_LHS);
pragma Inline (Set_Referenced_As_Out_Parameter);
@ -9402,7 +9438,6 @@ package Einfo is
pragma Inline (Set_String_Literal_Low_Bound);
pragma Inline (Set_Subprograms_For_Type);
pragma Inline (Set_Subps_Index);
pragma Inline (Set_Suppress_Elaboration_Warnings);
pragma Inline (Set_Suppress_Initialization);
pragma Inline (Set_Suppress_Style_Checks);
pragma Inline (Set_Suppress_Value_Tracking_On_Call);

47
gcc/ada/exp_ch3.adb
View File

@ -2721,36 +2721,30 @@ package body Exp_Ch3 is
and then not Restriction_Active (No_Exception_Propagation)
then
declare
DF_Call : Node_Id;
DF_Id : Entity_Id;
DF_Id : Entity_Id;
begin
-- Create a local version of Deep_Finalize which has indication
-- of partial initialization state.
DF_Id := Make_Temporary (Loc, 'F');
DF_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Name_uFinalizer));
Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id));
DF_Call :=
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (DF_Id, Loc),
Parameter_Associations => New_List (
Make_Identifier (Loc, Name_uInit),
New_Occurrence_Of (Standard_False, Loc)));
-- Do not emit warnings related to the elaboration order when a
-- controlled object is declared before the body of Finalize is
-- seen.
Set_No_Elaboration_Check (DF_Call);
Set_Exception_Handlers (Handled_Stmt_Node, New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (
Make_Others_Choice (Loc)),
Statements => New_List (
DF_Call,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (DF_Id, Loc),
Parameter_Associations => New_List (
Make_Identifier (Loc, Name_uInit),
New_Occurrence_Of (Standard_False, Loc))),
Make_Raise_Statement (Loc)))));
end;
else
@ -5814,6 +5808,7 @@ package body Exp_Ch3 is
Aggr_Init : Node_Id;
Comp_Init : List_Id := No_List;
Fin_Block : Node_Id;
Fin_Call : Node_Id;
Init_Stmts : List_Id := No_List;
Obj_Init : Node_Id := Empty;
@ -5956,14 +5951,7 @@ package body Exp_Ch3 is
Skip_Self => True);
if Present (Fin_Call) then
-- Do not emit warnings related to the elaboration order when a
-- controlled object is declared before the body of Finalize is
-- seen.
Set_No_Elaboration_Check (Fin_Call);
Append_To (Init_Stmts,
Fin_Block :=
Make_Block_Statement (Loc,
Declarations => No_List,
@ -5978,7 +5966,14 @@ package body Exp_Ch3 is
Statements => New_List (
Fin_Call,
Make_Raise_Statement (Loc)))))));
Make_Raise_Statement (Loc))))));
-- Signal the ABE mechanism that the block carries out
-- initialization actions.
Set_Is_Initialization_Block (Fin_Block);
Append_To (Init_Stmts, Fin_Block);
end if;
-- Otherwise finalization is not required, the initialization calls

36
gcc/ada/exp_ch6.adb
View File

@ -7714,7 +7714,7 @@ package body Exp_Ch6 is
Function_Call : Node_Id)
is
Acc_Type : constant Entity_Id := Etype (Allocator);
Loc : Source_Ptr;
Loc : constant Source_Ptr := Sloc (Function_Call);
Func_Call : Node_Id := Function_Call;
Ref_Func_Call : Node_Id;
Function_Id : Entity_Id;
@ -7744,8 +7744,6 @@ package body Exp_Ch6 is
pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call));
Set_Is_Expanded_Build_In_Place_Call (Func_Call);
Loc := Sloc (Function_Call);
if Is_Entity_Name (Name (Func_Call)) then
Function_Id := Entity (Name (Func_Call));
@ -7801,10 +7799,17 @@ package body Exp_Ch6 is
Rewrite (Allocator, New_Allocator);
-- Initial value of the temp is the result of the uninitialized
-- allocator
-- allocator. Unchecked_Convert is needed for T'Input where T is
-- derived from a controlled type.
Temp_Init := Relocate_Node (Allocator);
if Nkind_In
(Function_Call, N_Type_Conversion, N_Unchecked_Type_Conversion)
then
Temp_Init := Unchecked_Convert_To (Acc_Type, Temp_Init);
end if;
-- Indicate that caller allocates, and pass in the return object
Alloc_Form := Caller_Allocation;
@ -7869,6 +7874,15 @@ package body Exp_Ch6 is
Rewrite
(Ref_Func_Call,
OK_Convert_To (Acc_Type, Ref_Func_Call));
-- If the types are incompatible, we need an unchecked conversion. Note
-- that the full types will be compatible, but the types not visibly
-- compatible.
elsif Nkind_In
(Function_Call, N_Type_Conversion, N_Unchecked_Type_Conversion)
then
Ref_Func_Call := Unchecked_Convert_To (Acc_Type, Ref_Func_Call);
end if;
declare
@ -7880,7 +7894,8 @@ package body Exp_Ch6 is
-- caller-allocates case, this is overwriting the temp with its
-- initial value, which has no effect. In the callee-allocates case,
-- this is setting the temp to point to the object allocated by the
-- callee.
-- callee. Unchecked_Convert is needed for T'Input where T is derived
-- from a controlled type.
Actions : List_Id;
-- Actions to be inserted. If there are no tasks, this is just the
@ -7940,7 +7955,7 @@ package body Exp_Ch6 is
procedure Make_Build_In_Place_Call_In_Anonymous_Context
(Function_Call : Node_Id)
is
Loc : Source_Ptr;
Loc : constant Source_Ptr := Sloc (Function_Call);
Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
Function_Id : Entity_Id;
Result_Subt : Entity_Id;
@ -7962,8 +7977,6 @@ package body Exp_Ch6 is
Set_Is_Expanded_Build_In_Place_Call (Func_Call);
Loc := Sloc (Function_Call);
if Is_Entity_Name (Name (Func_Call)) then
Function_Id := Entity (Name (Func_Call));
@ -8535,7 +8548,10 @@ package body Exp_Ch6 is
New_Occurrence_Of (Designated_Type, Obj_Loc),
Name => Call_Deref));
Set_Renamed_Object (Obj_Def_Id, Call_Deref);
-- At this point, Defining_Identifier (Obj_Decl) is no longer equal
-- to Obj_Def_Id.
Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref);
-- If the original entity comes from source, then mark the new
-- entity as needing debug information, even though it's defined
@ -8544,7 +8560,7 @@ package body Exp_Ch6 is
-- Debug_Renaming_Declaration is called during analysis.
if Comes_From_Source (Obj_Def_Id) then
Set_Debug_Info_Needed (Obj_Def_Id);
Set_Debug_Info_Needed (Defining_Identifier (Obj_Decl));
end if;
Analyze (Obj_Decl);

45
gcc/ada/exp_ch7.adb
View File

@ -2605,8 +2605,8 @@ package body Exp_Ch7 is
-- procedures of types Init_Typ or Obj_Typ.
function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
-- Given a statement which is part of a list, return the next
-- statement while skipping over dynamic elab checks.
-- Obtain the next statement which follows list member Stmt while
-- ignoring artifacts related to access-before-elaboration checks.
-----------------------------
-- Find_Last_Init_In_Block --
@ -2725,16 +2725,22 @@ package body Exp_Ch7 is
-----------------------------
function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
Result : Node_Id := Next (Stmt);
Result : Node_Id;
begin
-- Skip over access-before-elaboration checks
-- Skip call markers and Program_Error raises installed by the
-- ABE mechanism.
Result := Next (Stmt);
while Present (Result) loop
if not Nkind_In (Result, N_Call_Marker,
N_Raise_Program_Error)
then
exit;
end if;
if Dynamic_Elaboration_Checks
and then Nkind (Result) = N_Raise_Program_Error
then
Result := Next (Result);
end if;
end loop;
return Result;
end Next_Suitable_Statement;
@ -4463,7 +4469,7 @@ package body Exp_Ch7 is
-- This is done only for non-generic packages
if Ekind (Spec_Id) = E_Package then
Push_Scope (Corresponding_Spec (N));
Push_Scope (Spec_Id);
-- Build dispatch tables of library level tagged types
@ -4475,18 +4481,15 @@ package body Exp_Ch7 is
Build_Task_Activation_Call (N);
-- When the package is subject to pragma Initial_Condition, the
-- assertion expression must be verified at the end of the body
-- statements.
-- Verify the run-time semantics of pragma Initial_Condition at the
-- end of the body statements.
if Present (Get_Pragma (Spec_Id, Pragma_Initial_Condition)) then
Expand_Pragma_Initial_Condition (N);
end if;
Expand_Pragma_Initial_Condition (Spec_Id, N);
Pop_Scope;
end if;
Set_Elaboration_Flag (N, Corresponding_Spec (N));
Set_Elaboration_Flag (N, Spec_Id);
Set_In_Package_Body (Spec_Id, False);
-- Set to encode entity names in package body before gigi is called
@ -4601,14 +4604,10 @@ package body Exp_Ch7 is
Build_Task_Activation_Call (N);
end if;
-- When the package is subject to pragma Initial_Condition and lacks
-- a body, the assertion expression must be verified at the end of
-- the visible declarations. Otherwise the check is performed at the
-- end of the body statements (see Expand_N_Package_Body).
-- Verify the run-time semantics of pragma Initial_Condition at the
-- end of the private declarations when the package lacks a body.
if Present (Get_Pragma (Id, Pragma_Initial_Condition)) then
Expand_Pragma_Initial_Condition (N);
end if;
Expand_Pragma_Initial_Condition (Id, N);
Pop_Scope;
end if;

214
gcc/ada/exp_ch9.adb
View File

@ -52,7 +52,6 @@ with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch9; use Sem_Ch9;
with Sem_Ch11; use Sem_Ch11;
with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
@ -3841,6 +3840,12 @@ package body Exp_Ch9 is
Set_Original_Protected_Subprogram (New_Id, Def_Id);
end if;
-- Link the protected or unprotected version to the original subprogram
-- it emulates.
Set_Ekind (New_Id, Ekind (Def_Id));
Set_Protected_Subprogram (New_Id, Def_Id);
-- The unprotected operation carries the user code, and debugging
-- information must be generated for it, even though this spec does
-- not come from source. It is also convenient to allow gdb to step
@ -4751,11 +4756,39 @@ package body Exp_Ch9 is
--------------------------------
procedure Build_Task_Activation_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
function Activation_Call_Loc return Source_Ptr;
-- Find a suitable source location for the activation call
-------------------------
-- Activation_Call_Loc --
-------------------------
function Activation_Call_Loc return Source_Ptr is
begin
-- The activation call must carry the location of the "end" keyword
-- when the context is a package declaration.
if Nkind (N) = N_Package_Declaration then
return End_Keyword_Location (N);
-- Otherwise the activation call must carry the location of the
-- "begin" keyword.
else
return Begin_Keyword_Location (N);
end if;
end Activation_Call_Loc;
-- Local variables
Chain : Entity_Id;
Call : Node_Id;
Loc : Source_Ptr;
Name : Node_Id;
P : Node_Id;
Owner : Node_Id;
Stmt : Node_Id;
-- Start of processing for Build_Task_Activation_Call
begin
-- For sequential elaboration policy, all the tasks will be activated at
@ -4763,105 +4796,107 @@ package body Exp_Ch9 is
if Partition_Elaboration_Policy = 'S' then
return;
-- 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.
elsif Nkind (N) = N_Package_Declaration
and then Present (Corresponding_Body (N))
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.
-- 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.
if Nkind (N) = N_Package_Body then
P := Corresponding_Spec (N);
loop
P := Parent (P);
exit when Nkind (P) = N_Package_Declaration;
end loop;
Owner := N;
Chain := Activation_Chain_Entity (P);
if Nkind (Owner) = N_Package_Body then
Owner := Unit_Declaration_Node (Corresponding_Spec (Owner));
end if;
Chain := Activation_Chain_Entity (Owner);
-- Nothing to do when there are no tasks to activate. This is indicated
-- by a missing activation chain entity.
if No (Chain) then
return;
end if;
-- 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.
Loc := Activation_Call_Loc;
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;
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)));
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;
else
Chain := Activation_Chain_Entity (N);
end if;
-- The call goes at the start of the statement sequence after the
-- start of exception range label if one is present.
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;
if Present (Handled_Statement_Sequence (N)) then
Stmt := First (Statements (Handled_Statement_Sequence (N)));
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)));
-- A special case, skip exception range label if one is present
-- (from front end zcx processing).
if Nkind (N) = N_Package_Declaration then
if Present (Corresponding_Body (N)) then
null;
elsif Present (Private_Declarations (Specification (N))) then
Append (Call, Private_Declarations (Specification (N)));
else
Append (Call, Visible_Declarations (Specification (N)));
if Nkind (Stmt) = N_Label and then Exception_Junk (Stmt) then
Next (Stmt);
end if;
else
if Present (Handled_Statement_Sequence (N)) then
-- 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.
-- The call goes at the start of the statement sequence after
-- the start of exception range label if one is present.
declare
Stm : Node_Id;
begin
Stm := First (Statements (Handled_Statement_Sequence (N)));
-- A special case, skip exception range label if one is
-- present (from front end zcx processing).
if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then
Next (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.
if Nkind (Stm) = N_Block_Statement
and then Exception_Junk (Stm)
then
Stm :=
First (Statements (Handled_Statement_Sequence (Stm)));
end if;
-- Insertion point is after any exception label pushes,
-- since we want it covered by any local handlers.
while Nkind (Stm) in N_Push_xxx_Label loop
Next (Stm);
end loop;
-- Now we have the proper insertion point
Insert_Before (Stm, Call);
end;
else
Set_Handled_Statement_Sequence (N,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Call)));
if Nkind (Stmt) = N_Block_Statement
and then Exception_Junk (Stmt)
then
Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
end if;
end if;
Analyze (Call);
Check_Task_Activation (N);
-- Insertion point is after any exception label pushes, since we
-- want it covered by any local handlers.
while Nkind (Stmt) in N_Push_xxx_Label loop
Next (Stmt);
end loop;
-- Now we have the proper insertion point
Insert_Before (Stmt, Call);
else
Set_Handled_Statement_Sequence (N,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Call)));
end if;
end if;
Analyze (Call);
end Build_Task_Activation_Call;
-------------------------------
@ -10527,6 +10562,11 @@ package body Exp_Ch9 is
Make_Defining_Identifier (Eloc,
New_External_Name (Chars (Ename), 'A', Num_Accept));
-- Link the acceptor to the original receiving entry
Set_Ekind (PB_Ent, E_Procedure);
Set_Receiving_Entry (PB_Ent, Eent);
if Comes_From_Source (Alt) then
Set_Debug_Info_Needed (PB_Ent);
end if;

318
gcc/ada/exp_prag.adb
View File

@ -42,6 +42,7 @@ with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
@ -1447,82 +1448,287 @@ package body Exp_Prag is
-- Expand_Pragma_Initial_Condition --
-------------------------------------
procedure Expand_Pragma_Initial_Condition (Spec_Or_Body : Node_Id) is
Loc : constant Source_Ptr := Sloc (Spec_Or_Body);
procedure Expand_Pragma_Initial_Condition
(Pack_Id : Entity_Id;
N : Node_Id)
is
procedure Extract_Package_Body_Lists
(Pack_Body : Node_Id;
Body_List : out List_Id;
Call_List : out List_Id;
Spec_List : out List_Id);
-- Obtain the various declarative and statement lists of package body
-- Pack_Body needed to insert the initial condition procedure and the
-- call to it. The lists are as follows:
--
-- * Body_List - used to insert the initial condition procedure body
--
-- * Call_List - used to insert the call to the initial condition
-- procedure.
--
-- * Spec_List - used to insert the initial condition procedure spec
Check : Node_Id;
Expr : Node_Id;
Init_Cond : Node_Id;
List : List_Id;
Pack_Id : Entity_Id;
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);
Dummy_1 : List_Id;
Dummy_2 : List_Id;
HSS : Node_Id;
begin
pragma Assert (Present (Pack_Spec));
-- The different parts of the invariant procedure are inserted as
-- follows:
-- package Pack is package body Pack is
-- <IC spec> <IC body>
-- private begin
-- ... <IC call>
-- end Pack; end Pack;
-- 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);
if No (Body_List) then
Body_List := New_List;
Set_Declarations (Pack_Body, Body_List);
end if;
-- The call to the initial condition procedure is inserted in the
-- statements of the package body.
HSS := Handled_Statement_Sequence (Pack_Body);
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;
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:
-- 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
if Nkind (Spec_Or_Body) = N_Package_Body then
Pack_Id := Corresponding_Spec (Spec_Or_Body);
-- Nothing to do when the package is not subject to an Initial_Condition
-- pragma.
if Present (Handled_Statement_Sequence (Spec_Or_Body)) then
List := Statements (Handled_Statement_Sequence (Spec_Or_Body));
if No (IC_Prag) then
return;
end if;
-- The package body lacks statements, create an empty list
Expr := Get_Pragma_Arg (First (Pragma_Argument_Associations (IC_Prag)));
Loc := Sloc (IC_Prag);
else
List := New_List;
-- Nothing to do when the pragma or its argument are illegal because
-- there is no valid expression to check.
Set_Handled_Statement_Sequence (Spec_Or_Body,
Make_Handled_Sequence_Of_Statements (Loc, Statements => List));
end if;
if Error_Posted (IC_Prag) or else Error_Posted (Expr) then
return;
end if;
elsif Nkind (Spec_Or_Body) = N_Package_Declaration then
Pack_Id := Defining_Entity (Spec_Or_Body);
-- Obtain the various lists of the context where the individual pieces
-- of the initial condition procedure are to be inserted.
if Present (Visible_Declarations (Specification (Spec_Or_Body))) then
List := Visible_Declarations (Specification (Spec_Or_Body));
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);
-- The package lacks visible declarations, create an empty list
else
List := New_List;
Set_Visible_Declarations (Specification (Spec_Or_Body), List);
end if;
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;
end if;
Init_Cond := Get_Pragma (Pack_Id, Pragma_Initial_Condition);
-- The caller should check whether the package is subject to pragma
-- Initial_Condition.
pragma Assert (Present (Init_Cond));
Expr :=
Get_Pragma_Arg (First (Pragma_Argument_Associations (Init_Cond)));
-- The assertion expression was found to be illegal, do not generate the
-- runtime check as it will repeat the illegality.
if Error_Posted (Init_Cond) or else Error_Posted (Expr) then
pragma Assert (False);
return;
end if;
Proc_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Pack_Id), "Initial_Condition"));
Set_Ekind (Proc_Id, E_Procedure);
Set_Is_Initial_Condition_Procedure (Proc_Id);
-- Generate:
-- pragma Check (Initial_Condition, <Expr>);
-- procedure <Pack_Id>Initial_Condition;
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))));
Proc_Decl :=
Make_Subprogram_Declaration (Loc,
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Proc_Id));
Append_To (List, Check);
Analyze (Check);
Append_To (Spec_List, Proc_Decl);
-- 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:
-- 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)))))));
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);
Analyze (Proc_Decl);
Analyze (Proc_Body);
Analyze (Call);
end Expand_Pragma_Initial_Condition;
------------------------------------

18
gcc/ada/exp_prag.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -42,15 +42,11 @@ package Exp_Prag is
-- Subp_Id's body. All generated code is added to list Stmts. If Stmts is
-- No_List on entry, a new list is created.
procedure Expand_Pragma_Initial_Condition (Spec_Or_Body : Node_Id);
-- Generate a runtime check needed to verify the assumption of introduced
-- by pragma Initial_Condition. Spec_Or_Body denotes the spec or body of
-- the package where the pragma appears. The check is inserted according
-- to the following precedence rules:
-- 1) If the package has a body with a statement sequence, the check is
-- inserted at the end of the statments.
-- 2) If the package has a body, the check is inserted at the end of the
-- body declarations.
-- 3) The check is inserted at the end of the visible declarations.
procedure Expand_Pragma_Initial_Condition
(Pack_Id : Entity_Id;
N : Node_Id);
-- Verify the run-time semantics of pragma Initial_Condition when it
-- applies to package Pack_Id. N denotes the related package spec or
-- body.
end Exp_Prag;

89
gcc/ada/exp_spark.adb
View File

@ -61,13 +61,16 @@ package body Exp_SPARK is
procedure Expand_SPARK_Indexed_Component (N : Node_Id);
-- Insert explicit dereference if required
procedure Expand_SPARK_N_Loop_Statement (N : Node_Id);
-- Perform loop statement-specific expansion
procedure Expand_SPARK_N_Object_Declaration (N : Node_Id);
-- Perform object-declaration-specific expansion
procedure Expand_SPARK_N_Object_Renaming_Declaration (N : Node_Id);
-- Perform name evaluation for a renamed object
procedure Expand_SPARK_Op_Ne (N : Node_Id);
procedure Expand_SPARK_N_Op_Ne (N : Node_Id);
-- Rewrite operator /= based on operator = when defined explicitly
procedure Expand_SPARK_Selected_Component (N : Node_Id);
@ -118,17 +121,7 @@ package body Exp_SPARK is
-- dealt with specially in GNATprove.
when N_Loop_Statement =>
declare
Scheme : constant Node_Id := Iteration_Scheme (N);
begin
if Present (Scheme)
and then Present (Iterator_Specification (Scheme))
and then
Is_Iterator_Over_Array (Iterator_Specification (Scheme))
then
Expand_Iterator_Loop_Over_Array (N);
end if;
end;
Expand_SPARK_N_Loop_Statement (N);
when N_Object_Declaration =>
Expand_SPARK_N_Object_Declaration (N);
@ -137,7 +130,7 @@ package body Exp_SPARK is
Expand_SPARK_N_Object_Renaming_Declaration (N);
when N_Op_Ne =>
Expand_SPARK_Op_Ne (N);
Expand_SPARK_N_Op_Ne (N);
when N_Freeze_Entity =>
if Is_Type (Entity (N)) then
@ -157,6 +150,21 @@ package body Exp_SPARK is
end case;
end Expand_SPARK;
------------------------------
-- Expand_SPARK_Freeze_Type --
------------------------------
procedure Expand_SPARK_Freeze_Type (E : Entity_Id) is
begin
-- When a DIC is inherited by a tagged type, it may need to be
-- specialized to the descendant type, hence build a separate DIC
-- procedure for it as done during regular expansion for compilation.
if Has_DIC (E) and then Is_Tagged_Type (E) then
Build_DIC_Procedure_Body (E, For_Freeze => True);
end if;
end Expand_SPARK_Freeze_Type;
----------------------------------------
-- Expand_SPARK_N_Attribute_Reference --
----------------------------------------
@ -261,20 +269,28 @@ package body Exp_SPARK is
end if;
end Expand_SPARK_N_Attribute_Reference;
------------------------------
-- Expand_SPARK_Freeze_Type --
------------------------------
-----------------------------------
-- Expand_SPARK_N_Loop_Statement --
-----------------------------------
procedure Expand_SPARK_N_Loop_Statement (N : Node_Id) is
Scheme : constant Node_Id := Iteration_Scheme (N);
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.
-- 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 Has_DIC (E) and then Is_Tagged_Type (E) then
Build_DIC_Procedure_Body (E, For_Freeze => True);
if Present (Scheme)
and then Present (Iterator_Specification (Scheme))
and then Is_Iterator_Over_Array (Iterator_Specification (Scheme))
then
Expand_Iterator_Loop_Over_Array (N);
end if;
end Expand_SPARK_Freeze_Type;
end Expand_SPARK_N_Loop_Statement;
------------------------------------
-- Expand_SPARK_Indexed_Component --
@ -295,9 +311,11 @@ package body Exp_SPARK is
---------------------------------------
procedure Expand_SPARK_N_Object_Declaration (N : Node_Id) is
Def_Id : constant Entity_Id := Defining_Identifier (N);
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (Def_Id);
Obj_Id : constant Entity_Id := Defining_Identifier (N);
Typ : constant Entity_Id := Etype (Obj_Id);
Call : Node_Id;
begin
-- If the object declaration denotes a variable without initialization
@ -305,12 +323,19 @@ package body Exp_SPARK is
-- and analyze a dummy call to the DIC procedure of the type in order
-- to detect potential elaboration issues.
if Comes_From_Source (Def_Id)
if Comes_From_Source (Obj_Id)
and then Ekind (Obj_Id) = E_Variable
and then Has_DIC (Typ)
and then Present (DIC_Procedure (Typ))
and then not Has_Init_Expression (N)
then
Analyze (Build_DIC_Call (Loc, Def_Id, Typ));
Call := Build_DIC_Call (Loc, Obj_Id, Typ);
-- Partially insert the call into the tree by setting its parent
-- pointer.
Set_Parent (Call, N);
Analyze (Call);
end if;
end Expand_SPARK_N_Object_Declaration;
@ -370,11 +395,11 @@ package body Exp_SPARK is
end if;
end Expand_SPARK_N_Object_Renaming_Declaration;
------------------------
-- Expand_SPARK_Op_Ne --
------------------------
--------------------------
-- Expand_SPARK_N_Op_Ne --
--------------------------
procedure Expand_SPARK_Op_Ne (N : Node_Id) is
procedure Expand_SPARK_N_Op_Ne (N : Node_Id) is
Typ : constant Entity_Id := Etype (Left_Opnd (N));
begin
@ -388,7 +413,7 @@ package body Exp_SPARK is
else
Exp_Ch4.Expand_N_Op_Ne (N);
end if;
end Expand_SPARK_Op_Ne;
end Expand_SPARK_N_Op_Ne;
-------------------------------------
-- Expand_SPARK_Potential_Renaming --

94
gcc/ada/exp_util.adb
View File

@ -52,6 +52,7 @@ with Sem_Ch8; use Sem_Ch8;
with Sem_Ch12; use Sem_Ch12;
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
@ -1763,9 +1764,12 @@ package body Exp_Util is
-- Perform minor decoration in case the body is not analyzed
Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
Set_Etype (Proc_Body_Id, Standard_Void_Type);
Set_Scope (Proc_Body_Id, Current_Scope);
Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
Set_Etype (Proc_Body_Id, Standard_Void_Type);
Set_Scope (Proc_Body_Id, Current_Scope);
Set_SPARK_Pragma (Proc_Body_Id, SPARK_Pragma (Proc_Id));
Set_SPARK_Pragma_Inherited
(Proc_Body_Id, SPARK_Pragma_Inherited (Proc_Id));
-- Link both spec and body to avoid generating duplicates
@ -1905,17 +1909,19 @@ package body Exp_Util is
-- Perform minor decoration in case the declaration is not analyzed
Set_Ekind (Proc_Id, E_Procedure);
Set_Etype (Proc_Id, Standard_Void_Type);
Set_Scope (Proc_Id, Current_Scope);
Set_Ekind (Proc_Id, E_Procedure);
Set_Etype (Proc_Id, Standard_Void_Type);
Set_Is_DIC_Procedure (Proc_Id);
Set_Scope (Proc_Id, Current_Scope);
Set_SPARK_Pragma (Proc_Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Proc_Id);
Set_Is_DIC_Procedure (Proc_Id);
Set_DIC_Procedure (Work_Typ, Proc_Id);
-- The DIC procedure requires debug info when the assertion expression
-- is subject to Source Coverage Obligations.
if Opt.Generate_SCO then
if Generate_SCO then
Set_Needs_Debug_Info (Proc_Id);
end if;
@ -3387,7 +3393,7 @@ package body Exp_Util is
-- The invariant procedure requires debug info when the invariants are
-- subject to Source Coverage Obligations.
if Opt.Generate_SCO then
if Generate_SCO then
Set_Needs_Debug_Info (Proc_Id);
end if;
@ -7232,7 +7238,7 @@ package body Exp_Util is
null;
end if;
-- Another special case, an attribute denoting a procedure call
-- Special case: an attribute denoting a procedure call
when N_Attribute_Reference =>
if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
@ -7250,6 +7256,14 @@ package body Exp_Util is
null;
end if;
-- Special case: a call marker
when N_Call_Marker =>
if Is_List_Member (P) then
Insert_List_Before_And_Analyze (P, Ins_Actions);
return;
end if;
-- A contract node should not belong to the tree
when N_Contract =>
@ -8834,6 +8848,11 @@ package body Exp_Util is
if Present (N) then
Remove_Warning_Messages (N);
-- Update the internal structures of the ABE mechanism in case the
-- dead node is an elaboration scenario.
Kill_Elaboration_Scenario (N);
-- Generate warning if appropriate
if W then
@ -9190,43 +9209,42 @@ package body Exp_Util is
Lo : constant Node_Id :=
New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
Index : constant Entity_Id := Etype (Lo);
Hi : Node_Id;
Length_Expr : constant Node_Id :=
Make_Op_Subtract (Loc,
Left_Opnd =>
Left_Opnd =>
Make_Integer_Literal (Loc,
Intval => String_Literal_Length (Literal_Typ)),
Right_Opnd =>
Make_Integer_Literal (Loc, 1));
Right_Opnd => Make_Integer_Literal (Loc, 1));
Hi : Node_Id;
begin
Set_Analyzed (Lo, False);
if Is_Integer_Type (Index) then
Hi :=
Make_Op_Add (Loc,
Left_Opnd => New_Copy_Tree (Lo),
Right_Opnd => Length_Expr);
else
Hi :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Val,
Prefix => New_Occurrence_Of (Index, Loc),
Expressions => New_List (
Make_Op_Add (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Pos,
Prefix => New_Occurrence_Of (Index, Loc),
Expressions => New_List (New_Copy_Tree (Lo))),
Right_Opnd => Length_Expr)));
end if;
if Is_Integer_Type (Index) then
Hi :=
Make_Op_Add (Loc,
Left_Opnd => New_Copy_Tree (Lo),
Right_Opnd => Length_Expr);
else
Hi :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Val,
Prefix => New_Occurrence_Of (Index, Loc),
Expressions => New_List (
Make_Op_Add (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Pos,
Prefix => New_Occurrence_Of (Index, Loc),
Expressions => New_List (New_Copy_Tree (Lo))),
Right_Opnd => Length_Expr)));
end if;
return
Make_Range (Loc,
Low_Bound => Lo,
High_Bound => Hi);
return
Make_Range (Loc,
Low_Bound => Lo,
High_Bound => Hi);
end Make_Literal_Range;
--------------------------

7
gcc/ada/exp_util.ads
View File

@ -856,11 +856,8 @@ package Exp_Util is
-- False means that it is not known if the value is positive or negative.
function Make_Invariant_Call (Expr : Node_Id) return Node_Id;
-- Expr is an object of a type which Has_Invariants set (and which thus
-- also has an Invariant_Procedure set). If invariants are enabled, this
-- function returns a call to the Invariant procedure passing Expr as the
-- argument, and returns it unanalyzed. If invariants are not enabled,
-- returns a null statement.
-- Generate a call to the Invariant_Procedure associated with the type of
-- expression Expr. Expr is passed as an actual parameter in the call.
function Make_Predicate_Call
(Typ : Entity_Id;

20
gcc/ada/frontend.adb
View File

@ -87,6 +87,7 @@ begin
Checks.Initialize;
Sem_Warn.Initialize;
Prep.Initialize;
Sem_Elab.Initialize;
if Generate_SCIL then
SCIL_LL.Initialize;
@ -422,8 +423,9 @@ begin
Instantiate_Bodies;
end if;
-- Analyze inlined bodies and check elaboration rules in GNATprove
-- mode as well as during compilation.
-- Analyze all inlined bodies, check access-before-elaboration
-- rules, and remove ignored Ghost code when generating code or
-- compiling for GNATprove.
if Operating_Mode = Generate_Code or else GNATprove_Mode then
if Inline_Processing_Required then
@ -437,12 +439,24 @@ begin
Collect_Garbage_Entities;
end if;
Check_Elab_Calls;
-- Examine all top level scenarios collected during analysis
-- and resolution. Diagnose conditional and guaranteed ABEs,
-- install run-time checks to catch ABEs, and guarantee the
-- prior elaboration of external units.
Check_Elaboration_Scenarios;
-- Remove any ignored Ghost code as it must not appear in the
-- executable.
Remove_Ignored_Ghost_Code;
-- Otherwise check the access-before-elaboration rules even when
-- previous errors were detected or the compilation is verifying
-- semantics.
else
Check_Elaboration_Scenarios;
end if;
-- At this stage we can unnest subprogram bodies if required

9
gcc/ada/gcc-interface/trans.c
View File

@ -7688,6 +7688,15 @@ gnat_to_gnu (Node_Id gnat_node)
/* Added Nodes */
/****************/
/* Call markers are created by the ABE mechanism to capture the target of
a call along with other elaboration-related attributes which are either
unavailable of expensive to recompute. Call markers do not have static
and runtime semantics, and should be ignored. */
case N_Call_Marker:
gnu_result = alloc_stmt_list ();
break;
case N_Expression_With_Actions:
/* This construct doesn't define a scope so we don't push a binding
level around the statement list, but we wrap it in a SAVE_EXPR to

3203
gcc/ada/gnat_ugn.texi
View File

File diff suppressed because it is too large Load Diff

33
gcc/ada/lib.adb
View File

@ -62,7 +62,9 @@ package body Lib is
Yes_After, -- S1 is in same extended unit as S2, and appears after it
No); -- S2 is not in same extended unit as S2
function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result;
function Check_Same_Extended_Unit
(S1 : Source_Ptr;
S2 : Source_Ptr) return SEU_Result;
-- Used by In_Same_Extended_Unit and Earlier_In_Extended_Unit. Returns
-- value as described above.
@ -273,7 +275,10 @@ package body Lib is
-- Check_Same_Extended_Unit --
------------------------------
function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result is
function Check_Same_Extended_Unit
(S1 : Source_Ptr;
S2 : Source_Ptr) return SEU_Result
is
Max_Iterations : constant Nat := Maximum_Instantiations * 2;
-- Limit to prevent a potential infinite loop
@ -459,6 +464,7 @@ package body Lib is
-- Prevent looping forever
if Counter > Max_Iterations then
-- ??? Not quite right, but return a value to be able to generate
-- SCIL files and hope for the best.
@ -502,11 +508,22 @@ package body Lib is
-- Earlier_In_Extended_Unit --
------------------------------
function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is
function Earlier_In_Extended_Unit
(S1 : Source_Ptr;
S2 : Source_Ptr) return Boolean
is
begin
return Check_Same_Extended_Unit (S1, S2) = Yes_Before;
end Earlier_In_Extended_Unit;
function Earlier_In_Extended_Unit
(N1 : Node_Or_Entity_Id;
N2 : Node_Or_Entity_Id) return Boolean
is
begin
return Earlier_In_Extended_Unit (Sloc (N1), Sloc (N2));
end Earlier_In_Extended_Unit;
-----------------------
-- Exact_Source_Name --
-----------------------
@ -747,7 +764,9 @@ package body Lib is
begin
return
Get_Code_Or_Source_Unit
(S, Unwind_Instances => True, Unwind_Subunits => False);
(S => S,
Unwind_Instances => True,
Unwind_Subunits => False);
end Get_Source_Unit;
function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is
@ -807,8 +826,7 @@ package body Lib is
-- Node may be in spec (or subunit etc) of main unit
else
return
In_Same_Extended_Unit (N, Cunit (Main_Unit));
return In_Same_Extended_Unit (N, Cunit (Main_Unit));
end if;
end In_Extended_Main_Code_Unit;
@ -828,8 +846,7 @@ package body Lib is
-- Location may be in spec (or subunit etc) of main unit
else
return
In_Same_Extended_Unit (Loc, Sloc (Cunit (Main_Unit)));
return In_Same_Extended_Unit (Loc, Sloc (Cunit (Main_Unit)));
end if;
end In_Extended_Main_Code_Unit;

9
gcc/ada/lib.ads
View File

@ -481,13 +481,20 @@ package Lib is
-- avoid registering switches added automatically by the gcc driver at the
-- end of the command line.
function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean;
function Earlier_In_Extended_Unit
(S1 : Source_Ptr;
S2 : Source_Ptr) return Boolean;
-- Given two Sloc values for which In_Same_Extended_Unit is true, determine
-- if S1 appears before S2. Returns True if S1 appears before S2, and False
-- otherwise. The result is undefined if S1 and S2 are not in the same
-- extended unit. Note: this routine will not give reliable results if
-- called after Sprint has been called with -gnatD set.
function Earlier_In_Extended_Unit
(N1 : Node_Or_Entity_Id;
N2 : Node_Or_Entity_Id) return Boolean;
-- Same as above, but the inputs denote nodes or entities
procedure Enable_Switch_Storing;
-- Enable registration of switches by Store_Compilation_Switch. Used to
-- avoid registering switches added automatically by the gcc driver at the

15
gcc/ada/sem.adb
View File

@ -612,6 +612,12 @@ package body Sem is
when N_With_Clause =>
Analyze_With_Clause (N);
-- A call to analyze a call marker is ignored because the node does
-- not have any static and run-time semantics.
when N_Call_Marker =>
null;
-- A call to analyze the Empty node is an error, but most likely it
-- is an error caused by an attempt to analyze a malformed piece of
-- tree caused by some other error, so if there have been any other
@ -1242,6 +1248,15 @@ package body Sem is
Scope_Stack.Locked := True;
end Lock;
------------------------
-- Preanalysis_Active --
------------------------
function Preanalysis_Active return Boolean is
begin
return not Full_Analysis and not Expander_Active;
end Preanalysis_Active;
----------------
-- Preanalyze --
----------------

4
gcc/ada/sem.ads
View File

@ -683,6 +683,10 @@ package Sem is
-- This function returns True if an explicit pragma Suppress for check C
-- is present in the package defining E.
function Preanalysis_Active return Boolean;
pragma Inline (Preanalysis_Active);
-- Determine whether preanalysis is active at the point of invocation
procedure Preanalyze (N : Node_Id);
-- Performs a pre-analysis of node N. During pre-analysis no expansion is
-- carried out for N or its children. For more info on pre-analysis read

27
gcc/ada/sem_attr.adb
View File

@ -28,7 +28,6 @@ with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
with Atree; use Atree;
with Casing; use Casing;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
@ -806,6 +805,20 @@ package body Sem_Attr is
("prefix of % attribute cannot be enumeration literal");
end if;
-- Preserve relevant elaboration-related attributes of the context
-- which are no longer available or very expensive to recompute once
-- analysis, resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => N,
Checks => True,
Modes => True);
-- Save the scenario for later examination by the ABE Processing
-- phase.
Record_Elaboration_Scenario (N);
-- Case of access to subprogram
if Is_Entity_Name (P) and then Is_Overloadable (Entity (P)) then
@ -860,14 +873,6 @@ package body Sem_Attr is
Kill_Current_Values;
end if;
-- In the static elaboration model, treat the attribute reference
-- as a call for elaboration purposes. Suppress this treatment
-- under debug flag. In any case, we are all done.
if not Dynamic_Elaboration_Checks and not Debug_Flag_Dot_UU then
Check_Elab_Call (N);
end if;
return;
-- Component is an operation of a protected type
@ -11133,8 +11138,8 @@ package body Sem_Attr is
-- 'Unrestricted_Access or in case of a subprogram.
if Is_Entity_Name (P)
and then (Attr_Id = Attribute_Unrestricted_Access
or else Is_Subprogram (Entity (P)))
and then (Attr_Id = Attribute_Unrestricted_Access
or else Is_Subprogram (Entity (P)))
then
Set_Address_Taken (Entity (P));
end if;

194
gcc/ada/sem_ch12.adb
View File

@ -839,6 +839,10 @@ package body Sem_Ch12 is
-- entity is marked as having a limited_view actual when some actual is
-- a limited view. This is used to place the instance body properly.
procedure Provide_Completing_Bodies (N : Node_Id);
-- Generate completing bodies for all subprograms found within package or
-- subprogram declaration N.
procedure Remove_Parent (In_Body : Boolean := False);
-- Reverse effect after instantiation of child is complete
@ -3542,6 +3546,14 @@ package body Sem_Ch12 is
Set_SPARK_Pragma_Inherited (Id);
Set_SPARK_Aux_Pragma_Inherited (Id);
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => Id,
Checks => True);
-- Analyze aspects now, so that generated pragmas appear in the
-- declarations before building and analyzing the generic copy.
@ -3670,7 +3682,7 @@ package body Sem_Ch12 is
Create_Generic_Contract (N);
Spec := Specification (N);
Id := Defining_Entity (Spec);
Id := Defining_Entity (Spec);
Generate_Definition (Id);
if Nkind (Id) = N_Defining_Operator_Symbol then
@ -3697,14 +3709,27 @@ package body Sem_Ch12 is
Analyze_Generic_Formal_Part (N);
Formals := Parameter_Specifications (Spec);
if Nkind (Spec) = N_Function_Specification then
Set_Ekind (Id, E_Generic_Function);
else
Set_Ekind (Id, E_Generic_Procedure);
end if;
-- Set SPARK_Mode from context
Set_SPARK_Pragma (Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Id);
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => Id,
Checks => True);
Formals := Parameter_Specifications (Spec);
if Present (Formals) then
Process_Formals (Formals, Spec);
end if;
@ -3900,6 +3925,16 @@ package body Sem_Ch12 is
-- Start of processing for Analyze_Package_Instantiation
begin
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => N,
Checks => True,
Level => True,
Modes => True);
Check_SPARK_05_Restriction ("generic is not allowed", N);
-- Very first thing: check for Text_IO special unit in case we are
@ -4562,19 +4597,26 @@ package body Sem_Ch12 is
Analyze (Act_Decl);
Set_Unit (Parent (N), N);
Set_Body_Required (Parent (N), False);
-- We never need elaboration checks on instantiations, since by
-- definition, the body instantiation is elaborated at the same
-- time as the spec instantiation.
Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
Set_Kill_Elaboration_Checks (Act_Decl_Id);
end if;
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
if Is_Known_Guaranteed_ABE (N) and then Needs_Body then
-- Do not instantiate the corresponding body because gigi cannot
-- handle certain types of premature instantiations.
if ABE_Is_Certain (N) and then Needs_Body then
Pending_Instantiations.Decrement_Last;
-- Create completing bodies for all subprogram declarations since
-- their real bodies will not be instantiated.
Provide_Completing_Bodies (Instance_Spec (N));
end if;
Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
@ -5056,7 +5098,7 @@ package body Sem_Ch12 is
-- No point in inlining if ABE is inevitable
and then not ABE_Is_Certain (N)
and then not Is_Known_Guaranteed_ABE (N)
-- Or if subprogram is eliminated
@ -5242,12 +5284,7 @@ package body Sem_Ch12 is
Check_Eliminated (Act_Decl_Id);
Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id));
-- In compilation unit case, kill elaboration checks on the
-- instantiation, since they are never needed -- the body is
-- instantiated at the same point as the spec.
if Nkind (Parent (N)) = N_Compilation_Unit then
Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
Set_Kill_Elaboration_Checks (Act_Decl_Id);
Set_Is_Compilation_Unit (Anon_Id);
@ -5338,6 +5375,16 @@ package body Sem_Ch12 is
-- Start of processing for Analyze_Subprogram_Instantiation
begin
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => N,
Checks => True,
Level => True,
Modes => True);
Check_SPARK_05_Restriction ("generic is not allowed", N);
-- Very first thing: check for special Text_IO unit in case we are
@ -5590,8 +5637,17 @@ package body Sem_Ch12 is
Set_Ignore_SPARK_Mode_Pragmas (Anon_Id);
end if;
if not Is_Intrinsic_Subprogram (Gen_Unit) then
Check_Elab_Instantiation (N);
-- Save the scenario for later examination by the ABE Processing
-- phase.
Record_Elaboration_Scenario (N);
-- The instantiation results in a guaranteed ABE. Create a completing
-- body for the subprogram declaration because the real body will not
-- be instantiated.
if Is_Known_Guaranteed_ABE (N) then
Provide_Completing_Bodies (Instance_Spec (N));
end if;
if Is_Dispatching_Operation (Act_Decl_Id)
@ -8561,7 +8617,7 @@ package body Sem_Ch12 is
-- The parent was a premature instantiation. Insert freeze node at
-- the end the current declarative part.
if ABE_Is_Certain (Get_Unit_Instantiation_Node (Par)) then
if Is_Known_Guaranteed_ABE (Get_Unit_Instantiation_Node (Par)) then
Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
-- Handle the following case:
@ -13991,6 +14047,102 @@ package body Sem_Ch12 is
end if;
end Preanalyze_Actuals;
-------------------------------
-- Provide_Completing_Bodies --
-------------------------------
procedure Provide_Completing_Bodies (N : Node_Id) is
procedure Build_Completing_Body (Subp_Decl : Node_Id);
-- Generate the completing body for subprogram declaration Subp_Decl
procedure Provide_Completing_Bodies_In (Decls : List_Id);
-- Generating completing bodies for all subprograms found in declarative
-- list Decls.
---------------------------
-- Build_Completing_Body --
---------------------------
procedure Build_Completing_Body (Subp_Decl : Node_Id) is
Loc : constant Source_Ptr := Sloc (Subp_Decl);
Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
Spec : Node_Id;
begin
-- Nothing to do if the subprogram already has a completing body
if Present (Corresponding_Body (Subp_Decl)) then
return;
-- Mark the function as having a valid return statement even though
-- the body contains a single raise statement.
elsif Ekind (Subp_Id) = E_Function then
Set_Return_Present (Subp_Id);
end if;
-- Clone the specification to obtain new entities and reset the only
-- semantic field.
Spec := Copy_Subprogram_Spec (Specification (Subp_Decl));
Set_Generic_Parent (Spec, Empty);
-- Generate:
-- function Func ... return ... is
-- <or>
-- procedure Proc ... is
-- begin
-- raise Program_Error with "access before elaboration";
-- edn Proc;
Insert_After_And_Analyze (Subp_Decl,
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Raise_Program_Error (Loc,
Reason => PE_Access_Before_Elaboration)))));
end Build_Completing_Body;
----------------------------------
-- Provide_Completing_Bodies_In --
----------------------------------
procedure Provide_Completing_Bodies_In (Decls : List_Id) is
Decl : Node_Id;
begin
if Present (Decls) then
Decl := First (Decls);
while Present (Decl) loop
Provide_Completing_Bodies (Decl);
Next (Decl);
end loop;
end if;
end Provide_Completing_Bodies_In;
-- Local variables
Spec : Node_Id;
-- Start of processing for Provide_Completing_Bodies
begin
if Nkind (N) = N_Package_Declaration then
Spec := Specification (N);
Push_Scope (Defining_Entity (N));
Provide_Completing_Bodies_In (Visible_Declarations (Spec));
Provide_Completing_Bodies_In (Private_Declarations (Spec));
Pop_Scope;
elsif Nkind (N) = N_Subprogram_Declaration then
Build_Completing_Body (N);
end if;
end Provide_Completing_Bodies;
-------------------
-- Remove_Parent --
-------------------

14
gcc/ada/sem_ch3.adb
View File

@ -4709,6 +4709,20 @@ package body Sem_Ch3 is
end if;
end if;
-- Set the SPARK mode from the current context (may be overwritten later
-- with explicit pragma).
Set_SPARK_Pragma (Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Id);
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => Id,
Checks => True);
-- Initialize alignment and size and capture alignment setting
Init_Alignment (Id);

24
gcc/ada/sem_ch5.adb
View File

@ -379,6 +379,15 @@ package body Sem_Ch5 is
begin
Mark_Coextensions (N, Rhs);
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => N,
Checks => True,
Modes => True);
-- Analyze the target of the assignment first in case the expression
-- contains references to Ghost entities. The checks that verify the
-- proper use of a Ghost entity need to know the enclosing context.
@ -917,11 +926,9 @@ package body Sem_Ch5 is
Error_Msg_CRT ("composite assignment", N);
end if;
-- Check elaboration warning for left side if not in elab code
-- Save the scenario for later examination by the ABE Processing phase
if not In_Subprogram_Or_Concurrent_Unit then
Check_Elab_Assign (Lhs);
end if;
Record_Elaboration_Scenario (N);
-- Set Referenced_As_LHS if appropriate. We only set this flag if the
-- assignment is a source assignment in the extended main source unit.
@ -2044,13 +2051,13 @@ package body Sem_Ch5 is
begin
if No (Iterator) then
null; -- error reported below.
null; -- error reported below
elsif not Is_Overloaded (Iterator) then
Check_Reverse_Iteration (Etype (Iterator));
-- If Iterator is overloaded, use reversible iterator if
-- one is available.
-- If Iterator is overloaded, use reversible iterator if one is
-- available.
elsif Is_Overloaded (Iterator) then
Get_First_Interp (Iterator, I, It);
@ -3609,8 +3616,7 @@ package body Sem_Ch5 is
end if;
else
-- Pre-Ada2012 for-loops and while loops.
-- Pre-Ada2012 for-loops and while loops
Analyze_Statements (Statements (N));
end if;

46
gcc/ada/sem_ch6.adb
View File

@ -226,6 +226,20 @@ package body Sem_Ch6 is
Generate_Definition (Subp_Id);
-- Set the SPARK mode from the current context (may be overwritten later
-- with explicit pragma).
Set_SPARK_Pragma (Subp_Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Subp_Id);
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => Subp_Id,
Checks => True);
Set_Is_Abstract_Subprogram (Subp_Id);
New_Overloaded_Entity (Subp_Id);
Check_Delayed_Subprogram (Subp_Id);
@ -1468,7 +1482,7 @@ package body Sem_Ch6 is
Set_Actual_Subtypes (N, Current_Scope);
Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Body_Id);
-- Analyze any aspect specifications that appear on the generic
@ -1769,13 +1783,12 @@ package body Sem_Ch6 is
if Analyzed (N) then
return;
end if;
-- If there is an error analyzing the name (which may have been
-- rewritten if the original call was in prefix notation) then error
-- has been emitted already, mark node and return.
if Error_Posted (N) or else Etype (Name (N)) = Any_Type then
elsif Error_Posted (N) or else Etype (Name (N)) = Any_Type then
Set_Etype (N, Any_Type);
return;
end if;
@ -1849,9 +1862,9 @@ package body Sem_Ch6 is
New_N :=
Make_Indexed_Component (Loc,
Prefix =>
Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc),
Prefix => New_Occurrence_Of (Scope (Entity (P)), Loc),
Selector_Name => New_Occurrence_Of (Entity (P), Loc)),
Expressions => Actuals);
Set_Name (N, New_N);
@ -1957,7 +1970,8 @@ package body Sem_Ch6 is
then
New_N :=
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc),
Prefix =>
New_Occurrence_Of (Scope (Entity (Prefix (P))), Loc),
Selector_Name => New_Occurrence_Of (Entity (Prefix (P)), Loc));
Rewrite (Prefix (P), New_N);
Analyze (P);
@ -4026,7 +4040,7 @@ package body Sem_Ch6 is
-- between the spec and body.
elsif No (SPARK_Pragma (Body_Id)) then
Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Body_Id);
end if;
@ -4471,12 +4485,11 @@ package body Sem_Ch6 is
Stm : Node_Id;
begin
-- Skip initial labels (for one thing this occurs when we are in
-- front-end ZCX mode, but in any case it is irrelevant), and also
-- initial Push_xxx_Error_Label nodes, which are also irrelevant.
-- Skip call markers installed by the ABE mechanism, labels, and
-- Push_xxx_Error_Label to find the first real statement.
Stm := First (Statements (HSS));
while Nkind (Stm) = N_Label
while Nkind_In (Stm, N_Call_Marker, N_Label)
or else Nkind (Stm) in N_Push_xxx_Label
loop
Next (Stm);
@ -4657,8 +4670,9 @@ package body Sem_Ch6 is
and then Is_Entry_Barrier_Function (N)
then
null;
else
Set_SPARK_Pragma (Designator, SPARK_Mode_Pragma);
Set_SPARK_Pragma (Designator, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Designator);
end if;
@ -4671,6 +4685,14 @@ package body Sem_Ch6 is
Set_Ignore_SPARK_Mode_Pragmas (Designator);
end if;
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => Designator,
Checks => True);
if Debug_Flag_C then
Write_Str ("==> subprogram spec ");
Write_Name (Chars (Designator));

10
gcc/ada/sem_ch7.adb
View File

@ -1144,16 +1144,10 @@ package body Sem_Ch7 is
end if;
end if;
-- Set Body_Required indication on the compilation unit node
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 (Parent (N), Body_Required);
if not Body_Required then
Set_Suppress_Elaboration_Warnings (Id);
end if;
end if;
End_Package_Scope (Id);

41
gcc/ada/sem_ch8.adb
View File

@ -57,6 +57,7 @@ with Sem_Ch13; use Sem_Ch13;
with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
@ -4133,6 +4134,11 @@ package body Sem_Ch8 is
Statements => New_List (Attr_Node)));
end if;
-- Signal the ABE mechanism that the generated subprogram body has not
-- ABE ramifications.
Set_Was_Attribute_Reference (Body_Node);
-- In case of tagged types we add the body of the generated function to
-- the freezing actions of the type (because in the general case such
-- type is still not frozen). We exclude from this processing generic
@ -4192,15 +4198,6 @@ package body Sem_Ch8 is
Error_Msg_N
("a library unit can only rename another library unit", N);
end if;
-- We suppress elaboration warnings for the resulting entity, since
-- clearly they are not needed, and more particularly, in the case
-- of a generic formal subprogram, the resulting entity can appear
-- after the instantiation itself, and thus look like a bogus case
-- of access before elaboration.
Set_Suppress_Elaboration_Warnings (New_S);
end Attribute_Renaming;
----------------------
@ -5433,6 +5430,16 @@ package body Sem_Ch8 is
return;
end if;
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
if Nkind (N) = N_Identifier then
Mark_Elaboration_Attributes
(N_Id => N,
Modes => True);
end if;
-- Here if Entity pointer was not set, we need full visibility analysis
-- First we generate debugging output if the debug E flag is set.
@ -5907,6 +5914,10 @@ package body Sem_Ch8 is
<<Done>>
Check_Restriction_No_Use_Of_Entity (N);
-- Save the scenario for later examination by the ABE Processing phase
Record_Elaboration_Scenario (N);
end Find_Direct_Name;
------------------------
@ -6421,6 +6432,14 @@ package body Sem_Ch8 is
Change_Selected_Component_To_Expanded_Name (N);
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => N,
Modes => True);
-- Set appropriate type
if Is_Type (Id) then
@ -6529,6 +6548,10 @@ package body Sem_Ch8 is
end if;
Check_Restriction_No_Use_Of_Entity (N);
-- Save the scenario for later examination by the ABE Processing phase
Record_Elaboration_Scenario (N);
end Find_Expanded_Name;
--------------------

40
gcc/ada/sem_ch9.adb
View File

@ -50,6 +50,7 @@ with Sem_Ch5; use Sem_Ch5;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
@ -1656,6 +1657,14 @@ package body Sem_Ch9 is
Set_SPARK_Pragma_Inherited (Def_Id);
end if;
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => Def_Id,
Checks => True);
-- Process formals
if Present (Formals) then
@ -2281,6 +2290,15 @@ package body Sem_Ch9 is
Synch_Type : Entity_Id;
begin
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => N,
Checks => True,
Modes => True);
Tasking_Used := True;
Check_SPARK_05_Restriction ("requeue statement is not allowed", N);
Check_Restriction (No_Requeue_Statements, N);
@ -2553,6 +2571,12 @@ package body Sem_Ch9 is
Error_Msg_N
("target protected object of requeue must be a variable", N);
end if;
-- A requeue statement is treated as a call for purposes of ABE checks
-- and diagnostics. Annotate the tree by creating a call marker in case
-- the requeue statement is transformed by expansion.
Build_Call_Marker (N);
end Analyze_Requeue;
------------------------------
@ -2836,6 +2860,14 @@ package body Sem_Ch9 is
Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Obj_Id);
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => Obj_Id,
Checks => True);
-- Instead of calling Analyze on the new node, call the proper analysis
-- procedure directly. Otherwise the node would be expanded twice, with
-- disastrous result.
@ -3099,6 +3131,14 @@ package body Sem_Ch9 is
Set_SPARK_Pragma_Inherited (T);
Set_SPARK_Aux_Pragma_Inherited (T);
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => T,
Checks => True);
Push_Scope (T);
if Ada_Version >= Ada_2005 then

11381
gcc/ada/sem_elab.adb
View File

File diff suppressed because it is too large Load Diff

195
gcc/ada/sem_elab.ads
View File

@ -23,158 +23,93 @@
-- --
------------------------------------------------------------------------------
-- This package contains the routines used to deal with issuing warnings
-- for cases of calls that may require warnings about possible access
-- before elaboration.
-- This package contains routines which handle access-before-elaboration
-- run-time checks and compile-time diagnostics. See the body for details.
with Types; use Types;
package Sem_Elab is
-----------------------------
-- Description of Approach --
-----------------------------
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.
-- 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.
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 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.
-- The following type classifies the various enclosing levels used in ABE
-- diagnostics.
-- In addition, in SPARK mode, we are checking for a variable reference in
-- another package, which requires an explicit Elaborate_All pragma.
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:
-- 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.
-- package Pack is
-- procedure Proc is -- subprogram body
-- package Nested is -- enclosing package ignored
-- X ... -- at declaration level
-- 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.
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:
-- 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.
-- generic
-- package Pack is -- generic package spec
-- package Nested is -- enclosing package ignored
-- X ... -- at generic library level
-- 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.
Instantiation,
-- A construct is at the "instantiation library level" when it appears
-- in a library unit which is also an instantiation. Example:
-- 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).
-- package Inst is new Gen; -- at instantiation level
-- 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.
Package_Spec,
Package_Body,
-- A construct is at the "library level" when it appears in a package
-- library unit, ignoring enclosing packages. Example:
-- 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.
-- package body Pack is -- package body
-- package Nested is -- enclosing package ignored
-- X ... -- at library level
--------------------------------------
-- Instantiation Elaboration Errors --
--------------------------------------
No_Level);
-- This value is used to indicate that none of the levels above are in
-- effect.
-- A special case arises when an instantiation appears in a context
-- that is known to be before the body is elaborated, e.g.
subtype Generic_Library_Level is Enclosing_Level_Kind range
Generic_Package_Spec ..
Generic_Package_Body;
-- generic package x is ...
-- ...
-- package xx is new x;
-- ...
-- package body x is ...
subtype Library_Level is Enclosing_Level_Kind range
Package_Spec ..
Package_Body;
-- 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.
subtype Any_Library_Level is Enclosing_Level_Kind range
Generic_Package_Spec ..
Package_Body;
-- 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.
function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind;
-- Determine the enclosing level of arbitrary node N
-- 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 Initialize;
-- Initialize the internal structures of this unit
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.
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.
-- 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 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;

62
gcc/ada/sem_prag.adb
View File

@ -14384,12 +14384,11 @@ package body Sem_Prag is
Call := Get_Pragma_Arg (Arg1);
end if;
if Nkind_In (Call,
N_Indexed_Component,
N_Function_Call,
N_Identifier,
N_Expanded_Name,
N_Selected_Component)
if Nkind_In (Call, N_Expanded_Name,
N_Function_Call,
N_Identifier,
N_Indexed_Component,
N_Selected_Component)
then
-- If this pragma Debug comes from source, its argument was
-- parsed as a name form (which is syntactically identical).
@ -14999,26 +14998,6 @@ package body Sem_Prag is
Set_Elaborate_Present (Citem, True);
Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
-- With the pragma present, elaboration calls on
-- subprograms from the named unit need no further
-- checks, as long as the pragma appears in the current
-- compilation unit. If the pragma appears in some unit
-- in the context, there might still be a need for an
-- Elaborate_All_Desirable from the current compilation
-- to the named unit, so we keep the check enabled.
if In_Extended_Main_Source_Unit (N) then
-- This does not apply in SPARK mode, where we allow
-- pragma Elaborate, but we don't trust it to be right
-- so we will still insist on the Elaborate_All.
if SPARK_Mode /= On then
Set_Suppress_Elaboration_Warnings
(Entity (Name (Citem)));
end if;
end if;
exit Inner;
end if;
@ -15096,14 +15075,6 @@ package body Sem_Prag is
Set_Elaborate_All_Present (Citem, True);
Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
-- Suppress warnings and elaboration checks on the named
-- unit if the pragma is in the current compilation, as
-- for pragma Elaborate.
if In_Extended_Main_Source_Unit (N) then
Set_Suppress_Elaboration_Warnings
(Entity (Name (Citem)));
end if;
exit Innr;
end if;
@ -15151,27 +15122,8 @@ package body Sem_Prag is
then
Error_Pragma ("pragma% must refer to a spec, not a body");
else
Set_Body_Required (Cunit_Node, True);
Set_Body_Required (Cunit_Node);
Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
-- If we are in dynamic elaboration mode, then we suppress
-- elaboration warnings for the unit, since it is definitely
-- fine NOT to do dynamic checks at the first level (and such
-- checks will be suppressed because no elaboration boolean
-- is created for Elaborate_Body packages).
-- But in the static model of elaboration, Elaborate_Body is
-- definitely NOT good enough to ensure elaboration safety on
-- its own, since the body may WITH other units that are not
-- safe from an elaboration point of view, so a client must
-- still do an Elaborate_All on such units.
-- Debug flag -gnatdD restores the old behavior of 3.13, where
-- Elaborate_Body always suppressed elab warnings.
if Dynamic_Elaboration_Checks or Debug_Flag_DD then
Set_Suppress_Elaboration_Warnings (Cunit_Ent);
end if;
end if;
end Elaborate_Body;
@ -20249,7 +20201,6 @@ package body Sem_Prag is
else
if not Debug_Flag_U then
Set_Is_Preelaborated (Ent);
Set_Suppress_Elaboration_Warnings (Ent);
end if;
end if;
end if;
@ -20877,7 +20828,6 @@ package body Sem_Prag is
if not Debug_Flag_U then
Set_Is_Pure (Ent);
Set_Has_Pragma_Pure (Ent);
Set_Suppress_Elaboration_Warnings (Ent);
end if;
end Pure;

115
gcc/ada/sem_res.adb
View File

@ -63,8 +63,8 @@ with Sem_Ch13; use Sem_Ch13;
with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Elim; use Sem_Elim;
with Sem_Elab; use Sem_Elab;
with Sem_Elim; use Sem_Elim;
with Sem_Eval; use Sem_Eval;
with Sem_Intr; use Sem_Intr;
with Sem_Util; use Sem_Util;
@ -1325,6 +1325,12 @@ package body Sem_Res is
begin
Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N));
-- Ensure that the corresponding operator has the same parent as the
-- original call. This guarantees that parent traversals performed by
-- the ABE mechanism succeed.
Set_Parent (Op_Node, Parent (N));
-- Binary operator
if Is_Binary then
@ -5785,6 +5791,15 @@ package body Sem_Res is
-- Start of processing for Resolve_Call
begin
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
-- resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => N,
Checks => True,
Modes => True);
-- The context imposes a unique interpretation with type Typ on a
-- procedure or function call. Find the entity of the subprogram that
-- yields the expected type, and propagate the corresponding formal
@ -5841,10 +5856,15 @@ package body Sem_Res is
elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component)
or else (Is_Entity_Name (Subp)
and then Ekind (Entity (Subp)) = E_Entry)
and then Ekind_In (Entity (Subp), E_Entry, E_Entry_Family))
then
Resolve_Entry_Call (N, Typ);
Check_Elab_Call (N);
-- Annotate the tree by creating a call marker in case the original
-- call is transformed by expansion. The call marker is automatically
-- saved for later examination by the ABE Processing phase.
Build_Call_Marker (N);
-- Kill checks and constant values, as above for indirect case
-- Who knows what happens when another task is activated?
@ -6100,14 +6120,14 @@ package body Sem_Res is
-- the proper indexed component.
Index_Node :=
Make_Indexed_Component (Loc,
Prefix =>
Make_Function_Call (Loc,
Name => New_Subp,
Parameter_Associations =>
New_List
(Remove_Head (Parameter_Associations (N)))),
Expressions => Parameter_Associations (N));
Make_Indexed_Component (Loc,
Prefix =>
Make_Function_Call (Loc,
Name => New_Subp,
Parameter_Associations =>
New_List
(Remove_Head (Parameter_Associations (N)))),
Expressions => Parameter_Associations (N));
end if;
-- Preserve the parenthesis count of the node
@ -6122,7 +6142,13 @@ package body Sem_Res is
Set_Etype (Prefix (N), Ret_Type);
Set_Etype (N, Typ);
Resolve_Indexed_Component (N, Typ);
Check_Elab_Call (Prefix (N));
-- Annotate the tree by creating a call marker in case
-- the original call is transformed by expansion. The call
-- marker is automatically saved for later examination by
-- the ABE Processing phase.
Build_Call_Marker (Prefix (N));
end if;
end if;
@ -6633,7 +6659,12 @@ package body Sem_Res is
-- All done, evaluate call and deal with elaboration issues
Eval_Call (N);
Check_Elab_Call (N);
-- Annotate the tree by creating a call marker in case the original call
-- is transformed by expansion. The call marker is automatically saved
-- for later examination by the ABE Processing phase.
Build_Call_Marker (N);
-- In GNATprove mode, expansion is disabled, but we want to inline some
-- subprograms to facilitate formal verification. Indirect calls through
@ -7176,7 +7207,7 @@ package body Sem_Res is
else
Error_Msg_N
("invalid use of subtype mark in expression or call", N);
("invalid use of subtype mark in expression or call", N);
end if;
-- Check discriminant use if entity is discriminant in current scope,
@ -7269,17 +7300,6 @@ package body Sem_Res is
& "(SPARK RM 7.1.3(12))", N);
end if;
-- Check for possible elaboration issues with respect to reads of
-- variables. The act of renaming the variable is not considered a
-- read as it simply establishes an alias.
if Ekind (E) = E_Variable
and then Dynamic_Elaboration_Checks
and then Nkind (Par) /= N_Object_Renaming_Declaration
then
Check_Elab_Call (N);
end if;
-- The variable may eventually become a constituent of a single
-- protected/task type. Record the reference now and verify its
-- legality when analyzing the contract of the variable
@ -7524,14 +7544,13 @@ package body Sem_Res is
------------------------
procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is
Entry_Name : constant Node_Id := Name (N);
Loc : constant Source_Ptr := Sloc (Entry_Name);
Actuals : List_Id;
First_Named : Node_Id;
Nam : Entity_Id;
Norm_OK : Boolean;
Obj : Node_Id;
Was_Over : Boolean;
Entry_Name : constant Node_Id := Name (N);
Loc : constant Source_Ptr := Sloc (Entry_Name);
Nam : Entity_Id;
Norm_OK : Boolean;
Obj : Node_Id;
Was_Over : Boolean;
begin
-- We kill all checks here, because it does not seem worth the effort to
@ -7645,7 +7664,6 @@ package body Sem_Res is
and then Present (Contract_Wrapper (Nam))
and then Current_Scope /= Contract_Wrapper (Nam)
then
-- Note the entity being called before rewriting the call, so that
-- it appears used at this point.
@ -7760,16 +7778,29 @@ package body Sem_Res is
Entry_Name);
end if;
Actuals := Parameter_Associations (N);
First_Named := First_Named_Actual (N);
declare
Entry_Call : Node_Id;
Rewrite (N,
Make_Entry_Call_Statement (Loc,
Name => Entry_Name,
Parameter_Associations => Actuals));
begin
Entry_Call :=
Make_Entry_Call_Statement (Loc,
Name => Entry_Name,
Parameter_Associations => Parameter_Associations (N));
Set_First_Named_Actual (N, First_Named);
Set_Analyzed (N, True);
-- Inherit relevant attributes from the original call
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.

1
gcc/ada/sem_spark.adb
View File

@ -2314,6 +2314,7 @@ package body Sem_SPARK is
when N_Abstract_Subprogram_Declaration
| N_At_Clause
| N_Attribute_Definition_Clause
| N_Call_Marker
| N_Delta_Constraint
| N_Digits_Constraint
| N_Empty

1038
gcc/ada/sem_util.adb
View File

File diff suppressed because it is too large Load Diff

125
gcc/ada/sem_util.ads
View File

@ -202,6 +202,10 @@ package Sem_Util is
-- given, and the reference N is not in the same extended source unit as
-- the declaration of T.
function Begin_Keyword_Location (N : Node_Id) return Source_Ptr;
-- Given block statement, entry body, package body, subprogram body, or
-- task body N, return the closest source location to the "begin" keyword.
function Build_Actual_Subtype
(T : Entity_Id;
N : Node_Or_Entity_Id) return Node_Id;
@ -547,8 +551,9 @@ package Sem_Util is
-- instead of 0).
function Defining_Entity
(N : Node_Id;
Empty_On_Errors : Boolean := False) return Entity_Id;
(N : Node_Id;
Empty_On_Errors : Boolean := False;
Concurrent_Subunit : Boolean := False) return Entity_Id;
-- Given a declaration N, returns the associated defining entity. If the
-- declaration has a specification, the entity is obtained from the
-- specification. If the declaration has a defining unit name, then the
@ -572,6 +577,9 @@ package Sem_Util is
--
-- The former semantics is appropriate for the back end; the latter
-- semantics is appropriate for the front end.
--
-- Set flag Concurrent_Subunit to handle rewritings of concurrent bodies
-- which act as subunits. Such bodies are generally rewritten as null.
function Denotes_Discriminant
(N : Node_Id;
@ -685,6 +693,12 @@ package Sem_Util is
-- Utility function to return the Ada entity of the subprogram enclosing
-- the entity E, if any. Returns Empty if no enclosing subprogram.
function End_Keyword_Location (N : Node_Id) return Source_Ptr;
-- Given block statement, entry body, package body, package declaration,
-- protected body, [single] protected type declaration, subprogram body,
-- task body, or [single] task type declaration N, return the closest
-- source location of the "end" keyword.
procedure Ensure_Freeze_Node (E : Entity_Id);
-- Make sure a freeze node is allocated for entity E. If necessary, build
-- and initialize a new freeze node and set Has_Delayed_Freeze True for E.
@ -740,12 +754,6 @@ package Sem_Util is
-- Call is set to the node for the corresponding call. If the node N is not
-- an actual parameter then Formal and Call are set to Empty.
function Find_Specific_Type (CW : Entity_Id) return Entity_Id;
-- Find specific type of a class-wide type, and handle the case of an
-- incomplete type coming either from a limited_with clause or from an
-- incomplete type declaration. If resulting type is private return its
-- full view.
function Find_Body_Discriminal
(Spec_Discriminant : Entity_Id) return Entity_Id;
-- Given a discriminant of the record type that implements a task or
@ -762,9 +770,12 @@ package Sem_Util is
-- discriminant at the same position in this new type.
function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id;
-- Given an arbitrary entity, try to find the nearest enclosing iterator
-- loop. If such a loop is found, return the entity of its identifier (the
-- E_Loop scope), otherwise return Empty.
-- Find the nearest iterator loop which encloses arbitrary entity Id. If
-- such a loop exists, return the entity of its identifier (E_Loop scope),
-- otherwise return Empty.
function Find_Enclosing_Scope (N : Node_Id) return Entity_Id;
-- Find the nearest scope which encloses arbitrary node N
function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id;
-- Find the nested loop statement in a conditional block. Loops subject to
@ -868,6 +879,12 @@ package Sem_Util is
-- If the state space is that of a package, Pack_Id denotes its entity,
-- otherwise Pack_Id is Empty.
function Find_Specific_Type (CW : Entity_Id) return Entity_Id;
-- Find specific type of a class-wide type, and handle the case of an
-- incomplete type coming either from a limited_with clause or from an
-- incomplete type declaration. If resulting type is private return its
-- full view.
function Find_Static_Alternative (N : Node_Id) return Node_Id;
-- N is a case statement whose expression is a compile-time value.
-- Determine the alternative chosen, so that the code of non-selected
@ -1134,8 +1151,7 @@ package Sem_Util is
-- subprogram or entry and returns it, or if no subprogram can be found,
-- returns Empty.
function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id;
pragma Inline (Get_Task_Body_Procedure);
function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id;
-- Given an entity for a task type or subtype, retrieves the
-- Task_Body_Procedure field from the corresponding task type declaration.
@ -1259,14 +1275,14 @@ package Sem_Util is
-- as expressed in pragma Refined_State. This function does not take into
-- account the visible refinement region of abstract state Id.
function Has_Null_Body (Proc_Id : Entity_Id) return Boolean;
-- Determine whether the body of procedure Proc_Id contains a sole
-- null statement, possibly followed by an optional return. Used to
-- optimize useless calls to assertion checks.
function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean;
-- Determine whether subprogram Subp has a class-wide precondition that is
-- not statically True.
function Has_Non_Trivial_Precondition (P : Entity_Id) return Boolean;
-- True if subprogram has a class-wide precondition that is not
-- statically True.
function Has_Null_Body (Proc_Id : Entity_Id) return Boolean;
-- Determine whether the body of procedure Proc_Id contains a sole null
-- statement, possibly followed by an optional return. Used to optimize
-- useless calls to assertion checks.
function Has_Null_Exclusion (N : Node_Id) return Boolean;
-- Determine whether node N has a null exclusion
@ -1357,9 +1373,10 @@ package Sem_Util is
-- Returns True if current scope is with the private part or the body of
-- an instance. Other semantic checks are suppressed in this context.
function In_Instance_Visible_Part return Boolean;
-- Returns True if current scope is within the visible part of a package
-- instance, where several additional semantic checks apply.
function In_Instance_Visible_Part
(Id : Entity_Id := Current_Scope) return Boolean;
-- Returns True if arbitrary entity Id is within the visible part of a
-- package instance, where several additional semantic checks apply.
function In_Package_Body return Boolean;
-- Returns True if current scope is within a package body
@ -1382,9 +1399,17 @@ package Sem_Util is
-- appearing anywhere within such a construct (that is it does not need
-- to be directly within).
function In_Subtree (Root : Node_Id; N : Node_Id) return Boolean;
function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean;
-- Determine whether node N is within the subtree rooted at Root
function In_Subtree
(N : Node_Id;
Root1 : Node_Id;
Root2 : Node_Id) return Boolean;
-- Determine whether node N is within the subtree rooted at Root1 or Root2.
-- This version is more efficient than calling the single root version of
-- Is_Subtree twice.
function In_Visible_Part (Scope_Id : Entity_Id) return Boolean;
-- Determine whether a declaration occurs within the visible part of a
-- package specification. The package must be on the scope stack, and the
@ -1765,6 +1790,14 @@ package Sem_Util is
-- persistent. A private type is potentially persistent if the full type
-- is potentially persistent.
function Is_Preelaborable_Aggregate (Aggr : Node_Id) return Boolean;
-- Determine whether aggregate Aggr violates the restrictions of
-- preelaborable constructs as defined in ARM 10.2.1(5-9).
function Is_Preelaborable_Construct (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N violates the restrictions of
-- preelaborable constructs as defined in ARM 10.2.1(5-9).
function Is_Protected_Self_Reference (N : Node_Id) return Boolean;
-- Return True if node N denotes a protected type name which represents
-- the current instance of a protected object according to RM 9.4(21/2).
@ -2028,6 +2061,24 @@ package Sem_Util is
-- statement in Statements (HSS) that has Comes_From_Source set. If no
-- such statement exists, Empty is returned.
procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id);
-- Given a node which designates the context of analysis and an origin in
-- the tree, traverse from Root_Nod and mark all allocators as either
-- dynamic or static depending on Context_Nod. Any incorrect marking is
-- cleaned up during resolution.
procedure Mark_Elaboration_Attributes
(N_Id : Node_Or_Entity_Id;
Checks : Boolean := False;
Level : Boolean := False;
Modes : Boolean := False);
-- Preserve relevant elaboration-related properties of the context in
-- arbitrary entity or node N_Id. When flag Checks is set, the routine
-- saves the status of Elaboration_Check. When flag Level is set, the
-- routine captures the declaration level of N_Id if applicable. When
-- flag Modes is set, the routine saves the Ghost and SPARK modes in
-- effect if applicable.
function Matching_Static_Array_Bounds
(L_Typ : Node_Id;
R_Typ : Node_Id) return Boolean;
@ -2035,12 +2086,6 @@ package Sem_Util is
-- same number of dimensions, and the same static bounds for each index
-- position.
procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id);
-- Given a node which designates the context of analysis and an origin in
-- the tree, traverse from Root_Nod and mark all allocators as either
-- dynamic or static depending on Context_Nod. Any incorrect marking is
-- cleaned up during resolution.
function May_Be_Lvalue (N : Node_Id) return Boolean;
-- Determines if N could be an lvalue (e.g. an assignment left hand side).
-- An lvalue is defined as any expression which appears in a context where
@ -2460,15 +2505,19 @@ package Sem_Util is
-- this is the case, and False if no scalar parts are present (meaning that
-- the result of Valid_Scalars applied to T is always vacuously True).
function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean;
-- Determines if the entity Scope1 is the same as Scope2, or if it is
-- inside it, where both entities represent scopes. Note that scopes
-- are only partially ordered, so Scope_Within_Or_Same (A,B) and
-- Scope_Within_Or_Same (B,A) can both be False for a given pair A,B.
function Scope_Within
(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 (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_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.

29
gcc/ada/sem_warn.adb
View File

@ -248,6 +248,10 @@ package body Sem_Warn is
-- If so, Ref is set to point to the reference node, and Var is set to
-- the referenced Entity.
function Has_Condition_Actions (Iter : Node_Id) return Boolean;
-- Determine whether iteration scheme Iter has meaningful condition
-- actions.
function Has_Indirection (T : Entity_Id) return Boolean;
-- If the controlling variable is an access type, or is a record type
-- with access components, assume that it is changed indirectly and
@ -360,6 +364,29 @@ package body Sem_Warn is
end if;
end Find_Var;
---------------------------
-- Has_Condition_Actions --
---------------------------
function Has_Condition_Actions (Iter : Node_Id) return Boolean is
Action : Node_Id;
begin
-- A call marker is not considered a meaningful action because it
-- acts as an annotation and has no runtime semantics.
Action := First (Condition_Actions (Iter));
while Present (Action) loop
if Nkind (Action) /= N_Call_Marker then
return True;
end if;
Next (Action);
end loop;
return False;
end Has_Condition_Actions;
---------------------
-- Has_Indirection --
---------------------
@ -597,7 +624,7 @@ package body Sem_Warn is
-- Skip processing for while iteration with conditions actions,
-- since they make it too complicated to get the warning right.
if Present (Condition_Actions (Iter)) then
if Has_Condition_Actions (Iter) then
return;
end if;

292
gcc/ada/sinfo.adb
View File

@ -61,19 +61,6 @@ package body Sinfo is
-- uniform format of the conditions following this. Note that csinfo
-- expects this uniform format.
function ABE_Is_Certain
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Formal_Package_Declaration
or else NT (N).Nkind = N_Function_Call
or else NT (N).Nkind = N_Function_Instantiation
or else NT (N).Nkind = N_Package_Instantiation
or else NT (N).Nkind = N_Procedure_Call_Statement
or else NT (N).Nkind = N_Procedure_Instantiation);
return Flag18 (N);
end ABE_Is_Certain;
function Abort_Present
(N : Node_Id) return Boolean is
begin
@ -439,7 +426,7 @@ package body Sinfo is
end Classifications;
function Cleanup_Actions
(N : Node_Id) return List_Id is
(N : Node_Id) return List_Id is
begin
pragma Assert (False
or else NT (N).Nkind = N_Block_Statement);
@ -447,7 +434,7 @@ package body Sinfo is
end Cleanup_Actions;
function Comes_From_Extended_Return_Statement
(N : Node_Id) return Boolean is
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Simple_Return_Statement);
@ -951,7 +938,7 @@ package body Sinfo is
or else NT (N).Nkind = N_Assignment_Statement
or else NT (N).Nkind = N_Selected_Component
or else NT (N).Nkind = N_Type_Conversion);
return Flag1 (N);
return Flag3 (N);
end Do_Discriminant_Check;
function Do_Division_Check
@ -1856,14 +1843,16 @@ package body Sinfo is
return Flag16 (N);
end Is_Controlling_Actual;
function Is_Disabled
function Is_Declaration_Level_Node
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_Pragma);
return Flag15 (N);
end Is_Disabled;
or else NT (N).Nkind = N_Call_Marker
or else NT (N).Nkind = N_Function_Instantiation
or else NT (N).Nkind = N_Package_Instantiation
or else NT (N).Nkind = N_Procedure_Instantiation);
return Flag5 (N);
end Is_Declaration_Level_Node;
function Is_Delayed_Aspect
(N : Node_Id) return Boolean is
@ -1875,6 +1864,23 @@ package body Sinfo is
return Flag14 (N);
end Is_Delayed_Aspect;
function Is_Disabled
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_Pragma);
return Flag15 (N);
end Is_Disabled;
function Is_Dispatching_Call
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Call_Marker);
return Flag3 (N);
end Is_Dispatching_Call;
function Is_Dynamic_Coextension
(N : Node_Id) return Boolean is
begin
@ -1892,8 +1898,27 @@ package body Sinfo is
return Flag1 (N);
end Is_Effective_Use_Clause;
function Is_Elaboration_Checks_OK_Node
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Assignment_Statement
or else NT (N).Nkind = N_Attribute_Reference
or else NT (N).Nkind = N_Call_Marker
or else NT (N).Nkind = N_Entry_Call_Statement
or else NT (N).Nkind = N_Expanded_Name
or else NT (N).Nkind = N_Function_Call
or else NT (N).Nkind = N_Function_Instantiation
or else NT (N).Nkind = N_Identifier
or else NT (N).Nkind = N_Package_Instantiation
or else NT (N).Nkind = N_Procedure_Call_Statement
or else NT (N).Nkind = N_Procedure_Instantiation
or else NT (N).Nkind = N_Requeue_Statement);
return Flag1 (N);
end Is_Elaboration_Checks_OK_Node;
function Is_Elsif
(N : Node_Id) return Boolean is
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_If_Expression);
@ -1982,6 +2007,25 @@ package body Sinfo is
return Flag4 (N);
end Is_Inherited_Pragma;
function Is_Initialization_Block
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Block_Statement);
return Flag1 (N);
end Is_Initialization_Block;
function Is_Known_Guaranteed_ABE
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Call_Marker
or else NT (N).Nkind = N_Function_Instantiation
or else NT (N).Nkind = N_Package_Instantiation
or else NT (N).Nkind = N_Procedure_Instantiation);
return Flag18 (N);
end Is_Known_Guaranteed_ABE;
function Is_Machine_Number
(N : Node_Id) return Boolean is
begin
@ -2038,6 +2082,44 @@ package body Sinfo is
return Flag4 (N);
end Is_Qualified_Universal_Literal;
function Is_Recorded_Scenario
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Call_Marker
or else NT (N).Nkind = N_Function_Instantiation
or else NT (N).Nkind = N_Package_Instantiation
or else NT (N).Nkind = N_Procedure_Instantiation);
return Flag6 (N);
end Is_Recorded_Scenario;
function Is_Source_Call
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Call_Marker);
return Flag4 (N);
end Is_Source_Call;
function Is_SPARK_Mode_On_Node
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Assignment_Statement
or else NT (N).Nkind = N_Attribute_Reference
or else NT (N).Nkind = N_Call_Marker
or else NT (N).Nkind = N_Entry_Call_Statement
or else NT (N).Nkind = N_Expanded_Name
or else NT (N).Nkind = N_Function_Call
or else NT (N).Nkind = N_Function_Instantiation
or else NT (N).Nkind = N_Identifier
or else NT (N).Nkind = N_Package_Instantiation
or else NT (N).Nkind = N_Procedure_Call_Statement
or else NT (N).Nkind = N_Procedure_Instantiation
or else NT (N).Nkind = N_Requeue_Statement);
return Flag2 (N);
end Is_SPARK_Mode_On_Node;
function Is_Static_Coextension
(N : Node_Id) return Boolean is
begin
@ -2425,15 +2507,6 @@ package body Sinfo is
return Flag7 (N);
end No_Ctrl_Actions;
function No_Elaboration_Check
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Function_Call
or else NT (N).Nkind = N_Procedure_Call_Statement);
return Flag14 (N);
end No_Elaboration_Check;
function No_Entities_Ref_In_Spec
(N : Node_Id) return Boolean is
begin
@ -2465,7 +2538,7 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Function_Call);
return Flag1 (N);
return Flag17 (N);
end No_Side_Effect_Removal;
function No_Truncation
@ -3192,6 +3265,14 @@ package body Sinfo is
return Flag15 (N);
end Tagged_Present;
function Target
(N : Node_Id) return Entity_Id is
begin
pragma Assert (False
or else NT (N).Nkind = N_Call_Marker);
return Node1 (N);
end Target;
function Target_Type
(N : Node_Id) return Entity_Id is
begin
@ -3364,6 +3445,14 @@ package body Sinfo is
return Elist2 (N);
end Used_Operations;
function Was_Attribute_Reference
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Subprogram_Body);
return Flag2 (N);
end Was_Attribute_Reference;
function Was_Expression_Function
(N : Node_Id) return Boolean is
begin
@ -3395,19 +3484,6 @@ package body Sinfo is
-- Field Set Procedures --
--------------------------
procedure Set_ABE_Is_Certain
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Formal_Package_Declaration
or else NT (N).Nkind = N_Function_Call
or else NT (N).Nkind = N_Function_Instantiation
or else NT (N).Nkind = N_Package_Instantiation
or else NT (N).Nkind = N_Procedure_Call_Statement
or else NT (N).Nkind = N_Procedure_Instantiation);
Set_Flag18 (N, Val);
end Set_ABE_Is_Certain;
procedure Set_Abort_Present
(N : Node_Id; Val : Boolean := True) is
begin
@ -4285,7 +4361,7 @@ package body Sinfo is
or else NT (N).Nkind = N_Assignment_Statement
or else NT (N).Nkind = N_Selected_Component
or else NT (N).Nkind = N_Type_Conversion);
Set_Flag1 (N, Val);
Set_Flag3 (N, Val);
end Set_Do_Discriminant_Check;
procedure Set_Do_Division_Check
@ -5181,6 +5257,17 @@ package body Sinfo is
Set_Flag16 (N, Val);
end Set_Is_Controlling_Actual;
procedure Set_Is_Declaration_Level_Node
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Call_Marker
or else NT (N).Nkind = N_Function_Instantiation
or else NT (N).Nkind = N_Package_Instantiation
or else NT (N).Nkind = N_Procedure_Instantiation);
Set_Flag5 (N, Val);
end Set_Is_Declaration_Level_Node;
procedure Set_Is_Delayed_Aspect
(N : Node_Id; Val : Boolean := True) is
begin
@ -5200,6 +5287,14 @@ package body Sinfo is
Set_Flag15 (N, Val);
end Set_Is_Disabled;
procedure Set_Is_Dispatching_Call
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Call_Marker);
Set_Flag3 (N, Val);
end Set_Is_Dispatching_Call;
procedure Set_Is_Dynamic_Coextension
(N : Node_Id; Val : Boolean := True) is
begin
@ -5217,8 +5312,27 @@ package body Sinfo is
Set_Flag1 (N, Val);
end Set_Is_Effective_Use_Clause;
procedure Set_Is_Elaboration_Checks_OK_Node
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Assignment_Statement
or else NT (N).Nkind = N_Attribute_Reference
or else NT (N).Nkind = N_Call_Marker
or else NT (N).Nkind = N_Entry_Call_Statement
or else NT (N).Nkind = N_Expanded_Name
or else NT (N).Nkind = N_Function_Call
or else NT (N).Nkind = N_Function_Instantiation
or else NT (N).Nkind = N_Identifier
or else NT (N).Nkind = N_Package_Instantiation
or else NT (N).Nkind = N_Procedure_Call_Statement
or else NT (N).Nkind = N_Procedure_Instantiation
or else NT (N).Nkind = N_Requeue_Statement);
Set_Flag1 (N, Val);
end Set_Is_Elaboration_Checks_OK_Node;
procedure Set_Is_Elsif
(N : Node_Id; Val : Boolean := True) is
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_If_Expression);
@ -5307,6 +5421,25 @@ package body Sinfo is
Set_Flag4 (N, Val);
end Set_Is_Inherited_Pragma;
procedure Set_Is_Initialization_Block
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Block_Statement);
Set_Flag1 (N, Val);
end Set_Is_Initialization_Block;
procedure Set_Is_Known_Guaranteed_ABE
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Call_Marker
or else NT (N).Nkind = N_Function_Instantiation
or else NT (N).Nkind = N_Package_Instantiation
or else NT (N).Nkind = N_Procedure_Instantiation);
Set_Flag18 (N, Val);
end Set_Is_Known_Guaranteed_ABE;
procedure Set_Is_Machine_Number
(N : Node_Id; Val : Boolean := True) is
begin
@ -5363,6 +5496,44 @@ package body Sinfo is
Set_Flag4 (N, Val);
end Set_Is_Qualified_Universal_Literal;
procedure Set_Is_Recorded_Scenario
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Call_Marker
or else NT (N).Nkind = N_Function_Instantiation
or else NT (N).Nkind = N_Package_Instantiation
or else NT (N).Nkind = N_Procedure_Instantiation);
Set_Flag6 (N, Val);
end Set_Is_Recorded_Scenario;
procedure Set_Is_Source_Call
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Call_Marker);
Set_Flag4 (N, Val);
end Set_Is_Source_Call;
procedure Set_Is_SPARK_Mode_On_Node
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Assignment_Statement
or else NT (N).Nkind = N_Attribute_Reference
or else NT (N).Nkind = N_Call_Marker
or else NT (N).Nkind = N_Entry_Call_Statement
or else NT (N).Nkind = N_Expanded_Name
or else NT (N).Nkind = N_Function_Call
or else NT (N).Nkind = N_Function_Instantiation
or else NT (N).Nkind = N_Identifier
or else NT (N).Nkind = N_Package_Instantiation
or else NT (N).Nkind = N_Procedure_Call_Statement
or else NT (N).Nkind = N_Procedure_Instantiation
or else NT (N).Nkind = N_Requeue_Statement);
Set_Flag2 (N, Val);
end Set_Is_SPARK_Mode_On_Node;
procedure Set_Is_Static_Coextension
(N : Node_Id; Val : Boolean := True) is
begin
@ -5750,15 +5921,6 @@ package body Sinfo is
Set_Flag7 (N, Val);
end Set_No_Ctrl_Actions;
procedure Set_No_Elaboration_Check
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Function_Call
or else NT (N).Nkind = N_Procedure_Call_Statement);
Set_Flag14 (N, Val);
end Set_No_Elaboration_Check;
procedure Set_No_Entities_Ref_In_Spec
(N : Node_Id; Val : Boolean := True) is
begin
@ -5790,7 +5952,7 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Function_Call);
Set_Flag1 (N, Val);
Set_Flag17 (N, Val);
end Set_No_Side_Effect_Removal;
procedure Set_No_Truncation
@ -6517,6 +6679,14 @@ package body Sinfo is
Set_Flag15 (N, Val);
end Set_Tagged_Present;
procedure Set_Target
(N : Node_Id; Val : Entity_Id) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Call_Marker);
Set_Node1 (N, Val); -- semantic field, no parent set
end Set_Target;
procedure Set_Target_Type
(N : Node_Id; Val : Entity_Id) is
begin
@ -6689,6 +6859,14 @@ package body Sinfo is
Set_Elist2 (N, Val);
end Set_Used_Operations;
procedure Set_Was_Attribute_Reference
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Subprogram_Body);
Set_Flag2 (N, Val);
end Set_Was_Attribute_Reference;
procedure Set_Was_Expression_Function
(N : Node_Id; Val : Boolean := True) is
begin

337
gcc/ada/sinfo.ads
View File

@ -845,15 +845,6 @@ package Sinfo is
-- section describes the usage of the semantic fields, which are used to
-- contain additional information determined during semantic analysis.
-- ABE_Is_Certain (Flag18-Sem)
-- This flag is set in an instantiation node or a call node is determined
-- to be sure to raise an ABE. This is used to trigger special handling
-- of such cases, particularly in the instantiation case where we avoid
-- instantiating the body if this flag is set. This flag is also present
-- in an N_Formal_Package_Declaration node since formal package
-- declarations are treated like instantiations, but it is always set to
-- False in this context.
-- Accept_Handler_Records (List5-Sem)
-- This field is present only in an N_Accept_Alternative node. It is used
-- to temporarily hold the exception handler records from an accept
@ -1159,7 +1150,7 @@ package Sinfo is
-- that an accessibility check is required for the parameter. It is
-- not yet decided who takes care of this check (TBD ???).
-- Do_Discriminant_Check (Flag1-Sem)
-- Do_Discriminant_Check (Flag3-Sem)
-- This flag is set on N_Selected_Component nodes to indicate that a
-- discriminant check is required using the discriminant check routine
-- associated with the selector. The actual check is generated by the
@ -1663,10 +1654,6 @@ package Sinfo is
-- place in the various Analyze_xxx_In_Decl_Part routines which perform
-- full analysis. The flag prevents the reanalysis of a delayed pragma.
-- Is_Expanded_Contract (Flag1-Sem)
-- Present in N_Contract nodes. Set if the contract has already undergone
-- expansion activities.
-- Is_Asynchronous_Call_Block (Flag7-Sem)
-- A flag set in a Block_Statement node to indicate that it is the
-- expansion of an asynchronous entry call. Such a block needs cleanup
@ -1701,6 +1688,12 @@ package Sinfo is
-- a dispatching call. It is off in all other cases. See Sem_Disp for
-- details of its use.
-- Is_Declaration_Level_Node (Flag5-Sem)
-- Present in call marker and instantiation nodes. Set when the constuct
-- appears within the declarations of a block statement, an entry body,
-- a subprogram body, or a task body. The flag aids the ABE Processing
-- phase to catch certain forms of guaranteed ABEs.
-- Is_Delayed_Aspect (Flag14-Sem)
-- Present in N_Pragma and N_Attribute_Definition_Clause nodes which
-- come from aspect specifications, where the evaluation of the aspect
@ -1715,6 +1708,10 @@ package Sinfo is
-- If this flag is set, the aspect or policy is not analyzed for semantic
-- correctness, so any expressions etc will not be marked as analyzed.
-- Is_Dispatching_Call (Flag3-Sem)
-- Present in call marker nodes. Set when the related call which prompted
-- the creation of the marker is dispatching.
-- Is_Dynamic_Coextension (Flag18-Sem)
-- Present in allocator nodes, to indicate that this is an allocator
-- for an access discriminant of a dynamically allocated object. The
@ -1725,6 +1722,15 @@ package Sinfo is
-- Present in both N_Use_Type_Clause and N_Use_Package_Clause to indicate
-- a use clause is "used" in the current source.
-- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
-- Present in nodes which represent an elaboration scenario. Those are
-- assignment statement, attribute reference, call marker, entry call
-- statement, expanded name, function call, identifier, instantiation,
-- procedure call statement, and requeue statement nodes. Set when the
-- node appears within a context which allows for the generation of
-- run-time ABE checks. This flag detemines whether the ABE Processing
-- phase generates conditional ABE checks and guaranteed ABE failures.
-- Is_Entry_Barrier_Function (Flag8-Sem)
-- This flag is set on N_Subprogram_Declaration and N_Subprogram_Body
-- nodes which emulate the barrier function of a protected entry body.
@ -1735,6 +1741,10 @@ package Sinfo is
-- actuals to support a build-in-place style of call have been added to
-- the call.
-- Is_Expanded_Contract (Flag1-Sem)
-- Present in N_Contract nodes. Set if the contract has already undergone
-- expansion activities.
-- Is_Finalization_Wrapper (Flag9-Sem)
-- This flag is present in N_Block_Statement nodes. It is set when the
-- block acts as a wrapper of a handled construct which has controlled
@ -1794,6 +1804,19 @@ package Sinfo is
-- This flag is set in an N_Pragma node that appears in a N_Contract node
-- to indicate that the pragma has been inherited from a parent context.
-- Is_Initialization_Block (Flag1-Sem)
-- Defined in block nodes. Set when the block statement was created by
-- the finalization machinery to wrap initialization statements. This
-- flag aids the ABE Processing phase to suppress the diagnostics of
-- finalization actions in initialization contexts.
-- Is_Known_Guaranteed_ABE (Flag18-Sem)
-- Present in call markers and instantiations. Set when the elaboration
-- or evaluation of the scenario results in a guaranteed ABE. The flag
-- is used to suppress the instantiation of generic bodies because gigi
-- cannot handle certain forms of premature instantiation, as well as to
-- prevent the reexamination of the node by the ABE Processing phase.
-- Is_Machine_Number (Flag11-Sem)
-- This flag is set in an N_Real_Literal node to indicate that the value
-- is a machine number. This avoids some unnecessary cases of converting
@ -1839,6 +1862,25 @@ package Sinfo is
-- the resolution of accidental overloading of binary or unary operators
-- which may occur in instances.
-- Is_Recorded_Scenario (Flag6-Sem)
-- Present in call marker and instantiation nodes. Set when the scenario
-- was saved by the ABE Recording phase. This flag aids the ABE machinery
-- to keep its internal data up-to-date in case the node is transformed
-- by Atree.Rewrite.
-- Is_Source_Call (Flag4-Sem)
-- Present in call marker nodes. Set when the related call came from
-- source.
-- Is_SPARK_Mode_On_Node (Flag2-Sem)
-- Present in nodes which represent an elaboration scenario. Those are
-- assignment statement, attribute reference, call marker, entry call
-- statement, expanded name, function call, identifier, instantiation,
-- procedure call statement, and requeue statement nodes. Set when the
-- node appears within a context subject to SPARK_Mode On. This flag
-- determines when the SPARK model of elaboration be activated by the
-- ABE Processing phase.
-- Is_Static_Coextension (Flag14-Sem)
-- Present in N_Allocator nodes. Set if the allocator is a coextension
-- of an object allocated on the stack rather than the heap.
@ -2040,13 +2082,6 @@ package Sinfo is
-- expansions where the generated assignments are initializations, not
-- real assignments.
-- No_Elaboration_Check (Flag14-Sem)
-- Present in N_Function_Call and N_Procedure_Call_Statement. Indicates
-- that no elaboration check is needed on the call, because it appears in
-- the context of a local Suppress pragma. This is used on calls within
-- task bodies, where the actual elaboration checks are applied after
-- analysis, when the local scope stack is not present.
-- No_Entities_Ref_In_Spec (Flag8-Sem)
-- Present in N_With_Clause nodes. Set if the with clause is on the
-- package or subprogram spec where the main unit is the corresponding
@ -2069,7 +2104,7 @@ package Sinfo is
-- It is used to indicate that processing for extended overflow checking
-- modes is not required (this is used to prevent infinite recursion).
-- No_Side_Effect_Removal (Flag1-Sem)
-- No_Side_Effect_Removal (Flag17-Sem)
-- Present in N_Function_Call nodes. Set when a function call does not
-- require side effect removal. This attribute suppresses the generation
-- of a temporary to capture the result of the function which eventually
@ -2281,6 +2316,10 @@ package Sinfo is
-- of a FOR loop is known to be null, or is probably null (loop would
-- only execute if invalid values are present).
-- Target (Node1-Sem)
-- Present in call marker nodes. References the entity of the entry,
-- operator, or subprogram invoked by the related call or requeue.
-- Target_Type (Node2-Sem)
-- Used in an N_Validate_Unchecked_Conversion node to point to the target
-- type entity for the unchecked conversion instantiation which gigi must
@ -2353,6 +2392,12 @@ package Sinfo is
-- on exit from the scope of the use_type_clause, in particular in the
-- case of Use_All_Type, when those operations several scopes.
-- Was_Attribute_Reference (Flag2-Sem)
-- Present in N_Subprogram_Body. Set to True if the original source is an
-- attribute reference which is an actual in a generic instantiation. The
-- instantiation prologue renames these attributes, and expansion later
-- converts them into subprogram bodies.
-- Was_Expression_Function (Flag18-Sem)
-- Present in N_Subprogram_Body. True if the original source had an
-- N_Expression_Function, which was converted to the N_Subprogram_Body
@ -2478,9 +2523,11 @@ package Sinfo is
-- Entity (Node4-Sem)
-- Associated_Node (Node4-Sem)
-- Original_Discriminant (Node2-Sem)
-- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
-- Is_SPARK_Mode_On_Node (Flag2-Sem)
-- Has_Private_View (Flag11-Sem) (set in generic units)
-- Redundant_Use (Flag13-Sem)
-- Atomic_Sync_Required (Flag14-Sem)
-- Has_Private_View (Flag11-Sem) (set in generic units)
-- plus fields for expression
--------------------------
@ -2625,20 +2672,20 @@ package Sinfo is
-- Corresponding_Aspect (Node3-Sem) (set to Empty if not present)
-- Pragma_Identifier (Node4)
-- Next_Rep_Item (Node5-Sem)
-- Class_Present (Flag6) set if from Aspect with 'Class
-- From_Aspect_Specification (Flag13-Sem)
-- Import_Interface_Present (Flag16-Sem)
-- Is_Analyzed_Pragma (Flag5-Sem)
-- Is_Checked (Flag11-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)
-- From_Aspect_Specification (Flag13-Sem)
-- Is_Delayed_Aspect (Flag14-Sem)
-- Is_Disabled (Flag15-Sem)
-- Is_Generic_Contract_Pragma (Flag2-Sem)
-- Is_Ignored (Flag9-Sem)
-- Is_Ignored_Ghost_Pragma (Flag8-Sem)
-- Is_Inherited_Pragma (Flag4-Sem)
-- Import_Interface_Present (Flag16-Sem)
-- Split_PPC (Flag17) set if corresponding aspect had Split_PPC set
-- Uneval_Old_Accept (Flag7-Sem)
-- Uneval_Old_Warn (Flag18-Sem)
-- Note: we should have a section on what pragmas are passed on to
@ -3780,8 +3827,8 @@ package Sinfo is
-- Sloc points to ALL
-- Prefix (Node3)
-- Actual_Designated_Subtype (Node4-Sem)
-- Atomic_Sync_Required (Flag14-Sem)
-- Has_Dereference_Action (Flag13-Sem)
-- Atomic_Sync_Required (Flag14-Sem)
-- plus fields for expression
-------------------------------
@ -3847,10 +3894,10 @@ package Sinfo is
-- Prefix (Node3)
-- Selector_Name (Node2)
-- Associated_Node (Node4-Sem)
-- Do_Discriminant_Check (Flag1-Sem)
-- Do_Discriminant_Check (Flag3-Sem)
-- Is_In_Discriminant_Check (Flag11-Sem)
-- Is_Prefixed_Call (Flag17-Sem)
-- Atomic_Sync_Required (Flag14-Sem)
-- Is_Prefixed_Call (Flag17-Sem)
-- plus fields for expression
--------------------------
@ -3943,10 +3990,11 @@ package Sinfo is
-- Expressions (List1) (set to No_List if no associated expressions)
-- Entity (Node4-Sem) used if the attribute yields a type
-- Associated_Node (Node4-Sem)
-- Do_Overflow_Check (Flag17-Sem)
-- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
-- Is_SPARK_Mode_On_Node (Flag2-Sem)
-- Header_Size_Added (Flag11-Sem)
-- Must_Be_Byte_Aligned (Flag14-Sem)
-- Redundant_Use (Flag13-Sem)
-- Must_Be_Byte_Aligned (Flag14-Sem)
-- plus fields for expression
-- Note: in Modify_Tree_For_C mode, Max and Min attributes are expanded
@ -4137,7 +4185,7 @@ package Sinfo is
----------------------------------
-- NAMED_ARRAY_AGGREGATE ::=
-- | (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})
-- (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})
-- See Record_Aggregate (4.3.1) for node structure
@ -4674,7 +4722,7 @@ package Sinfo is
-- Sloc points to first token of subtype mark
-- Subtype_Mark (Node4)
-- Expression (Node3)
-- Do_Discriminant_Check (Flag1-Sem)
-- Do_Discriminant_Check (Flag3-Sem)
-- Do_Length_Check (Flag4-Sem)
-- Float_Truncate (Flag11-Sem)
-- Do_Tag_Check (Flag13-Sem)
@ -4839,13 +4887,15 @@ package Sinfo is
-- Sloc points to :=
-- Name (Node2)
-- Expression (Node3)
-- Do_Discriminant_Check (Flag1-Sem)
-- Do_Tag_Check (Flag13-Sem)
-- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
-- Is_SPARK_Mode_On_Node (Flag2-Sem)
-- Do_Discriminant_Check (Flag3-Sem)
-- Do_Length_Check (Flag4-Sem)
-- Forwards_OK (Flag5-Sem)
-- Backwards_OK (Flag6-Sem)
-- No_Ctrl_Actions (Flag7-Sem)
-- Has_Target_Names (Flag8-Sem)
-- Do_Tag_Check (Flag13-Sem)
-- Componentwise_Assignment (Flag14-Sem)
-- Suppress_Assignment_Checks (Flag18-Sem)
@ -5101,15 +5151,16 @@ package Sinfo is
-- Identifier (Node1) block direct name (set to Empty if not present)
-- Declarations (List2) (set to No_List if no DECLARE part)
-- Handled_Statement_Sequence (Node4)
-- Cleanup_Actions (List5-Sem)
-- Is_Abort_Block (Flag4-Sem)
-- Is_Task_Master (Flag5-Sem)
-- Activation_Chain_Entity (Node3-Sem)
-- Cleanup_Actions (List5-Sem)
-- Has_Created_Identifier (Flag15)
-- Is_Task_Allocation_Block (Flag6)
-- Is_Asynchronous_Call_Block (Flag7)
-- Is_Task_Allocation_Block (Flag6)
-- Exception_Junk (Flag8-Sem)
-- Is_Abort_Block (Flag4-Sem)
-- Is_Finalization_Wrapper (Flag9-Sem)
-- Is_Initialization_Block (Flag1-Sem)
-- Is_Task_Master (Flag5-Sem)
-------------------------
-- 5.7 Exit Statement --
@ -5273,8 +5324,8 @@ package Sinfo is
-- symbol turns out to be a normal string after all.
-- Entity (Node4-Sem)
-- Associated_Node (Node4-Sem)
-- Has_Private_View (Flag11-Sem) set in generic units.
-- Etype (Node5-Sem)
-- Has_Private_View (Flag11-Sem) set in generic units
-- Note: the Strval field may be set to No_String for generated
-- operator symbols that are known not to be string literals
@ -5399,6 +5450,7 @@ package Sinfo is
-- Is_Protected_Subprogram_Body (Flag7-Sem)
-- Is_Task_Body_Procedure (Flag1-Sem)
-- Is_Task_Master (Flag5-Sem)
-- Was_Attribute_Reference (Flag2-Sem)
-- Was_Expression_Function (Flag18-Sem)
-- Was_Originally_Stub (Flag13-Sem)
@ -5422,9 +5474,9 @@ package Sinfo is
-- actual parameter part)
-- First_Named_Actual (Node4-Sem)
-- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
-- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
-- Is_SPARK_Mode_On_Node (Flag2-Sem)
-- Do_Tag_Check (Flag13-Sem)
-- No_Elaboration_Check (Flag14-Sem)
-- ABE_Is_Certain (Flag18-Sem)
-- plus fields for expression
-- If any IN parameter requires a range check, then the corresponding
@ -5452,11 +5504,11 @@ package Sinfo is
-- actual parameter part)
-- First_Named_Actual (Node4-Sem)
-- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
-- No_Side_Effect_Removal (Flag1-Sem)
-- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
-- Is_SPARK_Mode_On_Node (Flag2-Sem)
-- Is_Expanded_Build_In_Place_Call (Flag11-Sem)
-- Do_Tag_Check (Flag13-Sem)
-- No_Elaboration_Check (Flag14-Sem)
-- ABE_Is_Certain (Flag18-Sem)
-- No_Side_Effect_Removal (Flag17-Sem)
-- plus fields for expression
--------------------------------
@ -6165,6 +6217,8 @@ package Sinfo is
-- Parameter_Associations (List3) (set to No_List if no
-- actual parameter part)
-- First_Named_Actual (Node4-Sem)
-- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
-- Is_SPARK_Mode_On_Node (Flag2-Sem)
------------------------------
-- 9.5.4 Requeue Statement --
@ -6180,6 +6234,8 @@ package Sinfo is
-- Sloc points to REQUEUE
-- Name (Node2)
-- Abort_Present (Flag15)
-- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
-- Is_SPARK_Mode_On_Node (Flag2-Sem)
--------------------------
-- 9.6 Delay Statement --
@ -6975,7 +7031,11 @@ package Sinfo is
-- generic actual part)
-- Parent_Spec (Node4-Sem)
-- Instance_Spec (Node5-Sem)
-- ABE_Is_Certain (Flag18-Sem)
-- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
-- Is_SPARK_Mode_On_Node (Flag2-Sem)
-- Is_Declaration_Level_Node (Flag5-Sem)
-- Is_Recorded_Scenario (Flag6-Sem)
-- Is_Known_Guaranteed_ABE (Flag18-Sem)
-- N_Procedure_Instantiation
-- Sloc points to PROCEDURE
@ -6985,9 +7045,13 @@ package Sinfo is
-- Generic_Associations (List3) (set to No_List if no
-- generic actual part)
-- Instance_Spec (Node5-Sem)
-- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
-- Is_SPARK_Mode_On_Node (Flag2-Sem)
-- Is_Declaration_Level_Node (Flag5-Sem)
-- Is_Recorded_Scenario (Flag6-Sem)
-- Must_Override (Flag14) set if overriding indicator present
-- Must_Not_Override (Flag15) set if not_overriding indicator present
-- ABE_Is_Certain (Flag18-Sem)
-- Is_Known_Guaranteed_ABE (Flag18-Sem)
-- N_Function_Instantiation
-- Sloc points to FUNCTION
@ -6997,9 +7061,13 @@ package Sinfo is
-- generic actual part)
-- Parent_Spec (Node4-Sem)
-- Instance_Spec (Node5-Sem)
-- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
-- Is_SPARK_Mode_On_Node (Flag2-Sem)
-- Is_Declaration_Level_Node (Flag5-Sem)
-- Is_Recorded_Scenario (Flag6-Sem)
-- Must_Override (Flag14) set if overriding indicator present
-- Must_Not_Override (Flag15) set if not_overriding indicator present
-- ABE_Is_Certain (Flag18-Sem)
-- Is_Known_Guaranteed_ABE (Flag18-Sem)
-- Note: overriding indicator is an Ada 2005 feature
@ -7312,7 +7380,6 @@ package Sinfo is
-- empty generic actual part)
-- Box_Present (Flag15)
-- Instance_Spec (Node5-Sem)
-- ABE_Is_Certain (Flag18-Sem)
--------------------------------------
-- 12.7 Formal Package Actual Part --
@ -7722,6 +7789,42 @@ package Sinfo is
-- reconstructed tree printed by Sprint, and the node descriptions here
-- show this syntax.
-----------------
-- Call_Marker --
-----------------
-- This node is created during the analysis/resolution of entry calls,
-- requeues, and subprogram calls. It performs several functions:
-- * Call markers provide a uniform model for handling calls by the
-- ABE mechanism, regardless of whether expansion took place.
-- * The call marker captures the target of the related call along
-- with other attributes which are either unavailabe or expensive
-- to recompute once analysis, resolution, and expansion are over.
-- * The call marker aids the ABE Processing phase by signaling the
-- presence of a call in case the original call was transformed by
-- expansion.
-- * The call marker acts as a reference point for the insertion of
-- run-time conditional ABE checks or guaranteed ABE failures.
-- Sprint syntax: #target#
-- The Sprint syntax shown above is not enabled by default
-- N_Call_Marker
-- Sloc points to Sloc of original call
-- Target (Node1-Sem)
-- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
-- Is_SPARK_Mode_On_Node (Flag2-Sem)
-- Is_Dispatching_Call (Flag3-Sem)
-- Is_Source_Call (Flag4-Sem)
-- Is_Declaration_Level_Node (Flag5-Sem)
-- Is_Recorded_Scenario (Flag6-Sem)
-- Is_Known_Guaranteed_ABE (Flag18-Sem)
------------------------
-- Compound Statement --
------------------------
@ -7851,7 +7954,9 @@ package Sinfo is
-- Selector_Name (Node2)
-- Entity (Node4-Sem)
-- Associated_Node (Node4-Sem)
-- Has_Private_View (Flag11-Sem) set in generic units.
-- Is_Elaboration_Checks_OK_Node (Flag1-Sem)
-- Is_SPARK_Mode_On_Node (Flag2-Sem)
-- Has_Private_View (Flag11-Sem) set in generic units
-- Redundant_Use (Flag13-Sem)
-- Atomic_Sync_Required (Flag14-Sem)
-- plus fields for expression
@ -8352,8 +8457,8 @@ package Sinfo is
-- Empty --
-----------
-- Used as the contents of the Nkind field of the dummy Empty node
-- and in some other situations to indicate an uninitialized value.
-- Used as the contents of the Nkind field of the dummy Empty node and in
-- some other situations to indicate an uninitialized value.
-- N_Empty
-- Chars (Name1) is set to No_Name
@ -8709,6 +8814,7 @@ package Sinfo is
N_Access_Definition,
N_Access_To_Object_Definition,
N_Aspect_Specification,
N_Call_Marker,
N_Case_Expression_Alternative,
N_Case_Statement_Alternative,
N_Compilation_Unit,
@ -8977,9 +9083,6 @@ package Sinfo is
-- these routines check that they are being applied to an appropriate
-- node, as well as checking that the node is in range.
function ABE_Is_Certain
(N : Node_Id) return Boolean; -- Flag18
function Abort_Present
(N : Node_Id) return Boolean; -- Flag15
@ -9251,7 +9354,7 @@ package Sinfo is
(N : Node_Id) return Boolean; -- Flag13
function Do_Discriminant_Check
(N : Node_Id) return Boolean; -- Flag1
(N : Node_Id) return Boolean; -- Flag3
function Do_Division_Check
(N : Node_Id) return Boolean; -- Flag13
@ -9544,18 +9647,27 @@ package Sinfo is
function Is_Controlling_Actual
(N : Node_Id) return Boolean; -- Flag16
function Is_Declaration_Level_Node
(N : Node_Id) return Boolean; -- Flag5
function Is_Delayed_Aspect
(N : Node_Id) return Boolean; -- Flag14
function Is_Disabled
(N : Node_Id) return Boolean; -- Flag15
function Is_Dispatching_Call
(N : Node_Id) return Boolean; -- Flag3
function Is_Dynamic_Coextension
(N : Node_Id) return Boolean; -- Flag18
function Is_Effective_Use_Clause
(N : Node_Id) return Boolean; -- Flag1
function Is_Elaboration_Checks_OK_Node
(N : Node_Id) return Boolean; -- Flag1
function Is_Elsif
(N : Node_Id) return Boolean; -- Flag13
@ -9589,6 +9701,12 @@ package Sinfo is
function Is_Inherited_Pragma
(N : Node_Id) return Boolean; -- Flag4
function Is_Initialization_Block
(N : Node_Id) return Boolean; -- Flag1
function Is_Known_Guaranteed_ABE
(N : Node_Id) return Boolean; -- Flag18
function Is_Machine_Number
(N : Node_Id) return Boolean; -- Flag11
@ -9610,6 +9728,15 @@ package Sinfo is
function Is_Qualified_Universal_Literal
(N : Node_Id) return Boolean; -- Flag4
function Is_Recorded_Scenario
(N : Node_Id) return Boolean; -- Flag6
function Is_Source_Call
(N : Node_Id) return Boolean; -- Flag4
function Is_SPARK_Mode_On_Node
(N : Node_Id) return Boolean; -- Flag2
function Is_Static_Coextension
(N : Node_Id) return Boolean; -- Flag14
@ -9727,9 +9854,6 @@ package Sinfo is
function No_Ctrl_Actions
(N : Node_Id) return Boolean; -- Flag7
function No_Elaboration_Check
(N : Node_Id) return Boolean; -- Flag14
function No_Entities_Ref_In_Spec
(N : Node_Id) return Boolean; -- Flag8
@ -9740,7 +9864,7 @@ package Sinfo is
(N : Node_Id) return Boolean; -- Flag17
function No_Side_Effect_Removal
(N : Node_Id) return Boolean; -- Flag1
(N : Node_Id) return Boolean; -- Flag17
function No_Truncation
(N : Node_Id) return Boolean; -- Flag17
@ -9961,6 +10085,9 @@ package Sinfo is
function Tagged_Present
(N : Node_Id) return Boolean; -- Flag15
function Target
(N : Node_Id) return Entity_Id; -- Node1
function Target_Type
(N : Node_Id) return Entity_Id; -- Node2
@ -10021,6 +10148,9 @@ package Sinfo is
function Used_Operations
(N : Node_Id) return Elist_Id; -- Elist2
function Was_Attribute_Reference
(N : Node_Id) return Boolean; -- Flag2
function Was_Expression_Function
(N : Node_Id) return Boolean; -- Flag18
@ -10042,9 +10172,6 @@ package Sinfo is
-- tree pointers (List1-4), the parent pointer of the Val node is set to
-- point back to node N. This automates the setting of the parent pointer.
procedure Set_ABE_Is_Certain
(N : Node_Id; Val : Boolean := True); -- Flag18
procedure Set_Abort_Present
(N : Node_Id; Val : Boolean := True); -- Flag15
@ -10316,7 +10443,7 @@ package Sinfo is
(N : Node_Id; Val : Boolean := True); -- Flag13
procedure Set_Do_Discriminant_Check
(N : Node_Id; Val : Boolean := True); -- Flag1
(N : Node_Id; Val : Boolean := True); -- Flag3
procedure Set_Do_Division_Check
(N : Node_Id; Val : Boolean := True); -- Flag13
@ -10606,18 +10733,27 @@ package Sinfo is
procedure Set_Is_Controlling_Actual
(N : Node_Id; Val : Boolean := True); -- Flag16
procedure Set_Is_Declaration_Level_Node
(N : Node_Id; Val : Boolean := True); -- Flag5
procedure Set_Is_Delayed_Aspect
(N : Node_Id; Val : Boolean := True); -- Flag14
procedure Set_Is_Disabled
(N : Node_Id; Val : Boolean := True); -- Flag15
procedure Set_Is_Dispatching_Call
(N : Node_Id; Val : Boolean := True); -- Flag3
procedure Set_Is_Dynamic_Coextension
(N : Node_Id; Val : Boolean := True); -- Flag18
procedure Set_Is_Effective_Use_Clause
(N : Node_Id; Val : Boolean := True); -- Flag1
procedure Set_Is_Elaboration_Checks_OK_Node
(N : Node_Id; Val : Boolean := True); -- Flag1
procedure Set_Is_Elsif
(N : Node_Id; Val : Boolean := True); -- Flag13
@ -10651,6 +10787,12 @@ package Sinfo is
procedure Set_Is_Inherited_Pragma
(N : Node_Id; Val : Boolean := True); -- Flag4
procedure Set_Is_Initialization_Block
(N : Node_Id; Val : Boolean := True); -- Flag1
procedure Set_Is_Known_Guaranteed_ABE
(N : Node_Id; Val : Boolean := True); -- Flag18
procedure Set_Is_Machine_Number
(N : Node_Id; Val : Boolean := True); -- Flag11
@ -10672,6 +10814,15 @@ package Sinfo is
procedure Set_Is_Qualified_Universal_Literal
(N : Node_Id; Val : Boolean := True); -- Flag4
procedure Set_Is_Recorded_Scenario
(N : Node_Id; Val : Boolean := True); -- Flag6
procedure Set_Is_Source_Call
(N : Node_Id; Val : Boolean := True); -- Flag4
procedure Set_Is_SPARK_Mode_On_Node
(N : Node_Id; Val : Boolean := True); -- Flag2
procedure Set_Is_Static_Coextension
(N : Node_Id; Val : Boolean := True); -- Flag14
@ -10789,9 +10940,6 @@ package Sinfo is
procedure Set_No_Ctrl_Actions
(N : Node_Id; Val : Boolean := True); -- Flag7
procedure Set_No_Elaboration_Check
(N : Node_Id; Val : Boolean := True); -- Flag14
procedure Set_No_Entities_Ref_In_Spec
(N : Node_Id; Val : Boolean := True); -- Flag8
@ -10802,7 +10950,7 @@ package Sinfo is
(N : Node_Id; Val : Boolean := True); -- Flag17
procedure Set_No_Side_Effect_Removal
(N : Node_Id; Val : Boolean := True); -- Flag1
(N : Node_Id; Val : Boolean := True); -- Flag17
procedure Set_No_Truncation
(N : Node_Id; Val : Boolean := True); -- Flag17
@ -11023,6 +11171,9 @@ package Sinfo is
procedure Set_Tagged_Present
(N : Node_Id; Val : Boolean := True); -- Flag15
procedure Set_Target
(N : Node_Id; Val : Entity_Id); -- Node1
procedure Set_Target_Type
(N : Node_Id; Val : Entity_Id); -- Node2
@ -11083,6 +11234,9 @@ package Sinfo is
procedure Set_Used_Operations
(N : Node_Id; Val : Elist_Id); -- Elist2
procedure Set_Was_Attribute_Reference
(N : Node_Id; Val : Boolean := True); -- Flag2
procedure Set_Was_Expression_Function
(N : Node_Id; Val : Boolean := True); -- Flag18
@ -12854,6 +13008,13 @@ package Sinfo is
4 => False, -- SCIL_Entity (Node4-Sem)
5 => False), -- SCIL_Tag_Value (Node5-Sem)
N_Call_Marker =>
(1 => True, -- Target (Node1-Sem)
2 => False, -- unused
3 => False, -- unused
4 => False, -- unused
5 => False), -- unused
-- Entries for Empty, Error and Unused. Even thought these have a Chars
-- field for debugging purposes, they are not really syntactic fields, so
-- we mark all fields as unused.
@ -12890,7 +13051,6 @@ package Sinfo is
-- Inline Pragmas --
--------------------
pragma Inline (ABE_Is_Certain);
pragma Inline (Abort_Present);
pragma Inline (Abortable_Part);
pragma Inline (Abstract_Present);
@ -12988,10 +13148,10 @@ package Sinfo is
pragma Inline (Do_Range_Check);
pragma Inline (Do_Storage_Check);
pragma Inline (Do_Tag_Check);
pragma Inline (Elaborate_Present);
pragma Inline (Elaborate_All_Desirable);
pragma Inline (Elaborate_All_Present);
pragma Inline (Elaborate_Desirable);
pragma Inline (Elaborate_Present);
pragma Inline (Else_Actions);
pragma Inline (Else_Statements);
pragma Inline (Elsif_Parts);
@ -13080,10 +13240,13 @@ package Sinfo is
pragma Inline (Is_Component_Left_Opnd);
pragma Inline (Is_Component_Right_Opnd);
pragma Inline (Is_Controlling_Actual);
pragma Inline (Is_Declaration_Level_Node);
pragma Inline (Is_Delayed_Aspect);
pragma Inline (Is_Disabled);
pragma Inline (Is_Dispatching_Call);
pragma Inline (Is_Dynamic_Coextension);
pragma Inline (Is_Effective_Use_Clause);
pragma Inline (Is_Elaboration_Checks_OK_Node);
pragma Inline (Is_Elsif);
pragma Inline (Is_Entry_Barrier_Function);
pragma Inline (Is_Expanded_Build_In_Place_Call);
@ -13095,6 +13258,8 @@ package Sinfo is
pragma Inline (Is_Ignored_Ghost_Pragma);
pragma Inline (Is_In_Discriminant_Check);
pragma Inline (Is_Inherited_Pragma);
pragma Inline (Is_Initialization_Block);
pragma Inline (Is_Known_Guaranteed_ABE);
pragma Inline (Is_Machine_Number);
pragma Inline (Is_Null_Loop);
pragma Inline (Is_Overloaded);
@ -13102,6 +13267,9 @@ package Sinfo is
pragma Inline (Is_Prefixed_Call);
pragma Inline (Is_Protected_Subprogram_Body);
pragma Inline (Is_Qualified_Universal_Literal);
pragma Inline (Is_Recorded_Scenario);
pragma Inline (Is_Source_Call);
pragma Inline (Is_SPARK_Mode_On_Node);
pragma Inline (Is_Static_Coextension);
pragma Inline (Is_Static_Expression);
pragma Inline (Is_Subprogram_Descriptor);
@ -13140,7 +13308,6 @@ package Sinfo is
pragma Inline (Next_Rep_Item);
pragma Inline (Next_Use_Clause);
pragma Inline (No_Ctrl_Actions);
pragma Inline (No_Elaboration_Check);
pragma Inline (No_Entities_Ref_In_Spec);
pragma Inline (No_Initialization);
pragma Inline (No_Minimize_Eliminate);
@ -13218,6 +13385,7 @@ package Sinfo is
pragma Inline (Suppress_Loop_Warnings);
pragma Inline (Synchronized_Present);
pragma Inline (Tagged_Present);
pragma Inline (Target);
pragma Inline (Target_Type);
pragma Inline (Task_Definition);
pragma Inline (Task_Present);
@ -13238,11 +13406,11 @@ package Sinfo is
pragma Inline (Variants);
pragma Inline (Visible_Declarations);
pragma Inline (Used_Operations);
pragma Inline (Was_Attribute_Reference);
pragma Inline (Was_Expression_Function);
pragma Inline (Was_Originally_Stub);
pragma Inline (Withed_Body);
pragma Inline (Set_ABE_Is_Certain);
pragma Inline (Set_Abort_Present);
pragma Inline (Set_Abortable_Part);
pragma Inline (Set_Abstract_Present);
@ -13429,10 +13597,13 @@ package Sinfo is
pragma Inline (Set_Is_Component_Left_Opnd);
pragma Inline (Set_Is_Component_Right_Opnd);
pragma Inline (Set_Is_Controlling_Actual);
pragma Inline (Set_Is_Declaration_Level_Node);
pragma Inline (Set_Is_Delayed_Aspect);
pragma Inline (Set_Is_Disabled);
pragma Inline (Set_Is_Dispatching_Call);
pragma Inline (Set_Is_Dynamic_Coextension);
pragma Inline (Set_Is_Effective_Use_Clause);
pragma Inline (Set_Is_Elaboration_Checks_OK_Node);
pragma Inline (Set_Is_Elsif);
pragma Inline (Set_Is_Entry_Barrier_Function);
pragma Inline (Set_Is_Expanded_Build_In_Place_Call);
@ -13444,6 +13615,8 @@ package Sinfo is
pragma Inline (Set_Is_Ignored_Ghost_Pragma);
pragma Inline (Set_Is_In_Discriminant_Check);
pragma Inline (Set_Is_Inherited_Pragma);
pragma Inline (Set_Is_Initialization_Block);
pragma Inline (Set_Is_Known_Guaranteed_ABE);
pragma Inline (Set_Is_Machine_Number);
pragma Inline (Set_Is_Null_Loop);
pragma Inline (Set_Is_Overloaded);
@ -13451,6 +13624,9 @@ package Sinfo is
pragma Inline (Set_Is_Prefixed_Call);
pragma Inline (Set_Is_Protected_Subprogram_Body);
pragma Inline (Set_Is_Qualified_Universal_Literal);
pragma Inline (Set_Is_Recorded_Scenario);
pragma Inline (Set_Is_Source_Call);
pragma Inline (Set_Is_SPARK_Mode_On_Node);
pragma Inline (Set_Is_Static_Coextension);
pragma Inline (Set_Is_Static_Expression);
pragma Inline (Set_Is_Subprogram_Descriptor);
@ -13490,7 +13666,6 @@ package Sinfo is
pragma Inline (Set_Next_Rep_Item);
pragma Inline (Set_Next_Use_Clause);
pragma Inline (Set_No_Ctrl_Actions);
pragma Inline (Set_No_Elaboration_Check);
pragma Inline (Set_No_Entities_Ref_In_Spec);
pragma Inline (Set_No_Initialization);
pragma Inline (Set_No_Minimize_Eliminate);
@ -13567,6 +13742,7 @@ package Sinfo is
pragma Inline (Set_Synchronized_Present);
pragma Inline (Set_TSS_Elist);
pragma Inline (Set_Tagged_Present);
pragma Inline (Set_Target);
pragma Inline (Set_Target_Type);
pragma Inline (Set_Task_Definition);
pragma Inline (Set_Task_Present);
@ -13586,6 +13762,7 @@ package Sinfo is
pragma Inline (Set_Variant_Part);
pragma Inline (Set_Variants);
pragma Inline (Set_Visible_Declarations);
pragma Inline (Set_Was_Attribute_Reference);
pragma Inline (Set_Was_Expression_Function);
pragma Inline (Set_Was_Originally_Stub);
pragma Inline (Set_Withed_Body);

9
gcc/ada/sprint.adb
View File

@ -1225,6 +1225,15 @@ package body Sprint is
Write_Char (';');
when N_Call_Marker =>
null;
-- Enable the following code for debugging purposes only
-- Write_Indent_Str ("#");
-- Write_Id (Target (Node));
-- Write_Char ('#');
when N_Case_Expression =>
declare
Has_Parens : constant Boolean := Paren_Count (Node) > 0;