From 7255f3c31130b87e515afec8bf315206b1fb0fa1 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Mon, 21 May 2018 14:51:15 +0000 Subject: [PATCH] [Ada] Placement of pragma Elaboration_Checks This patch modifies the semantics of pragma Elaboration_Checks. The pragma was intended to be a configuration pragma, however its placement was never verified until now. The pragma may appear in the following contexts: * Configuration pragmas file * Prior to the context clauses of a compilation unit's initial declaration Any other placement of the pragma will result in a warning and the effects of the offending pragma will be ignored. ------------ -- Source -- ------------ -- elab_checks_1.adc pragma Elaboration_Checks (Dynamic); -- elab_checks_2.adc pragma Elaboration_Checks (Dynamic); pragma Elaboration_Checks (Static); -- Error -- pack_1.ads pragma Elaboration_Checks (Static); -- OK package Pack_1 is end Pack_1; -- pack_2.ads pragma Elaboration_Checks (Static); -- OK pragma Elaboration_Checks (Static); -- Error package Pack_2 is end Pack_2; -- pack_3.ads package Pack_3 is procedure Proc; end Pack_3; -- pack_3.adb pragma Elaboration_Checks (Static); -- Error package body Pack_3 is procedure Proc is begin null; end Proc; end Pack_3; -- pack_4.ads package Pack_4 is procedure Proc; end Pack_4; -- pack_4.adb package body Pack_4 is procedure Proc is separate; end Pack_4; -- pack_4-proc.adb pragma Elaboration_Checks (Static); -- Error separate (Pack_4) procedure Proc is begin null; end Proc; -- gen.ads generic with function Called_At_Elaboration return Boolean; package Gen is procedure Proc; end Gen; -- gen.adb package body Gen is procedure Proc is Obj : constant Boolean := Called_At_Elaboration; begin null; end Proc; begin Proc; end Gen; -- abe_static.ads pragma Elaboration_Checks (Static); with Gen; package ABE_Static is function ABE return Boolean; package Inst_1 is new Gen (ABE); end ABE_Static; -- abe_static.adb package body ABE_Static is package Inst_2 is new Gen (ABE); package Subunit is end Subunit; package body Subunit is separate; function ABE return Boolean is begin return True; end ABE; end ABE_Static; -- abe_static-subunit.adb separate (ABE_Static) package body Subunit is package Inst_3 is new Gen (ABE); package Nested_Subunit is end Nested_Subunit; package body Nested_Subunit is separate; end Subunit; -- abe_static-subunit-nested_subunit.adb separate (ABE_Static.Subunit) package body Nested_Subunit is package Inst_4 is new Gen (ABE); end Nested_Subunit; -- abe_static_main.adb with ABE_Static; procedure ABE_Static_Main is begin null; end ABE_Static_Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gcc -c pack_1.ads -gnatec=elab_checks_1.adc $ gcc -c pack_1.ads -gnatec=elab_checks_2.adc $ gcc -c pack_1.ads $ gcc -c pack_2.ads $ gcc -c pack_3.adb $ gcc -c pack_4.adb $ gnatmake -q -gnatE abe_static_main.adb elab_checks_2.adc:2:01: pragma "Elaboration_Checks" duplicates pragma declared at line 1 pack_2.ads:2:01: pragma "Elaboration_Checks" duplicates pragma declared at line 1 pack_3.adb:1:01: warning: effects of pragma "Elaboration_Checks" are ignored pack_3.adb:1:01: warning: place pragma on initial declaration of library unit pack_4-proc.adb:1:01: warning: effects of pragma "Elaboration_Checks" are ignored pack_4-proc.adb:1:01: warning: place pragma on initial declaration of library unit abe_static.adb:2:04: warning: in instantiation at gen.adb:3 abe_static.adb:2:04: warning: cannot call "ABE" before body seen abe_static.adb:2:04: warning: Program_Error may be raised at run time abe_static.adb:2:04: warning: body of unit "ABE_Static" elaborated abe_static.adb:2:04: warning: procedure "Proc" called at gen.adb:6, instance at line 2 abe_static.adb:2:04: warning: function "ABE" called at gen.adb:3, instance at line 2 abe_static.ads:8:04: warning: in instantiation at gen.adb:3 abe_static.ads:8:04: warning: cannot call "ABE" before body seen abe_static.ads:8:04: warning: Program_Error may be raised at run time abe_static.ads:8:04: warning: spec of unit "ABE_Static" elaborated abe_static.ads:8:04: warning: procedure "Proc" called at gen.adb:6, instance at line 8 abe_static.ads:8:04: warning: function "ABE" called at gen.adb:3, instance at line 8 abe_static-subunit.adb:4:04: warning: in instantiation at gen.adb:3 abe_static-subunit.adb:4:04: warning: cannot call "ABE" before body seen abe_static-subunit.adb:4:04: warning: Program_Error may be raised at run time abe_static-subunit.adb:4:04: warning: body of unit "ABE_Static" elaborated abe_static-subunit.adb:4:04: warning: procedure "Proc" called at gen.adb:6, instance at line 4 abe_static-subunit.adb:4:04: warning: function "ABE" called at gen.adb:3, instance at line 4 abe_static-subunit-nested_subunit.adb:4:04: warning: in instantiation at gen.adb:3 abe_static-subunit-nested_subunit.adb:4:04: warning: cannot call "ABE" before body seen abe_static-subunit-nested_subunit.adb:4:04: warning: Program_Error may be raised at run time abe_static-subunit-nested_subunit.adb:4:04: warning: body of unit "ABE_Static" elaborated abe_static-subunit-nested_subunit.adb:4:04: warning: procedure "Proc" called at gen.adb:6, instance at line 4 abe_static-subunit-nested_subunit.adb:4:04: warning: function "ABE" called at gen.adb:3, instance at line 4 warning: "abe_static_main.adb" has dynamic elaboration checks and with's warning: "abe_static.ads" which has static elaboration checks 2018-05-21 Hristian Kirtchev gcc/ada/ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Install the elaboration model of the compilation unit spec, if any. * sem_ch7.adb (Analyze_Package_Body_Helper): Install the elaboration model of the compilation unit spec, if any. * sem_ch10.adb (Analyze_Subunit): Install the elaboration model of the parent compilation unit spec, if any. * sem_elab.adb (Check_Elaboration_Scenarios): Restore the elaboration model of the main unit. (Is_Same_Unit): The routine now uses Unit_Entity. (Is_Subunit): Removed. (Normalize_Unit): Removed. (Unit_Entity): New routine. * sem_prag.adb (Analyze_Pragma): Reimplement the handling of pragma Elaboration_Checks. The analysis now ensures that the pragma appears at the configuration level, and on the initial declaration of a unit. Other placements are either flagged as illegal, or ignored. (Check_Duplicate_Elaboration_Checks_Pragma): New routine. (Ignore_Elaboration_Checks_Pragma): New routine. * sem_util.adb (Install_Elaboration_Model): New routine. * sem_util.ads (Install_Elaboration_Model): New routine. * doc/gnat_rm/implementation_defined_pragmas.rst: Update the documentation of pragma Elaboration_Checks. * gnat_rm.texi: Regenerate. From-SVN: r260457 --- gcc/ada/ChangeLog | 26 +++++ .../implementation_defined_pragmas.rst | 27 +++-- gcc/ada/gnat_rm.texi | 36 ++++-- gcc/ada/sem_ch10.adb | 6 + gcc/ada/sem_ch6.adb | 26 +++++ gcc/ada/sem_ch7.adb | 6 + gcc/ada/sem_elab.adb | 104 ++++++++++------- gcc/ada/sem_prag.adb | 108 +++++++++++++++++- gcc/ada/sem_util.adb | 76 ++++++++++++ gcc/ada/sem_util.ads | 5 + 10 files changed, 351 insertions(+), 69 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fa449bf1a03..4af6ce311fd 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2018-04-04 Hristian Kirtchev + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Install the elaboration + model of the compilation unit spec, if any. + * sem_ch7.adb (Analyze_Package_Body_Helper): Install the elaboration + model of the compilation unit spec, if any. + * sem_ch10.adb (Analyze_Subunit): Install the elaboration model of the + parent compilation unit spec, if any. + * sem_elab.adb (Check_Elaboration_Scenarios): Restore the elaboration + model of the main unit. + (Is_Same_Unit): The routine now uses Unit_Entity. + (Is_Subunit): Removed. + (Normalize_Unit): Removed. + (Unit_Entity): New routine. + * sem_prag.adb (Analyze_Pragma): Reimplement the handling of pragma + Elaboration_Checks. The analysis now ensures that the pragma appears at + the configuration level, and on the initial declaration of a unit. + Other placements are either flagged as illegal, or ignored. + (Check_Duplicate_Elaboration_Checks_Pragma): New routine. + (Ignore_Elaboration_Checks_Pragma): New routine. + * sem_util.adb (Install_Elaboration_Model): New routine. + * sem_util.ads (Install_Elaboration_Model): New routine. + * doc/gnat_rm/implementation_defined_pragmas.rst: Update the + documentation of pragma Elaboration_Checks. + * gnat_rm.texi: Regenerate. + 2018-04-04 Olivier Hainque * libgnat/s-trasym__dwarf.adb (Executable_Name): Return argv[0] instead diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index d6ded29fa40..b39625c39c5 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -1678,18 +1678,23 @@ Syntax: pragma Elaboration_Checks (Dynamic | Static); -This is a configuration pragma that provides control over the -elaboration model used by the compilation affected by the -pragma. If the parameter is ``Dynamic``, -then the dynamic elaboration -model described in the Ada Reference Manual is used, as though -the *-gnatE* switch had been specified on the command -line. If the parameter is ``Static``, then the default GNAT static -model is used. This configuration pragma overrides the setting -of the command line. For full details on the elaboration models -used by the GNAT compiler, see the chapter on elaboration order handling -in the *GNAT User's Guide*. +This is a configuration pragma which specifies the elaboration model to be +used during compilation. For more information on the elaboration models of +GNAT, consult the chapter on elaboration order handling in the *GNAT User's +Guide*. +The pragma may appear in the following contexts: + +* Configuration pragmas file + +* Prior to the context clauses of a compilation unit's initial declaration + +Any other placement of the pragma will result in a warning and the effects of +the offending pragma will be ignored. + +If the pragma argument is ``Dynamic``, then the dynamic elaboration model is in +effect. If the pragma argument is ``Static``, then the static elaboration model +is in effect. Pragma Eliminate ================ diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 4c14caeb721..f8017d8ed3b 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT Reference Manual , Jan 10, 2018 +GNAT Reference Manual , Apr 20, 2018 AdaCore @@ -3067,17 +3067,29 @@ Syntax: pragma Elaboration_Checks (Dynamic | Static); @end example -This is a configuration pragma that provides control over the -elaboration model used by the compilation affected by the -pragma. If the parameter is @code{Dynamic}, -then the dynamic elaboration -model described in the Ada Reference Manual is used, as though -the @emph{-gnatE} switch had been specified on the command -line. If the parameter is @code{Static}, then the default GNAT static -model is used. This configuration pragma overrides the setting -of the command line. For full details on the elaboration models -used by the GNAT compiler, see the chapter on elaboration order handling -in the @emph{GNAT User's Guide}. +This is a configuration pragma which specifies the elaboration model to be +used during compilation. For more information on the elaboration models of +GNAT, consult the chapter on elaboration order handling in the @emph{GNAT User's +Guide}. + +The pragma may appear in the following contexts: + + +@itemize * + +@item +Configuration pragmas file + +@item +Prior to the context clauses of a compilation unit's initial declaration +@end itemize + +Any other placement of the pragma will result in a warning and the effects of +the offending pragma will be ignored. + +If the pragma argument is @code{Dynamic}, then the dynamic elaboration model is in +effect. If the pragma argument is @code{Static}, then the static elaboration model +is in effect. @node Pragma Eliminate,Pragma Enable_Atomic_Synchronization,Pragma Elaboration_Checks,Implementation Defined Pragmas @anchor{gnat_rm/implementation_defined_pragmas pragma-eliminate}@anchor{5b} diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 6c360571668..ac8e2be5bf0 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -2390,6 +2390,12 @@ package body Sem_Ch10 is Install_SPARK_Mode (Saved_SM, Saved_SMP); + -- If the subunit is part of a compilation unit which is subject to + -- pragma Elaboration_Checks, set the model specified by the pragma + -- because it applies to all parts of the unit. + + Install_Elaboration_Model (Par_Unit); + Analyze (Proper_Body (Unit (N))); Remove_Context (N); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index e33492057ea..c88721fa28c 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3528,6 +3528,13 @@ package body Sem_Ch6 is Mark_And_Set_Ghost_Body (N, Spec_Id); + -- If the body completes the initial declaration of a compilation + -- unit which is subject to pragma Elaboration_Checks, set the + -- model specified by the pragma because it applies to all parts + -- of the unit. + + Install_Elaboration_Model (Spec_Id); + Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id)); Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id)); @@ -3573,6 +3580,12 @@ package body Sem_Ch6 is Mark_And_Set_Ghost_Body (N, Spec_Id); + -- If the body completes a compilation unit which is subject + -- to pragma Elaboration_Checks, set the model specified by + -- the pragma because it applies to all parts of the unit. + + Install_Elaboration_Model (Spec_Id); + else Spec_Id := Find_Corresponding_Spec (N); @@ -3583,6 +3596,12 @@ package body Sem_Ch6 is Mark_And_Set_Ghost_Body (N, Spec_Id); + -- If the body completes a compilation unit which is subject + -- to pragma Elaboration_Checks, set the model specified by + -- the pragma because it applies to all parts of the unit. + + Install_Elaboration_Model (Spec_Id); + -- In GNATprove mode, if the body has no previous spec, create -- one so that the inlining machinery can operate properly. -- Transfer aspects, if any, to the new spec, so that they @@ -3683,6 +3702,13 @@ package body Sem_Ch6 is -- and expansion are properly marked as Ghost. Mark_And_Set_Ghost_Body (N, Spec_Id); + + -- If the body completes the initial declaration of a compilation + -- unit which is subject to pragma Elaboration_Checks, set the + -- model specified by the pragma because it applies to all parts + -- of the unit. + + Install_Elaboration_Model (Spec_Id); end if; end if; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 9302f1abb09..b20f77c9547 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -749,6 +749,12 @@ package body Sem_Ch7 is Mark_And_Set_Ghost_Body (N, Spec_Id); + -- If the body completes the initial declaration of a compilation unit + -- which is subject to pragma Elaboration_Checks, set the model of the + -- pragma because it applies to all parts of the unit. + + Install_Elaboration_Model (Spec_Id); + Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id)); Style.Check_Identifier (Body_Id, Spec_Id); diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index cc5d0456cdc..69d46f4f857 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -1780,6 +1780,10 @@ package body Sem_Elab is -- suitable elaboration scenarios and process them. State is the current -- state of the Processing phase. + function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id; + pragma Inline (Unit_Entity); + -- Return the entity of the initial declaration for unit Unit_Id + procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id); pragma Inline (Update_Elaboration_Scenario); -- Update all relevant internal data structures when scenario Old_N is @@ -2341,6 +2345,13 @@ package body Sem_Elab is return; end if; + -- Restore the original elaboration model which was in effect when the + -- scenarios were first recorded. The model may be specified by pragma + -- Elaboration_Checks which appears on the initial declaration of the + -- main unit. + + Install_Elaboration_Model (Unit_Entity (Cunit_Entity (Main_Unit))); + -- Examine the context of the main unit and record all units with prior -- elaboration with respect to it. @@ -7120,50 +7131,8 @@ package body Sem_Elab is (Unit_1 : Entity_Id; Unit_2 : Entity_Id) return Boolean is - function Is_Subunit (Unit_Id : Entity_Id) return Boolean; - pragma Inline (Is_Subunit); - -- Determine whether unit Unit_Id is a subunit - - function Normalize_Unit (Unit_Id : Entity_Id) return Entity_Id; - -- Strip a potential subunit chain ending with unit Unit_Id and return - -- the corresponding spec. - - ---------------- - -- Is_Subunit -- - ---------------- - - function Is_Subunit (Unit_Id : Entity_Id) return Boolean is - begin - return Nkind (Parent (Unit_Declaration_Node (Unit_Id))) = N_Subunit; - end Is_Subunit; - - -------------------- - -- Normalize_Unit -- - -------------------- - - function Normalize_Unit (Unit_Id : Entity_Id) return Entity_Id is - Result : Entity_Id; - - begin - -- Eliminate a potential chain of subunits to reach to proper body - - Result := Unit_Id; - while Present (Result) - and then Result /= Standard_Standard - and then Is_Subunit (Result) - loop - Result := Scope (Result); - end loop; - - -- Obtain the entity of the corresponding spec (if any) - - return Unique_Entity (Result); - end Normalize_Unit; - - -- Start of processing for Is_Same_Unit - begin - return Normalize_Unit (Unit_1) = Normalize_Unit (Unit_2); + return Unit_Entity (Unit_1) = Unit_Entity (Unit_2); end Is_Same_Unit; ----------------- @@ -11153,6 +11122,55 @@ package body Sem_Elab is end if; end Traverse_Body; + ----------------- + -- Unit_Entity -- + ----------------- + + function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id is + function Is_Subunit (Id : Entity_Id) return Boolean; + pragma Inline (Is_Subunit); + -- Determine whether the entity of an initial declaration denotes a + -- subunit. + + ---------------- + -- Is_Subunit -- + ---------------- + + function Is_Subunit (Id : Entity_Id) return Boolean is + Decl : constant Node_Id := Unit_Declaration_Node (Id); + + begin + return + Nkind_In (Decl, N_Generic_Package_Declaration, + N_Generic_Subprogram_Declaration, + N_Package_Declaration, + N_Protected_Type_Declaration, + N_Subprogram_Declaration, + N_Task_Type_Declaration) + and then Present (Corresponding_Body (Decl)) + and then Nkind (Parent (Unit_Declaration_Node + (Corresponding_Body (Decl)))) = N_Subunit; + end Is_Subunit; + + -- Local variables + + Id : Entity_Id; + + -- Start of processing for Unit_Entity + + begin + Id := Unique_Entity (Unit_Id); + + -- Skip all subunits found in the scope chain which ends at the input + -- unit. + + while Is_Subunit (Id) loop + Id := Scope (Id); + end loop; + + return Id; + end Unit_Entity; + --------------------------------- -- Update_Elaboration_Scenario -- --------------------------------- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 4a5026c2353..11f978a9939 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -15267,16 +15267,118 @@ package body Sem_Prag is -- pragma Elaboration_Checks (Static | Dynamic); - when Pragma_Elaboration_Checks => + when Pragma_Elaboration_Checks => Elaboration_Checks : declare + procedure Check_Duplicate_Elaboration_Checks_Pragma; + -- Emit an error if the current context list already contains + -- a previous Elaboration_Checks pragma. This routine raises + -- Pragma_Exit if a duplicate is found. + + procedure Ignore_Elaboration_Checks_Pragma; + -- Warn that the effects of the pragma are ignored. This routine + -- raises Pragma_Exit. + + ----------------------------------------------- + -- Check_Duplicate_Elaboration_Checks_Pragma -- + ----------------------------------------------- + + procedure Check_Duplicate_Elaboration_Checks_Pragma is + Item : Node_Id; + + begin + Item := Prev (N); + while Present (Item) loop + if Nkind (Item) = N_Pragma + and then Pragma_Name (Item) = Name_Elaboration_Checks + then + Duplication_Error + (Prag => N, + Prev => Item); + raise Pragma_Exit; + end if; + + Prev (Item); + end loop; + end Check_Duplicate_Elaboration_Checks_Pragma; + + -------------------------------------- + -- Ignore_Elaboration_Checks_Pragma -- + -------------------------------------- + + procedure Ignore_Elaboration_Checks_Pragma is + begin + Error_Msg_Name_1 := Pname; + Error_Msg_N ("??effects of pragma % are ignored", N); + Error_Msg_N + ("\place pragma on initial declaration of library unit", N); + + raise Pragma_Exit; + end Ignore_Elaboration_Checks_Pragma; + + -- Local variables + + Context : constant Node_Id := Parent (N); + Unt : Node_Id; + + -- Start of processing for Elaboration_Checks + + begin GNAT_Pragma; Check_Arg_Count (1); Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic); - -- Set flag accordingly (ignore attempt at dynamic elaboration - -- checks in SPARK mode). + -- The pragma appears in a configuration file + + if No (Context) then + Check_Valid_Configuration_Pragma; + Check_Duplicate_Elaboration_Checks_Pragma; + + -- The pragma acts as a configuration pragma in a compilation unit + + -- pragma Elaboration_Checks (...); + -- package Pack is ...; + + elsif Nkind (Context) = N_Compilation_Unit + and then List_Containing (N) = Context_Items (Context) + then + Check_Valid_Configuration_Pragma; + Check_Duplicate_Elaboration_Checks_Pragma; + + Unt := Unit (Context); + + -- The pragma must appear on the initial declaration of a unit. + -- If this is not the case, warn that the effects of the pragma + -- are ignored. + + if Nkind (Unt) = N_Package_Body then + Ignore_Elaboration_Checks_Pragma; + + -- Check the Acts_As_Spec flag of the compilation units itself + -- to determine whether the subprogram body completes since it + -- has not been analyzed yet. This is safe because compilation + -- units are not overloadable. + + elsif Nkind (Unt) = N_Subprogram_Body + and then not Acts_As_Spec (Context) + then + Ignore_Elaboration_Checks_Pragma; + + elsif Nkind (Unt) = N_Subunit then + Ignore_Elaboration_Checks_Pragma; + end if; + + -- Otherwise the pragma does not appear at the configuration level + -- and is illegal. + + else + Pragma_Misplaced; + end if; + + -- At this point the pragma is not a duplicate, and appears in the + -- proper context. Set the elaboration model in effect. Dynamic_Elaboration_Checks := Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic; + end Elaboration_Checks; --------------- -- Eliminate -- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 958efb07cc8..cba7c467af0 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12583,6 +12583,82 @@ package body Sem_Util is end loop; end Inspect_Deferred_Constant_Completion; + ------------------------------- + -- Install_Elaboration_Model -- + ------------------------------- + + procedure Install_Elaboration_Model (Unit_Id : Entity_Id) is + function Find_Elaboration_Checks_Pragma (L : List_Id) return Node_Id; + -- Try to find pragma Elaboration_Checks in arbitrary list L. Return + -- Empty if there is no such pragma. + + ------------------------------------ + -- Find_Elaboration_Checks_Pragma -- + ------------------------------------ + + function Find_Elaboration_Checks_Pragma (L : List_Id) return Node_Id is + Item : Node_Id; + + begin + Item := First (L); + while Present (Item) loop + if Nkind (Item) = N_Pragma + and then Pragma_Name (Item) = Name_Elaboration_Checks + then + return Item; + end if; + + Next (Item); + end loop; + + return Empty; + end Find_Elaboration_Checks_Pragma; + + -- Local variables + + Args : List_Id; + Model : Node_Id; + Prag : Node_Id; + Unit : Node_Id; + + -- Start of processing for Install_Elaboration_Model + + begin + -- Nothing to do when the unit does not exist + + if No (Unit_Id) then + return; + end if; + + Unit := Parent (Unit_Declaration_Node (Unit_Id)); + + -- Nothing to do when the unit is not a library unit + + if Nkind (Unit) /= N_Compilation_Unit then + return; + end if; + + Prag := Find_Elaboration_Checks_Pragma (Context_Items (Unit)); + + -- The compilation unit is subject to pragma Elaboration_Checks. Set the + -- elaboration model as specified by the pragma. + + if Present (Prag) then + Args := Pragma_Argument_Associations (Prag); + + -- Guard against an illegal pragma. The sole argument must be an + -- identifier which specifies either Dynamic or Static model. + + if Present (Args) then + Model := Get_Pragma_Arg (First (Args)); + + if Nkind (Model) = N_Identifier then + Dynamic_Elaboration_Checks := Chars (Model) = Name_Dynamic; + end if; + end if; + end if; + end Install_Elaboration_Model; + ----------------------------- -- Install_Generic_Formals -- ----------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 3de394456b0..a9908516a9f 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1453,6 +1453,11 @@ package Sem_Util is -- whether they have been completed by a full constant declaration or an -- Import pragma. Emit the error message if that is not the case. + procedure Install_Elaboration_Model (Unit_Id : Entity_Id); + -- Install the elaboration model specified by pragma Elaboration_Checks + -- associated with compilation unit Unit_Id. No action is taken when the + -- unit lacks such pragma. + procedure Install_Generic_Formals (Subp_Id : Entity_Id); -- Install both the generic formal parameters and the formal parameters of -- generic subprogram Subp_Id into visibility. -- 2.30.2