This patch implements a new GNAT restriction named Static_Dispatch_Tables,
which is intented to prevent the creation of tagged types whose dispatch
tables cannot be placed in read-only memory.
The following test now compiles with errors.
pragma Restrictions (Static_Dispatch_Tables);
procedure Test_Static_DT is
package Local is
type Typ is tagged null record; -- Test
procedure Prim (Obj : Typ);
end;
package body Local is
procedure Prim (Obj : Typ) is
begin
null;
end;
end;
Obj : Local.Typ;
begin
Obj.Prim;
end;
Command: gcc -c test_static_dt.adb
test_static_dt.adb:5:12: violation of restriction
"Static_Dispatch_Tables" at line 1
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-11-09 Javier Miranda <[email protected]>
* 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.
Index: exp_aggr.adb
===================================================================
--- exp_aggr.adb (revision 254563)
+++ exp_aggr.adb (working copy)
@@ -7533,7 +7533,7 @@
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)
Index: libgnat/s-rident.ads
===================================================================
--- libgnat/s-rident.ads (revision 254563)
+++ libgnat/s-rident.ads (working copy)
@@ -183,6 +183,7 @@
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
Index: exp_disp.adb
===================================================================
--- exp_disp.adb (revision 254566)
+++ exp_disp.adb (working copy)
@@ -281,7 +281,8 @@
------------------------
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 @@
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 @@
-- 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 @@
----------------------------------
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 @@
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 @@
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
Index: gnat1drv.adb
===================================================================
--- gnat1drv.adb (revision 254571)
+++ gnat1drv.adb (working copy)
@@ -590,7 +590,7 @@
-- 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
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 254571)
+++ exp_ch3.adb (working copy)
@@ -6280,7 +6280,7 @@
-- 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,
Index: opt.ads
===================================================================
--- opt.ads (revision 254563)
+++ opt.ads (working copy)
@@ -2148,17 +2148,7 @@
-- 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 @@
-- 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 --
-----------------------
