g-comlin.ads, [...]: Add new warning for renaming of function return objects

2007-04-20  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* g-comlin.ads, g-comlin.adb: 
	Add new warning for renaming of function return objects

	* opt.adb (Tree_Write, Tree_Read): Use proper expressions for size
	(Tree_Read): Use size of object instead of type'object_size, since the
	latter is incorrect for packed array types.
	(Tree_Write): Same fix

	* opt.ads: Add new warning for renaming of function return objects
	(Generating_Code): New boolean variable used to indicate that the
	frontend as finished its work and has called the backend to process
	the tree and generate the object file.
	(GCC_Version): Is now private
	(Static_Dispatch_Tables): New constant declaration.
	(Overflow_Checks_Unsuppressed): New flag.
	(Process_Suppress_Unsuppress): Set Overflow_Checks_Unsuppressed.
	(List_Closure): New flag for gnatbind (-R)
	Zero_Formatting: New flag for gnatbind (-Z)
	(Special_Exception_Package_Used): New flag.
	(Warn_On_Unrepped_Components): New flag.

	* sem_ch8.adb (Check_Library_Unit_Renaming): Check that the renamed
	unit is a compilation unit, rather than relying on its scope, so that
	Standard can be renamed.
	(Analyze_Object_Renaming): Add new warning for renaming of function
	return objects.
	Also reject attempt to rename function return object in Ada 83 mode.
	(Attribute_Renaming): In case of tagged types, add the body of the
	generated function to the freezing actions of the type.
	(Find_Type): A protected type is visible right after the reserved word
	"is" is encountered in its type declaration. Set the entity and type
	rather than emitting an error message.
	(New_Scope): Properly propagate Discard_Names to inner scopes
	(Check_Nested_Access): New procedure.
	(Has_Nested_Access, Set_Has_Nested_Access): New procedures.
	(Find_Direct_Name, Note_Possible_Modification): Use Check_Nested_Access.

	* sem_warn.ads, sem_warn.adb: Improvements to infinite loop warning
	Add new warning for renaming of function return objects
	(Check_References): Suppress warnings for objects whose type or
	base type has Warnings suppressed.
	(Set_Dot_Warning_Switch): Add processing for -gnatw.c/C
	(Set_Warning_Switch): Include new -gnatwc in -gnatwa

From-SVN: r125414

7 files changed, 743 insertions, 166 deletions

diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb
index 4b62e1c..52a1555 100644
--- a/gcc/ada/g-comlin.adb
+++ b/gcc/ada/g-comlin.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1999-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1999-2007, 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- --
@@ -32,7 +32,7 @@
 ------------------------------------------------------------------------------
 
 with Ada.Command_Line;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.OS_Lib;      use GNAT.OS_Lib;
 
 package body GNAT.Command_Line is
 
@@ -142,9 +142,9 @@ package body GNAT.Command_Line is
       use GNAT.Directory_Operations;
       type Pointer is access all Expansion_Iterator;
 
+      It   : constant Pointer := Iterator'Unrestricted_Access;
       S    : String (1 .. 1024);
       Last : Natural;
-      It   : constant Pointer := Iterator'Unrestricted_Access;
 
       Current : Depth := It.Current_Depth;
       NL      : Positive;
@@ -304,8 +304,8 @@ package body GNAT.Command_Line is
 
       if Do_Expansion then
          declare
-            Arg       : String renames CL.Argument (Current_Argument - 1);
-            Index     : Positive := Arg'First;
+            Arg   : constant String := CL.Argument (Current_Argument - 1);
+            Index : Positive := Arg'First;
 
          begin
             while Index <= Arg'Last loop
@@ -381,7 +381,7 @@ package body GNAT.Command_Line is
       end if;
 
       declare
-         Arg            : String renames CL.Argument (Current_Argument);
+         Arg            : constant String := CL.Argument (Current_Argument);
          Index_Switches : Natural := 0;
          Max_Length     : Natural := 0;
          Index          : Natural;
@@ -780,9 +780,9 @@ package body GNAT.Command_Line is
    is
       Directory_Separator : Character;
       pragma Import (C, Directory_Separator, "__gnat_dir_separator");
-      First : Positive := Pattern'First;
 
-      Pat : String := Pattern;
+      First : Positive := Pattern'First;
+      Pat   : String := Pattern;
 
    begin
       Canonical_Case_File_Name (Pat);
@@ -838,7 +838,6 @@ package body GNAT.Command_Line is
             exit when Iterator.Maximum_Depth = Max_Depth;
          end if;
       end loop;
-
    end Start_Expansion;
 
 begin
diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads
index 447e617..60073f3 100644
--- a/gcc/ada/g-comlin.ads
+++ b/gcc/ada/g-comlin.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---                     Copyright (C) 1999-2005, AdaCore                     --
+--                     Copyright (C) 1999-2007, AdaCore                     --
 --                                                                          --
 -- 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- --
@@ -322,7 +322,6 @@ private
       Maximum_Depth : Depth := 1;
       --  The maximum depth of directories, reflecting the number of directory
       --  separators in the pattern.
-
    end record;
 
 end GNAT.Command_Line;
diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb
index 8c11718..7834812 100644
--- a/gcc/ada/opt.adb
+++ b/gcc/ada/opt.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -37,6 +37,9 @@ with Tree_IO; use Tree_IO;
 
 package body Opt is
 
+   SU : constant := Storage_Unit;
+   --  Shorthand for System.Storage_Unit
+
    ----------------------------------
    -- Register_Opt_Config_Switches --
    ----------------------------------
