Skip to content

R
riscv-gcc-1
Commit 9f5b6c7f by Arnaud Charlet
Options

[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
parent 3e2399ba
Showing with 166 additions and 44 deletions
gcc/ada/ChangeLog
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> 2010-06-18 Vincent Celier <celier@adacore.com>
* make.adb (Must_Compile): New Boolean global variable * make.adb (Must_Compile): New Boolean global variable
......
gcc/ada/adaint.c
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Implementation File * * 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 * * 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- * * terms of the GNU General Public License as published by the Free Soft- *
...@@ -377,7 +377,7 @@ to_ptr32 (char **ptr64) ...@@ -377,7 +377,7 @@ to_ptr32 (char **ptr64)
#define MAYBE_TO_PTR32(argv) argv #define MAYBE_TO_PTR32(argv) argv
#endif #endif
const char ATTR_UNSET = 127; static const char ATTR_UNSET = 127;
void void
__gnat_reset_attributes __gnat_reset_attributes
......
gcc/ada/exp_ch6.adb
...@@ -3396,6 +3396,7 @@ package body Exp_Ch6 is ...@@ -3396,6 +3396,7 @@ package body Exp_Ch6 is
return Skip; return Skip;
elsif Is_Entity_Name (N) elsif Is_Entity_Name (N)
and then Present (Return_Object)
and then Chars (N) = Chars (Return_Object) and then Chars (N) = Chars (Return_Object)
then then
-- Occurrence within an extended return statement. The return -- Occurrence within an extended return statement. The return
......
gcc/ada/g-socket.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -664,33 +664,33 @@ package GNAT.Sockets is ...@@ -664,33 +664,33 @@ package GNAT.Sockets is
-- with a socket. Options may exist at multiple protocol levels in the -- with a socket. Options may exist at multiple protocol levels in the
-- communication stack. Socket_Level is the uppermost socket level. -- communication stack. Socket_Level is the uppermost socket level.
type Level_Type is ( type Level_Type is
Socket_Level, (Socket_Level,
IP_Protocol_For_IP_Level, IP_Protocol_For_IP_Level,
IP_Protocol_For_UDP_Level, IP_Protocol_For_UDP_Level,
IP_Protocol_For_TCP_Level); IP_Protocol_For_TCP_Level);
-- There are several options available to manipulate sockets. Each option -- There are several options available to manipulate sockets. Each option
-- has a name and several values available. Most of the time, the value is -- has a name and several values available. Most of the time, the value is
-- a boolean to enable or disable this option. -- a boolean to enable or disable this option.
type Option_Name is ( type Option_Name is
Keep_Alive, -- Enable sending of keep-alive messages (Keep_Alive, -- Enable sending of keep-alive messages
Reuse_Address, -- Allow bind to reuse local address Reuse_Address, -- Allow bind to reuse local address
Broadcast, -- Enable datagram sockets to recv/send broadcasts Broadcast, -- Enable datagram sockets to recv/send broadcasts
Send_Buffer, -- Set/get the maximum socket send buffer in bytes Send_Buffer, -- Set/get the maximum socket send buffer in bytes
Receive_Buffer, -- Set/get the maximum socket recv 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 Linger, -- Shutdown wait for msg to be sent or timeout occur
Error, -- Get and clear the pending socket error Error, -- Get and clear the pending socket error
No_Delay, -- Do not delay send to coalesce data (TCP_NODELAY) No_Delay, -- Do not delay send to coalesce data (TCP_NODELAY)
Add_Membership, -- Join a multicast group Add_Membership, -- Join a multicast group
Drop_Membership, -- Leave a multicast group Drop_Membership, -- Leave a multicast group
Multicast_If, -- Set default out interface for multicast packets Multicast_If, -- Set default out interface for multicast packets
Multicast_TTL, -- Set the time-to-live of sent multicast packets Multicast_TTL, -- Set the time-to-live of sent multicast packets
Multicast_Loop, -- Sent multicast packets are looped to local socket Multicast_Loop, -- Sent multicast packets are looped to local socket
Receive_Packet_Info, -- Receive low level packet info as ancillary data Receive_Packet_Info, -- Receive low level packet info as ancillary data
Send_Timeout, -- Set timeout value for output Send_Timeout, -- Set timeout value for output
Receive_Timeout); -- Set timeout value for input Receive_Timeout); -- Set timeout value for input
type Option_Type (Name : Option_Name := Keep_Alive) is record type Option_Type (Name : Option_Name := Keep_Alive) is record
case Name is case Name is
...@@ -740,8 +740,8 @@ package GNAT.Sockets is ...@@ -740,8 +740,8 @@ package GNAT.Sockets is
-- socket options in that they are not specific to sockets but are -- socket options in that they are not specific to sockets but are
-- available for any device. -- available for any device.
type Request_Name is ( type Request_Name is
Non_Blocking_IO, -- Cause a caller not to wait on blocking operations. (Non_Blocking_IO, -- Cause a caller not to wait on blocking operations
N_Bytes_To_Read); -- Return the number of bytes available to read N_Bytes_To_Read); -- Return the number of bytes available to read
type Request_Type (Name : Request_Name := Non_Blocking_IO) is record type Request_Type (Name : Request_Name := Non_Blocking_IO) is record
......
gcc/ada/sem_util.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -9299,7 +9299,8 @@ package body Sem_Util is ...@@ -9299,7 +9299,8 @@ package body Sem_Util is
or else Modification_Comes_From_Source or else Modification_Comes_From_Source
then then
if Has_Pragma_Unmodified (Ent) 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; end if;
Set_Never_Set_In_Source (Ent, False); Set_Never_Set_In_Source (Ent, False);
...@@ -9354,7 +9355,7 @@ package body Sem_Util is ...@@ -9354,7 +9355,7 @@ package body Sem_Util is
and then Is_Entity_Name (Prefix (Exp)) and then Is_Entity_Name (Prefix (Exp))
then then
Error_Msg_Sloc := Sloc (A); Error_Msg_Sloc := Sloc (A);
Error_Msg_NE Error_Msg_NE -- CODEFIX???
("constant& may be modified via address clause#?", ("constant& may be modified via address clause#?",
N, Entity (Prefix (Exp))); N, Entity (Prefix (Exp)));
end if; end if;
...@@ -9493,15 +9494,112 @@ package body Sem_Util is ...@@ -9493,15 +9494,112 @@ package body Sem_Util is
then then
return Object_Access_Level (Expression (Obj)); 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 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 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; end if;
-- For convenience we handle qualified expressions, even though -- For convenience we handle qualified expressions, even though
...@@ -11241,8 +11339,10 @@ package body Sem_Util is ...@@ -11241,8 +11339,10 @@ package body Sem_Util is
and then Covers and then Covers
(Designated_Type (Expec_Type), Designated_Type (Found_Type)) (Designated_Type (Expec_Type), Designated_Type (Found_Type))
then then
Error_Msg_N ("result must be general access type!", Expr); Error_Msg_N -- CODEFIX
Error_Msg_NE ("add ALL to }!", Expr, Expec_Type); ("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, -- Another special check, if the expected type is an integer type,
-- but the expression is of type System.Address, and the parent is -- but the expression is of type System.Address, and the parent is
...@@ -11262,7 +11362,7 @@ package body Sem_Util is ...@@ -11262,7 +11362,7 @@ package body Sem_Util is
Error_Msg_N Error_Msg_N
("address arithmetic not predefined in package System", ("address arithmetic not predefined in package System",
Parent (Expr)); Parent (Expr));
Error_Msg_N Error_Msg_N -- CODEFIX???
("\possible missing with/use of System.Storage_Elements", ("\possible missing with/use of System.Storage_Elements",
Parent (Expr)); Parent (Expr));
return; return;
...@@ -11289,7 +11389,8 @@ package body Sem_Util is ...@@ -11289,7 +11389,8 @@ package body Sem_Util is
if From_With_Type (Found_Type) then if From_With_Type (Found_Type) then
Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
Error_Msg_Qual_Level := 99; 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; Error_Msg_Qual_Level := 0;
else else
Error_Msg_NE ("found}!", Expr, Found_Type); Error_Msg_NE ("found}!", Expr, Found_Type);
...@@ -11350,7 +11451,7 @@ package body Sem_Util is ...@@ -11350,7 +11451,7 @@ package body Sem_Util is
Ekind (Entity (Expr)) = E_Generic_Procedure) Ekind (Entity (Expr)) = E_Generic_Procedure)
then then
if Ekind (Expec_Type) = E_Access_Subprogram_Type then if Ekind (Expec_Type) = E_Access_Subprogram_Type then
Error_Msg_N Error_Msg_N -- CODEFIX???
("found procedure name, possibly missing Access attribute!", ("found procedure name, possibly missing Access attribute!",
Expr); Expr);
else else
...@@ -11363,7 +11464,7 @@ package body Sem_Util is ...@@ -11363,7 +11464,7 @@ package body Sem_Util is
and then Etype (Designated_Type (Expec_Type)) = Etype (Expr) and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
and then No (Parameter_Associations (Expr)) and then No (Parameter_Associations (Expr))
then then
Error_Msg_N Error_Msg_N -- CODEFIX???
("found function name, possibly missing Access attribute!", ("found function name, possibly missing Access attribute!",
Expr); Expr);
...@@ -11377,7 +11478,7 @@ package body Sem_Util is ...@@ -11377,7 +11478,7 @@ package body Sem_Util is
and then not In_Use (Expec_Type) and then not In_Use (Expec_Type)
and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type) and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
then then
Error_Msg_N Error_Msg_N -- CODEFIX???
("operator of the type is not directly visible!", Expr); ("operator of the type is not directly visible!", Expr);
elsif Ekind (Found_Type) = E_Void elsif Ekind (Found_Type) = E_Void
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment