From 8c4ee6f5320012a33382597cba44e225046d7c4f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 2 Aug 2011 16:28:32 +0200 Subject: [PATCH] [multiple changes] 2011-08-02 Ed Schonberg * sem_prag.adb (Chain_PPC): Implement AI04-0230: null procedures can only have inheritable classwide pre/postconditions. 2011-08-02 Javier Miranda * 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 b7d5737a4f7..f09f47d09ea 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2011-08-02 Ed Schonberg + + * sem_prag.adb (Chain_PPC): Implement AI04-0230: null procedures can + only have inheritable classwide pre/postconditions. + +2011-08-02 Javier Miranda + + * 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 * s-taskin.ads: Minor reformatting. diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index 6f6a8aa02de..7a5f7bce071 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 42063e26e7e..e9ac33afa4c 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 07444e7d4ae..cdc92a34b9c 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 1ab979fbd94..06e60660e6e 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 3bacf904771..20e5191d9f2 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) -- 2.30.2