OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2013-01-02  Robert Dewar  <dewar@adacore.com>

	* errout.ads: Minor comment fixes.
	* opt.ads: Minor comment additions.
	* exp_aggr.adb: Add tags to warning messages
	* exp_ch11.adb, exp_ch3.adb, exp_ch4.adb, exp_util.adb, sem_aggr.adb,
	sem_attr.adb, sem_case.adb, sem_cat.adb, sem_ch3.adb, sem_ch4.adb,
	sem_ch5.adb, sem_disp.adb, sem_dist.adb, sem_elab.adb, sem_eval.adb,
	sem_intr.adb, sem_mech.adb, sem_prag.adb, sem_res.adb, sem_util.adb,
	sem_warn.adb: Add tags to warning messages

2013-01-02  Doug Rupp  <rupp@adacore.com>

	* init.c [VMS] Remove subtest on reason mask for ACCVIO that is a C_E.

2013-01-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb: Recover source name for renamed packagea.

From-SVN: r194786
This commit is contained in:
Arnaud Charlet 2013-01-02 10:51:35 +01:00
parent dbfeb4faf0
commit 324ac54054
27 changed files with 423 additions and 351 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
gcc/ada/ChangeLog
View File

@ -1,3 +1,22 @@
2013-01-02 Robert Dewar <dewar@adacore.com>
* errout.ads: Minor comment fixes.
* opt.ads: Minor comment additions.
* exp_aggr.adb: Add tags to warning messages
* exp_ch11.adb, exp_ch3.adb, exp_ch4.adb, exp_util.adb, sem_aggr.adb,
sem_attr.adb, sem_case.adb, sem_cat.adb, sem_ch3.adb, sem_ch4.adb,
sem_ch5.adb, sem_disp.adb, sem_dist.adb, sem_elab.adb, sem_eval.adb,
sem_intr.adb, sem_mech.adb, sem_prag.adb, sem_res.adb, sem_util.adb,
sem_warn.adb: Add tags to warning messages
2013-01-02 Doug Rupp <rupp@adacore.com>
* init.c [VMS] Remove subtest on reason mask for ACCVIO that is a C_E.
2013-01-02 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb: Recover source name for renamed packagea.
2013-01-02 Robert Dewar <dewar@adacore.com>
* errout.adb (Set_Msg_Insertion_Warning): Correct typo causing

2
gcc/ada/errout.ads
View File

@ -60,7 +60,7 @@ package Errout is
-- Exception raised if Raise_Exception_On_Error is true
Warning_Doc_Switch : Boolean renames Err_Vars.Warning_Doc_Switch;
-- If this is set True, then the ??/?x?/?.x? sequences in error messages
-- If this is set True, then the ??/?x?/?X? sequences in error messages
-- are active (see errout.ads for details). If this switch is False, then
-- these sequences are ignored (i.e. simply equivalent to a single ?). The
-- -gnatw.d switch sets this flag True, -gnatw.D sets this flag False.

13
gcc/ada/exp_aggr.adb
View File

@ -431,13 +431,14 @@ package body Exp_Aggr is
if Present (Component_Associations (N)) then
Indx :=
First (Choices (First (Component_Associations (N))));
if Is_Entity_Name (Indx)
and then not Is_Type (Entity (Indx))
then
Error_Msg_N
("single component aggregate in non-static context?",
Indx);
Error_Msg_N ("\maybe subtype name was meant?", Indx);
("single component aggregate in "
& "non-static context??", Indx);
Error_Msg_N ("\maybe subtype name was meant??", Indx);
end if;
end if;
@ -3057,7 +3058,7 @@ package body Exp_Aggr is
elsif Expr_Value (Val1) /= Expr_Value (Val2) then
Apply_Compile_Time_Constraint_Error (Aggr,
Msg => "incorrect value for discriminant&?",
Msg => "incorrect value for discriminant&??",
Reason => CE_Discriminant_Check_Failed,
Ent => D);
return False;
@ -3767,7 +3768,7 @@ package body Exp_Aggr is
else
Error_Msg_N
("non-static object requires elaboration code?", N);
("non-static object requires elaboration code??", N);
exit;
end if;
@ -3775,7 +3776,7 @@ package body Exp_Aggr is
end loop;
if Present (Component_Associations (N)) then
Error_Msg_N ("object requires elaboration code?", N);
Error_Msg_N ("object requires elaboration code??", N);
end if;
end if;
end;

14
gcc/ada/exp_ch11.adb
View File

@ -1005,8 +1005,8 @@ package body Exp_Ch11 is
then
Warn_No_Exception_Propagation_Active (Handler);
Error_Msg_N
("\?this handler can never be entered, and has been removed",
Handler);
("\?X?this handler can never be entered, "
& "and has been removed", Handler);
end if;
if No_Exception_Propagation_Active then
@ -1808,10 +1808,10 @@ package body Exp_Ch11 is
if Configurable_Run_Time_Mode then
Error_Msg_NE
("\?& may call Last_Chance_Handler", N, E);
("\?X?& may call Last_Chance_Handler", N, E);
else
Error_Msg_NE
("\?& may result in unhandled exception", N, E);
("\?X?& may result in unhandled exception", N, E);
end if;
end if;
end;
@ -2147,10 +2147,10 @@ package body Exp_Ch11 is
if Configurable_Run_Time_Mode then
Error_Msg_N
("\?Last_Chance_Handler will be called on exception", N);
("\?X?Last_Chance_Handler will be called on exception", N);
else
Error_Msg_N
("\?execution may raise unhandled exception", N);
("\?X?execution may raise unhandled exception", N);
end if;
end if;
end Warn_If_No_Propagation;
@ -2162,7 +2162,7 @@ package body Exp_Ch11 is
procedure Warn_No_Exception_Propagation_Active (N : Node_Id) is
begin
Error_Msg_N
("?pragma Restrictions (No_Exception_Propagation) in effect", N);
("?X?pragma Restrictions (No_Exception_Propagation) in effect", N);
end Warn_No_Exception_Propagation_Active;
end Exp_Ch11;

9
gcc/ada/exp_ch3.adb
View File

