Commit 8c4ee6f5 by Arnaud Charlet

[multiple changes]

2011-08-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_prag.adb (Chain_PPC): Implement AI04-0230: null procedures can
	only have inheritable classwide pre/postconditions.

2011-08-02  Javier Miranda  <miranda@adacore.com>

	* a-tags.ads, a-tags.adb (Check_TSD): New subprogram.
	* rtsfind.ads (RE_Check_TSD): New runtime entity.
	* exp_disp.adb (Make_DT): Generate call to the new runtime routine that
	checks if the external tag of a type is the same as the external tag
	of some other declaration.

From-SVN: r177159
parent 0b3d16c0
2011-08-02 Ed Schonberg <schonberg@adacore.com>
* sem_prag.adb (Chain_PPC): Implement AI04-0230: null procedures can
only have inheritable classwide pre/postconditions.
2011-08-02 Javier Miranda <miranda@adacore.com>
* a-tags.ads, a-tags.adb (Check_TSD): New subprogram.
* rtsfind.ads (RE_Check_TSD): New runtime entity.
* exp_disp.adb (Make_DT): Generate call to the new runtime routine that
checks if the external tag of a type is the same as the external tag
of some other declaration.
2011-08-02 Thomas Quinot <quinot@adacore.com> 2011-08-02 Thomas Quinot <quinot@adacore.com>
* s-taskin.ads: Minor reformatting. * s-taskin.ads: Minor reformatting.
......
...@@ -303,6 +303,24 @@ package body Ada.Tags is ...@@ -303,6 +303,24 @@ package body Ada.Tags is
return This - Offset_To_Top (This); return This - Offset_To_Top (This);
end Base_Address; end Base_Address;
---------------
-- Check_TSD --
---------------
procedure Check_TSD (TSD : Type_Specific_Data_Ptr) is
T : Tag;
begin
-- Verify that the external tag of this TSD is not registered in the
-- runtime hash table.
T := External_Tag_HTable.Get (To_Address (TSD.External_Tag));
if T /= null then
raise Program_Error with "duplicated external tag";
end if;
end Check_TSD;
-------------------- --------------------
-- Descendant_Tag -- -- Descendant_Tag --
-------------------- --------------------
......
...@@ -421,6 +421,10 @@ private ...@@ -421,6 +421,10 @@ private
-- Ada 2005 (AI-251): Displace "This" to point to the base address of -- Ada 2005 (AI-251): Displace "This" to point to the base address of
-- the object (that is, the address of the primary tag of the object). -- the object (that is, the address of the primary tag of the object).
procedure Check_TSD (TSD : Type_Specific_Data_Ptr);
-- Ada 2012 (AI-113): Raise Program_Error if the external tag of this TSD
-- is the same as the external tag for some other tagged type declaration.
function Displace (This : System.Address; T : Tag) return System.Address; function Displace (This : System.Address; T : Tag) return System.Address;
-- Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch -- Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch
-- table of T. -- table of T.
......
...@@ -5990,6 +5990,24 @@ package body Exp_Disp is ...@@ -5990,6 +5990,24 @@ package body Exp_Disp is
end if; end if;
end if; end if;
-- Generate code to check if the external tag of this type is the same
-- as the external tag of some other declaration.
-- Check_TSD (TSD'Unrestricted_Access);
if not No_Run_Time_Mode
and then Ada_Version >= Ada_2012
and then RTE_Available (RE_Check_TSD)
then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RE_Check_TSD), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (TSD, Loc),
Attribute_Name => Name_Unchecked_Access))));
end if;
-- Generate code to register the Tag in the External_Tag hash table for -- Generate code to register the Tag in the External_Tag hash table for
-- the pure Ada type only. -- the pure Ada type only.
......
...@@ -551,6 +551,7 @@ package Rtsfind is ...@@ -551,6 +551,7 @@ package Rtsfind is
RE_Address_Array, -- Ada.Tags RE_Address_Array, -- Ada.Tags
RE_Addr_Ptr, -- Ada.Tags RE_Addr_Ptr, -- Ada.Tags
RE_Base_Address, -- Ada.Tags RE_Base_Address, -- Ada.Tags
RE_Check_TSD, -- Ada.Tags
RE_Cstring_Ptr, -- Ada.Tags RE_Cstring_Ptr, -- Ada.Tags
RE_Descendant_Tag, -- Ada.Tags RE_Descendant_Tag, -- Ada.Tags
RE_Dispatch_Table, -- Ada.Tags RE_Dispatch_Table, -- Ada.Tags
...@@ -1729,6 +1730,7 @@ package Rtsfind is ...@@ -1729,6 +1730,7 @@ package Rtsfind is
RE_Address_Array => Ada_Tags, RE_Address_Array => Ada_Tags,
RE_Addr_Ptr => Ada_Tags, RE_Addr_Ptr => Ada_Tags,
RE_Base_Address => Ada_Tags, RE_Base_Address => Ada_Tags,
RE_Check_TSD => Ada_Tags,
RE_Cstring_Ptr => Ada_Tags, RE_Cstring_Ptr => Ada_Tags,
RE_Descendant_Tag => Ada_Tags, RE_Descendant_Tag => Ada_Tags,
RE_Dispatch_Table => Ada_Tags, RE_Dispatch_Table => Ada_Tags,
......
...@@ -1595,6 +1595,19 @@ package body Sem_Prag is ...@@ -1595,6 +1595,19 @@ package body Sem_Prag is
("aspect % requires ''Class for abstract subprogram"); ("aspect % requires ''Class for abstract subprogram");
end if; end if;
-- AI05-0230: the same restriction applies to null procedures.
-- For compatibility with earlier uses of the Ada pragma, apply
-- this rule only to aspect specifications.
elsif Nkind (PO) = N_Subprogram_Declaration
and then Nkind (Specification (PO)) = N_Procedure_Specification
and then Null_Present (Specification (PO))
and then From_Aspect_Specification (N)
and then not Class_Present (N)
then
Error_Pragma
("aspect % requires ''Class for null procedure");
elsif not Nkind_In (PO, N_Subprogram_Declaration, elsif not Nkind_In (PO, N_Subprogram_Declaration,
N_Generic_Subprogram_Declaration, N_Generic_Subprogram_Declaration,
N_Entry_Declaration) N_Entry_Declaration)
......
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