From 6214b83bf1b6d05c9ff3bdb419975851bc131b97 Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Thu, 9 Nov 2017 11:57:50 +0000 Subject: [PATCH] [multiple changes] 2017-11-09 Javier Miranda * libgnat/s-rident.ads (Static_Dispatch_Tables): New restriction name. * exp_disp.adb (Building_Static_DT): Check restriction. (Building_Static_Secondary_DT): Check restriction. (Make_DT): Initialize the HT_Link to No_Tag. * opt.ads (Static_Dispatch_Tables): Rename flag... (Building_Static_Dispatch_Tables): ... into this. This will avoid conflict with the restriction name. * gnat1drv.adb: Update. * exp_aggr.adb (Is_Static_Dispatch_Table_Aggregate): Update. * exp_ch3.adb (Expand_N_Object_Declaration): Update. 2017-11-09 Pascal Obry * libgnarl/s-taprop__mingw.adb: Minor code clean-up. Better using a named number. From-SVN: r254572 --- gcc/ada/ChangeLog | 18 ++++++++++++++++++ gcc/ada/exp_aggr.adb | 2 +- gcc/ada/exp_ch3.adb | 2 +- gcc/ada/exp_disp.adb | 30 ++++++++++++++++++++++++------ gcc/ada/gnat1drv.adb | 2 +- gcc/ada/libgnarl/s-taprop__mingw.adb | 2 +- gcc/ada/libgnat/s-rident.ads | 1 + gcc/ada/opt.ads | 22 +++++++++++----------- 8 files changed, 58 insertions(+), 21 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f612544..1ccc7df 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,21 @@ +2017-11-09 Javier Miranda + + * libgnat/s-rident.ads (Static_Dispatch_Tables): New restriction name. + * exp_disp.adb (Building_Static_DT): Check restriction. + (Building_Static_Secondary_DT): Check restriction. + (Make_DT): Initialize the HT_Link to No_Tag. + * opt.ads (Static_Dispatch_Tables): Rename flag... + (Building_Static_Dispatch_Tables): ... into this. This will avoid + conflict with the restriction name. + * gnat1drv.adb: Update. + * exp_aggr.adb (Is_Static_Dispatch_Table_Aggregate): Update. + * exp_ch3.adb (Expand_N_Object_Declaration): Update. + +2017-11-09 Pascal Obry + + * libgnarl/s-taprop__mingw.adb: Minor code clean-up. Better using a + named number. + 2017-11-09 Yannick Moy * binde.adb (Diagnose_Elaboration_Problem): Mark procedure No_Return. diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 86621a4..a2498f8 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -7533,7 +7533,7 @@ package body Exp_Aggr is Typ : constant Entity_Id := Base_Type (Etype (N)); begin - return Static_Dispatch_Tables + return Building_Static_Dispatch_Tables and then Tagged_Type_Expansion and then RTU_Loaded (Ada_Tags) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 3385efa..16bbb18 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6280,7 +6280,7 @@ package body Exp_Ch3 is -- Force construction of dispatch tables of library level tagged types if Tagged_Type_Expansion - and then Static_Dispatch_Tables + and then Building_Static_Dispatch_Tables and then Is_Library_Level_Entity (Def_Id) and then Is_Library_Level_Tagged_Type (Base_Typ) and then Ekind_In (Base_Typ, E_Record_Type, diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index b29686a..caa7945 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -281,7 +281,8 @@ package body Exp_Disp is ------------------------ function Building_Static_DT (Typ : Entity_Id) return Boolean is - Root_Typ : Entity_Id := Root_Type (Typ); + Root_Typ : Entity_Id := Root_Type (Typ); + Static_DT : Boolean; begin -- Handle private types @@ -290,7 +291,7 @@ package body Exp_Disp is Root_Typ := Full_View (Root_Typ); end if; - return Static_Dispatch_Tables + Static_DT := Building_Static_Dispatch_Tables and then Is_Library_Level_Tagged_Type (Typ) -- If the type is derived from a CPP class we cannot statically @@ -298,6 +299,12 @@ package body Exp_Disp is -- from the CPP side. and then not Is_CPP_Class (Root_Typ); + + if not Static_DT then + Check_Restriction (Static_Dispatch_Tables, Typ); + end if; + + return Static_DT; end Building_Static_DT; ---------------------------------- @@ -305,8 +312,9 @@ package body Exp_Disp is ---------------------------------- function Building_Static_Secondary_DT (Typ : Entity_Id) return Boolean is - Full_Typ : Entity_Id := Typ; - Root_Typ : Entity_Id := Root_Type (Typ); + Full_Typ : Entity_Id := Typ; + Root_Typ : Entity_Id := Root_Type (Typ); + Static_DT : Boolean; begin -- Handle private types @@ -319,11 +327,20 @@ package body Exp_Disp is Root_Typ := Full_View (Root_Typ); end if; - return Building_Static_DT (Full_Typ) + Static_DT := Building_Static_DT (Full_Typ) and then not Is_Interface (Full_Typ) and then Has_Interfaces (Full_Typ) and then (Full_Typ = Root_Typ or else not Is_Variable_Size_Record (Etype (Full_Typ))); + + if not Static_DT + and then not Is_Interface (Full_Typ) + and then Has_Interfaces (Full_Typ) + then + Check_Restriction (Static_Dispatch_Tables, Typ); + end if; + + return Static_DT; end Building_Static_Secondary_DT; ---------------------------------- @@ -5103,7 +5120,8 @@ package body Exp_Disp is Append_To (Result, Make_Object_Declaration (Loc, Defining_Identifier => HT_Link, - Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc))); + Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc), + Expression => New_Occurrence_Of (RTE (RE_No_Tag), Loc))); end if; -- Generate code to create the storage for the type specific data object diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 7138c85..3e4234b 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -590,7 +590,7 @@ procedure Gnat1drv is -- problems with subtypes of type Ada.Tags.Dispatch_Table_Wrapper. ??? if Debug_Flag_Dot_T then - Static_Dispatch_Tables := False; + Building_Static_Dispatch_Tables := False; end if; -- Flip endian mode if -gnatd8 set diff --git a/gcc/ada/libgnarl/s-taprop__mingw.adb b/gcc/ada/libgnarl/s-taprop__mingw.adb index b14444a..c14c228 100644 --- a/gcc/ada/libgnarl/s-taprop__mingw.adb +++ b/gcc/ada/libgnarl/s-taprop__mingw.adb @@ -976,7 +976,7 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - if T.Common.LL.Thread /= 0 then + if T.Common.LL.Thread /= Null_Thread_Id then -- This task has been activated. Close the thread handle. This -- is needed to release system resources. diff --git a/gcc/ada/libgnat/s-rident.ads b/gcc/ada/libgnat/s-rident.ads index cd88593..cde036a 100644 --- a/gcc/ada/libgnat/s-rident.ads +++ b/gcc/ada/libgnat/s-rident.ads @@ -183,6 +183,7 @@ package System.Rident is No_Elaboration_Code, -- GNAT No_Obsolescent_Features, -- Ada 2005 AI-368 No_Wide_Characters, -- GNAT + Static_Dispatch_Tables, -- GNAT SPARK_05, -- GNAT -- The following cases require a parameter value diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 96e2f3e..94ed953 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -2148,17 +2148,7 @@ package Opt is -- Other Global Flags -- ------------------------ - Expander_Active : Boolean := False; - -- A flag that indicates if expansion is active (True) or deactivated - -- (False). When expansion is deactivated all calls to expander routines - -- have no effect. Note that the initial setting of False is merely to - -- prevent saving of an undefined value for an initial call to the - -- Expander_Mode_Save_And_Set procedure. For more information on the use of - -- this flag, see package Expander. Indeed this flag might more logically - -- be in the spec of Expander, but it is referenced by Errout, and it - -- really seems wrong for Errout to depend on Expander. - - Static_Dispatch_Tables : Boolean := True; + Building_Static_Dispatch_Tables : Boolean := True; -- This flag indicates if the backend supports generation of statically -- allocated dispatch tables. If it is True, then the front end will -- generate static aggregates for dispatch tables that contain forward @@ -2170,6 +2160,16 @@ package Opt is -- behavior can be disabled using switch -gnatd.t which will set this flag -- to False and revert to the previous dynamic behavior. + Expander_Active : Boolean := False; + -- A flag that indicates if expansion is active (True) or deactivated + -- (False). When expansion is deactivated all calls to expander routines + -- have no effect. Note that the initial setting of False is merely to + -- prevent saving of an undefined value for an initial call to the + -- Expander_Mode_Save_And_Set procedure. For more information on the use of + -- this flag, see package Expander. Indeed this flag might more logically + -- be in the spec of Expander, but it is referenced by Errout, and it + -- really seems wrong for Errout to depend on Expander. + ----------------------- -- Tree I/O Routines -- ----------------------- -- 2.7.4