mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-11 13:01:20 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2014-01-31  Robert Dewar  <dewar@adacore.com>

	* sem_ch4.adb: Minor reformatting.

2014-01-31  Robert Dewar  <dewar@adacore.com>

	* exp_ch2.adb: New calling sequence for Is_LHS.
	* frontend.adb: Add call to Process_Deferred_References.
	* lib-xref.ads, lib-xref.adb (Process_Deferred_References): New.
	(Deferred_References): New table.
	* sem_ch8.adb (Find_Direct_Name): Make deferred reference table
	entries.
	(Find_Expanded_Name): Ditto.
	* sem_res.adb: New calling sequence for Is_LHS.
	* sem_util.ads, sem_util.adb (Is_LHS): New calling sequence.
	* sem_warn.adb: Call Process_Deferred_References before issuing
	warnings.

2014-01-31  Tristan Gingold  <gingold@adacore.com>

	* exp_util.adb (Corresponding_Runtime_Package): Restrict the
	use of System_Tasking_Protected_Objects_Single_Entry.
	* exp_ch9.adb (Build_Simple_Entry_Call): Remove Mode parameter
	of Protected_Single_Entry_Call.
	(Expand_N_Timed_Entry_Call): Remove single_entry case.
	* exp_disp.adb (Make_Disp_Asynchronous_Select_Body): Remove
	single_entry case.
	(Make_Disp_Timed_Select_Body): Likewise.
	* rtsfind.ads (RE_Timed_Protected_Single_Entry_Call): Remove.
	* s-tposen.adb (Send_Program_Error, PO_Do_Or_Queue): Remove
	Self_Id parameter.
	(Wakeup_Entry_Caller): Remove Self_ID and New_State parameters.
	(Wait_For_Completion_With_Timeout): Remove.
	(Protected_Single_Entry_Call): Remove Mode parameter
	(always Simple_Call).
	(Service_Entry): Remove Self_Id constant (not used anymore).
	(Timed_Protected_Single_Entry_Call): Remove.
	* s-tposen.ads (Timed_Protected_Single_Entry_Call): Remove.
	(Protected_Single_Entry_Call): Remove Mode parameter.

From-SVN: r207349
This commit is contained in:
Arnaud Charlet 2014-01-31 16:39:17 +01:00
parent 408249b2e2
commit a54ffd6cb9
17 changed files with 215 additions and 335 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
gcc/ada/ChangeLog
View File

@ -1,3 +1,43 @@
2014-01-31 Robert Dewar <dewar@adacore.com>
* sem_ch4.adb: Minor reformatting.
2014-01-31 Robert Dewar <dewar@adacore.com>
* exp_ch2.adb: New calling sequence for Is_LHS.
* frontend.adb: Add call to Process_Deferred_References.
* lib-xref.ads, lib-xref.adb (Process_Deferred_References): New.
(Deferred_References): New table.
* sem_ch8.adb (Find_Direct_Name): Make deferred reference table
entries.
(Find_Expanded_Name): Ditto.
* sem_res.adb: New calling sequence for Is_LHS.
* sem_util.ads, sem_util.adb (Is_LHS): New calling sequence.
* sem_warn.adb: Call Process_Deferred_References before issuing
warnings.
2014-01-31 Tristan Gingold <gingold@adacore.com>
* exp_util.adb (Corresponding_Runtime_Package): Restrict the
use of System_Tasking_Protected_Objects_Single_Entry.
* exp_ch9.adb (Build_Simple_Entry_Call): Remove Mode parameter
of Protected_Single_Entry_Call.
(Expand_N_Timed_Entry_Call): Remove single_entry case.
* exp_disp.adb (Make_Disp_Asynchronous_Select_Body): Remove
single_entry case.
(Make_Disp_Timed_Select_Body): Likewise.
* rtsfind.ads (RE_Timed_Protected_Single_Entry_Call): Remove.
* s-tposen.adb (Send_Program_Error, PO_Do_Or_Queue): Remove
Self_Id parameter.
(Wakeup_Entry_Caller): Remove Self_ID and New_State parameters.
(Wait_For_Completion_With_Timeout): Remove.
(Protected_Single_Entry_Call): Remove Mode parameter
(always Simple_Call).
(Service_Entry): Remove Self_Id constant (not used anymore).
(Timed_Protected_Single_Entry_Call): Remove.
* s-tposen.ads (Timed_Protected_Single_Entry_Call): Remove.
(Protected_Single_Entry_Call): Remove Mode parameter.
2014-01-29 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.adb (Get_Pragma): Handle the retrieval of pragma Refined_Post.

