From 4969efdf7d92bc0a018a664fccc6d715e9de0d9f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 14 Jun 2016 14:23:34 +0200 Subject: [PATCH] [multiple changes] 2016-06-14 Tristan Gingold * einfo.adb, einfo.ads (Has_Timing_Event, Set_Has_Timing_Event): Add Has_Timing_Event flag. (Write_Entity_Flags): Display * sem_util.ads, sem_util.adb: (Propagate_Type_Has_Flags): New procedure to factorize code. * exp_ch3.adb (Expand_Freeze_Array_Type, Expand_Freeze_Record_Type): Call Propagate_Type_Has_Flags. * sem_ch3.adb (Access_Type_Decalaration): Initialize Has_Timing_Event flag. (Analyze_Object_Declaration): Move code that check No_Local_Timing_Events near the code that check No_Local_Protected_Objects. (Analyze_Private_Extension_Declaration, Array_Type_Declaration) (Build_Derived_Type, Copy_Array_Base_Type_Attributes, Process_Full_View) (Record_Type_Definition): Call Propagate_Type_Has_Flags. * sem_ch4.adb (Analyze_Allocator): Check No_Local_Timing_Events. * sem_ch7.adb (New_Private_Type): Set Has_Timing_Event on the Timing_Event type. (Uninstall_Declaration): Call Propagate_Type_Has_Flags. * sem_ch9.adb (Analyze_Protected_Definition): Call Propagate_Type_Has_Flags. 2016-06-14 Arnaud Charlet * sem.ads: Minor style fix. From-SVN: r237434 --- gcc/ada/ChangeLog | 27 ++++++++++++++++++++++ gcc/ada/einfo.adb | 26 ++++++++++++++++++++-- gcc/ada/einfo.ads | 11 +++++++++ gcc/ada/exp_ch3.adb | 17 +++++--------- gcc/ada/sem.ads | 4 ++-- gcc/ada/sem_ch3.adb | 53 ++++++++++++++++---------------------------- gcc/ada/sem_ch4.adb | 8 +++++++ gcc/ada/sem_ch7.adb | 11 +++++++-- gcc/ada/sem_ch9.adb | 12 ++-------- gcc/ada/sem_util.adb | 21 ++++++++++++++++++ gcc/ada/sem_util.ads | 9 ++++++++ 11 files changed, 137 insertions(+), 62 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 80537b66463..479c7f04887 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,30 @@ +2016-06-14 Tristan Gingold + + * einfo.adb, einfo.ads (Has_Timing_Event, + Set_Has_Timing_Event): Add Has_Timing_Event flag. + (Write_Entity_Flags): Display * sem_util.ads, sem_util.adb: + (Propagate_Type_Has_Flags): New procedure to factorize code. + * exp_ch3.adb (Expand_Freeze_Array_Type, + Expand_Freeze_Record_Type): Call Propagate_Type_Has_Flags. + * sem_ch3.adb (Access_Type_Decalaration): Initialize + Has_Timing_Event flag. (Analyze_Object_Declaration): + Move code that check No_Local_Timing_Events near + the code that check No_Local_Protected_Objects. + (Analyze_Private_Extension_Declaration, Array_Type_Declaration) + (Build_Derived_Type, Copy_Array_Base_Type_Attributes, + Process_Full_View) (Record_Type_Definition): Call + Propagate_Type_Has_Flags. + * sem_ch4.adb (Analyze_Allocator): Check No_Local_Timing_Events. + * sem_ch7.adb (New_Private_Type): Set Has_Timing_Event on the + Timing_Event type. + (Uninstall_Declaration): Call Propagate_Type_Has_Flags. + * sem_ch9.adb (Analyze_Protected_Definition): Call + Propagate_Type_Has_Flags. + +2016-06-14 Arnaud Charlet + + * sem.ads: Minor style fix. + 2016-06-14 Ed Schonberg * sem_ch12.adb (Analyze_Associations): An actual parameter diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index f215564231c..8f4a1347615 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -601,10 +601,21 @@ package body Einfo is -- Is_Exception_Handler Flag286 -- Rewritten_For_C Flag287 -- Predicates_Ignored Flag288 + -- Has_Timing_Event Flag289 - -- (unused) Flag289 - -- (unused) Flag300 + -- (unused) Flag290 + + -- (unused) Flag291 + -- (unused) Flag292 + -- (unused) Flag293 + -- (unused) Flag294 + -- (unused) Flag295 + -- (unused) Flag296 + -- (unused) Flag297 + -- (unused) Flag298 + -- (unused) Flag299 + -- (unused) Flag300 -- (unused) Flag301 -- (unused) Flag302 -- (unused) Flag303 @@ -1879,6 +1890,11 @@ package body Einfo is return Flag228 (Id); end Has_Thunks; + function Has_Timing_Event (Id : E) return B is + begin + return Flag289 (Base_Type (Id)); + end Has_Timing_Event; + function Has_Unchecked_Union (Id : E) return B is begin return Flag123 (Base_Type (Id)); @@ -4867,6 +4883,11 @@ package body Einfo is Set_Flag228 (Id, V); end Set_Has_Thunks; + procedure Set_Has_Timing_Event (Id : E; V : B := True) is + begin + Set_Flag289 (Id, V); + end Set_Has_Timing_Event; + procedure Set_Has_Unchecked_Union (Id : E; V : B := True) is begin pragma Assert (Id = Base_Type (Id)); @@ -8972,6 +8993,7 @@ package body Einfo is W ("Has_Storage_Size_Clause", Flag23 (Id)); W ("Has_Stream_Size_Clause", Flag184 (Id)); W ("Has_Task", Flag30 (Id)); + W ("Has_Timing_Event", Flag289 (Id)); W ("Has_Thunks", Flag228 (Id)); W ("Has_Unchecked_Union", Flag123 (Id)); W ("Has_Unknown_Discriminants", Flag72 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index c8b9469de98..405455d1b0e 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2050,6 +2050,12 @@ package Einfo is -- such an object must create the required tasks. Note: the flag is not -- set on access types, even if they designate an object that Has_Task. +-- Has_Timing_Event (Flag289) [base type only] +-- Defined in all type entities. Set on language defined type +-- Ada.Real_Time.Timing_Events.Timing_Event, and also (recursively) on +-- any composite type which has a component for which Has_Timing_Event +-- is set. Used for the No_Local_Timing_Event restriction. + -- Has_Thunks (Flag228) -- Applies to E_Constant entities marked Is_Tag. True for secondary tag -- referencing a dispatch table whose contents are pointers to thunks. @@ -5507,6 +5513,7 @@ package Einfo is -- Has_Static_Predicate (Flag269) -- Has_Static_Predicate_Aspect (Flag259) -- Has_Task (Flag30) (base type only) + -- Has_Timing_Event (Flag289) (base type only) -- Has_Unchecked_Union (Flag123) (base type only) -- Has_Volatile_Components (Flag87) (base type only) -- In_Use (Flag8) @@ -6960,6 +6967,7 @@ package Einfo is function Has_Storage_Size_Clause (Id : E) return B; function Has_Stream_Size_Clause (Id : E) return B; function Has_Task (Id : E) return B; + function Has_Timing_Event (Id : E) return B; function Has_Thunks (Id : E) return B; function Has_Unchecked_Union (Id : E) return B; function Has_Unknown_Discriminants (Id : E) return B; @@ -7629,6 +7637,7 @@ package Einfo is procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True); procedure Set_Has_Stream_Size_Clause (Id : E; V : B := True); procedure Set_Has_Task (Id : E; V : B := True); + procedure Set_Has_Timing_Event (Id : E; V : B := True); procedure Set_Has_Thunks (Id : E; V : B := True); procedure Set_Has_Unchecked_Union (Id : E; V : B := True); procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True); @@ -8413,6 +8422,7 @@ package Einfo is pragma Inline (Has_Storage_Size_Clause); pragma Inline (Has_Stream_Size_Clause); pragma Inline (Has_Task); + pragma Inline (Has_Timing_Event); pragma Inline (Has_Thunks); pragma Inline (Has_Unchecked_Union); pragma Inline (Has_Unknown_Discriminants); @@ -8922,6 +8932,7 @@ package Einfo is pragma Inline (Set_Has_Storage_Size_Clause); pragma Inline (Set_Has_Stream_Size_Clause); pragma Inline (Set_Has_Task); + pragma Inline (Set_Has_Timing_Event); pragma Inline (Set_Has_Thunks); pragma Inline (Set_Has_Unchecked_Union); pragma Inline (Set_Has_Unknown_Discriminants); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 18249d83a44..b5074174211 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -4612,13 +4612,12 @@ package body Exp_Ch3 is -- been a private type at the point of definition. Same if component -- type is controlled or contains protected objects. - Set_Has_Task (Base, Has_Task (Comp_Typ)); - Set_Has_Protected (Base, Has_Protected (Comp_Typ)); + Propagate_Type_Has_Flags (Base, Comp_Typ); Set_Has_Controlled_Component - (Base, Has_Controlled_Component + (Base, Has_Controlled_Component (Comp_Typ) - or else - Is_Controlled (Comp_Typ)); + or else + Is_Controlled (Comp_Typ)); if No (Init_Proc (Base)) then @@ -5185,13 +5184,7 @@ package body Exp_Ch3 is while Present (Comp) loop Comp_Typ := Etype (Comp); - if Has_Task (Comp_Typ) then - Set_Has_Task (Typ); - end if; - - if Has_Protected (Comp_Typ) then - Set_Has_Protected (Typ); - end if; + Propagate_Type_Has_Flags (Typ, Comp_Typ); -- Do not set Has_Controlled_Component on a class-wide equivalent -- type. See Make_CW_Equivalent_Type. diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index 22da2233005..c52f6b492e7 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -122,7 +122,7 @@ -- xx : x := y * z; -- end record; --- for x'small use 0.25 +-- for x'small use 0.25; -- The expander is in charge of dealing with fixed-point, and of course the -- small declaration, which is not too late, since the declaration of type q diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 17ac948651b..9f13bd9d031 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -1437,8 +1437,9 @@ package body Sem_Ch3 is -- and to Has_Protected. Set_Has_Task (T, False); - Set_Has_Controlled_Component (T, False); Set_Has_Protected (T, False); + Set_Has_Timing_Event (T, False); + Set_Has_Controlled_Component (T, False); -- Initialize field Finalization_Master explicitly to Empty, to avoid -- problems where an incomplete view of this entity has been previously @@ -3585,6 +3586,12 @@ package body Sem_Ch3 is end if; end if; + -- Check for violation of No_Local_Timing_Events + + if Has_Timing_Event (T) and then not Is_Library_Level_Entity (Id) then + Check_Restriction (No_Local_Timing_Events, Id); + end if; + -- The actual subtype of the object is the nominal subtype, unless -- the nominal one is unconstrained and obtained from the expression. @@ -4362,15 +4369,6 @@ package body Sem_Ch3 is Set_In_Private_Part (Id); end if; - -- Check for violation of No_Local_Timing_Events - - if Restriction_Check_Required (No_Local_Timing_Events) - and then not Is_Library_Level_Entity (Id) - and then Is_RTE (Etype (Id), RE_Timing_Event) - then - Check_Restriction (No_Local_Timing_Events, N); - end if; - <> -- Initialize the refined state of a variable here because this is a -- common destination for legal and illegal object declarations. @@ -4515,9 +4513,8 @@ package body Sem_Ch3 is Init_Size_Align (T); Set_Default_SSO (T); - Set_Etype (T, Parent_Base); - Set_Has_Task (T, Has_Task (Parent_Base)); - Set_Has_Protected (T, Has_Task (Parent_Base)); + Set_Etype (T, Parent_Base); + Propagate_Type_Has_Flags (T, Parent_Base); Set_Convention (T, Convention (Parent_Type)); Set_First_Rep_Item (T, First_Rep_Item (Parent_Type)); @@ -5576,8 +5573,7 @@ package body Sem_Ch3 is Set_First_Index (Implicit_Base, First_Index (T)); Set_Component_Type (Implicit_Base, Element_Type); - Set_Has_Task (Implicit_Base, Has_Task (Element_Type)); - Set_Has_Protected (Implicit_Base, Has_Protected (Element_Type)); + Propagate_Type_Has_Flags (Implicit_Base, Element_Type); Set_Component_Size (Implicit_Base, Uint_0); Set_Packed_Array_Impl_Type (Implicit_Base, Empty); Set_Has_Controlled_Component (Implicit_Base, @@ -5603,8 +5599,7 @@ package body Sem_Ch3 is Set_Is_Constrained (T, False); Set_First_Index (T, First (Subtype_Marks (Def))); Set_Has_Delayed_Freeze (T, True); - Set_Has_Task (T, Has_Task (Element_Type)); - Set_Has_Protected (T, Has_Protected (Element_Type)); + Propagate_Type_Has_Flags (T, Element_Type); Set_Has_Controlled_Component (T, Has_Controlled_Component (Element_Type) or else @@ -8951,12 +8946,11 @@ package body Sem_Ch3 is begin -- Set common attributes - Set_Scope (Derived_Type, Current_Scope); + Set_Scope (Derived_Type, Current_Scope); - Set_Etype (Derived_Type, Parent_Base); - Set_Ekind (Derived_Type, Ekind (Parent_Base)); - Set_Has_Task (Derived_Type, Has_Task (Parent_Base)); - Set_Has_Protected (Derived_Type, Has_Protected (Parent_Base)); + Set_Etype (Derived_Type, Parent_Base); + Set_Ekind (Derived_Type, Ekind (Parent_Base)); + Propagate_Type_Has_Flags (Derived_Type, Parent_Base); Set_Size_Info (Derived_Type, Parent_Type); Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); @@ -13713,8 +13707,7 @@ package body Sem_Ch3 is Set_Component_Size (T1, Component_Size (T2)); Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2)); Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2)); - Set_Has_Protected (T1, Has_Protected (T2)); - Set_Has_Task (T1, Has_Task (T2)); + Propagate_Type_Has_Flags (T1, T2); Set_Is_Packed (T1, Is_Packed (T2)); Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2)); Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2)); @@ -19931,9 +19924,7 @@ package body Sem_Ch3 is Set_Class_Wide_Type (Base_Type (Full_T), Class_Wide_Type (Priv_T)); - Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T)); - Set_Has_Protected - (Class_Wide_Type (Priv_T), Has_Protected (Full_T)); + Propagate_Type_Has_Flags (Class_Wide_Type (Priv_T), Full_T); end if; end; end if; @@ -21289,13 +21280,7 @@ package body Sem_Ch3 is Init_Component_Location (Component); end if; - if Has_Task (Etype (Component)) then - Set_Has_Task (T); - end if; - - if Has_Protected (Etype (Component)) then - Set_Has_Protected (T); - end if; + Propagate_Type_Has_Flags (T, Etype (Component)); if Ekind (Component) /= E_Component then null; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 33e3091e8e9..20d1a740765 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -812,6 +812,14 @@ package body Sem_Ch4 is Check_Restriction (No_Local_Protected_Objects, N); end if; + -- Likewise for No_Local_Timing_Events + + if Has_Timing_Event (Designated_Type (Acc_Type)) + and then not Is_Library_Level_Entity (Acc_Type) + then + Check_Restriction (No_Local_Timing_Events, N); + end if; + -- If the No_Streams restriction is set, check that the type of the -- object is not, and does not contain, any subtype derived from -- Ada.Streams.Root_Stream_Type. Note that we guard the call to diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 1a8786d7f58..bb475890049 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -47,6 +47,7 @@ with Nlists; use Nlists; with Opt; use Opt; with Output; use Output; with Restrict; use Restrict; +with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; @@ -2446,6 +2447,12 @@ package body Sem_Ch7 is Set_Is_Limited_Record (Id, Limited_Present (Def)); Set_Has_Delayed_Freeze (Id, True); + -- Recognize Ada.Real_Time.Timing_Events.Timing_Events here + + if Is_RTE (Id, RE_Timing_Event) then + Set_Has_Timing_Event (Id); + end if; + -- Create a class-wide type with the same attributes Make_Class_Wide_Type (Id); @@ -2578,8 +2585,8 @@ package body Sem_Ch7 is Set_Finalize_Storage_Only (Priv, Finalize_Storage_Only (Base_Type (Full))); - Set_Has_Task (Priv, Has_Task (Base_Type (Full))); - Set_Has_Protected (Priv, Has_Protected (Base_Type (Full))); + Propagate_Type_Has_Flags + (Priv, Base_Type (Full)); Set_Has_Controlled_Component (Priv, Has_Controlled_Component (Base_Type (Full))); diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 442a71d9f08..adfd27d0e98 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -1937,16 +1937,8 @@ package body Sem_Ch9 is while Present (E) loop if Ekind_In (E, E_Function, E_Procedure) then Set_Convention (E, Convention_Protected); - - elsif Is_Task_Type (Etype (E)) - or else Has_Task (Etype (E)) - then - Set_Has_Task (Current_Scope); - - elsif Is_Protected_Type (Etype (E)) - or else Has_Protected (Etype (E)) - then - Set_Has_Protected (Current_Scope); + else + Propagate_Type_Has_Flags (Current_Scope, Etype (E)); end if; Next_Entity (E); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 5dbaccd522b..6237d7b5d0c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -18300,6 +18300,27 @@ package body Sem_Util is Set_Sloc (Endl, Loc); end Process_End_Label; + ------------------------------ + -- Propagate_Type_Has_Flags -- + ------------------------------ + + procedure Propagate_Type_Has_Flags + (Typ : Entity_Id; + Comp_Typ : Entity_Id) is + begin + if Has_Task (Comp_Typ) then + Set_Has_Task (Typ); + end if; + + if Has_Protected (Comp_Typ) then + Set_Has_Protected (Typ); + end if; + + if Has_Timing_Event (Comp_Typ) then + Set_Has_Timing_Event (Typ); + end if; + end Propagate_Type_Has_Flags; + --------------------------------------- -- Record_Possible_Part_Of_Reference -- --------------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index c7fdc8181d5..d0e3d4ee87f 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2003,6 +2003,15 @@ package Sem_Util is -- parameter Ent gives the entity to which the End_Label refers, -- and to which cross-references are to be generated. + procedure Propagate_Type_Has_Flags + (Typ : Entity_Id; + Comp_Typ : Entity_Id); + -- Set Has_Task, Has_Protected and Has_Timing_Event on Typ when the flags + -- are set on Comp_Typ. This follows the definition of these flags which + -- are set (recursively) on any composite type which has a component marked + -- by one of these flags. This procedure can only set flags for Typ, and + -- never clear them. Comp_Typ is the type of a component or a parent. + procedure Record_Possible_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id); -- 2.30.2