From bdfb8ec4aaf389281c221776f8d2cfd965557cda Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 31 Jan 2014 16:45:08 +0100 Subject: [PATCH] [multiple changes] 2014-01-31 Robert Dewar * exp_ch9.adb, s-tassta.adb, s-tposen.adb, s-tposen.ads: Minor reformatting. 2014-01-31 Tristan Gingold * exp_disp.adb: Add a historic note. 2014-01-31 Robert Dewar * sem_warn.adb (Warn_On_Useless_Assignments): Add call to Process_Deferred_References. 2014-01-31 Yannick Moy * erroutc.adb (Validate_Specific_Warnings): Do not issue a message for ineffective pragma Warnings(Off) in GNATprove_Mode. From-SVN: r207351 --- gcc/ada/ChangeLog | 19 +++++++++++ gcc/ada/erroutc.adb | 7 ++++ gcc/ada/exp_ch9.adb | 76 ++++++++++++++++++++------------------------ gcc/ada/exp_disp.adb | 7 ++++ gcc/ada/s-tassta.adb | 14 ++++---- gcc/ada/s-tposen.adb | 36 ++++++++++----------- gcc/ada/s-tposen.ads | 2 +- gcc/ada/sem_warn.adb | 3 ++ 8 files changed, 97 insertions(+), 67 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 82247a059d6..aa976653f2a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,22 @@ +2014-01-31 Robert Dewar + + * exp_ch9.adb, s-tassta.adb, s-tposen.adb, s-tposen.ads: Minor + reformatting. + +2014-01-31 Tristan Gingold + + * exp_disp.adb: Add a historic note. + +2014-01-31 Robert Dewar + + * sem_warn.adb (Warn_On_Useless_Assignments): Add call to + Process_Deferred_References. + +2014-01-31 Yannick Moy + + * erroutc.adb (Validate_Specific_Warnings): Do not issue a message for + ineffective pragma Warnings(Off) in GNATprove_Mode. + 2014-01-31 Bob Duff * s-taskin.ads: Minor comment fix. diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 6924ce26449..f70fc60d926 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -1318,6 +1318,13 @@ package body Erroutc is elsif not SWE.Used + -- 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. diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 078e8369fda..1f9e05bd875 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -4723,7 +4723,6 @@ package body Exp_Ch9 is 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 @@ -4786,7 +4785,7 @@ package body Exp_Ch9 is Append_To (Plist, Make_Attribute_Reference (Loc, Attribute_Name => Name_Unchecked_Access, - Prefix => + Prefix => New_Reference_To (Defining_Identifier (N_Node), Loc))); else @@ -4834,9 +4833,9 @@ package body Exp_Ch9 is Pdecl := Make_Object_Declaration (Loc, Defining_Identifier => P, - Object_Definition => + Object_Definition => New_Reference_To (Designated_Type (Ent_Acc), Loc), - Expression => + Expression => Make_Aggregate (Loc, Expressions => Plist)); Parm3 := @@ -5064,8 +5063,8 @@ package body Exp_Ch9 is 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. declare Stm : Node_Id; @@ -5106,7 +5105,7 @@ package body Exp_Ch9 is else Set_Handled_Statement_Sequence (N, Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Call))); + Statements => New_List (Call))); end if; end if; @@ -5151,13 +5150,13 @@ package body Exp_Ch9 is Statements => New_List ( - -- Init (Args); + -- Init (Args); Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (Init, Loc), + Name => New_Reference_To (Init, Loc), Parameter_Associations => Args), - -- Activate_Tasks (_Chain); + -- Activate_Tasks (_Chain); Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc), @@ -5212,7 +5211,7 @@ package body Exp_Ch9 is Make_Object_Declaration (Loc, Defining_Identifier => Chain, - Aliased_Present => True, + Aliased_Present => True, Object_Definition => New_Reference_To (RTE (RE_Activation_Chain), Loc))), @@ -5245,15 +5244,13 @@ package body Exp_Ch9 is 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 := - 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); @@ -5382,7 +5379,7 @@ package body Exp_Ch9 is Append_To (Cdecls, Make_Component_Declaration (Loc, - Defining_Identifier => + Defining_Identifier => Make_Defining_Identifier (Loc, Chars (Efam)), Component_Definition => @@ -5393,12 +5390,12 @@ package body Exp_Ch9 is Subtype_Mark => New_Occurrence_Of (Efam_Type, Loc), - Constraint => + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( New_Occurrence_Of (Etype (Discrete_Subtype_Definition - (Parent (Efam))), Loc))))))); + (Parent (Efam))), Loc))))))); end if; @@ -5528,9 +5525,7 @@ package body Exp_Ch9 is -- 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 False; else @@ -5558,7 +5553,7 @@ package body Exp_Ch9 is return Make_Selected_Component (Loc, - Prefix => + Prefix => Unchecked_Convert_To (Corresponding_Record_Type (Dtyp), Make_Explicit_Dereference (Loc, N)), Selector_Name => Make_Identifier (Loc, Sel)); @@ -5820,8 +5815,8 @@ package body Exp_Ch9 is 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 @@ -5993,10 +5988,10 @@ package body Exp_Ch9 is Next (Alt); end loop; - -- 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'); @@ -6008,7 +6003,7 @@ package body Exp_Ch9 is 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 @@ -6227,7 +6222,7 @@ package body Exp_Ch9 is -- 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 Aonix compiler. + -- other compilers. -- Note that after analysis variables in this context will be replaced -- by the corresponding prival, that is to say a renaming of a selected @@ -6300,8 +6295,8 @@ package body Exp_Ch9 is 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 @@ -6349,14 +6344,14 @@ package body Exp_Ch9 is -- 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. - -- 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) @@ -6399,7 +6394,7 @@ package body Exp_Ch9 is -- 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 @@ -6443,7 +6438,6 @@ package body Exp_Ch9 is begin D := First (Declarations (N)); - while Present (D) loop Next_D := Next (D); if Nkind (D) = N_Object_Renaming_Declaration then @@ -6806,8 +6800,8 @@ package body Exp_Ch9 is -- 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 diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index b0660fc0290..33275d506d7 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -3522,6 +3522,13 @@ package body Exp_Disp is -- 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, diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 4925906b026..58e8f98b59c 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -150,14 +150,14 @@ package body System.Tasking.Stages is 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 - -- 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; diff --git a/gcc/ada/s-tposen.adb b/gcc/ada/s-tposen.adb index 697ee9dabb1..4487c5eee2c 100644 --- a/gcc/ada/s-tposen.adb +++ b/gcc/ada/s-tposen.adb @@ -54,7 +54,7 @@ pragma Style_Checks (All_Checks); 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 ??? @@ -84,10 +84,9 @@ package body System.Tasking.Protected_Objects.Single_Entry is 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); @@ -100,17 +99,16 @@ package body System.Tasking.Protected_Objects.Single_Entry is (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); - -- 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 -- @@ -140,9 +138,9 @@ package body System.Tasking.Protected_Objects.Single_Entry is -- 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; + begin Entry_Call.Exception_To_Raise := Program_Error'Identity; @@ -192,7 +190,6 @@ package body System.Tasking.Protected_Objects.Single_Entry is 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; @@ -207,7 +204,8 @@ package body System.Tasking.Protected_Objects.Single_Entry is 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; @@ -235,7 +233,8 @@ package body System.Tasking.Protected_Objects.Single_Entry is -- 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 @@ -391,7 +390,8 @@ package body System.Tasking.Protected_Objects.Single_Entry is ----------------------------------- 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; diff --git a/gcc/ada/s-tposen.ads b/gcc/ada/s-tposen.ads index b2713bd3282..3bb0aa8e6d1 100644 --- a/gcc/ada/s-tposen.ads +++ b/gcc/ada/s-tposen.ads @@ -228,7 +228,7 @@ package System.Tasking.Protected_Objects.Single_Entry is 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. -- diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index cca8c06ce71..6193a8f705a 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -4244,7 +4244,10 @@ package body Sem_Warn is procedure Warn_On_Useless_Assignments (E : Entity_Id) is Ent : Entity_Id; + begin + Process_Deferred_References; + if Warn_On_Modified_Unread and then In_Extended_Main_Source_Unit (E) then -- 2.30.2