[multiple changes]

2010-06-18  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch6.adb: Add extra guard.

2010-06-18  Gary Dismukes  <dismukes@adacore.com>

	* sem_util.adb (Object_Access_Level): For Ada 2005, determine the
	accessibility level of a function call from the level of the innermost
	enclosing dynamic scope.
	(Innermost_Master_Scope_Depth): New function to find the depth of the
	nearest dynamic scope enclosing a node.

2010-06-18  Tristan Gingold  <gingold@adacore.com>

	* adaint.c: Make ATTR_UNSET static as it is not used outside this file.

2010-06-18  Thomas Quinot  <quinot@adacore.com>

	* g-socket.ads: Minor reformatting.

From-SVN: r160964

5 files changed, 166 insertions, 44 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 5577d77..816b578 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,23 @@
+2010-06-18  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch6.adb: Add extra guard.
+
+2010-06-18  Gary Dismukes  <dismukes@adacore.com>
+
+	* sem_util.adb (Object_Access_Level): For Ada 2005, determine the
+	accessibility level of a function call from the level of the innermost
+	enclosing dynamic scope.
+	(Innermost_Master_Scope_Depth): New function to find the depth of the
+	nearest dynamic scope enclosing a node.
+
+2010-06-18  Tristan Gingold  <gingold@adacore.com>
+
+	* adaint.c: Make ATTR_UNSET static as it is not used outside this file.
+
+2010-06-18  Thomas Quinot  <quinot@adacore.com>
+
+	* g-socket.ads: Minor reformatting.
+
 2010-06-18  Vincent Celier  <celier@adacore.com>
 
 	* make.adb (Must_Compile): New Boolean global variable
diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c
index d73f63db..5ceedd0 100644
--- a/gcc/ada/adaint.c
+++ b/gcc/ada/adaint.c
@@ -6,7 +6,7 @@
  *                                                                          *
  *                          C Implementation File                           *
  *                                                                          *
- *          Copyright (C) 1992-2009, Free Software Foundation, Inc.         *
+ *          Copyright (C) 1992-2010, 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- *
@@ -377,7 +377,7 @@ to_ptr32 (char **ptr64)
 #define MAYBE_TO_PTR32(argv) argv
 #endif
 
-const char ATTR_UNSET = 127;
+static const char ATTR_UNSET = 127;
 
 void
 __gnat_reset_attributes
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 5a36234..08f7d7c 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -3396,6 +3396,7 @@ package body Exp_Ch6 is
             return Skip;
 
          elsif Is_Entity_Name (N)
+           and then Present (Return_Object)
            and then Chars (N) = Chars (Return_Object)
          then
             --  Occurrence within an extended return statement. The return
diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads
index d81f7da..b7030c2 100644
--- a/gcc/ada/g-socket.ads
+++ b/gcc/ada/g-socket.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---                     Copyright (C) 2001-2009, AdaCore                     --
+--                     Copyright (C) 2001-2010, 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- --
@@ -664,33 +664,33 @@ package GNAT.Sockets is
    --  with a socket. Options may exist at multiple protocol levels in the
    --  communication stack. Socket_Level is the uppermost socket level.
 
-   type Level_Type is (
-     Socket_Level,
-     IP_Protocol_For_IP_Level,
-     IP_Protocol_For_UDP_Level,
-     IP_Protocol_For_TCP_Level);
+   type Level_Type is
+     (Socket_Level,
+      IP_Protocol_For_IP_Level,
+      IP_Protocol_For_UDP_Level,
+      IP_Protocol_For_TCP_Level);
 
    --  There are several options available to manipulate sockets. Each option
    --  has a name and several values available. Most of the time, the value is
    --  a boolean to enable or disable this option.
 
