a-tags.ads, a-tags.adb:

2006-10-31  Javier Miranda  <miranda@adacore.com>

	* a-tags.ads, a-tags.adb: 
	(Predefined_DT): New function that improves readability of the code.
	(Get_Predefined_Prim_Op_Address, Set_Predefined_Prim_Op_Address,
	Inherit_DT): Use the new function Predefined_DT to improve code
	readability.
	(Register_Interface_Tag): Update assertion.
	(Set_Interface_Table): Update assertion.
	(Interface_Ancestor_Tags): New subprogram required to implement AI-405:
	determining progenitor interfaces in Tags.
	(Inherit_CPP_DT): New subprogram.

        * exp_disp.adb (Expand_Interface_Thunk): Suppress checks during the
	analysis of the thunk code.
        (Expand_Interface_Conversion): Handle run-time conversion of
        access to class wide types.
	(Expand_Dispatching_Call): When generating the profile for the
	subprogram itype for a dispatching operation, properly terminate the
	formal parameters chaind list (set the Next_Entity of the last formal
	to Empty).
	(Collect_All_Interfaces): Removed. This routine has been moved to
	sem_util and renamed as Collect_All_Abstract_Interfaces.
	(Set_All_DT_Position): Hidden entities associated with abstract
	interface primitives are not taken into account in the check for
	3.9.3(10); this check is done with the aliased entity.
	(Make_DT, Set_All_DT_Position): Enable full ABI compatibility for
	interfacing with CPP by default.
	(Expand_Interface_Conversion): Add missing support for static conversion
	from an interface to a tagged type.
	(Collect_All_Interfaces): Add new out formal containing the list of
	abstract interface types to cleanup the subprogram Make_DT.
	(Make_DT): Update the code to generate the table of interfaces in case
	of abstract interface types.
	(Is_Predefined_Dispatching_Alias): New function that returns true if
	a primitive is not a predefined dispatching primitive but it is an
	alias of a predefined dispatching primitive.
	(Make_DT): If the ancestor of the type is a CPP_Class and we are
	compiling under full ABI compatibility mode we avoid the generation of
	calls to run-time services that fill the dispatch tables because under
	this mode we currently inherit the dispatch tables in the IP subprogram.
	(Write_DT): Emit an "is null" indication for a null procedure primitive.
	(Expand_Interface_Conversion): Use an address as the type of the formal
	of the internally built function that handles the case in which the
	target type is an access type.

From-SVN: r118244

gcc/ada/a-tags.adb

@@ -411,6 +411,11 @@ package body Ada.Tags is
    --  Length of string represented by the given pointer (treating the string
    --  as a C-style string, which is Nul terminated).
 
+   function Predefined_DT (T : Tag) return Tag;
+   pragma Inline_Always (Predefined_DT);
+   --  Displace the Tag to reference the dispatch table containing the
+   --  predefined primitives.
+
    function Typeinfo_Ptr (T : Tag) return System.Address;
    --  Returns the current value of the typeinfo_ptr component available in
    --  the prologue of the dispatch table.
@@ -596,7 +601,7 @@ package body Ada.Tags is
    --  level of inheritance of both types, this can be computed in constant
    --  time by the formula:
 
-   --   Obj'tag.TSD.Ancestor_Tags (Obj'tag.TSD.Idepth - Typ'tag.TSD.Idepth)
+   --   TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
    --     = Typ'tag
 
    function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is
@@ -668,6 +673,13 @@ package body Ada.Tags is
          end loop;
       end if;
 
+      --  Check if T is an immediate ancestor. This is required to handle
+      --  conversion of class-wide interfaces to tagged types.
+
+      if CW_Membership (Obj_DT, T) then
+         return Obj_Base;
+      end if;
+
       --  If the object does not implement the interface we must raise CE
 
       raise Constraint_Error;
@@ -842,11 +854,10 @@ package body Ada.Tags is
      (T        : Tag;
       Position : Positive) return System.Address
    is
