From 8c4ee6f5320012a33382597cba44e225046d7c4f Mon Sep 17 00:00:00 2001
From: Arnaud Charlet <charlet@gcc.gnu.org>
Date: Tue, 2 Aug 2011 16:28:32 +0200
Subject: [PATCH] [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
---
gcc/ada/ChangeLog | 13 +++++++++++++
gcc/ada/a-tags.adb | 18 ++++++++++++++++++
gcc/ada/a-tags.ads | 4 ++++
gcc/ada/exp_disp.adb | 18 ++++++++++++++++++
gcc/ada/rtsfind.ads | 2 ++
gcc/ada/sem_prag.adb | 13 +++++++++++++
6 files changed, 68 insertions(+)
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index b7d5737a4f75..f09f47d09eab 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,16 @@
+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>
* s-taskin.ads: Minor reformatting.
diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb
index 6f6a8aa02def..7a5f7bce071f 100644
--- a/gcc/ada/a-tags.adb
+++ b/gcc/ada/a-tags.adb
@@ -303,6 +303,24 @@ package body Ada.Tags is
return This - Offset_To_Top (This);
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 --
--------------------
diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads
index 42063e26e7ea..e9ac33afa4c4 100644
--- a/gcc/ada/a-tags.ads
+++ b/gcc/ada/a-tags.ads
@@ -421,6 +421,10 @@ private
-- 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).
+ 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;
-- Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch
-- table of T.
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 07444e7d4aed..cdc92a34b9ca 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -5990,6 +5990,24 @@ package body Exp_Disp is
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
-- the pure Ada type only.
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index 1ab979fbd940..06e60660e6e5 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -551,6 +551,7 @@ package Rtsfind is
RE_Address_Array, -- Ada.Tags
RE_Addr_Ptr, -- Ada.Tags
RE_Base_Address, -- Ada.Tags
+ RE_Check_TSD, -- Ada.Tags
RE_Cstring_Ptr, -- Ada.Tags
RE_Descendant_Tag, -- Ada.Tags
RE_Dispatch_Table, -- Ada.Tags
@@ -1729,6 +1730,7 @@ package Rtsfind is
RE_Address_Array => Ada_Tags,
RE_Addr_Ptr => Ada_Tags,
RE_Base_Address => Ada_Tags,
+ RE_Check_TSD => Ada_Tags,
RE_Cstring_Ptr => Ada_Tags,
RE_Descendant_Tag => Ada_Tags,
RE_Dispatch_Table => Ada_Tags,
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 3bacf9047715..20e5191d9f2b 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -1595,6 +1595,19 @@ package body Sem_Prag is
("aspect % requires ''Class for abstract subprogram");
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,
N_Generic_Subprogram_Declaration,
N_Entry_Declaration)
--
GitLab