-   type Option_Name is (
-     Keep_Alive,          -- Enable sending of keep-alive messages
-     Reuse_Address,       -- Allow bind to reuse local address
-     Broadcast,           -- Enable datagram sockets to recv/send broadcasts
-     Send_Buffer,         -- Set/get the maximum socket send buffer in bytes
-     Receive_Buffer,      -- Set/get the maximum socket recv buffer in bytes
-     Linger,              -- Shutdown wait for msg to be sent or timeout occur
-     Error,               -- Get and clear the pending socket error
-     No_Delay,            -- Do not delay send to coalesce data (TCP_NODELAY)
-     Add_Membership,      -- Join a multicast group
-     Drop_Membership,     -- Leave a multicast group
-     Multicast_If,        -- Set default out interface for multicast packets
-     Multicast_TTL,       -- Set the time-to-live of sent multicast packets
-     Multicast_Loop,      -- Sent multicast packets are looped to local socket
-     Receive_Packet_Info, -- Receive low level packet info as ancillary data
-     Send_Timeout,        -- Set timeout value for output
-     Receive_Timeout);    -- Set timeout value for input
+   type Option_Name is
+     (Keep_Alive,          -- Enable sending of keep-alive messages
+      Reuse_Address,       -- Allow bind to reuse local address
+      Broadcast,           -- Enable datagram sockets to recv/send broadcasts
+      Send_Buffer,         -- Set/get the maximum socket send buffer in bytes
+      Receive_Buffer,      -- Set/get the maximum socket recv buffer in bytes
+      Linger,              -- Shutdown wait for msg to be sent or timeout occur
+      Error,               -- Get and clear the pending socket error
+      No_Delay,            -- Do not delay send to coalesce data (TCP_NODELAY)
+      Add_Membership,      -- Join a multicast group
+      Drop_Membership,     -- Leave a multicast group
+      Multicast_If,        -- Set default out interface for multicast packets
+      Multicast_TTL,       -- Set the time-to-live of sent multicast packets
+      Multicast_Loop,      -- Sent multicast packets are looped to local socket
+      Receive_Packet_Info, -- Receive low level packet info as ancillary data
+      Send_Timeout,        -- Set timeout value for output
+      Receive_Timeout);    -- Set timeout value for input
 
    type Option_Type (Name : Option_Name := Keep_Alive) is record
       case Name is
@@ -740,8 +740,8 @@ package GNAT.Sockets is
    --  socket options in that they are not specific to sockets but are
    --  available for any device.
 
