diff options
| author | Pierre-Marie de Rodat <pmderodat@gcc.gnu.org> | 2017-12-05 12:12:22 +0000 |
|---|---|---|
| committer | Pierre-Marie de Rodat <pmderodat@gcc.gnu.org> | 2017-12-05 12:12:22 +0000 |
| commit | 967947ed6b3b9e1b3723b2587feccb4dac47715e (patch) | |
| tree | fca443d4dc9d36a11449dda831a8b95f2b870dbe /gcc | |
| parent | 6cbd45e40605d0f77cdc4d31f5b80c1e3d656055 (diff) | |
| download | gcc-967947ed6b3b9e1b3723b2587feccb4dac47715e.zip gcc-967947ed6b3b9e1b3723b2587feccb4dac47715e.tar.gz gcc-967947ed6b3b9e1b3723b2587feccb4dac47715e.tar.bz2 | |
[multiple changes]
2017-12-05 Olivier Hainque <hainque@adacore.com>
* s-dwalin.adb (Read_And_Execute_Isn): Adjust test checking for the end
of section. Add comments explaining the rationale of the computation.
2017-12-05 Bob Duff <duff@adacore.com>
* exp_ch11.adb: Minor refactoring.
2017-12-05 Hristian Kirtchev <kirtchev@adacore.com>
* debug.adb: Add debug switches d_a, d_e, and d_p, along with
documentation.
(Set_Underscored_Debug_Flag): New routine.
* debug.ads: Add the flags for all underscore switches.
(Set_Underscored_Debug_Flag): New routine.
* einfo.adb: Flag303 is now Suppress_Elaboration_Warnings.
(Suppress_Elaboration_Warnings): New routine.
(Set_Suppress_Elaboration_Warnings): New routine.
(Write_Entity_Flags): Add output for Suppress_Elaboration_Warnings.
* einfo.ads: Add new flag Suppress_Elaboration_Warnings.
(Suppress_Elaboration_Warnings): New routine along with pragma Inline.
(Set_Suppress_Elaboration_Warnings): New routine along with pragma
Inline.
* exp_ch3.adb (Build_Init_Procedure): Restore the behavior of the
legacy elaboration model.
(Default_Initialize_Object): Restore the behavior of the legacy
elaboration model.
* exp_ch9.adb: Add with and use clause for Sem_Elab.
(Build_Task_Activation_Call): Restore the behavior of the legacy
elaboration model.
* frontend.adb (Frontend): Restore the behavior of the legacy
elaboration model.
* opt.ads: Add new flags Legacy_Elaboration_Checks and
Relaxed_Elaboration_Checks, along with documentation.
* sem_attr.adb (Analyze_Access_Attribute): Restore the behavior of the
legacy elaboration model.
* sem_ch5.adb (Analyze_Assignment): Restore the behavior of the legacy
elaboration model.
* sem_ch7.adb (Analyze_Package_Declaration): Restore the behavior of
the legacy elaboration model.
* sem_ch8.adb (Attribute_Renaming): Restore the behavior of the legacy
elaboration model.
* sem_ch12.adb (Analyze_Instance_And_Renamings): Restore the behavior
of the legacy elaboration model.
(Analyze_Package_Instantiation): Restore the behavior of the legacy
elaboration model.
(Analyze_Subprogram_Instantiation): Restore the behavior of the legacy
elaboration model.
* sem_elab.adb: Update the documentation of the Processing phase.
Update the documentation on elaboration-related compilation
switches. Update the documentation on adding a new target. Add
Processing_Attributes which represent the state of the Processing
phase. Resurrect the previous elaboration model as "legacy elaboration
model".
(Build_Call_Marker): This routine does not function when the legacy
elaboration model is in effect. Do not consider entry calls and requeue
statements when debug flag d_e is in effect. Do not consider calls to
subprograms which verify the runtime semantics of certain assertion
pragmas when debug flag d_p is in effect.
(Build_Variable_Reference_Marker): This routine does not function when
the legacy elaboration model is in effect.
(Check_Elaboration_Scenarios): This routine does not function when the
legacy elaboration model is in effect.
(Ensure_Prior_Elaboration): The various flags have now been replaced
with a state. Do not generate implicit Elaborate[_All] pragmas when
their creation has been suppressed.
(Ensure_Prior_Elaboration_Static): The with clause is marked based on
the requested pragma, not on the nature of the scenario.
(In_External_Context): Removed.
(Is_Assertion_Pragma_Target): New routine.
(Is_Potential_Scenario): Stop the traversal of a task body when
reaching an accept or select statement, and debug switch d_a is in
effect.
(Kill_Elaboration_Scenario): This routine does not function when the
legacy elaboration model is in effect.
(Process_Activation_Generic): The various flags have now been replaced
with a state.
(Process_Conditional_ABE): The various flags have now been replaced
with a state.
(Process_Conditional_ABE_Access): The various flags have now been
replaced with a state.
(Process_Conditional_ABE_Activation_Impl): The various flags have now
been replaced with a state. Do not process an activation call which
activates a task whose type is defined in an external instance, and
debug switch dL is in effect. Suppress the generation of implicit
Elaborate[_All] pragmas once a conditional ABE check has been
installed.
(Process_Conditional_ABE_Call): The various flags have now been
replaced with a state. Do not process a call which invokes a subprogram
defined in an external instance, and debug switch dL is in effect.
(Process_Conditional_ABE_Call_Ada): The various flags have now been
replaced with a state. Suppress the generation of implicit
Elaborate[_All] pragmas once a conditional ABE check has been
installed.
(Process_Conditional_ABE_Call_SPARK): The various flags have now been
replaced with a state.
(Process_Conditional_ABE_Instantiation): The various flags have now
been replaced with a state.
(Process_Conditional_ABE_Instantiation_Ada): The various flags have now
been replaced with a state. Suppress the generation of implicit
Elaborate[_All] pragmas once a conditional ABE check has been
installed.
(Process_Conditional_ABE_Instantiation_SPARK): The various flags have
now been replaced with a state.
(Process_Guaranteed_ABE_Activation_Impl): The various flags have now
been replaced with a state.
(Process_Single_Activation): The various flags have now been replaced
with a state.
(Record_Elaboration_Scenario): This routine does not function when the
legacy elaboration model is in effect.
(Traverse_Body): The various flags have now been replaced with a state.
* sem_elab.ads: Resurrect the pre-18.x elaboration model as "legacy
elaboration model".
* sem_prag.adb (Analyze_Pragma): Restore the behavior of the legacy
elaboration model.
* sem_res.adb (Resolve_Call): Restore the behavior of the legacy
elaboration model.
(Resolve_Entity_Name): Restore the behavior of the legacy elaboration
model.
* sem_util.adb (Mark_Elaboration_Attributes): This routine does not
function when the legacy elaboration model is in effect.
* sinfo.adb (Is_Known_Guaranteed_ABE): Update the assertion check.
(No_Elaboration_Check): New routine.
(Set_Is_Known_Guaranteed_ABE): Update the assertion check.
(Set_No_Elaboration_Check): New routine.
* sinfo.ads: Update the documentation of flag Is_Known_Guaranteed_ABE
along with occurrences in nodes. Add new flag No_Elaboration_Check
along with occurrences in nodes.
* switch-c.adb (Scan_Front_End_Switches): Add processing for debug
switches with underscores. Add processing for switches -gnatH and
-gnatJ.
* usage.adb (Usage): Add output for switches -gnatH and -gnatJ.
* doc/gnat_ugn/elaboration_order_handling_in_gnat.rst: Update the
documentation to include the legacy and relaxed elaboration models.
* gnat_ugn.texi: Regenerate.
2017-12-05 Arnaud Charlet <charlet@adacore.com>
* doc/gnat_ugn/platform_specific_information.rst: Minor edit.
Improve doc on required packages for linux 32bits.
2017-12-05 Doug Rupp <rupp@adacore.com>
* tracebak.c (ppc64-vx7): USE_GCC_UNWINDER for 64bit.
2017-12-05 Javier Miranda <miranda@adacore.com>
* checks.adb (Generate_Range_Check): Force evaluation of the node in
more cases. This patch was written to improve the code generated by
the CCG compiler but it is enabled for all targets since double
evaluation is always a potential source of inefficiency.
2017-12-05 Gary Dismukes <dismukes@adacore.com>
* doc/gnat_ugn/gnat_utility_programs.rst: Remove reference to obsolete
-fdump-xref switch.
From-SVN: r255412
Diffstat (limited to 'gcc')
33 files changed, 5689 insertions, 1080 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 36170ec..3507a1f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,161 @@ +2017-12-05 Olivier Hainque <hainque@adacore.com> + + * s-dwalin.adb (Read_And_Execute_Isn): Adjust test checking for the end + of section. Add comments explaining the rationale of the computation. + +2017-12-05 Bob Duff <duff@adacore.com> + + * exp_ch11.adb: Minor refactoring. + +2017-12-05 Hristian Kirtchev <kirtchev@adacore.com> + + * debug.adb: Add debug switches d_a, d_e, and d_p, along with + documentation. + (Set_Underscored_Debug_Flag): New routine. + * debug.ads: Add the flags for all underscore switches. + (Set_Underscored_Debug_Flag): New routine. + * einfo.adb: Flag303 is now Suppress_Elaboration_Warnings. + (Suppress_Elaboration_Warnings): New routine. + (Set_Suppress_Elaboration_Warnings): New routine. + (Write_Entity_Flags): Add output for Suppress_Elaboration_Warnings. + * einfo.ads: Add new flag Suppress_Elaboration_Warnings. + (Suppress_Elaboration_Warnings): New routine along with pragma Inline. + (Set_Suppress_Elaboration_Warnings): New routine along with pragma + Inline. + * exp_ch3.adb (Build_Init_Procedure): Restore the behavior of the + legacy elaboration model. + (Default_Initialize_Object): Restore the behavior of the legacy + elaboration model. + * exp_ch9.adb: Add with and use clause for Sem_Elab. + (Build_Task_Activation_Call): Restore the behavior of the legacy + elaboration model. + * frontend.adb (Frontend): Restore the behavior of the legacy + elaboration model. + * opt.ads: Add new flags Legacy_Elaboration_Checks and + Relaxed_Elaboration_Checks, along with documentation. + * sem_attr.adb (Analyze_Access_Attribute): Restore the behavior of the + legacy elaboration model. + * sem_ch5.adb (Analyze_Assignment): Restore the behavior of the legacy + elaboration model. + * sem_ch7.adb (Analyze_Package_Declaration): Restore the behavior of + the legacy elaboration model. + * sem_ch8.adb (Attribute_Renaming): Restore the behavior of the legacy + elaboration model. + * sem_ch12.adb (Analyze_Instance_And_Renamings): Restore the behavior + of the legacy elaboration model. + (Analyze_Package_Instantiation): Restore the behavior of the legacy + elaboration model. + (Analyze_Subprogram_Instantiation): Restore the behavior of the legacy + elaboration model. + * sem_elab.adb: Update the documentation of the Processing phase. + Update the documentation on elaboration-related compilation + switches. Update the documentation on adding a new target. Add + Processing_Attributes which represent the state of the Processing + phase. Resurrect the previous elaboration model as "legacy elaboration + model". + (Build_Call_Marker): This routine does not function when the legacy + elaboration model is in effect. Do not consider entry calls and requeue + statements when debug flag d_e is in effect. Do not consider calls to + subprograms which verify the runtime semantics of certain assertion + pragmas when debug flag d_p is in effect. + (Build_Variable_Reference_Marker): This routine does not function when + the legacy elaboration model is in effect. + (Check_Elaboration_Scenarios): This routine does not function when the + legacy elaboration model is in effect. + (Ensure_Prior_Elaboration): The various flags have now been replaced + with a state. Do not generate implicit Elaborate[_All] pragmas when + their creation has been suppressed. + (Ensure_Prior_Elaboration_Static): The with clause is marked based on + the requested pragma, not on the nature of the scenario. + (In_External_Context): Removed. + (Is_Assertion_Pragma_Target): New routine. + (Is_Potential_Scenario): Stop the traversal of a task body when + reaching an accept or select statement, and debug switch d_a is in + effect. + (Kill_Elaboration_Scenario): This routine does not function when the + legacy elaboration model is in effect. + (Process_Activation_Generic): The various flags have now been replaced + with a state. + (Process_Conditional_ABE): The various flags have now been replaced + with a state. + (Process_Conditional_ABE_Access): The various flags have now been + replaced with a state. + (Process_Conditional_ABE_Activation_Impl): The various flags have now + been replaced with a state. Do not process an activation call which + activates a task whose type is defined in an external instance, and + debug switch dL is in effect. Suppress the generation of implicit + Elaborate[_All] pragmas once a conditional ABE check has been + installed. + (Process_Conditional_ABE_Call): The various flags have now been + replaced with a state. Do not process a call which invokes a subprogram + defined in an external instance, and debug switch dL is in effect. + (Process_Conditional_ABE_Call_Ada): The various flags have now been + replaced with a state. Suppress the generation of implicit + Elaborate[_All] pragmas once a conditional ABE check has been + installed. + (Process_Conditional_ABE_Call_SPARK): The various flags have now been + replaced with a state. + (Process_Conditional_ABE_Instantiation): The various flags have now + been replaced with a state. + (Process_Conditional_ABE_Instantiation_Ada): The various flags have now + been replaced with a state. Suppress the generation of implicit + Elaborate[_All] pragmas once a conditional ABE check has been + installed. + (Process_Conditional_ABE_Instantiation_SPARK): The various flags have + now been replaced with a state. + (Process_Guaranteed_ABE_Activation_Impl): The various flags have now + been replaced with a state. + (Process_Single_Activation): The various flags have now been replaced + with a state. + (Record_Elaboration_Scenario): This routine does not function when the + legacy elaboration model is in effect. + (Traverse_Body): The various flags have now been replaced with a state. + * sem_elab.ads: Resurrect the pre-18.x elaboration model as "legacy + elaboration model". + * sem_prag.adb (Analyze_Pragma): Restore the behavior of the legacy + elaboration model. + * sem_res.adb (Resolve_Call): Restore the behavior of the legacy + elaboration model. + (Resolve_Entity_Name): Restore the behavior of the legacy elaboration + model. + * sem_util.adb (Mark_Elaboration_Attributes): This routine does not + function when the legacy elaboration model is in effect. + * sinfo.adb (Is_Known_Guaranteed_ABE): Update the assertion check. + (No_Elaboration_Check): New routine. + (Set_Is_Known_Guaranteed_ABE): Update the assertion check. + (Set_No_Elaboration_Check): New routine. + * sinfo.ads: Update the documentation of flag Is_Known_Guaranteed_ABE + along with occurrences in nodes. Add new flag No_Elaboration_Check + along with occurrences in nodes. + * switch-c.adb (Scan_Front_End_Switches): Add processing for debug + switches with underscores. Add processing for switches -gnatH and + -gnatJ. + * usage.adb (Usage): Add output for switches -gnatH and -gnatJ. + * doc/gnat_ugn/elaboration_order_handling_in_gnat.rst: Update the + documentation to include the legacy and relaxed elaboration models. + * gnat_ugn.texi: Regenerate. + +2017-12-05 Arnaud Charlet <charlet@adacore.com> + + * doc/gnat_ugn/platform_specific_information.rst: Minor edit. + Improve doc on required packages for linux 32bits. + +2017-12-05 Doug Rupp <rupp@adacore.com> + + * tracebak.c (ppc64-vx7): USE_GCC_UNWINDER for 64bit. + +2017-12-05 Javier Miranda <miranda@adacore.com> + + * checks.adb (Generate_Range_Check): Force evaluation of the node in + more cases. This patch was written to improve the code generated by + the CCG compiler but it is enabled for all targets since double + evaluation is always a potential source of inefficiency. + +2017-12-05 Gary Dismukes <dismukes@adacore.com> + + * doc/gnat_ugn/gnat_utility_programs.rst: Remove reference to obsolete + -fdump-xref switch. + 2017-12-05 Eric Botcazou <ebotcazou@adacore.com> * exp_ch5.adb (Expand_Iterator_Loop_Over_Array): Use the SLOC of the diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index f47e635..6fe75a1 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -6812,8 +6812,16 @@ package body Checks is -- evaluation is always a potential source of inefficiency, and is -- functionally incorrect in the volatile case. - if not Is_Entity_Name (N) or else Treat_As_Volatile (Entity (N)) then - Force_Evaluation (N); + -- We skip the evaluation of attribute references because, after these + -- runtime checks are generated, the expander may need to rewrite this + -- node (for example, see Attribute_Max_Size_In_Storage_Elements in + -- Expand_N_Attribute_Reference). + + if Nkind (N) /= N_Attribute_Reference + and then (not Is_Entity_Name (N) + or else Treat_As_Volatile (Entity (N))) + then + Force_Evaluation (N, Mode => Strict); end if; -- The easiest case is when Source_Base_Type and Target_Base_Type are diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 06bec39..0a14cec 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -145,6 +145,60 @@ package body Debug is -- d.Y -- d.Z Do not enable expansion in configurable run-time mode + -- d_a Stop elaboration checks on accept or select statement + -- d_b + -- d_c + -- d_d + -- d_e Ignore entry calls and requeue statements for elaboration + -- d_f + -- d_g + -- d_h + -- d_i + -- d_j + -- d_k + -- d_l + -- d_m + -- d_n + -- d_o + -- d_p Ignore assertion pragmas for elaboration + -- d_q + -- d_r + -- d_s + -- d_t + -- d_u + -- d_v + -- d_w + -- d_x + -- d_y + -- d_z + + -- d_A + -- d_B + -- d_C + -- d_D + -- d_E + -- d_F + -- d_G + -- d_H + -- d_I + -- d_J + -- d_K + -- d_L Output trace information on elaboration checking + -- d_M + -- d_N + -- d_O + -- d_P + -- d_Q + -- d_R + -- d_S + -- d_T + -- d_U + -- d_V + -- d_W + -- d_X + -- d_Y + -- d_Z + -- d1 Error msgs have node numbers where possible -- d2 Eliminate error flags in verbose form error messages -- d3 Dump bad node in Comperr on an abort @@ -165,6 +219,16 @@ package body Debug is -- d.8 -- d.9 Disable build-in-place for nonlimited types + -- d_1 + -- d_2 + -- d_3 + -- d_4 + -- d_5 + -- d_6 + -- d_7 + -- d_8 + -- d_9 + -- Debug flags for binder (GNATBIND) -- da All links (including internal units) listed if there is a cycle @@ -759,6 +823,24 @@ package body Debug is -- case if debug flag -gnatd.Z is used. This is to deal with the case -- where we discover difficulties in this new processing. + -- d_a The compiler stops the examination of a task body once it reaches + -- an accept or select statement for the static elaboration model. The + -- behavior is similar to that of No_Entry_Calls_In_Elaboration_Code, + -- but does not penalize actual entry calls in elaboration code. + + -- d_e The compiler ignores simple entry calls, asynchronous transfer of + -- control, conditional entry calls, timed entry calls, and requeue + -- statements in both the static and dynamic elaboration models. + + -- d_p The compiler ignores calls to subprograms which verify the run-time + -- semantics of invariants and postconditions in both the static and + -- dynamic elaboration models. + + -- d_L 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. + -- d1 Error messages have node numbers where possible. Normally error -- messages have only source locations. This option is useful when -- debugging errors caused by expanded code, where the source location @@ -944,7 +1026,7 @@ package body Debug is -------------------- procedure Set_Debug_Flag (C : Character; Val : Boolean := True) is - subtype Dig is Character range '1' .. '9'; + subtype Dig is Character range '1' .. '9'; subtype LLet is Character range 'a' .. 'z'; subtype ULet is Character range 'A' .. 'Z'; @@ -1090,7 +1172,7 @@ package body Debug is --------------------------- procedure Set_Dotted_Debug_Flag (C : Character; Val : Boolean := True) is - subtype Dig is Character range '1' .. '9'; + subtype Dig is Character range '1' .. '9'; subtype LLet is Character range 'a' .. 'z'; subtype ULet is Character range 'A' .. 'Z'; @@ -1231,4 +1313,153 @@ package body Debug is end if; end Set_Dotted_Debug_Flag; + -------------------------------- + -- Set_Underscored_Debug_Flag -- + -------------------------------- + + procedure Set_Underscored_Debug_Flag + (C : Character; + Val : Boolean := True) + is + subtype Dig is Character range '1' .. '9'; + subtype LLet is Character range 'a' .. 'z'; + subtype ULet is Character range 'A' .. 'Z'; + + begin + if C in Dig then + case Dig (C) is + when '1' => + Debug_Flag_Underscore_1 := Val; + when '2' => + Debug_Flag_Underscore_2 := Val; + when '3' => + Debug_Flag_Underscore_3 := Val; + when '4' => + Debug_Flag_Underscore_4 := Val; + when '5' => + Debug_Flag_Underscore_5 := Val; + when '6' => + Debug_Flag_Underscore_6 := Val; + when '7' => + Debug_Flag_Underscore_7 := Val; + when '8' => + Debug_Flag_Underscore_8 := Val; + when '9' => + Debug_Flag_Underscore_9 := Val; + end case; + + elsif C in ULet then + case ULet (C) is + when 'A' => + Debug_Flag_Underscore_AA := Val; + when 'B' => + Debug_Flag_Underscore_BB := Val; + when 'C' => + Debug_Flag_Underscore_CC := Val; + when 'D' => + Debug_Flag_Underscore_DD := Val; + when 'E' => + Debug_Flag_Underscore_EE := Val; + when 'F' => + Debug_Flag_Underscore_FF := Val; + when 'G' => + Debug_Flag_Underscore_GG := Val; + when 'H' => + Debug_Flag_Underscore_HH := Val; + when 'I' => + Debug_Flag_Underscore_II := Val; + when 'J' => + Debug_Flag_Underscore_JJ := Val; + when 'K' => + Debug_Flag_Underscore_KK := Val; + when 'L' => + Debug_Flag_Underscore_LL := Val; + when 'M' => + Debug_Flag_Underscore_MM := Val; + when 'N' => + Debug_Flag_Underscore_NN := Val; + when 'O' => + Debug_Flag_Underscore_OO := Val; + when 'P' => + Debug_Flag_Underscore_PP := Val; + when 'Q' => + Debug_Flag_Underscore_QQ := Val; + when 'R' => + Debug_Flag_Underscore_RR := Val; + when 'S' => + Debug_Flag_Underscore_SS := Val; + when 'T' => + Debug_Flag_Underscore_TT := Val; + when 'U' => + Debug_Flag_Underscore_UU := Val; + when 'V' => + Debug_Flag_Underscore_VV := Val; + when 'W' => + Debug_Flag_Underscore_WW := Val; + when 'X' => + Debug_Flag_Underscore_XX := Val; + when 'Y' => + Debug_Flag_Underscore_YY := Val; + when 'Z' => + Debug_Flag_Underscore_ZZ := Val; + end case; + + else + case LLet (C) is + when 'a' => + Debug_Flag_Underscore_A := Val; + when 'b' => + Debug_Flag_Underscore_B := Val; + when 'c' => + Debug_Flag_Underscore_C := Val; + when 'd' => + Debug_Flag_Underscore_D := Val; + when 'e' => + Debug_Flag_Underscore_E := Val; + when 'f' => + Debug_Flag_Underscore_F := Val; + when 'g' => + Debug_Flag_Underscore_G := Val; + when 'h' => + Debug_Flag_Underscore_H := Val; + when 'i' => + Debug_Flag_Underscore_I := Val; + when 'j' => + Debug_Flag_Underscore_J := Val; + when 'k' => + Debug_Flag_Underscore_K := Val; + when 'l' => + Debug_Flag_Underscore_L := Val; + when 'm' => + Debug_Flag_Underscore_M := Val; + when 'n' => + Debug_Flag_Underscore_N := Val; + when 'o' => + Debug_Flag_Underscore_O := Val; + when 'p' => + Debug_Flag_Underscore_P := Val; + when 'q' => + Debug_Flag_Underscore_Q := Val; + when 'r' => + Debug_Flag_Underscore_R := Val; + when 's' => + Debug_Flag_Underscore_S := Val; + when 't' => + Debug_Flag_Underscore_T := Val; + when 'u' => + Debug_Flag_Underscore_U := Val; + when 'v' => + Debug_Flag_Underscore_V := Val; + when 'w' => + Debug_Flag_Underscore_W := Val; + when 'x' => + Debug_Flag_Underscore_X := Val; + when 'y' => + Debug_Flag_Underscore_Y := Val; + when 'z' => + Debug_Flag_Underscore_Z := Val; + end case; + end if; + end Set_Underscored_Debug_Flag; + end Debug; diff --git a/gcc/ada/debug.ads b/gcc/ada/debug.ads index 3ed9326..91130c4 100644 --- a/gcc/ada/debug.ads +++ b/gcc/ada/debug.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -176,6 +176,70 @@ package Debug is Debug_Flag_Dot_8 : Boolean := False; Debug_Flag_Dot_9 : Boolean := False; + Debug_Flag_Underscore_A : Boolean := False; + Debug_Flag_Underscore_B : Boolean := False; + Debug_Flag_Underscore_C : Boolean := False; + Debug_Flag_Underscore_D : Boolean := False; + Debug_Flag_Underscore_E : Boolean := False; + Debug_Flag_Underscore_F : Boolean := False; + Debug_Flag_Underscore_G : Boolean := False; + Debug_Flag_Underscore_H : Boolean := False; + Debug_Flag_Underscore_I : Boolean := False; + Debug_Flag_Underscore_J : Boolean := False; + Debug_Flag_Underscore_K : Boolean := False; + Debug_Flag_Underscore_L : Boolean := False; + Debug_Flag_Underscore_M : Boolean := False; + Debug_Flag_Underscore_N : Boolean := False; + Debug_Flag_Underscore_O : Boolean := False; + Debug_Flag_Underscore_P : Boolean := False; + Debug_Flag_Underscore_Q : Boolean := False; + Debug_Flag_Underscore_R : Boolean := False; + Debug_Flag_Underscore_S : Boolean := False; + Debug_Flag_Underscore_T : Boolean := False; + Debug_Flag_Underscore_U : Boolean := False; + Debug_Flag_Underscore_V : Boolean := False; + Debug_Flag_Underscore_W : Boolean := False; + Debug_Flag_Underscore_X : Boolean := False; + Debug_Flag_Underscore_Y : Boolean := False; + Debug_Flag_Underscore_Z : Boolean := False; + + Debug_Flag_Underscore_AA : Boolean := False; + Debug_Flag_Underscore_BB : Boolean := False; + Debug_Flag_Underscore_CC : Boolean := False; + Debug_Flag_Underscore_DD : Boolean := False; + Debug_Flag_Underscore_EE : Boolean := False; + Debug_Flag_Underscore_FF : Boolean := False; + Debug_Flag_Underscore_GG : Boolean := False; + Debug_Flag_Underscore_HH : Boolean := False; + Debug_Flag_Underscore_II : Boolean := False; + Debug_Flag_Underscore_JJ : Boolean := False; + Debug_Flag_Underscore_KK : Boolean := False; + Debug_Flag_Underscore_LL : Boolean := False; + Debug_Flag_Underscore_MM : Boolean := False; + Debug_Flag_Underscore_NN : Boolean := False; + Debug_Flag_Underscore_OO : Boolean := False; + Debug_Flag_Underscore_PP : Boolean := False; + Debug_Flag_Underscore_QQ : Boolean := False; + Debug_Flag_Underscore_RR : Boolean := False; + Debug_Flag_Underscore_SS : Boolean := False; + Debug_Flag_Underscore_TT : Boolean := False; + Debug_Flag_Underscore_UU : Boolean := False; + Debug_Flag_Underscore_VV : Boolean := False; + Debug_Flag_Underscore_WW : Boolean := False; + Debug_Flag_Underscore_XX : Boolean := False; + Debug_Flag_Underscore_YY : Boolean := False; + Debug_Flag_Underscore_ZZ : Boolean := False; + + Debug_Flag_Underscore_1 : Boolean := False; + Debug_Flag_Underscore_2 : Boolean := False; + Debug_Flag_Underscore_3 : Boolean := False; + Debug_Flag_Underscore_4 : Boolean := False; + Debug_Flag_Underscore_5 : Boolean := False; + Debug_Flag_Underscore_6 : Boolean := False; + Debug_Flag_Underscore_7 : Boolean := False; + Debug_Flag_Underscore_8 : Boolean := False; + Debug_Flag_Underscore_9 : Boolean := False; + procedure Set_Debug_Flag (C : Character; Val : Boolean := True); -- Where C is 0-9, A-Z, or a-z, sets the corresponding debug flag to -- the given value. In the checks off version of debug, the call to @@ -185,4 +249,8 @@ package Debug is -- Where C is 0-9, A-Z, or a-z, sets the corresponding dotted debug -- flag (e.g. call with C = 'a' for the .a flag). + procedure Set_Underscored_Debug_Flag (C : Character; Val : Boolean := True); + -- Where C is 0-9, A-Z, or a-z, sets the corresponding underscored debug + -- flag (e.g. call with C = 'a' for the _a flag). + end Debug; diff --git a/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst b/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst index d8c9aef..d29a915 100644 --- a/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst @@ -630,6 +630,21 @@ elaboration order and to diagnose elaboration problems. region subject to SPARK_Mode On, otherwise the dynamic or static model is in effect. +.. index:: Legacy elaboration model + +* *Legacy elaboration model* + + In addition to the three elabortaion models outlined above, GNAT provides the + elaboration model of pre-18.x versions referred to as `legacy elaboration + model`. The legacy elaboration model is enabled with compiler switch + :switch:`-gnatH`. + +.. index:: Relaxed elaboration mode + +The dynamic, legacy, and static models can be relaxed using compiler switch +:switch:`-gnatJ`, making them more permissive. Note that in this mode, GNAT +may not diagnose certain elaboration issues or install run-time checks. + .. _Common_Elaboration_Model_Traits": Common Elaboration-model Traits @@ -910,6 +925,15 @@ external, and compiler switch :switch:`-gnatd.v` is in effect. 4. end SPARK_Model; +Legacy Elaboration Model in GNAT +================================ + +The legacy elaboration model is provided for compatibility with code bases +developed with pre-18.x versions of GNAT. It is similar in functionality to +the dynamic and static models of post-18.x version of GNAT, but may differ +in terms of diagnostics and run-time checks. The legacy elaboration model is +enabled with compiler switch :switch:`-gnatH`. + .. _Mixing_Elaboration_Models: Mixing Elaboration Models @@ -1029,6 +1053,21 @@ available. and it is the programmer's responsibility to ensure that it does not raise ``Program_Error``. + If the compilation was performed using a post-18.x version of GNAT, consider + using the legacy elaboration model, in the following order: + + - Use the legacy static elaboration model, with compiler switch + :switch:`-gnatH`. + + - Use the legacy dynamic elaboration model, with compiler switches + :switch:`-gnatH` :switch:`-gnatE`. + + - Use the relaxed legacy static elaboration model, with compiler switches + :switch:`-gnatH` :switch:`-gnatJ`. + + - Use the relaxed legacy dynamic elaboration model, with compiler switches + :switch:`-gnatH` :switch:`-gnatJ` :switch:`-gnatE`. + * *Suppress all elaboration checks* The drawback of run-time checks is that they generate overhead at run time, @@ -1421,160 +1460,6 @@ Elaboration-related Compiler Switches GNAT has several switches that affect the elaboration model and consequently the elaboration order chosen by the binder. -.. index:: -gnatdE (gnat) - -:switch:`-gnatdE` - Elaboration checks on predefined units - - When this switch is in effect, GNAT will consider scenarios and targets that - come from the Ada, GNAT, Interfaces, and System hierarchies. This switch is - useful when a programmer has defined a custom grandchild of those packages. - -.. index:: -gnatd.G (gnat) - -:switch:`-gnatd.G` - Ignore calls through generic formal parameters for elaboration - - When this switch is in effect, GNAT will ignore calls that invoke generic - actual entries, operators, or subprograms via generic formal subprograms. As - a result, GNAT will not generate implicit ``Elaborate`` and ``Elaborate_All`` - pragmas, and run-time checks for such calls. Note that this switch does not - overlap with :switch:`-gnatdL`. - - :: - - package body Ignore_Calls is - function ABE return Integer; - - generic - with function Gen_Formal return Integer; - package Gen is - Val : constant Integer := Gen_Formal; - end Gen; - - package Inst is new Gen (ABE); - - function ABE return Integer is - begin - ... - end ABE; - end Ignore_Calls; - - In the example above, the call to function ``ABE`` will be ignored because it - occurs during the elaboration of instance ``Inst``, through a call to generic - formal subprogram ``Gen_Formal``. - -.. index:: -gnatdL (gnat) - -:switch:`-gnatdL` - Ignore external calls from instances for elaboration - - When this switch is in effect, GNAT will ignore calls that originate from - within an instance and directly target an entry, operator, or subprogram - defined outside the instance. As a result, GNAT will not generate implicit - ``Elaborate`` and ``Elaborate_All`` pragmas, and run-time checks for such - calls. Note that this switch does not overlap with :switch:`-gnatd.G`. - - :: - - package body Ignore_Calls is - function ABE return Integer; - - generic - package Gen is - Val : constant Integer := ABE; - end Gen; - - package Inst is new Gen; - - function ABE return Integer is - begin - ... - end ABE; - end Ignore_Calls; - - In the example above, the call to function ``ABE`` will be ignored because it - originates from within an instance and targets a subprogram defined outside - the instance. - -.. index:: -gnatd.o (gnat) - -:switch:`-gnatd.o` - Conservative elaboration order for indirect calls - - When this switch is in effect, GNAT will treat ``'Access`` of an entry, - operator, or subprogram as an immediate call to that target. As a result, - GNAT will generate implicit ``Elaborate`` and ``Elaborate_All`` pragmas as - well as run-time checks for such attribute references. - - :: - - 1. package body Attribute_Call is - 2. function Func return Integer; - 3. type Func_Ptr is access function return Integer; - 4. - 5. Ptr : constant Func_Ptr := Func'Access; - | - >>> warning: cannot call "Func" before body seen - >>> warning: Program_Error may be raised at run time - >>> warning: body of unit "Attribute_Call" elaborated - >>> warning: "Access" of "Func" taken at line 5 - >>> warning: function "Func" called at line 5 - - 6. - 7. function Func return Integer is - 8. begin - 9. ... - 10. end Func; - 11. end Attribute_Call; - - In the example above, the elaboration of declaration ``Ptr`` is assigned - ``Func'Access`` before the body of ``Func`` has been elaborated. - -.. index:: -gnatd.U (gnat) - -:switch:`-gnatd.U` - Ignore indirect calls for static elaboration - - When this switch is in effect, GNAT will ignore ``'Access`` of an entry, - operator, or subprogram when the static model is in effect. - -.. index:: -gnatd.v (gnat) - -:switch:`-gnatd.v` - Enforce SPARK elaboration rules in SPARK code - - When this switch is in effect, GNAT will enforce the SPARK rules of - elaboration as defined in the SPARK Reference Manual, section 7.7. As a - result, constructs which violate the SPARK elaboration rules are no longer - accepted, even if GNAT is able to statically ensure that these constructs - will not lead to ABE problems. - -.. index:: -gnatd.y (gnat) - -:switch:`-gnatd.y` - Disable implicit pragma Elaborate[_All] on task bodies - - When this switch is in effect, GNAT will not generate ``Elaborate`` and - ``Elaborate_All`` pragmas if the need for the pragma came directly or - indirectly from a task body. - - :: - - with Server; - package body Disable_Task is - task T; - - task body T is - begin - Server.Proc; - end T; - end Disable_Task; - - In the example above, the activation of single task ``T`` invokes - ``Server.Proc``, which implies that ``Server`` requires ``Elaborate_All``, - however GNAT will not generate the pragma. - .. index:: -gnatE (gnat) :switch:`-gnatE` @@ -1617,6 +1502,23 @@ the elaboration order chosen by the binder. 4. end Client; +.. index:: -gnatH (gnat) + +:switch:`-gnatH` + Legacy elaboration checking mode enabled + + When this switch is in effect, GNAT will utilize the pre-18.x elaboration + model. + +.. index:: -gnatJ (gnat) + +:switch:`-gnatJ` + Relaxed elaboration checking mode enabled + + When this switch is in effect, GNAT will not process certain scenarios + resulting in a more permissive elaboration model. Note that this may + eliminate some diagnostics and run-time checks. + .. index:: -gnatw.f (gnat) :switch:`-gnatw.f` @@ -1698,6 +1600,7 @@ A programmer should first compile the program with the default options, using none of the binder or compiler switches. If the binder succeeds in finding an elaboration order, then apart from possible cases involing dispatching calls and access-to-subprogram types, the program is free of elaboration errors. + If it is important for the program to be portable to compilers other than GNAT, then the programmer should use compiler switch :switch:`-gnatel` and consider the messages about missing or implicitly created ``Elaborate`` and @@ -1706,24 +1609,35 @@ the messages about missing or implicitly created ``Elaborate`` and If the binder reports an elaboration circularity, the programmer has several options: -* Ensure that warnings are enabled. This will allow the static model to output - trace information of elaboration issues. The trace information could shed - light on previously unforeseen dependencies, as well as their origins. +* Ensure that elaboration warnings are enabled. This will allow the static + model to output trace information of elaboration issues. The trace + information could shed light on previously unforeseen dependencies, as well + as their origins. Elaboration warnings are enabled with compiler switch + :switch:`-gnatwl`. * Use switch :switch:`-gnatel` to obtain messages on generated implicit ``Elaborate`` and ``Elaborate_All`` pragmas. The trace information could indicate why a server unit must be elaborated prior to a client unit. * If the warnings produced by the static model indicate that a task is - involved, consider the options in the section on resolving task issues as - well as compiler switch :switch:`-gnatd.y`. + involved, consider the options in section `Resolving Task Issues`_. + +* If none of the steps outlined above resolve the circularity, use a more + permissive elaboration model, in the following order: + + - Use the dynamic elaboration model, with compiler switch :switch:`-gnatE`. + + - Use the legacy static elaboration model, with compiler switch + :switch:`-gnatH`. + + - Use the legacy dynamic elaboration model, with compiler switches + :switch:`-gnatH` :switch:`-gnatE`. -* If the warnings produced by the static model indicate that an generic - instantiations are involved, consider using compiler switches - :switch:`-gnatd.G` and :switch:`-gnatdL`. + - Use the relaxed legacy static elaboration model, with compiler switches + :switch:`-gnatH` :switch:`-gnatJ`. -* If none of the steps outlined above resolve the circularity, recompile the - program using the dynamic model by using compiler switch :switch:`-gnatE`. + - Use the relaxed legacy dynamic elaboration model, with compiler switches + :switch:`-gnatH` :switch:`-gnatJ` :switch:`-gnatE`. .. _Inspecting_the_Chosen_Elaboration_Order: diff --git a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst index 7173c56..4efbbe0 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst @@ -588,8 +588,8 @@ The following switches are available for ``gnatxref``: :switch:`--ext={extension}` Specify an alternate ali file extension. The default is ``ali`` and other extensions (e.g. ``gli`` for C/C++ sources) may be specified via this switch. - Note that if this switch overrides the default, which means that only the - new extension will be considered. + Note that if this switch overrides the default, only the new extension will + be considered. .. index:: --RTS (gnatxref) @@ -776,9 +776,8 @@ The following switches are available: :switch:`--ext={extension}` Specify an alternate ali file extension. The default is ``ali`` and other - extensions (e.g. ``gli`` for C/C++ sources when using :switch:`-fdump-xref`) - may be specified via this switch. Note that if this switch overrides the - default, which means that only the new extension will be considered. + extensions may be specified via this switch. Note that if this switch + overrides the default, only the new extension will be considered. .. index:: --RTS (gnatfind) diff --git a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst index bbf7901..5f2f70c 100644 --- a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst +++ b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst @@ -231,8 +231,8 @@ This section describes topics that are specific to GNU/Linux platforms. .. _Required_packages_on_GNU_Linux: -Required Packages on GNU/Linux: -------------------------------- +Required Packages on GNU/Linux +------------------------------ GNAT requires the C library developer's package to be installed. The name of of that package depends on your GNU/Linux distribution: @@ -241,10 +241,10 @@ The name of of that package depends on your GNU/Linux distribution: * Debian, Ubuntu: ``libc6-dev`` (normally installed by default). If using the 32-bit version of GNAT on a 64-bit version of GNU/Linux, -you'll need the 32-bit version of that package instead: +you'll need the 32-bit version of the glibc and glibc-devel packages: -* RedHat, SUSE: ``glibc-devel.i686``; -* Debian, Ubuntu: ``libc6-dev:i386``. +* RedHat, SUSE: ``glibc.i686``, ``glibc-devel.i686`` +* Debian, Ubuntu: ``libc6:i386``, ``libc6-dev:i386`` Other GNU/Linux distributions might be choosing a different name for that package. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 1312965..5968a73 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -625,8 +625,8 @@ package body Einfo is -- Ignore_SPARK_Mode_Pragmas Flag301 -- Is_Initial_Condition_Procedure Flag302 + -- Suppress_Elaboration_Warnings Flag303 - -- (unused) Flag303 -- (unused) Flag304 -- (unused) Flag305 -- (unused) Flag306 @@ -3497,6 +3497,11 @@ package body Einfo is return Uint24 (Id); end Subps_Index; + function Suppress_Elaboration_Warnings (Id : E) return B is + begin + return Flag303 (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); @@ -6732,6 +6737,11 @@ 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_Flag303 (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); @@ -9786,6 +9796,7 @@ 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", Flag303 (Id)); W ("Suppress_Initialization", Flag105 (Id)); W ("Suppress_Style_Checks", Flag165 (Id)); W ("Suppress_Value_Tracking_On_Call", Flag217 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index ab05611..7a8dd80 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -4445,6 +4445,20 @@ 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 (Flag303) +-- NOTE: this flag is relevant only for the legacy ABE mechanism and +-- should not be used outside of that context. +-- +-- 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 @@ -5604,6 +5618,7 @@ package Einfo is -- Referenced (Flag156) -- Referenced_As_LHS (Flag36) -- Referenced_As_Out_Parameter (Flag227) + -- Suppress_Elaboration_Warnings (Flag303) -- Suppress_Style_Checks (Flag165) -- Suppress_Value_Tracking_On_Call (Flag217) -- Used_As_Generic_Actual (Flag222) @@ -7437,6 +7452,7 @@ 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; @@ -8134,6 +8150,7 @@ 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); @@ -8991,6 +9008,7 @@ 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); @@ -9475,6 +9493,7 @@ package Einfo is pragma Inline (Set_String_Literal_Low_Bound); pragma Inline (Set_Subprograms_For_Type); pragma Inline (Set_Subps_Index); + pragma Inline (Set_Suppress_Elaboration_Warnings); pragma Inline (Set_Suppress_Initialization); pragma Inline (Set_Suppress_Style_Checks); pragma Inline (Set_Suppress_Value_Tracking_On_Call); diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index c4bf096..03d7371 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1421,9 +1421,9 @@ package body Exp_Ch11 is -- Add clean up actions if required - if not Nkind_In (Parent (N), N_Package_Body, - N_Accept_Statement, - N_Extended_Return_Statement) + if not Nkind_In (Parent (N), N_Accept_Statement, + N_Extended_Return_Statement, + N_Package_Body) and then not Delay_Cleanups (Current_Scope) -- No cleanup action needed in thunks associated with interfaces diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index f218069..dc7d6af 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2731,7 +2731,8 @@ package body Exp_Ch3 is and then not Restriction_Active (No_Exception_Propagation) then declare - DF_Id : Entity_Id; + DF_Call : Node_Id; + DF_Id : Entity_Id; begin -- Create a local version of Deep_Finalize which has indication @@ -2743,18 +2744,27 @@ package body Exp_Ch3 is 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. + + if Legacy_Elaboration_Checks then + Set_No_Elaboration_Check (DF_Call); + end if; + Set_Exception_Handlers (Handled_Stmt_Node, New_List ( Make_Exception_Handler (Loc, Exception_Choices => New_List ( Make_Others_Choice (Loc)), Statements => New_List ( - 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))), - + DF_Call, Make_Raise_Statement (Loc))))); end; else @@ -6083,6 +6093,15 @@ 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. + + if Legacy_Elaboration_Checks then + Set_No_Elaboration_Check (Fin_Call); + end if; + Fin_Block := Make_Block_Statement (Loc, Declarations => No_List, diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index d94a72f..621891d 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -52,6 +52,7 @@ 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; @@ -4905,6 +4906,10 @@ package body Exp_Ch9 is end if; Analyze (Call); + + if Legacy_Elaboration_Checks then + Check_Task_Activation (N); + end if; end Build_Task_Activation_Call; ------------------------------- diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 828f6ff..26483f4 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -440,10 +440,14 @@ begin Collect_Garbage_Entities; end if; + if Legacy_Elaboration_Checks then + Check_Elab_Calls; + end if; + -- 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. + -- and resolution. Diagnose conditional ABEs, install run-time + -- checks to catch conditional ABEs, and guarantee the prior + -- elaboration of external units. Check_Elaboration_Scenarios; @@ -452,9 +456,9 @@ begin Remove_Ignored_Ghost_Code; - -- Otherwise check the access-before-elaboration rules even when - -- previous errors were detected or the compilation is verifying - -- semantics. + -- Examine all top level scenarios collected during analysis and + -- resolution in order to diagnose conditional ABEs, even in the + -- presence of serious errors. else Check_Elaboration_Scenarios; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 18b09b2..eda994d 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -136,9 +136,9 @@ procedure Gnat1drv is -- Start of processing for Adjust_Global_Switches begin - -- Define pragma GNAT_Annotate as an alias of pragma Annotate, - -- to be able to work around bootstrap limitations with the old syntax - -- of pragma Annotate, and use pragma GNAT_Annotate in compiler sources + -- Define pragma GNAT_Annotate as an alias of pragma Annotate, to be + -- able to work around bootstrap limitations with the old syntax of + -- pragma Annotate, and use pragma GNAT_Annotate in compiler sources -- when needed. Map_Pragma_Name (From => Name_Gnat_Annotate, To => Name_Annotate); diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 261b410..cc902b3 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Nov 16, 2017 +GNAT User's Guide for Native Platforms , Dec 05, 2017 AdaCore @@ -460,7 +460,7 @@ Specifying a Run-Time Library GNU/Linux Topics -* Required Packages on GNU/Linux;: Required Packages on GNU/Linux. +* Required Packages on GNU/Linux:: Microsoft Windows Topics @@ -542,6 +542,7 @@ Elaboration Order Handling in GNAT * Dynamic Elaboration Model in GNAT:: * Static Elaboration Model in GNAT:: * SPARK Elaboration Model in GNAT:: +* Legacy Elaboration Model in GNAT:: * Mixing Elaboration Models:: * Elaboration Circularities:: * Resolving Elaboration Circularities:: @@ -17943,8 +17944,8 @@ Do not look for library files in the system default directory. Specify an alternate ali file extension. The default is @code{ali} and other extensions (e.g. @code{gli} for C/C++ sources) may be specified via this switch. -Note that if this switch overrides the default, which means that only the -new extension will be considered. +Note that if this switch overrides the default, only the new extension will +be considered. @end table @geindex --RTS (gnatxref) @@ -18200,9 +18201,8 @@ Do not look for library files in the system default directory. @item @code{--ext=@emph{extension}} Specify an alternate ali file extension. The default is @code{ali} and other -extensions (e.g. @code{gli} for C/C++ sources when using @code{-fdump-xref}) -may be specified via this switch. Note that if this switch overrides the -default, which means that only the new extension will be considered. +extensions may be specified via this switch. Note that if this switch +overrides the default, only the new extension will be considered. @end table @geindex --RTS (gnatfind) @@ -23789,13 +23789,13 @@ Program_Error. This section describes topics that are specific to GNU/Linux platforms. @menu -* Required Packages on GNU/Linux;: Required Packages on GNU/Linux. +* Required Packages on GNU/Linux:: @end menu @node Required Packages on GNU/Linux,,,GNU/Linux Topics @anchor{gnat_ugn/platform_specific_information id7}@anchor{1dc}@anchor{gnat_ugn/platform_specific_information required-packages-on-gnu-linux}@anchor{1dd} -@subsection Required Packages on GNU/Linux: +@subsection Required Packages on GNU/Linux GNAT requires the C library developer's package to be installed. @@ -23812,16 +23812,16 @@ Debian, Ubuntu: @code{libc6-dev} (normally installed by default). @end itemize If using the 32-bit version of GNAT on a 64-bit version of GNU/Linux, -you'll need the 32-bit version of that package instead: +you'll need the 32-bit version of the glibc and glibc-devel packages: @itemize * @item -RedHat, SUSE: @code{glibc-devel.i686}; +RedHat, SUSE: @code{glibc.i686}, @code{glibc-devel.i686} @item -Debian, Ubuntu: @code{libc6-dev:i386}. +Debian, Ubuntu: @code{libc6:i386}, @code{libc6-dev:i386} @end itemize Other GNU/Linux distributions might be choosing a different name @@ -27083,6 +27083,7 @@ GNAT, either automatically or with explicit programming features. * Dynamic Elaboration Model in GNAT:: * Static Elaboration Model in GNAT:: * SPARK Elaboration Model in GNAT:: +* Legacy Elaboration Model in GNAT:: * Mixing Elaboration Models:: * Elaboration Circularities:: * Resolving Elaboration Circularities:: @@ -27832,6 +27833,25 @@ region subject to SPARK_Mode On, otherwise the dynamic or static model is in effect. @end itemize +@geindex Legacy elaboration model + + +@itemize * + +@item +@emph{Legacy elaboration model} + +In addition to the three elabortaion models outlined above, GNAT provides the +elaboration model of pre-18.x versions referred to as @cite{legacy elaboration model}. The legacy elaboration model is enabled with compiler switch +@code{-gnatH}. +@end itemize + +@geindex Relaxed elaboration mode + +The dynamic, legacy, and static models can be relaxed using compiler switch +@code{-gnatJ}, making them more permissive. Note that in this mode, GNAT +may not diagnose certain elaboration issues or install run-time checks. + @node Common Elaboration-model Traits,Dynamic Elaboration Model in GNAT,Controlling the Elaboration Order in GNAT,Elaboration Order Handling in GNAT @anchor{gnat_ugn/elaboration_order_handling_in_gnat common-elaboration-model-traits}@anchor{23c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{23d} @section Common Elaboration-model Traits @@ -28101,7 +28121,7 @@ along with any additional dependencies that @code{Server} may require, are elaborated prior to the body of @code{Static_Model}. @end itemize -@node SPARK Elaboration Model in GNAT,Mixing Elaboration Models,Static Elaboration Model in GNAT,Elaboration Order Handling in GNAT +@node SPARK Elaboration Model in GNAT,Legacy Elaboration Model in GNAT,Static Elaboration Model in GNAT,Elaboration Order Handling in GNAT @anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{242}@anchor{gnat_ugn/elaboration_order_handling_in_gnat spark-elaboration-model-in-gnat}@anchor{243} @section SPARK Elaboration Model in GNAT @@ -28124,8 +28144,19 @@ external, and compiler switch @code{-gnatd.v} is in effect. 4. end SPARK_Model; @end example -@node Mixing Elaboration Models,Elaboration Circularities,SPARK Elaboration Model in GNAT,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{244}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{245} +@node Legacy Elaboration Model in GNAT,Mixing Elaboration Models,SPARK Elaboration Model in GNAT,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat legacy-elaboration-model-in-gnat}@anchor{244} +@section Legacy Elaboration Model in GNAT + + +The legacy elaboration model is provided for compatibility with code bases +developed with pre-18.x versions of GNAT. It is similar in functionality to +the dynamic and static models of post-18.x version of GNAT, but may differ +in terms of diagnostics and run-time checks. The legacy elaboration model is +enabled with compiler switch @code{-gnatH}. + +@node Mixing Elaboration Models,Elaboration Circularities,Legacy Elaboration Model in GNAT,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{245}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{246} @section Mixing Elaboration Models @@ -28169,7 +28200,7 @@ warning: "y.ads" which has static elaboration checks The warnings can be suppressed by binder switch @code{-ws}. @node Elaboration Circularities,Resolving Elaboration Circularities,Mixing Elaboration Models,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{246}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{247} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{247}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{248} @section Elaboration Circularities @@ -28228,7 +28259,7 @@ they @emph{with}, must be elaborated prior to @code{Client}. However, @code{Serv @code{Client}, and this leads to a circularity. @node Resolving Elaboration Circularities,Resolving Task Issues,Elaboration Circularities,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{248}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-elaboration-circularities}@anchor{249} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{249}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-elaboration-circularities}@anchor{24a} @section Resolving Elaboration Circularities @@ -28261,6 +28292,29 @@ generate an executable program that may or may not raise @code{Program_Error}, and it is the programmer's responsibility to ensure that it does not raise @code{Program_Error}. +If the compilation was performed using a post-18.x version of GNAT, consider +using the legacy elaboration model, in the following order: + + +@itemize - + +@item +Use the legacy static elaboration model, with compiler switch +@code{-gnatH}. + +@item +Use the legacy dynamic elaboration model, with compiler switches +@code{-gnatH} @code{-gnatE}. + +@item +Use the relaxed legacy static elaboration model, with compiler switches +@code{-gnatH} @code{-gnatJ}. + +@item +Use the relaxed legacy dynamic elaboration model, with compiler switches +@code{-gnatH} @code{-gnatJ} @code{-gnatE}. +@end itemize + @item @emph{Suppress all elaboration checks} @@ -28373,7 +28427,7 @@ run-time checks. @end itemize @node Resolving Task Issues,Elaboration-related Compiler Switches,Resolving Elaboration Circularities,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{24a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-task-issues}@anchor{24b} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{24b}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-task-issues}@anchor{24c} @section Resolving Task Issues @@ -28669,202 +28723,13 @@ static model will verify that no entry calls take place at elaboration time. @end itemize @node Elaboration-related Compiler Switches,Summary of Procedures for Elaboration Control,Resolving Task Issues,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{24c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id15}@anchor{24d} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{24d}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id15}@anchor{24e} @section Elaboration-related Compiler Switches GNAT has several switches that affect the elaboration model and consequently the elaboration order chosen by the binder. -@geindex -gnatdE (gnat) - - -@table @asis - -@item @code{-gnatdE} - -Elaboration checks on predefined units - -When this switch is in effect, GNAT will consider scenarios and targets that -come from the Ada, GNAT, Interfaces, and System hierarchies. This switch is -useful when a programmer has defined a custom grandchild of those packages. -@end table - -@geindex -gnatd.G (gnat) - - -@table @asis - -@item @code{-gnatd.G} - -Ignore calls through generic formal parameters for elaboration - -When this switch is in effect, GNAT will ignore calls that invoke generic -actual entries, operators, or subprograms via generic formal subprograms. As -a result, GNAT will not generate implicit @code{Elaborate} and @code{Elaborate_All} -pragmas, and run-time checks for such calls. Note that this switch does not -overlap with @code{-gnatdL}. - -@example -package body Ignore_Calls is - function ABE return Integer; - - generic - with function Gen_Formal return Integer; - package Gen is - Val : constant Integer := Gen_Formal; - end Gen; - - package Inst is new Gen (ABE); - - function ABE return Integer is - begin - ... - end ABE; -end Ignore_Calls; -@end example - -In the example above, the call to function @code{ABE} will be ignored because it -occurs during the elaboration of instance @code{Inst}, through a call to generic -formal subprogram @code{Gen_Formal}. -@end table - -@geindex -gnatdL (gnat) - - -@table @asis - -@item @code{-gnatdL} - -Ignore external calls from instances for elaboration - -When this switch is in effect, GNAT will ignore calls that originate from -within an instance and directly target an entry, operator, or subprogram -defined outside the instance. As a result, GNAT will not generate implicit -@code{Elaborate} and @code{Elaborate_All} pragmas, and run-time checks for such -calls. Note that this switch does not overlap with @code{-gnatd.G}. - -@example -package body Ignore_Calls is - function ABE return Integer; - - generic - package Gen is - Val : constant Integer := ABE; - end Gen; - - package Inst is new Gen; - - function ABE return Integer is - begin - ... - end ABE; -end Ignore_Calls; -@end example - -In the example above, the call to function @code{ABE} will be ignored because it -originates from within an instance and targets a subprogram defined outside -the instance. -@end table - -@geindex -gnatd.o (gnat) - - -@table @asis - -@item @code{-gnatd.o} - -Conservative elaboration order for indirect calls - -When this switch is in effect, GNAT will treat @code{'Access} of an entry, -operator, or subprogram as an immediate call to that target. As a result, -GNAT will generate implicit @code{Elaborate} and @code{Elaborate_All} pragmas as -well as run-time checks for such attribute references. - -@example - 1. package body Attribute_Call is - 2. function Func return Integer; - 3. type Func_Ptr is access function return Integer; - 4. - 5. Ptr : constant Func_Ptr := Func'Access; - | - >>> warning: cannot call "Func" before body seen - >>> warning: Program_Error may be raised at run time - >>> warning: body of unit "Attribute_Call" elaborated - >>> warning: "Access" of "Func" taken at line 5 - >>> warning: function "Func" called at line 5 - - 6. - 7. function Func return Integer is - 8. begin - 9. ... -10. end Func; -11. end Attribute_Call; -@end example - -In the example above, the elaboration of declaration @code{Ptr} is assigned -@code{Func'Access} before the body of @code{Func} has been elaborated. -@end table - -@geindex -gnatd.U (gnat) - - -@table @asis - -@item @code{-gnatd.U} - -Ignore indirect calls for static elaboration - -When this switch is in effect, GNAT will ignore @code{'Access} of an entry, -operator, or subprogram when the static model is in effect. -@end table - -@geindex -gnatd.v (gnat) - - -@table @asis - -@item @code{-gnatd.v} - -Enforce SPARK elaboration rules in SPARK code - -When this switch is in effect, GNAT will enforce the SPARK rules of -elaboration as defined in the SPARK Reference Manual, section 7.7. As a -result, constructs which violate the SPARK elaboration rules are no longer -accepted, even if GNAT is able to statically ensure that these constructs -will not lead to ABE problems. -@end table - -@geindex -gnatd.y (gnat) - - -@table @asis - -@item @code{-gnatd.y} - -Disable implicit pragma Elaborate[_All] on task bodies - -When this switch is in effect, GNAT will not generate @code{Elaborate} and -@code{Elaborate_All} pragmas if the need for the pragma came directly or -indirectly from a task body. - -@example -with Server; -package body Disable_Task is - task T; - - task body T is - begin - Server.Proc; - end T; -end Disable_Task; -@end example - -In the example above, the activation of single task @code{T} invokes -@code{Server.Proc}, which implies that @code{Server} requires @code{Elaborate_All}, -however GNAT will not generate the pragma. -@end table - @geindex -gnatE (gnat) @@ -28924,6 +28789,33 @@ a unit. This diagnostic requires compiler switch @code{-gnatd.v}. @end itemize @end table +@geindex -gnatH (gnat) + + +@table @asis + +@item @code{-gnatH} + +Legacy elaboration checking mode enabled + +When this switch is in effect, GNAT will utilize the pre-18.x elaboration +model. +@end table + +@geindex -gnatJ (gnat) + + +@table @asis + +@item @code{-gnatJ} + +Relaxed elaboration checking mode enabled + +When this switch is in effect, GNAT will not process certain scenarios +resulting in a more permissive elaboration model. Note that this may +eliminate some diagnostics and run-time checks. +@end table + @geindex -gnatw.f (gnat) @@ -29008,7 +28900,7 @@ checks. The example above will still fail at run time with an ABE. @end table @node Summary of Procedures for Elaboration Control,Inspecting the Chosen Elaboration Order,Elaboration-related Compiler Switches,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{24e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id16}@anchor{24f} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{24f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id16}@anchor{250} @section Summary of Procedures for Elaboration Control @@ -29016,6 +28908,7 @@ A programmer should first compile the program with the default options, using none of the binder or compiler switches. If the binder succeeds in finding an elaboration order, then apart from possible cases involing dispatching calls and access-to-subprogram types, the program is free of elaboration errors. + If it is important for the program to be portable to compilers other than GNAT, then the programmer should use compiler switch @code{-gnatel} and consider the messages about missing or implicitly created @code{Elaborate} and @@ -29028,9 +28921,11 @@ options: @itemize * @item -Ensure that warnings are enabled. This will allow the static model to output -trace information of elaboration issues. The trace information could shed -light on previously unforeseen dependencies, as well as their origins. +Ensure that elaboration warnings are enabled. This will allow the static +model to output trace information of elaboration issues. The trace +information could shed light on previously unforeseen dependencies, as well +as their origins. Elaboration warnings are enabled with compiler switch +@code{-gnatwl}. @item Use switch @code{-gnatel} to obtain messages on generated implicit @@ -29039,21 +28934,38 @@ indicate why a server unit must be elaborated prior to a client unit. @item If the warnings produced by the static model indicate that a task is -involved, consider the options in the section on resolving task issues as -well as compiler switch @code{-gnatd.y}. +involved, consider the options in section @ref{24b,,Resolving Task Issues}. @item -If the warnings produced by the static model indicate that an generic -instantiations are involved, consider using compiler switches -@code{-gnatd.G} and @code{-gnatdL}. +If none of the steps outlined above resolve the circularity, use a more +permissive elaboration model, in the following order: + + +@itemize - + +@item +Use the dynamic elaboration model, with compiler switch @code{-gnatE}. + +@item +Use the legacy static elaboration model, with compiler switch +@code{-gnatH}. @item -If none of the steps outlined above resolve the circularity, recompile the -program using the dynamic model by using compiler switch @code{-gnatE}. +Use the legacy dynamic elaboration model, with compiler switches +@code{-gnatH} @code{-gnatE}. + +@item +Use the relaxed legacy static elaboration model, with compiler switches +@code{-gnatH} @code{-gnatJ}. + +@item +Use the relaxed legacy dynamic elaboration model, with compiler switches +@code{-gnatH} @code{-gnatJ} @code{-gnatE}. +@end itemize @end itemize @node Inspecting the Chosen Elaboration Order,,Summary of Procedures for Elaboration Control,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat inspecting-the-chosen-elaboration-order}@anchor{250}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id17}@anchor{251} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat inspecting-the-chosen-elaboration-order}@anchor{251}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id17}@anchor{252} @section Inspecting the Chosen Elaboration Order @@ -29190,7 +29102,7 @@ gdbstr (body) @end example @node Inline Assembler,GNU Free Documentation License,Elaboration Order Handling in GNAT,Top -@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10}@anchor{gnat_ugn/inline_assembler doc}@anchor{252}@anchor{gnat_ugn/inline_assembler id1}@anchor{253} +@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10}@anchor{gnat_ugn/inline_assembler doc}@anchor{253}@anchor{gnat_ugn/inline_assembler id1}@anchor{254} @chapter Inline Assembler @@ -29249,7 +29161,7 @@ and with assembly language programming. @end menu @node Basic Assembler Syntax,A Simple Example of Inline Assembler,,Inline Assembler -@anchor{gnat_ugn/inline_assembler id2}@anchor{254}@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{255} +@anchor{gnat_ugn/inline_assembler id2}@anchor{255}@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{256} @section Basic Assembler Syntax @@ -29365,7 +29277,7 @@ Intel: Destination first; for example @code{mov eax, 4}@w{ } @node A Simple Example of Inline Assembler,Output Variables in Inline Assembler,Basic Assembler Syntax,Inline Assembler -@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{256}@anchor{gnat_ugn/inline_assembler id3}@anchor{257} +@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{257}@anchor{gnat_ugn/inline_assembler id3}@anchor{258} @section A Simple Example of Inline Assembler @@ -29514,7 +29426,7 @@ If there are no errors, @code{as} will generate an object file @code{nothing.out}. @node Output Variables in Inline Assembler,Input Variables in Inline Assembler,A Simple Example of Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id4}@anchor{258}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{259} +@anchor{gnat_ugn/inline_assembler id4}@anchor{259}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{25a} @section Output Variables in Inline Assembler @@ -29881,7 +29793,7 @@ end Get_Flags_3; @end quotation @node Input Variables in Inline Assembler,Inlining Inline Assembler Code,Output Variables in Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id5}@anchor{25a}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{25b} +@anchor{gnat_ugn/inline_assembler id5}@anchor{25b}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{25c} @section Input Variables in Inline Assembler @@ -29970,7 +29882,7 @@ _increment__incr.1: @end quotation @node Inlining Inline Assembler Code,Other Asm Functionality,Input Variables in Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id6}@anchor{25c}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{25d} +@anchor{gnat_ugn/inline_assembler id6}@anchor{25d}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{25e} @section Inlining Inline Assembler Code @@ -30041,7 +29953,7 @@ movl %esi,%eax thus saving the overhead of stack frame setup and an out-of-line call. @node Other Asm Functionality,,Inlining Inline Assembler Code,Inline Assembler -@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{25e}@anchor{gnat_ugn/inline_assembler id7}@anchor{25f} +@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{25f}@anchor{gnat_ugn/inline_assembler id7}@anchor{260} @section Other @code{Asm} Functionality @@ -30056,7 +29968,7 @@ and @code{Volatile}, which inhibits unwanted optimizations. @end menu @node The Clobber Parameter,The Volatile Parameter,,Other Asm Functionality -@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{260}@anchor{gnat_ugn/inline_assembler id8}@anchor{261} +@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{261}@anchor{gnat_ugn/inline_assembler id8}@anchor{262} @subsection The @code{Clobber} Parameter @@ -30120,7 +30032,7 @@ Use 'register' name @code{memory} if you changed a memory location @end itemize @node The Volatile Parameter,,The Clobber Parameter,Other Asm Functionality -@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{262}@anchor{gnat_ugn/inline_assembler id9}@anchor{263} +@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{263}@anchor{gnat_ugn/inline_assembler id9}@anchor{264} @subsection The @code{Volatile} Parameter @@ -30156,7 +30068,7 @@ to @code{True} only if the compiler's optimizations have created problems. @node GNU Free Documentation License,Index,Inline Assembler,Top -@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{264}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{265} +@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{265}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{266} @chapter GNU Free Documentation License diff --git a/gcc/ada/libgnat/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb index af11740..e8c14fa 100644 --- a/gcc/ada/libgnat/s-dwalin.adb +++ b/gcc/ada/libgnat/s-dwalin.adb @@ -578,14 +578,21 @@ package body System.Dwarf_Lines is Initialize_State_Machine (C); end if; - -- Read the next prologue + -- If we have reached the next prologue, read it. Beware of possibly + -- empty blocks. + + -- When testing for the end of section, beware of possible zero padding + -- at the end. Bail out as soon as there's not even room for at least a + -- DW_LNE_end_sequence, 3 bytes from Off to Off+2. This resolves to + -- Off+2 > Last_Offset_Within_Section, that is Off+2 > Section_Length-1, + -- or Off+3 > Section_Length. Tell (C.Lines, Off); while Off = C.Next_Prologue loop Initialize_State_Machine (C); Parse_Prologue (C); Tell (C.Lines, Off); - exit when Off + 4 >= Length (C.Lines); + exit when Off + 3 > Length (C.Lines); end loop; -- Test whether we're done @@ -595,7 +602,7 @@ package body System.Dwarf_Lines is -- We are finished when we either reach the end of the section, or we -- have reached zero padding at the end of the section. - if Prologue.Unit_Length = 0 or else Off + 4 >= Length (C.Lines) then + if Prologue.Unit_Length = 0 or else Off + 3 > Length (C.Lines) then Done := True; return; end if; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index b642b22..2a32b63 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -844,9 +844,9 @@ package Opt is Ignore_Unrecognized_VWY_Switches : Boolean := False; -- GNAT - -- Set True to ignore unrecognized y, V, w switches. Can be set True - -- by use of -gnateu, causing subsequent unrecognized switches to result - -- in a warning rather than an error. + -- Set True to ignore unrecognized y, V, w switches. Can be set True by + -- use of -gnateu, causing subsequent unrecognized switches to result in + -- a warning rather than an error. Implementation_Unit_Warnings : Boolean := True; -- GNAT @@ -936,6 +936,11 @@ package Opt is -- Set to True to enable leap seconds support in Ada.Calendar and its -- children. + Legacy_Elaboration_Checks : Boolean := False; + -- GNAT + -- Set to True when the pre-18.x access-before-elaboration model is to be + -- used. Modified by use of -gnatH. + Link_Only : Boolean := False; -- GNATMAKE, GPRBUILD -- Set to True to skip compile and bind steps (except when Bind_Only is @@ -1353,6 +1358,12 @@ package Opt is -- Set to True to enable compatibility mode with Rational compiler, and -- to accept renamings of implicit operations in their own scope. + Relaxed_Elaboration_Checks : Boolean := False; + -- GNAT + -- Set to True to ignore certain elaboration scenarios, thus making the + -- current ABE mechanism more permissive. This behavior is applicable to + -- both the default and the legacy ABE models. Modified by use of -gnatJ. + Relaxed_RM_Semantics : Boolean := False; -- GNAT -- Set to True to ignore some Ada semantic error to help parse legacy Ada diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index cc4e39c..91aa579 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -28,6 +28,7 @@ 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; @@ -875,6 +876,17 @@ package body Sem_Attr is Kill_Current_Values; end if; + -- In the static elaboration model, treat the attribute reference + -- as a subprogram call for elaboration purposes. Suppress this + -- treatment under debug flag. In any case, we are all done. + + if Legacy_Elaboration_Checks + and 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 diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index afa58f4..0865f7b 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -4611,6 +4611,19 @@ 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. + + if Legacy_Elaboration_Checks then + Set_Kill_Elaboration_Checks (Act_Decl_Id); + Set_Suppress_Elaboration_Warnings (Act_Decl_Id); + end if; + end if; + + if Legacy_Elaboration_Checks then + Check_Elab_Instantiation (N); end if; -- Save the scenario for later examination by the ABE Processing @@ -5300,9 +5313,17 @@ package body Sem_Ch12 is Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id)); if Nkind (Parent (N)) = N_Compilation_Unit then - Set_Kill_Elaboration_Checks (Act_Decl_Id); - Set_Is_Compilation_Unit (Anon_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 Legacy_Elaboration_Checks then + Set_Kill_Elaboration_Checks (Act_Decl_Id); + Set_Suppress_Elaboration_Warnings (Act_Decl_Id); + end if; + + Set_Is_Compilation_Unit (Anon_Id); Set_Cunit_Entity (Current_Sem_Unit, Pack_Id); end if; @@ -5652,6 +5673,12 @@ package body Sem_Ch12 is Set_Ignore_SPARK_Mode_Pragmas (Anon_Id); end if; + if Legacy_Elaboration_Checks + and then not Is_Intrinsic_Subprogram (Gen_Unit) + then + Check_Elab_Instantiation (N); + end if; + -- Save the scenario for later examination by the ABE Processing -- phase. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 7edac03..715e6da 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -8514,7 +8514,7 @@ package body Sem_Ch3 is Parent_Base := Base_Type (Parent_Type); end if; - -- AI05-0115 : if this is a derivation from a private type in some + -- AI05-0115: if this is a derivation from a private type in some -- other scope that may lead to invisible components for the derived -- type, mark it accordingly. @@ -21339,10 +21339,10 @@ package body Sem_Ch3 is if Nkind (S) /= N_Subtype_Indication then Find_Type (S); - -- No way to proceed if the subtype indication is malformed. - -- This will happen for example when the subtype indication in - -- an object declaration is missing altogether and the expression - -- is analyzed as if it were that indication. + -- No way to proceed if the subtype indication is malformed. This + -- will happen for example when the subtype indication in an object + -- declaration is missing altogether and the expression is analyzed + -- as if it were that indication. if not Is_Entity_Name (S) then return Any_Type; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index e7fc149..205f414 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -552,6 +552,7 @@ package body Sem_Ch5 is -- in-place. if Should_Transform_BIP_Assignment (Typ => T1) then + -- In certain cases involving user-defined concatenation operators, -- we need to resolve the right-hand side before transforming the -- assignment. @@ -580,10 +581,10 @@ package body Sem_Ch5 is end loop; end; - when N_Op + when N_Attribute_Reference | N_Expanded_Name | N_Identifier - | N_Attribute_Reference + | N_Op => null; @@ -987,6 +988,14 @@ package body Sem_Ch5 is Error_Msg_CRT ("composite assignment", N); end if; + -- Check elaboration warning for left side if not in elab code + + if Legacy_Elaboration_Checks + and not In_Subprogram_Or_Concurrent_Unit + then + Check_Elab_Assign (Lhs); + end if; + -- Save the scenario for later examination by the ABE Processing phase Record_Elaboration_Scenario (N); diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 2e035c7..be62256 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1148,6 +1148,10 @@ package body Sem_Ch7 is if Is_Comp_Unit then Set_Body_Required (Parent (N), Body_Required); + + if Legacy_Elaboration_Checks and not Body_Required then + Set_Suppress_Elaboration_Warnings (Id); + end if; end if; End_Package_Scope (Id); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 045b858..a51abd5 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -4229,6 +4229,16 @@ 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. + + if Legacy_Elaboration_Checks then + Set_Suppress_Elaboration_Warnings (New_S); + end if; end Attribute_Renaming; ---------------------- diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 23e6a10..99f2dd1 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Checks; use Checks; with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; @@ -31,22 +32,26 @@ with Errout; use Errout; with Exp_Ch11; use Exp_Ch11; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; +with Expander; use Expander; with Lib; use Lib; with Lib.Load; use Lib.Load; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; +with Output; use Output; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; +with Sem_Cat; use Sem_Cat; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; +with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Table; @@ -262,14 +267,13 @@ package body Sem_Elab is -- * Depending on the elaboration model in effect, perform the following -- actions: -- - -- - Dynamic model - Diagnose guaranteed ABEs and install run-time - -- conditional ABE checks. + -- - Dynamic model - Install run-time conditional ABE checks. -- -- - SPARK model - Enforce the SPARK elaboration rules -- - -- - Static model - Diagnose conditional/guaranteed ABEs, install - -- run-time conditional ABE checks, and guarantee the elaboration - -- of external units. + -- - Static model - Diagnose conditional ABEs, install run-time + -- conditional ABE checks, and guarantee the elaboration of + -- external units. -- -- * Examine nested scenarios -- @@ -372,6 +376,20 @@ package body Sem_Elab is -- The following switches may be used to control the behavior of the ABE -- mechanism. -- + -- -gnatd_a stop elaboration checks on accept or select statement + -- + -- The ABE mechanism stops the traversal of a task body when it + -- encounters an accept or a select statement. This behavior is + -- equivalent to restriction No_Entry_Calls_In_Elaboration_Code, + -- but without penalizing actual entry calls during elaboration. + -- + -- -gnatd_e ignore entry calls and requeue statements for elaboration + -- + -- The ABE mechanism does not generate N_Call_Marker nodes for + -- protected or task entry calls as well as requeue statements. + -- As a result, the calls and requeues are not recorded or + -- processed. + -- -- -gnatdE elaboration checks on predefined units -- -- The ABE mechanism considers scenarios which appear in internal @@ -384,21 +402,11 @@ package body Sem_Elab is -- actual subprograms through generic formal subprograms. As a -- result, the calls are not recorded or processed. -- - -- If switches -gnatd.G and -gnatdL are used together, then the - -- ABE mechanism effectively ignores all calls which cause the - -- elaboration flow to "leave" the instance. - -- - -- -gnatdL ignore external calls from instances for elaboration - -- - -- The ABE mechanism does not generate N_Call_Marker nodes for - -- calls which occur in expanded instances, do not invoke generic - -- actual subprograms through formal subprograms, and the target - -- is external to the instance. As a result, the calls are not - -- recorded or processed. + -- -gnatdL ignore activations and calls to instances for elaboration -- - -- If switches -gnatd.G and -gnatdL are used together, then the - -- ABE mechanism effectively ignores all calls which cause the - -- elaboration flow to "leave" the instance. + -- The ABE mechanism ignores calls and task activations when they + -- target a subprogram or task type defined an external instance. + -- As a result, the calls and task activations are not processed. -- -- -gnatd.o conservative elaboration order for indirect calls -- @@ -407,6 +415,23 @@ package body Sem_Elab is -- target. As a result, it performs ABE checks and diagnostics on -- the immediate call. -- + -- -gnatd_p ignore assertion pragmas for elaboration + -- + -- The ABE mechanism does not generate N_Call_Marker nodes for + -- calls to subprograms which verify the run-time semantics of + -- the following assertion pragmas: + -- + -- Invariant + -- Invariant'Class + -- Post + -- Post'Class + -- Postcondition + -- Type_Invariant + -- Type_Invariant_Class + -- + -- As a result, the assertion expressions of the pragmas will not + -- be processed. + -- -- -gnatd.U ignore indirect calls for static elaboration -- -- The ABE mechanism does not consider '[Unrestricted_]Access of @@ -444,6 +469,29 @@ package body Sem_Elab is -- -- The complementary switch for -gnatel. -- + -- -gnatH legacy elaboration checking mode enabled + -- + -- When this switch is in effect, the pre-18.x ABE model becomes + -- the defacto ABE model. This ammounts to cutting off all entry + -- points into the new ABE mechanism, and giving full control to + -- the old ABE mechanism. + -- + -- -gnatJ permissive elaboration checking mode enabled + -- + -- This switch activates the following switches: + -- + -- -gnatd_a + -- -gnatd_e + -- -gnatd.G + -- -gnatdL + -- -gnatd_p + -- -gnatd.U + -- -gnatd.y + -- + -- IMPORTANT: The behavior of the ABE mechanism becomes more + -- permissive at the cost of accurate diagnostics and runtime + -- ABE checks. + -- -- -gnatw.f turn on warnings for suspicious Subp'Access -- -- The ABE mechanism treats '[Unrestricted_]Access of an entry, @@ -507,8 +555,14 @@ package body Sem_Elab is -- -- 1) Add predicate Is_xxx. -- - -- 2) Update predicates Is_Ada_Semantic_Target, Is_Bridge_Target, or - -- Is_SPARK_Semantic_Target. If necessary, create a new category. + -- 2) Update the following predicates + -- + -- Is_Ada_Semantic_Target + -- Is_Assertion_Pragma_Target + -- Is_Bridge_Target + -- Is_SPARK_Semantic_Target + -- + -- If necessary, create a new category. -- -- 3) Update the appropriate Info_xxx routine. -- @@ -642,6 +696,38 @@ package body Sem_Elab is -- to pragma SPARK_Mode with value On, or starts one such region. end record; + -- The following type captures relevant attributes which pertain to the + -- state of the Processing phase. + + type Processing_Attributes is record + Suppress_Implicit_Pragmas : Boolean; + -- This flag is set when the Processing phase must not generate any + -- implicit Elaborate[_All] pragmas. + + Within_Initial_Condition : Boolean; + -- This flag is set when the Processing phase is currently examining a + -- scenario which was reached from an initial condition procedure. + + Within_Instance : Boolean; + -- This flag is set when the Processing phase is currently examining a + -- scenario which was reached from a scenario defined in an instance. + + Within_Partial_Finalization : Boolean; + -- This flag is set when the Processing phase is currently examining a + -- scenario which was reached from a partial finalization procedure. + + Within_Task_Body : Boolean; + -- This flag is set when the Processing phase is currently examining a + -- scenario which was reached from a task body. + end record; + + Initial_State : constant Processing_Attributes := + (Suppress_Implicit_Pragmas => False, + Within_Initial_Condition => False, + Within_Instance => False, + Within_Partial_Finalization => False, + Within_Task_Body => False); + -- The following type captures relevant attributes which pertain to a -- target. @@ -997,18 +1083,14 @@ package body Sem_Elab is -- Return the set of elaboration attributes associated with unit Unit_Id procedure Ensure_Prior_Elaboration - (N : Node_Id; - Unit_Id : Entity_Id; - Prag_Nam : Name_Id; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean); + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id; + State : Processing_Attributes); -- Guarantee the elaboration of unit Unit_Id with respect to the main unit -- by installing pragma Elaborate or Elaborate_All denoted by Prag_Nam. N - -- denotes the related scenario. The flags should be set when the need for - -- elaboration was initiated as follows: - -- - -- In_Partial_Fin - partial finalization procedure - -- In_Task_Body - task body + -- denotes the related scenario. State denotes the current state of the + -- Processing phase. procedure Ensure_Prior_Elaboration_Dynamic (N : Node_Id; @@ -1242,9 +1324,14 @@ package body Sem_Elab is function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean; pragma Inline (Is_Ada_Semantic_Target); - -- Determine whether arbitrary entity Id nodes a source or internally + -- Determine whether arbitrary entity Id denodes a source or internally -- generated subprogram which emulates Ada semantics. + function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean; + pragma Inline (Is_Assertion_Pragma_Target); + -- Determine whether arbitrary entity Id denotes a procedure which varifies + -- the run-time semantics of an assertion pragma. + function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean; pragma Inline (Is_Bodiless_Subprogram); -- Determine whether subprogram Subp_Id will never have a body @@ -1460,169 +1547,108 @@ package body Sem_Elab is generic with procedure Process_Single_Activation - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - In_Init_Cond : Boolean; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean); + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + State : Processing_Attributes); -- Perform ABE checks and diagnostics for task activation call Call -- which activates task Obj_Id. Call_Attrs are the attributes of the -- activation call. Task_Attrs are the attributes of the task type. - -- The flags should be set when the processing was initiated as follows: - -- - -- In_Init_Cond - initial condition procedure - -- In_Partial_Fin - partial finalization procedure - -- In_Task_Body - task body + -- State is the current state of the Processing phase. procedure Process_Activation_Generic - (Call : Node_Id; - Call_Attrs : Call_Attributes; - In_Init_Cond : Boolean; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean); + (Call : Node_Id; + Call_Attrs : Call_Attributes; + State : Processing_Attributes); -- Perform ABE checks and diagnostics for activation call Call by invoking -- routine Process_Single_Activation on each task object being activated. - -- Call_Attrs are the attributes of the activation call. The flags should - -- be set when the processing was initiated as follows: - -- - -- In_Init_Cond - initial condition procedure - -- In_Partial_Fin - partial finalization procedure - -- In_Task_Body - task body + -- Call_Attrs are the attributes of the activation call. State is the + -- current state of the Processing phase. procedure Process_Conditional_ABE - (N : Node_Id; - In_Init_Cond : Boolean := False; - In_Partial_Fin : Boolean := False; - In_Task_Body : Boolean := False); + (N : Node_Id; + State : Processing_Attributes := Initial_State); -- Top-level dispatcher for processing of various elaboration scenarios. - -- Perform conditional ABE checks and diagnostics for scenario N. The flags - -- should be set when the processing was initiated as follows: - -- - -- In_Init_Cond - initial condition procedure - -- In_Partial_Fin - partial finalization procedure - -- In_Task_Body - task body + -- Perform conditional ABE checks and diagnostics for scenario N. State + -- is the current state of the Processing phase. procedure Process_Conditional_ABE_Access - (Attr : Node_Id; - In_Init_Cond : Boolean; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean); + (Attr : Node_Id; + State : Processing_Attributes); -- Perform ABE checks and diagnostics for 'Access to entry, operator, or - -- subprogram denoted by Attr. The flags should be set when the processing - -- was initiated as follows: - -- - -- In_Init_Cond - initial condition procedure - -- In_Partial_Fin - partial finalization procedure - -- In_Task_Body - task body + -- subprogram denoted by Attr. State is the current state of the Processing + -- phase. procedure Process_Conditional_ABE_Activation_Impl - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - In_Init_Cond : Boolean; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean); + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + State : Processing_Attributes); -- Perform common conditional ABE checks and diagnostics for call Call -- which activates task Obj_Id ignoring the Ada or SPARK rules. Call_Attrs -- are the attributes of the activation call. Task_Attrs are the attributes - -- of the task type. The flags should be set when the processing was - -- initiated as follows: - -- - -- In_Init_Cond - initial condition procedure - -- In_Partial_Fin - partial finalization procedure - -- In_Task_Body - task body + -- of the task type. State is the current state of the Processing phase. procedure Process_Conditional_ABE_Call - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - In_Init_Cond : Boolean; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean); + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + State : Processing_Attributes); -- Top-level dispatcher for processing of calls. Perform ABE checks and -- diagnostics for call Call which invokes target Target_Id. Call_Attrs - -- are the attributes of the call. The flags should be set when the - -- processing was initiated as follows: - -- - -- In_Init_Cond - initial condition procedure - -- In_Partial_Fin - partial finalization procedure - -- In_Task_Body - task body + -- are the attributes of the call. State is the current state of the + -- Processing phase. procedure Process_Conditional_ABE_Call_Ada - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean); + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes; + State : Processing_Attributes); -- Perform ABE checks and diagnostics for call Call which invokes target -- Target_Id using the Ada rules. Call_Attrs are the attributes of the - -- call. Target_Attrs are attributes of the target. The flags should be - -- set when the processing was initiated as follows: - -- - -- In_Partial_Fin - partial finalization procedure - -- In_Task_Body - task body + -- call. Target_Attrs are attributes of the target. State is the current + -- state of the Processing phase. procedure Process_Conditional_ABE_Call_SPARK - (Call : Node_Id; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes; - In_Init_Cond : Boolean; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean); + (Call : Node_Id; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes; + State : Processing_Attributes); -- Perform ABE checks and diagnostics for call Call which invokes target -- Target_Id using the SPARK rules. Target_Attrs denotes the attributes of - -- the target. The flags should be set when the processing was initiated as - -- follows: - -- - -- In_Init_Cond - initial condition procedure - -- In_Partial_Fin - partial finalization procedure - -- In_Task_Body - task body + -- the target. State is the current state of the Processing phase. procedure Process_Conditional_ABE_Instantiation - (Exp_Inst : Node_Id; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean); + (Exp_Inst : Node_Id; + State : Processing_Attributes); -- Top-level dispatcher for processing of instantiations. Perform ABE - -- checks and diagnostics for expanded instantiation Exp_Inst. The flags - -- should be set when the processing was initiated as follows: - -- - -- In_Partial_Fin - partial finalization procedure - -- In_Task_Body - task body + -- checks and diagnostics for expanded instantiation Exp_Inst. State is + -- the current state of the Processing phase. procedure Process_Conditional_ABE_Instantiation_Ada - (Exp_Inst : Node_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean); + (Exp_Inst : Node_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes; + State : Processing_Attributes); -- Perform ABE checks and diagnostics for expanded instantiation Exp_Inst -- of generic Gen_Id using the Ada rules. Inst is the instantiation node. -- Inst_Attrs are the attributes of the instance. Gen_Attrs denotes the - -- attributes of the generic. The flags should be set when the processing - -- was initiated as follows: - -- - -- In_Partial_Fin - partial finalization procedure - -- In_Task_Body - task body + -- attributes of the generic. State is the current state of the Processing + -- phase. procedure Process_Conditional_ABE_Instantiation_SPARK - (Inst : Node_Id; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean); + (Inst : Node_Id; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes; + State : Processing_Attributes); -- Perform ABE checks and diagnostics for instantiation Inst of generic -- Gen_Id using the SPARK rules. Gen_Attrs denotes the attributes of the - -- generic. The flags should be set when the processing was initiated as - -- follows: - -- - -- In_Partial_Fin - partial finalization procedure - -- In_Task_Body - task body + -- generic. State is the current state of the Processing phase. procedure Process_Conditional_ABE_Variable_Assignment (Asmt : Node_Id); -- Top-level dispatcher for processing of variable assignments. Perform ABE @@ -1656,22 +1682,15 @@ package body Sem_Elab is -- guaranteed ABE. procedure Process_Guaranteed_ABE_Activation_Impl - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - In_Init_Cond : Boolean; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean); + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + State : Processing_Attributes); -- Perform common guaranteed ABE checks and diagnostics for call Call which -- activates task Obj_Id ignoring the Ada or SPARK rules. Call_Attrs are -- the attributes of the activation call. Task_Attrs are the attributes of - -- the task type. The following parameters are provided for compatibility - -- and are not used. - -- - -- In_Init_Cond - -- In_Partial_Fin - -- In_Task_Body + -- the task type. State is provided for compatibility and is not used. procedure Process_Guaranteed_ABE_Call (Call : Node_Id; @@ -1736,18 +1755,10 @@ package body Sem_Elab is pragma Inline (Static_Elaboration_Checks); -- Determine whether the static model is in effect - procedure Traverse_Body - (N : Node_Id; - In_Init_Cond : Boolean; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean); - -- Inspect the declarations and statements of subprogram body N for - -- suitable elaboration scenarios and process them. The flags should - -- be set when the processing was initiated as follows: - -- - -- In_Init_Cond - initial condition procedure - -- In_Partial_Fin - partial finalization procedure - -- In_Task_Body - task body + procedure Traverse_Body (N : Node_Id; State : Processing_Attributes); + -- Inspect the declarative and statement lists of subprogram body N for + -- suitable elaboration scenarios and process them. State is the current + -- state of the Processing phase. procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id); pragma Inline (Update_Elaboration_Scenario); @@ -1759,13 +1770,6 @@ package body Sem_Elab is ----------------------- procedure Build_Call_Marker (N : Node_Id) is - function In_External_Context - (Call : Node_Id; - Target_Id : Entity_Id) return Boolean; - pragma Inline (In_External_Context); - -- Determine whether target Target_Id is external to call N which must - -- reside within an instance. - function In_Premature_Context (Call : Node_Id) return Boolean; -- Determine whether call Call appears within a premature context @@ -1783,57 +1787,6 @@ package body Sem_Elab is -- Determine whether subprogram Subp_Id denotes a generic formal -- subprogram which appears in the "prologue" of an instantiation. - ------------------------- - -- In_External_Context -- - ------------------------- - - function In_External_Context - (Call : Node_Id; - Target_Id : Entity_Id) return Boolean - is - Target_Decl : constant Node_Id := Unit_Declaration_Node (Target_Id); - - Inst : Node_Id; - Inst_Body : Node_Id; - Inst_Decl : Node_Id; - - begin - -- Performance note: parent traversal - - Inst := Find_Enclosing_Instance (Call); - - -- The call appears within an instance - - if Present (Inst) then - - -- The call comes from the main unit and the target does not - - if In_Extended_Main_Code_Unit (Call) - and then not In_Extended_Main_Code_Unit (Target_Decl) - then - return True; - - -- Otherwise the target declaration must not appear within the - -- instance spec or body. - - else - Extract_Instance_Attributes - (Exp_Inst => Inst, - Inst_Decl => Inst_Decl, - Inst_Body => Inst_Body); - - -- Performance note: parent traversal - - return not In_Subtree - (N => Target_Decl, - Root1 => Inst_Decl, - Root2 => Inst_Body); - end if; - end if; - - return False; - end In_External_Context; - -------------------------- -- In_Premature_Context -- -------------------------- @@ -1936,18 +1889,26 @@ package body Sem_Elab is -- Local variables - Call_Attrs : Call_Attributes; - Call_Nam : Node_Id; - Marker : Node_Id; - Target_Id : Entity_Id; + Call_Attrs : Call_Attributes; + Call_Nam : Node_Id; + Marker : Node_Id; + Target_Attrs : Target_Attributes; + Target_Id : Entity_Id; -- Start of processing for Build_Call_Marker begin + -- Nothing to do when switch -gnatH (legacy elaboration checking mode + -- enabled) is in effect because the legacy ABE mechanism does not need + -- to carry out this action. + + if Legacy_Elaboration_Checks then + return; + -- Nothing to do for ASIS. As a result, ABE checks and diagnostics are -- not performed in this mode. - if ASIS_Mode then + elsif ASIS_Mode then return; -- Nothing to do when the call is being preanalyzed as the marker will @@ -1965,12 +1926,13 @@ package body Sem_Elab is then return; - -- Nothing to do when the call is analyzed/resolved too early within an - -- intermediate context. - - -- Performance note: parent traversal + -- Nothing to do when the input denotes entry call or requeue statement, + -- and switch -gnatd_e (ignore entry calls and requeue statements for + -- elaboration) is in effect. - elsif In_Premature_Context (N) then + elsif Debug_Flag_Underscore_E + and then Nkind_In (N, N_Entry_Call_Statement, N_Requeue_Statement) + then return; end if; @@ -1994,6 +1956,15 @@ package body Sem_Elab is and then Is_Generic_Formal_Subp (Entity (Call_Nam)) then return; + + -- Nothing to do when the call is analyzed/resolved too early within an + -- intermediate context. This check is saved for last because it incurs + -- a performance penalty. + + -- Performance note: parent traversal + + elsif In_Premature_Context (N) then + return; end if; Extract_Call_Attributes @@ -2001,33 +1972,29 @@ package body Sem_Elab is Target_Id => Target_Id, Attrs => Call_Attrs); - -- Nothing to do when the call appears within the expanded spec or - -- body of an instantiated generic, the call does not invoke a generic - -- formal subprogram, the target is external to the instance, and switch - -- -gnatdL (ignore external calls from instances for elaboration) is in - -- effect. This behaviour approximates that of the old ABE mechanism. - - if Debug_Flag_LL - and then not Is_Generic_Formal_Subp (Entity (Call_Nam)) + Extract_Target_Attributes + (Target_Id => Target_Id, + Attrs => Target_Attrs); - -- Performance note: parent traversal + -- Nothing to do when the call invokes an assertion pragma procedure + -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is + -- in effect. - and then In_External_Context - (Call => N, - Target_Id => Target_Id) + if Debug_Flag_Underscore_P + and then Is_Assertion_Pragma_Target (Target_Id) then return; -- Source calls to source targets are always considered because they -- reflect the original call graph. - elsif Comes_From_Source (Target_Id) and then Call_Attrs.From_Source then + elsif Target_Attrs.From_Source and then Call_Attrs.From_Source then null; -- A call to a source function which acts as the default expression in -- another call requires special detection. - elsif Comes_From_Source (Target_Id) + elsif Target_Attrs.From_Source and then Nkind (N) = N_Function_Call and then Is_Default_Expression (N) then @@ -2161,10 +2128,17 @@ package body Sem_Elab is -- Start of processing for Build_Variable_Reference_Marker begin + -- Nothing to do when switch -gnatH (legacy elaboration checking mode + -- enabled) is in effect because the legacy ABE mechanism does not need + -- to carry out this action. + + if Legacy_Elaboration_Checks then + return; + -- Nothing to do for ASIS. As a result, ABE checks and diagnostics are -- not performed in this mode. - if ASIS_Mode then + elsif ASIS_Mode then return; -- Nothing to do when the reference is being preanalyzed as the marker @@ -2260,10 +2234,17 @@ package body Sem_Elab is procedure Check_Elaboration_Scenarios is begin + -- Nothing to do when switch -gnatH (legacy elaboration checking mode + -- enabled) is in effect because the legacy ABE mechanism does not need + -- to carry out this action. + + if Legacy_Elaboration_Checks then + return; + -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics -- are performed in this mode. - if ASIS_Mode then + elsif ASIS_Mode then return; end if; @@ -2819,11 +2800,10 @@ package body Sem_Elab is else Ensure_Prior_Elaboration - (N => N, - Unit_Id => Find_Top_Unit (Constit_Id), - Prag_Nam => Name_Elaborate, - In_Partial_Fin => False, - In_Task_Body => False); + (N => N, + Unit_Id => Find_Top_Unit (Constit_Id), + Prag_Nam => Name_Elaborate, + State => Initial_State); end if; end if; end Check_SPARK_Constituent; @@ -3113,27 +3093,32 @@ package body Sem_Elab is ------------------------------ procedure Ensure_Prior_Elaboration - (N : Node_Id; - Unit_Id : Entity_Id; - Prag_Nam : Name_Id; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean) + (N : Node_Id; + Unit_Id : Entity_Id; + Prag_Nam : Name_Id; + State : Processing_Attributes) is begin pragma Assert (Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All)); + -- Nothing to do when the caller has suppressed the generation of + -- implicit Elaborate[_All] pragmas. + + if State.Suppress_Implicit_Pragmas then + return; + -- Nothing to do when the need for prior elaboration came from a partial -- finalization routine which occurs in an initialization context. This -- behaviour parallels that of the old ABE mechanism. - if In_Partial_Fin then + elsif State.Within_Partial_Finalization then return; -- Nothing to do when the need for prior elaboration came from a task -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on -- task bodies) is in effect. - elsif Debug_Flag_Dot_Y and then In_Task_Body then + elsif Debug_Flag_Dot_Y and then State.Within_Task_Body then return; -- Nothing to do when the unit is elaborated prior to the main unit. @@ -3393,9 +3378,6 @@ package body Sem_Elab is Loc : constant Source_Ptr := Sloc (Main_Cunit); Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id); - Is_Instantiation : constant Boolean := - Nkind (N) in N_Generic_Instantiation; - Clause : Node_Id; Elab_Attrs : Elaboration_Attributes; Items : List_Id; @@ -3468,14 +3450,10 @@ package body Sem_Elab is Append_To (Items, Clause); end if; - -- Instantiations require an implicit Elaborate because Elaborate_All is - -- too conservative and may introduce non-existent elaboration cycles. + -- Mark the with clause depending on the pragma required - if Is_Instantiation then + if Prag_Nam = Name_Elaborate then Set_Elaborate_Desirable (Clause); - - -- Otherwise generate an implicit Elaborate_All - else Set_Elaborate_All_Desirable (Clause); end if; @@ -6549,6 +6527,20 @@ package body Sem_Elab is or else Is_Task_Entry (Id); end Is_Ada_Semantic_Target; + -------------------------------- + -- Is_Assertion_Pragma_Target -- + -------------------------------- + + function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean is + begin + return + Is_Default_Initial_Condition_Proc (Id) + or else Is_Initial_Condition_Proc (Id) + or else Is_Invariant_Proc (Id) + or else Is_Partial_Invariant_Proc (Id) + or else Is_Postconditions_Proc (Id); + end Is_Assertion_Pragma_Target; + ---------------------------- -- Is_Bodiless_Subprogram -- ---------------------------- @@ -7528,6 +7520,14 @@ package body Sem_Elab is -- Start of processing for Kill_Elaboration_Scenario begin + -- Nothing to do when switch -gnatH (legacy elaboration checking mode + -- enabled) is in effect because the legacy ABE lechanism does not need + -- to carry out this action. + + if Legacy_Elaboration_Checks then + return; + end if; + -- Eliminate a recorded scenario when it appears within dead code -- because it will not be executed at elaboration time. @@ -8268,11 +8268,9 @@ package body Sem_Elab is -------------------------------- procedure Process_Activation_Generic - (Call : Node_Id; - Call_Attrs : Call_Attributes; - In_Init_Cond : Boolean; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean) + (Call : Node_Id; + Call_Attrs : Call_Attributes; + State : Processing_Attributes) is procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id); -- Perform ABE checks and diagnostics for object Obj_Id with type Typ. @@ -8300,13 +8298,11 @@ package body Sem_Elab is Attrs => Task_Attrs); Process_Single_Activation - (Call => Call, - Call_Attrs => Call_Attrs, - Obj_Id => Obj_Id, - Task_Attrs => Task_Attrs, - In_Init_Cond => In_Init_Cond, - In_Partial_Fin => In_Partial_Fin, - In_Task_Body => In_Task_Body); + (Call => Call, + Call_Attrs => Call_Attrs, + Obj_Id => Obj_Id, + Task_Attrs => Task_Attrs, + State => State); -- Examine the component type when the object is an array @@ -8420,10 +8416,8 @@ package body Sem_Elab is ------------------------------------ procedure Process_Conditional_ABE_Access - (Attr : Node_Id; - In_Init_Cond : Boolean; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean) + (Attr : Node_Id; + State : Processing_Attributes) is function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id; pragma Inline (Build_Access_Marker); @@ -8511,21 +8505,18 @@ package body Sem_Elab is if Debug_Flag_Dot_O then Process_Conditional_ABE - (N => Build_Access_Marker (Target_Id), - In_Init_Cond => In_Init_Cond, - In_Partial_Fin => In_Partial_Fin, - In_Task_Body => In_Task_Body); + (N => Build_Access_Marker (Target_Id), + State => State); -- Otherwise ensure that the unit with the corresponding body is -- elaborated prior to the main unit. else Ensure_Prior_Elaboration - (N => Attr, - Unit_Id => Target_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate_All, - In_Partial_Fin => In_Partial_Fin, - In_Task_Body => In_Task_Body); + (N => Attr, + Unit_Id => Target_Attrs.Unit_Id, + Prag_Nam => Name_Elaborate_All, + State => State); end if; end Process_Conditional_ABE_Access; @@ -8534,13 +8525,11 @@ package body Sem_Elab is --------------------------------------------- procedure Process_Conditional_ABE_Activation_Impl - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - In_Init_Cond : Boolean; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean) + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + State : Processing_Attributes) is Check_OK : constant Boolean := not Is_Ignored_Ghost_Entity (Obj_Id) @@ -8553,6 +8542,9 @@ package body Sem_Elab is Root : constant Node_Id := Root_Scenario; + New_State : Processing_Attributes := State; + -- Each step of the Processing phase constitutes a new state + begin -- Output relevant information when switch -gnatel (info messages on -- implicit Elaborate[_All] pragmas) is in effect. @@ -8562,16 +8554,27 @@ package body Sem_Elab is ("info: activation of & during elaboration", Call, Obj_Id); end if; + -- Nothing to do when the call activates a task whose type is defined + -- within an instance and switch -gnatdL (ignore activations and calls + -- to instances for elaboration) is in effect. + + if Debug_Flag_LL + and then In_External_Instance + (N => Call, + Target_Decl => Task_Attrs.Task_Decl) + then + return; + -- Nothing to do when the activation is a guaranteed ABE - if Is_Known_Guaranteed_ABE (Call) then + elsif Is_Known_Guaranteed_ABE (Call) then return; -- Nothing to do when the root scenario appears at the declaration -- level and the task is in the same unit, but outside this context. - + -- -- task type Task_Typ; -- task declaration - + -- -- procedure Proc is -- function A ... is -- begin @@ -8583,14 +8586,14 @@ package body Sem_Elab is -- end; -- ... -- end A; - + -- -- X : ... := A; -- root scenario -- ... - + -- -- task body Task_Typ is -- ... -- end Task_Typ; - + -- -- In the example above, the context of X is the declarative list of -- Proc. The "elaboration" of X may reach the activation of T whose body -- is defined outside of X's context. The task body is relevant only @@ -8604,29 +8607,24 @@ package body Sem_Elab is return; -- Nothing to do when the activation is ABE-safe - + -- -- generic -- package Gen is -- task type Task_Typ; -- end Gen; - + -- -- package body Gen is -- task body Task_Typ is -- begin -- ... -- end Task_Typ; -- end Gen; - + -- -- with Gen; -- procedure Main is -- package Nested is - -- ... - -- end Nested; - - -- package body Nested is -- package Inst is new Gen; -- T : Inst.Task_Typ; - -- [begin] -- <activation call> -- safe activation -- end Nested; -- ... @@ -8645,33 +8643,27 @@ package body Sem_Elab is then -- If the root scenario appears prior to the task body, then this is -- a possible ABE with respect to the root scenario. - + -- -- task type Task_Typ; - + -- -- function A ... is -- begin -- if Some_Condition then -- declare -- package Pack is - -- ... - -- end Pack; - - -- package body Pack is -- T : Task_Typ; - -- [begin] - -- <activation call> -- activation of T - -- end Pack; + -- end Pack; -- activation of T -- ... -- end A; - + -- -- X : ... := A; -- root scenario - + -- -- task body Task_Typ is -- task body -- ... -- end Task_Typ; - + -- -- Y : ... := A; -- root scenario - + -- -- IMPORTANT: The activation of T is a possible ABE for X, but -- not for Y. Intalling an unconditional ABE raise prior to the -- activation call would be wrong as it will fail for Y as well @@ -8683,7 +8675,7 @@ package body Sem_Elab is -- a partial finalization context because this leads to confusing -- noise. - if In_Partial_Fin then + if State.Within_Partial_Finalization then null; -- ABE diagnostics are emitted only in the static model because @@ -8714,6 +8706,40 @@ package body Sem_Elab is Target_Id => Task_Attrs.Spec_Id, Target_Decl => Task_Attrs.Task_Decl, Target_Body => Task_Attrs.Body_Decl); + + -- Update the state of the Processing phase to indicate that + -- no implicit Elaborate[_All] pragmas must be generated from + -- this point on. + -- + -- task type Task_Typ; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- declare + -- package Pack is + -- <ABE check> + -- T : Task_Typ; + -- end Pack; -- activation of T + -- ... + -- end A; + -- + -- X : ... := A; + -- + -- task body Task_Typ is + -- begin + -- External.Subp; -- imparts Elaborate_All + -- end Task_Typ; + -- + -- If Some_Condition is True, then the ABE check will fail at + -- runtime and the call to External.Subp will never take place, + -- rendering the implicit Elaborate_All useless. + -- + -- If Some_Condition is False, then the call to External.Subp + -- will never take place, rendering the implicit Elaborate_All + -- useless. + + New_State.Suppress_Implicit_Pragmas := True; end if; end if; @@ -8729,6 +8755,11 @@ package body Sem_Elab is Id => Task_Attrs.Unit_Id); end if; + -- Update the state of the Processing phase to indicate that any further + -- traversal is now within a task body. + + New_State.Within_Task_Body := True; + -- Both the activation call and task type are subject to SPARK_Mode -- On, this triggers the SPARK rules for task activation. Compared to -- calls and instantiations, task activation in SPARK does not require @@ -8745,18 +8776,15 @@ package body Sem_Elab is else Ensure_Prior_Elaboration - (N => Call, - Unit_Id => Task_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate_All, - In_Partial_Fin => In_Partial_Fin, - In_Task_Body => In_Task_Body); + (N => Call, + Unit_Id => Task_Attrs.Unit_Id, + Prag_Nam => Name_Elaborate_All, + State => New_State); end if; Traverse_Body - (N => Task_Attrs.Body_Decl, - In_Init_Cond => In_Init_Cond, - In_Partial_Fin => In_Partial_Fin, - In_Task_Body => True); + (N => Task_Attrs.Body_Decl, + State => New_State); end Process_Conditional_ABE_Activation_Impl; procedure Process_Conditional_ABE_Activation is @@ -8767,12 +8795,10 @@ package body Sem_Elab is ---------------------------------- procedure Process_Conditional_ABE_Call - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - In_Init_Cond : Boolean; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean) + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + State : Processing_Attributes) is function In_Initialization_Context (N : Node_Id) return Boolean; -- Determine whether arbitrary node N appears within a type init proc, @@ -8852,11 +8878,12 @@ package body Sem_Elab is -- Local variables - Init_Cond_On : Boolean; - Partial_Fin_On : Boolean; SPARK_Rules_On : Boolean; Target_Attrs : Target_Attributes; + New_State : Processing_Attributes := State; + -- Each step of the Processing phase constitutes a new state + -- Start of processing for Process_Conditional_ABE_Call begin @@ -8864,20 +8891,6 @@ package body Sem_Elab is (Target_Id => Target_Id, Attrs => Target_Attrs); - -- The call occurs in an initial condition context when a prior - -- scenario is already in that mode, or when the target denotes - -- an Initial_Condition procedure. - - Init_Cond_On := - In_Init_Cond or else Is_Initial_Condition_Proc (Target_Id); - - -- The call occurs in a partial finalization context when a prior - -- scenario is already in that mode, or when the target denotes a - -- [Deep_]Finalize primitive or a finalizer within an initialization - -- context. - - Partial_Fin_On := In_Partial_Fin or else Is_Partial_Finalization_Proc; - -- The SPARK rules are in effect when both the call and target are -- subject to SPARK_Mode On. @@ -8910,16 +8923,27 @@ package body Sem_Elab is return; end if; + -- Nothing to do when the call invokes a target defined within an + -- instance and switch -gnatdL (ignore activations and calls to + -- instances for elaboration) is in effect. + + if Debug_Flag_LL + and then In_External_Instance + (N => Call, + Target_Decl => Target_Attrs.Spec_Decl) + then + return; + -- Nothing to do when the call is a guaranteed ABE - if Is_Known_Guaranteed_ABE (Call) then + elsif Is_Known_Guaranteed_ABE (Call) then return; -- Nothing to do when the root scenario appears at the declaration level -- and the target is in the same unit, but outside this context. - + -- -- function B ...; -- target declaration - + -- -- procedure Proc is -- function A ... is -- begin @@ -8927,14 +8951,14 @@ package body Sem_Elab is -- return B; -- call site -- ... -- end A; - + -- -- X : ... := A; -- root scenario -- ... - + -- -- function B ... is -- ... -- end B; - + -- -- In the example above, the context of X is the declarative region of -- Proc. The "elaboration" of X may eventually reach B which is defined -- outside of X's context. B is relevant only when Proc is invoked, but @@ -8945,47 +8969,58 @@ package body Sem_Elab is elsif Is_Up_Level_Target (Target_Attrs.Spec_Decl) then return; + end if; + + -- The call occurs in an initial condition context when a prior scenario + -- is already in that mode, or when the target is an Initial_Condition + -- procedure. Update the state of the Processing phase to reflect this. + + New_State.Within_Initial_Condition := + New_State.Within_Initial_Condition + or else Is_Initial_Condition_Proc (Target_Id); + + -- The call occurs in a partial finalization context when a prior + -- scenario is already in that mode, or when the target denotes a + -- [Deep_]Finalize primitive or a finalizer within an initialization + -- context. Update the state of the Processing phase to reflect this. + + New_State.Within_Partial_Finalization := + New_State.Within_Partial_Finalization + or else Is_Partial_Finalization_Proc; -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK -- elaboration rules in SPARK code) is intentionally not taken into -- account here because Process_Conditional_ABE_Call_SPARK has two -- separate modes of operation. - elsif SPARK_Rules_On then + if SPARK_Rules_On then Process_Conditional_ABE_Call_SPARK - (Call => Call, - Target_Id => Target_Id, - Target_Attrs => Target_Attrs, - In_Init_Cond => Init_Cond_On, - In_Partial_Fin => Partial_Fin_On, - In_Task_Body => In_Task_Body); + (Call => Call, + Target_Id => Target_Id, + Target_Attrs => Target_Attrs, + State => New_State); -- Otherwise the Ada rules are in effect else Process_Conditional_ABE_Call_Ada - (Call => Call, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id, - Target_Attrs => Target_Attrs, - In_Partial_Fin => Partial_Fin_On, - In_Task_Body => In_Task_Body); + (Call => Call, + Call_Attrs => Call_Attrs, + Target_Id => Target_Id, + Target_Attrs => Target_Attrs, + State => New_State); end if; -- Inspect the target body (and barried function) for other suitable -- elaboration scenarios. Traverse_Body - (N => Target_Attrs.Body_Barf, - In_Init_Cond => Init_Cond_On, - In_Partial_Fin => Partial_Fin_On, - In_Task_Body => In_Task_Body); + (N => Target_Attrs.Body_Barf, + State => New_State); Traverse_Body - (N => Target_Attrs.Body_Decl, - In_Init_Cond => Init_Cond_On, - In_Partial_Fin => Partial_Fin_On, - In_Task_Body => In_Task_Body); + (N => Target_Attrs.Body_Decl, + State => New_State); end Process_Conditional_ABE_Call; -------------------------------------- @@ -8993,12 +9028,11 @@ package body Sem_Elab is -------------------------------------- procedure Process_Conditional_ABE_Call_Ada - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean) + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes; + State : Processing_Attributes) is Check_OK : constant Boolean := not Call_Attrs.Ghost_Mode_Ignore @@ -9011,6 +9045,9 @@ package body Sem_Elab is Root : constant Node_Id := Root_Scenario; + New_State : Processing_Attributes := State; + -- Each step of the Processing phase constitutes a new state + begin -- Nothing to do for an Ada dispatching call because there are no ABE -- diagnostics for either models. ABE checks for the dynamic model are @@ -9020,15 +9057,15 @@ package body Sem_Elab is return; -- Nothing to do when the call is ABE-safe - + -- -- generic -- function Gen ...; - + -- -- function Gen ... is -- begin -- ... -- end Gen; - + -- -- with Gen; -- procedure Main is -- function Inst is new Gen; @@ -9045,24 +9082,24 @@ package body Sem_Elab is then -- If the root scenario appears prior to the target body, then this -- is a possible ABE with respect to the root scenario. - + -- -- function B ...; - + -- -- function A ... is -- begin -- if Some_Condition then -- return B; -- call site -- ... -- end A; - + -- -- X : ... := A; -- root scenario - + -- -- function B ... is -- target body -- ... -- end B; - + -- -- Y : ... := A; -- root scenario - + -- -- IMPORTANT: The call to B from A is a possible ABE for X, but not -- for Y. Installing an unconditional ABE raise prior to the call to -- B would be wrong as it will fail for Y as well, but in Y's case @@ -9074,7 +9111,7 @@ package body Sem_Elab is -- partial finalization context because this leads to confusing -- noise. - if In_Partial_Fin then + if State.Within_Partial_Finalization then null; -- ABE diagnostics are emitted only in the static model because @@ -9102,6 +9139,36 @@ package body Sem_Elab is Target_Id => Target_Attrs.Spec_Id, Target_Decl => Target_Attrs.Spec_Decl, Target_Body => Target_Attrs.Body_Decl); + + -- Update the state of the Processing phase to indicate that + -- no implicit Elaborate[_All] pragmas must be generated from + -- this point on. + -- + -- function B ...; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- <ABE check> + -- return B; + -- ... + -- end A; + -- + -- X : ... := A; + -- + -- function B ... is + -- External.Subp; -- imparts Elaborate_All + -- end B; + -- + -- If Some_Condition is True, then the ABE check will fail at + -- runtime and the call to External.Subp will never take place, + -- rendering the implicit Elaborate_All useless. + -- + -- If Some_Condition is False, then the call to External.Subp + -- will never take place, rendering the implicit Elaborate_All + -- useless. + + New_State.Suppress_Implicit_Pragmas := True; end if; end if; @@ -9124,11 +9191,10 @@ package body Sem_Elab is if Call_Attrs.Elab_Checks_OK then Ensure_Prior_Elaboration - (N => Call, - Unit_Id => Target_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate_All, - In_Partial_Fin => In_Partial_Fin, - In_Task_Body => In_Task_Body); + (N => Call, + Unit_Id => Target_Attrs.Unit_Id, + Prag_Nam => Name_Elaborate_All, + State => New_State); end if; end Process_Conditional_ABE_Call_Ada; @@ -9137,12 +9203,10 @@ package body Sem_Elab is ---------------------------------------- procedure Process_Conditional_ABE_Call_SPARK - (Call : Node_Id; - Target_Id : Entity_Id; - Target_Attrs : Target_Attributes; - In_Init_Cond : Boolean; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean) + (Call : Node_Id; + Target_Id : Entity_Id; + Target_Attrs : Target_Attributes; + State : Processing_Attributes) is Region : Node_Id; @@ -9154,24 +9218,24 @@ package body Sem_Elab is then -- If the call appears prior to the target body, then the call must -- appear within the early call region of the target body. - + -- -- function B ...; - + -- -- X : ... := B; -- call site - + -- -- <preelaborable construct 1> --+ -- ... | early call region -- <preelaborable construct N> --+ - + -- -- function B ... is -- target body -- ... -- end B; - + -- -- When the call to B is not nested within some other scenario, the -- call is automatically illegal because it can never appear in the -- early call region of B's body. This is equivalent to a guaranteed -- ABE. - + -- -- <preelaborable construct 1> --+ -- | -- function B ...; | @@ -9184,22 +9248,22 @@ package body Sem_Elab is -- end A; | -- | -- <preelaborable construct N> --+ - + -- -- function B ... is -- target body -- ... -- end B; - + -- -- When the call to B is nested within some other scenario, the call -- is always ABE-safe. It is not immediately obvious why this is the -- case. The elaboration safety follows from the early call region -- rule being applied to ALL calls preceding their associated bodies. - + -- -- In the example above, the call to B is safe as long as the call to -- A is safe. There are several cases to consider: - + -- -- <call 1 to A> -- function B ...; - + -- -- <call 2 to A> -- function A ... is -- begin @@ -9207,17 +9271,17 @@ package body Sem_Elab is -- return B; -- ... -- end A; - + -- -- <call 3 to A> -- function B ... is -- ... -- end B; - + -- -- * Call 1 - This call is either nested within some scenario or not, -- which falls under the two general cases outlined above. - + -- -- * Call 2 - This is the same case as Call 1. - + -- -- * Call 3 - The placement of this call limits the range of B's -- early call region unto call 3, therefore the call to B is no -- longer within the early call region of B's body, making it ABE- @@ -9229,14 +9293,14 @@ package body Sem_Elab is -- initial condition context because this leads to incorrect -- diagnostics. - if In_Init_Cond then + if State.Within_Initial_Condition then null; -- Do not emit any ABE diagnostics when the call occurs in a -- partial finalization context because this leads to confusing -- noise. - elsif In_Partial_Fin then + elsif State.Within_Partial_Finalization then null; -- ABE diagnostics are emitted only in the static model because @@ -9308,11 +9372,10 @@ package body Sem_Elab is else Ensure_Prior_Elaboration - (N => Call, - Unit_Id => Target_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate_All, - In_Partial_Fin => In_Partial_Fin, - In_Task_Body => In_Task_Body); + (N => Call, + Unit_Id => Target_Attrs.Unit_Id, + Prag_Nam => Name_Elaborate_All, + State => State); end if; end Process_Conditional_ABE_Call_SPARK; @@ -9321,9 +9384,8 @@ package body Sem_Elab is ------------------------------------------- procedure Process_Conditional_ABE_Instantiation - (Exp_Inst : Node_Id; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean) + (Exp_Inst : Node_Id; + State : Processing_Attributes) is Gen_Attrs : Target_Attributes; Gen_Id : Entity_Id; @@ -9367,10 +9429,10 @@ package body Sem_Elab is -- Nothing to do when the root scenario appears at the declaration level -- and the generic is in the same unit, but outside this context. - + -- -- generic -- procedure Gen is ...; -- generic declaration - + -- -- procedure Proc is -- function A ... is -- begin @@ -9380,14 +9442,14 @@ package body Sem_Elab is -- ... -- ... -- end A; - + -- -- X : ... := A; -- root scenario -- ... - + -- -- procedure Gen is -- ... -- end Gen; - + -- -- In the example above, the context of X is the declarative region of -- Proc. The "elaboration" of X may eventually reach Gen which appears -- outside of X's context. Gen is relevant only when Proc is invoked, @@ -9403,24 +9465,22 @@ package body Sem_Elab is elsif SPARK_Rules_On then Process_Conditional_ABE_Instantiation_SPARK - (Inst => Inst, - Gen_Id => Gen_Id, - Gen_Attrs => Gen_Attrs, - In_Partial_Fin => In_Partial_Fin, - In_Task_Body => In_Task_Body); + (Inst => Inst, + Gen_Id => Gen_Id, + Gen_Attrs => Gen_Attrs, + State => State); -- Otherwise the Ada rules are in effect, or SPARK code is allowed to -- violate the SPARK rules. else Process_Conditional_ABE_Instantiation_Ada - (Exp_Inst => Exp_Inst, - Inst => Inst, - Inst_Attrs => Inst_Attrs, - Gen_Id => Gen_Id, - Gen_Attrs => Gen_Attrs, - In_Partial_Fin => In_Partial_Fin, - In_Task_Body => In_Task_Body); + (Exp_Inst => Exp_Inst, + Inst => Inst, + Inst_Attrs => Inst_Attrs, + Gen_Id => Gen_Id, + Gen_Attrs => Gen_Attrs, + State => State); end if; end Process_Conditional_ABE_Instantiation; @@ -9429,13 +9489,12 @@ package body Sem_Elab is ----------------------------------------------- procedure Process_Conditional_ABE_Instantiation_Ada - (Exp_Inst : Node_Id; - Inst : Node_Id; - Inst_Attrs : Instantiation_Attributes; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean) + (Exp_Inst : Node_Id; + Inst : Node_Id; + Inst_Attrs : Instantiation_Attributes; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes; + State : Processing_Attributes) is Check_OK : constant Boolean := not Inst_Attrs.Ghost_Mode_Ignore @@ -9446,20 +9505,23 @@ package body Sem_Elab is -- the generic have active elaboration checks and both are not ignored -- Ghost constructs. + New_State : Processing_Attributes := State; + -- Each step of the Processing phase constitutes a new state + Root : constant Node_Id := Root_Scenario; begin -- Nothing to do when the instantiation is ABE-safe - + -- -- generic -- package Gen is -- ... -- end Gen; - + -- -- package body Gen is -- ... -- end Gen; - + -- -- with Gen; -- procedure Main is -- package Inst is new Gen (ABE); -- safe instantiation @@ -9475,12 +9537,12 @@ package body Sem_Elab is then -- If the root scenario appears prior to the generic body, then this -- is a possible ABE with respect to the root scenario. - + -- -- generic -- package Gen is -- ... -- end Gen; - + -- -- function A ... is -- begin -- if Some_Condition then @@ -9488,15 +9550,15 @@ package body Sem_Elab is -- package Inst is new Gen; -- instantiation site -- ... -- end A; - + -- -- X : ... := A; -- root scenario - + -- -- package body Gen is -- generic body -- ... -- end Gen; - + -- -- Y : ... := A; -- root scenario - + -- -- IMPORTANT: The instantiation of Gen is a possible ABE for X, but -- not for Y. Installing an unconditional ABE raise prior to the -- instance site would be wrong as it will fail for Y as well, but in @@ -9508,7 +9570,7 @@ package body Sem_Elab is -- in partial finalization context because this leads to unwanted -- noise. - if In_Partial_Fin then + if State.Within_Partial_Finalization then null; -- ABE diagnostics are emitted only in the static model because @@ -9536,6 +9598,40 @@ package body Sem_Elab is Target_Id => Gen_Attrs.Spec_Id, Target_Decl => Gen_Attrs.Spec_Decl, Target_Body => Gen_Attrs.Body_Decl); + + -- Update the state of the Processing phase to indicate that + -- no implicit Elaborate[_All] pragmas must be generated from + -- this point on. + -- + -- generic + -- package Gen is + -- ... + -- end Gen; + -- + -- function A ... is + -- begin + -- if Some_Condition then + -- <ABE check> + -- declare Inst is new Gen; + -- ... + -- end A; + -- + -- X : ... := A; + -- + -- package body Gen is + -- begin + -- External.Subp; -- imparts Elaborate_All + -- end Gen; + -- + -- If Some_Condition is True, then the ABE check will fail at + -- runtime and the call to External.Subp will never take place, + -- rendering the implicit Elaborate_All useless. + -- + -- If Some_Condition is False, then the call to External.Subp + -- will never take place, rendering the implicit Elaborate_All + -- useless. + + New_State.Suppress_Implicit_Pragmas := True; end if; end if; @@ -9552,17 +9648,16 @@ package body Sem_Elab is end if; -- Ensure that the unit with the generic body is elaborated prior to - -- the main unit. No implicit pragma Elaborate is generated if the - -- instantiation has elaboration checks suppressed. This behaviour - -- parallels that of the old ABE mechanism. + -- the main unit. No implicit pragma is generated if the instantiation + -- has elaboration checks suppressed. This behaviour parallels that of + -- the old ABE mechanism. if Inst_Attrs.Elab_Checks_OK then Ensure_Prior_Elaboration - (N => Inst, - Unit_Id => Gen_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate, - In_Partial_Fin => In_Partial_Fin, - In_Task_Body => In_Task_Body); + (N => Inst, + Unit_Id => Gen_Attrs.Unit_Id, + Prag_Nam => Name_Elaborate, + State => New_State); end if; end Process_Conditional_ABE_Instantiation_Ada; @@ -9571,11 +9666,10 @@ package body Sem_Elab is ------------------------------------------------- procedure Process_Conditional_ABE_Instantiation_SPARK - (Inst : Node_Id; - Gen_Id : Entity_Id; - Gen_Attrs : Target_Attributes; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean) + (Inst : Node_Id; + Gen_Id : Entity_Id; + Gen_Attrs : Target_Attributes; + State : Processing_Attributes) is Req_Nam : Name_Id; @@ -9607,11 +9701,10 @@ package body Sem_Elab is else Ensure_Prior_Elaboration - (N => Inst, - Unit_Id => Gen_Attrs.Unit_Id, - Prag_Nam => Name_Elaborate, - In_Partial_Fin => In_Partial_Fin, - In_Task_Body => In_Task_Body); + (N => Inst, + Unit_Id => Gen_Attrs.Unit_Id, + Prag_Nam => Name_Elaborate, + State => State); end if; end Process_Conditional_ABE_Instantiation_SPARK; @@ -9816,10 +9909,8 @@ package body Sem_Elab is -- Placing the body in alphabetical order will result in a guaranteed ABE. procedure Process_Conditional_ABE - (N : Node_Id; - In_Init_Cond : Boolean := False; - In_Partial_Fin : Boolean := False; - In_Task_Body : Boolean := False) + (N : Node_Id; + State : Processing_Attributes := Initial_State) is Call_Attrs : Call_Attributes; Target_Id : Entity_Id; @@ -9833,12 +9924,10 @@ package body Sem_Elab is if Is_Suitable_Access (N) then Process_Conditional_ABE_Access - (Attr => N, - In_Init_Cond => In_Init_Cond, - In_Partial_Fin => In_Partial_Fin, - In_Task_Body => In_Task_Body); + (Attr => N, + State => State); - -- Calls + -- Activations and calls elsif Is_Suitable_Call (N) then @@ -9857,20 +9946,16 @@ package body Sem_Elab is if Is_Activation_Proc (Target_Id) then Process_Conditional_ABE_Activation - (Call => N, - Call_Attrs => Call_Attrs, - In_Init_Cond => In_Init_Cond, - In_Partial_Fin => In_Partial_Fin, - In_Task_Body => In_Task_Body); + (Call => N, + Call_Attrs => Call_Attrs, + State => State); else Process_Conditional_ABE_Call - (Call => N, - Call_Attrs => Call_Attrs, - Target_Id => Target_Id, - In_Init_Cond => In_Init_Cond, - In_Partial_Fin => In_Partial_Fin, - In_Task_Body => In_Task_Body); + (Call => N, + Call_Attrs => Call_Attrs, + Target_Id => Target_Id, + State => State); end if; end if; @@ -9878,9 +9963,8 @@ package body Sem_Elab is elsif Is_Suitable_Instantiation (N) then Process_Conditional_ABE_Instantiation - (Exp_Inst => N, - In_Partial_Fin => In_Partial_Fin, - In_Task_Body => In_Task_Body); + (Exp_Inst => N, + State => State); -- Variable assignments @@ -9915,17 +9999,13 @@ package body Sem_Elab is -------------------------------------------- procedure Process_Guaranteed_ABE_Activation_Impl - (Call : Node_Id; - Call_Attrs : Call_Attributes; - Obj_Id : Entity_Id; - Task_Attrs : Task_Attributes; - In_Init_Cond : Boolean; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean) + (Call : Node_Id; + Call_Attrs : Call_Attributes; + Obj_Id : Entity_Id; + Task_Attrs : Task_Attributes; + State : Processing_Attributes) is - pragma Unreferenced (In_Init_Cond); - pragma Unreferenced (In_Partial_Fin); - pragma Unreferenced (In_Task_Body); + pragma Unreferenced (State); Check_OK : constant Boolean := not Is_Ignored_Ghost_Entity (Obj_Id) @@ -9939,9 +10019,9 @@ package body Sem_Elab is begin -- Nothing to do when the root scenario appears at the declaration -- level and the task is in the same unit, but outside this context. - + -- -- task type Task_Typ; -- task declaration - + -- -- procedure Proc is -- function A ... is -- begin @@ -9953,14 +10033,14 @@ package body Sem_Elab is -- end; -- ... -- end A; - + -- -- X : ... := A; -- root scenario -- ... - + -- -- task body Task_Typ is -- ... -- end Task_Typ; - + -- -- In the example above, the context of X is the declarative list of -- Proc. The "elaboration" of X may reach the activation of T whose body -- is defined outside of X's context. The task body is relevant only @@ -9974,31 +10054,25 @@ package body Sem_Elab is return; -- Nothing to do when the activation is ABE-safe - + -- -- generic -- package Gen is -- task type Task_Typ; -- end Gen; - + -- -- package body Gen is -- task body Task_Typ is -- begin -- ... -- end Task_Typ; -- end Gen; - + -- -- with Gen; -- procedure Main is -- package Nested is - -- ... - -- end Nested; - - -- package body Nested is -- package Inst is new Gen; -- T : Inst.Task_Typ; - -- [begin] - -- <activation call> -- safe activation - -- end Nested; + -- end Nested; -- safe activation -- ... elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then @@ -10008,20 +10082,15 @@ package body Sem_Elab is -- call and the task appear within the same context ignoring library -- levels, and the body of the task has not been seen yet or appears -- after the activation call. - + -- -- procedure Guaranteed_ABE is -- task type Task_Typ; - + -- -- package Nested is - -- ... - -- end Nested; - - -- package body Nested is -- T : Task_Typ; - -- [begin] -- <activation call> -- guaranteed ABE -- end Nested; - + -- -- task body Task_Typ is -- ... -- end Task_Typ; @@ -10078,9 +10147,9 @@ package body Sem_Elab is -- Nothing to do when the root scenario appears at the declaration level -- and the target is in the same unit, but outside this context. - + -- -- function B ...; -- target declaration - + -- -- procedure Proc is -- function A ... is -- begin @@ -10088,14 +10157,14 @@ package body Sem_Elab is -- return B; -- call site -- ... -- end A; - + -- -- X : ... := A; -- root scenario -- ... - + -- -- function B ... is -- ... -- end B; - + -- -- In the example above, the context of X is the declarative region of -- Proc. The "elaboration" of X may eventually reach B which is defined -- outside of X's context. B is relevant only when Proc is invoked, but @@ -10108,15 +10177,15 @@ package body Sem_Elab is return; -- Nothing to do when the call is ABE-safe - + -- -- generic -- function Gen ...; - + -- -- function Gen ... is -- begin -- ... -- end Gen; - + -- -- with Gen; -- procedure Main is -- function Inst is new Gen; @@ -10129,14 +10198,14 @@ package body Sem_Elab is -- A call leads to a guaranteed ABE when the call and the target appear -- within the same context ignoring library levels, and the body of the -- target has not been seen yet or appears after the call. - + -- -- procedure Guaranteed_ABE is -- function Func ...; - + -- -- package Nested is -- Obj : ... := Func; -- guaranteed ABE -- end Nested; - + -- -- function Func ... is -- ... -- end Func; @@ -10198,10 +10267,10 @@ package body Sem_Elab is -- Nothing to do when the root scenario appears at the declaration level -- and the generic is in the same unit, but outside this context. - + -- -- generic -- procedure Gen is ...; -- generic declaration - + -- -- procedure Proc is -- function A ... is -- begin @@ -10211,14 +10280,14 @@ package body Sem_Elab is -- ... -- ... -- end A; - + -- -- X : ... := A; -- root scenario -- ... - + -- -- procedure Gen is -- ... -- end Gen; - + -- -- In the example above, the context of X is the declarative region of -- Proc. The "elaboration" of X may eventually reach Gen which appears -- outside of X's context. Gen is relevant only when Proc is invoked, @@ -10231,16 +10300,16 @@ package body Sem_Elab is return; -- Nothing to do when the instantiation is ABE-safe - + -- -- generic -- package Gen is -- ... -- end Gen; - + -- -- package body Gen is -- ... -- end Gen; - + -- -- with Gen; -- procedure Main is -- package Inst is new Gen (ABE); -- safe instantiation @@ -10253,15 +10322,15 @@ package body Sem_Elab is -- the generic appear within the same context ignoring library levels, -- and the body of the generic has not been seen yet or appears after -- the instantiation. - + -- -- procedure Guaranteed_ABE is -- generic -- procedure Gen; - + -- -- package Nested is -- procedure Inst is new Gen; -- guaranteed ABE -- end Nested; - + -- -- procedure Gen is -- ... -- end Gen; @@ -10330,11 +10399,9 @@ package body Sem_Elab is if Is_Activation_Proc (Target_Id) then Process_Guaranteed_ABE_Activation - (Call => N, - Call_Attrs => Call_Attrs, - In_Init_Cond => False, - In_Partial_Fin => False, - In_Task_Body => False); + (Call => N, + Call_Attrs => Call_Attrs, + State => Initial_State); else Process_Guaranteed_ABE_Call @@ -10388,10 +10455,17 @@ package body Sem_Elab is Declaration_Level_OK := False; Library_Level_OK := False; + -- Nothing to do when switch -gnatH (legacy elaboration checking mode + -- enabled) is in effect because the legacy ABE mechanism does not need + -- to carry out this action. + + if Legacy_Elaboration_Checks then + return; + -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics -- are performed in this mode. - if ASIS_Mode then + elsif ASIS_Mode then return; -- Nothing to do when the scenario is being preanalyzed @@ -10498,7 +10572,7 @@ package body Sem_Elab is if Declaration_Level_OK and then Level = Declaration_Level then null; - -- Library-level scenario + -- Library-level or instantiation scenario elsif Library_Level_OK and then Level in Library_Or_Instantiation_Level @@ -10705,12 +10779,7 @@ package body Sem_Elab is -- Traverse_Body -- ------------------- - procedure Traverse_Body - (N : Node_Id; - In_Init_Cond : Boolean; - In_Partial_Fin : Boolean; - In_Task_Body : Boolean) - is + procedure Traverse_Body (N : Node_Id; State : Processing_Attributes) is procedure Find_And_Process_Nested_Scenarios; pragma Inline (Find_And_Process_Nested_Scenarios); -- Examine the declarations and statements of subprogram body N for @@ -10771,9 +10840,17 @@ package body Sem_Elab is elsif Nkind_In (Original_Node (Nod), N_Accept_Statement, N_Selective_Accept) - and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code) then - return Abandon; + if Restriction_Active (No_Entry_Calls_In_Elaboration_Code) then + return Abandon; + + -- The same behavior is achieved when switch -gnatd_a (stop + -- elabortion checks on accept or select statement) is in + -- effect. + + elsif Debug_Flag_Underscore_A then + return Abandon; + end if; -- Certain nodes carry semantic lists which act as repositories -- until expansion transforms the node and relocates the contents. @@ -10805,10 +10882,8 @@ package body Sem_Elab is Save_Scenario (Nod); Process_Conditional_ABE - (N => Nod, - In_Init_Cond => In_Init_Cond, - In_Partial_Fin => In_Partial_Fin, - In_Task_Body => In_Task_Body); + (N => Nod, + State => State); end if; return OK; @@ -10871,10 +10946,8 @@ package body Sem_Elab is Nested_Elmt := First_Elmt (Nested); while Present (Nested_Elmt) loop Process_Conditional_ABE - (N => Node (Nested_Elmt), - In_Init_Cond => In_Init_Cond, - In_Partial_Fin => In_Partial_Fin, - In_Task_Body => In_Task_Body); + (N => Node (Nested_Elmt), + State => State); Next_Elmt (Nested_Elmt); end loop; @@ -11034,4 +11107,3811 @@ package body Sem_Elab is return Visited_Bodies_Index (Key mod Visited_Bodies_Max); end Visited_Bodies_Hash; + --------------------------------------------------------------------------- + -- -- + -- L E G A C Y A C C E S S B E F O R E E L A B O R A T I O N -- + -- -- + -- M E C H A N I S M -- + -- -- + --------------------------------------------------------------------------- + + -- This section contains the implementation of the pre-18.x legacy ABE + -- mechanism. The mechanism can be activated using switch -gnatH (legacy + -- elaboration checking mode enabled). + + ----------------------------- + -- Description of Approach -- + ----------------------------- + + -- Every non-static call that is encountered by Sem_Res results in a call + -- to Check_Elab_Call, with N being the call node, and Outer set to its + -- default value of True. In addition X'Access is treated like a call + -- for the access-to-procedure case, and in SPARK mode only we also + -- check variable references. + + -- The goal of Check_Elab_Call is to determine whether or not the reference + -- in question can generate an access before elaboration error (raising + -- Program_Error) either by directly calling a subprogram whose body + -- has not yet been elaborated, or indirectly, by calling a subprogram + -- whose body has been elaborated, but which contains a call to such a + -- subprogram. + + -- In addition, in SPARK mode, we are checking for a variable reference in + -- another package, which requires an explicit Elaborate_All pragma. + + -- The only references that we need to look at the outer level are + -- references that occur in elaboration code. There are two cases. The + -- reference can be at the outer level of elaboration code, or it can + -- be within another unit, e.g. the elaboration code of a subprogram. + + -- In the case of an elaboration call at the outer level, we must trace + -- all calls to outer level routines either within the current unit or to + -- other units that are with'ed. For calls within the current unit, we can + -- determine if the body has been elaborated or not, and if it has not, + -- then a warning is generated. + + -- Note that there are two subcases. If the original call directly calls a + -- subprogram whose body has not been elaborated, then we know that an ABE + -- will take place, and we replace the call by a raise of Program_Error. + -- If the call is indirect, then we don't know that the PE will be raised, + -- since the call might be guarded by a conditional. In this case we set + -- Do_Elab_Check on the call so that a dynamic check is generated, and + -- output a warning. + + -- For calls to a subprogram in a with'ed unit or a 'Access or variable + -- reference (SPARK mode case), we require that a pragma Elaborate_All + -- or pragma Elaborate be present, or that the referenced unit have a + -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none + -- of these conditions is met, then a warning is generated that a pragma + -- Elaborate_All may be needed (error in the SPARK case), or an implicit + -- pragma is generated. + + -- For the case of an elaboration call at some inner level, we are + -- interested in tracing only calls to subprograms at the same level, i.e. + -- those that can be called during elaboration. Any calls to outer level + -- routines cannot cause ABE's as a result of the original call (there + -- might be an outer level call to the subprogram from outside that causes + -- the ABE, but that gets analyzed separately). + + -- Note that we never trace calls to inner level subprograms, since these + -- cannot result in ABE's unless there is an elaboration problem at a lower + -- level, which will be separately detected. + + -- Note on pragma Elaborate. The checking here assumes that a pragma + -- Elaborate on a with'ed unit guarantees that subprograms within the unit + -- can be called without causing an ABE. This is not in fact the case since + -- pragma Elaborate does not guarantee the transitive coverage guaranteed + -- by Elaborate_All. However, we decide to trust the user in this case. + + -------------------------------------- + -- Instantiation Elaboration Errors -- + -------------------------------------- + + -- A special case arises when an instantiation appears in a context that is + -- known to be before the body is elaborated, e.g. + + -- generic package x is ... + -- ... + -- package xx is new x; + -- ... + -- package body x is ... + + -- In this situation it is certain that an elaboration error will occur, + -- and an unconditional raise Program_Error statement is inserted before + -- the instantiation, and a warning generated. + + -- The problem is that in this case we have no place to put the body of + -- the instantiation. We can't put it in the normal place, because it is + -- too early, and will cause errors to occur as a result of referencing + -- entities before they are declared. + + -- Our approach in this case is simply to avoid creating the body of the + -- instantiation in such a case. The instantiation spec is modified to + -- include dummy bodies for all subprograms, so that the resulting code + -- does not contain subprogram specs with no corresponding bodies. + + -- The following table records the recursive call chain for output in the + -- Output routine. Each entry records the call node and the entity of the + -- called routine. The number of entries in the table (i.e. the value of + -- Elab_Call.Last) indicates the current depth of recursion and is used to + -- identify the outer level. + + type Elab_Call_Element is record + Cloc : Source_Ptr; + Ent : Entity_Id; + end record; + + package Elab_Call is new Table.Table + (Table_Component_Type => Elab_Call_Element, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 100, + Table_Name => "Elab_Call"); + + -- The following table records all calls that have been processed starting + -- from an outer level call. The table prevents both infinite recursion and + -- useless reanalysis of calls within the same context. The use of context + -- is important because it allows for proper checks in more complex code: + + -- if ... then + -- Call; -- requires a check + -- Call; -- does not need a check thanks to the table + -- elsif ... then + -- Call; -- requires a check, different context + -- end if; + + -- Call; -- requires a check, different context + + type Visited_Element is record + Subp_Id : Entity_Id; + -- The entity of the subprogram being called + + Context : Node_Id; + -- The context where the call to the subprogram occurs + end record; + + package Elab_Visited is new Table.Table + (Table_Component_Type => Visited_Element, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 100, + Table_Name => "Elab_Visited"); + + -- The following table records delayed calls which must be examined after + -- all generic bodies have been instantiated. + + type Delay_Element is record + N : Node_Id; + -- The parameter N from the call to Check_Internal_Call. Note that this + -- node may get rewritten over the delay period by expansion in the call + -- case (but not in the instantiation case). + + E : Entity_Id; + -- The parameter E from the call to Check_Internal_Call + + Orig_Ent : Entity_Id; + -- The parameter Orig_Ent from the call to Check_Internal_Call + + Curscop : Entity_Id; + -- The current scope of the call. This is restored when we complete the + -- delayed call, so that we do this in the right scope. + + Outer_Scope : Entity_Id; + -- Save scope of outer level call + + From_Elab_Code : Boolean; + -- Save indication of whether this call is from elaboration code + + In_Task_Activation : Boolean; + -- Save indication of whether this call is from a task body. Tasks are + -- activated at the "begin", which is after all local procedure bodies, + -- so calls to those procedures can't fail, even if they occur after the + -- task body. + + From_SPARK_Code : Boolean; + -- Save indication of whether this call is under SPARK_Mode => On + end record; + + package Delay_Check is new Table.Table + (Table_Component_Type => Delay_Element, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 1000, + Table_Increment => 100, + Table_Name => "Delay_Check"); + + C_Scope : Entity_Id; + -- Top-level scope of current scope. Compute this only once at the outer + -- level, i.e. for a call to Check_Elab_Call from outside this unit. + + Outer_Level_Sloc : Source_Ptr; + -- Save Sloc value for outer level call node for comparisons of source + -- locations. A body is too late if it appears after the *outer* level + -- call, not the particular call that is being analyzed. + + From_Elab_Code : Boolean; + -- This flag shows whether the outer level call currently being examined + -- is or is not in elaboration code. We are only interested in calls to + -- routines in other units if this flag is True. + + In_Task_Activation : Boolean := False; + -- This flag indicates whether we are performing elaboration checks on task + -- bodies, at the point of activation. If true, we do not raise + -- Program_Error for calls to local procedures, because all local bodies + -- are known to be elaborated. However, we still need to trace such calls, + -- because a local procedure could call a procedure in another package, + -- so we might need an implicit Elaborate_All. + + Delaying_Elab_Checks : Boolean := True; + -- This is set True till the compilation is complete, including the + -- insertion of all instance bodies. Then when Check_Elab_Calls is called, + -- the delay table is used to make the delayed calls and this flag is reset + -- to False, so that the calls are processed. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- Note: Outer_Scope in all following specs represents the scope of + -- interest of the outer level call. If it is set to Standard_Standard, + -- then it means the outer level call was at elaboration level, and that + -- thus all calls are of interest. If it was set to some other scope, + -- then the original call was an inner call, and we are not interested + -- in calls that go outside this scope. + + procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id); + -- Analysis of construct N shows that we should set Elaborate_All_Desirable + -- for the WITH clause for unit U (which will always be present). A special + -- case is when N is a function or procedure instantiation, in which case + -- it is sufficient to set Elaborate_Desirable, since in this case there is + -- no possibility of transitive elaboration issues. + + procedure Check_A_Call + (N : Node_Id; + E : Entity_Id; + Outer_Scope : Entity_Id; + Inter_Unit_Only : Boolean; + Generate_Warnings : Boolean := True; + In_Init_Proc : Boolean := False); + -- This is the internal recursive routine that is called to check for + -- possible elaboration error. The argument N is a subprogram call or + -- generic instantiation, or 'Access attribute reference to be checked, and + -- E is the entity of the called subprogram, or instantiated generic unit, + -- or subprogram referenced by 'Access. + -- + -- In SPARK mode, N can also be a variable reference, since in SPARK this + -- also triggers a requirement for Elaborate_All, and in this case E is the + -- entity being referenced. + -- + -- Outer_Scope is the outer level scope for the original reference. + -- Inter_Unit_Only is set if the call is only to be checked in the + -- case where it is to another unit (and skipped if within a unit). + -- Generate_Warnings is set to False to suppress warning messages about + -- missing pragma Elaborate_All's. These messages are not wanted for + -- inner calls in the dynamic model. Note that an instance of the Access + -- attribute applied to a subprogram also generates a call to this + -- procedure (since the referenced subprogram may be called later + -- indirectly). Flag In_Init_Proc should be set whenever the current + -- context is a type init proc. + -- + -- Note: this might better be called Check_A_Reference to recognize the + -- variable case for SPARK, but we prefer to retain the historical name + -- since in practice this is mostly about checking calls for the possible + -- occurrence of an access-before-elaboration exception. + + procedure Check_Bad_Instantiation (N : Node_Id); + -- N is a node for an instantiation (if called with any other node kind, + -- Check_Bad_Instantiation ignores the call). This subprogram checks for + -- the special case of a generic instantiation of a generic spec in the + -- same declarative part as the instantiation where a body is present and + -- has not yet been seen. This is an obvious error, but needs to be checked + -- specially at the time of the instantiation, since it is a case where we + -- cannot insert the body anywhere. If this case is detected, warnings are + -- generated, and a raise of Program_Error is inserted. In addition any + -- subprograms in the generic spec are stubbed, and the Bad_Instantiation + -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this + -- flag as an indication that no attempt should be made to insert an + -- instance body. + + procedure Check_Internal_Call + (N : Node_Id; + E : Entity_Id; + Outer_Scope : Entity_Id; + Orig_Ent : Entity_Id); + -- N is a function call or procedure statement call node and E is the + -- entity of the called function, which is within the current compilation + -- unit (where subunits count as part of the parent). This call checks if + -- this call, or any call within any accessed body could cause an ABE, and + -- if so, outputs a warning. Orig_Ent differs from E only in the case of + -- renamings, and points to the original name of the entity. This is used + -- for error messages. Outer_Scope is the outer level scope for the + -- original call. + + procedure Check_Internal_Call_Continue + (N : Node_Id; + E : Entity_Id; + Outer_Scope : Entity_Id; + Orig_Ent : Entity_Id); + -- The processing for Check_Internal_Call is divided up into two phases, + -- and this represents the second phase. The second phase is delayed if + -- Delaying_Elab_Checks is set to True. In this delayed case, the first + -- phase makes an entry in the Delay_Check table, which is processed when + -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to + -- Check_Internal_Call. Outer_Scope is the outer level scope for the + -- original call. + + function Get_Referenced_Ent (N : Node_Id) return Entity_Id; + -- N is either a function or procedure call or an access attribute that + -- references a subprogram. This call retrieves the relevant entity. If + -- this is a call to a protected subprogram, the entity is a selected + -- component. The callable entity may be absent, in which case Empty is + -- returned. This happens with non-analyzed calls in nested generics. + -- + -- If SPARK_Mode is On, then N can also be a reference to an E_Variable + -- entity, in which case, the value returned is simply this entity. + + function Has_Generic_Body (N : Node_Id) return Boolean; + -- N is a generic package instantiation node, and this routine determines + -- if this package spec does in fact have a generic body. If so, then + -- True is returned, otherwise False. Note that this is not at all the + -- same as checking if the unit requires a body, since it deals with + -- the case of optional bodies accurately (i.e. if a body is optional, + -- then it looks to see if a body is actually present). Note: this + -- function can only do a fully correct job if in generating code mode + -- where all bodies have to be present. If we are operating in semantics + -- check only mode, then in some cases of optional bodies, a result of + -- False may incorrectly be given. In practice this simply means that + -- some cases of warnings for incorrect order of elaboration will only + -- be given when generating code, which is not a big problem (and is + -- inevitable, given the optional body semantics of Ada). + + procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty); + -- Given code for an elaboration check (or unconditional raise if the check + -- is not needed), inserts the code in the appropriate place. N is the call + -- or instantiation node for which the check code is required. C is the + -- test whose failure triggers the raise. + + function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean; + -- Returns True if node N is a call to a generic formal subprogram + + function Is_Finalization_Procedure (Id : Entity_Id) return Boolean; + -- Determine whether entity Id denotes a [Deep_]Finalize procedure + + procedure Output_Calls + (N : Node_Id; + Check_Elab_Flag : Boolean); + -- Outputs chain of calls stored in the Elab_Call table. The caller has + -- already generated the main warning message, so the warnings generated + -- are all continuation messages. The argument is the call node at which + -- the messages are to be placed. When Check_Elab_Flag is set, calls are + -- enumerated only when flag Elab_Warning is set for the dynamic case or + -- when flag Elab_Info_Messages is set for the static case. + + function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; + -- Given two scopes, determine whether they are the same scope from an + -- elaboration point of view, i.e. packages and blocks are ignored. + + procedure Set_C_Scope; + -- On entry C_Scope is set to some scope. On return, C_Scope is reset + -- to be the enclosing compilation unit of this scope. + + procedure Set_Elaboration_Constraint + (Call : Node_Id; + Subp : Entity_Id; + Scop : Entity_Id); + -- The current unit U may depend semantically on some unit P that is not + -- in the current context. If there is an elaboration call that reaches P, + -- we need to indicate that P requires an Elaborate_All, but this is not + -- effective in U's ali file, if there is no with_clause for P. In this + -- case we add the Elaborate_All on the unit Q that directly or indirectly + -- makes P available. This can happen in two cases: + -- + -- a) Q declares a subtype of a type declared in P, and the call is an + -- initialization call for an object of that subtype. + -- + -- b) Q declares an object of some tagged type whose root type is + -- declared in P, and the initialization call uses object notation on + -- that object to reach a primitive operation or a classwide operation + -- declared in P. + -- + -- If P appears in the context of U, the current processing is correct. + -- Otherwise we must identify these two cases to retrieve Q and place the + -- Elaborate_All_Desirable on it. + + function Spec_Entity (E : Entity_Id) return Entity_Id; + -- Given a compilation unit entity, if it is a spec entity, it is returned + -- unchanged. If it is a body entity, then the spec for the corresponding + -- spec is returned + + function Within (E1, E2 : Entity_Id) return Boolean; + -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one + -- of its contained scopes, False otherwise. + + function Within_Elaborate_All + (Unit : Unit_Number_Type; + E : Entity_Id) return Boolean; + -- Return True if we are within the scope of an Elaborate_All for E, or if + -- we are within the scope of an Elaborate_All for some other unit U, and U + -- with's E. This prevents spurious warnings when the called entity is + -- renamed within U, or in case of generic instances. + + -------------------------------------- + -- Activate_Elaborate_All_Desirable -- + -------------------------------------- + + procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id) is + UN : constant Unit_Number_Type := Get_Code_Unit (N); + CU : constant Node_Id := Cunit (UN); + UE : constant Entity_Id := Cunit_Entity (UN); + Unm : constant Unit_Name_Type := Unit_Name (UN); + CI : constant List_Id := Context_Items (CU); + Itm : Node_Id; + Ent : Entity_Id; + + procedure Add_To_Context_And_Mark (Itm : Node_Id); + -- This procedure is called when the elaborate indication must be + -- applied to a unit not in the context of the referencing unit. The + -- unit gets added to the context as an implicit with. + + function In_Withs_Of (UEs : Entity_Id) return Boolean; + -- UEs is the spec entity of a unit. If the unit to be marked is + -- in the context item list of this unit spec, then the call returns + -- True and Itm is left set to point to the relevant N_With_Clause node. + + procedure Set_Elab_Flag (Itm : Node_Id); + -- Sets Elaborate_[All_]Desirable as appropriate on Itm + + ----------------------------- + -- Add_To_Context_And_Mark -- + ----------------------------- + + procedure Add_To_Context_And_Mark (Itm : Node_Id) is + CW : constant Node_Id := + Make_With_Clause (Sloc (Itm), + Name => Name (Itm)); + + begin + Set_Library_Unit (CW, Library_Unit (Itm)); + Set_Implicit_With (CW, True); + + -- Set elaborate all desirable on copy and then append the copy to + -- the list of body with's and we are done. + + Set_Elab_Flag (CW); + Append_To (CI, CW); + end Add_To_Context_And_Mark; + + ----------------- + -- In_Withs_Of -- + ----------------- + + function In_Withs_Of (UEs : Entity_Id) return Boolean is + UNs : constant Unit_Number_Type := Get_Source_Unit (UEs); + CUs : constant Node_Id := Cunit (UNs); + CIs : constant List_Id := Context_Items (CUs); + + begin + Itm := First (CIs); + while Present (Itm) loop + if Nkind (Itm) = N_With_Clause then + Ent := + Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); + + if U = Ent then + return True; + end if; + end if; + + Next (Itm); + end loop; + + return False; + end In_Withs_Of; + + ------------------- + -- Set_Elab_Flag -- + ------------------- + + procedure Set_Elab_Flag (Itm : Node_Id) is + begin + if Nkind (N) in N_Subprogram_Instantiation then + Set_Elaborate_Desirable (Itm); + else + Set_Elaborate_All_Desirable (Itm); + end if; + end Set_Elab_Flag; + + -- Start of processing for Activate_Elaborate_All_Desirable + + begin + -- Do not set binder indication if expansion is disabled, as when + -- compiling a generic unit. + + if not Expander_Active then + return; + end if; + + -- If an instance of a generic package contains a controlled object (so + -- we're calling Initialize at elaboration time), and the instance is in + -- a package body P that says "with P;", then we need to return without + -- adding "pragma Elaborate_All (P);" to P. + + if U = Main_Unit_Entity then + return; + end if; + + Itm := First (CI); + while Present (Itm) loop + if Nkind (Itm) = N_With_Clause then + Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); + + -- If we find it, then mark elaborate all desirable and return + + if U = Ent then + Set_Elab_Flag (Itm); + return; + end if; + end if; + + Next (Itm); + end loop; + + -- If we fall through then the with clause is not present in the + -- current unit. One legitimate possibility is that the with clause + -- is present in the spec when we are a body. + + if Is_Body_Name (Unm) + and then In_Withs_Of (Spec_Entity (UE)) + then + Add_To_Context_And_Mark (Itm); + return; + end if; + + -- Similarly, we may be in the spec or body of a child unit, where + -- the unit in question is with'ed by some ancestor of the child unit. + + if Is_Child_Name (Unm) then + declare + Pkg : Entity_Id; + + begin + Pkg := UE; + loop + Pkg := Scope (Pkg); + exit when Pkg = Standard_Standard; + + if In_Withs_Of (Pkg) then + Add_To_Context_And_Mark (Itm); + return; + end if; + end loop; + end; + end if; + + -- Here if we do not find with clause on spec or body. We just ignore + -- this case; it means that the elaboration involves some other unit + -- than the unit being compiled, and will be caught elsewhere. + end Activate_Elaborate_All_Desirable; + + ------------------ + -- Check_A_Call -- + ------------------ + + procedure Check_A_Call + (N : Node_Id; + E : Entity_Id; + Outer_Scope : Entity_Id; + Inter_Unit_Only : Boolean; + Generate_Warnings : Boolean := True; + In_Init_Proc : Boolean := False) + is + Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference; + -- Indicates if we have Access attribute case + + function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean; + -- True if we're calling an instance of a generic subprogram, or a + -- subprogram in an instance of a generic package, and the call is + -- outside that instance. + + procedure Elab_Warning + (Msg_D : String; + Msg_S : String; + Ent : Node_Or_Entity_Id); + -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for + -- dynamic or static elaboration model), N and Ent. Msg_D is a real + -- warning (output if Msg_D is non-null and Elab_Warnings is set), + -- Msg_S is an info message (output if Elab_Info_Messages is set). + + function Find_W_Scope return Entity_Id; + -- Find top-level scope for called entity (not following renamings + -- or derivations). This is where the Elaborate_All will go if it is + -- needed. We start with the called entity, except in the case of an + -- initialization procedure outside the current package, where the init + -- proc is in the root package, and we start from the entity of the name + -- in the call. + + ----------------------------------- + -- Call_To_Instance_From_Outside -- + ----------------------------------- + + function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean is + Scop : Entity_Id := Id; + + begin + loop + if Scop = Standard_Standard then + return False; + end if; + + if Is_Generic_Instance (Scop) then + return not In_Open_Scopes (Scop); + end if; + + Scop := Scope (Scop); + end loop; + end Call_To_Instance_From_Outside; + + ------------------ + -- Elab_Warning -- + ------------------ + + procedure Elab_Warning + (Msg_D : String; + Msg_S : String; + Ent : Node_Or_Entity_Id) + is + begin + -- Dynamic elaboration checks, real warning + + if Dynamic_Elaboration_Checks then + if not Access_Case then + if Msg_D /= "" and then Elab_Warnings then + Error_Msg_NE (Msg_D, N, Ent); + end if; + + -- In the access case emit first warning message as well, + -- otherwise list of calls will appear as errors. + + elsif Elab_Warnings then + Error_Msg_NE (Msg_S, N, Ent); + end if; + + -- Static elaboration checks, info message + + else + if Elab_Info_Messages then + Error_Msg_NE (Msg_S, N, Ent); + end if; + end if; + end Elab_Warning; + + ------------------ + -- Find_W_Scope -- + ------------------ + + function Find_W_Scope return Entity_Id is + Refed_Ent : constant Entity_Id := Get_Referenced_Ent (N); + W_Scope : Entity_Id; + + begin + if Is_Init_Proc (Refed_Ent) + and then not In_Same_Extended_Unit (N, Refed_Ent) + then + W_Scope := Scope (Refed_Ent); + else + W_Scope := E; + end if; + + -- Now loop through scopes to get to the enclosing compilation unit + + while not Is_Compilation_Unit (W_Scope) loop + W_Scope := Scope (W_Scope); + end loop; + + return W_Scope; + end Find_W_Scope; + + -- Local variables + + Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; + -- Indicates if we have instantiation case + + Loc : constant Source_Ptr := Sloc (N); + + Variable_Case : constant Boolean := + Nkind (N) in N_Has_Entity + and then Present (Entity (N)) + and then Ekind (Entity (N)) = E_Variable; + -- Indicates if we have variable reference case + + W_Scope : constant Entity_Id := Find_W_Scope; + -- Top-level scope of directly called entity for subprogram. This + -- differs from E_Scope in the case where renamings or derivations + -- are involved, since it does not follow these links. W_Scope is + -- generally in a visible unit, and it is this scope that may require + -- an Elaborate_All. However, there are some cases (initialization + -- calls and calls involving object notation) where W_Scope might not + -- be in the context of the current unit, and there is an intermediate + -- package that is, in which case the Elaborate_All has to be placed + -- on this intermediate package. These special cases are handled in + -- Set_Elaboration_Constraint. + + Ent : Entity_Id; + Callee_Unit_Internal : Boolean; + Caller_Unit_Internal : Boolean; + Decl : Node_Id; + Inst_Callee : Source_Ptr; + Inst_Caller : Source_Ptr; + Unit_Callee : Unit_Number_Type; + Unit_Caller : Unit_Number_Type; + + Body_Acts_As_Spec : Boolean; + -- Set to true if call is to body acting as spec (no separate spec) + + Cunit_SC : Boolean := False; + -- Set to suppress dynamic elaboration checks where one of the + -- enclosing scopes has Elaboration_Checks_Suppressed set, or else + -- if a pragma Elaborate[_All] applies to that scope, in which case + -- warnings on the scope are also suppressed. For the internal case, + -- we ignore this flag. + + E_Scope : Entity_Id; + -- Top-level scope of entity for called subprogram. This value includes + -- following renamings and derivations, so this scope can be in a + -- non-visible unit. This is the scope that is to be investigated to + -- see whether an elaboration check is required. + + Is_DIC : Boolean; + -- Flag set when the subprogram being invoked is the procedure generated + -- for pragma Default_Initial_Condition. + + SPARK_Elab_Errors : Boolean; + -- Flag set when an entity is called or a variable is read during SPARK + -- dynamic elaboration. + + -- Start of processing for Check_A_Call + + begin + -- If the call is known to be within a local Suppress Elaboration + -- pragma, nothing to check. This can happen in task bodies. But + -- we ignore this for a call to a generic formal. + + if Nkind (N) in N_Subprogram_Call + and then No_Elaboration_Check (N) + and then not Is_Call_Of_Generic_Formal (N) + then + return; + + -- If this is a rewrite of a Valid_Scalars attribute, then nothing to + -- check, we don't mind in this case if the call occurs before the body + -- since this is all generated code. + + elsif Nkind (Original_Node (N)) = N_Attribute_Reference + and then Attribute_Name (Original_Node (N)) = Name_Valid_Scalars + then + return; + + -- Intrinsics such as instances of Unchecked_Deallocation do not have + -- any body, so elaboration checking is not needed, and would be wrong. + + elsif Is_Intrinsic_Subprogram (E) then + return; + + -- Do not consider references to internal variables for SPARK semantics + + elsif Variable_Case and then not Comes_From_Source (E) then + return; + end if; + + -- Proceed with check + + Ent := E; + + -- For a variable reference, just set Body_Acts_As_Spec to False + + if Variable_Case then + Body_Acts_As_Spec := False; + + -- Additional checks for all other cases + + else + -- Go to parent for derived subprogram, or to original subprogram in + -- the case of a renaming (Alias covers both these cases). + + loop + if (Suppress_Elaboration_Warnings (Ent) + or else Elaboration_Checks_Suppressed (Ent)) + and then (Inst_Case or else No (Alias (Ent))) + then + return; + end if; + + -- Nothing to do for imported entities + + if Is_Imported (Ent) then + return; + end if; + + exit when Inst_Case or else No (Alias (Ent)); + Ent := Alias (Ent); + end loop; + + Decl := Unit_Declaration_Node (Ent); + + if Nkind (Decl) = N_Subprogram_Body then + Body_Acts_As_Spec := True; + + elsif Nkind_In (Decl, N_Subprogram_Declaration, + N_Subprogram_Body_Stub) + or else Inst_Case + then + Body_Acts_As_Spec := False; + + -- If we have none of an instantiation, subprogram body or subprogram + -- declaration, or in the SPARK case, a variable reference, then + -- it is not a case that we want to check. (One case is a call to a + -- generic formal subprogram, where we do not want the check in the + -- template). + + else + return; + end if; + end if; + + E_Scope := Ent; + loop + if Elaboration_Checks_Suppressed (E_Scope) + or else Suppress_Elaboration_Warnings (E_Scope) + then + Cunit_SC := True; + end if; + + -- Exit when we get to compilation unit, not counting subunits + + exit when Is_Compilation_Unit (E_Scope) + and then (Is_Child_Unit (E_Scope) + or else Scope (E_Scope) = Standard_Standard); + + pragma Assert (E_Scope /= Standard_Standard); + + -- Move up a scope looking for compilation unit + + E_Scope := Scope (E_Scope); + end loop; + + -- No checks needed for pure or preelaborated compilation units + + if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then + return; + end if; + + -- If the generic entity is within a deeper instance than we are, then + -- either the instantiation to which we refer itself caused an ABE, in + -- which case that will be handled separately, or else we know that the + -- body we need appears as needed at the point of the instantiation. + -- However, this assumption is only valid if we are in static mode. + + if not Dynamic_Elaboration_Checks + and then + Instantiation_Depth (Sloc (Ent)) > Instantiation_Depth (Sloc (N)) + then + return; + end if; + + -- Do not give a warning for a package with no body + + if Ekind (Ent) = E_Generic_Package and then not Has_Generic_Body (N) then + return; + end if; + + -- Case of entity is in same unit as call or instantiation. In the + -- instantiation case, W_Scope may be different from E_Scope; we want + -- the unit in which the instantiation occurs, since we're analyzing + -- based on the expansion. + + if W_Scope = C_Scope then + if not Inter_Unit_Only then + Check_Internal_Call (N, Ent, Outer_Scope, E); + end if; + + return; + end if; + + -- Case of entity is not in current unit (i.e. with'ed unit case) + + -- We are only interested in such calls if the outer call was from + -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode. + + if not From_Elab_Code and then not Dynamic_Elaboration_Checks then + return; + end if; + + -- Nothing to do if some scope said that no checks were required + + if Cunit_SC then + return; + end if; + + -- Nothing to do for a generic instance, because a call to an instance + -- cannot fail the elaboration check, because the body of the instance + -- is always elaborated immediately after the spec. + + if Call_To_Instance_From_Outside (Ent) then + return; + end if; + + -- Nothing to do if subprogram with no separate spec. However, a call + -- to Deep_Initialize may result in a call to a user-defined Initialize + -- procedure, which imposes a body dependency. This happens only if the + -- type is controlled and the Initialize procedure is not inherited. + + if Body_Acts_As_Spec then + if Is_TSS (Ent, TSS_Deep_Initialize) then + declare + Typ : constant Entity_Id := Etype (First_Formal (Ent)); + Init : Entity_Id; + + begin + if not Is_Controlled (Typ) then + return; + else + Init := Find_Prim_Op (Typ, Name_Initialize); + + if Comes_From_Source (Init) then + Ent := Init; + else + return; + end if; + end if; + end; + + else + return; + end if; + end if; + + -- Check cases of internal units + + Callee_Unit_Internal := In_Internal_Unit (E_Scope); + + -- Do not give a warning if the with'ed unit is internal and this is + -- the generic instantiation case (this saves a lot of hassle dealing + -- with the Text_IO special child units) + + if Callee_Unit_Internal and Inst_Case then + return; + end if; + + if C_Scope = Standard_Standard then + Caller_Unit_Internal := False; + else + Caller_Unit_Internal := In_Internal_Unit (C_Scope); + end if; + + -- Do not give a warning if the with'ed unit is internal and the caller + -- is not internal (since the binder always elaborates internal units + -- first). + + if Callee_Unit_Internal and not Caller_Unit_Internal then + return; + end if; + + -- For now, if debug flag -gnatdE is not set, do no checking for one + -- internal unit withing another. This fixes the problem with the sgi + -- build and storage errors. To be resolved later ??? + + if (Callee_Unit_Internal and Caller_Unit_Internal) + and not Debug_Flag_EE + then + return; + end if; + + if Is_TSS (E, TSS_Deep_Initialize) then + Ent := E; + end if; + + -- If the call is in an instance, and the called entity is not + -- defined in the same instance, then the elaboration issue focuses + -- around the unit containing the template, it is this unit that + -- requires an Elaborate_All. + + -- However, if we are doing dynamic elaboration, we need to chase the + -- call in the usual manner. + + -- We also need to chase the call in the usual manner if it is a call + -- to a generic formal parameter, since that case was not handled as + -- part of the processing of the template. + + Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N))); + Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent))); + + if Inst_Caller = No_Location then + Unit_Caller := No_Unit; + else + Unit_Caller := Get_Source_Unit (N); + end if; + + if Inst_Callee = No_Location then + Unit_Callee := No_Unit; + else + Unit_Callee := Get_Source_Unit (Ent); + end if; + + if Unit_Caller /= No_Unit + and then Unit_Callee /= Unit_Caller + and then not Dynamic_Elaboration_Checks + and then not Is_Call_Of_Generic_Formal (N) + then + E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); + + -- If we don't get a spec entity, just ignore call. Not quite + -- clear why this check is necessary. ??? + + if No (E_Scope) then + return; + end if; + + -- Otherwise step to enclosing compilation unit + + while not Is_Compilation_Unit (E_Scope) loop + E_Scope := Scope (E_Scope); + end loop; + + -- For the case where N is not an instance, and is not a call within + -- instance to other than a generic formal, we recompute E_Scope + -- for the error message, since we do NOT want to go to the unit + -- that has the ultimate declaration in the case of renaming and + -- derivation and we also want to go to the generic unit in the + -- case of an instance, and no further. + + else + -- Loop to carefully follow renamings and derivations one step + -- outside the current unit, but not further. + + if not (Inst_Case or Variable_Case) + and then Present (Alias (Ent)) + then + E_Scope := Alias (Ent); + else + E_Scope := Ent; + end if; + + loop + while not Is_Compilation_Unit (E_Scope) loop + E_Scope := Scope (E_Scope); + end loop; + + -- If E_Scope is the same as C_Scope, it means that there + -- definitely was a local renaming or derivation, and we + -- are not yet out of the current unit. + + exit when E_Scope /= C_Scope; + Ent := Alias (Ent); + E_Scope := Ent; + + -- If no alias, there could be a previous error, but not if we've + -- already reached the outermost level (Standard). + + if No (Ent) then + return; + end if; + end loop; + end if; + + if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then + return; + end if; + + -- Determine whether the Default_Initial_Condition procedure of some + -- type is being invoked. + + Is_DIC := Ekind (Ent) = E_Procedure and then Is_DIC_Procedure (Ent); + + -- Checks related to Default_Initial_Condition fall under the SPARK + -- umbrella because this is a SPARK-specific annotation. + + SPARK_Elab_Errors := + SPARK_Mode = On and (Is_DIC or Dynamic_Elaboration_Checks); + + -- Now check if an Elaborate_All (or dynamic check) is needed + + if (Elab_Info_Messages or Elab_Warnings or SPARK_Elab_Errors) + and then Generate_Warnings + and then not Suppress_Elaboration_Warnings (Ent) + and then not Elaboration_Checks_Suppressed (Ent) + and then not Suppress_Elaboration_Warnings (E_Scope) + and then not Elaboration_Checks_Suppressed (E_Scope) + then + -- Instantiation case + + if Inst_Case then + if Comes_From_Source (Ent) and then SPARK_Elab_Errors then + Error_Msg_NE + ("instantiation of & during elaboration in SPARK", N, Ent); + else + Elab_Warning + ("instantiation of & may raise Program_Error?l?", + "info: instantiation of & during elaboration?$?", Ent); + end if; + + -- Indirect call case, info message only in static elaboration + -- case, because the attribute reference itself cannot raise an + -- exception. Note that SPARK does not permit indirect calls. + + elsif Access_Case then + Elab_Warning ("", "info: access to & during elaboration?$?", Ent); + + -- Variable reference in SPARK mode + + elsif Variable_Case then + if Comes_From_Source (Ent) and then SPARK_Elab_Errors then + Error_Msg_NE + ("reference to & during elaboration in SPARK", N, Ent); + end if; + + -- Subprogram call case + + else + if Nkind (Name (N)) in N_Has_Entity + and then Is_Init_Proc (Entity (Name (N))) + and then Comes_From_Source (Ent) + then + Elab_Warning + ("implicit call to & may raise Program_Error?l?", + "info: implicit call to & during elaboration?$?", + Ent); + + elsif SPARK_Elab_Errors then + + -- Emit a specialized error message when the elaboration of an + -- object of a private type evaluates the expression of pragma + -- Default_Initial_Condition. This prevents the internal name + -- of the procedure from appearing in the error message. + + if Is_DIC then + Error_Msg_N + ("call to Default_Initial_Condition during elaboration in " + & "SPARK", N); + else + Error_Msg_NE + ("call to & during elaboration in SPARK", N, Ent); + end if; + + else + Elab_Warning + ("call to & may raise Program_Error?l?", + "info: call to & during elaboration?$?", + Ent); + end if; + end if; + + Error_Msg_Qual_Level := Nat'Last; + + -- Case of Elaborate_All not present and required, for SPARK this + -- is an error, so give an error message. + + if SPARK_Elab_Errors then + Error_Msg_NE -- CODEFIX + ("\Elaborate_All pragma required for&", N, W_Scope); + + -- Otherwise we generate an implicit pragma. For a subprogram + -- instantiation, Elaborate is good enough, since no transitive + -- call is possible at elaboration time in this case. + + elsif Nkind (N) in N_Subprogram_Instantiation then + Elab_Warning + ("\missing pragma Elaborate for&?l?", + "\implicit pragma Elaborate for& generated?$?", + W_Scope); + + -- For all other cases, we need an implicit Elaborate_All + + else + Elab_Warning + ("\missing pragma Elaborate_All for&?l?", + "\implicit pragma Elaborate_All for & generated?$?", + W_Scope); + end if; + + Error_Msg_Qual_Level := 0; + + -- Take into account the flags related to elaboration warning + -- messages when enumerating the various calls involved. This + -- ensures the proper pairing of the main warning and the + -- clarification messages generated by Output_Calls. + + Output_Calls (N, Check_Elab_Flag => True); + + -- Set flag to prevent further warnings for same unit unless in + -- All_Errors_Mode. + + if not All_Errors_Mode and not Dynamic_Elaboration_Checks then + Set_Suppress_Elaboration_Warnings (W_Scope); + end if; + end if; + + -- Check for runtime elaboration check required + + if Dynamic_Elaboration_Checks then + if not Elaboration_Checks_Suppressed (Ent) + and then not Elaboration_Checks_Suppressed (W_Scope) + and then not Elaboration_Checks_Suppressed (E_Scope) + and then not Cunit_SC + then + -- Runtime elaboration check required. Generate check of the + -- elaboration Boolean for the unit containing the entity. + + -- Note that for this case, we do check the real unit (the one + -- from following renamings, since that is the issue). + + -- Could this possibly miss a useless but required PE??? + + Insert_Elab_Check (N, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Elaborated, + Prefix => + New_Occurrence_Of (Spec_Entity (E_Scope), Loc))); + + -- Prevent duplicate elaboration checks on the same call, which + -- can happen if the body enclosing the call appears itself in a + -- call whose elaboration check is delayed. + + if Nkind (N) in N_Subprogram_Call then + Set_No_Elaboration_Check (N); + end if; + end if; + + -- Case of static elaboration model + + else + -- Do not do anything if elaboration checks suppressed. Note that + -- we check Ent here, not E, since we want the real entity for the + -- body to see if checks are suppressed for it, not the dummy + -- entry for renamings or derivations. + + if Elaboration_Checks_Suppressed (Ent) + or else Elaboration_Checks_Suppressed (E_Scope) + or else Elaboration_Checks_Suppressed (W_Scope) + then + null; + + -- Do not generate an Elaborate_All for finalization routines + -- that perform partial clean up as part of initialization. + + elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then + null; + + -- Here we need to generate an implicit elaborate all + + else + -- Generate Elaborate_All warning unless suppressed + + if (Elab_Info_Messages and Generate_Warnings and not Inst_Case) + and then not Suppress_Elaboration_Warnings (Ent) + and then not Suppress_Elaboration_Warnings (E_Scope) + and then not Suppress_Elaboration_Warnings (W_Scope) + then + Error_Msg_Node_2 := W_Scope; + Error_Msg_NE + ("info: call to& in elaboration code requires pragma " + & "Elaborate_All on&?$?", N, E); + end if; + + -- Set indication for binder to generate Elaborate_All + + Set_Elaboration_Constraint (N, E, W_Scope); + end if; + end if; + end Check_A_Call; + + ----------------------------- + -- Check_Bad_Instantiation -- + ----------------------------- + + procedure Check_Bad_Instantiation (N : Node_Id) is + Ent : Entity_Id; + + begin + -- Nothing to do if we do not have an instantiation (happens in some + -- error cases, and also in the formal package declaration case) + + if Nkind (N) not in N_Generic_Instantiation then + return; + + -- Nothing to do if serious errors detected (avoid cascaded errors) + + elsif Serious_Errors_Detected /= 0 then + return; + + -- Nothing to do if not in full analysis mode + + elsif not Full_Analysis then + return; + + -- Nothing to do if inside a generic template + + elsif Inside_A_Generic then + return; + + -- Nothing to do if a library level instantiation + + elsif Nkind (Parent (N)) = N_Compilation_Unit then + return; + + -- Nothing to do if we are compiling a proper body for semantic + -- purposes only. The generic body may be in another proper body. + + elsif + Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit + then + return; + end if; + + Ent := Get_Generic_Entity (N); + + -- The case we are interested in is when the generic spec is in the + -- current declarative part + + if not Same_Elaboration_Scope (Current_Scope, Scope (Ent)) + or else not In_Same_Extended_Unit (N, Ent) + then + return; + end if; + + -- If the generic entity is within a deeper instance than we are, then + -- either the instantiation to which we refer itself caused an ABE, in + -- which case that will be handled separately. Otherwise, we know that + -- the body we need appears as needed at the point of the instantiation. + -- If they are both at the same level but not within the same instance + -- then the body of the generic will be in the earlier instance. + + declare + D1 : constant Nat := Instantiation_Depth (Sloc (Ent)); + D2 : constant Nat := Instantiation_Depth (Sloc (N)); + + begin + if D1 > D2 then + return; + + elsif D1 = D2 + and then Is_Generic_Instance (Scope (Ent)) + and then not In_Open_Scopes (Scope (Ent)) + then + return; + end if; + end; + + -- Now we can proceed, if the entity being called has a completion, + -- then we are definitely OK, since we have already seen the body. + + if Has_Completion (Ent) then + return; + end if; + + -- If there is no body, then nothing to do + + if not Has_Generic_Body (N) then + return; + end if; + + -- Here we definitely have a bad instantiation + + Error_Msg_Warn := SPARK_Mode /= On; + Error_Msg_NE ("cannot instantiate& before body seen<<", N, Ent); + Error_Msg_N ("\Program_Error [<<", N); + + Insert_Elab_Check (N); + Set_Is_Known_Guaranteed_ABE (N); + end Check_Bad_Instantiation; + + --------------------- + -- Check_Elab_Call -- + --------------------- + + procedure Check_Elab_Call + (N : Node_Id; + Outer_Scope : Entity_Id := Empty; + In_Init_Proc : Boolean := False) + is + Ent : Entity_Id; + P : Node_Id; + + begin + pragma Assert (Legacy_Elaboration_Checks); + + -- If the reference is not in the main unit, there is nothing to check. + -- Elaboration call from units in the context of the main unit will lead + -- to semantic dependencies when those units are compiled. + + if not In_Extended_Main_Code_Unit (N) then + return; + end if; + + -- For an entry call, check relevant restriction + + if Nkind (N) = N_Entry_Call_Statement + and then not In_Subprogram_Or_Concurrent_Unit + then + Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N); + + -- Nothing to do if this is not an expected type of reference (happens + -- in some error conditions, and in some cases where rewriting occurs). + + elsif Nkind (N) not in N_Subprogram_Call + and then Nkind (N) /= N_Attribute_Reference + and then (SPARK_Mode /= On + or else Nkind (N) not in N_Has_Entity + or else No (Entity (N)) + or else Ekind (Entity (N)) /= E_Variable) + then + return; + + -- Nothing to do if this is a call already rewritten for elab checking. + -- Such calls appear as the targets of If_Expressions. + + -- This check MUST be wrong, it catches far too much + + elsif Nkind (Parent (N)) = N_If_Expression then + return; + + -- Nothing to do if inside a generic template + + elsif Inside_A_Generic + and then No (Enclosing_Generic_Body (N)) + then + return; + + -- Nothing to do if call is being pre-analyzed, as when within a + -- pre/postcondition, a predicate, or an invariant. + + elsif In_Spec_Expression then + return; + end if; + + -- Nothing to do if this is a call to a postcondition, which is always + -- within a subprogram body, even though the current scope may be the + -- enclosing scope of the subprogram. + + if Nkind (N) = N_Procedure_Call_Statement + and then Is_Entity_Name (Name (N)) + and then Chars (Entity (Name (N))) = Name_uPostconditions + then + return; + end if; + + -- Here we have a reference at elaboration time that must be checked + + if Debug_Flag_Underscore_LL then + Write_Str (" Check_Elab_Ref: "); + + if Nkind (N) = N_Attribute_Reference then + if not Is_Entity_Name (Prefix (N)) then + Write_Str ("<<not entity name>>"); + else + Write_Name (Chars (Entity (Prefix (N)))); + end if; + + Write_Str ("'Access"); + + elsif No (Name (N)) or else not Is_Entity_Name (Name (N)) then + Write_Str ("<<not entity name>> "); + + else + Write_Name (Chars (Entity (Name (N)))); + end if; + + Write_Str (" reference at "); + Write_Location (Sloc (N)); + Write_Eol; + end if; + + -- Climb up the tree to make sure we are not inside default expression + -- of a parameter specification or a record component, since in both + -- these cases, we will be doing the actual reference later, not now, + -- and it is at the time of the actual reference (statically speaking) + -- that we must do our static check, not at the time of its initial + -- analysis). + + -- However, we have to check references within component definitions + -- (e.g. a function call that determines an array component bound), + -- so we terminate the loop in that case. + + P := Parent (N); + while Present (P) loop + if Nkind_In (P, N_Parameter_Specification, + N_Component_Declaration) + then + return; + + -- The reference occurs within the constraint of a component, + -- so it must be checked. + + elsif Nkind (P) = N_Component_Definition then + exit; + + else + P := Parent (P); + end if; + end loop; + + -- Stuff that happens only at the outer level + + if No (Outer_Scope) then + Elab_Visited.Set_Last (0); + + -- Nothing to do if current scope is Standard (this is a bit odd, but + -- it happens in the case of generic instantiations). + + C_Scope := Current_Scope; + + if C_Scope = Standard_Standard then + return; + end if; + + -- First case, we are in elaboration code + + From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; + + if From_Elab_Code then + + -- Complain if ref that comes from source in preelaborated unit + -- and we are not inside a subprogram (i.e. we are in elab code). + + if Comes_From_Source (N) + and then In_Preelaborated_Unit + and then not In_Inlined_Body + and then Nkind (N) /= N_Attribute_Reference + then + -- This is a warning in GNAT mode allowing such calls to be + -- used in the predefined library with appropriate care. + + Error_Msg_Warn := GNAT_Mode; + Error_Msg_N + ("<<non-static call not allowed in preelaborated unit", N); + return; + end if; + + -- Second case, we are inside a subprogram or concurrent unit, which + -- means we are not in elaboration code. + + else + -- In this case, the issue is whether we are inside the + -- declarative part of the unit in which we live, or inside its + -- statements. In the latter case, there is no issue of ABE calls + -- at this level (a call from outside to the unit in which we live + -- might cause an ABE, but that will be detected when we analyze + -- that outer level call, as it recurses into the called unit). + + -- Climb up the tree, doing this test, and also testing for being + -- inside a default expression, which, as discussed above, is not + -- checked at this stage. + + declare + P : Node_Id; + L : List_Id; + + begin + P := N; + loop + -- If we find a parentless subtree, it seems safe to assume + -- that we are not in a declarative part and that no + -- checking is required. + + if No (P) then + return; + end if; + + if Is_List_Member (P) then + L := List_Containing (P); + P := Parent (L); + else + L := No_List; + P := Parent (P); + end if; + + exit when Nkind (P) = N_Subunit; + + -- Filter out case of default expressions, where we do not + -- do the check at this stage. + + if Nkind_In (P, N_Parameter_Specification, + N_Component_Declaration) + then + return; + end if; + + -- A protected body has no elaboration code and contains + -- only other bodies. + + if Nkind (P) = N_Protected_Body then + return; + + elsif Nkind_In (P, N_Subprogram_Body, + N_Task_Body, + N_Block_Statement, + N_Entry_Body) + then + if L = Declarations (P) then + exit; + + -- We are not in elaboration code, but we are doing + -- dynamic elaboration checks, in this case, we still + -- need to do the reference, since the subprogram we are + -- in could be called from another unit, also in dynamic + -- elaboration check mode, at elaboration time. + + elsif Dynamic_Elaboration_Checks then + + -- We provide a debug flag to disable this check. That + -- way we have an easy work around for regressions + -- that are caused by this new check. This debug flag + -- can be removed later. + + if Debug_Flag_DD then + return; + end if; + + -- Do the check in this case + + exit; + + elsif Nkind (P) = N_Task_Body then + + -- The check is deferred until Check_Task_Activation + -- but we need to capture local suppress pragmas + -- that may inhibit checks on this call. + + Ent := Get_Referenced_Ent (N); + + if No (Ent) then + return; + + elsif Elaboration_Checks_Suppressed (Current_Scope) + or else Elaboration_Checks_Suppressed (Ent) + or else Elaboration_Checks_Suppressed (Scope (Ent)) + then + if Nkind (N) in N_Subprogram_Call then + Set_No_Elaboration_Check (N); + end if; + end if; + + return; + + -- Static model, call is not in elaboration code, we + -- never need to worry, because in the static model the + -- top-level caller always takes care of things. + + else + return; + end if; + end if; + end loop; + end; + end if; + end if; + + Ent := Get_Referenced_Ent (N); + + if No (Ent) then + return; + end if; + + -- Determine whether a prior call to the same subprogram was already + -- examined within the same context. If this is the case, then there is + -- no need to proceed with the various warnings and checks because the + -- work was already done for the previous call. + + declare + Self : constant Visited_Element := + (Subp_Id => Ent, Context => Parent (N)); + + begin + for Index in 1 .. Elab_Visited.Last loop + if Self = Elab_Visited.Table (Index) then + return; + end if; + end loop; + end; + + -- See if we need to analyze this reference. We analyze it if either of + -- the following conditions is met: + + -- It is an inner level call (since in this case it was triggered + -- by an outer level call from elaboration code), but only if the + -- call is within the scope of the original outer level call. + + -- It is an outer level reference from elaboration code, or a call to + -- an entity is in the same elaboration scope. + + -- And in these cases, we will check both inter-unit calls and + -- intra-unit (within a single unit) calls. + + C_Scope := Current_Scope; + + -- If not outer level reference, then we follow it if it is within the + -- original scope of the outer reference. + + if Present (Outer_Scope) + and then Within (Scope (Ent), Outer_Scope) + then + Set_C_Scope; + Check_A_Call + (N => N, + E => Ent, + Outer_Scope => Outer_Scope, + Inter_Unit_Only => False, + In_Init_Proc => In_Init_Proc); + + -- Nothing to do if elaboration checks suppressed for this scope. + -- However, an interesting exception, the fact that elaboration checks + -- are suppressed within an instance (because we can trace the body when + -- we process the template) does not extend to calls to generic formal + -- subprograms. + + elsif Elaboration_Checks_Suppressed (Current_Scope) + and then not Is_Call_Of_Generic_Formal (N) + then + null; + + elsif From_Elab_Code then + Set_C_Scope; + Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); + + elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then + Set_C_Scope; + Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); + + -- If none of those cases holds, but Dynamic_Elaboration_Checks mode + -- is set, then we will do the check, but only in the inter-unit case + -- (this is to accommodate unguarded elaboration calls from other units + -- in which this same mode is set). We don't want warnings in this case, + -- it would generate warnings having nothing to do with elaboration. + + elsif Dynamic_Elaboration_Checks then + Set_C_Scope; + Check_A_Call + (N, + Ent, + Standard_Standard, + Inter_Unit_Only => True, + Generate_Warnings => False); + + -- Otherwise nothing to do + + else + return; + end if; + + -- A call to an Init_Proc in elaboration code may bring additional + -- dependencies, if some of the record components thereof have + -- initializations that are function calls that come from source. We + -- treat the current node as a call to each of these functions, to check + -- their elaboration impact. + + if Is_Init_Proc (Ent) and then From_Elab_Code then + Process_Init_Proc : declare + Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent); + + function Check_Init_Call (Nod : Node_Id) return Traverse_Result; + -- Find subprogram calls within body of Init_Proc for Traverse + -- instantiation below. + + procedure Traverse_Body is new Traverse_Proc (Check_Init_Call); + -- Traversal procedure to find all calls with body of Init_Proc + + --------------------- + -- Check_Init_Call -- + --------------------- + + function Check_Init_Call (Nod : Node_Id) return Traverse_Result is + Func : Entity_Id; + + begin + if Nkind (Nod) in N_Subprogram_Call + and then Is_Entity_Name (Name (Nod)) + then + Func := Entity (Name (Nod)); + + if Comes_From_Source (Func) then + Check_A_Call + (N, Func, Standard_Standard, Inter_Unit_Only => True); + end if; + + return OK; + + else + return OK; + end if; + end Check_Init_Call; + + -- Start of processing for Process_Init_Proc + + begin + if Nkind (Unit_Decl) = N_Subprogram_Body then + Traverse_Body (Handled_Statement_Sequence (Unit_Decl)); + end if; + end Process_Init_Proc; + end if; + end Check_Elab_Call; + + ----------------------- + -- Check_Elab_Assign -- + ----------------------- + + procedure Check_Elab_Assign (N : Node_Id) is + Ent : Entity_Id; + Scop : Entity_Id; + + Pkg_Spec : Entity_Id; + Pkg_Body : Entity_Id; + + begin + pragma Assert (Legacy_Elaboration_Checks); + + -- For record or array component, check prefix. If it is an access type, + -- then there is nothing to do (we do not know what is being assigned), + -- but otherwise this is an assignment to the prefix. + + if Nkind_In (N, N_Indexed_Component, + N_Selected_Component, + N_Slice) + then + if not Is_Access_Type (Etype (Prefix (N))) then + Check_Elab_Assign (Prefix (N)); + end if; + + return; + end if; + + -- For type conversion, check expression + + if Nkind (N) = N_Type_Conversion then + Check_Elab_Assign (Expression (N)); + return; + end if; + + -- Nothing to do if this is not an entity reference otherwise get entity + + if Is_Entity_Name (N) then + Ent := Entity (N); + else + return; + end if; + + -- What we are looking for is a reference in the body of a package that + -- modifies a variable declared in the visible part of the package spec. + + if Present (Ent) + and then Comes_From_Source (N) + and then not Suppress_Elaboration_Warnings (Ent) + and then Ekind (Ent) = E_Variable + and then not In_Private_Part (Ent) + and then Is_Library_Level_Entity (Ent) + then + Scop := Current_Scope; + loop + if No (Scop) or else Scop = Standard_Standard then + return; + elsif Ekind (Scop) = E_Package + and then Is_Compilation_Unit (Scop) + then + exit; + else + Scop := Scope (Scop); + end if; + end loop; + + -- Here Scop points to the containing library package + + Pkg_Spec := Scop; + Pkg_Body := Body_Entity (Pkg_Spec); + + -- All OK if the package has an Elaborate_Body pragma + + if Has_Pragma_Elaborate_Body (Scop) then + return; + end if; + + -- OK if entity being modified is not in containing package spec + + if not In_Same_Source_Unit (Scop, Ent) then + return; + end if; + + -- All OK if entity appears in generic package or generic instance. + -- We just get too messed up trying to give proper warnings in the + -- presence of generics. Better no message than a junk one. + + Scop := Scope (Ent); + while Present (Scop) and then Scop /= Pkg_Spec loop + if Ekind (Scop) = E_Generic_Package then + return; + elsif Ekind (Scop) = E_Package + and then Is_Generic_Instance (Scop) + then + return; + end if; + + Scop := Scope (Scop); + end loop; + + -- All OK if in task, don't issue warnings there + + if In_Task_Activation then + return; + end if; + + -- OK if no package body + + if No (Pkg_Body) then + return; + end if; + + -- OK if reference is not in package body + + if not In_Same_Source_Unit (Pkg_Body, N) then + return; + end if; + + -- OK if package body has no handled statement sequence + + declare + HSS : constant Node_Id := + Handled_Statement_Sequence (Declaration_Node (Pkg_Body)); + begin + if No (HSS) or else not Comes_From_Source (HSS) then + return; + end if; + end; + + -- We definitely have a case of a modification of an entity in + -- the package spec from the elaboration code of the package body. + -- We may not give the warning (because there are some additional + -- checks to avoid too many false positives), but it would be a good + -- idea for the binder to try to keep the body elaboration close to + -- the spec elaboration. + + Set_Elaborate_Body_Desirable (Pkg_Spec); + + -- All OK in gnat mode (we know what we are doing) + + if GNAT_Mode then + return; + end if; + + -- All OK if all warnings suppressed + + if Warning_Mode = Suppress then + return; + end if; + + -- All OK if elaboration checks suppressed for entity + + if Checks_May_Be_Suppressed (Ent) + and then Is_Check_Suppressed (Ent, Elaboration_Check) + then + return; + end if; + + -- OK if the entity is initialized. Note that the No_Initialization + -- flag usually means that the initialization has been rewritten into + -- assignments, but that still counts for us. + + declare + Decl : constant Node_Id := Declaration_Node (Ent); + begin + if Nkind (Decl) = N_Object_Declaration + and then (Present (Expression (Decl)) + or else No_Initialization (Decl)) + then + return; + end if; + end; + + -- Here is where we give the warning + + -- All OK if warnings suppressed on the entity + + if not Has_Warnings_Off (Ent) then + Error_Msg_Sloc := Sloc (Ent); + + Error_Msg_NE + ("??& can be accessed by clients before this initialization", + N, Ent); + Error_Msg_NE + ("\??add Elaborate_Body to spec to ensure & is initialized", + N, Ent); + end if; + + if not All_Errors_Mode then + Set_Suppress_Elaboration_Warnings (Ent); + end if; + end if; + end Check_Elab_Assign; + + ---------------------- + -- Check_Elab_Calls -- + ---------------------- + + -- WARNING: This routine manages SPARK regions + + procedure Check_Elab_Calls is + Saved_SM : SPARK_Mode_Type; + Saved_SMP : Node_Id; + + begin + pragma Assert (Legacy_Elaboration_Checks); + + -- If expansion is disabled, do not generate any checks, unless we + -- are in GNATprove mode, so that errors are issued in GNATprove for + -- violations of static elaboration rules in SPARK code. Also skip + -- checks if any subunits are missing because in either case we lack the + -- full information that we need, and no object file will be created in + -- any case. + + if (not Expander_Active and not GNATprove_Mode) + or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) + or else Subunits_Missing + then + return; + end if; + + -- Skip delayed calls if we had any errors + + if Serious_Errors_Detected = 0 then + Delaying_Elab_Checks := False; + Expander_Mode_Save_And_Set (True); + + for J in Delay_Check.First .. Delay_Check.Last loop + Push_Scope (Delay_Check.Table (J).Curscop); + From_Elab_Code := Delay_Check.Table (J).From_Elab_Code; + In_Task_Activation := Delay_Check.Table (J).In_Task_Activation; + + Saved_SM := SPARK_Mode; + Saved_SMP := SPARK_Mode_Pragma; + + -- Set appropriate value of SPARK_Mode + + if Delay_Check.Table (J).From_SPARK_Code then + SPARK_Mode := On; + end if; + + Check_Internal_Call_Continue + (N => Delay_Check.Table (J).N, + E => Delay_Check.Table (J).E, + Outer_Scope => Delay_Check.Table (J).Outer_Scope, + Orig_Ent => Delay_Check.Table (J).Orig_Ent); + + Restore_SPARK_Mode (Saved_SM, Saved_SMP); + Pop_Scope; + end loop; + + -- Set Delaying_Elab_Checks back on for next main compilation + + Expander_Mode_Restore; + Delaying_Elab_Checks := True; + end if; + end Check_Elab_Calls; + + ------------------------------ + -- Check_Elab_Instantiation -- + ------------------------------ + + procedure Check_Elab_Instantiation + (N : Node_Id; + Outer_Scope : Entity_Id := Empty) + is + Ent : Entity_Id; + + begin + pragma Assert (Legacy_Elaboration_Checks); + + -- Check for and deal with bad instantiation case. There is some + -- duplicated code here, but we will worry about this later ??? + + Check_Bad_Instantiation (N); + + if Is_Known_Guaranteed_ABE (N) then + return; + end if; + + -- Nothing to do if we do not have an instantiation (happens in some + -- error cases, and also in the formal package declaration case) + + if Nkind (N) not in N_Generic_Instantiation then + return; + end if; + + -- Nothing to do if inside a generic template + + if Inside_A_Generic then + return; + end if; + + -- Nothing to do if the instantiation is not in the main unit + + if not In_Extended_Main_Code_Unit (N) then + return; + end if; + + Ent := Get_Generic_Entity (N); + From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; + + -- See if we need to analyze this instantiation. We analyze it if + -- either of the following conditions is met: + + -- It is an inner level instantiation (since in this case it was + -- triggered by an outer level call from elaboration code), but + -- only if the instantiation is within the scope of the original + -- outer level call. + + -- It is an outer level instantiation from elaboration code, or the + -- instantiated entity is in the same elaboration scope. + + -- And in these cases, we will check both the inter-unit case and + -- the intra-unit (within a single unit) case. + + C_Scope := Current_Scope; + + if Present (Outer_Scope) and then Within (Scope (Ent), Outer_Scope) then + Set_C_Scope; + Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False); + + elsif From_Elab_Code then + Set_C_Scope; + Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); + + elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then + Set_C_Scope; + Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); + + -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is + -- set, then we will do the check, but only in the inter-unit case (this + -- is to accommodate unguarded elaboration calls from other units in + -- which this same mode is set). We inhibit warnings in this case, since + -- this instantiation is not occurring in elaboration code. + + elsif Dynamic_Elaboration_Checks then + Set_C_Scope; + Check_A_Call + (N, + Ent, + Standard_Standard, + Inter_Unit_Only => True, + Generate_Warnings => False); + + else + return; + end if; + end Check_Elab_Instantiation; + + ------------------------- + -- Check_Internal_Call -- + ------------------------- + + procedure Check_Internal_Call + (N : Node_Id; + E : Entity_Id; + Outer_Scope : Entity_Id; + Orig_Ent : Entity_Id) + is + function Within_Initial_Condition (Call : Node_Id) return Boolean; + -- Determine whether call Call occurs within pragma Initial_Condition or + -- pragma Check with check_kind set to Initial_Condition. + + ------------------------------ + -- Within_Initial_Condition -- + ------------------------------ + + function Within_Initial_Condition (Call : Node_Id) return Boolean is + Args : List_Id; + Nam : Name_Id; + Par : Node_Id; + + begin + -- Traverse the parent chain looking for an enclosing pragma + + Par := Call; + while Present (Par) loop + if Nkind (Par) = N_Pragma then + Nam := Pragma_Name (Par); + + -- Pragma Initial_Condition appears in its alternative from as + -- Check (Initial_Condition, ...). + + if Nam = Name_Check then + Args := Pragma_Argument_Associations (Par); + + -- Pragma Check should have at least two arguments + + pragma Assert (Present (Args)); + + return + Chars (Expression (First (Args))) = Name_Initial_Condition; + + -- Direct match + + elsif Nam = Name_Initial_Condition then + return True; + + -- Since pragmas are never nested within other pragmas, stop + -- the traversal. + + else + return False; + end if; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Par) then + exit; + end if; + + Par := Parent (Par); + + -- If assertions are not enabled, the check pragma is rewritten + -- as an if_statement in sem_prag, to generate various warnings + -- on boolean expressions. Retrieve the original pragma. + + if Nkind (Original_Node (Par)) = N_Pragma then + Par := Original_Node (Par); + end if; + end loop; + + return False; + end Within_Initial_Condition; + + -- Local variables + + Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; + + -- Start of processing for Check_Internal_Call + + begin + -- For P'Access, we want to warn if the -gnatw.f switch is set, and the + -- node comes from source. + + if Nkind (N) = N_Attribute_Reference + and then ((not Warn_On_Elab_Access and then not Debug_Flag_Dot_O) + or else not Comes_From_Source (N)) + then + return; + + -- If not function or procedure call, instantiation, or 'Access, then + -- ignore call (this happens in some error cases and rewriting cases). + + elsif not Nkind_In (N, N_Attribute_Reference, + N_Function_Call, + N_Procedure_Call_Statement) + and then not Inst_Case + then + return; + + -- Nothing to do if this is a call or instantiation that has already + -- been found to be a sure ABE. + + elsif Nkind (N) /= N_Attribute_Reference + and then Is_Known_Guaranteed_ABE (N) + then + return; + + -- Nothing to do if errors already detected (avoid cascaded errors) + + elsif Serious_Errors_Detected /= 0 then + return; + + -- Nothing to do if not in full analysis mode + + elsif not Full_Analysis then + return; + + -- Nothing to do if analyzing in special spec-expression mode, since the + -- call is not actually being made at this time. + + elsif In_Spec_Expression then + return; + + -- Nothing to do for call to intrinsic subprogram + + elsif Is_Intrinsic_Subprogram (E) then + return; + + -- Nothing to do if call is within a generic unit + + elsif Inside_A_Generic then + return; + + -- Nothing to do when the call appears within pragma Initial_Condition. + -- The pragma is part of the elaboration statements of a package body + -- and may only call external subprograms or subprograms whose body is + -- already available. + + elsif Within_Initial_Condition (N) then + return; + end if; + + -- Delay this call if we are still delaying calls + + if Delaying_Elab_Checks then + Delay_Check.Append + ((N => N, + E => E, + Orig_Ent => Orig_Ent, + Curscop => Current_Scope, + Outer_Scope => Outer_Scope, + From_Elab_Code => From_Elab_Code, + In_Task_Activation => In_Task_Activation, + From_SPARK_Code => SPARK_Mode = On)); + return; + + -- Otherwise, call phase 2 continuation right now + + else + Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent); + end if; + end Check_Internal_Call; + + ---------------------------------- + -- Check_Internal_Call_Continue -- + ---------------------------------- + + procedure Check_Internal_Call_Continue + (N : Node_Id; + E : Entity_Id; + Outer_Scope : Entity_Id; + Orig_Ent : Entity_Id) + is + function Find_Elab_Reference (N : Node_Id) return Traverse_Result; + -- Function applied to each node as we traverse the body. Checks for + -- call or entity reference that needs checking, and if so checks it. + -- Always returns OK, so entire tree is traversed, except that as + -- described below subprogram bodies are skipped for now. + + procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference); + -- Traverse procedure using above Find_Elab_Reference function + + ------------------------- + -- Find_Elab_Reference -- + ------------------------- + + function Find_Elab_Reference (N : Node_Id) return Traverse_Result is + Actual : Node_Id; + + begin + -- If user has specified that there are no entry calls in elaboration + -- code, do not trace past an accept statement, because the rendez- + -- vous will happen after elaboration. + + if Nkind_In (Original_Node (N), N_Accept_Statement, + N_Selective_Accept) + and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code) + then + return Abandon; + + -- If we have a function call, check it + + elsif Nkind (N) = N_Function_Call then + Check_Elab_Call (N, Outer_Scope); + return OK; + + -- If we have a procedure call, check the call, and also check + -- arguments that are assignments (OUT or IN OUT mode formals). + + elsif Nkind (N) = N_Procedure_Call_Statement then + Check_Elab_Call (N, Outer_Scope, In_Init_Proc => Is_Init_Proc (E)); + + Actual := First_Actual (N); + while Present (Actual) loop + if Known_To_Be_Assigned (Actual) then + Check_Elab_Assign (Actual); + end if; + + Next_Actual (Actual); + end loop; + + return OK; + + -- If we have an access attribute for a subprogram, check it. + -- Suppress this behavior under debug flag. + + elsif not Debug_Flag_Dot_UU + and then Nkind (N) = N_Attribute_Reference + and then Nam_In (Attribute_Name (N), Name_Access, + Name_Unrestricted_Access) + and then Is_Entity_Name (Prefix (N)) + and then Is_Subprogram (Entity (Prefix (N))) + then + Check_Elab_Call (N, Outer_Scope); + return OK; + + -- In SPARK mode, if we have an entity reference to a variable, then + -- check it. For now we consider any reference. + + elsif SPARK_Mode = On + and then Nkind (N) in N_Has_Entity + and then Present (Entity (N)) + and then Ekind (Entity (N)) = E_Variable + then + Check_Elab_Call (N, Outer_Scope); + return OK; + + -- If we have a generic instantiation, check it + + elsif Nkind (N) in N_Generic_Instantiation then + Check_Elab_Instantiation (N, Outer_Scope); + return OK; + + -- Skip subprogram bodies that come from source (wait for call to + -- analyze these). The reason for the come from source test is to + -- avoid catching task bodies. + + -- For task bodies, we should really avoid these too, waiting for the + -- task activation, but that's too much trouble to catch for now, so + -- we go in unconditionally. This is not so terrible, it means the + -- error backtrace is not quite complete, and we are too eager to + -- scan bodies of tasks that are unused, but this is hardly very + -- significant. + + elsif Nkind (N) = N_Subprogram_Body + and then Comes_From_Source (N) + then + return Skip; + + elsif Nkind (N) = N_Assignment_Statement + and then Comes_From_Source (N) + then + Check_Elab_Assign (Name (N)); + return OK; + + else + return OK; + end if; + end Find_Elab_Reference; + + Inst_Case : constant Boolean := Is_Generic_Unit (E); + Loc : constant Source_Ptr := Sloc (N); + + Ebody : Entity_Id; + Sbody : Node_Id; + + -- Start of processing for Check_Internal_Call_Continue + + begin + -- Save outer level call if at outer level + + if Elab_Call.Last = 0 then + Outer_Level_Sloc := Loc; + end if; + + -- If the call is to a function that renames a literal, no check needed + + if Ekind (E) = E_Enumeration_Literal then + return; + end if; + + -- Register the subprogram as examined within this particular context. + -- This ensures that calls to the same subprogram but in different + -- contexts receive warnings and checks of their own since the calls + -- may be reached through different flow paths. + + Elab_Visited.Append ((Subp_Id => E, Context => Parent (N))); + + Sbody := Unit_Declaration_Node (E); + + if not Nkind_In (Sbody, N_Subprogram_Body, N_Package_Body) then + Ebody := Corresponding_Body (Sbody); + + if No (Ebody) then + return; + else + Sbody := Unit_Declaration_Node (Ebody); + end if; + end if; + + -- If the body appears after the outer level call or instantiation then + -- we have an error case handled below. + + if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody)) + and then not In_Task_Activation + then + null; + + -- If we have the instantiation case we are done, since we now know that + -- the body of the generic appeared earlier. + + elsif Inst_Case then + return; + + -- Otherwise we have a call, so we trace through the called body to see + -- if it has any problems. + + else + pragma Assert (Nkind (Sbody) = N_Subprogram_Body); + + Elab_Call.Append ((Cloc => Loc, Ent => E)); + + if Debug_Flag_Underscore_LL then + Write_Str ("Elab_Call.Last = "); + Write_Int (Int (Elab_Call.Last)); + Write_Str (" Ent = "); + Write_Name (Chars (E)); + Write_Str (" at "); + Write_Location (Sloc (N)); + Write_Eol; + end if; + + -- Now traverse declarations and statements of subprogram body. Note + -- that we cannot simply Traverse (Sbody), since traverse does not + -- normally visit subprogram bodies. + + declare + Decl : Node_Id; + begin + Decl := First (Declarations (Sbody)); + while Present (Decl) loop + Traverse (Decl); + Next (Decl); + end loop; + end; + + Traverse (Handled_Statement_Sequence (Sbody)); + + Elab_Call.Decrement_Last; + return; + end if; + + -- Here is the case of calling a subprogram where the body has not yet + -- been encountered. A warning message is needed, except if this is the + -- case of appearing within an aspect specification that results in + -- a check call, we do not really have such a situation, so no warning + -- is needed (e.g. the case of a precondition, where the call appears + -- textually before the body, but in actual fact is moved to the + -- appropriate subprogram body and so does not need a check). + + declare + P : Node_Id; + O : Node_Id; + + begin + P := Parent (N); + loop + -- Keep looking at parents if we are still in the subexpression + + if Nkind (P) in N_Subexpr then + P := Parent (P); + + -- Here P is the parent of the expression, check for special case + + else + O := Original_Node (P); + + -- Definitely not the special case if orig node is not a pragma + + exit when Nkind (O) /= N_Pragma; + + -- Check we have an If statement or a null statement (happens + -- when the If has been expanded to be True). + + exit when not Nkind_In (P, N_If_Statement, N_Null_Statement); + + -- Our special case will be indicated either by the pragma + -- coming from an aspect ... + + if Present (Corresponding_Aspect (O)) then + return; + + -- Or, in the case of an initial condition, specifically by a + -- Check pragma specifying an Initial_Condition check. + + elsif Pragma_Name (O) = Name_Check + and then + Chars + (Expression (First (Pragma_Argument_Associations (O)))) = + Name_Initial_Condition + then + return; + + -- For anything else, we have an error + + else + exit; + end if; + end if; + end loop; + end; + + -- Not that special case, warning and dynamic check is required + + -- If we have nothing in the call stack, then this is at the outer + -- level, and the ABE is bound to occur, unless it's a 'Access, or + -- it's a renaming. + + if Elab_Call.Last = 0 then + Error_Msg_Warn := SPARK_Mode /= On; + + declare + Insert_Check : Boolean := True; + -- This flag is set to True if an elaboration check should be + -- inserted. + + begin + if In_Task_Activation then + Insert_Check := False; + + elsif Inst_Case then + Error_Msg_NE + ("cannot instantiate& before body seen<<", N, Orig_Ent); + + elsif Nkind (N) = N_Attribute_Reference then + Error_Msg_NE + ("Access attribute of & before body seen<<", N, Orig_Ent); + Error_Msg_N ("\possible Program_Error on later references<", N); + Insert_Check := False; + + elsif Nkind (Unit_Declaration_Node (Orig_Ent)) /= + N_Subprogram_Renaming_Declaration + then + Error_Msg_NE + ("cannot call& before body seen<<", N, Orig_Ent); + + elsif not Is_Generic_Actual_Subprogram (Orig_Ent) then + Insert_Check := False; + end if; + + if Insert_Check then + Error_Msg_N ("\Program_Error [<<", N); + Insert_Elab_Check (N); + end if; + end; + + -- Call is not at outer level + + else + -- Do not generate elaboration checks in GNATprove mode because the + -- elaboration counter and the check are both forms of expansion. + + if GNATprove_Mode then + null; + + -- Generate an elaboration check + + elsif not Elaboration_Checks_Suppressed (E) then + Set_Elaboration_Entity_Required (E); + + -- Create a declaration of the elaboration entity, and insert it + -- prior to the subprogram or the generic unit, within the same + -- scope. Since the subprogram may be overloaded, create a unique + -- entity. + + if No (Elaboration_Entity (E)) then + declare + Loce : constant Source_Ptr := Sloc (E); + Ent : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (E), 'E', -1)); + + begin + Set_Elaboration_Entity (E, Ent); + Push_Scope (Scope (E)); + + Insert_Action (Declaration_Node (E), + Make_Object_Declaration (Loce, + Defining_Identifier => Ent, + Object_Definition => + New_Occurrence_Of (Standard_Short_Integer, Loce), + Expression => + Make_Integer_Literal (Loc, Uint_0))); + + -- Set elaboration flag at the point of the body + + Set_Elaboration_Flag (Sbody, E); + + -- Kill current value indication. This is necessary because + -- the tests of this flag are inserted out of sequence and + -- must not pick up bogus indications of the wrong constant + -- value. Also, this is never a true constant, since one way + -- or another, it gets reset. + + Set_Current_Value (Ent, Empty); + Set_Last_Assignment (Ent, Empty); + Set_Is_True_Constant (Ent, False); + Pop_Scope; + end; + end if; + + -- Generate: + -- if Enn = 0 then + -- raise Program_Error with "access before elaboration"; + -- end if; + + Insert_Elab_Check (N, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Elaborated, + Prefix => New_Occurrence_Of (E, Loc))); + end if; + + -- Generate the warning + + if not Suppress_Elaboration_Warnings (E) + and then not Elaboration_Checks_Suppressed (E) + + -- Suppress this warning if we have a function call that occurred + -- within an assertion expression, since we can get false warnings + -- in this case, due to the out of order handling in this case. + + and then + (Nkind (Original_Node (N)) /= N_Function_Call + or else not In_Assertion_Expression_Pragma (Original_Node (N))) + then + Error_Msg_Warn := SPARK_Mode /= On; + + if Inst_Case then + Error_Msg_NE + ("instantiation of& may occur before body is seen<l<", + N, Orig_Ent); + else + -- A rather specific check. For Finalize/Adjust/Initialize, if + -- the type has Warnings_Off set, suppress the warning. + + if Nam_In (Chars (E), Name_Adjust, + Name_Finalize, + Name_Initialize) + and then Present (First_Formal (E)) + then + declare + T : constant Entity_Id := Etype (First_Formal (E)); + begin + if Is_Controlled (T) then + if Warnings_Off (T) + or else (Ekind (T) = E_Private_Type + and then Warnings_Off (Full_View (T))) + then + goto Output; + end if; + end if; + end; + end if; + + -- Go ahead and give warning if not this special case + + Error_Msg_NE + ("call to& may occur before body is seen<l<", N, Orig_Ent); + end if; + + Error_Msg_N ("\Program_Error ]<l<", N); + + -- There is no need to query the elaboration warning message flags + -- because the main message is an error, not a warning, therefore + -- all the clarification messages produces by Output_Calls must be + -- emitted unconditionally. + + <<Output>> + + Output_Calls (N, Check_Elab_Flag => False); + end if; + end if; + end Check_Internal_Call_Continue; + + --------------------------- + -- Check_Task_Activation -- + --------------------------- + + procedure Check_Task_Activation (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Inter_Procs : constant Elist_Id := New_Elmt_List; + Intra_Procs : constant Elist_Id := New_Elmt_List; + Ent : Entity_Id; + P : Entity_Id; + Task_Scope : Entity_Id; + Cunit_SC : Boolean := False; + Decl : Node_Id; + Elmt : Elmt_Id; + Enclosing : Entity_Id; + + procedure Add_Task_Proc (Typ : Entity_Id); + -- Add to Task_Procs the task body procedure(s) of task types in Typ. + -- For record types, this procedure recurses over component types. + + procedure Collect_Tasks (Decls : List_Id); + -- Collect the types of the tasks that are to be activated in the given + -- list of declarations, in order to perform elaboration checks on the + -- corresponding task procedures that are called implicitly here. + + function Outer_Unit (E : Entity_Id) return Entity_Id; + -- find enclosing compilation unit of Entity, ignoring subunits, or + -- else enclosing subprogram. If E is not a package, there is no need + -- for inter-unit elaboration checks. + + ------------------- + -- Add_Task_Proc -- + ------------------- + + procedure Add_Task_Proc (Typ : Entity_Id) is + Comp : Entity_Id; + Proc : Entity_Id := Empty; + + begin + if Is_Task_Type (Typ) then + Proc := Get_Task_Body_Procedure (Typ); + + elsif Is_Array_Type (Typ) + and then Has_Task (Base_Type (Typ)) + then + Add_Task_Proc (Component_Type (Typ)); + + elsif Is_Record_Type (Typ) + and then Has_Task (Base_Type (Typ)) + then + Comp := First_Component (Typ); + while Present (Comp) loop + Add_Task_Proc (Etype (Comp)); + Comp := Next_Component (Comp); + end loop; + end if; + + -- If the task type is another unit, we will perform the usual + -- elaboration check on its enclosing unit. If the type is in the + -- same unit, we can trace the task body as for an internal call, + -- but we only need to examine other external calls, because at + -- the point the task is activated, internal subprogram bodies + -- will have been elaborated already. We keep separate lists for + -- each kind of task. + + -- Skip this test if errors have occurred, since in this case + -- we can get false indications. + + if Serious_Errors_Detected /= 0 then + return; + end if; + + if Present (Proc) then + if Outer_Unit (Scope (Proc)) = Enclosing then + + if No (Corresponding_Body (Unit_Declaration_Node (Proc))) + and then + (not Is_Generic_Instance (Scope (Proc)) + or else Scope (Proc) = Scope (Defining_Identifier (Decl))) + then + Error_Msg_Warn := SPARK_Mode /= On; + Error_Msg_N + ("task will be activated before elaboration of its body<<", + Decl); + Error_Msg_N ("\Program_Error [<<", Decl); + + elsif Present + (Corresponding_Body (Unit_Declaration_Node (Proc))) + then + Append_Elmt (Proc, Intra_Procs); + end if; + + else + -- No need for multiple entries of the same type + + Elmt := First_Elmt (Inter_Procs); + while Present (Elmt) loop + if Node (Elmt) = Proc then + return; + end if; + + Next_Elmt (Elmt); + end loop; + + Append_Elmt (Proc, Inter_Procs); + end if; + end if; + end Add_Task_Proc; + + ------------------- + -- Collect_Tasks -- + ------------------- + + procedure Collect_Tasks (Decls : List_Id) is + begin + if Present (Decls) then + Decl := First (Decls); + while Present (Decl) loop + if Nkind (Decl) = N_Object_Declaration + and then Has_Task (Etype (Defining_Identifier (Decl))) + then + Add_Task_Proc (Etype (Defining_Identifier (Decl))); + end if; + + Next (Decl); + end loop; + end if; + end Collect_Tasks; + + ---------------- + -- Outer_Unit -- + ---------------- + + function Outer_Unit (E : Entity_Id) return Entity_Id is + Outer : Entity_Id; + + begin + Outer := E; + while Present (Outer) loop + if Elaboration_Checks_Suppressed (Outer) then + Cunit_SC := True; + end if; + + exit when Is_Child_Unit (Outer) + or else Scope (Outer) = Standard_Standard + or else Ekind (Outer) /= E_Package; + Outer := Scope (Outer); + end loop; + + return Outer; + end Outer_Unit; + + -- Start of processing for Check_Task_Activation + + begin + pragma Assert (Legacy_Elaboration_Checks); + + Enclosing := Outer_Unit (Current_Scope); + + -- Find all tasks declared in the current unit + + if Nkind (N) = N_Package_Body then + P := Unit_Declaration_Node (Corresponding_Spec (N)); + + Collect_Tasks (Declarations (N)); + Collect_Tasks (Visible_Declarations (Specification (P))); + Collect_Tasks (Private_Declarations (Specification (P))); + + elsif Nkind (N) = N_Package_Declaration then + Collect_Tasks (Visible_Declarations (Specification (N))); + Collect_Tasks (Private_Declarations (Specification (N))); + + else + Collect_Tasks (Declarations (N)); + end if; + + -- We only perform detailed checks in all tasks that are library level + -- entities. If the master is a subprogram or task, activation will + -- depend on the activation of the master itself. + + -- Should dynamic checks be added in the more general case??? + + if Ekind (Enclosing) /= E_Package then + return; + end if; + + -- For task types defined in other units, we want the unit containing + -- the task body to be elaborated before the current one. + + Elmt := First_Elmt (Inter_Procs); + while Present (Elmt) loop + Ent := Node (Elmt); + Task_Scope := Outer_Unit (Scope (Ent)); + + if not Is_Compilation_Unit (Task_Scope) then + null; + + elsif Suppress_Elaboration_Warnings (Task_Scope) + or else Elaboration_Checks_Suppressed (Task_Scope) + then + null; + + elsif Dynamic_Elaboration_Checks then + if not Elaboration_Checks_Suppressed (Ent) + and then not Cunit_SC + and then not Restriction_Active + (No_Entry_Calls_In_Elaboration_Code) + then + -- Runtime elaboration check required. Generate check of the + -- elaboration counter for the unit containing the entity. + + Insert_Elab_Check (N, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Spec_Entity (Task_Scope), Loc), + Attribute_Name => Name_Elaborated)); + end if; + + else + -- Force the binder to elaborate other unit first + + if Elab_Info_Messages + and then not Suppress_Elaboration_Warnings (Ent) + and then not Elaboration_Checks_Suppressed (Ent) + and then not Suppress_Elaboration_Warnings (Task_Scope) + and then not Elaboration_Checks_Suppressed (Task_Scope) + then + Error_Msg_Node_2 := Task_Scope; + Error_Msg_NE + ("info: activation of an instance of task type & requires " + & "pragma Elaborate_All on &?$?", N, Ent); + end if; + + Activate_Elaborate_All_Desirable (N, Task_Scope); + Set_Suppress_Elaboration_Warnings (Task_Scope); + end if; + + Next_Elmt (Elmt); + end loop; + + -- For tasks declared in the current unit, trace other calls within the + -- task procedure bodies, which are available. + + if not Debug_Flag_Dot_Y then + In_Task_Activation := True; + + Elmt := First_Elmt (Intra_Procs); + while Present (Elmt) loop + Ent := Node (Elmt); + Check_Internal_Call_Continue (N, Ent, Enclosing, Ent); + Next_Elmt (Elmt); + end loop; + + In_Task_Activation := False; + end if; + end Check_Task_Activation; + + ------------------------ + -- Get_Referenced_Ent -- + ------------------------ + + function Get_Referenced_Ent (N : Node_Id) return Entity_Id is + Nam : Node_Id; + + begin + if Nkind (N) in N_Has_Entity + and then Present (Entity (N)) + and then Ekind (Entity (N)) = E_Variable + then + return Entity (N); + end if; + + if Nkind (N) = N_Attribute_Reference then + Nam := Prefix (N); + else + Nam := Name (N); + end if; + + if No (Nam) then + return Empty; + elsif Nkind (Nam) = N_Selected_Component then + return Entity (Selector_Name (Nam)); + elsif not Is_Entity_Name (Nam) then + return Empty; + else + return Entity (Nam); + end if; + end Get_Referenced_Ent; + + ---------------------- + -- Has_Generic_Body -- + ---------------------- + + function Has_Generic_Body (N : Node_Id) return Boolean is + Ent : constant Entity_Id := Get_Generic_Entity (N); + Decl : constant Node_Id := Unit_Declaration_Node (Ent); + Scop : Entity_Id; + + function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id; + -- Determine if the list of nodes headed by N and linked by Next + -- contains a package body for the package spec entity E, and if so + -- return the package body. If not, then returns Empty. + + function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id; + -- This procedure is called load the unit whose name is given by Nam. + -- This unit is being loaded to see whether it contains an optional + -- generic body. The returned value is the loaded unit, which is always + -- a package body (only package bodies can contain other entities in the + -- sense in which Has_Generic_Body is interested). We only attempt to + -- load bodies if we are generating code. If we are in semantics check + -- only mode, then it would be wrong to load bodies that are not + -- required from a semantic point of view, so in this case we return + -- Empty. The result is that the caller may incorrectly decide that a + -- generic spec does not have a body when in fact it does, but the only + -- harm in this is that some warnings on elaboration problems may be + -- lost in semantic checks only mode, which is not big loss. We also + -- return Empty if we go for a body and it is not there. + + function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id; + -- PE is the entity for a package spec. This function locates the + -- corresponding package body, returning Empty if none is found. The + -- package body returned is fully parsed but may not yet be analyzed, + -- so only syntactic fields should be referenced. + + ------------------ + -- Find_Body_In -- + ------------------ + + function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is + Nod : Node_Id; + + begin + Nod := N; + while Present (Nod) loop + + -- If we found the package body we are looking for, return it + + if Nkind (Nod) = N_Package_Body + and then Chars (Defining_Unit_Name (Nod)) = Chars (E) + then + return Nod; + + -- If we found the stub for the body, go after the subunit, + -- loading it if necessary. + + elsif Nkind (Nod) = N_Package_Body_Stub + and then Chars (Defining_Identifier (Nod)) = Chars (E) + then + if Present (Library_Unit (Nod)) then + return Unit (Library_Unit (Nod)); + + else + return Load_Package_Body (Get_Unit_Name (Nod)); + end if; + + -- If neither package body nor stub, keep looking on chain + + else + Next (Nod); + end if; + end loop; + + return Empty; + end Find_Body_In; + + ----------------------- + -- Load_Package_Body -- + ----------------------- + + function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is + U : Unit_Number_Type; + + begin + if Operating_Mode /= Generate_Code then + return Empty; + else + U := + Load_Unit + (Load_Name => Nam, + Required => False, + Subunit => False, + Error_Node => N); + + if U = No_Unit then + return Empty; + else + return Unit (Cunit (U)); + end if; + end if; + end Load_Package_Body; + + ------------------------------- + -- Locate_Corresponding_Body -- + ------------------------------- + + function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is + Spec : constant Node_Id := Declaration_Node (PE); + Decl : constant Node_Id := Parent (Spec); + Scop : constant Entity_Id := Scope (PE); + PBody : Node_Id; + + begin + if Is_Library_Level_Entity (PE) then + + -- If package is a library unit that requires a body, we have no + -- choice but to go after that body because it might contain an + -- optional body for the original generic package. + + if Unit_Requires_Body (PE) then + + -- Load the body. Note that we are a little careful here to use + -- Spec to get the unit number, rather than PE or Decl, since + -- in the case where the package is itself a library level + -- instantiation, Spec will properly reference the generic + -- template, which is what we really want. + + return + Load_Package_Body + (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec)))); + + -- But if the package is a library unit that does NOT require + -- a body, then no body is permitted, so we are sure that there + -- is no body for the original generic package. + + else + return Empty; + end if; + + -- Otherwise look and see if we are embedded in a further package + + elsif Is_Package_Or_Generic_Package (Scop) then + + -- If so, get the body of the enclosing package, and look in + -- its package body for the package body we are looking for. + + PBody := Locate_Corresponding_Body (Scop); + + if No (PBody) then + return Empty; + else + return Find_Body_In (PE, First (Declarations (PBody))); + end if; + + -- If we are not embedded in a further package, then the body + -- must be in the same declarative part as we are. + + else + return Find_Body_In (PE, Next (Decl)); + end if; + end Locate_Corresponding_Body; + + -- Start of processing for Has_Generic_Body + + begin + if Present (Corresponding_Body (Decl)) then + return True; + + elsif Unit_Requires_Body (Ent) then + return True; + + -- Compilation units cannot have optional bodies + + elsif Is_Compilation_Unit (Ent) then + return False; + + -- Otherwise look at what scope we are in + + else + Scop := Scope (Ent); + + -- Case of entity is in other than a package spec, in this case + -- the body, if present, must be in the same declarative part. + + if not Is_Package_Or_Generic_Package (Scop) then + declare + P : Node_Id; + + begin + -- Declaration node may get us a spec, so if so, go to + -- the parent declaration. + + P := Declaration_Node (Ent); + while not Is_List_Member (P) loop + P := Parent (P); + end loop; + + return Present (Find_Body_In (Ent, Next (P))); + end; + + -- If the entity is in a package spec, then we have to locate + -- the corresponding package body, and look there. + + else + declare + PBody : constant Node_Id := Locate_Corresponding_Body (Scop); + + begin + if No (PBody) then + return False; + else + return + Present + (Find_Body_In (Ent, (First (Declarations (PBody))))); + end if; + end; + end if; + end if; + end Has_Generic_Body; + + ----------------------- + -- Insert_Elab_Check -- + ----------------------- + + procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is + Nod : Node_Id; + Loc : constant Source_Ptr := Sloc (N); + + Chk : Node_Id; + -- The check (N_Raise_Program_Error) node to be inserted + + begin + -- If expansion is disabled, do not generate any checks. Also + -- skip checks if any subunits are missing because in either + -- case we lack the full information that we need, and no object + -- file will be created in any case. + + if not Expander_Active or else Subunits_Missing then + return; + end if; + + -- If we have a generic instantiation, where Instance_Spec is set, + -- then this field points to a generic instance spec that has + -- been inserted before the instantiation node itself, so that + -- is where we want to insert a check. + + if Nkind (N) in N_Generic_Instantiation + and then Present (Instance_Spec (N)) + then + Nod := Instance_Spec (N); + else + Nod := N; + end if; + + -- Build check node, possibly with condition + + Chk := + Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration); + + if Present (C) then + Set_Condition (Chk, Make_Op_Not (Loc, Right_Opnd => C)); + end if; + + -- If we are inserting at the top level, insert in Aux_Decls + + if Nkind (Parent (Nod)) = N_Compilation_Unit then + declare + ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod)); + + begin + if No (Declarations (ADN)) then + Set_Declarations (ADN, New_List (Chk)); + else + Append_To (Declarations (ADN), Chk); + end if; + + Analyze (Chk); + end; + + -- Otherwise just insert as an action on the node in question + + else + Insert_Action (Nod, Chk); + end if; + end Insert_Elab_Check; + + ------------------------------- + -- Is_Call_Of_Generic_Formal -- + ------------------------------- + + function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean is + begin + return Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) + + -- Always return False if debug flag -gnatd.G is set + + and then not Debug_Flag_Dot_GG + + -- For now, we detect this by looking for the strange identifier + -- node, whose Chars reflect the name of the generic formal, but + -- the Chars of the Entity references the generic actual. + + and then Nkind (Name (N)) = N_Identifier + and then Chars (Name (N)) /= Chars (Entity (Name (N))); + end Is_Call_Of_Generic_Formal; + + ------------------------------- + -- Is_Finalization_Procedure -- + ------------------------------- + + function Is_Finalization_Procedure (Id : Entity_Id) return Boolean is + begin + -- Check whether Id is a procedure with at least one parameter + + if Ekind (Id) = E_Procedure and then Present (First_Formal (Id)) then + declare + Typ : constant Entity_Id := Etype (First_Formal (Id)); + Deep_Fin : Entity_Id := Empty; + Fin : Entity_Id := Empty; + + begin + -- If the type of the first formal does not require finalization + -- actions, then this is definitely not [Deep_]Finalize. + + if not Needs_Finalization (Typ) then + return False; + end if; + + -- At this point we have the following scenario: + + -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]); + + -- Recover the two possible versions of [Deep_]Finalize using the + -- type of the first parameter and compare with the input. + + Deep_Fin := TSS (Typ, TSS_Deep_Finalize); + + if Is_Controlled (Typ) then + Fin := Find_Prim_Op (Typ, Name_Finalize); + end if; + + return (Present (Deep_Fin) and then Id = Deep_Fin) + or else (Present (Fin) and then Id = Fin); + end; + end if; + + return False; + end Is_Finalization_Procedure; + + ------------------ + -- Output_Calls -- + ------------------ + + procedure Output_Calls + (N : Node_Id; + Check_Elab_Flag : Boolean) + is + function Emit (Flag : Boolean) return Boolean; + -- Determine whether to emit an error message based on the combination + -- of flags Check_Elab_Flag and Flag. + + function Is_Printable_Error_Name return Boolean; + -- An internal function, used to determine if a name, stored in the + -- Name_Buffer, is either a non-internal name, or is an internal name + -- that is printable by the error message circuits (i.e. it has a single + -- upper case letter at the end). + + ---------- + -- Emit -- + ---------- + + function Emit (Flag : Boolean) return Boolean is + begin + if Check_Elab_Flag then + return Flag; + else + return True; + end if; + end Emit; + + ----------------------------- + -- Is_Printable_Error_Name -- + ----------------------------- + + function Is_Printable_Error_Name return Boolean is + begin + if not Is_Internal_Name then + return True; + + elsif Name_Len = 1 then + return False; + + else + Name_Len := Name_Len - 1; + return not Is_Internal_Name; + end if; + end Is_Printable_Error_Name; + + -- Local variables + + Ent : Entity_Id; + + -- Start of processing for Output_Calls + + begin + for J in reverse 1 .. Elab_Call.Last loop + Error_Msg_Sloc := Elab_Call.Table (J).Cloc; + + Ent := Elab_Call.Table (J).Ent; + Get_Name_String (Chars (Ent)); + + -- Dynamic elaboration model, warnings controlled by -gnatwl + + if Dynamic_Elaboration_Checks then + if Emit (Elab_Warnings) then + if Is_Generic_Unit (Ent) then + Error_Msg_NE ("\\?l?& instantiated #", N, Ent); + elsif Is_Init_Proc (Ent) then + Error_Msg_N ("\\?l?initialization procedure called #", N); + elsif Is_Printable_Error_Name then + Error_Msg_NE ("\\?l?& called #", N, Ent); + else + Error_Msg_N ("\\?l?called #", N); + end if; + end if; + + -- Static elaboration model, info messages controlled by -gnatel + + else + if Emit (Elab_Info_Messages) then + if Is_Generic_Unit (Ent) then + Error_Msg_NE ("\\?$?& instantiated #", N, Ent); + elsif Is_Init_Proc (Ent) then + Error_Msg_N ("\\?$?initialization procedure called #", N); + elsif Is_Printable_Error_Name then + Error_Msg_NE ("\\?$?& called #", N, Ent); + else + Error_Msg_N ("\\?$?called #", N); + end if; + end if; + end if; + end loop; + end Output_Calls; + + ---------------------------- + -- Same_Elaboration_Scope -- + ---------------------------- + + function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is + S1 : Entity_Id; + S2 : Entity_Id; + + begin + -- Find elaboration scope for Scop1 + -- This is either a subprogram or a compilation unit. + + S1 := Scop1; + while S1 /= Standard_Standard + and then not Is_Compilation_Unit (S1) + and then Ekind_In (S1, E_Package, E_Protected_Type, E_Block) + loop + S1 := Scope (S1); + end loop; + + -- Find elaboration scope for Scop2 + + S2 := Scop2; + while S2 /= Standard_Standard + and then not Is_Compilation_Unit (S2) + and then Ekind_In (S2, E_Package, E_Protected_Type, E_Block) + loop + S2 := Scope (S2); + end loop; + + return S1 = S2; + end Same_Elaboration_Scope; + + ----------------- + -- Set_C_Scope -- + ----------------- + + procedure Set_C_Scope is + begin + while not Is_Compilation_Unit (C_Scope) loop + C_Scope := Scope (C_Scope); + end loop; + end Set_C_Scope; + + -------------------------------- + -- Set_Elaboration_Constraint -- + -------------------------------- + + procedure Set_Elaboration_Constraint + (Call : Node_Id; + Subp : Entity_Id; + Scop : Entity_Id) + is + Elab_Unit : Entity_Id; + + -- Check whether this is a call to an Initialize subprogram for a + -- controlled type. Note that Call can also be a 'Access attribute + -- reference, which now generates an elaboration check. + + Init_Call : constant Boolean := + Nkind (Call) = N_Procedure_Call_Statement + and then Chars (Subp) = Name_Initialize + and then Comes_From_Source (Subp) + and then Present (Parameter_Associations (Call)) + and then Is_Controlled (Etype (First_Actual (Call))); + + begin + -- If the unit is mentioned in a with_clause of the current unit, it is + -- visible, and we can set the elaboration flag. + + if Is_Immediately_Visible (Scop) + or else (Is_Child_Unit (Scop) and then Is_Visible_Lib_Unit (Scop)) + then + Activate_Elaborate_All_Desirable (Call, Scop); + Set_Suppress_Elaboration_Warnings (Scop); + return; + end if; + + -- If this is not an initialization call or a call using object notation + -- we know that the unit of the called entity is in the context, and we + -- can set the flag as well. The unit need not be visible if the call + -- occurs within an instantiation. + + if Is_Init_Proc (Subp) + or else Init_Call + or else Nkind (Original_Node (Call)) = N_Selected_Component + then + null; -- detailed processing follows. + + else + Activate_Elaborate_All_Desirable (Call, Scop); + Set_Suppress_Elaboration_Warnings (Scop); + return; + end if; + + -- If the unit is not in the context, there must be an intermediate unit + -- that is, on which we need to place to elaboration flag. This happens + -- with init proc calls. + + if Is_Init_Proc (Subp) or else Init_Call then + + -- The initialization call is on an object whose type is not declared + -- in the same scope as the subprogram. The type of the object must + -- be a subtype of the type of operation. This object is the first + -- actual in the call. + + declare + Typ : constant Entity_Id := + Etype (First (Parameter_Associations (Call))); + begin + Elab_Unit := Scope (Typ); + while (Present (Elab_Unit)) + and then not Is_Compilation_Unit (Elab_Unit) + loop + Elab_Unit := Scope (Elab_Unit); + end loop; + end; + + -- If original node uses selected component notation, the prefix is + -- visible and determines the scope that must be elaborated. After + -- rewriting, the prefix is the first actual in the call. + + elsif Nkind (Original_Node (Call)) = N_Selected_Component then + Elab_Unit := Scope (Etype (First (Parameter_Associations (Call)))); + + -- Not one of special cases above + + else + -- Using previously computed scope. If the elaboration check is + -- done after analysis, the scope is not visible any longer, but + -- must still be in the context. + + Elab_Unit := Scop; + end if; + + Activate_Elaborate_All_Desirable (Call, Elab_Unit); + Set_Suppress_Elaboration_Warnings (Elab_Unit); + end Set_Elaboration_Constraint; + + ----------------- + -- Spec_Entity -- + ----------------- + + function Spec_Entity (E : Entity_Id) return Entity_Id is + Decl : Node_Id; + + begin + -- Check for case of body entity + -- Why is the check for E_Void needed??? + + if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then + Decl := E; + + loop + Decl := Parent (Decl); + exit when Nkind (Decl) in N_Proper_Body; + end loop; + + return Corresponding_Spec (Decl); + + else + return E; + end if; + end Spec_Entity; + + ------------ + -- Within -- + ------------ + + function Within (E1, E2 : Entity_Id) return Boolean is + Scop : Entity_Id; + begin + Scop := E1; + loop + if Scop = E2 then + return True; + elsif Scop = Standard_Standard then + return False; + else + Scop := Scope (Scop); + end if; + end loop; + end Within; + + -------------------------- + -- Within_Elaborate_All -- + -------------------------- + + function Within_Elaborate_All + (Unit : Unit_Number_Type; + E : Entity_Id) return Boolean + is + type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean; + pragma Pack (Unit_Number_Set); + + Seen : Unit_Number_Set := (others => False); + -- Seen (X) is True after we have seen unit X in the walk. This is used + -- to prevent processing the same unit more than once. + + Result : Boolean := False; + + procedure Helper (Unit : Unit_Number_Type); + -- This helper procedure does all the work for Within_Elaborate_All. It + -- walks the dependency graph, and sets Result to True if it finds an + -- appropriate Elaborate_All. + + ------------ + -- Helper -- + ------------ + + procedure Helper (Unit : Unit_Number_Type) is + CU : constant Node_Id := Cunit (Unit); + + Item : Node_Id; + Item2 : Node_Id; + Elab_Id : Entity_Id; + Par : Node_Id; + + begin + if Seen (Unit) then + return; + else + Seen (Unit) := True; + end if; + + -- First, check for Elaborate_Alls on this unit + + Item := First (Context_Items (CU)); + while Present (Item) loop + if Nkind (Item) = N_Pragma + and then Pragma_Name (Item) = Name_Elaborate_All + then + -- Return if some previous error on the pragma itself. The + -- pragma may be unanalyzed, because of a previous error, or + -- if it is the context of a subunit, inherited by its parent. + + if Error_Posted (Item) or else not Analyzed (Item) then + return; + end if; + + Elab_Id := + Entity + (Expression (First (Pragma_Argument_Associations (Item)))); + + if E = Elab_Id then + Result := True; + return; + end if; + + Par := Parent (Unit_Declaration_Node (Elab_Id)); + + Item2 := First (Context_Items (Par)); + while Present (Item2) loop + if Nkind (Item2) = N_With_Clause + and then Entity (Name (Item2)) = E + and then not Limited_Present (Item2) + then + Result := True; + return; + end if; + + Next (Item2); + end loop; + end if; + + Next (Item); + end loop; + + -- Second, recurse on with's. We could do this as part of the above + -- loop, but it's probably more efficient to have two loops, because + -- the relevant Elaborate_All is likely to be on the initial unit. In + -- other words, we're walking the with's breadth-first. This part is + -- only necessary in the dynamic elaboration model. + + if Dynamic_Elaboration_Checks then + Item := First (Context_Items (CU)); + while Present (Item) loop + if Nkind (Item) = N_With_Clause + and then not Limited_Present (Item) + then + -- Note: the following call to Get_Cunit_Unit_Number does a + -- linear search, which could be slow, but it's OK because + -- we're about to give a warning anyway. Also, there might + -- be hundreds of units, but not millions. If it turns out + -- to be a problem, we could store the Get_Cunit_Unit_Number + -- in each N_Compilation_Unit node, but that would involve + -- rearranging N_Compilation_Unit_Aux to make room. + + Helper (Get_Cunit_Unit_Number (Library_Unit (Item))); + + if Result then + return; + end if; + end if; + + Next (Item); + end loop; + end if; + end Helper; + + -- Start of processing for Within_Elaborate_All + + begin + Helper (Unit); + return Result; + end Within_Elaborate_All; + end Sem_Elab; diff --git a/gcc/ada/sem_elab.ads b/gcc/ada/sem_elab.ads index bfb174d..21518be 100644 --- a/gcc/ada/sem_elab.ads +++ b/gcc/ada/sem_elab.ads @@ -125,4 +125,69 @@ package Sem_Elab is -- ABE diagnostics or runtime checks. If this is the case, store N into -- a table for later processing. + --------------------------------------------------------------------------- + -- -- + -- L E G A C Y A C C E S S B E F O R E E L A B O R A T I O N -- + -- -- + -- M E C H A N I S M -- + -- -- + --------------------------------------------------------------------------- + + -- This section contains the implementation of the pre-18.x Legacy ABE + -- Mechanism. The mechanism can be activated using switch -gnatH (legacy + -- elaboration checking mode enabled). + + 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_Call + (N : Node_Id; + Outer_Scope : Entity_Id := Empty; + In_Init_Proc : Boolean := False); + -- Check a call for possible elaboration problems. The node N is either an + -- N_Function_Call or N_Procedure_Call_Statement node or an access + -- attribute reference whose prefix is a subprogram. + -- + -- If SPARK_Mode is On, then N can also be a variable reference, since + -- SPARK requires the use of Elaborate_All for references to variables + -- in other packages. + + -- The Outer_Scope argument indicates whether this is an outer level + -- call from Sem_Res (Outer_Scope set to Empty), or an internal recursive + -- call (Outer_Scope set to entity of outermost call, see body). The flag + -- In_Init_Proc should be set whenever the current context is a type + -- init proc. + + -- Note: this might better be called Check_Elab_Reference (to recognize + -- the SPARK case), but we prefer to keep the original name, since this + -- is primarily used for checking for calls that could generate an ABE). + + procedure Check_Elab_Calls; + -- Not all the processing for Check_Elab_Call can be done at the time + -- of calls to Check_Elab_Call. This is because for internal calls, we + -- need to wait to complete the check until all generic bodies have been + -- instantiated. The Check_Elab_Calls procedure cleans up these waiting + -- checks. It is called once after the completion of instantiation. + + procedure Check_Elab_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. + end Sem_Elab; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 17ce6ac..86602ad 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -15008,6 +15008,25 @@ 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. 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 Legacy_Elaboration_Checks + and then In_Extended_Main_Source_Unit (N) + and then SPARK_Mode /= On + then + Set_Suppress_Elaboration_Warnings + (Entity (Name (Citem))); + end if; + exit Inner; end if; @@ -15067,6 +15086,17 @@ 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 Legacy_Elaboration_Checks + and then In_Extended_Main_Source_Unit (N) + then + Set_Suppress_Elaboration_Warnings + (Entity (Name (Citem))); + end if; + exit Innr; end if; @@ -15116,6 +15146,27 @@ package body Sem_Prag is else 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 Legacy_Elaboration_Checks + and then (Dynamic_Elaboration_Checks or Debug_Flag_DD) + then + Set_Suppress_Elaboration_Warnings (Cunit_Ent); + end if; end if; end Elaborate_Body; @@ -20193,6 +20244,10 @@ package body Sem_Prag is else if not Debug_Flag_U then Set_Is_Preelaborated (Ent); + + if Legacy_Elaboration_Checks then + Set_Suppress_Elaboration_Warnings (Ent); + end if; end if; end if; end if; @@ -20820,6 +20875,10 @@ package body Sem_Prag is if not Debug_Flag_U then Set_Is_Pure (Ent); Set_Has_Pragma_Pure (Ent); + + if Legacy_Elaboration_Checks then + Set_Suppress_Elaboration_Warnings (Ent); + end if; end if; end Pure; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 5884eaa..5c87fa1 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5116,6 +5116,7 @@ package body Sem_Res is -- statement. if Nkind (N) = N_Allocator then + -- Avoid coextension processing for an allocator that is the -- expansion of a build-in-place function call. @@ -5166,9 +5167,10 @@ package body Sem_Res is if not Is_Static_Coextension (N) then Set_Is_Dynamic_Coextension (N); - -- ??? We currently do not handle finalization and - -- deallocation of coextensions properly so let's at - -- least warn the user about it. + -- Finalization and deallocation of coextensions utilizes an + -- approximate implementation which does not directly adhere + -- to the semantic rules. Warn on potential issues involving + -- coextensions. if Is_Controlled (Desig_T) then Error_Msg_N @@ -5187,10 +5189,11 @@ package body Sem_Res is Set_Is_Dynamic_Coextension (N, False); Set_Is_Static_Coextension (N, False); - -- ??? It seems we also do not properly finalize anonymous - -- access-to-controlled objects within their declared scope and - -- instead finalize them with their associated unit. Warn the - -- user about it here. + -- Anonymous access-to-controlled objects are not finalized on + -- time because this involves run-time ownership and currently + -- this property is not available. In rare cases the object may + -- not be finalized at all. Warn on potential issues involving + -- anonymous access-to-controlled objects. if Ekind (Typ) = E_Anonymous_Access_Type and then Is_Controlled_Active (Desig_T) @@ -5910,6 +5913,10 @@ package body Sem_Res is then Resolve_Entry_Call (N, Typ); + if Legacy_Elaboration_Checks then + Check_Elab_Call (N); + end if; + -- 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. @@ -6193,6 +6200,10 @@ package body Sem_Res is Set_Etype (N, Typ); Resolve_Indexed_Component (N, Typ); + if Legacy_Elaboration_Checks then + Check_Elab_Call (Prefix (N)); + end if; + -- 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 @@ -6710,6 +6721,10 @@ package body Sem_Res is Eval_Call (N); + if Legacy_Elaboration_Checks then + Check_Elab_Call (N); + end if; + -- 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. @@ -7354,6 +7369,18 @@ 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 Legacy_Elaboration_Checks + and then 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 diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f582113..3209df4 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -9086,7 +9086,8 @@ package body Sem_Util is Lit := First_Literal (Btyp); - -- Position in the enumeration type starts at 0. + -- Position in the enumeration type starts at 0 + if UI_To_Int (Pos) < 0 then raise Constraint_Error; end if; @@ -12224,7 +12225,8 @@ package body Sem_Util is --------------------------------------- function Incomplete_View_From_Limited_With - (Typ : Entity_Id) return Entity_Id is + (Typ : Entity_Id) return Entity_Id + is begin -- It might make sense to make this an attribute in Einfo, and set it -- in Sem_Ch10 in Build_Shadow_Entity. However, we're running short on @@ -18026,6 +18028,14 @@ package body Sem_Util is -- Start of processing for Mark_Elaboration_Attributes begin + -- Do not capture any elaboration-related attributes when switch -gnatH + -- (legacy elaboration checking mode enabled) is in effect because the + -- attributes are useless to the legacy model. + + if Legacy_Elaboration_Checks then + return; + end if; + if Nkind (N_Id) in N_Entity then Mark_Elaboration_Attributes_Id (N_Id); else diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index afb3ece..494b46a 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -2051,8 +2051,11 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Call_Marker + 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 Is_Known_Guaranteed_ABE; @@ -2543,6 +2546,15 @@ 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 Flag4 (N); + end No_Elaboration_Check; + function No_Entities_Ref_In_Spec (N : Node_Id) return Boolean is begin @@ -5502,8 +5514,11 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Call_Marker + 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_Is_Known_Guaranteed_ABE; @@ -5994,6 +6009,15 @@ 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_Flag4 (N, Val); + end Set_No_Elaboration_Check; + procedure Set_No_Entities_Ref_In_Spec (N : Node_Id; Val : Boolean := True) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 278b456..87d68ea 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1844,11 +1844,24 @@ package Sinfo is -- 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. + -- NOTE: this flag is shared between the legacy ABE mechanism and the + -- default ABE mechanism. + -- + -- Present in the following nodes: + -- + -- call marker + -- formal package declaration + -- function call + -- function instantiation + -- package instantiation + -- procedure call statement + -- procedure instantiation + -- + -- 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 @@ -2117,6 +2130,16 @@ package Sinfo is -- expansions where the generated assignments are initializations, not -- real assignments. + -- No_Elaboration_Check (Flag4-Sem) + -- NOTE: this flag is relevant only for the legacy ABE mechanism and + -- should not be used outside of that context. + -- + -- 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 @@ -5515,7 +5538,9 @@ package Sinfo is -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) -- Is_SPARK_Mode_On_Node (Flag2-Sem) -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem) + -- No_Elaboration_Check (Flag4-Sem) -- Do_Tag_Check (Flag13-Sem) + -- Is_Known_Guaranteed_ABE (Flag18-Sem) -- plus fields for expression -- If any IN parameter requires a range check, then the corresponding @@ -5546,9 +5571,11 @@ package Sinfo is -- Is_Elaboration_Checks_OK_Node (Flag1-Sem) -- Is_SPARK_Mode_On_Node (Flag2-Sem) -- Is_Elaboration_Warnings_OK_Node (Flag3-Sem) + -- No_Elaboration_Check (Flag4-Sem) -- Is_Expanded_Build_In_Place_Call (Flag11-Sem) -- Do_Tag_Check (Flag13-Sem) -- No_Side_Effect_Removal (Flag17-Sem) + -- Is_Known_Guaranteed_ABE (Flag18-Sem) -- plus fields for expression -------------------------------- @@ -7422,6 +7449,7 @@ package Sinfo is -- empty generic actual part) -- Box_Present (Flag15) -- Instance_Spec (Node5-Sem) + -- Is_Known_Guaranteed_ABE (Flag18-Sem) -------------------------------------- -- 12.7 Formal Package Actual Part -- @@ -9940,6 +9968,9 @@ package Sinfo is function No_Ctrl_Actions (N : Node_Id) return Boolean; -- Flag7 + function No_Elaboration_Check + (N : Node_Id) return Boolean; -- Flag4 + function No_Entities_Ref_In_Spec (N : Node_Id) return Boolean; -- Flag8 @@ -11038,6 +11069,9 @@ 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); -- Flag4 + procedure Set_No_Entities_Ref_In_Spec (N : Node_Id; Val : Boolean := True); -- Flag8 @@ -13444,6 +13478,7 @@ 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); @@ -13806,6 +13841,7 @@ 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); diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index c1ff88d..c6ba979 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -131,13 +131,22 @@ package body Switch.C is Args : String_List; Arg_Rank : Positive) is - First_Switch : Boolean := True; - -- False for all but first switch - Max : constant Natural := Switch_Chars'Last; - Ptr : Natural; C : Character := ' '; + Ptr : Natural; + Dot : Boolean; + -- This flag is set upon encountering a dot in a debug switch + + First_Char : Positive; + -- Marks start of switch to be stored + + First_Ptr : Positive; + -- Save position of first character after -gnatd (for checking that + -- debug flags that must come first are first, in particular -gnatd.b). + + First_Switch : Boolean := True; + -- False for all but first switch Store_Switch : Boolean; -- For -gnatxx switches, the normal processing, signalled by this flag @@ -148,12 +157,8 @@ package body Switch.C is -- appropriate calls to Store_Compilation_Switch are made from within -- the case branch. - First_Char : Positive; - -- Marks start of switch to be stored - - First_Ptr : Positive; - -- Save position of first character after -gnatd (for checking that - -- debug flags that must come first are first, in particular -gnatd.b), + Underscore : Boolean; + -- This flag is set upon encountering an underscode in a debug switch begin Ptr := Switch_Chars'First; @@ -342,8 +347,10 @@ package body Switch.C is -- -gnatd (compiler debug options) when 'd' => + Dot := False; Store_Switch := False; - Dot := False; + Underscore := False; + First_Ptr := Ptr + 1; -- Note: for the debug switch, the remaining characters in this @@ -374,11 +381,17 @@ package body Switch.C is or else not First_Switch) then Osint.Fail - ("-gnatd.b must be first if combined " - & "with other switches"); + ("-gnatd.b must be first if combined with other " + & "switches"); end if; - -- Not a dotted flag + -- Case of an underscored flag + + elsif Underscore then + Set_Underscored_Debug_Flag (C); + Store_Compilation_Switch ("-gnatd_" & C); + + -- Normal flag else Set_Debug_Flag (C); @@ -388,8 +401,15 @@ package body Switch.C is elsif C = '.' then Dot := True; + elsif C = '_' then + Underscore := True; + elsif Dot then Bad_Switch ("-gnatd." & Switch_Chars (Ptr .. Max)); + + elsif Underscore then + Bad_Switch ("-gnatd_" & Switch_Chars (Ptr .. Max)); + else Bad_Switch ("-gnatd" & Switch_Chars (Ptr .. Max)); end if; @@ -879,6 +899,12 @@ package body Switch.C is Ptr := Ptr + 1; Usage_Requested := True; + -- -gnatH (legacy static elaboration checking mode enabled) + + when 'H' => + Ptr := Ptr + 1; + Legacy_Elaboration_Checks := True; + -- -gnati (character set) when 'i' => @@ -916,6 +942,46 @@ package body Switch.C is Ptr := Ptr + 1; Scan_Nat (Switch_Chars, Max, Ptr, Error_Msg_Line_Length, C); + -- -gnatJ (relaxed elaboration checking mode enabled) + + when 'J' => + Ptr := Ptr + 1; + Relaxed_Elaboration_Checks := True; + + -- Common relaxations for both ABE mechanisms + -- + -- -gnatd.G (ignore calls through generic formal parameters for + -- elaboration) + -- -gnatd.U (ignore indirect calls for static elaboration) + -- -gnatd.y (disable implicit pragma Elaborate_All on task + -- bodies) + + Debug_Flag_Dot_GG := True; + Debug_Flag_Dot_UU := True; + Debug_Flag_Dot_Y := True; + + -- Relaxatons to the legacy ABE mechanism + + if Legacy_Elaboration_Checks then + null; + + -- Relaxations to the default ABE mechanism + -- + -- -gnatd_a (stop elaboration checks on accept or select + -- statement) + -- -gnatd_e (ignore entry calls and requeue statements for + -- elaboration) + -- -gnatd_p (ignore assertion pragmas for elaboration) + -- -gnatdL (ignore activations and calls to instances for + -- elaboration) + + else + Debug_Flag_Underscore_A := True; + Debug_Flag_Underscore_E := True; + Debug_Flag_Underscore_P := True; + Debug_Flag_LL := True; + end if; + -- -gnatk (limit file name length) when 'k' => @@ -1267,7 +1333,7 @@ package body Switch.C is Bad_Switch ("-gnatw_" & Switch_Chars (Ptr .. Max)); end if; - -- Normal case, no dot + -- Normal case else if Set_Warning_Switch (C) then diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c index 3c43d1a..c46a73b 100644 --- a/gcc/ada/tracebak.c +++ b/gcc/ada/tracebak.c @@ -373,7 +373,11 @@ extern void __runnit(); /* thread entry point. */ (defined (__powerpc__) && defined (__Lynx__) && defined(__ELF__)) || \ (defined (__linux__) && defined (__powerpc__)) +#if defined (_ARCH_PPC64) && !defined (__USING_SJLJ_EXCEPTIONS__) +#define USE_GCC_UNWINDER +#else #define USE_GENERIC_UNWINDER +#endif struct layout { diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index bb712cc..66b860c 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -302,6 +302,11 @@ begin Write_Switch_Char ("h"); Write_Line ("Output this usage (help) information"); + -- Line for -gnatH switch + + Write_Switch_Char ("H"); + Write_Line ("Legacy elaboration checking mode enabled"); + -- Line for -gnati switch Write_Switch_Char ("i?"); @@ -317,6 +322,11 @@ begin Write_Switch_Char ("jnn"); Write_Line ("Format error and warning messages to fit nn character lines"); + -- Line for -gnatJ switch + + Write_Switch_Char ("J"); + Write_Line ("Relaxed elaboration checking mode enabled"); + -- Line for -gnatk switch Write_Switch_Char ("k"); |