-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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- --
-- note get reset by any Error_Msg call, so the caller is responsible
-- for resetting it.
+ Error_Msg_Warn : Boolean;
+ -- Used if current message contains a < insertion character to indicate
+ -- if the current message is a warning message.
+
Warn_On_Instance : Boolean := False;
-- Normally if a warning is generated in a generic template from the
-- analysis of the template, then the warning really belongs in the
with Snames; use Snames;
with Stand; use Stand;
with Style;
-with Uintp; use Uintp;
with Uname; use Uname;
with Unchecked_Conversion;
return;
end if;
- -- The idea at this stage is that we have two kinds of messages.
+ -- The idea at this stage is that we have two kinds of messages
- -- First, we have those that are to be placed as requested at
- -- Flag_Location. This includes messages that have nothing to
- -- do with generics, and also messages placed on generic templates
- -- that reflect an error in the template itself. For such messages
- -- we simply call Error_Msg_Internal to place the message in the
- -- requested location.
+ -- First, we have those messages that are to be placed as requested at
+ -- Flag_Location. This includes messages that have nothing to do with
+ -- generics, and also messages placed on generic templates that reflect
+ -- an error in the template itself. For such messages we simply call
+ -- Error_Msg_Internal to place the message in the requested location.
if Instantiation (Sindex) = No_Location then
Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False);
procedure Error_Msg_F (Msg : String; N : Node_Id) is
begin
- Error_Msg_NEL (Msg, N, N, First_Sloc (N));
+ Error_Msg_NEL (Msg, N, N, Sloc (First_Node (N)));
end Error_Msg_F;
------------------
procedure Remove_Warning_Messages (N : Node_Id) is
function Check_For_Warning (N : Node_Id) return Traverse_Result;
- -- This function checks one node for a possible warning message.
+ -- This function checks one node for a possible warning message
function Check_All_Warnings is new
Traverse_Func (Check_For_Warning);
when '?' =>
null; -- already dealt with
+ when '<' =>
+ null; -- already dealt with
+
when '|' =>
null; -- already dealt with
-- phase anyway. Messages starting with (style) are also treated as
-- warning messages.
+ -- Insertion character < (Less Than: conditional warning message)
+ -- The character < appearing anywhere in a message is used for a
+ -- conditional error message. If Error_Msg_Warn is True, then the
+ -- effect is the same as ? described above. If Error_Msg_Warn is
+ -- False, then there is no effect.
+
-- Insertion character A-Z (Upper case letter: Ada reserved word)
-- If two or more upper case letters appear in the message, they are
-- taken as an Ada reserved word, and are converted to the default
-- note get reset by any Error_Msg call, so the caller is responsible
-- for resetting it.
+ Error_Msg_Warn : Boolean renames Err_Vars.Error_Msg_Warn;
+ -- Used if current message contains a < insertion character to indicate
+ -- if the current message is a warning message.
+
-----------------------------------------------------
-- Format of Messages and Manual Quotation Control --
-----------------------------------------------------
function Get_Location (E : Error_Msg_Id) return Source_Ptr
renames Erroutc.Get_Location;
- -- Returns the flag location of the error message with the given id E.
+ -- Returns the flag location of the error message with the given id E
------------------------
-- List Pragmas Table --
-- of its descendent nodes. No effect if no such warnings.
procedure Remove_Warning_Messages (L : List_Id);
- -- Remove warnings on all elements of a list.
+ -- Remove warnings on all elements of a list
procedure Set_Ignore_Errors (To : Boolean);
-- Following a call to this procedure with To=True, all error calls are
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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- --
with Snames; use Snames;
with Targparm; use Targparm;
with Table;
-with Types; use Types;
with Uintp; use Uintp;
package body Erroutc is
then
Is_Warning_Msg := True;
+ elsif Msg (J) = '<'
+ and then (J = Msg'First or else Msg (J - 1) /= ''')
+ then
+ Is_Warning_Msg := Error_Msg_Warn;
+
elsif Msg (J) = '|'
and then (J = Msg'First or else Msg (J - 1) /= ''')
then
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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- --
-- reporting packages, including Errout and Prj.Err.
with Table;
-with Types; use Types;
+with Types; use Types;
package Erroutc is
-- Error_Msg routines.
function Get_Location (E : Error_Msg_Id) return Source_Ptr;
- -- Returns the flag location of the error message with the given id E.
+ -- Returns the flag location of the error message with the given id E
-----------------------------------
-- Error Message Data Structures --
-- Handle name insertion (% insertion character)
procedure Set_Msg_Insertion_Reserved_Name;
- -- Handle insertion of reserved word name (* insertion character).
+ -- Handle insertion of reserved word name (* insertion character)
procedure Set_Msg_Insertion_Reserved_Word
(Text : String;
-----------------------
procedure Error_Msg_AP (Msg : String);
- -- Output a message just after the previous token.
+ -- Output a message just after the previous token
procedure Output_Source_Line
(L : Physical_Line_Number;
return;
end if;
- -- Return without doing anything if message is killed and this
- -- is not the first error message. The philosophy is that if we
- -- get a weird error message and we already have had a message,
- -- then we hope the weird message is a junk cascaded message
+ -- Return without doing anything if message is killed and this is not
+ -- the first error message. The philosophy is that if we get a weird
+ -- error message and we already have had a message, then we hope the
+ -- weird message is a junk cascaded message
- -- Immediate return if warning message and warnings are suppressed
+ -- Immediate return if warning message and warnings are suppressed.
-- Note that style messages are not warnings for this purpose.
if Is_Warning_Msg and then Warnings_Suppressed (Sptr) then
and then Errors.Table (Prev_Msg).Sfile =
Errors.Table (Cur_Msg).Sfile
then
- -- Don't delete unconditional messages and at this stage,
- -- don't delete continuation lines (we attempted to delete
- -- those earlier if the parent message was deleted.
+ -- Don't delete unconditional messages and at this stage, don't
+ -- delete continuation lines (we attempted to delete those earlier
+ -- if the parent message was deleted.
if not Errors.Table (Cur_Msg).Uncond
and then not Continuation
then
- -- Don't delete if prev msg is warning and new msg is
- -- an error. This is because we don't want a real error
- -- masked by a warning. In all other cases (that is parse
- -- errors for the same line that are not unconditional)
- -- we do delete the message. This helps to avoid
- -- junk extra messages from cascaded parsing errors
+ -- Don't delete if prev msg is warning and new msg is an error.
+ -- This is because we don't want a real error masked by a warning.
+ -- In all other cases (that is parse errors for the same line that
+ -- are not unconditional) we do delete the message. This helps to
+ -- avoid junk extra messages from cascaded parsing errors
if not (Errors.Table (Prev_Msg).Warn
or
or
Errors.Table (Cur_Msg).Style)
then
- -- All tests passed, delete the message by simply
- -- returning without any further processing.
+ -- All tests passed, delete the message by simply returning
+ -- without any further processing.
if not Continuation then
Last_Killed := True;
Write_Eol;
end if;
-
end loop;
-- Then output errors, if any, for subsidiary units
Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;
Warnings_Detected := 0;
end if;
-
end Finalize;
----------------
-- an initial dummy entry covering all possible source locations.
Warnings.Init;
-
end Initialize;
------------------------
Set_Msg_Insertion_Name;
elsif C = '$' then
+
-- '$' is ignored
null;
Set_Msg_Insertion_File_Name;
elsif C = '}' then
+
-- '}' is ignored
null;
Set_Msg_Insertion_Reserved_Name;
elsif C = '&' then
+
-- '&' is ignored
null;
elsif C = '?' then
null;
+ elsif C = '<' then
+ null;
+
elsif C = '|' then
null;
with Prj.Err; use Prj.Err;
with Prj.Strt; use Prj.Strt;
with Prj.Tree; use Prj.Tree;
-with Scans; use Scans;
with Snames;
-with Types; use Types;
with Prj.Attr; use Prj.Attr;
with Prj.Attr.PM; use Prj.Attr.PM;
with Uintp; use Uintp;
end if;
Error_Msg_Name_1 := Token_Name;
-
- if Warning then
- Error_Msg ("?undefined attribute {", Token_Ptr);
-
- else
- Error_Msg ("undefined attribute {", Token_Ptr);
- end if;
+ Error_Msg_Warn := Warning;
+ Error_Msg ("<undefined attribute {", Token_Ptr);
end if;
-- Set, if appropriate the index case insensitivity flag
with Sinput.P;
with Snames; use Snames;
with Table; use Table;
-with Types; use Types;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Strings; use Ada.Strings;
with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.HTable;
package body Prj.Nmsc is
while Source_Id /= No_Other_Source loop
Source := In_Tree.Other_Sources.Table (Source_Id);
- Source_Id := Source.Next;
if Source.File_Name = File_Id then
Real_Location);
return;
end if;
+
+ Source_Id := Source.Next;
end loop;
if Current_Verbosity = High then
end if;
else
- -- Library_Symbol_File is defined. Check that the file exists.
+ -- Library_Symbol_File is defined. Check that the file exists
Data.Symbol_Data.Symbol_File := Lib_Symbol_File.Value;
then
Error_Msg_Name_1 := Lib_Ref_Symbol_File.Value;
- -- For controlled symbol policy, it is an error
- -- if the reference symbol file does not exist.
+ -- For controlled symbol policy, it is an error if the
+ -- reference symbol file does not exist. For other symbol
+ -- policies, this is just a warning
- if Data.Symbol_Data.Symbol_Policy = Controlled then
- Error_Msg
- (Project, In_Tree,
- "library reference symbol file { does not exist",
- Lib_Ref_Symbol_File.Location);
+ Error_Msg_Warn :=
+ Data.Symbol_Data.Symbol_Policy /= Controlled;
- else
- -- For other symbol policies, this is just a warning
-
- Error_Msg
- (Project, In_Tree,
- "?library reference symbol file { does not exist",
- Lib_Ref_Symbol_File.Location);
+ Error_Msg
+ (Project, In_Tree,
+ "<library reference symbol file { does not exist",
+ Lib_Ref_Symbol_File.Location);
- -- In addition, if symbol policy is Compliant, it is
- -- changed to Autonomous, because there is no reference
- -- to check against, and we don't want to fail in this
- -- case.
+ -- In addition in the non-controlled case, if symbol policy
+ -- is Compliant, it is changed to Autonomous, because there
+ -- is no reference to check against, and we don't want to
+ -- fail in this case.
+ if Data.Symbol_Data.Symbol_Policy /= Controlled then
if Data.Symbol_Data.Symbol_Policy = Compliant then
Data.Symbol_Data.Symbol_Policy := Autonomous;
end if;
end if;
end if;
-
end if;
end if;
end if;
if Msg (First) = '\' then
First := First + 1;
- -- Warniung character is always the first one in this package
+ -- Warniung character is always the first one in this package
+ -- this is an undoocumented kludge!!!
elsif Msg (First) = '?' then
First := First + 1;
Add ("Warning: ");
+
+ elsif Msg (First) = '<' then
+ First := First + 1;
+
+ if Err_Vars.Error_Msg_Warn then
+ Add ("Warning: ");
+ end if;
end if;
for Index in First .. Msg'Last loop
-- convention Stubbed.
procedure Supply_Bodies (L : List_Id);
- -- Calls Supply_Bodies for all elements of the given list L.
+ -- Calls Supply_Bodies for all elements of the given list L
function Within (E1, E2 : Entity_Id) return Boolean;
- -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or
- -- is one of its contained scopes, False otherwise.
+ -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one
+ -- of its contained scopes, False otherwise.
function Within_Elaborate_All (E : Entity_Id) return Boolean;
-- Before emitting a warning on a scope E for a missing elaborate_all,
- -- check whether E may be in the context of a directly visible unit
- -- U to which the pragma applies. This prevents spurious warnings when
- -- the called entity is renamed within U.
+ -- check whether E may be in the context of a directly visible unit U to
+ -- which the pragma applies. This prevents spurious warnings when the
+ -- called entity is renamed within U.
------------------
-- Check_A_Call --
then
return;
- -- Nothing to do if this is a call already rewritten for elab checking.
+ -- Nothing to do if this is a call already rewritten for elab checking
elsif Nkind (Parent (N)) = N_Conditional_Expression then
return;
and then In_Preelaborated_Unit
and then not In_Inlined_Body
then
- -- This is a warning in -gnatg mode allowing such calls to
- -- be used in the predefined library with appropriate care.
-
- if GNAT_Mode then
- Error_Msg_N
- ("?non-static call not allowed in preelaborated unit", N);
- else
- Error_Msg_N
- ("non-static call not allowed in preelaborated unit", N);
- end if;
+ -- This is a warning in GNAT mode allowing such calls to be
+ -- used in the predefined library with appropriate care.
+ Error_Msg_Warn := GNAT_Mode;
+ Error_Msg_N
+ ("<non-static call not allowed in preelaborated unit", N);
return;
end if;
- -- Second case, we are inside a subprogram or concurrent unit
- -- i.e, we are not in elaboration code.
+ -- Second case, we are inside a subprogram or concurrent unit, which
+ -- means we are not in elaboration code.
else
-- In this case, the issue is whether we are inside the
- -- declarative part of the unit in which we live, or inside
- -- its statements. In the latter case, there is no issue of
- -- ABE calls at this level (a call from outside to the unit
- -- in which we live might cause an ABE, but that will be
- -- detected when we analyze that outer level call, as it
- -- recurses into the called unit).
+ -- declarative part of the unit in which we live, or inside its
+ -- statements. In the latter case, there is no issue of ABE calls
+ -- at this level (a call from outside to the unit in which we live
+ -- might cause an ABE, but that will be detected when we analyze
+ -- that outer level call, as it recurses into the called unit).
- -- Climb up the tree, doing this test, and also testing
- -- for being inside a default expression, which, as
- -- discussed above, is not checked at this stage.
+ -- Climb up the tree, doing this test, and also testing for being
+ -- inside a default expression, which, as discussed above, is not
+ -- checked at this stage.
declare
P : Node_Id;
begin
P := N;
loop
- -- If we find a parentless subtree, it seems safe to
- -- assume that we are not in a declarative part and
- -- that no checking is required.
+ -- If we find a parentless subtree, it seems safe to assume
+ -- that we are not in a declarative part and that no
+ -- checking is required.
if No (P) then
return;
exit when Nkind (P) = N_Subunit;
- -- Filter out case of default expressions, where
- -- we do not do the check at this stage.
+ -- Filter out case of default expressions, where we do not
+ -- do the check at this stage.
if Nkind (P) = N_Parameter_Specification
or else
elsif Dynamic_Elaboration_Checks then
-- This is a rather new check, going into version
- -- 3.14a1 for the first time (V1.80 of this unit),
- -- so we provide a debug flag to enable it. That
- -- way we have an easy work around for regressions
- -- that are caused by this new check. This debug
- -- flag can be removed later.
+ -- 3.14a1 for the first time (V1.80 of this unit), so
+ -- we provide a debug flag to enable it. That way we
+ -- have an easy work around for regressions that are
+ -- caused by this new check. This debug flag can be
+ -- removed later.
if Debug_Flag_DD then
return;
return;
end if;
- -- Nothing to do if the instantiation is not in the main unit.
+ -- Nothing to do if the instantiation is not in the main unit
if not In_Extended_Main_Code_Unit (N) then
return;
else
Elmt := First_Elmt (Inter_Procs);
- -- No need for multiple entries of the same type.
+ -- No need for multiple entries of the same type
while Present (Elmt) loop
if Node (Elmt) = Proc then
begin
Enclosing := Outer_Unit (Current_Scope);
- -- Find all tasks declared in the current unit.
+ -- Find all tasks declared in the current unit
if Nkind (N) = N_Package_Body then
P := Unit_Declaration_Node (Corresponding_Spec (N));
projects / platform / upstream / linaro-gcc.git / commitdiff