-   type Request_Name is (
-      Non_Blocking_IO,  --  Cause a caller not to wait on blocking operations.
+   type Request_Name is
+     (Non_Blocking_IO,  --  Cause a caller not to wait on blocking operations
       N_Bytes_To_Read); --  Return the number of bytes available to read
 
    type Request_Type (Name : Request_Name := Non_Blocking_IO) is record
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index cc25e34..fb193a5 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, 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- --
@@ -9299,7 +9299,8 @@ package body Sem_Util is
                  or else Modification_Comes_From_Source
                then
                   if Has_Pragma_Unmodified (Ent) then
-                     Error_Msg_NE ("?pragma Unmodified given for &!", N, Ent);
+                     Error_Msg_NE -- CODEFIX???
+                       ("?pragma Unmodified given for &!", N, Ent);
                   end if;
 
                   Set_Never_Set_In_Source (Ent, False);
@@ -9354,7 +9355,7 @@ package body Sem_Util is
                           and then Is_Entity_Name (Prefix (Exp))
                         then
                            Error_Msg_Sloc := Sloc (A);
-                           Error_Msg_NE
+                           Error_Msg_NE -- CODEFIX???
                              ("constant& may be modified via address clause#?",
                               N, Entity (Prefix (Exp)));
                         end if;
@@ -9493,15 +9494,112 @@ package body Sem_Util is
       then
          return Object_Access_Level (Expression (Obj));
 
-      --  Function results are objects, so we get either the access level of
-      --  the function or, in the case of an indirect call, the level of the
-      --  access-to-subprogram type.
-
       elsif Nkind (Obj) = N_Function_Call then
-         if Is_Entity_Name (Name (Obj)) then
-            return Subprogram_Access_Level (Entity (Name (Obj)));
+
+         --  Function results are objects, so we get either the access level of
+         --  the function or, in the case of an indirect call, the level of the
+         --  access-to-subprogram type. (This code is used for Ada 95, but it
+         --  looks wrong, because it seems that we should be checking the level
+         --  of the call itself, even for Ada 95. However, using the Ada 2005
+         --  version of the code causes regressions in several tests that are
+         --  compiled with -gnat95. ???)
+
+         if Ada_Version < Ada_05 then
+            if Is_Entity_Name (Name (Obj)) then
+               return Subprogram_Access_Level (Entity (Name (Obj)));
+            else
+               return Type_Access_Level (Etype (Prefix (Name (Obj))));
+            end if;
+
+         --  For Ada 2005, the level of the result object of a function call is
+         --  defined to be the level of the call's innermost enclosing master.
+         --  We determine that by querying the depth of the innermost enclosing
+         --  dynamic scope.
+
          else
-            return Type_Access_Level (Etype (Prefix (Name (Obj))));
+            Return_Master_Scope_Depth_Of_Call : declare
+
+               function Innermost_Master_Scope_Depth
+                 (N : Node_Id) return Uint;
+               --  Returns the scope depth of the given node's innermost
+               --  enclosing dynamic scope (effectively the accessibility
+               --  level of the innermost enclosing master).
+
+               ----------------------------------
+               -- Innermost_Master_Scope_Depth --
+               ----------------------------------
+
+               function Innermost_Master_Scope_Depth
+                 (N : Node_Id) return Uint
+               is
+                  Node_Par : Node_Id := Parent (N);
+
+               begin
+                  --  Locate the nearest enclosing node (by traversing Parents)
+                  --  that Defining_Entity can be applied to, and return the
+                  --  depth of that entity's nearest enclosing dynamic scope.
+
+                  while Present (Node_Par) loop
+                     case Nkind (Node_Par) is
+                        when N_Component_Declaration           |
+                             N_Entry_Declaration               |
+                             N_Formal_Object_Declaration       |
+                             N_Formal_Type_Declaration         |
+                             N_Full_Type_Declaration           |
+                             N_Incomplete_Type_Declaration     |
+                             N_Loop_Parameter_Specification    |
+                             N_Object_Declaration              |
+                             N_Protected_Type_Declaration      |
+                             N_Private_Extension_Declaration   |
+                             N_Private_Type_Declaration        |
+                             N_Subtype_Declaration             |
+                             N_Function_Specification          |
+                             N_Procedure_Specification         |
+                             N_Task_Type_Declaration           |
+                             N_Body_Stub                       |
+                             N_Generic_Instantiation           |
+                             N_Proper_Body                     |
+                             N_Implicit_Label_Declaration      |
+                             N_Package_Declaration             |
+                             N_Single_Task_Declaration         |
+                             N_Subprogram_Declaration          |
+                             N_Generic_Declaration             |
+                             N_Renaming_Declaration            |
+                             N_Block_Statement                 |
+                             N_Formal_Subprogram_Declaration   |
+                             N_Abstract_Subprogram_Declaration |
+                             N_Entry_Body                      |
+                             N_Exception_Declaration           |
+                             N_Formal_Package_Declaration      |
+                             N_Number_Declaration              |
+                             N_Package_Specification           |
+                             N_Parameter_Specification         |
+                             N_Single_Protected_Declaration    |
+                             N_Subunit                         =>
+
+                           return Scope_Depth
+                                    (Nearest_Dynamic_Scope
+                                       (Defining_Entity (Node_Par)));
+
+                        when others =>
+                           null;
+                     end case;
+
+                     Node_Par := Parent (Node_Par);
+                  end loop;
+
+                  pragma Assert (False);
+
+                  --  Should never reach the following return
+
+                  return Scope_Depth (Current_Scope) + 1;
+               end Innermost_Master_Scope_Depth;
+
+            --  Start of processing for Return_Master_Scope_Depth_Of_Call
+
+            begin
+               return Innermost_Master_Scope_Depth (Obj);
+            end Return_Master_Scope_Depth_Of_Call;
          end if;
 
       --  For convenience we handle qualified expressions, even though
@@ -11241,8 +11339,10 @@ package body Sem_Util is
         and then Covers
           (Designated_Type (Expec_Type), Designated_Type (Found_Type))
       then
-         Error_Msg_N ("result must be general access type!", Expr);
-         Error_Msg_NE ("add ALL to }!", Expr, Expec_Type);
+         Error_Msg_N -- CODEFIX
+           ("result must be general access type!", Expr);
+         Error_Msg_NE -- CODEFIX
+           ("add ALL to }!", Expr, Expec_Type);
 
       --  Another special check, if the expected type is an integer type,
       --  but the expression is of type System.Address, and the parent is
@@ -11262,7 +11362,7 @@ package body Sem_Util is
          Error_Msg_N
            ("address arithmetic not predefined in package System",
             Parent (Expr));
-         Error_Msg_N
+         Error_Msg_N -- CODEFIX???
            ("\possible missing with/use of System.Storage_Elements",
             Parent (Expr));
          return;
@@ -11289,7 +11389,8 @@ package body Sem_Util is
             if From_With_Type (Found_Type) then
                Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
                Error_Msg_Qual_Level := 99;
-               Error_Msg_NE ("\\missing `WITH &;", Expr, Scope (Found_Type));
+               Error_Msg_NE -- CODEFIX
+                 ("\\missing `WITH &;", Expr, Scope (Found_Type));
                Error_Msg_Qual_Level := 0;
             else
                Error_Msg_NE ("found}!", Expr, Found_Type);
@@ -11350,7 +11451,7 @@ package body Sem_Util is
               Ekind (Entity (Expr)) = E_Generic_Procedure)
          then
             if Ekind (Expec_Type) = E_Access_Subprogram_Type then
-               Error_Msg_N
+               Error_Msg_N -- CODEFIX???
                  ("found procedure name, possibly missing Access attribute!",
                    Expr);
             else
@@ -11363,7 +11464,7 @@ package body Sem_Util is
            and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
            and then No (Parameter_Associations (Expr))
          then
-            Error_Msg_N
+            Error_Msg_N -- CODEFIX???
               ("found function name, possibly missing Access attribute!",
                Expr);
 
@@ -11377,7 +11478,7 @@ package body Sem_Util is
             and then not In_Use (Expec_Type)
             and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
          then
-            Error_Msg_N
+            Error_Msg_N -- CODEFIX???
               ("operator of the type is not directly visible!", Expr);
 
          elsif Ekind (Found_Type) = E_Void