diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 20 | ||||
| -rw-r--r-- | gcc/ada/adaint.c | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/g-socket.ads | 50 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 135 |
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 |