Commit 6214b83b by Pierre-Marie de Rodat

[multiple changes]

2017-11-09  Javier Miranda  <miranda@adacore.com>

	* 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  <obry@adacore.com>

	* libgnarl/s-taprop__mingw.adb: Minor code clean-up.  Better using a
	named number.

From-SVN: r254572
parent d63199d8
2017-11-09 Javier Miranda <miranda@adacore.com>
* 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 <obry@adacore.com>
* libgnarl/s-taprop__mingw.adb: Minor code clean-up. Better using a
named number.
2017-11-09 Yannick Moy <moy@adacore.com> 2017-11-09 Yannick Moy <moy@adacore.com>
* binde.adb (Diagnose_Elaboration_Problem): Mark procedure No_Return. * binde.adb (Diagnose_Elaboration_Problem): Mark procedure No_Return.
......
...@@ -7533,7 +7533,7 @@ package body Exp_Aggr is ...@@ -7533,7 +7533,7 @@ package body Exp_Aggr is
Typ : constant Entity_Id := Base_Type (Etype (N)); Typ : constant Entity_Id := Base_Type (Etype (N));
begin begin
return Static_Dispatch_Tables return Building_Static_Dispatch_Tables
and then Tagged_Type_Expansion and then Tagged_Type_Expansion
and then RTU_Loaded (Ada_Tags) and then RTU_Loaded (Ada_Tags)
......
...@@ -6280,7 +6280,7 @@ package body Exp_Ch3 is ...@@ -6280,7 +6280,7 @@ package body Exp_Ch3 is
-- Force construction of dispatch tables of library level tagged types -- Force construction of dispatch tables of library level tagged types
if Tagged_Type_Expansion 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_Entity (Def_Id)
and then Is_Library_Level_Tagged_Type (Base_Typ) and then Is_Library_Level_Tagged_Type (Base_Typ)
and then Ekind_In (Base_Typ, E_Record_Type, and then Ekind_In (Base_Typ, E_Record_Type,
......
...@@ -281,7 +281,8 @@ package body Exp_Disp is ...@@ -281,7 +281,8 @@ package body Exp_Disp is
------------------------ ------------------------
function Building_Static_DT (Typ : Entity_Id) return Boolean 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 begin
-- Handle private types -- Handle private types
...@@ -290,7 +291,7 @@ package body Exp_Disp is ...@@ -290,7 +291,7 @@ package body Exp_Disp is
Root_Typ := Full_View (Root_Typ); Root_Typ := Full_View (Root_Typ);
end if; end if;
return Static_Dispatch_Tables Static_DT := Building_Static_Dispatch_Tables
and then Is_Library_Level_Tagged_Type (Typ) and then Is_Library_Level_Tagged_Type (Typ)
-- If the type is derived from a CPP class we cannot statically -- If the type is derived from a CPP class we cannot statically
...@@ -298,6 +299,12 @@ package body Exp_Disp is ...@@ -298,6 +299,12 @@ package body Exp_Disp is
-- from the CPP side. -- from the CPP side.
and then not Is_CPP_Class (Root_Typ); 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; end Building_Static_DT;
---------------------------------- ----------------------------------
...@@ -305,8 +312,9 @@ package body Exp_Disp is ...@@ -305,8 +312,9 @@ package body Exp_Disp is
---------------------------------- ----------------------------------
function Building_Static_Secondary_DT (Typ : Entity_Id) return Boolean is function Building_Static_Secondary_DT (Typ : Entity_Id) return Boolean is
Full_Typ : Entity_Id := Typ; Full_Typ : Entity_Id := Typ;
Root_Typ : Entity_Id := Root_Type (Typ); Root_Typ : Entity_Id := Root_Type (Typ);
Static_DT : Boolean;
begin begin
-- Handle private types -- Handle private types
...@@ -319,11 +327,20 @@ package body Exp_Disp is ...@@ -319,11 +327,20 @@ package body Exp_Disp is
Root_Typ := Full_View (Root_Typ); Root_Typ := Full_View (Root_Typ);
end if; end if;
return Building_Static_DT (Full_Typ) Static_DT := Building_Static_DT (Full_Typ)
and then not Is_Interface (Full_Typ) and then not Is_Interface (Full_Typ)
and then Has_Interfaces (Full_Typ) and then Has_Interfaces (Full_Typ)
and then (Full_Typ = Root_Typ and then (Full_Typ = Root_Typ
or else not Is_Variable_Size_Record (Etype (Full_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; end Building_Static_Secondary_DT;
---------------------------------- ----------------------------------
...@@ -5103,7 +5120,8 @@ package body Exp_Disp is ...@@ -5103,7 +5120,8 @@ package body Exp_Disp is
Append_To (Result, Append_To (Result,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => HT_Link, 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; end if;
-- Generate code to create the storage for the type specific data object -- Generate code to create the storage for the type specific data object
......
...@@ -590,7 +590,7 @@ procedure Gnat1drv is ...@@ -590,7 +590,7 @@ procedure Gnat1drv is
-- problems with subtypes of type Ada.Tags.Dispatch_Table_Wrapper. ??? -- problems with subtypes of type Ada.Tags.Dispatch_Table_Wrapper. ???
if Debug_Flag_Dot_T then if Debug_Flag_Dot_T then
Static_Dispatch_Tables := False; Building_Static_Dispatch_Tables := False;
end if; end if;
-- Flip endian mode if -gnatd8 set -- Flip endian mode if -gnatd8 set
......
...@@ -976,7 +976,7 @@ package body System.Task_Primitives.Operations is ...@@ -976,7 +976,7 @@ package body System.Task_Primitives.Operations is
Known_Tasks (T.Known_Tasks_Index) := null; Known_Tasks (T.Known_Tasks_Index) := null;
end if; 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 -- This task has been activated. Close the thread handle. This
-- is needed to release system resources. -- is needed to release system resources.
......
...@@ -183,6 +183,7 @@ package System.Rident is ...@@ -183,6 +183,7 @@ package System.Rident is
No_Elaboration_Code, -- GNAT No_Elaboration_Code, -- GNAT
No_Obsolescent_Features, -- Ada 2005 AI-368 No_Obsolescent_Features, -- Ada 2005 AI-368
No_Wide_Characters, -- GNAT No_Wide_Characters, -- GNAT
Static_Dispatch_Tables, -- GNAT
SPARK_05, -- GNAT SPARK_05, -- GNAT
-- The following cases require a parameter value -- The following cases require a parameter value
......
...@@ -2148,17 +2148,7 @@ package Opt is ...@@ -2148,17 +2148,7 @@ package Opt is
-- Other Global Flags -- -- Other Global Flags --
------------------------ ------------------------
Expander_Active : Boolean := False; Building_Static_Dispatch_Tables : Boolean := True;
-- 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;
-- This flag indicates if the backend supports generation of statically -- This flag indicates if the backend supports generation of statically
-- allocated dispatch tables. If it is True, then the front end will -- allocated dispatch tables. If it is True, then the front end will
-- generate static aggregates for dispatch tables that contain forward -- generate static aggregates for dispatch tables that contain forward
...@@ -2170,6 +2160,16 @@ package Opt is ...@@ -2170,6 +2160,16 @@ package Opt is
-- behavior can be disabled using switch -gnatd.t which will set this flag -- behavior can be disabled using switch -gnatd.t which will set this flag
-- to False and revert to the previous dynamic behavior. -- 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 -- -- Tree I/O Routines --
----------------------- -----------------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment