From 124bed29851cb5ece3d1218c6113a0774ffc26a7 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 14 Jun 2016 14:41:03 +0200 Subject: [PATCH] [multiple changes] 2016-06-14 Ed Schonberg * sem_ch6.adb (Set_Actual_Subtypes): Do not generate actual subtypes for unconstrained formals when analyzing the generated body of an expression function, because it may lead to premature and misplaced freezing of the types of formals. 2016-06-14 Gary Dismukes * sem_elab.adb, sem_ch4.adb: Minor reformatting and typo fix. 2016-06-14 Tristan Gingold * einfo.adb (Set_Has_Timing_Event): Add assertion. * sem_util.ads, sem_util.adb (Propagate_Concurrent_Flags): New name for Propagate_Type_Has_Flags. * exp_ch3.adb, sem_ch3.adb, sem_ch7.adb, sem_ch9.adb: Adjust after renaming. From-SVN: r237439 --- gcc/ada/ChangeLog | 19 +++++++++++++++++++ gcc/ada/einfo.adb | 1 + gcc/ada/exp_ch3.adb | 4 ++-- gcc/ada/sem_ch3.adb | 18 +++++++++--------- gcc/ada/sem_ch4.adb | 4 ++-- gcc/ada/sem_ch6.adb | 10 ++++++++++ gcc/ada/sem_ch7.adb | 2 +- gcc/ada/sem_ch9.adb | 2 +- gcc/ada/sem_elab.adb | 10 +++++----- gcc/ada/sem_util.adb | 10 +++++----- gcc/ada/sem_util.ads | 2 +- 11 files changed, 56 insertions(+), 26 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ef70ce53fd6..ebdf963de00 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,22 @@ +2016-06-14 Ed Schonberg + + * sem_ch6.adb (Set_Actual_Subtypes): Do not generate actual + subtypes for unconstrained formals when analyzing the generated + body of an expression function, because it may lead to premature + and misplaced freezing of the types of formals. + +2016-06-14 Gary Dismukes + + * sem_elab.adb, sem_ch4.adb: Minor reformatting and typo fix. + +2016-06-14 Tristan Gingold + + * einfo.adb (Set_Has_Timing_Event): Add assertion. + * sem_util.ads, sem_util.adb (Propagate_Concurrent_Flags): New + name for Propagate_Type_Has_Flags. + * exp_ch3.adb, sem_ch3.adb, sem_ch7.adb, sem_ch9.adb: Adjust after + renaming. + 2016-06-14 Bob Duff * sem_elab.adb (Check_A_Call): Do nothing if the callee is diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 8f4a1347615..f812026ce75 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -4885,6 +4885,7 @@ package body Einfo is procedure Set_Has_Timing_Event (Id : E; V : B := True) is begin + pragma Assert (Id = Base_Type (Id)); Set_Flag289 (Id, V); end Set_Has_Timing_Event; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 7f98b91d23d..06252736c7e 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -4619,7 +4619,7 @@ package body Exp_Ch3 is -- been a private type at the point of definition. Same if component -- type is controlled or contains protected objects. - Propagate_Type_Has_Flags (Base, Comp_Typ); + Propagate_Concurrent_Flags (Base, Comp_Typ); Set_Has_Controlled_Component (Base, Has_Controlled_Component (Comp_Typ) or else Is_Controlled (Comp_Typ)); @@ -5189,7 +5189,7 @@ package body Exp_Ch3 is while Present (Comp) loop Comp_Typ := Etype (Comp); - Propagate_Type_Has_Flags (Typ, Comp_Typ); + Propagate_Concurrent_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_ch3.adb b/gcc/ada/sem_ch3.adb index 9f13bd9d031..4e5b8f7f9ae 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4514,7 +4514,7 @@ package body Sem_Ch3 is Set_Default_SSO (T); Set_Etype (T, Parent_Base); - Propagate_Type_Has_Flags (T, Parent_Base); + Propagate_Concurrent_Flags (T, Parent_Base); Set_Convention (T, Convention (Parent_Type)); Set_First_Rep_Item (T, First_Rep_Item (Parent_Type)); @@ -5573,7 +5573,7 @@ package body Sem_Ch3 is Set_First_Index (Implicit_Base, First_Index (T)); Set_Component_Type (Implicit_Base, Element_Type); - Propagate_Type_Has_Flags (Implicit_Base, Element_Type); + Propagate_Concurrent_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, @@ -5599,7 +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); - Propagate_Type_Has_Flags (T, Element_Type); + Propagate_Concurrent_Flags (T, Element_Type); Set_Has_Controlled_Component (T, Has_Controlled_Component (Element_Type) or else @@ -8948,9 +8948,9 @@ package body Sem_Ch3 is Set_Scope (Derived_Type, Current_Scope); - Set_Etype (Derived_Type, Parent_Base); - Set_Ekind (Derived_Type, Ekind (Parent_Base)); - Propagate_Type_Has_Flags (Derived_Type, Parent_Base); + Set_Etype (Derived_Type, Parent_Base); + Set_Ekind (Derived_Type, Ekind (Parent_Base)); + Propagate_Concurrent_Flags (Derived_Type, Parent_Base); Set_Size_Info (Derived_Type, Parent_Type); Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); @@ -13707,7 +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)); - Propagate_Type_Has_Flags (T1, T2); + Propagate_Concurrent_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)); @@ -19924,7 +19924,7 @@ package body Sem_Ch3 is Set_Class_Wide_Type (Base_Type (Full_T), Class_Wide_Type (Priv_T)); - Propagate_Type_Has_Flags (Class_Wide_Type (Priv_T), Full_T); + Propagate_Concurrent_Flags (Class_Wide_Type (Priv_T), Full_T); end if; end; end if; @@ -21280,7 +21280,7 @@ package body Sem_Ch3 is Init_Component_Location (Component); end if; - Propagate_Type_Has_Flags (T, Etype (Component)); + Propagate_Concurrent_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 edcfee226d5..a109cd0c50c 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -3917,9 +3917,9 @@ package body Sem_Ch4 is if Warn_On_Suspicious_Contract and then not Referenced (Loop_Id, Cond) then - -- Generating C this check causes spurious warnings on inlined + -- Generating C, this check causes spurious warnings on inlined -- postconditions; we can safely disable it because this check - -- was previously performed when analying the internally built + -- was previously performed when analyzing the internally built -- postconditions procedure. if Modify_Tree_For_C and then In_Inlined_Body then diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index a6ac2920076..4f7efc30ff1 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -11150,6 +11150,16 @@ package body Sem_Ch6 is return; end if; + -- The subtype declarations may freeze the formals. The body generated + -- for an expression function is not a freeze point, so do not emit + -- these declarations (small loss of efficiency in rare cases). + + if Nkind (N) = N_Subprogram_Body + and then Was_Expression_Function (N) + then + return; + end if; + Formal := First_Formal (Subp); while Present (Formal) loop T := Etype (Formal); diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 8c318fddc73..0c235f624db 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -2585,7 +2585,7 @@ package body Sem_Ch7 is Set_Finalize_Storage_Only (Priv, Finalize_Storage_Only (Base_Type (Full))); - Propagate_Type_Has_Flags + Propagate_Concurrent_Flags (Priv, Base_Type (Full)); Set_Has_Controlled_Component (Priv, Has_Controlled_Component diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index adfd27d0e98..aa2a18de792 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -1938,7 +1938,7 @@ package body Sem_Ch9 is if Ekind_In (E, E_Function, E_Procedure) then Set_Convention (E, Convention_Protected); else - Propagate_Type_Has_Flags (Current_Scope, Etype (E)); + Propagate_Concurrent_Flags (Current_Scope, Etype (E)); end if; Next_Entity (E); diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 27fed6f0a47..48054400464 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -128,7 +128,7 @@ package body Sem_Elab is Table_Name => "Delay_Check"); C_Scope : Entity_Id; - -- Top level scope of current scope. Compute this only once at the outer + -- Top-level scope of current scope. Compute this only once at the outer -- level, i.e. for a call to Check_Elab_Call from outside this unit. Outer_Level_Sloc : Source_Ptr; @@ -532,7 +532,7 @@ package body Sem_Elab is -- Msg_S is an info message (output if Elab_Info_Messages is set. function Find_W_Scope return Entity_Id; - -- Find top level scope for called entity (not following renamings + -- Find top-level scope for called entity (not following renamings -- or derivations). This is where the Elaborate_All will go if it is -- needed. We start with the called entity, except in the case of an -- initialization procedure outside the current package, where the init @@ -653,7 +653,7 @@ package body Sem_Elab is -- we ignore this flag. E_Scope : Entity_Id; - -- Top level scope of entity for called subprogram. This value includes + -- Top-level scope of entity for called subprogram. This value includes -- following renamings and derivations, so this scope can be in a -- non-visible unit. This is the scope that is to be investigated to -- see whether an elaboration check is required. @@ -667,7 +667,7 @@ package body Sem_Elab is -- Flag set when a source entity is called during elaboration in SPARK W_Scope : constant Entity_Id := Find_W_Scope; - -- Top level scope of directly called entity for subprogram. This + -- Top-level scope of directly called entity for subprogram. This -- differs from E_Scope in the case where renamings or derivations -- are involved, since it does not follow these links. W_Scope is -- generally in a visible unit, and it is this scope that may require @@ -1587,7 +1587,7 @@ package body Sem_Elab is -- Static model, call is not in elaboration code, we -- never need to worry, because in the static model the - -- top level caller always takes care of things. + -- top-level caller always takes care of things. else return; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 020e6d739ce..c39e3a66545 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -18359,11 +18359,11 @@ package body Sem_Util is Set_Sloc (Endl, Loc); end Process_End_Label; - ------------------------------ - -- Propagate_Type_Has_Flags -- - ------------------------------ + -------------------------------- + -- Propagate_Concurrent_Flags -- + -------------------------------- - procedure Propagate_Type_Has_Flags + procedure Propagate_Concurrent_Flags (Typ : Entity_Id; Comp_Typ : Entity_Id) is begin @@ -18378,7 +18378,7 @@ package body Sem_Util is if Has_Timing_Event (Comp_Typ) then Set_Has_Timing_Event (Typ); end if; - end Propagate_Type_Has_Flags; + end Propagate_Concurrent_Flags; --------------------------------------- -- Record_Possible_Part_Of_Reference -- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index a1e703fbba9..b95366962e3 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2008,7 +2008,7 @@ 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 + procedure Propagate_Concurrent_Flags (Typ : Entity_Id; Comp_Typ : Entity_Id); -- Set Has_Task, Has_Protected and Has_Timing_Event on Typ when the flags -- 2.30.2