@ -7132,7 +7132,7 @@ package body Exp_Ch3 is
if Is_Ancestor (RSPWS, Etype (Pool)) then
Error_Msg_N
("?subpool access type has deeper accessibility " &
("??subpool access type has deeper accessibility " &
"level than pool", Def_Id);
Append_Freeze_Action (Def_Id,
@ -7744,14 +7744,13 @@ package body Exp_Ch3 is
if Warning_Needed then
Error_Msg_N
("Objects of the type cannot be initialized " &
"statically by default?",
Parent (E));
("Objects of the type cannot be initialized "
& "statically by default??", Parent (E));
end if;
end if;
else
Error_Msg_N ("Object cannot be initialized statically?", E);
Error_Msg_N ("Object cannot be initialized statically??", E);
end if;
end if;
end Initialization_Warning;

49
gcc/ada/exp_ch4.adb
View File

@ -3686,7 +3686,7 @@ package body Exp_Ch4 is
Kill_Dead_Code (Declaration_Node (Entity (High_Bound)));
Apply_Compile_Time_Constraint_Error
(N => Cnode,
Msg => "concatenation result upper bound out of range?",
Msg => "concatenation result upper bound out of range??",
Reason => CE_Range_Check_Failed);
end Expand_Concatenate;
@ -5501,9 +5501,10 @@ package body Exp_Ch4 is
-- actually eliminated the danger of optimization above.
if Overflow_Check_Mode not in Minimized_Or_Eliminated then
Error_Msg_N ("?explicit membership test may be optimized away", N);
Error_Msg_N
("??explicit membership test may be optimized away", N);
Error_Msg_N -- CODEFIX
("\?use ''Valid attribute instead", N);
("\??use ''Valid attribute instead", N);
end if;
return;
@ -5684,8 +5685,8 @@ package body Exp_Ch4 is
if Lcheck = LT or else Ucheck = GT then
if Warn1 then
Error_Msg_N ("?range test optimized away", N);
Error_Msg_N ("\?value is known to be out of range", N);
Error_Msg_N ("??range test optimized away", N);
Error_Msg_N ("\??value is known to be out of range", N);
end if;
Rewrite (N, New_Reference_To (Standard_False, Loc));
@ -5698,8 +5699,8 @@ package body Exp_Ch4 is
elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
if Warn1 then
Error_Msg_N ("?range test optimized away", N);
Error_Msg_N ("\?value is known to be in range", N);
Error_Msg_N ("??range test optimized away", N);
Error_Msg_N ("\??value is known to be in range", N);
end if;
Rewrite (N, New_Reference_To (Standard_True, Loc));
@ -5713,8 +5714,8 @@ package body Exp_Ch4 is
elsif Lcheck in Compare_GE then
if Warn2 and then not In_Instance then
Error_Msg_N ("?lower bound test optimized away", Lo);
Error_Msg_N ("\?value is known to be in range", Lo);
Error_Msg_N ("??lower bound test optimized away", Lo);
Error_Msg_N ("\??value is known to be in range", Lo);
end if;
Rewrite (N,
@ -5730,8 +5731,8 @@ package body Exp_Ch4 is
elsif Ucheck in Compare_LE then
if Warn2 and then not In_Instance then
Error_Msg_N ("?upper bound test optimized away", Hi);
Error_Msg_N ("\?value is known to be in range", Hi);
Error_Msg_N ("??upper bound test optimized away", Hi);
Error_Msg_N ("\??value is known to be in range", Hi);
end if;
Rewrite (N,
@ -5755,25 +5756,25 @@ package body Exp_Ch4 is
if Lcheck = LT or else Ucheck = GT then
Error_Msg_N
("?value can only be in range if it is invalid", N);
("??value can only be in range if it is invalid", N);
-- Result is in range for valid value
elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
Error_Msg_N
("?value can only be out of range if it is invalid", N);
("??value can only be out of range if it is invalid", N);
-- Lower bound check succeeds if value is valid
elsif Warn2 and then Lcheck in Compare_GE then
Error_Msg_N
("?lower bound check only fails if it is invalid", Lo);
("??lower bound check only fails if it is invalid", Lo);
-- Upper bound check succeeds if value is valid
elsif Warn2 and then Ucheck in Compare_LE then
Error_Msg_N
("?upper bound check only fails for invalid values", Hi);
("??upper bound check only fails for invalid values", Hi);
end if;
end if;
end;
@ -9665,9 +9666,10 @@ package body Exp_Ch4 is
Reason => PE_Accessibility_Check_Failed));
Set_Etype (N, Target_Type);
Error_Msg_N ("?accessibility check failure", N);
Error_Msg_N
("??accessibility check failure", N);
Error_Msg_NE
("\?& will be raised at run time", N, Standard_Program_Error);
("\??& will be raised at run time", N, Standard_Program_Error);
end Raise_Accessibility_Error;
----------------------
@ -10632,7 +10634,7 @@ package body Exp_Ch4 is
end if;
-- Otherwise force evaluation unless Assignment_OK flag is set (this
-- flag indicates ??? -- more comments needed here)
-- flag indicates ??? More comments needed here)
if Assignment_OK (N) then
null;
@ -12061,7 +12063,7 @@ package body Exp_Ch4 is
if Constant_Condition_Warnings
and then Comes_From_Source (Original_Node (N))
then
Error_Msg_N ("could replace by ""'=""?", N);
Error_Msg_N ("could replace by ""'=""?c?", N);
end if;
Op := N_Op_Eq;
@ -12254,7 +12256,8 @@ package body Exp_Ch4 is
and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
then
Error_Msg_N
("can never be greater than, could replace by ""'=""?", N);
("can never be greater than, could replace by ""'=""?c?",
N);
Warning_Generated := True;
end if;
@ -12279,7 +12282,7 @@ package body Exp_Ch4 is
and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
then
Error_Msg_N
("can never be less than, could replace by ""'=""?", N);
("can never be less than, could replace by ""'=""?c?", N);
Warning_Generated := True;
end if;
@ -12312,11 +12315,11 @@ package body Exp_Ch4 is
then
if True_Result then
Error_Msg_N
("condition can only be False if invalid values present?",
("condition can only be False if invalid values present??",
N);
elsif False_Result then
Error_Msg_N
("condition can only be True if invalid values present?",
("condition can only be True if invalid values present??",
N);
end if;
end if;

9
gcc/ada/exp_util.adb
View File

@ -224,9 +224,11 @@ package body Exp_Util is
end case;
if Present (Msg_Node) then
Error_Msg_N ("?info: atomic synchronization set for &", Msg_Node);
Error_Msg_N
("?n?info: atomic synchronization set for &", Msg_Node);
else
Error_Msg_N ("?info: atomic synchronization set", N);
Error_Msg_N
("?n?info: atomic synchronization set", N);
end if;
end if;
end Activate_Atomic_Synchronization;
@ -5125,7 +5127,8 @@ package body Exp_Util is
if W then
Error_Msg_F
("?this code can never be executed and has been deleted!", N);
("??this code can never be executed and has been deleted!",
N);
end if;
end if;

4
gcc/ada/init.c
View File

@ -985,12 +985,10 @@ static const struct cond_except dec_ada_cond_except_table [] = {
/* Subtest for ACCVIO Constraint_Error, kept for compatibility,
in hindsight should have just made ACCVIO == Storage_Error. */
#define ACCVIO_REASON_MASK 2
#define ACCVIO_VIRTUAL_ADDR 3
static const struct cond_subtests accvio_c_e =
{2, /* number of subtests below */
{1, /* number of subtests below */
{
{ACCVIO_REASON_MASK, 0},
{ACCVIO_VIRTUAL_ADDR, 0}
}
};

26
gcc/ada/opt.ads
View File

@ -211,10 +211,9 @@ package Opt is
-- Enable assertions made using pragma Assert
Assume_No_Invalid_Values : Boolean := False;
-- GNAT
-- Normally, in accordance with (RM 13.9.1 (9-11)) the front end assumes
-- that values could have invalid representations, unless it can clearly
-- prove that the values are valid. If this switch is set (by -gnatB or by
-- GNAT Normally, in accordance with (RM 13.9.1 (9-11)) the front end
-- assumes that values could have invalid representations, unless it can
-- clearly prove that the values are valid. If this switch is set (by
-- pragma Assume_No_Invalid_Values (Off)), then the compiler assumes values
-- are valid and in range of their representations. This feature is now
-- fully enabled in the compiler.
@ -374,7 +373,8 @@ package Opt is
Constant_Condition_Warnings : Boolean := False;
-- GNAT
-- Set to True to activate warnings on constant conditions
-- Set to True to activate warnings on constant conditions. Modified by
-- use of -gnatwc/C.
Create_Mapping_File : Boolean := False;
-- GNATMAKE, GPRMAKE
@ -1467,7 +1467,7 @@ package Opt is
-- GNAT
-- Set to True to generate all warnings on Ada 2005 compatibility issues,
-- including warnings on Ada 2005 obsolescent features used in Ada 2005
-- mode. Set False by -gnatwY.
-- mode. Set by default, set False by -gnatwY.
Warn_On_Ada_2012_Compatibility : Boolean := True;
-- GNAT
@ -1496,12 +1496,13 @@ package Opt is
Warn_On_Atomic_Synchronization : Boolean := False;
-- GNAT
-- Set to True to generate information messages for atomic synchronization.
-- Set True by use of -gnatw.n.
-- Modified by use of -gnatw.n/.N.
Warn_On_Bad_Fixed_Value : Boolean := False;
-- GNAT
-- Set to True to generate warnings for static fixed-point expression
-- values that are not an exact multiple of the small value of the type.
-- Odd by default, modified by use of -gnatwb/B.
Warn_On_Biased_Representation : Boolean := True;
-- GNAT
@ -1548,6 +1549,7 @@ package Opt is
-- Set to True to generate warnings if no value is ever assigned to a
-- variable that is at least partially uninitialized. Set to false to
-- suppress such warnings. The default is that such warnings are enabled.
-- Modified by use of -gnatwv/V.
Warn_On_Non_Local_Exception : Boolean := False;
-- GNAT
@ -1557,6 +1559,7 @@ package Opt is
-- default is not to generate the warnings except that if the source has
-- at least one exception handler, and this restriction is set, and the
-- warning was not explicitly turned off, then it is turned on by default.
-- Modified by use of -gnatw.x/.X.
No_Warn_On_Non_Local_Exception : Boolean := False;
-- GNAT
@ -1584,7 +1587,8 @@ package Opt is
Warn_On_Questionable_Missing_Parens : Boolean := True;
-- GNAT
-- Set to True to generate warnings for cases where parentheses are missing
-- and the usage is questionable, because the intent is unclear.
-- and the usage is questionable, because the intent is unclear. On by
-- default, modified by use of -gnatwq/Q.
Warn_On_Parameter_Order : Boolean := False;
-- GNAT
@ -1613,7 +1617,7 @@ package Opt is
Warn_On_Suspicious_Modulus_Value : Boolean := True;
-- GNAT
-- Set to True to generate warnings for suspicious modulus values. The
-- default is that this warning is enabled.
-- default is that this warning is enabled. Modified by -gnatw.m/.M.
Warn_On_Unchecked_Conversion : Boolean := True;
-- GNAT
@ -1626,12 +1630,12 @@ package Opt is
-- Set to True to generate warnings for inappropriate uses (comparisons
-- and explicit ranges) on unordered enumeration types (which includes
-- all enumeration types for which pragma Ordered is not given). The
-- default is that this warning is disabled.
-- default is that this warning is disabled. Modified by -gnat.u/.U.
Warn_On_Unrecognized_Pragma : Boolean := True;
-- GNAT
-- Set to True to generate warnings for unrecognized pragmas. The default
-- is that this warning is enabled.
-- is that this warning is enabled. Modified by use of -gnatwg/G.
Warn_On_Unrepped_Components : Boolean := False;
-- GNAT

51
gcc/ada/sem_aggr.adb
View File

@ -468,13 +468,13 @@ package body Sem_Aggr is
then
if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then
Apply_Compile_Time_Constraint_Error
(Exp, "value not in range of}?", CE_Range_Check_Failed,
(Exp, "value not in range of}??", CE_Range_Check_Failed,
Ent => Base_Type (Check_Typ),
Typ => Base_Type (Check_Typ));
elsif Is_Out_Of_Range (Exp, Check_Typ) then
Apply_Compile_Time_Constraint_Error
(Exp, "value not in range of}?", CE_Range_Check_Failed,
(Exp, "value not in range of}??", CE_Range_Check_Failed,
Ent => Check_Typ,
Typ => Check_Typ);
@ -583,9 +583,9 @@ package body Sem_Aggr is
elsif Expr_Value (This_Low) /= Expr_Value (Aggr_Low (Dim)) then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("sub-aggregate low bound mismatch?", N);
Error_Msg_N ("sub-aggregate low bound mismatch??", N);
Error_Msg_N
("\Constraint_Error will be raised at run time?", N);
("\Constraint_Error will be raised at run time??", N);
end if;
end if;
@ -597,9 +597,9 @@ package body Sem_Aggr is
Expr_Value (This_High) /= Expr_Value (Aggr_High (Dim))
then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("sub-aggregate high bound mismatch?", N);
Error_Msg_N ("sub-aggregate high bound mismatch??", N);
Error_Msg_N
("\Constraint_Error will be raised at run time?", N);
("\Constraint_Error will be raised at run time??", N);
end if;
end if;
end if;
@ -1440,8 +1440,8 @@ package body Sem_Aggr is
if OK_BH and then OK_AH and then Val_BH < Val_AH then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("upper bound out of range?", AH);
Error_Msg_N ("\Constraint_Error will be raised at run time?", AH);
Error_Msg_N ("upper bound out of range??", AH);
Error_Msg_N ("\Constraint_Error will be raised at run time??", AH);
-- You need to set AH to BH or else in the case of enumerations
-- indexes we will not be able to resolve the aggregate bounds.
@ -1483,14 +1483,14 @@ package body Sem_Aggr is
if OK_L and then Val_L > Val_AL then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("lower bound of aggregate out of range?", N);
Error_Msg_N ("\Constraint_Error will be raised at run time?", N);
Error_Msg_N ("lower bound of aggregate out of range??", N);
Error_Msg_N ("\Constraint_Error will be raised at run time??", N);
end if;
if OK_H and then Val_H < Val_AH then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("upper bound of aggregate out of range?", N);
Error_Msg_N ("\Constraint_Error will be raised at run time?", N);
Error_Msg_N ("upper bound of aggregate out of range??", N);
Error_Msg_N ("\Constraint_Error will be raised at run time??", N);
end if;
end Check_Bounds;
@ -1529,8 +1529,8 @@ package body Sem_Aggr is
if Range_Len < Len then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("too many elements?", N);
Error_Msg_N ("\Constraint_Error will be raised at run time?", N);
Error_Msg_N ("too many elements??", N);
Error_Msg_N ("\Constraint_Error will be raised at run time??", N);
end if;
end Check_Length;
@ -1980,7 +1980,7 @@ package body Sem_Aggr is
elsif Nkind (Choice) = N_Subtype_Indication then
Resolve_Discrete_Subtype_Indication (Choice, Index_Base);
-- Does the subtype indication evaluation raise CE ?
-- Does the subtype indication evaluation raise CE?
Get_Index_Bounds (Subtype_Mark (Choice), S_Low, S_High);
Get_Index_Bounds (Choice, Low, High);
@ -2310,7 +2310,8 @@ package body Sem_Aggr is
(Enumeration_Pos (AHi) - Enumeration_Pos (ALo))
then
Error_Msg_N
("missing index value(s) in array aggregate?", N);
("missing index value(s) in array aggregate??",
N);
-- Output missing value(s) at start
@ -2319,11 +2320,11 @@ package body Sem_Aggr is
if Chars (ALo) = Chars (Ent) then
Error_Msg_Name_1 := Chars (ALo);
Error_Msg_N ("\ %?", N);
Error_Msg_N ("\ %??", N);
else
Error_Msg_Name_1 := Chars (ALo);
Error_Msg_Name_2 := Chars (Ent);
Error_Msg_N ("\ % .. %?", N);
Error_Msg_N ("\ % .. %??", N);
end if;
end if;
@ -2334,11 +2335,11 @@ package body Sem_Aggr is
if Chars (AHi) = Chars (Ent) then
Error_Msg_Name_1 := Chars (Ent);
Error_Msg_N ("\ %?", N);
Error_Msg_N ("\ %??", N);
else
Error_Msg_Name_1 := Chars (Ent);
Error_Msg_Name_2 := Chars (AHi);
Error_Msg_N ("\ % .. %?", N);
Error_Msg_N ("\ % .. %??", N);
end if;
end if;
@ -2356,7 +2357,7 @@ package body Sem_Aggr is
not Is_Constrained (First_Subtype (Etype (N)))
then
Error_Msg_N
("bounds of aggregate do not match target?", N);
("bounds of aggregate do not match target??", N);
end if;
end;
end if;
@ -2810,7 +2811,7 @@ package body Sem_Aggr is
and then Enclosing_CPP_Parent (Typ) /= A_Type
then
Error_Msg_NE
("?must use 'C'P'P constructor for type &", A,
("??must use 'C'P'P constructor for type &", A,
Enclosing_CPP_Parent (Typ));
-- The following call is not needed if the previous warning
@ -4576,9 +4577,9 @@ package body Sem_Aggr is
Insert_Action
(Compile_Time_Constraint_Error
(Expr,
"(Ada 2005) null not allowed in null-excluding component?"),
Make_Raise_Constraint_Error (Sloc (Expr),
Reason => CE_Access_Check_Failed));
"(Ada 2005) null not allowed in null-excluding component??"),
Make_Raise_Constraint_Error
(Sloc (Expr), Reason => CE_Access_Check_Failed));
-- Set proper type for bogus component (why is this needed???)

57
gcc/ada/sem_attr.adb
View File

@ -739,7 +739,7 @@ package body Sem_Attr is
if Is_CPP_Class (Root_Type (Typ)) then
Error_Msg_N
("?current instance unsupported for derivations of "
("??current instance unsupported for derivations of "
& "'C'P'P types", N);
end if;
@ -2019,7 +2019,7 @@ package body Sem_Attr is
if not Attribute_83 (Attr_Id) then
if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_Name_1 := Aname;
Error_Msg_N ("(Ada 83) attribute% is not standard?", N);
Error_Msg_N ("(Ada 83) attribute% is not standard??", N);
end if;
if Attribute_Impl_Def (Attr_Id) then
@ -2640,7 +2640,7 @@ package body Sem_Attr is
and then Warn_On_Redundant_Constructs
then
Error_Msg_NE -- CODEFIX
("?redundant attribute, & is its own base type", N, Typ);
("?r?redundant attribute, & is its own base type", N, Typ);
end if;
if Nkind (Parent (N)) /= N_Attribute_Reference then
@ -2896,7 +2896,7 @@ package body Sem_Attr is
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("constrained for private type is an " &
"obsolescent feature (RM J.4)?", N);
"obsolescent feature (RM J.4)?j?", N);
end if;
-- If we are within an instance, the attribute must be legal
@ -4346,7 +4346,7 @@ package body Sem_Attr is
and then Is_Constant_Object (Entity (P))
then
Error_Msg_N
("?attribute Old applied to constant has no effect", P);
("??attribute Old applied to constant has no effect", P);
end if;
-- The attribute appears within a pre/postcondition, but refers to
@ -4603,7 +4603,7 @@ package body Sem_Attr is
and then Warn_On_Redundant_Constructs
then
Error_Msg_N
("postconditions on inlined functions not enforced?", N);
("postconditions on inlined functions not enforced?r?", N);
end if;
-- If we are in the scope of a function and in Spec_Expression mode,
@ -5032,10 +5032,10 @@ package body Sem_Attr is
Name_Simple_Storage_Pool_Type))
then
Error_Msg_Name_1 := Aname;
Error_Msg_N ("cannot use % attribute for type with simple " &
"storage pool?", N);
Error_Msg_N ("cannot use % attribute for type with simple "
& "storage pool??", N);
Error_Msg_N
("\Program_Error will be raised at run time?", N);
("\Program_Error will be raised at run time??", N);
Rewrite
(N, Make_Raise_Program_Error
@ -5228,8 +5228,8 @@ package body Sem_Attr is
if not Is_Tagged_Type (P_Type) then
Error_Attr_P ("prefix of % attribute must be tagged");
-- Next test does not apply to generated code
-- why not, and what does the illegal reference mean???
-- Next test does not apply to generated code why not, and what does
-- the illegal reference mean???
elsif Is_Object_Reference (P)
and then not Is_Class_Wide_Type (P_Type)
@ -5240,9 +5240,9 @@ package body Sem_Attr is
"of class - wide type");
end if;
-- The prefix cannot be an incomplete type. However, references
-- to 'Tag can be generated when expanding interface conversions,
-- and this is legal.
-- The prefix cannot be an incomplete type. However, references to
-- 'Tag can be generated when expanding interface conversions, and
-- this is legal.
if Comes_From_Source (N) then
Check_Not_Incomplete_Type;
@ -5728,8 +5728,8 @@ package body Sem_Attr is
begin
if Present (Pred_Func) and then Current_Scope = Pred_Func then
Error_Msg_N
("attribute Valid requires a predicate check?", N);
Error_Msg_N ("\and will result in infinite recursion?", N);
("attribute Valid requires a predicate check??", N);
Error_Msg_N ("\and will result in infinite recursion??", N);
end if;
end;
@ -5744,7 +5744,7 @@ package body Sem_Attr is
Check_Object_Reference (P);
if No_Scalar_Parts (P_Type) then
Error_Attr_P ("?attribute % always True, no scalars to check");
Error_Attr_P ("??attribute % always True, no scalars to check");
end if;
Set_Etype (N, Standard_Boolean);
@ -6095,7 +6095,7 @@ package body Sem_Attr is
elsif Is_Out_Of_Range (N, T) then
Apply_Compile_Time_Constraint_Error
(N, "value not in range of}?", CE_Range_Check_Failed);
(N, "value not in range of}??", CE_Range_Check_Failed);
elsif not Range_Checks_Suppressed (T) then
Enable_Range_Check (N);
@ -8894,9 +8894,10 @@ package body Sem_Attr is
-- know will fail, so generate an appropriate warning.
if In_Instance_Body then
Error_Msg_F ("?non-local pointer cannot point to local object", P);
Error_Msg_F
("\?Program_Error will be raised at run time", P);
("??non-local pointer cannot point to local object", P);
Error_Msg_F
("\??Program_Error will be raised at run time", P);
Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Accessibility_Check_Failed));
@ -9368,9 +9369,9 @@ package body Sem_Attr is
if In_Instance_Body then
Error_Msg_F
("?non-local pointer cannot point to local object", P);
("??non-local pointer cannot point to local object", P);
Error_Msg_F
("\?Program_Error will be raised at run time", P);
("\??Program_Error will be raised at run time", P);
Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Accessibility_Check_Failed));
@ -9484,11 +9485,13 @@ package body Sem_Attr is
declare
D : constant Node_Id := Declaration_Node (Entity (P));
begin
Error_Msg_N ("aliased object has explicit bounds?",
D);
Error_Msg_N ("\declare without bounds"
& " (and with explicit initialization)?", D);
Error_Msg_N ("\for use with unconstrained access?", D);
Error_Msg_N
("aliased object has explicit bounds??", D);
Error_Msg_N
("\declare without bounds (and with explicit "
& "initialization)??", D);
Error_Msg_N
("\for use with unconstrained access??", D);
end;
end if;
end if;

4
gcc/ada/sem_case.adb
View File

@ -601,8 +601,8 @@ package body Sem_Case is
and then Comes_From_Source (Others_Choice)
and then Is_Empty_List (Choice_List)
then
Error_Msg_N ("?OTHERS choice is redundant", Others_Choice);
Error_Msg_N ("\previous choices cover all values", Others_Choice);
Error_Msg_N ("?r?OTHERS choice is redundant", Others_Choice);
Error_Msg_N ("\?r?previous choices cover all values", Others_Choice);
end if;
end Expand_Others_Choice;

7
gcc/ada/sem_cat.adb
View File

@ -923,6 +923,7 @@ package body Sem_Cat is
then
-- If the type is private, it must have the Ada 2005 pragma
-- Has_Preelaborable_Initialization.
-- The check is omitted within predefined units. This is probably
-- obsolete code to fix the Ada 95 weakness in this area ???
@ -1728,8 +1729,7 @@ package body Sem_Cat is
Direct_Designated_Type := Designated_Type (T);
Desig_Type := Etype (Direct_Designated_Type);
-- Why is the check below not in
-- Validate_Remote_Access_To_Class_Wide_Type???
-- Why is this check not in Validate_Remote_Access_To_Class_Wide_Type???
if not Is_Valid_Remote_Object_Type (Desig_Type) then
Error_Msg_N
@ -2047,6 +2047,7 @@ package body Sem_Cat is
function Is_Primary (N : Node_Id) return Boolean;
-- Determine whether node is syntactically a primary in an expression
-- This function should probably be somewhere else ???
--
-- Also it does not do what it says, e.g if N is a binary operator
-- whose parent is a binary operator, Is_Primary returns True ???
@ -2170,7 +2171,7 @@ package body Sem_Cat is
if GNAT_Mode then
Error_Msg_N
("?non-static constant in preelaborated unit", N);
("??non-static constant in preelaborated unit", N);
else
Flag_Non_Static_Expr
("non-static constant in preelaborated unit", N);

16
gcc/ada/sem_ch12.adb
View File

@ -12996,6 +12996,22 @@ package body Sem_Ch12 is
end if;
if Is_Global (E) then
-- If the entity is a package renaming that is the prefix of
-- an expanded name, it has been rewritten as the renamed
-- package, which is necessary semantically but complicates
-- ASIS tree traversal, so we recover the original entity to
-- expose the renaming.
if Ekind (E) = E_Package
and then Nkind (Parent (N)) = N_Expanded_Name
and then Present (Original_Node (N2))
and then Present (Entity (Original_Node (N2)))
then
N2 := Original_Node (N2);
Set_Associated_Node (N, N2);
end if;
Set_Global_Type (N, N2);
elsif Nkind (N) = N_Op_Concat

28
gcc/ada/sem_ch3.adb
View File

@ -3643,9 +3643,9 @@ package body Sem_Ch3 is
(E, Attribute_Address))
then
Error_Msg_N
("?more than one task with same entry address", N);
("??more than one task with same entry address", N);
Error_Msg_N
("\?Program_Error will be raised at run time", N);
("\??Program_Error will be raised at run time", N);
Insert_Action (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Duplicated_Entry_Address));
@ -10866,7 +10866,7 @@ package body Sem_Ch3 is
if Ada_Version < Ada_2005 then
Error_Msg_N
("access subtype of general access type would not " &
"be allowed in Ada 2005?", S);
"be allowed in Ada 2005?y?", S);
else
Error_Msg_N
("access subtype of general access type not allowed", S);
@ -10882,7 +10882,7 @@ package body Sem_Ch3 is
if Ada_Version < Ada_2005 then
Error_Msg_N
("access subtype would not be allowed in generic body " &
"in Ada 2005?", S);
"in Ada 2005?y?", S);
else
Error_Msg_N
("access subtype not allowed in generic body", S);
@ -11320,6 +11320,7 @@ package body Sem_Ch3 is
-- to one: one new discriminant can constrain several old ones. In
-- that case, scan sequentially the stored_constraint, the list of
-- discriminants of the parents, and the constraints.
-- Previous code checked for the present of the Stored_Constraint
-- list for the derived type, but did not use it at all. Should it
-- be present when the component is a discriminated task type?
@ -11780,7 +11781,7 @@ package body Sem_Ch3 is
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("subtype digits constraint is an " &
"obsolescent feature (RM J.3(8))?", C);
"obsolescent feature (RM J.3(8))?j?", C);
end if;
D := Digits_Expression (C);
@ -11794,7 +11795,7 @@ package body Sem_Ch3 is
if Digits_Value (Def_Id) > Digits_Value (T) then
Error_Msg_Uint_1 := Digits_Value (T);
Error_Msg_N ("?digits value is too large, maximum is ^", D);
Error_Msg_N ("??digits value is too large, maximum is ^", D);
Rais :=
Make_Raise_Constraint_Error (Sloc (D),
Reason => CE_Range_Check_Failed);
@ -12007,7 +12008,7 @@ package body Sem_Ch3 is
if Warn_On_Obsolescent_Feature then
Error_Msg_S
("subtype delta constraint is an " &
"obsolescent feature (RM J.3(7))?");
"obsolescent feature (RM J.3(7))?j?");
end if;
D := Delta_Expression (C);
@ -12020,7 +12021,7 @@ package body Sem_Ch3 is
-- course there is an ACVC test that checks this!
if Delta_Value (Def_Id) < Delta_Value (T) then
Error_Msg_N ("?delta value is too small", D);
Error_Msg_N ("??delta value is too small", D);
Rais :=
Make_Raise_Constraint_Error (Sloc (D),
Reason => CE_Range_Check_Failed);
@ -16797,10 +16798,6 @@ package body Sem_Ch3 is
Set_Must_Not_Freeze (I);
Set_Must_Not_Freeze (Prefix (I));
-- Is order critical??? if so, document why, if not
-- use Analyze_And_Resolve
Analyze_And_Resolve (I);
T := Etype (I);
R := I;
@ -16928,7 +16925,8 @@ package body Sem_Ch3 is
and then Nkind (Right_Opnd (Mod_Expr)) = N_Integer_Literal
and then Intval (Right_Opnd (Mod_Expr)) <= Uint_64
then
Error_Msg_N ("suspicious MOD value, was '*'* intended'??", Mod_Expr);
Error_Msg_N
("suspicious MOD value, was '*'* intended'??M?", Mod_Expr);
end if;
-- Proceed with analysis of mod expression
@ -17273,7 +17271,7 @@ package body Sem_Ch3 is
High_Val := Expr_Value_R (High);
if Low_Val > High_Val then
Error_Msg_NE ("?fixed point type& has null range", Def, T);
Error_Msg_NE ("??fixed point type& has null range", Def, T);
end if;
end;
end if;
@ -19141,7 +19139,7 @@ package body Sem_Ch3 is
then
Make_Class_Wide_Type (Typ);
Error_Msg_N
("incomplete view of tagged type should be declared tagged?",
("incomplete view of tagged type should be declared tagged??",
Parent (Current_Entity (Typ)));
end if;
return;

33
gcc/ada/sem_ch4.adb
View File

@ -636,7 +636,9 @@ package body Sem_Ch4 is
Analyze (Not_Null_Check);
else
Error_Msg_N ("null value not allowed here?", E);
-- Seems weird for the following to be a warning ???
Error_Msg_N ("null value not allowed here??", E);
end if;
end;
end if;
@ -2082,7 +2084,8 @@ package body Sem_Ch4 is
-- account a possible implicit dereference.
if Is_Access_Type (Array_Type) then
Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
Error_Msg_NW
(Warn_On_Dereference, "?d?implicit dereference", N);
Array_Type := Process_Implicit_Dereference_Prefix (Pent, P);
end if;
@ -2241,7 +2244,8 @@ package body Sem_Ch4 is
if Is_Access_Type (Typ) then
Typ := Designated_Type (Typ);
Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
Error_Msg_NW
(Warn_On_Dereference, "?d?implicit dereference", N);
end if;
if Is_Array_Type (Typ) then
@ -2670,7 +2674,7 @@ package body Sem_Ch4 is
and then Intval (Right_Opnd (Parent (N))) <= Uint_64
then
Error_Msg_N
("suspicious MOD value, was '*'* intended'??", Parent (N));
("suspicious MOD value, was '*'* intended'??M?", Parent (N));
end if;
-- Remaining processing is same as for other arithmetic operators
@ -3235,7 +3239,7 @@ package body Sem_Ch4 is
while Present (It.Typ) loop
if Is_Access_Type (It.Typ) then
T := Designated_Type (It.Typ);
Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N);
else
T := It.Typ;
end if;
@ -3318,7 +3322,7 @@ package body Sem_Ch4 is
then
Insert_Explicit_Dereference (Nam);
Error_Msg_NW
(Warn_On_Dereference, "?implicit dereference", N);
(Warn_On_Dereference, "?d?implicit dereference", N);
end if;
end if;
@ -3427,13 +3431,13 @@ package body Sem_Ch4 is
if All_Present (N) then
Error_Msg_N
("?quantified expression with ALL "
("??quantified expression with ALL "
& "over a null range has value True", N);
Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
else
Error_Msg_N
("?quantified expression with SOME "
("??quantified expression with SOME "
& "over a null range has value False", N);
Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
end if;
@ -3810,7 +3814,7 @@ package body Sem_Ch4 is
-- Normal case of selected component applied to access type
else
Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N);
if Is_Entity_Name (Name) then
Pent := Entity (Name);
@ -3922,7 +3926,7 @@ package body Sem_Ch4 is
if Is_Access_Type (Etype (Name)) then
Insert_Explicit_Dereference (Name);
Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N);
end if;
elsif Is_Record_Type (Prefix_Type) then
@ -4220,7 +4224,7 @@ package body Sem_Ch4 is
if Is_Access_Type (Etype (Name)) then
Insert_Explicit_Dereference (Name);
Error_Msg_NW
(Warn_On_Dereference, "?implicit dereference", N);
(Warn_On_Dereference, "?d?implicit dereference", N);
end if;
end if;
@ -4403,7 +4407,7 @@ package body Sem_Ch4 is
Ent => Prefix_Type, Rep => False);
else
Apply_Compile_Time_Constraint_Error
(N, "component not present in }?",
(N, "component not present in }??",
CE_Discriminant_Check_Failed,
Ent => Prefix_Type, Rep => False);
end if;
@ -4537,7 +4541,8 @@ package body Sem_Ch4 is
if Is_Access_Type (Typ) then
Typ := Designated_Type (Typ);
Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
Error_Msg_NW
(Warn_On_Dereference, "?d?implicit dereference", N);
end if;
if Is_Array_Type (Typ)
@ -4574,7 +4579,7 @@ package body Sem_Ch4 is
if Is_Access_Type (Array_Type) then
Array_Type := Designated_Type (Array_Type);
Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N);
end if;
if not Is_Array_Type (Array_Type) then

