From 5e1527bd5913aa38b5975022665985773747127a Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Tue, 14 Aug 2007 10:44:53 +0200 Subject: [PATCH] a-tags.ads, a-tags.adb (Displace): Associate a message with the raised CE exception. 2007-08-14 Javier Miranda * a-tags.ads, a-tags.adb (Displace): Associate a message with the raised CE exception. (To_Addr_Ptr, To_Address, To_Dispatch_Table_Ptr, To_Object_Specific_Data_Ptr To_Predef_Prims_Ptr, To_Tag_Ptr, To_Type_Specific_Data_Ptr): Moved here from the package spec. (Default_Prim_Op_Count): Removed. (IW_Membership, Get_Entry_Index, Get_Offset_Index, Get_Prim_Op_Kind, Register_Tag, Set_Entry_Index, Set_Offset_To_Top, Set_Prim_Op_Kind): Remove pragma Inline_Always. * rtsfind.ads (Default_Prim_Op_Count): Removed (Max_Predef_Prims): New entity (RE_Expanded_Name): Removed (RE_HT_Link): Removed (RE_Iface_Tag): Remmoved (RE_Ifaces_Table): Removed (RE_Interfaces_Array): Removed (RE_Interface_Data_Element): Removed (RE_Nb_Ifaces): Removed (RE_RC_Offset): Removed (RE_Static_Offset_To_Top): Removed * exp_atag.ads (Build_Inherit_Prims): Addition of a new formal. (Build_Inherit_Predefined_Prims): Replace occurrences of Default_ Prim_Op_Count by Max_Predef_Prims. From-SVN: r127438 --- gcc/ada/a-tags.adb | 37 +++++++++++++++++++++--------- gcc/ada/a-tags.ads | 63 ++++++++++++---------------------------------------- gcc/ada/exp_atag.ads | 10 +++++++-- gcc/ada/rtsfind.ads | 24 +++++++------------- 4 files changed, 57 insertions(+), 77 deletions(-) diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index 622087a..5a0cf71 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -32,6 +32,7 @@ ------------------------------------------------------------------------------ with Ada.Exceptions; +with Ada.Unchecked_Conversion; with System.HTable; with System.Storage_Elements; use System.Storage_Elements; with System.WCh_Con; use System.WCh_Con; @@ -76,9 +77,7 @@ package body Ada.Tags is pragma Inline_Always (OSD); pragma Inline_Always (SSD); - --------------------------------------------- - -- Unchecked Conversions for String Fields -- - --------------------------------------------- + -- Unchecked conversions function To_Address is new Unchecked_Conversion (Cstring_Ptr, System.Address); @@ -86,16 +85,34 @@ package body Ada.Tags is function To_Cstring_Ptr is new Unchecked_Conversion (System.Address, Cstring_Ptr); - -- Disable warnings on possible aliasing problem because we only use - -- use this function to convert tags found in the External_Tag of - -- locally defined tagged types. - - pragma Warnings (off); + -- Disable warnings on possible aliasing problem function To_Tag is new Unchecked_Conversion (Integer_Address, Tag); - pragma Warnings (on); + function To_Addr_Ptr is + new Ada.Unchecked_Conversion (System.Address, Addr_Ptr); + + function To_Address is + new Ada.Unchecked_Conversion (Tag, System.Address); + + function To_Dispatch_Table_Ptr is + new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr); + + function To_Dispatch_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Dispatch_Table_Ptr); + + function To_Object_Specific_Data_Ptr is + new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr); + + function To_Predef_Prims_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Predef_Prims_Table_Ptr); + + function To_Tag_Ptr is + new Ada.Unchecked_Conversion (System.Address, Tag_Ptr); + + function To_Type_Specific_Data_Ptr is + new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); ------------------------------------------------ -- Unchecked Conversions for other components -- @@ -357,7 +374,7 @@ package body Ada.Tags is -- If the object does not implement the interface we must raise CE - raise Constraint_Error; + raise Constraint_Error with "invalid interface conversion"; end Displace; -------- diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 538c3e9..a41ae9d 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -37,7 +37,6 @@ with System; with System.Storage_Elements; -with Ada.Unchecked_Conversion; package Ada.Tags is pragma Preelaborate_05; @@ -273,6 +272,7 @@ private end record; type Type_Specific_Data_Ptr is access all Type_Specific_Data; + pragma No_Strict_Aliasing (Type_Specific_Data_Ptr); -- Declarations for the dispatch table record @@ -321,6 +321,8 @@ private -- gdb, its name must not be changed. type Tag is access all Dispatch_Table; + pragma No_Strict_Aliasing (Tag); + type Interface_Tag is access all Dispatch_Table; No_Tag : constant Tag := null; @@ -329,7 +331,10 @@ private -- of the wrapper. type Tag_Ptr is access all Tag; + pragma No_Strict_Aliasing (Tag_Ptr); + type Dispatch_Table_Ptr is access all Dispatch_Table_Wrapper; + pragma No_Strict_Aliasing (Dispatch_Table_Ptr); -- The following type declaration is used by the compiler when the program -- is compiled with restriction No_Dispatching_Calls. It is also used with @@ -341,11 +346,6 @@ private NDT_Prims_Ptr : Natural; end record; - Default_Prim_Op_Count : constant Positive := 15; - -- Number of predefined ada primitives: Size, Alignment, Read, Write, - -- Input, Output, "=", assignment, deep adjust, deep finalize, async - -- select, conditional select, prim_op kind, task_id, and timed select. - DT_Predef_Prims_Size : constant SSE.Storage_Count := SSE.Storage_Count (1 * (Standard'Address_Size / @@ -385,6 +385,7 @@ private end record; type Object_Specific_Data_Ptr is access all Object_Specific_Data; + pragma No_Strict_Aliasing (Object_Specific_Data_Ptr); -- The following subprogram specifications are placed here instead of -- the package body to see them from the frontend through rtsfind. @@ -494,52 +495,16 @@ private -- Ada 2005 (AI-251): Set the kind of a primitive operation in T's TSD -- table indexed by Position. - -- Unchecked Conversions - - Max_Predef_Prims : constant Natural := 16; - -- Compiler should check this constant is OK ??? + Max_Predef_Prims : constant Positive := 15; + -- Number of reserved slots for predefined ada primitives: Size, Alignment, + -- Read, Write, Input, Output, "=", assignment, deep adjust, deep finalize, + -- async select, conditional select, prim_op kind, task_id, and timed + -- select. The compiler checks that this value is correct. subtype Predef_Prims_Table is Address_Array (1 .. Max_Predef_Prims); type Predef_Prims_Table_Ptr is access Predef_Prims_Table; + pragma No_Strict_Aliasing (Predef_Prims_Table_Ptr); type Addr_Ptr is access System.Address; - - function To_Addr_Ptr is - new Ada.Unchecked_Conversion (System.Address, Addr_Ptr); - - function To_Address is - new Ada.Unchecked_Conversion (Tag, System.Address); - - function To_Dispatch_Table_Ptr is - new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr); - - function To_Dispatch_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Dispatch_Table_Ptr); - - function To_Object_Specific_Data_Ptr is - new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr); - - function To_Predef_Prims_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Predef_Prims_Table_Ptr); - - function To_Tag_Ptr is - new Ada.Unchecked_Conversion (System.Address, Tag_Ptr); - - function To_Type_Specific_Data_Ptr is - new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); - - -- Primitive dispatching operations are always inlined, to facilitate use - -- in a minimal/no run-time environment for high integrity use. - - pragma Inline_Always (Displace); - pragma Inline_Always (IW_Membership); - pragma Inline_Always (Get_Entry_Index); - pragma Inline_Always (Get_Offset_Index); - pragma Inline_Always (Get_Prim_Op_Kind); - pragma Inline_Always (Get_Tagged_Kind); - pragma Inline_Always (Register_Tag); - pragma Inline_Always (Set_Entry_Index); - pragma Inline_Always (Set_Offset_To_Top); - pragma Inline_Always (Set_Prim_Op_Kind); - + pragma No_Strict_Aliasing (Addr_Ptr); end Ada.Tags; diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads index 6b0fce7..3e7e773 100644 --- a/gcc/ada/exp_atag.ads +++ b/gcc/ada/exp_atag.ads @@ -32,6 +32,9 @@ with Uintp; use Uintp; package Exp_Atag is + -- Note: In all the subprograms of this package formal 'Loc' is the source + -- location used in constructing the corresponding nodes. + procedure Build_Common_Dispatching_Select_Statements (Loc : Source_Ptr; DT_Ptr : Entity_Id; @@ -100,12 +103,15 @@ package Exp_Atag is function Build_Inherit_Prims (Loc : Source_Ptr; + Typ : Entity_Id; Old_Tag_Node : Node_Id; New_Tag_Node : Node_Id; Num_Prims : Nat) return Node_Id; -- Build code that inherits Num_Prims user-defined primitives from the - -- dispatch table of the parent type. It is used to copy the dispatch - -- table of the parent in case of derivations of CPP_Class types. + -- dispatch table of the parent type of tagged type Typ. It is used to + -- copy the dispatch table of the parent in the following cases: + -- a) case of derivations of CPP_Class types + -- b) tagged types whose dispatch table is not statically allocated -- -- Generates: -- New_Tag.Prims_Ptr (1 .. Num_Prims) := diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index cb59e71..769720e 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -492,7 +492,6 @@ package Rtsfind is RE_Addr_Ptr, -- Ada.Tags RE_Base_Address, -- Ada.Tags RE_Cstring_Ptr, -- Ada.Tags - RE_Default_Prim_Op_Count, -- Ada.Tags RE_Descendant_Tag, -- Ada.Tags RE_Dispatch_Table, -- Ada.Tags RE_Dispatch_Table_Wrapper, -- Ada.Tags @@ -500,9 +499,7 @@ package Rtsfind is RE_DT, -- Ada.Tags RE_DT_Predef_Prims_Offset, -- Ada.Tags RE_DT_Typeinfo_Ptr_Size, -- Ada.Tags - RE_Expanded_Name, -- Ada.Tags RE_External_Tag, -- Ada.Tags - RE_HT_Link, -- Ada.Tags RO_TA_External_Tag, -- Ada.Tags RE_Get_Access_Level, -- Ada.Tags RE_Get_Entry_Index, -- Ada.Tags @@ -510,13 +507,13 @@ package Rtsfind is RE_Get_Prim_Op_Kind, -- Ada.Tags RE_Get_Tagged_Kind, -- Ada.Tags RE_Idepth, -- Ada.Tags - RE_Iface_Tag, -- Ada.Tags - RE_Ifaces_Table, -- Ada.Tags + RE_Interfaces_Array, -- Ada.Tags RE_Interfaces_Table, -- Ada.Tags RE_Interface_Data, -- Ada.Tags + RE_Interface_Data_Element, -- Ada.Tags RE_Interface_Tag, -- Ada.Tags RE_IW_Membership, -- Ada.Tags - RE_Nb_Ifaces, -- Ada.Tags + RE_Max_Predef_Prims, -- Ada.Tags RE_No_Dispatch_Table_Wrapper, -- Ada.Tags RE_NDT_Prims_Ptr, -- Ada.Tags RE_NDT_TSD, -- Ada.Tags @@ -545,13 +542,11 @@ package Rtsfind is RE_Type_Specific_Data, -- Ada.Tags RE_Register_Tag, -- Ada.Tags RE_Transportable, -- Ada.Tags - RE_RC_Offset, -- Ada.Tags RE_Secondary_DT, -- Ada.Tags RE_Select_Specific_Data, -- Ada.Tags RE_Set_Entry_Index, -- Ada.Tags RE_Set_Offset_To_Top, -- Ada.Tags RE_Set_Prim_Op_Kind, -- Ada.Tags - RE_Static_Offset_To_Top, -- Ada.Tags RE_Tag, -- Ada.Tags RE_Tag_Error, -- Ada.Tags RE_Tag_Kind, -- Ada.Tags @@ -1050,6 +1045,7 @@ package Rtsfind is RE_Unspecified_Size, -- System.Parameters RE_DSA_Implementation, -- System.Partition_Interface + RE_PCS_Version, -- System.Partition_Interface RE_Get_RCI_Package_Receiver, -- System.Partition_Interface RE_Get_Unique_Remote_Pointer, -- System.Partition_Interface RE_RACW_Stub_Type_Access, -- System.Partition_Interface @@ -1598,7 +1594,6 @@ package Rtsfind is RE_Addr_Ptr => Ada_Tags, RE_Base_Address => Ada_Tags, RE_Cstring_Ptr => Ada_Tags, - RE_Default_Prim_Op_Count => Ada_Tags, RE_Descendant_Tag => Ada_Tags, RE_Dispatch_Table => Ada_Tags, RE_Dispatch_Table_Wrapper => Ada_Tags, @@ -1606,9 +1601,7 @@ package Rtsfind is RE_DT => Ada_Tags, RE_DT_Predef_Prims_Offset => Ada_Tags, RE_DT_Typeinfo_Ptr_Size => Ada_Tags, - RE_Expanded_Name => Ada_Tags, RE_External_Tag => Ada_Tags, - RE_HT_Link => Ada_Tags, RO_TA_External_Tag => Ada_Tags, RE_Get_Access_Level => Ada_Tags, RE_Get_Entry_Index => Ada_Tags, @@ -1616,13 +1609,13 @@ package Rtsfind is RE_Get_Prim_Op_Kind => Ada_Tags, RE_Get_Tagged_Kind => Ada_Tags, RE_Idepth => Ada_Tags, - RE_Iface_Tag => Ada_Tags, - RE_Ifaces_Table => Ada_Tags, + RE_Interfaces_Array => Ada_Tags, RE_Interfaces_Table => Ada_Tags, RE_Interface_Data => Ada_Tags, + RE_Interface_Data_Element => Ada_Tags, RE_Interface_Tag => Ada_Tags, RE_IW_Membership => Ada_Tags, - RE_Nb_Ifaces => Ada_Tags, + RE_Max_Predef_Prims => Ada_Tags, RE_No_Dispatch_Table_Wrapper => Ada_Tags, RE_NDT_Prims_Ptr => Ada_Tags, RE_NDT_TSD => Ada_Tags, @@ -1651,13 +1644,11 @@ package Rtsfind is RE_Type_Specific_Data => Ada_Tags, RE_Register_Tag => Ada_Tags, RE_Transportable => Ada_Tags, - RE_RC_Offset => Ada_Tags, RE_Secondary_DT => Ada_Tags, RE_Select_Specific_Data => Ada_Tags, RE_Set_Entry_Index => Ada_Tags, RE_Set_Offset_To_Top => Ada_Tags, RE_Set_Prim_Op_Kind => Ada_Tags, - RE_Static_Offset_To_Top => Ada_Tags, RE_Tag => Ada_Tags, RE_Tag_Error => Ada_Tags, RE_Tag_Kind => Ada_Tags, @@ -2154,6 +2145,7 @@ package Rtsfind is RE_Unspecified_Size => System_Parameters, RE_DSA_Implementation => System_Partition_Interface, + RE_PCS_Version => System_Partition_Interface, RE_Get_RCI_Package_Receiver => System_Partition_Interface, RE_Get_Unique_Remote_Pointer => System_Partition_Interface, RE_RACW_Stub_Type_Access => System_Partition_Interface, -- 2.7.4