2
gcc/ada/exp_ch2.adb
View File

@ -380,7 +380,7 @@ package body Exp_Ch2 is
and then Is_Scalar_Type (Etype (N))
and then (Is_Assignable (E) or else Is_Constant_Object (E))
and then Comes_From_Source (N)
and then not Is_LHS (N)
and then Is_LHS (N) = No
and then not Is_Actual_Out_Parameter (N)
and then (Nkind (Parent (N)) /= N_Attribute_Reference
or else Attribute_Name (Parent (N)) /= Name_Valid)

34
gcc/ada/exp_ch9.adb
View File

@ -4682,12 +4682,10 @@ package body Exp_Ch9 is
-- family index expressions are evaluated before the entry
-- parameters.
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else not Is_Protected_Type (Conctyp)
or else Number_Entries (Conctyp) > 1
or else (Has_Attach_Handler (Conctyp)
and then not Restricted_Profile)
if not Is_Protected_Type (Conctyp)
or else
Corresponding_Runtime_Package (Conctyp) =
System_Tasking_Protected_Objects_Entries
then
X := Make_Defining_Identifier (Loc, Name_uX);
@ -4902,8 +4900,7 @@ package body Exp_Ch9 is
when System_Tasking_Protected_Objects_Single_Entry =>
-- Protected_Single_Entry_Call (
-- Object => po._object'Access,
-- Uninterpreted_Data => P'Address;
-- Mode => Simple_Call);
-- Uninterpreted_Data => P'Address);
Call :=
Make_Procedure_Call_Statement (Loc,
@ -4914,8 +4911,7 @@ package body Exp_Ch9 is
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unchecked_Access,
Prefix => Parm1),
Parm3,
New_Reference_To (RTE (RE_Simple_Call), Loc)));
Parm3));
when others =>
raise Program_Error;
@ -12481,24 +12477,6 @@ package body Exp_Ch9 is
(RTE (RE_Timed_Protected_Entry_Call), Loc),
Parameter_Associations => Params));
when System_Tasking_Protected_Objects_Single_Entry =>
Param := First (Params);
while Present (Param)
and then not
Is_RTE (Etype (Param), RE_Protected_Entry_Index)
loop
Next (Param);
end loop;
Remove (Param);
Rewrite (Call,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To
(RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
Parameter_Associations => Params));
when others =>
raise Program_Error;
end case;

47
gcc/ada/exp_disp.adb
View File

@ -2337,30 +2337,6 @@ package body Exp_Disp is
New_Reference_To (Com_Block, Loc)))); -- comm block
when System_Tasking_Protected_Objects_Single_Entry =>
-- Generate:
-- procedure Protected_Single_Entry_Call
-- (Object : Protection_Entry_Access;
-- Uninterpreted_Data : System.Address;
-- Mode : Call_Modes);
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To
(RTE (RE_Protected_Single_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Obj_Ref,
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uP),
Attribute_Name => Name_Address),
New_Reference_To
(RTE (RE_Asynchronous_Call), Loc))));
when others =>
raise Program_Error;
end case;
@ -3569,29 +3545,6 @@ package body Exp_Disp is
Make_Identifier (Loc, Name_uM), -- delay mode
Make_Identifier (Loc, Name_uF)))); -- status flag
when System_Tasking_Protected_Objects_Single_Entry =>
-- Generate:
-- Timed_Protected_Single_Entry_Call
-- (T._object'access, P, D, M, F);
-- where T is the protected object, P is the wrapped
-- parameters, D is the delay amount, M is the delay mode, F
-- is the status flag.
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To
(RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
Parameter_Associations =>
New_List (
Obj_Ref,
Make_Identifier (Loc, Name_uP), -- parameter block
Make_Identifier (Loc, Name_uD), -- delay
Make_Identifier (Loc, Name_uM), -- delay mode
Make_Identifier (Loc, Name_uF)))); -- status flag
when others =>
raise Program_Error;
end case;

