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

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));