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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@177159 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index b7d5737..f09f47d 100644 (file)
--- 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 6f6a8aa..7a5f7bc 100644 (file)
--- 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 42063e2..e9ac33a 100644 (file)
--- 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 07444e7..cdc92a3 100644 (file)
--- 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 1ab979f..06e6066 100644 (file)
--- 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 3bacf90..20e5191 100644 (file)
--- 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)