1
gcc/ada/exp_util.adb
View File

@ -1646,6 +1646,7 @@ package body Exp_Util is
then
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
or else Restriction_Active (No_Select_Statements) = False
or else Number_Entries (Typ) > 1
or else (Has_Attach_Handler (Typ)
and then not Restricted_Profile)

2
gcc/ada/frontend.adb
View File

@ -36,6 +36,7 @@ with Fname.UF;
with Inline; use Inline;
with Lib; use Lib;
with Lib.Load; use Lib.Load;
with Lib.Xref; use Lib.Xref;
with Live; use Live;
with Namet; use Namet;
with Nlists; use Nlists;
@ -392,6 +393,7 @@ begin
-- Output waiting warning messages
Lib.Xref.Process_Deferred_References;
Sem_Warn.Output_Non_Modified_In_Out_Warnings;
Sem_Warn.Output_Unreferenced_Messages;
Sem_Warn.Check_Unused_Withs;

36
gcc/ada/lib-xref.adb
View File

@ -1705,8 +1705,8 @@ package body Lib.Xref is
end loop;
end Handle_Orphan_Type_References;
-- Now we have all the references, including those for any embedded
-- type references, so we can sort them, and output them.
-- Now we have all the references, including those for any embedded type
-- references, so we can sort them, and output them.
Output_Refs : declare
@ -2563,6 +2563,38 @@ package body Lib.Xref is
end Output_Refs;
end Output_References;
---------------------------------
-- Process_Deferred_References --
---------------------------------
procedure Process_Deferred_References is
begin
for J in Deferred_References.First .. Deferred_References.Last loop
declare
D : Deferred_Reference_Entry renames Deferred_References.Table (J);
begin
case Is_LHS (D.N) is
when Yes =>
Generate_Reference (D.E, D.N, 'm');
when No =>
Generate_Reference (D.E, D.N, 'r');
-- Not clear if Unknown can occur at this stage, but if it
-- does we will treat it as a normal reference.
when Unknown =>
Generate_Reference (D.E, D.N, 'r');
end case;
end;
end loop;
-- Clear processed entries from table
Deferred_References.Init;
end Process_Deferred_References;
-- Start of elaboration for Lib.Xref
begin

33
gcc/ada/lib-xref.ads
View File

@ -600,6 +600,39 @@ package Lib.Xref is
-- Export at line 4, that its body is exported to C, and that the link name
-- as given in the pragma is "here".
-------------------------
-- Deferred_References --
-------------------------
-- Normally we generate references as we go along, but as discussed in
-- Sem_Util.Is_LHS, and Sem_Ch8.Find_Direct_Name/Find_Selected_Component,
-- we have one case where that is tricky, which is when we have something
-- like X.A := 3, where we don't know until we know the type of X whether
-- this is a reference (if X is an access type, so what we really have is
-- X.all.A := 3) or a modification, where X is not an access type.
-- What we do in such cases is to gather nodes, where we would have liked
-- to call Generate_Reference but we couldn't because we didn't know enough
-- into this table, Then we deal with generating references later on when
-- we have sufficient information to do it right.
type Deferred_Reference_Entry is record
E : Entity_Id;
N : Node_Id;
end record;
-- One entry, E, N are as required for Generate_Reference call
package Deferred_References is new Table.Table (
Table_Component_Type => Deferred_Reference_Entry,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => 512,
Table_Increment => 200,
Table_Name => "Name_Deferred_References");
procedure Process_Deferred_References;
-- This procedure is called from Frontend to process these table entries.
-----------------------------
-- SPARK Xrefs Information --
-----------------------------

3
gcc/ada/rtsfind.ads
View File

@ -1750,7 +1750,6 @@ package Rtsfind is
RE_Exceptional_Complete_Single_Entry_Body,
RE_Protected_Count_Entry, -- Protected_Objects.Single_Entry
RE_Protected_Single_Entry_Caller, -- Protected_Objects.Single_Entry
RE_Timed_Protected_Single_Entry_Call,
RE_Protected_Entry_Index, -- System.Tasking.Protected_Objects
RE_Entry_Body, -- System.Tasking.Protected_Objects
@ -3062,8 +3061,6 @@ package Rtsfind is
System_Tasking_Protected_Objects_Single_Entry,
RE_Protected_Single_Entry_Caller =>
System_Tasking_Protected_Objects_Single_Entry,
RE_Timed_Protected_Single_Entry_Call =>
System_Tasking_Protected_Objects_Single_Entry,
RE_Protected_Entry_Index => System_Tasking_Protected_Objects,
RE_Entry_Body => System_Tasking_Protected_Objects,