-      Prim_Ops_DT : constant Tag := To_Tag (To_Address (T) - DT_Prologue_Size);
    begin
       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
       pragma Assert (Position <= Default_Prim_Op_Count);
-      return Prim_Ops_DT.Prims_Ptr (Position);
+      return Predefined_DT (T).Prims_Ptr (Position);
    end Get_Predefined_Prim_Op_Address;
 
    -------------------------
@@ -923,27 +934,59 @@ package body Ada.Tags is
       return To_Tagged_Kind_Ptr (Tagged_Kind_Ptr).all;
    end Get_Tagged_Kind;
 
+   --------------------
+   -- Inherit_CPP_DT --
+   --------------------
+
+   procedure Inherit_CPP_DT
+     (Old_T       : Tag;
+      New_T       : Tag;
+      Entry_Count : Natural)
+   is
+   begin
+      New_T.Prims_Ptr (1 .. Entry_Count) := Old_T.Prims_Ptr (1 .. Entry_Count);
+   end Inherit_CPP_DT;
+
    ----------------
    -- Inherit_DT --
    ----------------
 
    procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural) is
-      Old_T_Prim_Ops : Tag;
-      New_T_Prim_Ops : Tag;
-      Size           : Positive;
+      subtype All_Predefined_Prims is
+        Positive range 1 .. Default_Prim_Op_Count;
+
    begin
       pragma Assert (Check_Signature (Old_T, Must_Be_Primary_Or_Secondary_DT));
       pragma Assert (Check_Signature (New_T, Must_Be_Primary_Or_Secondary_DT));
       pragma Assert (Check_Size (Old_T, New_T, Entry_Count));
 
       if Old_T /= null then
+
+         --  Inherit the primitives of the parent
+
          New_T.Prims_Ptr (1 .. Entry_Count) :=
            Old_T.Prims_Ptr (1 .. Entry_Count);
-         Old_T_Prim_Ops := To_Tag (To_Address (Old_T) - DT_Prologue_Size);
-         New_T_Prim_Ops := To_Tag (To_Address (New_T) - DT_Prologue_Size);
-         Size := Default_Prim_Op_Count;
-         New_T_Prim_Ops.Prims_Ptr (1 .. Size) :=
-           Old_T_Prim_Ops.Prims_Ptr (1 .. Size);
+
+         --  Inherit the predefined primitives of the parent
+
+         --  NOTE: In the following assignment we have to unactivate a warning
+         --  generated by the compiler because of the following declaration of
+         --  the Dispatch_Table:
+
+         --      Prims_Ptr : Address_Array (1 .. 1);
+
+         --  This is a dummy declaration that is expanded by the frontend to
+         --  the correct size of the dispatch table corresponding with each
+         --  tagged type. As a consequence, if we try to use a constant to
+         --  copy the predefined elements (ie.  Prims_Ptr (1 .. 15) := ...)
+         --  the compiler generates a warning indicating that Constraint_Error
+         --  will be raised at run-time (which is not true in this specific
+         --  case).
+
+         pragma Warnings (Off);
+         Predefined_DT (New_T).Prims_Ptr (All_Predefined_Prims) :=
+           Predefined_DT (Old_T).Prims_Ptr (All_Predefined_Prims);
+         pragma Warnings (On);
       end if;
    end Inherit_DT;
 
@@ -994,6 +1037,35 @@ package body Ada.Tags is
       New_TSD_Ptr.Tags_Table (0) := New_Tag;
    end Inherit_TSD;
 
