From: Robert Dewar Date: Wed, 6 Jun 2007 10:45:10 +0000 (+0200) Subject: sem_elab.adb (Check_A_Call): Specialize elaboration warnings on elaboration model X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=e090bc755c27e9c1364f02e2228bbea13a47f34b;p=gcc.git sem_elab.adb (Check_A_Call): Specialize elaboration warnings on elaboration model 2007-04-20 Robert Dewar * sem_elab.adb (Check_A_Call): Specialize elaboration warnings on elaboration model (Check_A_Call): Add check for entry call which was causing blowup From-SVN: r125454 --- diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index e3f72e4f112..bae6a9fd96e 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2007, 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- -- @@ -849,38 +849,77 @@ package body Sem_Elab is and then Elab_Warnings and then Generate_Warnings then - if Inst_Case then - Error_Msg_NE - ("instantiation of& may raise Program_Error?", N, Ent); + Generate_Elab_Warnings : declare + 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. + + ------------------ + -- Elab_Warning -- + ------------------ + + procedure Elab_Warning + (Msg_D : String; + Msg_S : String; + Ent : Node_Or_Entity_Id) + is + begin + if Dynamic_Elaboration_Checks then + Error_Msg_NE (Msg_D, N, Ent); + else + Error_Msg_NE (Msg_S, N, Ent); + end if; + end Elab_Warning; - else - if Is_Init_Proc (Entity (Name (N))) - and then Comes_From_Source (Ent) - then - Error_Msg_NE - ("implicit call to & may raise Program_Error?", N, Ent); + -- Start of processing for Generate_Elab_Warnings + + begin + if Inst_Case then + Elab_Warning + ("instantiation of& may raise Program_Error?", + "instantiation of& during elaboration?", Ent); else - Error_Msg_NE - ("call to & may raise Program_Error?", N, Ent); + 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?", + "implicit call to & during elaboration?", + Ent); + + else + Elab_Warning + ("call to & may raise Program_Error?", + "call to & during elaboration?", + Ent); + end if; end if; - end if; - Error_Msg_Qual_Level := Nat'Last; + Error_Msg_Qual_Level := Nat'Last; - if Nkind (N) in N_Subprogram_Instantiation then - Error_Msg_NE - ("\missing pragma Elaborate for&?", N, W_Scope); - else - Error_Msg_NE - ("\missing pragma Elaborate_All for&?", N, W_Scope); - end if; + if Nkind (N) in N_Subprogram_Instantiation then + Elab_Warning + ("\missing pragma Elaborate for&?", + "\implicit pragma Elaborate for& generated?", + W_Scope); + else + Elab_Warning + ("\missing pragma Elaborate_All for&?", + "\implicit pragma Elaborate_All for & generated?", + W_Scope); + end if; + end Generate_Elab_Warnings; Error_Msg_Qual_Level := 0; Output_Calls (N); - -- Set flag to prevent further warnings for same unit - -- unless in All_Errors_Mode. + -- 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, True); @@ -1695,7 +1734,7 @@ package body Sem_Elab is Expander_Mode_Save_And_Set (True); for J in Delay_Check.First .. Delay_Check.Last loop - New_Scope (Delay_Check.Table (J).Curscop); + Push_Scope (Delay_Check.Table (J).Curscop); From_Elab_Code := Delay_Check.Table (J).From_Elab_Code; Check_Internal_Call_Continue ( @@ -2114,7 +2153,7 @@ package body Sem_Elab is begin Set_Elaboration_Entity (E, Ent); - New_Scope (Scope (E)); + Push_Scope (Scope (E)); Insert_Action (Declaration_Node (E), Make_Object_Declaration (Loce, @@ -3017,7 +3056,7 @@ package body Sem_Elab is declare Spec : constant Node_Id := Specification (N); begin - New_Scope (Defining_Unit_Name (Spec)); + Push_Scope (Defining_Unit_Name (Spec)); Supply_Bodies (Visible_Declarations (Spec)); Supply_Bodies (Private_Declarations (Spec)); Pop_Scope;