206
gcc/ada/s-tposen.adb
View File

@ -74,9 +74,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
-- Local Subprograms --
-----------------------
procedure Send_Program_Error
(Self_Id : Task_Id;
Entry_Call : Entry_Call_Link);
procedure Send_Program_Error (Entry_Call : Entry_Call_Link);
pragma Inline (Send_Program_Error);
-- Raise Program_Error in the caller of the specified entry call
@ -84,19 +82,12 @@ package body System.Tasking.Protected_Objects.Single_Entry is
-- Entry Calls Handling --
--------------------------
procedure Wakeup_Entry_Caller
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link;
New_State : Entry_Call_State);
procedure Wakeup_Entry_Caller (Entry_Call : Entry_Call_Link);
pragma Inline (Wakeup_Entry_Caller);
-- This is called at the end of service of an entry call,
-- to abort the caller if he is in an abortable part, and
-- to wake up the caller if he is on Entry_Caller_Sleep.
-- Call it holding the lock of Entry_Call.Self.
--
-- Timed_Call or Simple_Call:
-- The caller is waiting on Entry_Caller_Sleep, in
-- Wait_For_Completion, or Wait_For_Completion_With_Timeout.
procedure Wait_For_Completion (Entry_Call : Entry_Call_Link);
pragma Inline (Wait_For_Completion);
@ -105,13 +96,6 @@ package body System.Tasking.Protected_Objects.Single_Entry is
-- queued. This waits for calls on protected entries.
-- Call this only when holding Self_ID locked.
procedure Wait_For_Completion_With_Timeout
(Entry_Call : Entry_Call_Link;
Wakeup_Time : Duration;
Mode : Delay_Modes);
-- Same as Wait_For_Completion but it waits for a timeout with the value
-- specified in Wakeup_Time as well.
procedure Check_Exception
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link);
@ -122,8 +106,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
-- The caller should not be holding any locks, or there will be deadlock.
procedure PO_Do_Or_Queue
(Self_Id : Task_Id;
Object : Protection_Entry_Access;
(Object : Protection_Entry_Access;
Entry_Call : Entry_Call_Link);
-- This procedure executes or queues an entry call, depending
-- on the status of the corresponding barrier. It assumes that the
@ -157,9 +140,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
-- Send_Program_Error --
------------------------
procedure Send_Program_Error
(Self_Id : Task_Id;
Entry_Call : Entry_Call_Link)
procedure Send_Program_Error (Entry_Call : Entry_Call_Link)
is
Caller : constant Task_Id := Entry_Call.Self;
begin
@ -170,7 +151,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
end if;
STPO.Write_Lock (Caller);
Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
Wakeup_Entry_Caller (Entry_Call);
STPO.Unlock (Caller);
if Single_Lock then
@ -190,51 +171,6 @@ package body System.Tasking.Protected_Objects.Single_Entry is
Self_Id.Common.State := Runnable;
end Wait_For_Completion;
--------------------------------------
-- Wait_For_Completion_With_Timeout --
--------------------------------------
procedure Wait_For_Completion_With_Timeout
(Entry_Call : Entry_Call_Link;
Wakeup_Time : Duration;
Mode : Delay_Modes)
is
Self_Id : constant Task_Id := Entry_Call.Self;
Timedout : Boolean;
Yielded : Boolean;
pragma Unreferenced (Yielded);
use type Ada.Exceptions.Exception_Id;
begin
-- This procedure waits for the entry call to be served, with a timeout.
-- It tries to cancel the call if the timeout expires before the call is
-- served.
-- If we wake up from the timed sleep operation here, it may be for the
-- following possible reasons:
-- 1) The entry call is done being served.
-- 2) The timeout has expired (Timedout = True)
-- Once the timeout has expired we may need to continue to wait if the
-- call is already being serviced. In that case, we want to go back to
-- sleep, but without any timeout. The variable Timedout is used to
-- control this. If the Timedout flag is set, we do not need to Sleep
-- with a timeout. We just sleep until we get a wakeup for some status
-- change.
pragma Assert (Entry_Call.Mode = Timed_Call);
Self_Id.Common.State := Entry_Caller_Sleep;
STPO.Timed_Sleep
(Self_Id, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded);
Entry_Call.State := (if Timedout then Cancelled else Done);
Self_Id.Common.State := Runnable;
end Wait_For_Completion_With_Timeout;
-------------------------
-- Wakeup_Entry_Caller --
-------------------------
@ -246,31 +182,18 @@ package body System.Tasking.Protected_Objects.Single_Entry is
-- (This enforces the rule that a task must be off-queue if its state is
-- Done or Cancelled.) Call it holding the lock of Entry_Call.Self.
-- Timed_Call or Simple_Call:
-- The caller is waiting on Entry_Caller_Sleep, in
-- Wait_For_Completion, or Wait_For_Completion_With_Timeout.
-- Conditional_Call:
-- The caller might be in Wait_For_Completion,
-- waiting for a rendezvous (possibly requeued without abort)
-- to complete.
-- The caller is waiting on Entry_Caller_Sleep, in Wait_For_Completion.
procedure Wakeup_Entry_Caller
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link;
New_State : Entry_Call_State)
(Entry_Call : Entry_Call_Link)
is
pragma Warnings (Off, Self_ID);
Caller : constant Task_Id := Entry_Call.Self;
begin
pragma Assert (New_State = Done or else New_State = Cancelled);
pragma Assert
(Caller.Common.State /= Terminated and then
Caller.Common.State /= Unactivated);
Entry_Call.State := New_State;
Entry_Call.State := Done;
STPO.Wakeup (Caller, Entry_Caller_Sleep);
end Wakeup_Entry_Caller;
@ -338,8 +261,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
--------------------
procedure PO_Do_Or_Queue
(Self_Id : Task_Id;
Object : Protection_Entry_Access;
(Object : Protection_Entry_Access;
Entry_Call : Entry_Call_Link)
is
Barrier_Value : Boolean;
@ -356,7 +278,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
-- This violates the No_Entry_Queue restriction, send
-- Program_Error to the caller.
Send_Program_Error (Self_Id, Entry_Call);
Send_Program_Error (Entry_Call);
return;
end if;
@ -370,45 +292,32 @@ package body System.Tasking.Protected_Objects.Single_Entry is
end if;
STPO.Write_Lock (Entry_Call.Self);
Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
Wakeup_Entry_Caller (Entry_Call);
STPO.Unlock (Entry_Call.Self);
if Single_Lock then
STPO.Unlock_RTS;
end if;
elsif Entry_Call.Mode /= Conditional_Call then
else
pragma Assert (Entry_Call.Mode = Simple_Call);
if Object.Entry_Queue /= null then
-- This violates the No_Entry_Queue restriction, send
-- Program_Error to the caller.
Send_Program_Error (Self_Id, Entry_Call);
Send_Program_Error (Entry_Call);
return;
else
Object.Entry_Queue := Entry_Call;
end if;
else
-- Conditional_Call
if Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Entry_Call.Self);
Wakeup_Entry_Caller (Self_Id, Entry_Call, Cancelled);
STPO.Unlock (Entry_Call.Self);
if Single_Lock then
STPO.Unlock_RTS;
end if;
end if;
exception
when others =>
Send_Program_Error
(Self_Id, Entry_Call);
Send_Program_Error (Entry_Call);
end PO_Do_Or_Queue;
----------------------------
@ -430,8 +339,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
procedure Protected_Single_Entry_Call
(Object : Protection_Entry_Access;
Uninterpreted_Data : System.Address;
Mode : Call_Modes)
Uninterpreted_Data : System.Address)
is
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
@ -448,12 +356,12 @@ package body System.Tasking.Protected_Objects.Single_Entry is
Lock_Entry (Object);
Entry_Call.Mode := Mode;
Entry_Call.Mode := Simple_Call;
Entry_Call.State := Now_Abortable;
Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access);
PO_Do_Or_Queue (Object, Entry_Call'Access);
Unlock_Entry (Object);
-- The call is either `Done' or not. It cannot be cancelled since there
@ -493,7 +401,6 @@ package body System.Tasking.Protected_Objects.Single_Entry is
-------------------
procedure Service_Entry (Object : Protection_Entry_Access) is
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
Caller : Task_Id;
@ -507,7 +414,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
-- Violation of No_Entry_Queue restriction, raise exception
Send_Program_Error (Self_Id, Entry_Call);
Send_Program_Error (Entry_Call);
Unlock_Entry (Object);
return;
end if;
@ -524,7 +431,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
end if;
STPO.Write_Lock (Caller);
Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
Wakeup_Entry_Caller (Entry_Call);
STPO.Unlock (Caller);
if Single_Lock then
@ -539,79 +446,10 @@ package body System.Tasking.Protected_Objects.Single_Entry is
exception
when others =>
Send_Program_Error (Self_Id, Entry_Call);
Send_Program_Error (Entry_Call);
Unlock_Entry (Object);
end Service_Entry;
---------------------------------------
-- Timed_Protected_Single_Entry_Call --
---------------------------------------
-- Compiler interface only (do not call from within the RTS)
procedure Timed_Protected_Single_Entry_Call
(Object : Protection_Entry_Access;
Uninterpreted_Data : System.Address;
Timeout : Duration;
Mode : Delay_Modes;
Entry_Call_Successful : out Boolean)
is
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
begin
-- If pragma Detect_Blocking is active then Program_Error must be
-- raised if this potentially blocking operation is called from a
-- protected action.
if Detect_Blocking
and then Self_Id.Common.Protected_Action_Nesting > 0
then
raise Program_Error with "potentially blocking operation";
end if;
Lock (Object.Common'Access);
Entry_Call.Mode := Timed_Call;
Entry_Call.State := Now_Abortable;
Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access);
Unlock_Entry (Object);
-- Try to avoid waiting for completed calls.
-- The call is either `Done' or not. It cannot be cancelled since there
-- is no ATC construct and the timed wait has not started yet.
pragma Assert (Entry_Call.State /= Cancelled);
if Entry_Call.State = Done then
Check_Exception (Self_Id, Entry_Call'Access);
Entry_Call_Successful := True;
return;
end if;
if Single_Lock then
STPO.Lock_RTS;
else
STPO.Write_Lock (Self_Id);
end if;
Wait_For_Completion_With_Timeout (Entry_Call'Access, Timeout, Mode);
if Single_Lock then
STPO.Unlock_RTS;
else
STPO.Unlock (Self_Id);
end if;
pragma Assert (Entry_Call.State >= Done);
Check_Exception (Self_Id, Entry_Call'Access);
Entry_Call_Successful := Entry_Call.State = Done;
end Timed_Protected_Single_Entry_Call;
------------------
-- Unlock_Entry --
------------------

15
gcc/ada/s-tposen.ads
View File

@ -225,8 +225,7 @@ package System.Tasking.Protected_Objects.Single_Entry is
procedure Protected_Single_Entry_Call
(Object : Protection_Entry_Access;
Uninterpreted_Data : System.Address;
Mode : Call_Modes);
Uninterpreted_Data : System.Address);
-- Make a protected entry call to the specified object
--
-- Pend a protected entry call on the protected object represented by
@ -237,18 +236,6 @@ package System.Tasking.Protected_Objects.Single_Entry is
-- This will be returned by Next_Entry_Call when this call is serviced.
-- It can be used by the compiler to pass information between the
-- caller and the server, in particular entry parameters.
--
-- Mode
-- The kind of call to be pended
procedure Timed_Protected_Single_Entry_Call
(Object : Protection_Entry_Access;
Uninterpreted_Data : System.Address;
Timeout : Duration;
Mode : Delay_Modes;
Entry_Call_Successful : out Boolean);
-- Same as the Protected_Entry_Call but with time-out specified.
-- This routine is used to implement timed entry calls.
procedure Exceptional_Complete_Single_Entry_Body
(Object : Protection_Entry_Access;

15
gcc/ada/sem_ch4.adb
View File

@ -5890,16 +5890,15 @@ package body Sem_Ch4 is
-- correct. If an operand is universal it is compatible with any
-- numeric type.
-- In Ada 2005, the equality on anonymous access types is declared
-- in Standard, and is always visible.
-- In an instance, the type may have been immediately visible.
-- Either the types are compatible, or one operand is universal
-- (numeric or null).
elsif In_Open_Scopes (Scope (Bas))
or else Is_Potentially_Use_Visible (Bas)
or else In_Use (Bas)
or else (In_Use (Scope (Bas)) and then not Is_Hidden (Bas))
-- In an instance, the type may have been immediately visible.
-- Either the types are compatible, or one operand is universal
-- (numeric or null).
or else (In_Instance
and then
(First_Subtype (T1) = First_Subtype (Etype (R))
@ -5907,6 +5906,10 @@ package body Sem_Ch4 is
or else
(Is_Numeric_Type (T1)
and then Is_Universal_Numeric_Type (Etype (R)))))
-- In Ada 2005, the equality on anonymous access types is declared
-- in Standard, and is always visible.
or else Ekind (T1) = E_Anonymous_Access_Type
then
null;

68
gcc/ada/sem_ch8.adb
View File

@ -5152,29 +5152,29 @@ package body Sem_Ch8 is
-- Normal case, not a label: generate reference
-- ??? It is too early to generate a reference here even if the
-- entity is unambiguous, because the tree is not sufficiently
-- typed at this point for Generate_Reference to determine
-- whether this reference modifies the denoted object (because
-- implicit dereferences cannot be identified prior to full type
-- resolution).
-- The Is_Actual_Parameter routine takes care of one of these
-- cases but there are others probably ???
-- If the entity is the LHS of an assignment, and is a variable
-- (rather than a package prefix), we can mark it as a
-- modification right away, to avoid duplicate references.
else
if not Is_Actual_Parameter then
if Is_LHS (N)
and then Ekind (E) /= E_Package
and then Ekind (E) /= E_Generic_Package
then
Generate_Reference (E, N, 'm');
-- Package or generic package is always a simple reference
if Ekind_In (E, E_Package, E_Generic_Package) then
Generate_Reference (E, N, 'r');
-- Else see if we have a left hand side
else
Generate_Reference (E, N);
case Is_LHS (N) is
when Yes =>
Generate_Reference (E, N, 'm');
when No =>
Generate_Reference (E, N, 'r');
-- If we don't know now, generate reference later
when Unknown =>
Deferred_References.Append ((E, N));
end case;
end if;
end if;
@ -5655,26 +5655,32 @@ package body Sem_Ch8 is
Change_Selected_Component_To_Expanded_Name (N);
-- Set appropriate type
if Is_Type (Id) then
Set_Etype (N, Id);
else
Set_Etype (N, Get_Full_View (Etype (Id)));
end if;
-- Do style check and generate reference, but skip both steps if this
-- entity has homonyms, since we may not have the right homonym set yet.
-- The proper homonym will be set during the resolve phase.
if Has_Homonym (Id) then
Set_Entity (N, Id);
else
Set_Entity_Or_Discriminal (N, Id);
if Is_LHS (N) then
Generate_Reference (Id, N, 'm');
else
Generate_Reference (Id, N);
end if;
end if;
if Is_Type (Id) then
Set_Etype (N, Id);
else
Set_Etype (N, Get_Full_View (Etype (Id)));
case Is_LHS (N) is
when Yes =>
Generate_Reference (Id, N, 'm');
when No =>
Generate_Reference (Id, N, 'r');
when Unknown =>
Deferred_References.Append ((Id, N));
end case;
end if;
-- Check for violation of No_Wide_Characters

4
gcc/ada/sem_res.adb
View File

@ -7673,7 +7673,7 @@ package body Sem_Res is
or else (Is_Entity_Name (Prefix (N))
and then Is_Atomic (Entity (Prefix (N)))))
and then Is_Bit_Packed_Array (Array_Type)
and then Is_LHS (N)
and then Is_LHS (N) = Yes
then
Error_Msg_N ("??assignment to component of packed atomic array",
Prefix (N));
@ -9170,7 +9170,7 @@ package body Sem_Res is
or else (Is_Entity_Name (Prefix (N))
and then Is_Atomic (Entity (Prefix (N)))))
and then Is_Packed (T)
and then Is_LHS (N)
and then Is_LHS (N) = Yes
then
Error_Msg_N
("??assignment to component of packed atomic record", Prefix (N));

28
gcc/ada/sem_util.adb
View File

@ -5587,7 +5587,8 @@ package body Sem_Util is
-- we exclude overloaded calls, since we don't know enough to be sure
-- of giving the right answer in this case.
if Is_Entity_Name (Name (Call))
if Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement)
and then Is_Entity_Name (Name (Call))
and then Present (Entity (Name (Call)))
and then Is_Overloadable (Entity (Name (Call)))
and then not Is_Overloaded (Name (Call))
@ -9982,14 +9983,18 @@ package body Sem_Util is
-- We seem to have a lot of overlapping functions that do similar things
-- (testing for left hand sides or lvalues???).
function Is_LHS (N : Node_Id) return Boolean is
function Is_LHS (N : Node_Id) return Is_LHS_Result is
P : constant Node_Id := Parent (N);
begin
-- Return True if we are the left hand side of an assignment statement
if Nkind (P) = N_Assignment_Statement then
return Name (P) = N;
if Name (P) = N then
return Yes;
else
return No;
end if;
-- Case of prefix of indexed or selected component or slice
@ -10002,23 +10007,16 @@ package body Sem_Util is
-- what we really have is N.all.Q (or N.all(Q .. R)). In either
-- case this makes N.all a left hand side but not N itself.
-- Here follows a worrisome kludge. If Etype (N) is not set, which
-- for sure happens in the call from Find_Direct_Name, that means we
-- don't know if N is of an access type, so we can't give an accurate
-- answer. For now, we assume we do not have an access type, which
-- means for example that P.Q.R := X will look like a modification
-- of P, even if P.Q eventually turns out to be an access type. The
-- consequence is at least that in some cases we incorrectly identify
-- a reference as a modification. It is not clear if there are any
-- other bad consequences. ???
-- If we don't know the type yet, this is the case where we return
-- Unknown, since the answer depends on the type which is unknown.
if No (Etype (N)) then
return False;
return Unknown;
-- We have an Etype set, so we can check it
elsif Is_Access_Type (Etype (N)) then
return False;
return No;
-- OK, not access type case, so just test whole expression
@ -10029,7 +10027,7 @@ package body Sem_Util is
-- All other cases are not left hand sides
else
return False;
return No;
end if;
end Is_LHS;

11
gcc/ada/sem_util.ads
View File

@ -1164,8 +1164,15 @@ package Sem_Util is
-- AI05-0139-2: Check whether Typ is one of the predefined interfaces in
-- Ada.Iterator_Interfaces, or it is derived from one.
function Is_LHS (N : Node_Id) return Boolean;
-- Returns True iff N is used as Name in an assignment statement
type Is_LHS_Result is (Yes, No, Unknown);
function Is_LHS (N : Node_Id) return Is_LHS_Result;
-- Returns Yes if N is definitely used as Name in an assignment statement.
-- Returns No if N is definitely NOT used as a Name in an assignment
-- statement. Returns Unknown if we can't tell at this stage (happens in
-- the case where we don't know the type of N yet, and we have something
-- like N.A := 3, where this counts as N being used on the left side of
-- an assignment only if N is not an access type. If it is an access type
-- then it is N.all.A that is assigned, not N.
function Is_Library_Level_Entity (E : Entity_Id) return Boolean;
-- A library-level declaration is one that is accessible from Standard,

5
gcc/ada/sem_warn.adb
View File

@ -30,6 +30,7 @@ with Errout; use Errout;
with Exp_Code; use Exp_Code;
with Fname; use Fname;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nlists; use Nlists;
with Opt; use Opt;
@ -998,6 +999,8 @@ package body Sem_Warn is
-- Start of processing for Check_References
begin
Process_Deferred_References;
-- No messages if warnings are suppressed, or if we have detected any
-- real errors so far (this last check avoids junk messages resulting
-- from errors, e.g. a subunit that is not loaded).
@ -2566,6 +2569,8 @@ package body Sem_Warn is
return;
end if;
Process_Deferred_References;
-- Flag any unused with clauses. For a subunit, check only the units
-- in its context, not those of the parent, which may be needed by other
-- subunits. We will get the full warnings when we compile the parent,