+   -----------------------------
+   -- Interface_Ancestor_Tags --
+   -----------------------------
+
+   function Interface_Ancestor_Tags (T : Tag) return Tag_Array is
+      Iface_Table : Interface_Data_Ptr;
+
+   begin
+      Iface_Table := To_Interface_Data_Ptr (TSD (T).Ifaces_Table_Ptr);
+
+      if Iface_Table = null then
+         declare
+            Table : Tag_Array (1 .. 0);
+         begin
+            return Table;
+         end;
+      else
+         declare
+            Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces);
+         begin
+            for J in 1 .. Iface_Table.Nb_Ifaces loop
+               Table (J) := Iface_Table.Table (J).Iface_Tag;
+            end loop;
+
+            return Table;
+         end;
+      end if;
+   end Interface_Ancestor_Tags;
+
    ------------------
    -- Internal_Tag --
    ------------------
@@ -1107,21 +1179,24 @@ package body Ada.Tags is
      (Obj : System.Address;
       T   : Tag) return SSE.Storage_Count
    is
+      Parent_Slot : constant Positive := 1;
+      --  The tag of the parent is always in the first slot of the table of
+      --  ancestor tags.
+
+      Size_Slot : constant Positive := 1;
+      --  The pointer to the _size primitive is always in the first slot of
+      --  the dispatch table.
+
       Parent_Tag : Tag;
       --  The tag of the parent type through the dispatch table
 
-      Prim_Ops_DT : Tag;
-      --  The table of primitive operations of the parent
-
       F : Acc_Size;
-      --  Access to the _size primitive of the parent. We assume that it is
-      --  always in the first slot of the dispatch table.
+      --  Access to the _size primitive of the parent
 
    begin
       pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
-      Parent_Tag  := TSD (T).Tags_Table (1);
-      Prim_Ops_DT := To_Tag (To_Address (Parent_Tag) - DT_Prologue_Size);
-      F           := To_Acc_Size (Prim_Ops_DT.Prims_Ptr (1));
+      Parent_Tag := TSD (T).Tags_Table (Parent_Slot);
+      F := To_Acc_Size (Predefined_DT (Parent_Tag).Prims_Ptr (Size_Slot));
 
       --  Here we compute the size of the _parent field of the object
 
@@ -1152,6 +1227,15 @@ package body Ada.Tags is
       end if;
    end Parent_Tag;
 
+   -------------------
+   -- Predefined_DT --
+   -------------------
+
+   function Predefined_DT (T : Tag) return Tag is
+   begin
+      return To_Tag (To_Address (T) - DT_Prologue_Size);
+   end Predefined_DT;
+
    ----------------------------
    -- Register_Interface_Tag --
    ----------------------------
@@ -1165,14 +1249,13 @@ package body Ada.Tags is
       Iface_Table : Interface_Data_Ptr;
 
    begin
-      pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
+      pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
       pragma Assert (Check_Signature (Interface_T, Must_Be_Interface));
 
       New_T_TSD   := TSD (T);
       Iface_Table := To_Interface_Data_Ptr (New_T_TSD.Ifaces_Table_Ptr);
 
       pragma Assert (Position <= Iface_Table.Nb_Ifaces);
-
       Iface_Table.Table (Position).Iface_Tag := Interface_T;
    end Register_Interface_Tag;
 
@@ -1237,7 +1320,7 @@ package body Ada.Tags is
 
    procedure Set_Interface_Table (T : Tag; Value : System.Address) is
    begin
-      pragma Assert (Check_Signature (T, Must_Be_Primary_DT));
+      pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Interface));
       TSD (T).Ifaces_Table_Ptr := Value;
    end Set_Interface_Table;
 
@@ -1308,18 +1391,22 @@ package body Ada.Tags is
       pragma Assert
         (Check_Signature (Prim_DT, Must_Be_Primary_DT));
 
-      Sec_Base := This + Offset_Value;
-      Sec_DT   := To_Tag_Ptr (Sec_Base).all;
-      Offset_To_Top :=
-        To_Storage_Offset_Ptr (To_Address (Sec_DT) - K_Offset_To_Top);
+      --  Save the offset to top field in the secondary dispatch table.
 
