a-tags.ads, a-tags.adb (Displace): Associate a message with the raised CE exception.

2007-08-14  Javier Miranda  <miranda@adacore.com>

	* 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

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,