@@ -169,10 +172,10 @@ package body Opt is
       Tree_Read_Char (Identifier_Character_Set);
       Tree_Read_Int  (Maximum_File_Name_Length);
       Tree_Read_Data (Suppress_Options'Address,
-                      Suppress_Array'Object_Size / Storage_Unit);
+                      (Suppress_Options'Size + SU - 1) / SU);
       Tree_Read_Bool (Verbose_Mode);
       Tree_Read_Data (Warning_Mode'Address,
-                      Warning_Mode_Type'Object_Size / Storage_Unit);
+                      (Warning_Mode'Size + SU - 1) / SU);
       Tree_Read_Int  (Ada_Version_Config_Val);
       Tree_Read_Int  (Ada_Version_Explicit_Config_Val);
       Tree_Read_Int  (Assertions_Enabled_Config_Val);
@@ -198,23 +201,23 @@ package body Opt is
       begin
          Tree_Read_Data
            (Tmp'Address, Tree_Version_String_Len);
-         GNAT.Strings.Free (Tree_Version_String);
+         System.Strings.Free (Tree_Version_String);
          Free (Tree_Version_String);
          Tree_Version_String := new String'(Tmp);
       end;
 
       Tree_Read_Data (Distribution_Stub_Mode'Address,
-                      Distribution_Stub_Mode_Type'Object_Size / Storage_Unit);
+                      (Distribution_Stub_Mode'Size + SU - 1) / Storage_Unit);
       Tree_Read_Bool (Inline_Active);
       Tree_Read_Bool (Inline_Processing_Required);
       Tree_Read_Bool (List_Units);
       Tree_Read_Bool (Configurable_Run_Time_Mode);
       Tree_Read_Data (Operating_Mode'Address,
-                      Operating_Mode_Type'Object_Size / Storage_Unit);
+                      (Operating_Mode'Size + SU - 1) / Storage_Unit);
       Tree_Read_Bool (Suppress_Checks);
       Tree_Read_Bool (Try_Semantics);
       Tree_Read_Data (Wide_Character_Encoding_Method'Address,
-                      WC_Encoding_Method'Object_Size / Storage_Unit);
+                      (Wide_Character_Encoding_Method'Size + SU - 1) / SU);
       Tree_Read_Bool (Upper_Half_Encoding);
       Tree_Read_Bool (Force_ALI_Tree_File);
    end Tree_Read;
@@ -233,10 +236,10 @@ package body Opt is
       Tree_Write_Char (Identifier_Character_Set);
       Tree_Write_Int  (Maximum_File_Name_Length);
       Tree_Write_Data (Suppress_Options'Address,
-                       Suppress_Array'Object_Size / Storage_Unit);
+                       (Suppress_Options'Size + SU - 1) / SU);
       Tree_Write_Bool (Verbose_Mode);
       Tree_Write_Data (Warning_Mode'Address,
-                       Warning_Mode_Type'Object_Size / Storage_Unit);
+                       (Warning_Mode'Size + SU - 1) / Storage_Unit);
       Tree_Write_Int  (Ada_Version_Type'Pos (Ada_Version_Config));
       Tree_Write_Int  (Ada_Version_Type'Pos (Ada_Version_Explicit_Config));
       Tree_Write_Int  (Boolean'Pos (Assertions_Enabled_Config));
@@ -246,20 +249,19 @@ package body Opt is
       Tree_Write_Bool (Enable_Overflow_Checks);
       Tree_Write_Bool (Full_List);
       Tree_Write_Int  (Int (Version_String'Length));
-      Tree_Write_Data (Version_String'Address,
-                       Version_String'Length);
+      Tree_Write_Data (Version_String'Address, Version_String'Length);
       Tree_Write_Data (Distribution_Stub_Mode'Address,
-                       Distribution_Stub_Mode_Type'Object_Size / Storage_Unit);
+                       (Distribution_Stub_Mode'Size + SU - 1) / SU);
       Tree_Write_Bool (Inline_Active);
       Tree_Write_Bool (Inline_Processing_Required);
       Tree_Write_Bool (List_Units);
       Tree_Write_Bool (Configurable_Run_Time_Mode);
       Tree_Write_Data (Operating_Mode'Address,
-                       Operating_Mode_Type'Object_Size / Storage_Unit);
+                       (Operating_Mode'Size + SU - 1) / SU);
       Tree_Write_Bool (Suppress_Checks);
       Tree_Write_Bool (Try_Semantics);
       Tree_Write_Data (Wide_Character_Encoding_Method'Address,
-                       WC_Encoding_Method'Object_Size / Storage_Unit);
+                       (Wide_Character_Encoding_Method'Size + SU - 1) / SU);
       Tree_Write_Bool (Upper_Half_Encoding);
       Tree_Write_Bool (Force_ALI_Tree_File);
    end Tree_Write;
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index fb1fa0e..14d04db 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -39,8 +39,8 @@
 with Hostparm; use Hostparm;
 with Types;    use Types;
 
+with System.Strings; use System.Strings;
 with System.WCh_Con; use System.WCh_Con;
-with GNAT.Strings;   use GNAT.Strings;
 
 package Opt is
 
@@ -386,6 +386,11 @@ package Opt is
    --  Set to True if -gnato (enable overflow checks) switch is set,
    --  but not -gnatp.
 
+   Overflow_Checks_Unsuppressed : Boolean := False;
+   --  GNAT
+   --  Set to True if at least one pragma Unsuppress
+   --  (All_Checks|Overflow_Checks) has been processed.
+
    Error_Msg_Line_Length : Nat := 0;
    --  GNAT
    --  Records the error message line length limit. If this is set to zero,
@@ -510,16 +515,15 @@ package Opt is
    --  the name is of the form .xxx, then to name.xxx where name is the source
    --  file name with extension stripped.
 
-   function get_gcc_version return Int;
-   pragma Import (C, get_gcc_version, "get_gcc_version");
-
-   GCC_Version : constant Nat := get_gcc_version;
-   --  GNATMAKE
-   --  Indicates which version of gcc is in use (2 = 2.8.1, 3 = 3.x)
+   Generating_Code : Boolean := False;
+   --  GNAT
+   --  True if the frontend finished its work and has called the backend to
+   --  processs the tree and generate the object file.
 
    Global_Discard_Names : Boolean := False;
    --  GNAT, GNATBIND
-   --  Set true if a pragma Discard_Names applies to the current unit
+   --  True if a pragma Discard_Names appeared as a configuration pragma for
+   --  the current compilation unit.
 
    GNAT_Mode : Boolean := False;
    --  GNAT
@@ -633,6 +637,10 @@ package Opt is
    --  GNAT
    --  List units in the active library for a compilation (-gnatu switch)
 
+   List_Closure : Boolean := False;
+   --  GNATBIND
+   --  List all sources in the closure of a main (-R gnatbind switch)
+
    List_Dependencies : Boolean := False;
    --  GNATMAKE
    --  When True gnatmake verifies that the objects are up to date and
@@ -668,7 +676,7 @@ package Opt is
    --  before preprocessing occurs. Set to True by switch -s of gnatprep
    --  or -s in preprocessing data file for the compiler.
 
-   type Create_Repinfo_File_Proc is access procedure (Src : File_Name_Type);
+   type Create_Repinfo_File_Proc is access procedure (Src  : String);
    type Write_Repinfo_Line_Proc  is access procedure (Info : String);
    type Close_Repinfo_File_Proc  is access procedure;
    --  Types used for procedure addresses below
@@ -753,6 +761,12 @@ package Opt is
    --  GNATMAKE
    --  Set to True if minimal recompilation mode requested
 
+   Special_Exception_Package_Used : Boolean := False;
+   --  GNAT
+   --  Set to True if either of the unit GNAT.Most_Recent_Exception or
+   --  GNAT.Exception_Traces is with'ed. Used to inhibit transformation of
+   --  local raise statements into gotos in the presence of either package.
+
    Multiple_Unit_Index : Int;
    --  GNAT
    --  This is set non-zero if the current unit is being compiled in multiple
@@ -1186,6 +1200,11 @@ package Opt is
    --  Set to True to generate warnings for redundant constructs (e.g. useless
    --  assignments/conversions). The default is that this warning is disabled.
 
+   Warn_On_Object_Renames_Function : Boolean := False;
+   --  GNAT
+   --  Set to True to generate warnings when a function result is renamed as
+   --  an object. The default is that this warning is disabled.
+
    Warn_On_Reverse_Bit_Order : Boolean := True;
    --  GNAT
    --  Set to True to generate warning (informational) messages for component
@@ -1203,6 +1222,12 @@ package Opt is
    --  Set to True to generate warnings for unrecognized pragmas. The default
    --  is that this warning is enabled.
 
+   Warn_On_Unrepped_Components : Boolean := False;
+   --  GNAT
+   --  Set to True to generate warnings for the case of components of record
+   --  which have a record representation clause but this component does not
+   --  have a component clause. The default is that this warning is disabled.
+
    type Warning_Mode_Type is (Suppress, Normal, Treat_As_Error);
    Warning_Mode : Warning_Mode_Type := Normal;
    --  GNAT, GNATBIND
@@ -1226,6 +1251,11 @@ package Opt is
    --  GNAT
    --  Set if cross-referencing is enabled (i.e. xref info in ALI files)
 
+   Zero_Formatting : Boolean := False;
+   --  GNATBIND
+   --  Do no formatting (no title, no leading spaces, no empty lines) in
+   --  auxiliary outputs (-e, -K, -l, -R).
+
    ----------------------------
    -- Configuration Settings --
    ----------------------------
@@ -1362,6 +1392,15 @@ package Opt is
    -- Other Global Flags --
    ------------------------
 
+   Static_Dispatch_Tables : constant Boolean;
+   --  This flag indicates if the backend supports generation of statically
+   --  allocated dispatch tables. If it is True, then the front end will
+   --  generate static aggregates for dispatch tables that contain forward
+   --  references to addresses of subprograms not seen yet, and the back end
+   --  must be prepared to handle this case. If it is False, then the front
+   --  end generates assignments to initialize the dispatch table, and there
+   --  are no such forward references.
+
    Expander_Active : Boolean := False;
    --  A flag that indicates if expansion is active (True) or deactivated
    --  (False). When expansion is deactivated all calls to expander routines
@@ -1431,4 +1470,20 @@ private
       Use_VADS_Size                  : Boolean;
    end record;
 
+   --  The following declarations are for GCC version dependent flags. We do
+   --  not let client code in the compiler test GCC_Version directly, but
+   --  instead use deferred constants for relevant feature tags.
+
+   function get_gcc_version return Int;
+   pragma Import (C, get_gcc_version, "get_gcc_version");
+
+   GCC_Version : constant Nat := get_gcc_version;
+   --  GNATMAKE
+   --  Indicates which version of gcc is in use (3 = 3.x, 4 = 4.x). Note that
+   --  gcc 2.8.1 (which used to be a value of 2) is no longer supported.
+
+   Static_Dispatch_Tables : constant Boolean := GCC_Version >= 4;
+   --  GCC version 4 can handle the static dispatch tables, but not version 3.
+   --  Also we need -funit-at-a-time, which should also be tested here ???
+
 end Opt;
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 982fa76..7de0b70 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -721,10 +721,25 @@ package body Sem_Ch8 is
             Set_Etype (Nam, T);
          end if;
 
+         --  Complete analysis of the subtype mark in any case, for ASIS use.
+
+         if Present (Subtype_Mark (N)) then
+            Find_Type (Subtype_Mark (N));
+         end if;
+
       elsif Present (Subtype_Mark (N)) then
          Find_Type (Subtype_Mark (N));
          T := Entity (Subtype_Mark (N));
-         Analyze_And_Resolve (Nam, T);
+         Analyze (Nam);
+
+         if Nkind (Nam) = N_Type_Conversion
+            and then not Is_Tagged_Type (T)
+         then
+            Error_Msg_N
+              ("renaming of conversion only allowed for tagged types", Nam);
+         end if;
+
+         Resolve (Nam, T);
 
       --  Ada 2005 (AI-230/AI-254): Access renaming
 
@@ -748,6 +763,40 @@ package body Sem_Ch8 is
          end if;
       end if;
 
+      --  Special processing for renaming function return object
+
+      if Nkind (Nam) = N_Function_Call
+        and then Comes_From_Source (Nam)
+      then
+         case Ada_Version is
+
+            --  Usage is illegal in Ada 83
+
+            when Ada_83 =>
+               Error_Msg_N
+                 ("(Ada 83) cannot rename function return object", Nam);
+
+            --  In Ada 95, warn for odd case of renaming parameterless function
+            --  call if this is not a limited type (where this is useful)
+
+            when others =>
+               if Warn_On_Object_Renames_Function
+                 and then No (Parameter_Associations (Nam))
+                 and then not Is_Limited_Type (Etype (Nam))
+               then
+                  Error_Msg_N
+                    ("?renaming function result object is suspicious",
+                     Nam);
+                  Error_Msg_NE
+                    ("\?function & will be called only once",
+                     Nam, Entity (Name (Nam)));
+                  Error_Msg_N
+                    ("\?suggest using an initialized constant object instead",
+                     Nam);
+               end if;
+         end case;
+      end if;
+
       --  An object renaming requires an exact match of the type. Class-wide
       --  matching is not allowed.
 
@@ -802,7 +851,7 @@ package body Sem_Ch8 is
                --  formal object of a generic unit G, and the object renaming
                --  declaration occurs within the body of G or within the body
                --  of a generic unit declared within the declarative region
-               --  of G, then the declaration of the formal object of G shall
+               --  of G, then the declaration of the formal object of G must
                --  have a null exclusion.
 
                if Is_Formal_Object (Nam_Ent)
@@ -818,8 +867,12 @@ package body Sem_Ch8 is
                      Error_Node := Access_Definition (Nam_Decl);
                   end if;
 
-                  Error_Msg_N ("null-exclusion required in formal " &
-                               "object declaration", Error_Node);
+                  Error_Msg_N
+                    ("`NOT NULL` required in formal object declaration",
+                     Error_Node);
+                  Error_Msg_Sloc := Sloc (N);
+                  Error_Msg_N
+                    ("\because of renaming at# ('R'M 8.5.4(4))", Error_Node);
 
                --  Ada 2005 (AI-423): Otherwise, the subtype of the object name
                --  shall exclude null.
@@ -827,8 +880,9 @@ package body Sem_Ch8 is
                elsif Nkind (Subtyp_Decl) = N_Subtype_Declaration
                  and then not Has_Null_Exclusion (Subtyp_Decl)
                then
-                  Error_Msg_N ("subtype must have null-exclusion",
-                               Subtyp_Decl);
+                  Error_Msg_N
+                    ("`NOT NULL` required for subtype & ('R'M 8.5.1(4.6/2))",
+                     Defining_Identifier (Subtyp_Decl));
                end if;
             end if;
          end;
@@ -1275,8 +1329,9 @@ package body Sem_Ch8 is
                 not (Has_Null_Exclusion (Parent (Sub_Formal))
                        or else Can_Never_Be_Null (Etype (Sub_Formal)))
             then
-               Error_Msg_N ("null-exclusion required in parameter profile",
-                            Parent (Sub_Formal));
+               Error_Msg_NE
+                 ("`NOT NULL` required for parameter &",
+                  Parent (Sub_Formal), Sub_Formal);
             end if;
 
             Next_Formal (Ren_Formal);
@@ -1292,8 +1347,9 @@ package body Sem_Ch8 is
              not (Has_Null_Exclusion (Parent (Sub))
                     or else Can_Never_Be_Null (Etype (Sub)))
          then
-            Error_Msg_N ("null-exclusion required in return profile",
-                         Result_Definition (Parent (Sub)));
+            Error_Msg_N
+              ("return must specify `NOT NULL`",
+               Result_Definition (Parent (Sub)));
          end if;
       end Check_Null_Exclusion;
 
@@ -1525,6 +1581,7 @@ package body Sem_Ch8 is
          --  for it at the freezing point.
 
          Set_Corresponding_Spec (N, Rename_Spec);
+
          if Nkind (Unit_Declaration_Node (Rename_Spec)) =
                                      N_Abstract_Subprogram_Declaration
          then
@@ -1954,8 +2011,9 @@ package body Sem_Ch8 is
                  and then not Can_Never_Be_Null (Old_F)
                then
                   Error_Msg_N ("access parameter is controlling,", New_F);
-                  Error_Msg_NE ("\corresponding parameter of& " &
-                    " must be explicitly null excluding", New_F, Old_S);
+                  Error_Msg_NE
+                    ("\corresponding parameter of& "
+                     & "must be explicitly null excluding", New_F, Old_S);
                end if;
 
                Next_Formal (Old_F);
@@ -2334,16 +2392,43 @@ package body Sem_Ch8 is
                    Statements => New_List (Attr_Node)));
       end if;
 
-      Rewrite (N, Body_Node);
-      Analyze (N);
+      --  In case of tagged types we add the body of the generated function to
+      --  the freezing actions of the type (because in the general case such
+      --  type is still not frozen). We exclude from this processing generic
+      --  formal subprograms found in instantiations and AST_Entry renamings.
+
+      if not Present (Corresponding_Formal_Spec (N))
+        and then Etype (Nam) /= RTE (RE_AST_Handler)
+      then
+         declare
+            P : constant Entity_Id := Prefix (Nam);
+
+         begin
+            Find_Type (P);
+
+            if Is_Tagged_Type (Etype (P)) then
+               Ensure_Freeze_Node (Etype (P));
+               Append_Freeze_Action (Etype (P), Body_Node);
+            else
+               Rewrite (N, Body_Node);
+               Analyze (N);
+               Set_Etype (New_S, Base_Type (Etype (New_S)));
+            end if;
+         end;
+
+      --  Generic formal subprograms or AST_Handler renaming
+
+      else
+         Rewrite (N, Body_Node);
+         Analyze (N);
+         Set_Etype (New_S, Base_Type (Etype (New_S)));
+      end if;
 
       if Is_Compilation_Unit (New_S) then
          Error_Msg_N
            ("a library unit can only rename another library unit", N);
       end if;
 
-      Set_Etype (New_S, Base_Type (Etype (New_S)));
-
       --  We suppress elaboration warnings for the resulting entity, since
       --  clearly they are not needed, and more particularly, in the case
       --  of a generic formal subprogram, the resulting entity can appear
@@ -2502,7 +2587,10 @@ package body Sem_Ch8 is
       if Nkind (Parent (N)) /= N_Compilation_Unit then
          return;
 
-      elsif Scope (Old_E) /= Standard_Standard
+      --  Check for library unit. Note that we used to check for the scope
+      --  being Standard here, but that was wrong for Standard itself.
+
+      elsif not Is_Compilation_Unit (Old_E)
         and then not Is_Child_Unit (Old_E)
       then
          Error_Msg_N ("renamed unit must be a library unit", Name (N));
@@ -3276,7 +3364,7 @@ package body Sem_Ch8 is
 
             --  Another special check if N is the prefix of a selected
             --  component which is a known unit, add message complaining
-            --  about missingw with for this unit.
+            --  about missing with for this unit.
 
             elsif Nkind (Parent (N)) = N_Selected_Component
               and then N = Prefix (Parent (N))
@@ -3735,6 +3823,7 @@ package body Sem_Ch8 is
 
             else
                Generate_Reference (E, N);
+               Check_Nested_Access (E);
             end if;
 
             --  Set Entity, with style check if need be. For a discriminant
@@ -4029,8 +4118,10 @@ package body Sem_Ch8 is
                --  we assume a missing with for the corresponding package.
 
                if Is_Known_Unit (N) then
-                  Error_Msg_Node_2 := Selector;
-                  Error_Msg_N ("missing `WITH &.&;`", Prefix (N));
+                  if not Error_Posted (N) then
+                     Error_Msg_Node_2 := Selector;
+                     Error_Msg_N ("missing `WITH &.&;`", Prefix (N));
+                  end if;
 
                --  If this is a selection from a dummy package, then suppress
                --  the error message, of course the entity is missing if the
@@ -5005,8 +5096,27 @@ package body Sem_Ch8 is
                   else
                      Error_Msg_N
                        ("task type cannot be used as type mark " &
-                        "within its own body", N);
+                        "within its own spec or body", N);
                   end if;
+
+               elsif Ekind (Base_Type (T_Name)) = E_Protected_Type then
+
+                  --  In Ada 2005, a protected name can be used in an access
+                  --  definition within its own body.
+
+                  if Ada_Version >= Ada_05
+                    and then Nkind (Parent (N)) = N_Access_Definition
+                  then
+                     Set_Entity (N, T_Name);
+                     Set_Etype  (N, T_Name);
+                     return;
+
+                  else
+                     Error_Msg_N
+                       ("protected type cannot be used as type mark " &
+                        "within its own spec or body", N);
+                  end if;
+
                else
                   Error_Msg_N ("type declaration cannot refer to itself", N);
                end if;
@@ -5151,10 +5261,10 @@ package body Sem_Ch8 is
       procedure Add_Implicit_Operator
         (T       : Entity_Id;
          Op_Type : Entity_Id := Empty);
-      --  Add implicit interpretation to node N, using the type for which
-      --  a predefined operator exists. If the operator yields a boolean
-      --  type, the Operand_Type is implicitly referenced by the operator,
-      --  and a reference to it must be generated.
+      --  Add implicit interpretation to node N, using the type for which a
+      --  predefined operator exists. If the operator yields a boolean type,
+      --  the Operand_Type is implicitly referenced by the operator, and a
+      --  reference to it must be generated.
 
       ---------------------------
       -- Add_Implicit_Operator --
@@ -5511,101 +5621,6 @@ package body Sem_Ch8 is
                                and then Has_Components (Designated_Type (T))));
    end Is_Appropriate_For_Record;
 
-   ---------------
-   -- New_Scope --
-   ---------------
-
-   procedure New_Scope (S : Entity_Id) is
-      E : Entity_Id;
-
-   begin
-      if Ekind (S) = E_Void then
-         null;
-
-      --  Set scope depth if not a non-concurrent type, and we have not
-      --  yet set the scope depth. This means that we have the first
-      --  occurrence of the scope, and this is where the depth is set.
-
-      elsif (not Is_Type (S) or else Is_Concurrent_Type (S))
-        and then not Scope_Depth_Set (S)
-      then
-         if S = Standard_Standard then
-            Set_Scope_Depth_Value (S, Uint_0);
-
-         elsif Is_Child_Unit (S) then
-            Set_Scope_Depth_Value (S, Uint_1);
-
-         elsif not Is_Record_Type (Current_Scope) then
-            if Ekind (S) = E_Loop then
-               Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope));
-            else
-               Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1);
-            end if;
-         end if;
-      end if;
-
-      Scope_Stack.Increment_Last;
-
-      declare
-         SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
-
-      begin
-         SST.Entity                         := S;
-         SST.Save_Scope_Suppress            := Scope_Suppress;
-         SST.Save_Local_Entity_Suppress     := Local_Entity_Suppress.Last;
-
-         if Scope_Stack.Last > Scope_Stack.First then
-            SST.Component_Alignment_Default := Scope_Stack.Table
-                                                 (Scope_Stack.Last - 1).
-                                                   Component_Alignment_Default;
-         end if;
-
-         SST.Last_Subprogram_Name           := null;
-         SST.Is_Transient                   := False;
-         SST.Node_To_Be_Wrapped             := Empty;
-         SST.Pending_Freeze_Actions         := No_List;
-         SST.Actions_To_Be_Wrapped_Before   := No_List;
-         SST.Actions_To_Be_Wrapped_After    := No_List;
-         SST.First_Use_Clause               := Empty;
-         SST.Is_Active_Stack_Base           := False;
-         SST.Previous_Visibility            := False;
-      end;
-
-      if Debug_Flag_W then
-         Write_Str ("--> new scope: ");
-         Write_Name (Chars (Current_Scope));
-         Write_Str (", Id=");
-         Write_Int (Int (Current_Scope));
-         Write_Str (", Depth=");
-         Write_Int (Int (Scope_Stack.Last));
-         Write_Eol;
-      end if;
-
-      --  Copy from Scope (S) the categorization flags to S, this is not
-      --  done in case Scope (S) is Standard_Standard since propagation
-      --  is from library unit entity inwards.
-
-      if S /= Standard_Standard
-        and then Scope (S) /= Standard_Standard
-        and then not Is_Child_Unit (S)
-      then
-         E := Scope (S);
-
-         if Nkind (E) not in N_Entity then
-            return;
-         end if;
-
-         --  We only propagate inwards for library level entities,
-         --  inner level subprograms do not inherit the categorization.
-
-         if Is_Library_Level_Entity (S) then
-            Set_Is_Preelaborated (S, Is_Preelaborated (E));
-            Set_Is_Shared_Passive (S, Is_Shared_Passive (E));
-            Set_Categorization_From_Scope (E => S, Scop => E);
-         end if;
-      end if;
-   end New_Scope;
-
    ------------------------
    -- Note_Redundant_Use --
    ------------------------
@@ -5832,6 +5847,109 @@ package body Sem_Ch8 is
       Scope_Stack.Decrement_Last;
    end Pop_Scope;
 
+   ---------------
+   -- Push_Scope --
+   ---------------
+
+   procedure Push_Scope (S : Entity_Id) is
+      E : Entity_Id;
+
+   begin
+      if Ekind (S) = E_Void then
+         null;
+
+      --  Set scope depth if not a non-concurrent type, and we have not
+      --  yet set the scope depth. This means that we have the first
+      --  occurrence of the scope, and this is where the depth is set.
+
+      elsif (not Is_Type (S) or else Is_Concurrent_Type (S))
+        and then not Scope_Depth_Set (S)
+      then
+         if S = Standard_Standard then
+            Set_Scope_Depth_Value (S, Uint_0);
+
+         elsif Is_Child_Unit (S) then
+            Set_Scope_Depth_Value (S, Uint_1);
+
+         elsif not Is_Record_Type (Current_Scope) then
+            if Ekind (S) = E_Loop then
+               Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope));
+            else
+               Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1);
+            end if;
+         end if;
+      end if;
+
+      Scope_Stack.Increment_Last;
+
+      declare
+         SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
+
+      begin
+         SST.Entity                         := S;
+         SST.Save_Scope_Suppress            := Scope_Suppress;
+         SST.Save_Local_Entity_Suppress     := Local_Entity_Suppress.Last;
+
+         if Scope_Stack.Last > Scope_Stack.First then
+            SST.Component_Alignment_Default := Scope_Stack.Table
+                                                 (Scope_Stack.Last - 1).
+                                                   Component_Alignment_Default;
+         end if;
+
+         SST.Last_Subprogram_Name           := null;
+         SST.Is_Transient                   := False;
+         SST.Node_To_Be_Wrapped             := Empty;
+         SST.Pending_Freeze_Actions         := No_List;
+         SST.Actions_To_Be_Wrapped_Before   := No_List;
+         SST.Actions_To_Be_Wrapped_After    := No_List;
+         SST.First_Use_Clause               := Empty;
+         SST.Is_Active_Stack_Base           := False;
+         SST.Previous_Visibility            := False;
+      end;
+
+      if Debug_Flag_W then
+         Write_Str ("--> new scope: ");
+         Write_Name (Chars (Current_Scope));
+         Write_Str (", Id=");
+         Write_Int (Int (Current_Scope));
+         Write_Str (", Depth=");
+         Write_Int (Int (Scope_Stack.Last));
+         Write_Eol;
+      end if;
+
+      --  Deal with copying flags from the previous scope to this one. This
+      --  is not necessary if either scope is standard, or if the new scope
+      --  is a child unit.
+
+      if S /= Standard_Standard
+        and then Scope (S) /= Standard_Standard
+        and then not Is_Child_Unit (S)
+      then
+         E := Scope (S);
+
+         if Nkind (E) not in N_Entity then
+            return;
+         end if;
+
+         --  Copy categorization flags from Scope (S) to S, this is not done
+         --  when Scope (S) is Standard_Standard since propagation is from
+         --  library unit entity inwards. Copy other relevant attributes as
+         --  well (Discard_Names in particular).
+
+         --  We only propagate inwards for library level entities,
+         --  inner level subprograms do not inherit the categorization.
+
+         if Is_Library_Level_Entity (S) then
+            Set_Is_Preelaborated  (S, Is_Preelaborated (E));
+            Set_Is_Shared_Passive (S, Is_Shared_Passive (E));
+            Set_Discard_Names     (S, Discard_Names (E));
+            Set_Suppress_Value_Tracking_On_Call
+                                  (S, Suppress_Value_Tracking_On_Call (E));
+            Set_Categorization_From_Scope (E => S, Scop => E);
+         end if;
+      end if;
+   end Push_Scope;
+
    ---------------------
    -- Premature_Usage --
    ---------------------
@@ -5897,7 +6015,7 @@ package body Sem_Ch8 is
 
    function Present_System_Aux (N : Node_Id := Empty) return Boolean is
       Loc      : Source_Ptr;
-      Aux_Name : Name_Id;
+      Aux_Name : Unit_Name_Type;
       Unum     : Unit_Number_Type;
       Withn    : Node_Id;
       With_Sys : Node_Id;
@@ -6104,11 +6222,11 @@ package body Sem_Ch8 is
          end if;
 
          if Is_Child_Unit (S)
-            and not In_Child     --  check only for current unit.
+            and not In_Child     --  check only for current unit
          then
             In_Child := True;
 
-            --  restore visibility of parents according to whether the child
+            --  Restore visibility of parents according to whether the child
             --  is private and whether we are in its visible part.
 
             Comp_Unit := Parent (Unit_Declaration_Node (S));
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index af50d9c..b2141d7 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1999-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1999-2007, 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- --
@@ -26,6 +26,7 @@
 
 with Alloc;
 with Atree;    use Atree;
+with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Errout;   use Errout;
 with Exp_Code; use Exp_Code;
@@ -119,6 +120,377 @@ package body Sem_Warn is
       end if;
    end Check_Code_Statement;
 
+   ---------------------------------
+   -- Check_Infinite_Loop_Warning --
+   ---------------------------------
+
+   --  The case we look for is a while loop which tests a local variable, where
+   --  there is no obvious direct or possible indirect update of the variable
+   --  within the body of the loop.
+
+   procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id) is
+      Iter : constant Node_Id := Iteration_Scheme (Loop_Statement);
+
+      Ref : Node_Id   := Empty;
+      --  Reference in iteration scheme to variable that may not be modified
+      --  in loop, indicating a possible infinite loop.
+
+      Var : Entity_Id := Empty;
+      --  Corresponding entity (entity of Ref)
+
+      procedure Find_Var (N : Node_Id);
+      --  Inspect condition to see if it depends on a single entity
+      --  reference. If so, Ref is set to point to the reference node,
+      --  and Var is set to the referenced Entity.
+
+      function Has_Indirection (T : Entity_Id) return Boolean;
+      --  If the controlling variable is an access type, or is a record type
+      --  with access components, assume that it is changed indirectly and
+      --  suppress the warning. As a concession to low-level programming, in
+      --  particular within Declib, we also suppress warnings on a record
+      --  type that contains components of type Address or Short_Address.
+
+      function Is_Suspicious_Function_Name (E : Entity_Id) return Boolean;
+      --  Given an entity name, see if the name appears to have something to
+      --  do with I/O or network stuff, and if so, return True. Used to kill
+      --  some false positives on a heuristic basis that such functions will
+      --  likely have some strange side effect dependencies. A rather funny
+      --  kludge, but warning messages are in the heuristics business.
+
+      function Test_Ref (N : Node_Id) return Traverse_Result;
+      --  Test for reference to variable in question. Returns Abandon if
+      --  matching reference found.
+
+      function Find_Ref is new Traverse_Func (Test_Ref);
+      --  Function to traverse body of procedure. Returns Abandon if matching
+      --  reference found.
+
+      --------------
+      -- Find_Var --
+      --------------
+
+      procedure Find_Var (N : Node_Id) is
+      begin
+         --  Condition is a direct variable reference
+
+         if Is_Entity_Name (N) then
+            Ref := N;
+            Var := Entity (Ref);
+
+            --  Case of condition is a comparison with compile time known value
+
+         elsif Nkind (N) in N_Op_Compare then
+            if Compile_Time_Known_Value (Right_Opnd (N)) then
+               Find_Var (Left_Opnd (N));
+
+            elsif Compile_Time_Known_Value (Left_Opnd (N)) then
+               Find_Var (Right_Opnd (N));
+
+            --  Ignore any other comparison
+
+            else
+               return;
+            end if;
+
+            --  If condition is a negation, check its operand
+
+         elsif Nkind (N) = N_Op_Not then
+            Find_Var (Right_Opnd (N));
+
+            --  Case of condition is function call
+
+         elsif Nkind (N) = N_Function_Call then
+
+            --  Forget it if function name is not entity, who knows what
+            --  we might be calling?
+
+            if not Is_Entity_Name (Name (N)) then
+               return;
+
+               --  Forget it if warnings are suppressed on function entity
+
+            elsif Warnings_Off (Entity (Name (N))) then
+               return;
+
+               --  Forget it if function name is suspicious. A strange test
+               --  but warning generation is in the heuristics business!
+
+            elsif Is_Suspicious_Function_Name (Entity (Name (N))) then
+               return;
+            end if;
+
+            --  OK, see if we have one argument
+
+            declare
+               PA : constant List_Id := Parameter_Associations (N);
+
+            begin
+               --  One argument, so check the argument
+
+               if Present (PA)
+                 and then List_Length (PA) = 1
+               then
+                  if Nkind (First (PA)) = N_Parameter_Association then
+                     Find_Var (Explicit_Actual_Parameter (First (PA)));
+                  else
+                     Find_Var (First (PA));
+                  end if;
+
+                  --  Not one argument
+
+               else
+                  return;
+               end if;
+            end;
+
+            --  Any other kind of node is not something we warn for
+
+         else
+            return;
+         end if;
+      end Find_Var;
+
+      ---------------------
+      -- Has_Indirection --
+      ---------------------
+
+      function Has_Indirection (T : Entity_Id) return Boolean is
+         Comp : Entity_Id;
+         Rec  : Entity_Id;
+
+      begin
+         if Is_Access_Type (T) then
+            return True;
+
+         elsif Is_Private_Type (T)
+           and then Present (Full_View (T))
+           and then Is_Access_Type (Full_View (T))
+         then
+            return True;
+
+         elsif Is_Record_Type (T) then
+            Rec := T;
+
+         elsif Is_Private_Type (T)
+           and then Present (Full_View (T))
+           and then Is_Record_Type (Full_View (T))
+         then
+            Rec := Full_View (T);
+         else
+            return False;
+         end if;
+
+         Comp := First_Component (Rec);
+         while Present (Comp) loop
+            if Is_Access_Type (Etype (Comp))
+              or else Is_Descendent_Of_Address (Etype (Comp))
+            then
+               return True;
+            end if;
+
+            Next_Component (Comp);
+         end loop;
+
+         return False;
+      end Has_Indirection;
+
+      ---------------------------------
+      -- Is_Suspicious_Function_Name --
+      ---------------------------------
+
+      function Is_Suspicious_Function_Name (E : Entity_Id) return Boolean is
+         S : Entity_Id;
+
+         function Substring_Present (S : String) return Boolean;
+         --  Returns True if name buffer has given string delimited by non-
+         --  alphabetic characters or by end of string. S is lower case.
+
+         -----------------------
+         -- Substring_Present --
+         -----------------------
+
+         function Substring_Present (S : String) return Boolean is
+            Len : constant Natural := S'Length;
+
+         begin
+            for J in 1 .. Name_Len - (Len - 1) loop
+               if Name_Buffer (J .. J + (Len - 1)) = S
+                 and then
+                   (J = 1
+                     or else Name_Buffer (J - 1) not in 'a' .. 'z')
+                 and then
+                   (J + Len > Name_Len
+                     or else Name_Buffer (J + Len) not in 'a' .. 'z')
+               then
+                  return True;
+               end if;
+            end loop;
+
+            return False;
+         end Substring_Present;
+
+         --  Start of processing for Is_Suspicious_Function_Name
+
+      begin
+         S := E;
+         while Present (S) and then S /= Standard_Standard loop
+            Get_Name_String (Chars (S));
+
+            if Substring_Present ("io")
+              or else Substring_Present ("file")
+              or else Substring_Present ("network")
+            then
+               return True;
+            else
+               S := Scope (S);
+            end if;
+         end loop;
+
+         return False;
+      end Is_Suspicious_Function_Name;
+
+      --------------
+      -- Test_Ref --
+      --------------
+
+      function Test_Ref (N : Node_Id) return Traverse_Result is
+      begin
+         --  Waste of time to look at iteration scheme
+
+         if N = Iter then
+            return Skip;
+
+            --  Direct reference to variable in question
+
+         elsif Is_Entity_Name (N)
+           and then Present (Entity (N))
+           and then Entity (N) = Var
+         then
+            --  If this is an Lvalue, then definitely abandon, since
+            --  this could be a direct modification of the variable.
+
+            if May_Be_Lvalue (N) then
+               return Abandon;
+            end if;
+
+            --  If we appear in the context of a procedure call, then also
+            --  abandon, since there may be issues of non-visible side
+            --  effects going on in the call.
+
+            declare
+               P : Node_Id;
+            begin
+               P := N;
+               loop
+                  P := Parent (P);
+                  exit when P = Loop_Statement;
+
+                  if Nkind (P) = N_Procedure_Call_Statement then
+                     return Abandon;
+                  end if;
+               end loop;
+            end;
+
+            --  Reference to variable renaming variable in question
+
+         elsif Is_Entity_Name (N)
+           and then Present (Entity (N))
+           and then Ekind (Entity (N)) = E_Variable
+           and then Present (Renamed_Object (Entity (N)))
+           and then Is_Entity_Name (Renamed_Object (Entity (N)))
+           and then Entity (Renamed_Object (Entity (N))) = Var
+           and then May_Be_Lvalue (N)
+         then
+            return Abandon;
+
+            --  Call to subprogram
+
+         elsif Nkind (N) = N_Procedure_Call_Statement
+           or else Nkind (N) = N_Function_Call
+         then
+            --  If subprogram is within the scope of the entity we are
+            --  dealing with as the loop variable, then it could modify
+            --  this parameter, so we abandon in this case. In the case
+            --  of a subprogram that is not an entity we also abandon.
+
+            if not Is_Entity_Name (Name (N))
+              or else Scope_Within (Entity (Name (N)), Scope (Var))
+            then
+               return Abandon;
+            end if;
+         end if;
+
+         --  All OK, continue scan
+
+         return OK;
+      end Test_Ref;
+
+   --  Start of processing for Check_Infinite_Loop_Warning
+
+   begin
+      --  We need a while iteration with no condition actions. Conditions
+      --  actions just make things too complicated to get the warning right.
+
+      if No (Iter)
+        or else No (Condition (Iter))
+        or else Present (Condition_Actions (Iter))
+        or else Debug_Flag_Dot_W
+      then
+         return;
+      end if;
+
+      --  Initial conditions met, see if condition is of right form
+
+      Find_Var (Condition (Iter));
+
+      --  Nothing to do if local variable from source not found
+
+      if No (Var)
+        or else Ekind (Var) /= E_Variable
+        or else Is_Library_Level_Entity (Var)
+        or else not Comes_From_Source (Var)
+      then
+         return;
+
+      --  Nothing to do if there is some indirection involved (assume that the
+      --  designated variable might be modified in some way we don't see).
+
+      elsif Has_Indirection (Etype (Var)) then
+         return;
+
+      --  Same sort of thing for volatile variable, might be modified by
+      --  some other task or by the operating system in some way.
+
+      elsif Is_Volatile (Var) then
+         return;
+      end if;
+
+      --  Filter out case of original statement sequence starting with delay.
+      --  We assume this is a multi-tasking program and that the condition
+      --  is affected by other threads (some kind of busy wait).
+
+      declare
+         Fstm : constant Node_Id :=
+                  Original_Node (First (Statements (Loop_Statement)));
+      begin
+         if Nkind (Fstm) = N_Delay_Relative_Statement
+           or else Nkind (Fstm) = N_Delay_Until_Statement
+         then
+            return;
+         end if;
+      end;
+
+      --  We have a variable reference of the right form, now we scan the loop
+      --  body to see if it looks like it might not be modified
+
+      if Find_Ref (Loop_Statement) = OK then
+         Error_Msg_NE
+           ("variable& is not modified in loop body?", Ref, Var);
+         Error_Msg_N
+           ("\possible infinite loop", Ref);
+      end if;
+   end Check_Infinite_Loop_Warning;
+
    ----------------------
    -- Check_References --
    ----------------------
@@ -334,10 +706,14 @@ package body Sem_Warn is
       E1 := First_Entity (E);
       while Present (E1) loop
 
-         --  We only look at source entities with warning flag on
-
-         if Comes_From_Source (E1) and then not Warnings_Off (E1) then
+         --  We only look at source entities with warning flag on. We also
+         --  ignore objects whose type or base type has warnings suppressed.
 
+         if Comes_From_Source (E1)
+           and then not Warnings_Off (E1)
+           and then not Warnings_Off (Etype (E1))
+           and then not Warnings_Off (Base_Type (Etype (E1)))
+         then
             --  We are interested in variables and out parameters, but we
             --  exclude protected types, too complicated to worry about.
 
@@ -629,6 +1005,14 @@ package body Sem_Warn is
                and then (Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit
                            or else
                          Get_Source_Unit (E1) = Main_Unit)
+
+               --  No warning on a return object, because these are often
+               --  created with a single expression and an implicit return.
+               --  If the object is a variable there will be a warning
+               --  indicating that it could be declared constant.
+
+               and then not
+                 (Ekind (E1) = E_Constant and then Is_Return_Object (E1))
             then
                --  Suppress warnings in internal units if not in -gnatg mode
                --  (these would be junk warnings for an applications program,
@@ -870,7 +1254,7 @@ package body Sem_Warn is
                               return;
                            end if;
 
-                           --  We are only interested in deferences
+                           --  We are only interested in dereferences
 
                            if not Is_Dereferenced (N) then
                               return;
@@ -1741,6 +2125,18 @@ package body Sem_Warn is
    function Set_Dot_Warning_Switch (C : Character) return Boolean is
    begin
       case C is
+         when 'c' =>
+            Warn_On_Unrepped_Components         := True;
+
+         when 'C' =>
+            Warn_On_Unrepped_Components         := False;
+
+         when 'r' =>
+            Warn_On_Object_Renames_Function     := True;
+
+         when 'R' =>
+            Warn_On_Object_Renames_Function     := False;
+
          when 'x' =>
             Warn_On_Non_Local_Exception         := True;
 
@@ -1779,8 +2175,10 @@ package body Sem_Warn is
             Warn_On_Obsolescent_Feature         := True;
             Warn_On_Questionable_Missing_Parens := True;
             Warn_On_Redundant_Constructs        := True;
+            Warn_On_Object_Renames_Function     := True;
             Warn_On_Unchecked_Conversion        := True;
             Warn_On_Unrecognized_Pragma         := True;
+            Warn_On_Unrepped_Components         := True;
 
          when 'A' =>
             Check_Unreferenced                  := False;
@@ -1803,8 +2201,10 @@ package body Sem_Warn is
             Warn_On_Obsolescent_Feature         := False;
             Warn_On_Questionable_Missing_Parens := False;
             Warn_On_Redundant_Constructs        := False;
+            Warn_On_Object_Renames_Function     := False;
             Warn_On_Unchecked_Conversion        := False;
             Warn_On_Unrecognized_Pragma         := False;
+            Warn_On_Unrepped_Components         := False;
 
          when 'b' =>
             Warn_On_Bad_Fixed_Value             := True;
diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads
index efc747c..86c36a9 100644
--- a/gcc/ada/sem_warn.ads
+++ b/gcc/ada/sem_warn.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1999-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1999-2007, 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- --
@@ -120,7 +120,11 @@ package Sem_Warn is
    ----------------------------
 
    procedure Check_Code_Statement (N : Node_Id);
-   --  Peform warning checks on a code statement node
+   --  Perform warning checks on a code statement node
+
+   procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id);
+   --  N is the node for a loop statement. This procedure checks if a warning
+   --  should be given for a possible infinite loop, and if so issues it.
 
    procedure Warn_On_Known_Condition (C : Node_Id);
    --  C is a node for a boolean expression resluting from a relational