-      pragma Assert
-        (Check_Signature (Sec_DT, Must_Be_Secondary_DT));
+      if Offset_Value /= 0 then
+         Sec_Base := This + Offset_Value;
+         Sec_DT   := To_Tag_Ptr (Sec_Base).all;
+         Offset_To_Top :=
+           To_Storage_Offset_Ptr (To_Address (Sec_DT) - K_Offset_To_Top);
 
-      if Is_Static then
-         Offset_To_Top.all := Offset_Value;
-      else
-         Offset_To_Top.all := SSE.Storage_Offset'Last;
+         pragma Assert
+           (Check_Signature (Sec_DT, Must_Be_Secondary_DT));
+
+         if Is_Static then
+            Offset_To_Top.all := Offset_Value;
+         else
+            Offset_To_Top.all := SSE.Storage_Offset'Last;
+         end if;
       end if;
 
       --  Save Offset_Value in the table of interfaces of the primary DT. This
@@ -1373,11 +1460,10 @@ package body Ada.Tags is
       Position : Positive;
       Value    : System.Address)
    is
-      Prim_Ops_DT : constant Tag := To_Tag (To_Address (T) - DT_Prologue_Size);
    begin
       pragma Assert (Check_Signature (T, Must_Be_Primary_Or_Secondary_DT));
       pragma Assert (Position >= 1 and then Position <= Default_Prim_Op_Count);
-      Prim_Ops_DT.Prims_Ptr (Position) := Value;
+      Predefined_DT (T).Prims_Ptr (Position) := Value;
    end Set_Predefined_Prim_Op_Address;
 
    -------------------------

gcc/ada/a-tags.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
 --                                                                          --
 -- This specification is derived from the Ada Reference Manual for use with --
 -- GNAT. The copyright notice above, and the license provisions that follow --
@@ -44,11 +44,18 @@ package Ada.Tags is
    --  In accordance with Ada 2005 AI-362
 
    type Tag is private;
+   pragma Preelaborable_Initialization (Tag);
 
    No_Tag : constant Tag;
 
    function Expanded_Name (T : Tag) return String;
 
+   function Wide_Expanded_Name (T : Tag) return Wide_String;
+   pragma Ada_05 (Wide_Expanded_Name);
+
+   function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String;
+   pragma Ada_05 (Wide_Wide_Expanded_Name);
+
    function External_Tag (T : Tag) return String;
 
    function Internal_Tag (External : String) return Tag;
@@ -66,13 +73,12 @@ package Ada.Tags is
    function Parent_Tag (T : Tag) return Tag;
    pragma Ada_05 (Parent_Tag);
 
-   Tag_Error : exception;
+   type Tag_Array is array (Positive range <>) of Tag;
 
-   function Wide_Expanded_Name (T : Tag) return Wide_String;
-   pragma Ada_05 (Wide_Expanded_Name);
+   function Interface_Ancestor_Tags (T : Tag) return Tag_Array;
+   pragma Ada_05 (Interface_Ancestor_Tags);
 
-   function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String;
-   pragma Ada_05 (Wide_Wide_Expanded_Name);
+   Tag_Error : exception;
 
 private
    --  The following subprogram specifications are placed here instead of
@@ -192,7 +198,7 @@ private
    --      type I is interface;
    --      type T is tagged ...
    --
-   --      function Test (O : in I'Class) is
+   --      function Test (O : I'Class) is
    --      begin
    --         return O in T'Class.
    --      end Test;
@@ -257,6 +263,11 @@ private
    --  return the tagged kind of a type in the context of concurrency and
    --  limitedness.
 
+   procedure Inherit_CPP_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural);
+   --  Entry point used to initialize the DT of a type knowing the tag
+   --  of the direct CPP ancestor and the number of primitive ops that
+   --  are inherited (Entry_Count).
+
    procedure Inherit_DT (Old_T : Tag; New_T : Tag; Entry_Count : Natural);
    --  Entry point used to initialize the DT of a type knowing the tag
    --  of the direct ancestor and the number of primitive ops that are