29
gcc/ada/sem_ch5.adb
View File

@ -430,9 +430,9 @@ package body Sem_Ch5 is
if Locking_Policy /= 'C' then
Error_Msg_N ("assignment to the attribute PRIORITY has " &
"no effect?", Lhs);
"no effect??", Lhs);
Error_Msg_N ("\since no Locking_Policy has been " &
"specified", Lhs);
"specified??", Lhs);
end if;
return;
@ -636,8 +636,9 @@ package body Sem_Ch5 is
if Known_Null (Rhs) then
Apply_Compile_Time_Constraint_Error
(N => Rhs,
Msg => "(Ada 2005) null not allowed in null-excluding objects?",
(N => Rhs,
Msg =>
"(Ada 2005) null not allowed in null-excluding objects??",
Reason => CE_Null_Not_Allowed);
-- We still mark this as a possible modification, that's necessary
@ -717,10 +718,10 @@ package body Sem_Ch5 is
then
if Nkind (Lhs) in N_Has_Entity then
Error_Msg_NE -- CODEFIX
("?useless assignment of & to itself!", N, Entity (Lhs));
("?r?useless assignment of & to itself!", N, Entity (Lhs));
else
Error_Msg_N -- CODEFIX
("?useless assignment of object to itself!", N);
("?r?useless assignment of object to itself!", N);
end if;
end if;
@ -2405,7 +2406,7 @@ package body Sem_Ch5 is
(L, H, Assume_Valid => False) = GT
then
Error_Msg_N
("?loop range is null, loop will not execute", DS);
("??loop range is null, loop will not execute", DS);
-- Since we know the range of the loop is null, set the
-- appropriate flag to remove the loop entirely during
@ -2420,9 +2421,11 @@ package body Sem_Ch5 is
else
Error_Msg_N
("?loop range may be null, loop may not execute", DS);
("??loop range may be null, loop may not execute",
DS);
Error_Msg_N
("?can only execute if invalid values are present", DS);
("??can only execute if invalid values are present",
DS);
end if;
end if;
@ -2449,8 +2452,8 @@ package body Sem_Ch5 is
(Intval (Original_Node (H)) = Uint_0
or else Intval (Original_Node (H)) = Uint_1)
then
Error_Msg_N ("?loop range may be null", DS);
Error_Msg_N ("\?bounds may be wrong way round", DS);
Error_Msg_N ("??loop range may be null", DS);
Error_Msg_N ("\??bounds may be wrong way round", DS);
end if;
end;
end if;
@ -2666,7 +2669,7 @@ package body Sem_Ch5 is
then
Error_Msg_Sloc := Sloc (ODSD);
Error_Msg_N
("inner range same as outer range#?", DSD);
("inner range same as outer range#??", DSD);
end if;
end;
end if;
@ -2918,7 +2921,7 @@ package body Sem_Ch5 is
Check_SPARK_Restriction
("unreachable code is not allowed", Error_Node);
else
Error_Msg ("?unreachable code!", Sloc (Error_Node));
Error_Msg ("??unreachable code!", Sloc (Error_Node));
end if;
end if;

18
gcc/ada/sem_disp.adb
View File

@ -904,10 +904,10 @@ package body Sem_Disp is
and then not Is_Generic_Type (Typ)
and then not In_Instance
then
Error_Msg_N ("?declaration of& is too late!", Subp);
Error_Msg_N ("??declaration of& is too late!", Subp);
Error_Msg_NE -- CODEFIX??
("\spec should appear immediately after declaration of &!",
Subp, Typ);
("\??spec should appear immediately after declaration "
& "of & !", Subp, Typ);
exit;
end if;
@ -933,10 +933,10 @@ package body Sem_Disp is
and then not Is_Generic_Type (Typ)
and then not In_Instance
then
Error_Msg_N ("?declaration of& is too late!", Subp);
Error_Msg_N ("??declaration of& is too late!", Subp);
Error_Msg_NE
("\spec should appear immediately after declaration of &!",
Subp, Typ);
("\??spec should appear immediately after declaration "
& "of & !", Subp, Typ);
end if;
end if;
end;
@ -1153,7 +1153,7 @@ package body Sem_Disp is
and then In_Same_List (Parent (Tagged_Type), Parent (Parent (Subp)))
then
Error_Msg_N
("?not dispatching (must be defined in a package spec)", Subp);
("??not dispatching (must be defined in a package spec)", Subp);
return;
-- When the type is frozen, it is legitimate to define a new
@ -1169,7 +1169,7 @@ package body Sem_Disp is
elsif Is_Frozen (Tagged_Type) and then not Has_Dispatching_Parent then
Error_Msg_N ("this primitive operation is declared too late", Subp);
Error_Msg_NE
("?no primitive operations for& after this line",
("??no primitive operations for& after this line",
Freeze_Node (Tagged_Type),
Tagged_Type);
return;
@ -1220,7 +1220,7 @@ package body Sem_Disp is
else
Error_Msg_NE
("operation does not override inherited&?", Subp, Subp);
("operation does not override inherited&??", Subp, Subp);
end if;
else

7
gcc/ada/sem_dist.adb
View File

@ -522,8 +522,9 @@ package body Sem_Dist is
Parameter := First (Parameter_Specifications (Type_Def));
while Present (Parameter) loop
if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
Error_Msg_N ("formal parameter& has anonymous access type?",
Defining_Identifier (Parameter));
Error_Msg_N
("formal parameter& has anonymous access type??",
Defining_Identifier (Parameter));
Is_Degenerate := True;
exit;
end if;
@ -533,7 +534,7 @@ package body Sem_Dist is
if Is_Degenerate then
Error_Msg_NE
("remote access-to-subprogram type& can only be null?",
("remote access-to-subprogram type& can only be null??",
Defining_Identifier (Parameter), User_Type);
-- The only legal value for a RAS with a formal parameter of an

60
gcc/ada/sem_elab.adb
View File

@ -908,8 +908,8 @@ package body Sem_Elab is
if Inst_Case then
Elab_Warning
("instantiation of& may raise Program_Error?",
"info: instantiation of& during elaboration?", Ent);
("instantiation of& may raise Program_Error?l?",
"info: instantiation of& during elaboration?l?", Ent);
-- Indirect call case, warning only in static elaboration
-- case, because the attribute reference itself cannot raise
@ -917,7 +917,7 @@ package body Sem_Elab is
elsif Access_Case then
Elab_Warning
("", "info: access to& during elaboration?", Ent);
("", "info: access to& during elaboration?l?", Ent);
-- Subprogram call case
@ -927,14 +927,14 @@ package body Sem_Elab is
and then Comes_From_Source (Ent)
then
Elab_Warning
("implicit call to & may raise Program_Error?",
"info: implicit call to & during elaboration?",
("implicit call to & may raise Program_Error?l?",
"info: implicit call to & during elaboration?l?",
Ent);
else
Elab_Warning
("call to & may raise Program_Error?",
"info: call to & during elaboration?",
("call to & may raise Program_Error?l?",
"info: call to & during elaboration?l?",
Ent);
end if;
end if;
@ -943,14 +943,14 @@ package body Sem_Elab is
if Nkind (N) in N_Subprogram_Instantiation then
Elab_Warning
("\missing pragma Elaborate for&?",
"\info: implicit pragma Elaborate for& generated?",
("\missing pragma Elaborate for&?l?",
"\info: implicit pragma Elaborate for& generated?l?",
W_Scope);
else
Elab_Warning
("\missing pragma Elaborate_All for&?",
"\info: implicit pragma Elaborate_All for & generated?",
("\missing pragma Elaborate_All for&?l?",
"\info: implicit pragma Elaborate_All for & generated?l?",
W_Scope);
end if;
end Generate_Elab_Warnings;
@ -1030,7 +1030,7 @@ package body Sem_Elab is
Error_Msg_Node_2 := W_Scope;
Error_Msg_NE
("call to& in elaboration code " &
"requires pragma Elaborate_All on&?", N, E);
"requires pragma Elaborate_All on&??", N, E);
end if;
-- Set indication for binder to generate Elaborate_All
@ -1138,13 +1138,13 @@ package body Sem_Elab is
-- Here we definitely have a bad instantiation
Error_Msg_NE ("?cannot instantiate& before body seen", N, Ent);
Error_Msg_NE ("??cannot instantiate& before body seen", N, Ent);
if Present (Instance_Spec (N)) then
Supply_Bodies (Instance_Spec (N));
end if;
Error_Msg_N ("\?Program_Error will be raised at run time", N);
Error_Msg_N ("\??Program_Error will be raised at run time", N);
Insert_Elab_Check (N);
Set_ABE_Is_Certain (N);
end Check_Bad_Instantiation;
@ -1720,13 +1720,13 @@ package body Sem_Elab is
Error_Msg_Sloc := Sloc (Ent);
Error_Msg_NE
("?elaboration code may access& before it is initialized",
("??elaboration code may access& before it is initialized",
N, Ent);
Error_Msg_NE
("\?suggest adding pragma Elaborate_Body to spec of &",
("\??suggest adding pragma Elaborate_Body to spec of &",
N, Scop);
Error_Msg_N
("\?or an explicit initialization could be added #", N);
("\??or an explicit initialization could be added #", N);
end if;
if not All_Errors_Mode then
@ -2181,12 +2181,12 @@ package body Sem_Elab is
if Elab_Call.Last = 0 then
if Inst_Case then
Error_Msg_NE
("?cannot instantiate& before body seen", N, Orig_Ent);
("??cannot instantiate& before body seen", N, Orig_Ent);
else
Error_Msg_NE ("?cannot call& before body seen", N, Orig_Ent);
Error_Msg_NE ("??cannot call& before body seen", N, Orig_Ent);
end if;
Error_Msg_N ("\?Program_Error will be raised at run time", N);
Error_Msg_N ("\??Program_Error will be raised at run time", N);
Insert_Elab_Check (N);
-- Call is not at outer level
@ -2255,15 +2255,15 @@ package body Sem_Elab is
then
if Inst_Case then
Error_Msg_NE
("instantiation of& may occur before body is seen?",
("instantiation of& may occur before body is seen??",
N, Orig_Ent);
else
Error_Msg_NE
("call to& may occur before body is seen?", N, Orig_Ent);
("call to& may occur before body is seen??", N, Orig_Ent);
end if;
Error_Msg_N
("\Program_Error may be raised at run time?", N);
("\Program_Error may be raised at run time??", N);
Output_Calls (N);
end if;
@ -2359,10 +2359,10 @@ package body Sem_Elab is
Scope (Proc) = Scope (Defining_Identifier (Decl)))
then
Error_Msg_N
("task will be activated before elaboration of its body?",
("task will be activated before elaboration of its body??",
Decl);
Error_Msg_N
("\Program_Error will be raised at run time?", Decl);
("\Program_Error will be raised at run time??", Decl);
elsif
Present (Corresponding_Body (Unit_Declaration_Node (Proc)))
@ -2506,7 +2506,7 @@ package body Sem_Elab is
Error_Msg_Node_2 := Task_Scope;
Error_Msg_NE
("activation of an instance of task type&" &
" requires pragma Elaborate_All on &?", N, Ent);
" requires pragma Elaborate_All on &??", N, Ent);
end if;
Activate_Elaborate_All_Desirable (N, Task_Scope);
@ -3082,16 +3082,16 @@ package body Sem_Elab is
Ent := Elab_Call.Table (J).Ent;
if Is_Generic_Unit (Ent) then
Error_Msg_NE ("\?& instantiated #", N, Ent);
Error_Msg_NE ("\??& instantiated #", N, Ent);
elsif Is_Init_Proc (Ent) then
Error_Msg_N ("\?initialization procedure called #", N);
Error_Msg_N ("\??initialization procedure called #", N);
elsif Is_Printable_Error_Name (Chars (Ent)) then
Error_Msg_NE ("\?& called #", N, Ent);
Error_Msg_NE ("\??& called #", N, Ent);
else
Error_Msg_N ("\? called #", N);
Error_Msg_N ("\?? called #", N);
end if;
end loop;
end Output_Calls;

20
gcc/ada/sem_eval.adb
View File

@ -293,7 +293,7 @@ package body Sem_Eval is
and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
then
Error_Msg_N
("?float value out of range, infinity will be generated", N);
("??float value out of range, infinity will be generated", N);
end if;
return;
@ -369,7 +369,7 @@ package body Sem_Eval is
Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
then
Apply_Compile_Time_Constraint_Error
(N, "non-static universal integer value out of range?",
(N, "non-static universal integer value out of range??",
CE_Range_Check_Failed);
-- Check out of range of base type
@ -390,7 +390,7 @@ package body Sem_Eval is
elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then
Apply_Compile_Time_Constraint_Error
(N, "value not in range of}?", CE_Range_Check_Failed);
(N, "value not in range of}??", CE_Range_Check_Failed);
elsif Checks_On then
Enable_Range_Check (N);
@ -407,14 +407,12 @@ package body Sem_Eval is
procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
begin
if not Raises_Constraint_Error (N)
and then Is_Constrained (Ttype)
then
if not Raises_Constraint_Error (N) and then Is_Constrained (Ttype) then
if
UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
then
Apply_Compile_Time_Constraint_Error
(N, "string length wrong for}?",
(N, "string length wrong for}??",
CE_Length_Check_Failed,
Ent => Ttype,
Typ => Ttype);
@ -1655,7 +1653,7 @@ package body Sem_Eval is
begin
if Result < Lo or else Result > Hi then
Apply_Compile_Time_Constraint_Error
(N, "value not in range of }?",
(N, "value not in range of }??",
CE_Overflow_Check_Failed,
Ent => BT);
return;
@ -3316,10 +3314,10 @@ package body Sem_Eval is
= Entity (Drange)
then
if Warn_On_Redundant_Constructs then
Error_Msg_N ("redundant slice denotes whole array?", N);
Error_Msg_N ("redundant slice denotes whole array?r?", N);
end if;
-- The following might be a useful optimization????
-- The following might be a useful optimization???
-- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
end if;
@ -4656,7 +4654,7 @@ package body Sem_Eval is
else
Apply_Compile_Time_Constraint_Error
(N, "value not in range of}?", CE_Range_Check_Failed);
(N, "value not in range of}??", CE_Range_Check_Failed);
end if;
end Out_Of_Range;

2
gcc/ada/sem_intr.adb
View File

@ -163,7 +163,7 @@ package body Sem_Intr is
and then Can_Never_Be_Null (Etype (Arg1))
then
Error_Msg_N
("freeing `NOT NULL` object will raise Constraint_Error?", N);
("freeing `NOT NULL` object will raise Constraint_Error??", N);
-- For unchecked deallocation, error to deallocate from empty pool.
-- Note: this test used to be in Exp_Intr as a warning, but AI 157

2
gcc/ada/sem_mech.adb
View File

@ -245,7 +245,7 @@ package body Sem_Mech is
if Mech in Descriptor_Codes and then not Is_Formal (Ent) then
if Is_Record_Type (Etype (Ent)) then
Error_Msg_N ("?records cannot be returned by Descriptor", Enod);
Error_Msg_N ("??records cannot be returned by Descriptor", Enod);
return;
end if;
end if;

88
gcc/ada/sem_prag.adb
View File

@ -980,7 +980,7 @@ package body Sem_Prag is
procedure Check_Ada_83_Warning is
begin
if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_N ("(Ada 83) pragma& is non-standard?", N);
Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
end if;
end Check_Ada_83_Warning;
@ -1853,7 +1853,7 @@ package body Sem_Prag is
then
Error_Msg_Name_1 := Pname;
Error_Msg_N
("?pragma% is only effective in main program", N);
("??pragma% is only effective in main program", N);
end if;
end Check_In_Main_Program;
@ -3551,7 +3551,7 @@ package body Sem_Prag is
else
if Warn_On_Export_Import and not OpenVMS_On_Target then
Error_Msg_N
("?unrecognized convention name, C assumed",
("??unrecognized convention name, C assumed",
Get_Pragma_Arg (Arg1));
end if;
@ -3860,7 +3860,7 @@ package body Sem_Prag is
begin
if not OpenVMS_On_Target then
Error_Pragma
("?pragma% ignored (applies only to Open'V'M'S)");
("??pragma% ignored (applies only to Open'V'M'S)");
end if;
Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
@ -3996,7 +3996,7 @@ package body Sem_Prag is
end if;
if Warn_On_Export_Import and then Is_Exported (Def_Id) then
Error_Msg_N ("?duplicate Export_Object pragma", N);
Error_Msg_N ("??duplicate Export_Object pragma", N);
else
Set_Exported (Def_Id, Arg_Internal);
end if;
@ -4019,21 +4019,20 @@ package body Sem_Prag is
and then Has_Discriminants (Etype (Def_Id))
then
Error_Msg_N
("imported value must be initialized?", Arg_Internal);
("imported value must be initialized??", Arg_Internal);
end if;
if Warn_On_Export_Import
and then Is_Access_Type (Etype (Def_Id))
then
Error_Pragma_Arg
("cannot import object of an access type?", Arg_Internal);
("cannot import object of an access type??", Arg_Internal);
end if;
if Warn_On_Export_Import
and then Is_Imported (Def_Id)
then
Error_Msg_N
("?duplicate Import_Object pragma", N);
Error_Msg_N ("??duplicate Import_Object pragma", N);
-- Check for explicit initialization present. Note that an
-- initialization generated by the code generator, e.g. for an
@ -4957,7 +4956,7 @@ package body Sem_Prag is
if Front_End_Inlining
and then Analyzed (Corresponding_Body (Decl))
then
Error_Msg_N ("pragma appears too late, ignored?", N);
Error_Msg_N ("pragma appears too late, ignored??", N);
return True;
-- If the subprogram is a renaming as body, the body is just a
@ -5209,10 +5208,12 @@ package body Sem_Prag is
then
if Inlining_Not_Possible (Subp) then
Error_Msg_NE
("pragma Inline for& is ignored?", N, Entity (Subp_Id));
("pragma Inline for& is ignored?r?",
N, Entity (Subp_Id));
else
Error_Msg_NE
("pragma Inline for& is redundant?", N, Entity (Subp_Id));
("pragma Inline for& is redundant?r?",
N, Entity (Subp_Id));
end if;
end if;
@ -5284,7 +5285,7 @@ package body Sem_Prag is
Get_Character (C) = '/'))
then
Error_Msg
("?interface name contains illegal character",
("??interface name contains illegal character",
Sloc (SN) + Source_Ptr (J));
end if;
end loop;
@ -5704,7 +5705,7 @@ package body Sem_Prag is
if not UI_Is_In_Int_Range (Val) then
Error_Pragma_Arg
("pragma ignored, value too large?", Arg);
("pragma ignored, value too large??", Arg);
end if;
-- Warning case. If the real restriction is active, then we
@ -5981,20 +5982,23 @@ package body Sem_Prag is
and then Comes_From_Source (Arg)
then
Error_Msg_NE
("?& has been made static as a result of Export", Arg, E);
("?x?& has been made static as a result of Export",
Arg, E);
Error_Msg_N
("\this usage is non-standard and non-portable", Arg);
("\?x?this usage is non-standard and non-portable",
Arg);
end if;
end if;
end if;
if Warn_On_Export_Import and then Is_Type (E) then
Error_Msg_NE ("exporting a type has no effect?", Arg, E);
Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
end if;
if Warn_On_Export_Import and Inside_A_Generic then
Error_Msg_NE
("all instances of& will have the same external name?", Arg, E);
("all instances of& will have the same external name?x?",
Arg, E);
end if;
end Set_Exported;
@ -6562,13 +6566,13 @@ package body Sem_Prag is
if not Is_Pragma_Name (Pname) then
if Warn_On_Unrecognized_Pragma then
Error_Msg_Name_1 := Pname;
Error_Msg_N ("?unrecognized pragma%!", Pragma_Identifier (N));
Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
for PN in First_Pragma_Name .. Last_Pragma_Name loop
if Is_Bad_Spelling_Of (Pname, PN) then
Error_Msg_Name_1 := PN;
Error_Msg_N -- CODEFIX
("\?possible misspelling of %!", Pragma_Identifier (N));
("\?g?possible misspelling of %!", Pragma_Identifier (N));
exit;
end if;
end loop;
@ -8119,7 +8123,7 @@ package body Sem_Prag is
-- Following message is obsolete ???
Error_Msg_N
("'G'N'A'T pragma cpp'_class is now obsolete and has no " &
"effect; replace it by pragma import?", N);
"effect; replace it by pragma import?j?", N);
end if;
Check_Arg_Count (1);
@ -8171,7 +8175,7 @@ package body Sem_Prag is
if Is_Constructor (Def_Id) then
Error_Msg_N
("?duplicate argument for pragma 'C'P'P_Constructor", Arg1);
("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
return;
end if;
@ -8245,7 +8249,7 @@ package body Sem_Prag is
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("'G'N'A'T pragma cpp'_virtual is now obsolete and has " &
"no effect?", N);
"no effect?j?", N);
end if;
end CPP_Virtual;
@ -8260,7 +8264,7 @@ package body Sem_Prag is
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("'G'N'A'T pragma cpp'_vtable is now obsolete and has " &
"no effect?", N);
"no effect?j?", N);
end if;
end CPP_Vtable;
@ -8745,9 +8749,9 @@ package body Sem_Prag is
if Elab_Warnings and not Dynamic_Elaboration_Checks then
Error_Msg_N
("?use of pragma Elaborate may not be safe", N);
("?l?use of pragma Elaborate may not be safe", N);
Error_Msg_N
("?use pragma Elaborate_All instead if possible", N);
("?l?use pragma Elaborate_All instead if possible", N);
end if;
end Elaborate;
@ -9586,7 +9590,7 @@ package body Sem_Prag is
if not OpenVMS_On_Target then
if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
Error_Pragma
("?pragma% ignored (applies only to Open'V'M'S)");
("??pragma% ignored (applies only to Open'V'M'S)");
end if;
return;
@ -11564,7 +11568,7 @@ package body Sem_Prag is
Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
if not OpenVMS_On_Target then
Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)");
Error_Pragma ("??pragma% ignored (applies only to Open'V'M'S)");
end if;
-- D_Float case
@ -12468,7 +12472,7 @@ package body Sem_Prag is
elsif VM_Target /= No_VM then
if not GNAT_Mode then
Error_Pragma
("?pragma% ignored in this configuration");
("??pragma% ignored in this configuration");
end if;
-- Normal case where we do the pack action
@ -12494,7 +12498,7 @@ package body Sem_Prag is
if VM_Target /= No_VM then
if not GNAT_Mode then
Error_Pragma
("?pragma% ignored in this configuration");
("??pragma% ignored in this configuration");
end if;
-- Normal case of pack request active
@ -12639,7 +12643,7 @@ package body Sem_Prag is
if Has_Pragma_Preelab_Init (Ent)
and then Warn_On_Redundant_Constructs
then
Error_Pragma ("?duplicate pragma%!");
Error_Pragma ("?r?duplicate pragma%!");
else
Set_Has_Pragma_Preelab_Init (Ent);
end if;
@ -13314,7 +13318,7 @@ package body Sem_Prag is
or else
Has_Rep_Pragma (Def_Id, Name_Psect_Object)
then
Error_Msg_N ("?duplicate Common/Psect_Object pragma", N);
Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
end if;
if Ekind (Def_Id) = E_Constant then
@ -13338,7 +13342,7 @@ package body Sem_Prag is
and then Warn_On_Export_Import
then
Error_Msg_N
("?object for pragma % has defaults", Internal);
("?x?object for pragma % has defaults", Internal);
exit;
else
@ -13522,7 +13526,7 @@ package body Sem_Prag is
and then Warn_On_Redundant_Constructs
then
Error_Msg_NE
("pragma Pure_Function on& is redundant?",
("pragma Pure_Function on& is redundant?r?",
N, Entity (E_Id));
end if;
end if;
@ -13728,8 +13732,10 @@ package body Sem_Prag is
Set_Ravenscar_Profile (N);
if Warn_On_Obsolescent_Feature then
Error_Msg_N ("pragma Ravenscar is an obsolescent feature?", N);
Error_Msg_N ("|use pragma Profile (Ravenscar) instead", N);
Error_Msg_N
("pragma Ravenscar is an obsolescent feature?j?", N);
Error_Msg_N
("|use pragma Profile (Ravenscar) instead?j?", N);
end if;
-------------------------
@ -13747,8 +13753,10 @@ package body Sem_Prag is
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("pragma Restricted_Run_Time is an obsolescent feature?", N);
Error_Msg_N ("|use pragma Profile (Restricted) instead", N);
("pragma Restricted_Run_Time is an obsolescent feature?j?",
N);
Error_Msg_N
("|use pragma Profile (Restricted) instead?j?", N);
end if;
------------------
@ -14939,7 +14947,7 @@ package body Sem_Prag is
end if;
if not AAMP_On_Target then
Error_Pragma ("?pragma% ignored (applies only to AAMP)");
Error_Pragma ("??pragma% ignored (applies only to AAMP)");
end if;
----------------
@ -15432,7 +15440,7 @@ package body Sem_Prag is
if Err then
Error_Msg
("?pragma Warnings On with no " &
("??pragma Warnings On with no " &
"matching Warnings Off",
Loc);
end if;

134
gcc/ada/sem_res.adb
View File

@ -577,7 +577,7 @@ package body Sem_Res is
-- Warn about the danger
Error_Msg_N
("?creation of & object may raise Storage_Error!",
("??creation of & object may raise Storage_Error!",
Scope (Disc));
<<No_Danger>>
@ -769,8 +769,8 @@ package body Sem_Res is
and then Nkind (Parent (P)) = N_Subprogram_Body
and then Is_Empty_List (Declarations (Parent (P)))
then
Error_Msg_N ("!?infinite recursion", N);
Error_Msg_N ("\!?Storage_Error will be raised at run time", N);
Error_Msg_N ("!??infinite recursion", N);
Error_Msg_N ("\!??Storage_Error will be raised at run time", N);
Insert_Action (N,
Make_Raise_Storage_Error (Sloc (N),
Reason => SE_Infinite_Recursion));
@ -867,8 +867,8 @@ package body Sem_Res is
end if;
end loop;
Error_Msg_N ("!?possible infinite recursion", N);
Error_Msg_N ("\!?Storage_Error may be raised at run time", N);
Error_Msg_N ("!??possible infinite recursion", N);
Error_Msg_N ("\!??Storage_Error may be raised at run time", N);
return True;
end Check_Infinite_Recursion;
@ -3963,14 +3963,14 @@ package body Sem_Res is
if Is_Controlling_Formal (F) then
Apply_Compile_Time_Constraint_Error
(N => A,
Msg => "null value not allowed here?",
Msg => "null value not allowed here??",
Reason => CE_Access_Check_Failed);
elsif Ada_Version >= Ada_2005 then
Apply_Compile_Time_Constraint_Error
(N => A,
Msg => "(Ada 2005) null not allowed in "
& "null-excluding formal?",
& "null-excluding formal??",
Reason => CE_Null_Not_Allowed);
end if;
end if;
@ -4448,9 +4448,9 @@ package body Sem_Res is
Deepest_Type_Access_Level (Typ)
then
if In_Instance_Body then
Error_Msg_N ("?type in allocator has deeper level than" &
Error_Msg_N ("??type in allocator has deeper level than" &
" designated class-wide type", E);
Error_Msg_N ("\?Program_Error will be raised at run time",
Error_Msg_N ("\??Program_Error will be raised at run time",
E);
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
@ -4556,8 +4556,8 @@ package body Sem_Res is
and then Ekind (Current_Scope) = E_Package
and then not In_Package_Body (Current_Scope)
then
Error_Msg_N ("?cannot activate task before body seen", N);
Error_Msg_N ("\?Program_Error will be raised at run time", N);
Error_Msg_N ("??cannot activate task before body seen", N);
Error_Msg_N ("\??Program_Error will be raised at run time", N);
end if;
-- Ada 2012 (AI05-0111-3): Detect an attempt to allocate a task or a
@ -4569,8 +4569,8 @@ package body Sem_Res is
and then Present (Subpool_Handle_Name (N))
and then Has_Task (Desig_T)
then
Error_Msg_N ("?cannot allocate task on subpool", N);
Error_Msg_N ("\?Program_Error will be raised at run time", N);
Error_Msg_N ("??cannot allocate task on subpool", N);
Error_Msg_N ("\??Program_Error will be raised at run time", N);
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
@ -5026,24 +5026,24 @@ package body Sem_Res is
then
Error_Msg_N
("float division by zero, " &
"may generate '+'/'- infinity?", Right_Opnd (N));
"may generate '+'/'- infinity??", Right_Opnd (N));
-- For all other cases, we get a Constraint_Error
else
Apply_Compile_Time_Constraint_Error
(N, "division by zero?", CE_Divide_By_Zero,
(N, "division by zero??", CE_Divide_By_Zero,
Loc => Sloc (Right_Opnd (N)));
end if;
when N_Op_Rem =>
Apply_Compile_Time_Constraint_Error
(N, "rem with zero divisor?", CE_Divide_By_Zero,
(N, "rem with zero divisor??", CE_Divide_By_Zero,
Loc => Sloc (Right_Opnd (N)));
when N_Op_Mod =>
Apply_Compile_Time_Constraint_Error
(N, "mod with zero divisor?", CE_Divide_By_Zero,
(N, "mod with zero divisor??", CE_Divide_By_Zero,
Loc => Sloc (Right_Opnd (N)));
-- Division by zero can only happen with division, rem,
@ -5285,10 +5285,10 @@ package body Sem_Res is
then
Rtype := Etype (N);
Error_Msg_NE
("?& should not be used in entry body (RM C.7(17))",
("??& should not be used in entry body (RM C.7(17))",
N, Nam);
Error_Msg_NE
("\Program_Error will be raised at run time?", N, Nam);
("\Program_Error will be raised at run time??", N, Nam);
Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Current_Task_In_Entry_Body));
@ -5578,9 +5578,9 @@ package body Sem_Res is
Set_Has_Recursive_Call (Nam);
Error_Msg_N
("?possible infinite recursion!", N);
("??possible infinite recursion!", N);
Error_Msg_N
("\?Storage_Error may be raised at run time!", N);
("\??Storage_Error may be raised at run time!", N);
end if;
exit Scope_Loop;
@ -5898,8 +5898,8 @@ package body Sem_Res is
end loop;
if not Call_OK then
Error_Msg_N ("!? cannot determine tag of result", N);
Error_Msg_N ("!? Program_Error will be raised", N);
Error_Msg_N ("!?? cannot determine tag of result", N);
Error_Msg_N ("!?? Program_Error will be raised", N);
Insert_Action (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Explicit_Raise));
@ -6100,7 +6100,7 @@ package body Sem_Res is
-- Check comparison on unordered enumeration
if Bad_Unordered_Enumeration_Reference (N, Etype (L)) then
Error_Msg_N ("comparison on unordered enumeration type?", N);
Error_Msg_N ("comparison on unordered enumeration type?U?", N);
end if;
-- Evaluate the relation (note we do this after the above check since
@ -6939,7 +6939,7 @@ package body Sem_Res is
and then Comes_From_Source (R)
then
Error_Msg_N -- CODEFIX
("?comparison with True is redundant!", R);
("?r?comparison with True is redundant!", R);
end if;
Check_Unset_Reference (L);
@ -7322,9 +7322,9 @@ package body Sem_Res is
and then Is_Bit_Packed_Array (Array_Type)
and then Is_LHS (N)
then
Error_Msg_N ("?assignment to component of packed atomic array",
Error_Msg_N ("??assignment to component of packed atomic array",
Prefix (N));
Error_Msg_N ("?\may cause unexpected accesses to atomic object",
Error_Msg_N ("??\may cause unexpected accesses to atomic object",
Prefix (N));
end if;
end Resolve_Indexed_Component;
@ -7700,7 +7700,7 @@ package body Sem_Res is
while Present (Alt) loop
if Is_Static_Expression (Alt)
and then (Nkind_In (Alt, N_Integer_Literal,
N_Character_Literal)
N_Character_Literal)
or else Nkind (Alt) in N_Has_Entity)
then
Nalts := Nalts + 1;
@ -7709,7 +7709,7 @@ package body Sem_Res is
for J in 1 .. Nalts - 1 loop
if Alts (J).Val = Alts (Nalts).Val then
Error_Msg_Sloc := Sloc (Alts (J).Alt);
Error_Msg_N ("duplicate of value given#?", Alt);
Error_Msg_N ("duplicate of value given#??", Alt);
end if;
end loop;
end if;
@ -7838,7 +7838,7 @@ package body Sem_Res is
if not Inside_Init_Proc then
Insert_Action
(Compile_Time_Constraint_Error (N,
"(Ada 2005) null not allowed in null-excluding objects?"),
"(Ada 2005) null not allowed in null-excluding objects??"),
Make_Raise_Constraint_Error (Loc,
Reason => CE_Access_Check_Failed));
else
@ -8308,7 +8308,7 @@ package body Sem_Res is
and then not Is_Boolean_Type (Typ)
and then Parent_Is_Boolean
then
Error_Msg_N ("?not expression should be parenthesized here!", N);
Error_Msg_N ("?q?not expression should be parenthesized here!", N);
end if;
-- Warn on double negation if checking redundant constructs
@ -8319,7 +8319,7 @@ package body Sem_Res is
and then Root_Type (Typ) = Standard_Boolean
and then Nkind (Right_Opnd (N)) = N_Op_Not
then
Error_Msg_N ("redundant double negation?", N);
Error_Msg_N ("redundant double negation?r?", N);
end if;
-- Complete resolution and evaluation of NOT
@ -8459,7 +8459,7 @@ package body Sem_Res is
and then not First_Last_Ref
then
Error_Msg ("subrange of unordered enumeration type?", Sloc (N));
Error_Msg ("subrange of unordered enumeration type?U?", Sloc (N));
end if;
Check_Unset_Reference (L);
@ -8546,7 +8546,7 @@ package body Sem_Res is
and then Warn_On_Bad_Fixed_Value
then
Error_Msg_N
("?static fixed-point value is not a multiple of Small!",
("?b?static fixed-point value is not a multiple of Small!",
N);
end if;
@ -8796,9 +8796,9 @@ package body Sem_Res is
and then Is_LHS (N)
then
Error_Msg_N
("?assignment to component of packed atomic record", Prefix (N));
("??assignment to component of packed atomic record", Prefix (N));
Error_Msg_N
("?\may cause unexpected accesses to atomic object", Prefix (N));
("\??may cause unexpected accesses to atomic object", Prefix (N));
end if;
Analyze_Dimension (N);
@ -8891,7 +8891,7 @@ package body Sem_Res is
-- of the First_Node call here.
Error_Msg_F
("?assertion would fail at run time!",
("??assertion would fail at run time!",
Expression
(First (Pragma_Argument_Associations (Orig))));
end if;
@ -8906,10 +8906,9 @@ package body Sem_Res is
declare
Expr : constant Node_Id :=
Original_Node
(Expression
(Next (First
(Pragma_Argument_Associations (Orig)))));
Original_Node
(Expression
(Next (First (Pragma_Argument_Associations (Orig)))));
begin
if Is_Entity_Name (Expr)
and then Entity (Expr) = Standard_False
@ -8923,7 +8922,7 @@ package body Sem_Res is
-- comment above for an explanation of why we do this.
Error_Msg_F
("?check would fail at run time!",
("??check would fail at run time!",
Expression
(Last (Pragma_Argument_Associations (Orig))));
end if;
@ -9329,7 +9328,8 @@ package body Sem_Res is
or else Char_Val > Expr_Value (Comp_Typ_Hi)
then
Apply_Compile_Time_Constraint_Error
(N, "character out of range?", CE_Range_Check_Failed,
(N, "character out of range??",
CE_Range_Check_Failed,
Loc => Source_Ptr (Int (Loc) + J));
end if;
end loop;
@ -9474,11 +9474,10 @@ package body Sem_Res is
and then abs (Realval (Rop)) < Delta_Value (Standard_Duration)
then
Error_Msg_N
("?universal real operand can only " &
"be interpreted as Duration!",
Rop);
("??universal real operand can only " &
"be interpreted as Duration!", Rop);
Error_Msg_N
("\?precision will be lost in the conversion!", Rop);
("\??precision will be lost in the conversion!", Rop);
end if;
elsif Is_Numeric_Type (Typ)
@ -9654,15 +9653,17 @@ package body Sem_Res is
-- entity, give the name of the entity in the message. If not,
-- just mention the expression.
-- Shoudn't we test Warn_On_Redundant_Constructs here ???
else
if Is_Entity_Name (Orig_N) then
Error_Msg_Node_2 := Orig_T;
Error_Msg_NE -- CODEFIX
("?redundant conversion, & is of type &!",
("??redundant conversion, & is of type &!",
N, Entity (Orig_N));
else
Error_Msg_NE
("?redundant conversion, expression is of type&!",
("??redundant conversion, expression is of type&!",
N, Orig_T);
end if;
end if;
@ -9830,7 +9831,7 @@ package body Sem_Res is
if OK and then Hi >= Lo and then Lo >= 0 then
Error_Msg_N -- CODEFIX
("?abs applied to known non-negative value has no effect", N);
("?r?abs applied to known non-negative value has no effect", N);
end if;
end if;
@ -9968,8 +9969,10 @@ package body Sem_Res is
-- If we fall through warning should be issued
-- Shouldn't we test Warn_On_Questionable_Missing_Parens ???
Error_Msg_N
("?unary minus expression should be parenthesized here!", N);
("??unary minus expression should be parenthesized here!", N);
end if;
end if;
end;
@ -10443,9 +10446,11 @@ package body Sem_Res is
end loop;
if Nkind (N) = N_Real_Literal then
Error_Msg_NE ("?real literal interpreted as }!", N, T1);
Error_Msg_NE
("??real literal interpreted as }!", N, T1);
else
Error_Msg_NE ("?universal_fixed expression interpreted as }!", N, T1);
Error_Msg_NE
("??universal_fixed expression interpreted as }!", N, T1);
end if;
return T1;
@ -10628,10 +10633,10 @@ package body Sem_Res is
then
if In_Instance_Body then
Error_Msg_N
("?source array type has " &
("??source array type has " &
"deeper accessibility level than target", Operand);
Error_Msg_N
("\?Program_Error will be raised at run time",
("\??Program_Error will be raised at run time",
Operand);
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
@ -10915,10 +10920,10 @@ package body Sem_Res is
if In_Instance_Body then
Error_Msg_N
("?cannot convert local pointer to non-local access type",
("??cannot convert local pointer to non-local access type",
Operand);
Error_Msg_N
("\?Program_Error will be raised at run time", Operand);
("\??Program_Error will be raised at run time", Operand);
else
Error_Msg_N
@ -10948,10 +10953,11 @@ package body Sem_Res is
if In_Instance_Body then
Error_Msg_N
("?cannot convert access discriminant to non-local" &
("??cannot convert access discriminant to non-local" &
" access type", Operand);
Error_Msg_N
("\?Program_Error will be raised at run time", Operand);
("\??Program_Error will be raised at run time",
Operand);
else
Error_Msg_N
("cannot convert access discriminant to non-local" &
@ -11092,10 +11098,10 @@ package body Sem_Res is
if In_Instance_Body then
Error_Msg_N
("?cannot convert local pointer to non-local access type",
("??cannot convert local pointer to non-local access type",
Operand);
Error_Msg_N
("\?Program_Error will be raised at run time", Operand);
("\??Program_Error will be raised at run time", Operand);
else
-- Avoid generation of spurious error message
@ -11130,10 +11136,10 @@ package body Sem_Res is
if In_Instance_Body then
Error_Msg_N
("?cannot convert access discriminant to non-local" &
" access type", Operand);
("??cannot convert access discriminant to non-local"
& " access type", Operand);
Error_Msg_N
("\?Program_Error will be raised at run time",
("\??Program_Error will be raised at run time",
Operand);
else

44
gcc/ada/sem_util.adb
View File

@ -444,8 +444,8 @@ package body Sem_Util is
begin
if Has_Predicates (Typ) then
if Is_Generic_Actual_Type (Typ) then
Error_Msg_FE (Msg & '?', N, Typ);
Error_Msg_F ("\Program_Error will be raised at run time?", N);
Error_Msg_FE (Msg & "??", N, Typ);
Error_Msg_F ("\Program_Error will be raised at run time??", N);
Insert_Action (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Bad_Predicated_Generic_Type));
@ -1576,7 +1576,7 @@ package body Sem_Util is
then
Error_Msg_N
("result may differ if evaluated "
& "after other actual in expression?", Act1);
& "after other actual in expression??", Act1);
end if;
end if;
end loop;
@ -1610,7 +1610,7 @@ package body Sem_Util is
while Present (S) and then S /= Standard_Standard loop
if Is_Protected_Type (S) then
Error_Msg_N
("potentially blocking operation in protected operation?", N);
("potentially blocking operation in protected operation??", N);
return;
end if;
@ -1724,7 +1724,7 @@ package body Sem_Util is
Object_Access_Level (Context)
then
Error_Msg_N
("?possible unprotected access to protected data", Expr);
("??possible unprotected access to protected data", Expr);
end if;
end if;
end Check_Unprotected_Access;
@ -2249,8 +2249,8 @@ package body Sem_Util is
Loc : Source_Ptr := No_Location;
Warn : Boolean := False) return Node_Id
is
Msgc : String (1 .. Msg'Length + 2);
-- Copy of message, with room for possible ? and ! at end
Msgc : String (1 .. Msg'Length + 3);
-- Copy of message, with room for possible ?? and ! at end
Msgl : Natural;
Wmsg : Boolean;
@ -2289,11 +2289,15 @@ package body Sem_Util is
elsif Warn
or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
then
Msgl := Msgl + 1;
Msgc (Msgl) := '?';
Msgl := Msgl + 1;
Msgc (Msgl) := '?';
Wmsg := True;
elsif In_Instance_Not_Visible then
Msgl := Msgl + 1;
Msgc (Msgl) := '?';
Msgl := Msgl + 1;
Msgc (Msgl) := '?';
Wmsg := True;
@ -2413,19 +2417,19 @@ package body Sem_Util is
and then not Comes_From_Source (Conc_Typ)
then
Error_Msg_NEL
("\?& will be raised at run time",
("\??& will be raised at run time",
N, Standard_Constraint_Error, Eloc);
else
Error_Msg_NEL
("\?& will be raised for objects of this type",
("\??& will be raised for objects of this type",
N, Standard_Constraint_Error, Eloc);
end if;
end;
else
Error_Msg_NEL
("\?& will be raised at run time",
("\??& will be raised at run time",
N, Standard_Constraint_Error, Eloc);
end if;
@ -3863,7 +3867,7 @@ package body Sem_Util is
Is_Potentially_Use_Visible (C))
then
Error_Msg_Sloc := Sloc (C);
Error_Msg_N ("declaration hides &#?", Def_Id);
Error_Msg_N ("declaration hides &#?h?", Def_Id);
end if;
end Enter_Name;
@ -11258,7 +11262,8 @@ package body Sem_Util is
-- sure this is a modification.
if Has_Pragma_Unmodified (Ent) and then Sure then
Error_Msg_NE ("?pragma Unmodified given for &!", N, Ent);
Error_Msg_NE
("??pragma Unmodified given for &!", N, Ent);
end if;
Set_Never_Set_In_Source (Ent, False);
@ -11348,8 +11353,8 @@ package body Sem_Util is
then
Error_Msg_Sloc := Sloc (A);
Error_Msg_NE
("constant& may be modified via address clause#?",
N, Entity (Prefix (Exp)));
("constant& may be modified via address "
& "clause#??", N, Entity (Prefix (Exp)));
end if;
end;
end if;
@ -11600,16 +11605,15 @@ package body Sem_Util is
end Return_Master_Scope_Depth_Of_Call;
end if;
-- For convenience we handle qualified expressions, even though
-- they aren't technically object names.
-- For convenience we handle qualified expressions, even though they
-- aren't technically object names.
elsif Nkind (Obj) = N_Qualified_Expression then
return Object_Access_Level (Expression (Obj));
-- Otherwise return the scope level of Standard.
-- (If there are cases that fall through
-- to this point they will be treated as
-- having global accessibility for now. ???)
-- Otherwise return the scope level of Standard. (If there are cases
-- that fall through to this point they will be treated as having
-- global accessibility for now. ???)
else
return Scope_Depth (Standard_Standard);

29
gcc/ada/sem_warn.adb
View File

@ -200,7 +200,7 @@ package body Sem_Warn is
if No (Asm_Input_Value) then
Error_Msg_F
("?code statement with no inputs should usually be Volatile!", N);
("??code statement with no inputs should usually be Volatile!", N);
return;
end if;
@ -208,7 +208,7 @@ package body Sem_Warn is
if No (Asm_Output_Variable) then
Error_Msg_F
("?code statement with no outputs should usually be Volatile!", N);
("??code statement with no outputs should usually be Volatile!", N);
return;
end if;
end Check_Code_Statement;
@ -707,9 +707,9 @@ package body Sem_Warn is
if No_Ref_Found (Loop_Statement) = OK then
Error_Msg_NE
("?variable& is not modified in loop body!", Ref, Var);
("??variable& is not modified in loop body!", Ref, Var);
Error_Msg_N
("\?possible infinite loop!", Ref);
("\??possible infinite loop!", Ref);
end if;
end Check_Infinite_Loop_Warning;
@ -1057,7 +1057,7 @@ package body Sem_Warn is
-- the designated object).
if not Warnings_Off_E1 then
Error_Msg_NE ("?& may be null!", UR, E1);
Error_Msg_NE ("??& may be null!", UR, E1);
end if;
goto Continue;
@ -1083,7 +1083,7 @@ package body Sem_Warn is
and then not Is_Imported (E1)
then
Error_Msg_N
("?& is not modified, volatile has no effect!", E1);
("??& is not modified, volatile has no effect!", E1);
-- Another special case, Exception_Occurrence, this catches
-- the case of exception choice (and a bit more too, but not
@ -1105,7 +1105,7 @@ package body Sem_Warn is
then
if not Warnings_Off_E1 then
Error_Msg_N -- CODEFIX
("?& is not modified, "
("??& is not modified, "
& "could be declared constant!",
E1);
end if;
@ -1237,7 +1237,7 @@ package body Sem_Warn is
and then not Warnings_Off_E1
then
Output_Reference_Error
("?formal parameter& is read but "
("?v?formal parameter& is read but "
& "never assigned!");
end if;
@ -1245,7 +1245,7 @@ package body Sem_Warn is
and then not Warnings_Off_E1
then
Output_Reference_Error
("?formal parameter& is not referenced!");
("?v?formal parameter& is not referenced!");
end if;
end if;
@ -1257,14 +1257,14 @@ package body Sem_Warn is
and then not Warnings_Off_E1
then
Output_Reference_Error
("?variable& is read but never assigned!");
("?v?variable& is read but never assigned!");
end if;
elsif not Has_Unreferenced (E1)
and then not Warnings_Off_E1
then
Output_Reference_Error -- CODEFIX
("?variable& is never read and never assigned!");
("?v?variable& is never read and never assigned!");
end if;
-- Deal with special case where this variable is hidden
@ -1275,12 +1275,12 @@ package body Sem_Warn is
and then not Warnings_Off_E1
then
Error_Msg_N
("?for loop implicitly declares loop variable!",
("?v?for loop implicitly declares loop variable!",
Hiding_Loop_Variable (E1));
Error_Msg_Sloc := Sloc (E1);
Error_Msg_N
("\?declaration hides & declared#!",
("\?v?declaration hides & declared#!",
Hiding_Loop_Variable (E1));
end if;
end if;
@ -1321,7 +1321,8 @@ package body Sem_Warn is
then
if not Warnings_Off_E1 then
Error_Msg_NE
("?OUT parameter& not set before return", UR, E1);
("?v?OUT parameter& not set before return",
UR, E1);
end if;
-- If the unset reference is a selected component