diff options
author | Robert Dewar <dewar@adacore.com> | 2005-09-05 09:52:55 +0200 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2005-09-05 09:52:55 +0200 |
commit | 3711d64615812c04a47aecb0787136a57548f31b (patch) | |
tree | a2e43c3e03fc087f1f1ac33952d8eb14bc5d2009 | |
parent | 405e57adc0248985e4ef02e7b16a176c06a646e7 (diff) | |
download | gcc-3711d64615812c04a47aecb0787136a57548f31b.zip gcc-3711d64615812c04a47aecb0787136a57548f31b.tar.gz gcc-3711d64615812c04a47aecb0787136a57548f31b.tar.bz2 |
errout.ads, errout.adb (Fix Error_Msg_F): Fix implementation to meet spec.
2005-09-01 Robert Dewar <dewar@adacore.com>
* errout.ads, errout.adb (Fix Error_Msg_F): Fix implementation to meet
spec.
Implement new insertion char < (conditional warning)
* errutil.adb, erroutc.adb: Implement new insertion char <
(conditional warning).
* sem_elab.adb, prj-dect.adb, erroutc.ads, err_vars.ads
(Error_Msg_Warn): New variable for < insertion char.
* prj-nmsc.adb: Implement new errout insertion char < (conditional
warning).
(Check_For_Source): Change value of Source_Id only after the current
source has been dealt with.
From-SVN: r103859
-rw-r--r-- | gcc/ada/err_vars.ads | 6 | ||||
-rw-r--r-- | gcc/ada/errout.adb | 21 | ||||
-rw-r--r-- | gcc/ada/errout.ads | 14 | ||||
-rw-r--r-- | gcc/ada/erroutc.adb | 8 | ||||
-rw-r--r-- | gcc/ada/erroutc.ads | 8 | ||||
-rw-r--r-- | gcc/ada/errutil.adb | 42 | ||||
-rw-r--r-- | gcc/ada/prj-dect.adb | 11 | ||||
-rw-r--r-- | gcc/ada/prj-nmsc.adb | 50 | ||||
-rw-r--r-- | gcc/ada/sem_elab.adb | 76 |
9 files changed, 123 insertions, 113 deletions
diff --git a/gcc/ada/err_vars.ads b/gcc/ada/err_vars.ads index a74577b..04ef8b2 100644 --- a/gcc/ada/err_vars.ads +++ b/gcc/ada/err_vars.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -103,6 +103,10 @@ package Err_Vars is -- 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 diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 66b6c3b..5da299a 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -49,7 +49,6 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Style; -with Uintp; use Uintp; with Uname; use Uname; with Unchecked_Conversion; @@ -322,14 +321,13 @@ package body Errout is 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); @@ -606,7 +604,7 @@ package body Errout is 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; ------------------ @@ -1613,7 +1611,7 @@ package body Errout is 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); @@ -2253,6 +2251,9 @@ package body Errout is when '?' => null; -- already dealt with + when '<' => + null; -- already dealt with + when '|' => null; -- already dealt with diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index f0690d8..ff25468 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -243,6 +243,12 @@ package Errout is -- 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 @@ -358,6 +364,10 @@ package Errout is -- 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 -- ----------------------------------------------------- @@ -440,7 +450,7 @@ package Errout is 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 -- @@ -601,7 +611,7 @@ package Errout is -- 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 diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index ed4d4aa..2a96296 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -40,7 +40,6 @@ with Sinput; use Sinput; with Snames; use Snames; with Targparm; use Targparm; with Table; -with Types; use Types; with Uintp; use Uintp; package body Erroutc is @@ -983,6 +982,11 @@ 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 diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index d061b3a..ea6fda0 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -28,7 +28,7 @@ -- reporting packages, including Errout and Prj.Err. with Table; -with Types; use Types; +with Types; use Types; package Erroutc is @@ -122,7 +122,7 @@ 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 -- @@ -332,7 +332,7 @@ package Erroutc is -- 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; diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index fae34f4..e0a6864 100644 --- a/gcc/ada/errutil.adb +++ b/gcc/ada/errutil.adb @@ -44,7 +44,7 @@ package body Errutil is ----------------------- 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; @@ -184,12 +184,12 @@ package body Errutil is 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 @@ -246,20 +246,19 @@ package body Errutil is 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 @@ -269,8 +268,8 @@ package body Errutil is 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; @@ -438,7 +437,6 @@ package body Errutil is Write_Eol; end if; - end loop; -- Then output errors, if any, for subsidiary units @@ -564,7 +562,6 @@ package body Errutil is Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected; Warnings_Detected := 0; end if; - end Finalize; ---------------- @@ -585,7 +582,6 @@ package body Errutil is -- an initial dummy entry covering all possible source locations. Warnings.Init; - end Initialize; ------------------------ @@ -682,6 +678,7 @@ package body Errutil is Set_Msg_Insertion_Name; elsif C = '$' then + -- '$' is ignored null; @@ -690,6 +687,7 @@ package body Errutil is Set_Msg_Insertion_File_Name; elsif C = '}' then + -- '}' is ignored null; @@ -698,6 +696,7 @@ package body Errutil is Set_Msg_Insertion_Reserved_Name; elsif C = '&' then + -- '&' is ignored null; @@ -724,6 +723,9 @@ package body Errutil is elsif C = '?' then null; + elsif C = '<' then + null; + elsif C = '|' then null; diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index a209620..00922b3 100644 --- a/gcc/ada/prj-dect.adb +++ b/gcc/ada/prj-dect.adb @@ -30,9 +30,7 @@ with Opt; use Opt; 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; @@ -212,13 +210,8 @@ package body Prj.Dect is 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 diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 71697e9..bc7adfa 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -38,7 +38,6 @@ with Prj.Util; use Prj.Util; 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; @@ -47,7 +46,6 @@ with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; 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 @@ -876,7 +874,6 @@ 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 @@ -939,6 +936,8 @@ package body Prj.Nmsc is Real_Location); return; end if; + + Source_Id := Source.Next; end loop; if Current_Verbosity = High then @@ -2368,7 +2367,7 @@ package body Prj.Nmsc is 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; @@ -2461,34 +2460,29 @@ package body Prj.Nmsc is 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; @@ -2588,11 +2582,19 @@ package body Prj.Nmsc is 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 diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index a86c2a5..25b5fd3 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -296,17 +296,17 @@ package body Sem_Elab is -- 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 -- @@ -963,7 +963,7 @@ package body Sem_Elab is 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; @@ -1051,35 +1051,29 @@ package body Sem_Elab is 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; @@ -1088,9 +1082,9 @@ package body Sem_Elab is 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; @@ -1106,8 +1100,8 @@ package body Sem_Elab is 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 @@ -1136,11 +1130,11 @@ package body Sem_Elab is 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; @@ -1381,7 +1375,7 @@ package body Sem_Elab is 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; @@ -1882,7 +1876,7 @@ package body Sem_Elab is 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 @@ -1946,7 +1940,7 @@ package body Sem_Elab is 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)); |