From: Viljar Indus <[email protected]>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
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 22adac2186b..fefb01029d3 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;
--
2.53.0
