https://gcc.gnu.org/g:c7aeef1cf102454bb55f6c0af996366c1b8af4f3
commit r17-1645-gc7aeef1cf102454bb55f6c0af996366c1b8af4f3 Author: Viljar Indus <[email protected]> Date: Wed Jun 3 15:15:56 2026 +0300 ada: Use correct warning char for unconditional elab warning Warning messages from Check_Internal_Call_Continue were not actually conditional on the -gnatwl flag and were emitted always. Use the switchless warning character for those messages and refactor Output_Calls in order to handle all of the possible warning characters in the continuation messages. gcc/ada/ChangeLog: * sem_elab.adb (Output_Calls): Apply correct warning characeter for each continuation message. (Check_Internal_Call_Continue): Use regular warning character in error messages. Diff: --- gcc/ada/sem_elab.adb | 99 +++++++++++++++++++++++++--------------------------- 1 file changed, 47 insertions(+), 52 deletions(-) diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 22adac2186b6..fefb01029d39 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -16313,15 +16313,14 @@ package body Sem_Elab is 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); + procedure Output_Calls (N : Node_Id; Uncond_Msg : 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. + -- the messages are to be placed. When Uncond_Msg is set, calls are + -- unconditionally emitted. Otherwise 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 @@ -17159,7 +17158,7 @@ package body Sem_Elab is -- ensures the proper pairing of the main warning and the -- clarification messages generated by Output_Calls. - Output_Calls (N, Check_Elab_Flag => True); + Output_Calls (N, Uncond_Msg => False); -- Set flag to prevent further warnings for same unit unless in -- All_Errors_Mode. @@ -18683,7 +18682,7 @@ package body Sem_Elab is if Inst_Case then Error_Msg_NE - ("instantiation of& may occur before body is seen<l<", + ("instantiation of& may occur before body is seen<<", N, Orig_Ent); else -- A rather specific check: for Adjust/Finalize/Initialize, if @@ -18709,19 +18708,19 @@ package body Sem_Elab is -- 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); + ("call to& may occur before body is seen<<", N, Orig_Ent); end if; - Error_Msg_N ("\Program_Error ]<l<", N); + Error_Msg_N ("\Program_Error ]<<", 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. + -- because the main message is an error or an unconditional + -- warning, therefore all the clarification messages produces by + -- Output_Calls must be emitted unconditionally. <<Output>> - Output_Calls (N, Check_Elab_Flag => False); + Output_Calls (N, Uncond_Msg => True); end if; end if; end Check_Internal_Call_Continue; @@ -19397,13 +19396,10 @@ package body Sem_Elab is -- Output_Calls -- ------------------ - procedure Output_Calls - (N : Node_Id; - Check_Elab_Flag : Boolean) - is - function Emit (Flag : Boolean) return Boolean; + procedure Output_Calls (N : Node_Id; Uncond_Msg : Boolean) is + function Emit return Boolean; -- Determine whether to emit an error message based on the combination - -- of flags Check_Elab_Flag and Flag. + -- 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 @@ -19415,12 +19411,22 @@ package body Sem_Elab is -- Emit -- ---------- - function Emit (Flag : Boolean) return Boolean is + function Emit return Boolean is begin - if Check_Elab_Flag then - return Flag; - else + -- a regular elaboration warning or error + + if Uncond_Msg then return True; + + -- Dynamic elaboration model, warnings controlled by -gnatwl + + elsif Dynamic_Elaboration_Checks then + return Elab_Warnings; + + -- Static elaboration model, info messages controlled by -gnatel + + else + return Elab_Info_Messages; end if; end Emit; @@ -19446,6 +19452,13 @@ package body Sem_Elab is Ent : Entity_Id; + Prefix : constant String := + (if Uncond_Msg + then "<<" + elsif Dynamic_Elaboration_Checks + then "?l?" + else "?$?"); + -- Start of processing for Output_Calls begin @@ -19455,34 +19468,16 @@ package body Sem_Elab is 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; + if Emit then + if Is_Generic_Unit (Ent) then + Error_Msg_NE ("\\" & Prefix & "& instantiated #", N, Ent); + elsif Is_Init_Proc (Ent) then + Error_Msg_N + ("\\" & Prefix & "initialization procedure called #", N); + elsif Is_Printable_Error_Name then + Error_Msg_NE ("\\" & Prefix & "& called #", N, Ent); + else + Error_Msg_N ("\\" & Prefix & "called #", N); end if; end if; end loop;
