From ad018b0cbec171fc39a144fb42471d2d99c64ffb Mon Sep 17 00:00:00 2001 From: charlet Date: Mon, 5 Sep 2005 07:52:55 +0000 Subject: [PATCH] 2005-09-01 Robert Dewar * 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@103859 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/err_vars.ads | 6 ++++- gcc/ada/errout.adb | 21 ++++++++------- gcc/ada/errout.ads | 14 ++++++++-- gcc/ada/erroutc.adb | 8 ++++-- gcc/ada/erroutc.ads | 8 +++--- gcc/ada/errutil.adb | 42 +++++++++++++++-------------- gcc/ada/prj-dect.adb | 11 ++------ gcc/ada/prj-nmsc.adb | 50 +++++++++++++++++----------------- 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 ("