2014-01-31 Robert Dewar <dewar@adacore.com>
* exp_ch9.adb, s-tassta.adb, s-tposen.adb, s-tposen.ads: Minor
reformatting.
2014-01-31 Tristan Gingold <gingold@adacore.com>
* exp_disp.adb: Add a historic note.
2014-01-31 Robert Dewar <dewar@adacore.com>
* sem_warn.adb (Warn_On_Useless_Assignments): Add call to
Process_Deferred_References.
2014-01-31 Yannick Moy <moy@adacore.com>
* erroutc.adb (Validate_Specific_Warnings): Do not issue a message for
ineffective pragma Warnings(Off) in GNATprove_Mode.
From-SVN: r207351
+2014-01-31 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch9.adb, s-tassta.adb, s-tposen.adb, s-tposen.ads: Minor
+ reformatting.
+
+2014-01-31 Tristan Gingold <gingold@adacore.com>
+
+ * exp_disp.adb: Add a historic note.
+
+2014-01-31 Robert Dewar <dewar@adacore.com>
+
+ * sem_warn.adb (Warn_On_Useless_Assignments): Add call to
+ Process_Deferred_References.
+
+2014-01-31 Yannick Moy <moy@adacore.com>
+
+ * erroutc.adb (Validate_Specific_Warnings): Do not issue a message for
+ ineffective pragma Warnings(Off) in GNATprove_Mode.
+
2014-01-31 Bob Duff <duff@adacore.com>
* s-taskin.ads: Minor comment fix.
2014-01-31 Bob Duff <duff@adacore.com>
* s-taskin.ads: Minor comment fix.
+ -- Do not issue this warning in GNATprove_Mode, as not
+ -- all warnings may be generated in this mode, and pragma
+ -- Warnings(Off) may correspond to warnings generated by the
+ -- formal verification backend instead of frontend warnings.
+
+ and then not GNATprove_Mode
+
-- Do not issue this warning for -Wxxx messages since the
-- back-end doesn't report the information.
-- Do not issue this warning for -Wxxx messages since the
-- back-end doesn't report the information.
Actual := First_Actual (N);
Formal := First_Formal (Ent);
Actual := First_Actual (N);
Formal := First_Formal (Ent);
while Present (Actual) loop
-- If it is a by_copy_type, copy it to a new variable. The
while Present (Actual) loop
-- If it is a by_copy_type, copy it to a new variable. The
Append_To (Plist,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unchecked_Access,
Append_To (Plist,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unchecked_Access,
New_Reference_To (Defining_Identifier (N_Node), Loc)));
else
New_Reference_To (Defining_Identifier (N_Node), Loc)));
else
Pdecl :=
Make_Object_Declaration (Loc,
Defining_Identifier => P,
Pdecl :=
Make_Object_Declaration (Loc,
Defining_Identifier => P,
New_Reference_To (Designated_Type (Ent_Acc), Loc),
New_Reference_To (Designated_Type (Ent_Acc), Loc),
Make_Aggregate (Loc, Expressions => Plist));
Parm3 :=
Make_Aggregate (Loc, Expressions => Plist));
Parm3 :=
else
if Present (Handled_Statement_Sequence (N)) then
else
if Present (Handled_Statement_Sequence (N)) then
- -- The call goes at the start of the statement sequence
- -- after the start of exception range label if one is present.
+ -- The call goes at the start of the statement sequence after
+ -- the start of exception range label if one is present.
else
Set_Handled_Statement_Sequence (N,
Make_Handled_Sequence_Of_Statements (Loc,
else
Set_Handled_Statement_Sequence (N,
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Call)));
+ Statements => New_List (Call)));
Make_Procedure_Call_Statement (Loc,
Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (Init, Loc),
+ Name => New_Reference_To (Init, Loc),
Parameter_Associations => Args),
Parameter_Associations => Args),
- -- Activate_Tasks (_Chain);
+ -- Activate_Tasks (_Chain);
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc),
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc),
Make_Object_Declaration (Loc,
Defining_Identifier => Chain,
Make_Object_Declaration (Loc,
Defining_Identifier => Chain,
- Aliased_Present => True,
+ Aliased_Present => True,
Object_Definition =>
New_Reference_To (RTE (RE_Activation_Chain), Loc))),
Object_Definition =>
New_Reference_To (RTE (RE_Activation_Chain), Loc))),
if Comes_From_Source (T) then
Spec_Id :=
if Comes_From_Source (T) then
Spec_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (T), "TB"));
+ Make_Defining_Identifier (Loc, New_External_Name (Chars (T), "TB"));
-- Case of anonymous task type, suffix B
else
Spec_Id :=
-- Case of anonymous task type, suffix B
else
Spec_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (T), 'B'));
+ Make_Defining_Identifier (Loc, New_External_Name (Chars (T), 'B'));
end if;
Set_Is_Internal (Spec_Id);
end if;
Set_Is_Internal (Spec_Id);
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Make_Defining_Identifier (Loc, Chars (Efam)),
Component_Definition =>
Make_Defining_Identifier (Loc, Chars (Efam)),
Component_Definition =>
Subtype_Mark =>
New_Occurrence_Of (Efam_Type, Loc),
Subtype_Mark =>
New_Occurrence_Of (Efam_Type, Loc),
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
New_Occurrence_Of
(Etype (Discrete_Subtype_Definition
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
New_Occurrence_Of
(Etype (Discrete_Subtype_Definition
- (Parent (Efam))), Loc)))))));
+ (Parent (Efam))), Loc)))))));
-- assume that it can be called from an inner task, and therefore
-- cannot treat it as a local reference.
-- assume that it can be called from an inner task, and therefore
-- cannot treat it as a local reference.
- elsif Is_Overloadable (Scop)
- and then In_Open_Scopes (T)
- then
+ elsif Is_Overloadable (Scop) and then In_Open_Scopes (T) then
return
Make_Selected_Component (Loc,
return
Make_Selected_Component (Loc,
Unchecked_Convert_To (Corresponding_Record_Type (Dtyp),
Make_Explicit_Dereference (Loc, N)),
Selector_Name => Make_Identifier (Loc, Sel));
Unchecked_Convert_To (Corresponding_Record_Type (Dtyp),
Make_Explicit_Dereference (Loc, N)),
Selector_Name => Make_Identifier (Loc, Sel));
if Restriction_Active (No_Task_Hierarchy) = False then
Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master);
if Restriction_Active (No_Task_Hierarchy) = False then
Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master);
- -- The block may have no declarations, and nevertheless be a task
- -- master, if it contains a call that may return an object that
+ -- The block may have no declarations (and nevertheless be a task
+ -- master) if it contains a call that may return an object that
-- contains tasks.
if No (Declarations (N)) then
-- contains tasks.
if No (Declarations (N)) then
- -- If we are the first accept statement, then we have to create
- -- the Ann variable, as for the stand alone case, except that
- -- it is inserted before the selective accept. Similarly, a
- -- label for requeue expansion must be declared.
+ -- If this is the first accept statement, then we have to
+ -- create the Ann variable, as for the stand alone case, except
+ -- that it is inserted before the selective accept. Similarly,
+ -- a label for requeue expansion must be declared.
if N = Accept_Statement (Alt) then
Ann := Make_Temporary (Loc, 'A');
if N = Accept_Statement (Alt) then
Ann := Make_Temporary (Loc, 'A');
Insert_Before_And_Analyze (Sel_Acc, Adecl);
Insert_Before_And_Analyze (Sel_Acc, Adecl);
- -- If we are not the first accept statement, then find the Ann
+ -- If this is not the first accept statement, then find the Ann
-- variable allocated by the first accept and use it.
else
-- variable allocated by the first accept and use it.
else
-- The Ravenscar profile restricts barriers to simple variables declared
-- within the protected object. We also allow Boolean constants, since
-- these appear in several published examples and are also allowed by
-- The Ravenscar profile restricts barriers to simple variables declared
-- within the protected object. We also allow Boolean constants, since
-- these appear in several published examples and are also allowed by
-- Note that after analysis variables in this context will be replaced
-- by the corresponding prival, that is to say a renaming of a selected
-- Note that after analysis variables in this context will be replaced
-- by the corresponding prival, that is to say a renaming of a selected
while Present (Tasknm) loop
Count := Count + 1;
while Present (Tasknm) loop
Count := Count + 1;
- -- A task interface class-wide type object is being aborted.
- -- Retrieve its _task_id by calling a dispatching routine.
+ -- A task interface class-wide type object is being aborted. Retrieve
+ -- its _task_id by calling a dispatching routine.
if Ada_Version >= Ada_2005
and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type
if Ada_Version >= Ada_2005
and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type
-- Expand_N_Accept_Statement --
-------------------------------
-- Expand_N_Accept_Statement --
-------------------------------
- -- This procedure handles expansion of accept statements that stand
- -- alone, i.e. they are not part of an accept alternative. The expansion
- -- of accept statement in accept alternatives is handled by the routines
+ -- This procedure handles expansion of accept statements that stand alone,
+ -- i.e. they are not part of an accept alternative. The expansion of
+ -- accept statement in accept alternatives is handled by the routines
-- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
-- following description applies only to stand alone accept statements.
-- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The
-- following description applies only to stand alone accept statements.
- -- If there is no handled statement sequence, or only null statements,
- -- then this is called a trivial accept, and the expansion is:
+ -- If there is no handled statement sequence, or only null statements, then
+ -- this is called a trivial accept, and the expansion is:
-- Accept_Trivial (entry-index)
-- Accept_Trivial (entry-index)
-- an accept statement has no declarative part). In particular, if the
-- expander is active, the first such declaration is the declaration of
-- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
-- an accept statement has no declarative part). In particular, if the
-- expander is active, the first such declaration is the declaration of
-- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement).
-- The two blocks are merged into a single block if the inner block has
-- no exception handlers, but otherwise two blocks are required, since
-- exceptions might be raised in the exception handlers of the inner
-- The two blocks are merged into a single block if the inner block has
-- no exception handlers, but otherwise two blocks are required, since
-- exceptions might be raised in the exception handlers of the inner
begin
D := First (Declarations (N));
begin
D := First (Declarations (N));
while Present (D) loop
Next_D := Next (D);
if Nkind (D) = N_Object_Renaming_Declaration then
while Present (D) loop
Next_D := Next (D);
if Nkind (D) = N_Object_Renaming_Declaration then
-- The job is to convert this to the asynchronous form
-- The job is to convert this to the asynchronous form
- -- If the trigger is a delay statement, it will have been expanded into a
- -- call to one of the GNARL delay procedures. This routine will convert
+ -- If the trigger is a delay statement, it will have been expanded into
+ -- a call to one of the GNARL delay procedures. This routine will convert
-- this into a protected entry call on a delay object and then continue
-- processing as for a protected entry call trigger. This requires
-- declaring a Delay_Block object and adding a pointer to this object to
-- this into a protected entry call on a delay object and then continue
-- processing as for a protected entry call trigger. This requires
-- declaring a Delay_Block object and adding a pointer to this object to
-- the wrapped parameters, D is the delay amount, M is the delay
-- mode and F is the status flag.
-- the wrapped parameters, D is the delay amount, M is the delay
-- mode and F is the status flag.
+ -- Historically, there was also an implementation for single
+ -- entry protected types (in s-tposen). However, it was removed
+ -- by also testing for no No_Select_Statements restriction in
+ -- Exp_Utils.Corresponding_Runtime_Package. This simplified the
+ -- implementation of s-tposen, which was initially created for
+ -- the Ravenscar profile.
+
case Corresponding_Runtime_Package (Conc_Typ) is
when System_Tasking_Protected_Objects_Entries =>
Append_To (Stmts,
case Corresponding_Runtime_Package (Conc_Typ) is
when System_Tasking_Protected_Objects_Entries =>
Append_To (Stmts,
C : Task_Id;
P : Task_Id;
C : Task_Id;
P : Task_Id;
- -- Each task C will take care of its own dependents, so there is no need
- -- to worry about them here. In fact, it would be wrong to abort
+ -- Each task C will take care of its own dependents, so there is no
+ -- need to worry about them here. In fact, it would be wrong to abort
-- indirect dependents here, because we can't distinguish between
-- indirect dependents here, because we can't distinguish between
- -- duplicate master ids. For example, suppose we have three nested task
- -- bodies T1,T2,T3. And suppose T1 also calls P which calls Q (and both
- -- P and Q are task masters). Q will have the same master id as
- -- Master_of_Task of T3. Previous versions of this would abort T3 when Q
- -- calls Complete_Master, which was completely wrong.
+ -- duplicate master ids. For example, suppose we have three nested
+ -- task bodies T1,T2,T3. And suppose T1 also calls P which calls Q (and
+ -- both P and Q are task masters). Q will have the same master id as
+ -- Master_of_Task of T3. Previous versions of this would abort T3 when
+ -- Q calls Complete_Master, which was completely wrong.
begin
C := All_Tasks_List;
begin
C := All_Tasks_List;
pragma Polling (Off);
-- Turn off polling, we do not want polling to take place during tasking
pragma Polling (Off);
-- Turn off polling, we do not want polling to take place during tasking
--- operations. It can cause infinite loops and other problems.
+-- operations. It can cause infinite loops and other problems.
pragma Suppress (All_Checks);
-- Why is this required ???
pragma Suppress (All_Checks);
-- Why is this required ???
procedure Wakeup_Entry_Caller (Entry_Call : Entry_Call_Link);
pragma Inline (Wakeup_Entry_Caller);
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.
+ -- 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.
procedure Wait_For_Completion (Entry_Call : Entry_Call_Link);
pragma Inline (Wait_For_Completion);
procedure Wait_For_Completion (Entry_Call : Entry_Call_Link);
pragma Inline (Wait_For_Completion);
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link);
pragma Inline (Check_Exception);
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link);
pragma Inline (Check_Exception);
- -- Raise any pending exception from the Entry_Call.
- -- This should be called at the end of every compiler interface procedure
- -- that implements an entry call.
- -- The caller should not be holding any locks, or there will be deadlock.
+ -- Raise any pending exception from the Entry_Call. This should be called
+ -- at the end of every compiler interface procedure that implements an
+ -- entry call. The caller should not be holding any locks, or there will
+ -- be deadlock.
procedure PO_Do_Or_Queue
(Object : Protection_Entry_Access;
Entry_Call : Entry_Call_Link);
procedure PO_Do_Or_Queue
(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
- -- specified object is locked.
+ -- This procedure executes or queues an entry call, depending on the status
+ -- of the corresponding barrier. The specified object is assumed locked.
---------------------
-- Check_Exception --
---------------------
-- Check_Exception --
-- Send_Program_Error --
------------------------
-- Send_Program_Error --
------------------------
- procedure Send_Program_Error (Entry_Call : Entry_Call_Link)
- is
+ procedure Send_Program_Error (Entry_Call : Entry_Call_Link) is
Caller : constant Task_Id := Entry_Call.Self;
Caller : constant Task_Id := Entry_Call.Self;
begin
Entry_Call.Exception_To_Raise := Program_Error'Identity;
begin
Entry_Call.Exception_To_Raise := Program_Error'Identity;
pragma Assert
(Caller.Common.State /= Terminated and then
Caller.Common.State /= Unactivated);
pragma Assert
(Caller.Common.State /= Terminated and then
Caller.Common.State /= Unactivated);
Entry_Call.State := Done;
STPO.Wakeup (Caller, Entry_Caller_Sleep);
end Wakeup_Entry_Caller;
Entry_Call.State := Done;
STPO.Wakeup (Caller, Entry_Caller_Sleep);
end Wakeup_Entry_Caller;
procedure Exceptional_Complete_Single_Entry_Body
(Object : Protection_Entry_Access;
procedure Exceptional_Complete_Single_Entry_Body
(Object : Protection_Entry_Access;
- Ex : Ada.Exceptions.Exception_Id) is
+ Ex : Ada.Exceptions.Exception_Id)
+ is
begin
Object.Call_In_Progress.Exception_To_Raise := Ex;
end Exceptional_Complete_Single_Entry_Body;
begin
Object.Call_In_Progress.Exception_To_Raise := Ex;
end Exceptional_Complete_Single_Entry_Body;
-- Lock_Entry --
----------------
-- Lock_Entry --
----------------
- -- Compiler interface only.
+ -- Compiler interface only
+
-- Do not call this procedure from within the run-time system.
procedure Lock_Entry (Object : Protection_Entry_Access) is
-- Do not call this procedure from within the run-time system.
procedure Lock_Entry (Object : Protection_Entry_Access) is
-----------------------------------
function Protected_Single_Entry_Caller
-----------------------------------
function Protected_Single_Entry_Caller
- (Object : Protection_Entry) return Task_Id is
+ (Object : Protection_Entry) return Task_Id
+ is
begin
return Object.Call_In_Progress.Self;
end Protected_Single_Entry_Caller;
begin
return Object.Call_In_Progress.Self;
end Protected_Single_Entry_Caller;
Uninterpreted_Data : System.Address);
-- Make a protected entry call to the specified object
--
Uninterpreted_Data : System.Address);
-- Make a protected entry call to the specified object
--
- -- Pend a protected entry call on the protected object represented by
+ -- Pends a protected entry call on the protected object represented by
-- Object. A pended call is not queued; it may be executed immediately
-- or queued, depending on the state of the entry barrier.
--
-- Object. A pended call is not queued; it may be executed immediately
-- or queued, depending on the state of the entry barrier.
--
procedure Warn_On_Useless_Assignments (E : Entity_Id) is
Ent : Entity_Id;
procedure Warn_On_Useless_Assignments (E : Entity_Id) is
Ent : Entity_Id;
+ Process_Deferred_References;
+
if Warn_On_Modified_Unread
and then In_Extended_Main_Source_Unit (E)
then
if Warn_On_Modified_Unread
and then In_Extended_Main_Source_Unit (E)
then