* 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
+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.
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 --
--------------------
-- 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.
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.
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
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,
("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)