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>
* make.adb (Must_Compile): New Boolean global variable
......
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
......
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
......
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
......
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
......
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