2005-11-14 Robert Dewar <dewar@adacore.com>

	    Ed Schonberg  <schonberg@adacore.com>

	PR ada/18434

	* types.ads: Include All_Checks in Suppress_Array

	* checks.adb (Check_Needed): Remove kludge for a/=b rewritten as
	not(a=b), since we no longer do this rewriting, and hence it is not
	needed.
	(Elaboration_Checks_Suppressed): Add special casing to
	deal with different cases of static and dynamic elaboration checks (all
	checks does not count in the first case, but does in the second).
	(Expr_Known_Valid): Do not assume that the result of any arbitrary
	function call is valid, since this is not the case.
	(Ensure_Valid): Do not apply validity check to a real literal
	in a universal or fixed context

	* exp_ch4.adb (Expand_N_Op_Ne): Don't expand a/=b to not(a=b) for
	elementary types using the operator in standard. It is cleaner not to
	modify the programmers intent, especially in the case of floating-point.
	(Rewrite_Comparison): Fix handling of /= (this was always wrong, but
	it did not matter because we always rewrote a/=b to not(a=b).
	(Expand_Allocator_Expression): For an allocator expression whose nominal
	subtype is an unconstrained packed type, convert the expression to its
	actual constrained subtype.
	Implement warning for <= or >= where < or > not possible
	Fix to Vax_Float tests (too early in many routines, causing premature
	Vax_Float expansions.

	* sem_prag.adb (Analyze_Pragma, case Obsolescent): Allow this pragma
	to be used with packages and generic packages as well as with
	subprograms.
	(Suppress): Set All_Checks, but not Elaboration_Check, for case
	of pragma Suppress (All_Checks)
	(Analyze_Pragma, case Warnings): Implement first argument allowed to be
	a string literal for precise control over warnings.
	Avoid raise of pragma in case of unrecognized pragma and just return
	instead.

	* sem_prag.ads: Minor reformatting

	* switch-c.adb (Scan_Front_End_Switches): Replace "raise Bad_Switch;"
	with call to new procedure Bad_Switch. Call Scan_Pos with new parameter
	Switch. Do not handle any exception.
	Include -gnatwx as part of -gnatg (warn on redundant parens)
	Allow optional = after -gnatm
	(Scan_Front_End_Switches): The -gnatp switch sets All_Checks, but no
	longer sets Elaboration_Checks.
	Code to set warning mode moved to Sem_Warn
	so that it can be shared by pragma processing.

	* s-mastop-tru64.adb (Pop_Frame): Remove redundant parentheses in if
	statement.

	* s-taprop-solaris.adb: 
	Change some <= to =, to avoid new warning

	* a-exexda.adb, prj-proc.adb: 
	Fix obvious typo (Num_Tracebacks compared <= 0 instead of < 0)
	Fix obvious typo (Total_Errors_Detected <= 0 should be = 0)


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@106950 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 107 insertions, 31 deletions

diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 29233a4f7ca..b06f117e158 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -64,6 +64,7 @@ with Sem_Res;  use Sem_Res;
 with Sem_Type; use Sem_Type;
 with Sem_Util; use Sem_Util;
 with Sem_VFpt; use Sem_VFpt;
+with Sem_Warn; use Sem_Warn;
 with Stand;    use Stand;
 with Sinfo;    use Sinfo;
 with Sinfo.CN; use Sinfo.CN;
@@ -236,8 +237,9 @@ package body Sem_Prag is
 
       Pragma_Exit : exception;
       --  This exception is used to exit pragma processing completely. It
-      --  is used when an error is detected, and in other situations where
-      --  it is known that no further processing is required.
+      --  is used when an error is detected, and no further processing is
+      --  required. It is also used if an earlier error has left the tree
+      --  in a state where the pragma should not be processed.
 
       Arg_Count : Nat;
       --  Number of pragma argument associations
@@ -1331,15 +1333,12 @@ package body Sem_Prag is
 
                   Analyze (Expression (Arg1));
 
-                  if        Unit_Kind = N_Generic_Subprogram_Declaration
+                  if Unit_Kind = N_Generic_Subprogram_Declaration
                     or else Unit_Kind = N_Subprogram_Declaration
                   then
                      Unit_Name := Defining_Entity (Unit_Node);
 
-                  elsif     Unit_Kind = N_Function_Instantiation
-                    or else Unit_Kind = N_Package_Instantiation
-                    or else Unit_Kind = N_Procedure_Instantiation
-                  then
+                  elsif Unit_Kind in N_Generic_Instantiation then
                      Unit_Name := Defining_Entity (Unit_Node);
 
                   else
@@ -2141,7 +2140,7 @@ package body Sem_Prag is
            and then Ekind (E) /= E_Variable
            and then not
              (Is_Access_Type (E)
-              and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
+                and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
          then
             Error_Pragma_Arg
               ("second argument of pragma% must be subprogram (type)",
@@ -3784,9 +3783,21 @@ package body Sem_Prag is
             --  suppress check for any check id value.
 
             if C = All_Checks then
+
+               --  For All_Checks, we set all specific checks with the
+               --  exception of Elaboration_Check, which is handled specially
+               --  because of not wanting All_Checks to have the effect of
+               --  deactivating static elaboration order processing.
+
                for J in Scope_Suppress'Range loop
-                  Scope_Suppress (J) := Suppress_Case;
+                  if J /= Elaboration_Check then
+                     Scope_Suppress (J) := Suppress_Case;
+                  end if;
                end loop;
+
+            --  If not All_Checks, just set appropriate entry. Note that we
+            --  will set Elaboration_Check if this is explicitly specified.
+
             else
                Scope_Suppress (C) := Suppress_Case;
             end if;
@@ -4259,7 +4270,7 @@ package body Sem_Prag is
          if Warn_On_Unrecognized_Pragma then
             Error_Pragma ("unrecognized pragma%!?");
          else
-            raise Pragma_Exit;
+            return;
          end if;
       else
          Prag_Id := Get_Pragma_Id (Chars (N));
@@ -5885,7 +5896,7 @@ package body Sem_Prag is
                Error_Pragma ("pragma% must refer to a spec, not a body");
             else
                Set_Body_Required (Cunit_Node, True);
-               Set_Has_Pragma_Elaborate_Body     (Cunit_Ent);
+               Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
 
                --  If we are in dynamic elaboration mode, then we suppress
                --  elaboration warnings for the unit, since it is definitely
@@ -5991,7 +6002,7 @@ package body Sem_Prag is
                 Present (Source_Location)
             then
                Error_Pragma
-                 ("parameter profile and source location can not " &
+                 ("parameter profile and source location cannot " &
                   "be used together in pragma%");
             end if;
 
@@ -8141,6 +8152,28 @@ package body Sem_Prag is
             S      : String_Id;
             Active : Boolean := True;
 
+            procedure Check_Obsolete_Subprogram;
+            --  Checks if Subp is a subprogram declaration node, and if so
+            --  replaces Subp by the defining entity of the subprogram. If not,
+            --  issues an error message
+
+            ------------------------------
+            -- Check_Obsolete_Subprogram--
+            ------------------------------
+
+            procedure Check_Obsolete_Subprogram is
+            begin
+               if Nkind (Subp) /= N_Subprogram_Declaration then
+                  Error_Pragma
+                    ("pragma% misplaced, must immediately " &
+                     "follow subprogram/package declaration");
+               else
+                  Subp := Defining_Entity (Subp);
+               end if;
+            end Check_Obsolete_Subprogram;
+
+         --  Start of processing for pragma Obsolescent
+
          begin
             GNAT_Pragma;
             Check_At_Most_N_Arguments (2);
@@ -8153,6 +8186,7 @@ package body Sem_Prag is
 
             if Present (Prev (N)) then
                Subp := Prev (N);
+               Check_Obsolete_Subprogram;
 
             --  Second possibility, stand alone subprogram declaration with the
             --  pragma immediately following the declaration.
@@ -8161,25 +8195,22 @@ package body Sem_Prag is
               and then Nkind (Parent (N)) = N_Compilation_Unit_Aux
             then
                Subp := Unit (Parent (Parent (N)));
+               Check_Obsolete_Subprogram;
 
-            --  Any other possibility is a misplacement
+            --  Only other possibility is library unit placement for package
 
             else
-               Subp := Empty;
-            end if;
-
-            --  Check correct placement
+               Subp := Find_Lib_Unit_Name;
 
-            if Nkind (Subp) /= N_Subprogram_Declaration then
-               Error_Pragma
-                 ("pragma% misplaced, must immediately " &
-                  "follow subprogram spec");
+               if Ekind (Subp) /= E_Package
+                 and then Ekind (Subp) /= E_Generic_Package
+               then
+                  Check_Obsolete_Subprogram;
+               end if;
             end if;
 
             --  If OK placement, acquire arguments
 
-            Subp := Defining_Entity (Subp);
-
             if Arg_Count >= 1 then
 
                --  Deal with static string argument
@@ -9907,8 +9938,7 @@ package body Sem_Prag is
                  ("pragma% requires separate spec and must come before body");
 
             elsif Rep_Item_Too_Early (E, N)
-                 or else
-               Rep_Item_Too_Late (E, N)
+              or else Rep_Item_Too_Late (E, N)
             then
                raise Pragma_Exit;
 
@@ -10346,16 +10376,58 @@ package body Sem_Prag is
          --------------
 
          --  pragma Warnings (On | Off, [LOCAL_NAME])
+         --  pragma Warnings (static_string_EXPRESSION);
 
          when Pragma_Warnings => Warnings : begin
             GNAT_Pragma;
             Check_At_Least_N_Arguments (1);
-            Check_At_Most_N_Arguments (2);
             Check_No_Identifiers;
 
-            --  One argument case was processed by parser in Par.Prag
+            --  One argument case
 
-            if Arg_Count /= 1 then
+            if Arg_Count = 1 then
+               declare
+                  Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
+
+               begin
+                  --  On/Off one argument case was processed by parser
+
+                  if Nkind (Argx) = N_Identifier
+                    and then
+                      (Chars (Argx) = Name_On
+                         or else
+                       Chars (Argx) = Name_Off)
+                  then
+                     null;
+
+                  else
+                     Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+
+                     declare
+                        Lit : constant Node_Id   := Expr_Value_S (Argx);
+                        Str : constant String_Id := Strval (Lit);
+                        C   : Char_Code;
+
+                     begin
+                        for J in 1 .. String_Length (Str) loop
+                           C := Get_String_Char (Str, J);
+
+                           if In_Character_Range (C)
+                             and then Set_Warning_Switch (Get_Character (C))
+                           then
+                              null;
+                           else
+                              Error_Pragma_Arg
+                                ("invalid warning switch character", Arg1);
+                           end if;
+                        end loop;
+                     end;
+                  end if;
+               end;
+
+            --  Two argument case
+
+            elsif Arg_Count /= 1 then
                Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
                Check_Arg_Count (2);
 
@@ -10372,7 +10444,7 @@ package body Sem_Prag is
                   --  is a conversion. Retrieve the real entity name.
 
                   if (In_Instance_Body
-                       or else In_Inlined_Body)
+                      or else In_Inlined_Body)
                     and then Nkind (E_Id) = N_Unchecked_Type_Conversion
                   then
                      E_Id := Expression (E_Id);
@@ -10390,8 +10462,8 @@ package body Sem_Prag is
                      return;
                   else
                      loop
-                        Set_Warnings_Off (E,
-                          (Chars (Expression (Arg1)) = Name_Off));
+                        Set_Warnings_Off
+                          (E, (Chars (Expression (Arg1)) = Name_Off));
 
                         if Is_Enumeration_Type (E) then
                            declare
@@ -10410,6 +10482,10 @@ package body Sem_Prag is
                      end loop;
                   end if;
                end;
+
+               --  More than two arguments
+            else
+               Check_At_Most_N_Arguments (2);
             end if;
          end Warnings;