diff mbox

[Ada] Wrong initialization of extended aggregates of CPP types

Message ID 20100810143009.GA1513@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Aug. 10, 2010, 2:30 p.m. UTC
The code generated by the compiler to initialize extended aggregates
of imported C++ types leaves objects partially initialized. As a
result, dispatching calls using these objects have unexpected
results. The following test must execute fine and print "OK".

class Base {
  public:
  int My_V;
  Base ();
  virtual void Primitive ();
};

Base::Base ()  {
}

void Base::Primitive () {
}

with Interfaces.C; use Interfaces.C;
package file_cpp is
   package Class_Base is
      type Base is tagged limited record
         My_V : aliased int;
      end record;
      pragma Import (CPP, Base);

      function New_Base return Base;
      pragma CPP_Constructor (New_Base, "_ZN4BaseC1Ev");

      procedure Primitive (this : access Base);
      pragma Import (CPP, Primitive, "_ZN4Base9PrimitiveEv");
   end;
   use Class_Base;
end file_cpp;

with file_cpp; use file_cpp;
package Deriv is
   use file_cpp.Class_Base;
   type My_Class is new Base with null record;
   type My_Class_Access is access all My_Class'Class;

   overriding
   procedure Primitive (this : access My_Class);
end Deriv;

with Text_IO; use Text_IO;
package body Deriv is
   procedure Primitive (this : access My_Class) is
   begin
      Put_Line ("OK");
   end Primitive;
end Deriv;

with file_cpp; use file_cpp;
with Deriv; use Deriv;
procedure Main is
   use file_cpp.Class_Base;
   V : My_Class_Access :=
         new My_Class'(New_Base with others => <>);  --  Test
begin
   Primitive (V);                                     -- Test
end Main;

project Default is
   for Languages use ("Ada", "C++");
   for Main use ("main.adb");

   package Ide is
      for Vcs_Kind use "CVS";
      for Compiler_Command ("c") use "gcc";
   end Ide;

   package Compiler is
      for Default_Switches ("ada") use ("-O2", "-gnat05");
   end Compiler;
end Default;

Command: gprbuild -q -P default.gpr; ./main
Output:  OK

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-08-10  Javier Miranda  <miranda@adacore.com>

	* sem_aggr.adb (Resolve_Extension_Aggregate): Warn on the use of C++
	constructors that leave the object partially initialized.
	* exp_atag.ads, exp_atags.adb (Build_Inherit_CPP_Prims): New subprogram
	that copies from parent of Typ the dispatch table slots of inherited
	C++ primitives. It handles primary and secondary dispatch tables.
	* einfo.adb (Related_Type): Moved from Node26 to Node27. Required to
	use this attribute with E_Variable entities.
	(Set_Is_Tag): Relax assertion to allow its use with variables that
	store tags.
	(Set_Related_Type): Relax assertion to allow its use with variables
	that store the tag of a C++ class.
	(Write_26_Field_Name): Remove Related_Type.
	(Write_27_Field_Name): Add Related_Type.
	* einfo.ads (Related_Type): Moved from Node26 to Node27. Available also
	with E_Variable entities.
	* sem_prag.adb (CPP_Constructor): Warn on duplicated occurrence of this
	pragma.
	* sem_util.adb (Search_Tag): Add missing support for CPP types.
	(Enclosing_CPP_Parent): New subprogram.
	(Has_Suffix): New subprogram.
	* sem_util.ads (Enclosing_CPP_Parent): New subprogram that returns the
	closest ancestor of a type that is a C++ type.
	(Has_Suffix): New subprogram. Used in assertions to check the suffix of
	internal entities.
	* sem_attr.adb (Analyze_Access_Attribute): Check wrong use of current
	instance in derivations of C++ types.
	* exp_tss.adb (CPP_Init_Proc): New subprogram.
	(Is_CPP_Init_Proc): New subprogram.
	(Set_TSS): Handle new C++ init routines.
	* exp_tss.ads (TSS_CPP_Init): New TSS name. For initialization of C++
	dispatch tables.
	(CPP_Init_Proc): New subprogram.
	(Is_CPP_Init_Proc): New subprogram.
	* exp_disp.adb (CPP_Num_Prims): New subprogram.
	(Has_CPP_Constructors): New subprogram.
	(Make_Secondary_DT, Make_DT): For derivations of CPP types, do not
	initialize slots located in the C++ part of the dispatch table.
	(Make_Tags): For CPP types declare variables used by the IP routine to
	store the C++ tag values after the first invocation of the C++
	constructor.
	(Build_CPP_Init_DT): New subprogram.
	(Set_CPP_Constructors): New implementation that builds an IP for each
	CPP constructor. These IP are wrappers of the C++ constructors that,
	after the first invocation of the constructor, read the C++ tags from
	the object and save them locally. These copies of the C++ tags are used
	by the IC routines to initialize tables of Ada derivations of CPP types.
	(Write_DT): Indicate what primitives are imported from C++
	* exp_disp.ads (CPP_Num_Prims): New subprogram.
	(Has_CPP_Constructors): New subprogram.
	* exp_aggr.adb (Build_Record_Aggr_Code): For derivations of C++ types
	invoke the IC routine to inherit the slots of the parents.
	* sem_ch13.adb (Analyze_Freeze_Entity): Add new warnings on CPP types.
	* exp_ch3.adb (Is_Variable_Size_Array): New subprogram.
	(Is_Variable_Size_Record): Factorize code calling
	Is_Variable_Size_Array.
	(Build_CPP_Init_Procedure): New subprogram that builds the tree
	corresponding to the procedure that initializes the C++ part of the
	dispatch table of an Ada tagged type that is a derivation of a CPP type.
	(Build_Init_Procedure): Adding documentation plus code reorganization to
	leave more clear the construction of the IP with C++ types.
	(Expand_Freeze_Record_Type): Delay call to Set_CPP_Constructors because
	it cannot be called after Make_Tags has been invoked.
	(Inherit_CPP_Tag): Removed.
	(Init_Secondary_Tags): For derivations of CPP types, warn on tags
	located at variable offset.
	* freeze.ads: Minor reformating.
	* sem_ch8.adb (Write_Scopes): Add pragma export. Required to have it
	available in gdb.
	* gcc-interface/Make-lang.in: Update dependencies.
diff mbox

Patch

Index: einfo.adb
===================================================================
--- einfo.adb	(revision 163063)
+++ einfo.adb	(working copy)
@@ -219,11 +219,11 @@  package body Einfo is
    --    Last_Assignment                 Node26
    --    Overridden_Operation            Node26
    --    Package_Instantiation           Node26
-   --    Related_Type                    Node26
    --    Relative_Deadline_Variable      Node26
    --    Static_Initialization           Node26
 
    --    Current_Use_Clause              Node27
+   --    Related_Type                    Node27
    --    Wrapped_Entity                  Node27
 
    --    Extra_Formals                   Node28
@@ -1481,7 +1481,6 @@  package body Einfo is
 
    function Has_Thunks (Id : E) return B is
    begin
-      pragma Assert (Ekind (Id) = E_Constant);
       return Flag228 (Id);
    end Has_Thunks;
 
@@ -2442,8 +2441,8 @@  package body Einfo is
 
    function Related_Type (Id : E) return E is
    begin
-      pragma Assert (Ekind_In (Id, E_Component, E_Constant));
-      return Node26 (Id);
+      pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable));
+      return Node27 (Id);
    end Related_Type;
 
    function Relative_Deadline_Variable (Id : E) return E is
@@ -3884,8 +3883,7 @@  package body Einfo is
 
    procedure Set_Has_Thunks (Id : E; V : B := True) is
    begin
-      pragma Assert (Is_Tag (Id)
-        and then Ekind (Id) = E_Constant);
+      pragma Assert (Is_Tag (Id));
       Set_Flag228 (Id, V);
    end Set_Has_Thunks;
 
@@ -4452,7 +4450,7 @@  package body Einfo is
 
    procedure Set_Is_Tag (Id : E; V : B := True) is
    begin
-      pragma Assert (Ekind_In (Id, E_Component, E_Constant));
+      pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable));
       Set_Flag78 (Id, V);
    end Set_Is_Tag;
 
@@ -4883,8 +4881,8 @@  package body Einfo is
 
    procedure Set_Related_Type (Id : E; V : E) is
    begin
-      pragma Assert (Ekind_In (Id, E_Component, E_Constant));
-      Set_Node26 (Id, V);
+      pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable));
+      Set_Node27 (Id, V);
    end Set_Related_Type;
 
    procedure Set_Relative_Deadline_Variable (Id : E; V : E) is
@@ -8011,10 +8009,6 @@  package body Einfo is
    procedure Write_Field26_Name (Id : Entity_Id) is
    begin
       case Ekind (Id) is
-         when E_Component                                  |
-              E_Constant                                   =>
-            Write_Str ("Related_Type");
-
          when E_Generic_Package                            |
               E_Package                                    =>
             Write_Str ("Package_Instantiation");
@@ -8052,6 +8046,11 @@  package body Einfo is
    procedure Write_Field27_Name (Id : Entity_Id) is
    begin
       case Ekind (Id) is
+         when E_Component                                  |
+              E_Constant                                   |
+              E_Variable                                   =>
+            Write_Str ("Related_Type");
+
          when E_Procedure                                  =>
             Write_Str ("Wrapped_Entity");
 
Index: einfo.ads
===================================================================
--- einfo.ads	(revision 163063)
+++ einfo.ads	(working copy)
@@ -3306,10 +3306,10 @@  package Einfo is
 --       wrapper package, but for debugging purposes its external symbol
 --       must correspond to the name and scope of the related instance.
 
---    Related_Type (Node26)
---       Present in components and constants associated with dispatch tables.
---       Set to point to the entity of the associated tagged type or interface
---       type.
+--    Related_Type (Node27)
+--       Present in components, constants and variables. Set when there is an
+--       associated dispatch table to point to entities containing primary or
+--       secondary tags. Not set in the _tag component of record types.
 
 --    Relative_Deadline_Variable (Node26) [implementation base type only]
 --       Present in task type entities. This flag is set if a valid and
@@ -4827,7 +4827,7 @@  package Einfo is
    --    Interface_Name                      (Node21)   (JGNAT usage only)
    --    Original_Record_Component           (Node22)
    --    DT_Offset_To_Top_Func               (Node25)
-   --    Related_Type                        (Node26)
+   --    Related_Type                        (Node27)
    --    Has_Biased_Representation           (Flag139)
    --    Has_Per_Object_Constraint           (Flag154)
    --    Is_Atomic                           (Flag85)
@@ -4850,7 +4850,7 @@  package Einfo is
    --    Size_Check_Code                     (Node19)   (constants only)
    --    Prival_Link                         (Node20)   (privals only)
    --    Interface_Name                      (Node21)
-   --    Related_Type                        (Node26)   (constants only)
+   --    Related_Type                        (Node27)   (constants only)
    --    Has_Alignment_Clause                (Flag46)
    --    Has_Atomic_Components               (Flag86)
    --    Has_Biased_Representation           (Flag139)
@@ -5479,6 +5479,7 @@  package Einfo is
    --    Related_Expression                  (Node24)
    --    Debug_Renaming_Link                 (Node25)
    --    Last_Assignment                     (Node26)
+   --    Related_Type                        (Node27)
    --    Has_Alignment_Clause                (Flag46)
    --    Has_Atomic_Components               (Flag86)
    --    Has_Biased_Representation           (Flag139)
Index: exp_aggr.adb
===================================================================
--- exp_aggr.adb	(revision 163054)
+++ exp_aggr.adb	(working copy)
@@ -34,6 +34,7 @@  with Exp_Util; use Exp_Util;
 with Exp_Ch3;  use Exp_Ch3;
 with Exp_Ch7;  use Exp_Ch7;
 with Exp_Ch9;  use Exp_Ch9;
+with Exp_Disp; use Exp_Disp;
 with Exp_Tss;  use Exp_Tss;
 with Fname;    use Fname;
 with Freeze;   use Freeze;
@@ -2840,12 +2841,61 @@  package body Exp_Aggr is
       --  constructor to ensure the proper initialization of the _Tag
       --  component.
 
-      if Is_CPP_Class (Typ) then
-         pragma Assert (Present (Base_Init_Proc (Typ)));
-         Append_List_To (L,
-           Build_Initialization_Call (Loc,
-             Id_Ref => Lhs,
-             Typ    => Typ));
+      if Is_CPP_Class (Root_Type (Typ))
+        and then CPP_Num_Prims (Typ) > 0
+      then
+         Invoke_Constructor : declare
+            CPP_Parent : constant Entity_Id :=
+                           Enclosing_CPP_Parent (Typ);
+
+            procedure Invoke_IC_Proc (T : Entity_Id);
+            --  Recursive routine used to climb to parents. Required because
+            --  parents must be initialized before descendants to ensure
+            --  propagation of inherited C++ slots.
+
+            --------------------
+            -- Invoke_IC_Proc --
+            --------------------
+
+            procedure Invoke_IC_Proc (T : Entity_Id) is
+            begin
+               --  Avoid generating extra calls. Initialization required
+               --  only for types defined from the level of derivation of
+               --  type of the constructor and the type of the aggregate.
+
+               if T = CPP_Parent then
+                  return;
+               end if;
+
+               Invoke_IC_Proc (Etype (T));
+
+               --  Generate call to the IC routine
+
+               if Present (CPP_Init_Proc (T)) then
+                  Append_To (L,
+                    Make_Procedure_Call_Statement (Loc,
+                      New_Reference_To (CPP_Init_Proc (T), Loc)));
+               end if;
+            end Invoke_IC_Proc;
+
+         --  Start of processing for Invoke_Constructor
+
+         begin
+            --  Implicit invocation of the C++ constructor
+
+            if Nkind (N) = N_Aggregate then
+               Append_To (L,
+                 Make_Procedure_Call_Statement (Loc,
+                   Name =>
+                     New_Reference_To
+                       (Base_Init_Proc (CPP_Parent), Loc),
+                   Parameter_Associations => New_List (
+                     Unchecked_Convert_To (CPP_Parent,
+                       New_Copy_Tree (Lhs)))));
+            end if;
+
+            Invoke_IC_Proc (Typ);
+         end Invoke_Constructor;
       end if;
 
       --  Generate the assignments, component by component
Index: exp_atag.adb
===================================================================
--- exp_atag.adb	(revision 163054)
+++ exp_atag.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2006-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 2006-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -26,6 +26,7 @@ 
 with Atree;    use Atree;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
+with Exp_Disp; use Exp_Disp;
 with Exp_Util; use Exp_Util;
 with Namet;    use Namet;
 with Nlists;   use Nlists;
@@ -33,6 +34,7 @@  with Nmake;    use Nmake;
 with Rtsfind;  use Rtsfind;
 with Sinfo;    use Sinfo;
 with Sem_Aux;  use Sem_Aux;
+with Sem_Disp; use Sem_Disp;
 with Sem_Util; use Sem_Util;
 with Stand;    use Stand;
 with Snames;   use Snames;
@@ -327,6 +329,258 @@  package body Exp_Atag is
             New_List (Make_Integer_Literal (Loc, Position)));
    end Build_Get_Predefined_Prim_Op_Address;
 
+   -----------------------------
+   -- Build_Inherit_CPP_Prims --
+   -----------------------------
+
+   function Build_Inherit_CPP_Prims (Typ : Entity_Id) return List_Id is
+      Loc          : constant Source_Ptr := Sloc (Typ);
+      CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
+      CPP_Table    : array (1 .. CPP_Nb_Prims) of Boolean := (others => False);
+      CPP_Typ      : constant Entity_Id := Enclosing_CPP_Parent (Typ);
+      Result       : constant List_Id   := New_List;
+      Parent_Typ   : constant Entity_Id := Etype (Typ);
+      E            : Entity_Id;
+      Elmt         : Elmt_Id;
+      Parent_Tag   : Entity_Id;
+      Prim         : Entity_Id;
+      Prim_Pos     : Nat;
+      Typ_Tag      : Entity_Id;
+
+   begin
+      pragma Assert (not Is_CPP_Class (Typ));
+
+      --  No code needed if this type has no primitives inherited from C++
+
+      if CPP_Nb_Prims = 0 then
+         return Result;
+      end if;
+
+      --  Stage 1: Inherit and override C++ slots of the primary dispatch table
+
+      --  Generate:
+      --     Typ'Tag (Prim_Pos) := Prim'Unrestricted_Access;
+
+      Parent_Tag := Node (First_Elmt (Access_Disp_Table (Parent_Typ)));
+      Typ_Tag    := Node (First_Elmt (Access_Disp_Table (Typ)));
+
+      Elmt := First_Elmt (Primitive_Operations (Typ));
+      while Present (Elmt) loop
+         Prim     := Node (Elmt);
+         E        := Ultimate_Alias (Prim);
+         Prim_Pos := UI_To_Int (DT_Position (E));
+
+         --  Skip predefined, abstract, and eliminated primitives. Skip also
+         --  primitives not located in the C++ part of the dispatch table.
+
+         if not Is_Predefined_Dispatching_Operation (Prim)
+           and then not Is_Predefined_Dispatching_Operation (E)
+           and then not Present (Interface_Alias (Prim))
+           and then not Is_Abstract_Subprogram (E)
+           and then not Is_Eliminated (E)
+           and then Prim_Pos <= CPP_Nb_Prims
+           and then Find_Dispatching_Type (E) = Typ
+         then
+            --  Remember that this slot is used
+
+            pragma Assert (CPP_Table (Prim_Pos) = False);
+            CPP_Table (Prim_Pos) := True;
+
+            Append_To (Result,
+              Make_Assignment_Statement (Loc,
+                Name =>
+                  Make_Indexed_Component (Loc,
+                    Prefix =>
+                      Make_Explicit_Dereference (Loc,
+                        Unchecked_Convert_To
+                          (Node (Last_Elmt (Access_Disp_Table (Typ))),
+                           New_Reference_To (Typ_Tag, Loc))),
+                    Expressions =>
+                       New_List (Make_Integer_Literal (Loc, Prim_Pos))),
+
+               Expression =>
+                 Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+                   Make_Attribute_Reference (Loc,
+                     Prefix => New_Reference_To (E, Loc),
+                     Attribute_Name => Name_Unrestricted_Access))));
+         end if;
+
+         Next_Elmt (Elmt);
+      end loop;
+
+      --  If all primitives have been overridden then there is no need to copy
+      --  from Typ's parent its dispatch table. Otherwise, if some primitive is
+      --  inherited from the parent we copy only the C++ part of the dispatch
+      --  table from the parent before the assignments that initialize the
+      --  overridden primitives.
+
+      --  Generate:
+
+      --     type CPP_TypG is array (1 .. CPP_Nb_Prims) ofd Prim_Ptr;
+      --     type CPP_TypH is access CPP_TypG;
+      --     CPP_TypG!(Typ_Tag).all := CPP_TypG!(Parent_Tag).all;
+
+      --   Note: There is no need to duplicate the declarations of CPP_TypG and
+      --         CPP_TypH because, for expansion of dispatching calls, these
+      --         entities are stored in the last elements of Access_Disp_Table.
+
+      for J in CPP_Table'Range loop
+         if not CPP_Table (J) then
+            Prepend_To (Result,
+              Make_Assignment_Statement (Loc,
+                Name =>
+                  Make_Explicit_Dereference (Loc,
+                    Unchecked_Convert_To
+                      (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))),
+                       New_Reference_To (Typ_Tag, Loc))),
+                Expression =>
+                  Make_Explicit_Dereference (Loc,
+                    Unchecked_Convert_To
+                      (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))),
+                       New_Reference_To (Parent_Tag, Loc)))));
+            exit;
+         end if;
+      end loop;
+
+      --  Stage 2: Inherit and override C++ slots of secondary dispatch tables
+
+      declare
+         Iface                   : Entity_Id;
+         Iface_Nb_Prims          : Nat;
+         Parent_Ifaces_List      : Elist_Id;
+         Parent_Ifaces_Comp_List : Elist_Id;
+         Parent_Ifaces_Tag_List  : Elist_Id;
+         Parent_Iface_Tag_Elmt   : Elmt_Id;
+         Typ_Ifaces_List         : Elist_Id;
+         Typ_Ifaces_Comp_List    : Elist_Id;
+         Typ_Ifaces_Tag_List     : Elist_Id;
+         Typ_Iface_Tag_Elmt      : Elmt_Id;
+
+      begin
+         Collect_Interfaces_Info
+           (T               => Parent_Typ,
+            Ifaces_List     => Parent_Ifaces_List,
+            Components_List => Parent_Ifaces_Comp_List,
+            Tags_List       => Parent_Ifaces_Tag_List);
+
+         Collect_Interfaces_Info
+           (T               => Typ,
+            Ifaces_List     => Typ_Ifaces_List,
+            Components_List => Typ_Ifaces_Comp_List,
+            Tags_List       => Typ_Ifaces_Tag_List);
+
+         Parent_Iface_Tag_Elmt := First_Elmt (Parent_Ifaces_Tag_List);
+         Typ_Iface_Tag_Elmt    := First_Elmt (Typ_Ifaces_Tag_List);
+         while Present (Parent_Iface_Tag_Elmt) loop
+            Parent_Tag := Node (Parent_Iface_Tag_Elmt);
+            Typ_Tag    := Node (Typ_Iface_Tag_Elmt);
+
+            pragma Assert
+              (Related_Type (Parent_Tag) = Related_Type (Typ_Tag));
+            Iface := Related_Type (Parent_Tag);
+
+            Iface_Nb_Prims :=
+              UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface)));
+
+            if Iface_Nb_Prims > 0 then
+
+               --  Update slots of overridden primitives
+
+               declare
+                  Last_Nod : constant Node_Id := Last (Result);
+                  Nb_Prims : constant Nat := UI_To_Int
+                                              (DT_Entry_Count
+                                               (First_Tag_Component (Iface)));
+                  Elmt     : Elmt_Id;
+                  Prim     : Entity_Id;
+                  E        : Entity_Id;
+                  Prim_Pos : Nat;
+
+                  Prims_Table : array (1 .. Nb_Prims) of Boolean;
+
+               begin
+                  Prims_Table := (others => False);
+
+                  Elmt := First_Elmt (Primitive_Operations (Typ));
+                  while Present (Elmt) loop
+                     Prim := Node (Elmt);
+                     E    := Ultimate_Alias (Prim);
+
+                     if not Is_Predefined_Dispatching_Operation (Prim)
+                       and then Present (Interface_Alias (Prim))
+                       and then Find_Dispatching_Type (Interface_Alias (Prim))
+                                  = Iface
+                       and then not Is_Abstract_Subprogram (E)
+                       and then not Is_Eliminated (E)
+                       and then Find_Dispatching_Type (E) = Typ
+                     then
+                        Prim_Pos := UI_To_Int (DT_Position (Prim));
+
+                        --  Remember that this slot is already initialized
+
+                        pragma Assert (Prims_Table (Prim_Pos) = False);
+                        Prims_Table (Prim_Pos) := True;
+
+                        Append_To (Result,
+                          Make_Assignment_Statement (Loc,
+                            Name =>
+                              Make_Indexed_Component (Loc,
+                                Prefix =>
+                                  Make_Explicit_Dereference (Loc,
+                                    Unchecked_Convert_To
+                                      (Node
+                                        (Last_Elmt
+                                          (Access_Disp_Table (Iface))),
+                                       New_Reference_To (Typ_Tag, Loc))),
+                                Expressions =>
+                                   New_List
+                                    (Make_Integer_Literal (Loc, Prim_Pos))),
+
+                            Expression =>
+                              Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+                                Make_Attribute_Reference (Loc,
+                                  Prefix => New_Reference_To (E, Loc),
+                                  Attribute_Name =>
+                                    Name_Unrestricted_Access))));
+                     end if;
+
+                     Next_Elmt (Elmt);
+                  end loop;
+
+                  --  Check if all primitives from the parent have been
+                  --  overridden (to avoid copying the whole secondary
+                  --  table from the parent).
+
+                  --   IfaceG!(Typ_Sec_Tag).all := IfaceG!(Parent_Sec_Tag).all;
+
+                  for J in Prims_Table'Range loop
+                     if not Prims_Table (J) then
+                        Insert_After (Last_Nod,
+                          Make_Assignment_Statement (Loc,
+                            Name =>
+                              Make_Explicit_Dereference (Loc,
+                                Unchecked_Convert_To
+                                 (Node (Last_Elmt (Access_Disp_Table (Iface))),
+                                  New_Reference_To (Typ_Tag, Loc))),
+                            Expression =>
+                              Make_Explicit_Dereference (Loc,
+                                Unchecked_Convert_To
+                                 (Node (Last_Elmt (Access_Disp_Table (Iface))),
+                                  New_Reference_To (Parent_Tag, Loc)))));
+                        exit;
+                     end if;
+                  end loop;
+               end;
+            end if;
+
+            Next_Elmt (Typ_Iface_Tag_Elmt);
+            Next_Elmt (Parent_Iface_Tag_Elmt);
+         end loop;
+      end;
+
+      return Result;
+   end Build_Inherit_CPP_Prims;
+
    -------------------------
    -- Build_Inherit_Prims --
    -------------------------
Index: exp_atag.ads
===================================================================
--- exp_atag.ads	(revision 163054)
+++ exp_atag.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2006-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 2006-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -97,6 +97,11 @@  package Exp_Atag is
    --
    --  Generates: TSD (Tag).Transportable;
 
+   function Build_Inherit_CPP_Prims (Typ : Entity_Id) return List_Id;
+   --  Build code that copies from Typ's parent the dispatch table slots of
+   --  inherited primitives and updates slots of overridden primitives. The
+   --  generated code handles primary and secondary dispatch tables of Typ.
+
    function Build_Inherit_Predefined_Prims
      (Loc          : Source_Ptr;
       Old_Tag_Node : Node_Id;
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb	(revision 163054)
+++ exp_ch3.adb	(working copy)
@@ -214,6 +214,9 @@  package body Exp_Ch3 is
    --  Check if E is defined in the RTL (in a child of Ada or System). Used
    --  to avoid to bring in the overhead of _Input, _Output for tagged types.
 
+   function Is_Variable_Size_Array (E : Entity_Id) return Boolean;
+   --  Returns true if E has variable size components
+
    function Is_Variable_Size_Record (E : Entity_Id) return Boolean;
    --  Returns true if E has variable size components
 
@@ -1777,6 +1780,12 @@  package body Exp_Ch3 is
       --
       --  This function builds the call statement in this _init_proc.
 
+      procedure Build_CPP_Init_Procedure;
+      --  Build the tree corresponding to the procedure specification and body
+      --  of the IC procedure that initializes the C++ part of the dispatch
+      --  table of an Ada tagged type that is a derivation of a CPP type.
+      --  Install it as the CPP_Init TSS.
+
       procedure Build_Init_Procedure;
       --  Build the tree corresponding to the procedure specification and body
       --  of the initialization procedure (by calling all the preceding
@@ -2209,6 +2218,104 @@  package body Exp_Ch3 is
          end loop;
       end Build_Offset_To_Top_Functions;
 
+      ------------------------------
+      -- Build_CPP_Init_Procedure --
+      ------------------------------
+
+      procedure Build_CPP_Init_Procedure is
+         Body_Node         : Node_Id;
+         Body_Stmts        : List_Id;
+         Flag_Id           : Entity_Id;
+         Flag_Decl         : Node_Id;
+         Handled_Stmt_Node : Node_Id;
+         Init_Tags_List    : List_Id;
+         Proc_Id           : Entity_Id;
+         Proc_Spec_Node    : Node_Id;
+
+      begin
+         --  Check cases requiring no IC routine
+
+         if not Is_CPP_Class (Root_Type (Rec_Type))
+           or else Is_CPP_Class (Rec_Type)
+           or else CPP_Num_Prims (Rec_Type) = 0
+           or else not Tagged_Type_Expansion
+           or else No_Run_Time_Mode
+         then
+            return;
+         end if;
+
+         --  Generate:
+
+         --     Flag : Boolean := False;
+         --
+         --     procedure Typ_IC is
+         --     begin
+         --        if not Flag then
+         --           Copy C++ dispatch table slots from parent
+         --           Update C++ slots of overridden primitives
+         --        end if;
+         --     end;
+
+         Flag_Id := Make_Temporary (Loc, 'F');
+
+         Flag_Decl :=
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => Flag_Id,
+             Object_Definition =>
+               New_Reference_To (Standard_Boolean, Loc),
+             Expression =>
+               New_Reference_To (Standard_True, Loc));
+
+         Analyze (Flag_Decl);
+         Append_Freeze_Action (Rec_Type, Flag_Decl);
+
+         Body_Stmts := New_List;
+         Body_Node := New_Node (N_Subprogram_Body, Loc);
+
+         Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
+
+         Proc_Id :=
+           Make_Defining_Identifier (Loc,
+             Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc));
+
+         Set_Ekind       (Proc_Id, E_Procedure);
+         Set_Is_Internal (Proc_Id);
+
+         Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id);
+
+         Set_Parameter_Specifications (Proc_Spec_Node, New_List);
+         Set_Specification (Body_Node, Proc_Spec_Node);
+         Set_Declarations (Body_Node, New_List);
+
+         Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type);
+
+         Append_To (Init_Tags_List,
+           Make_Assignment_Statement (Loc,
+             Name =>
+               New_Reference_To (Flag_Id, Loc),
+             Expression =>
+               New_Reference_To (Standard_False, Loc)));
+
+         Append_To (Body_Stmts,
+           Make_If_Statement (Loc,
+             Condition => New_Occurrence_Of (Flag_Id, Loc),
+             Then_Statements => Init_Tags_List));
+
+         Handled_Stmt_Node :=
+           New_Node (N_Handled_Sequence_Of_Statements, Loc);
+         Set_Statements (Handled_Stmt_Node, Body_Stmts);
+         Set_Exception_Handlers (Handled_Stmt_Node, No_List);
+         Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node);
+
+         if not Debug_Generated_Code then
+            Set_Debug_Info_Off (Proc_Id);
+         end if;
+
+         --  Associate CPP_Init_Proc with type
+
+         Set_Init_Proc (Rec_Type, Proc_Id);
+      end Build_CPP_Init_Procedure;
+
       --------------------------
       -- Build_Init_Procedure --
       --------------------------
@@ -2239,9 +2346,7 @@  package body Exp_Ch3 is
          --  a type extension. If the flag is false, we do not set the tag
          --  because it has been set already in the extension.
 
-         if Is_Tagged_Type (Rec_Type)
-           and then not Is_CPP_Class (Rec_Type)
-         then
+         if Is_Tagged_Type (Rec_Type) then
             Set_Tag := Make_Temporary (Loc, 'P');
 
             Append_To (Parameters,
@@ -2312,133 +2417,154 @@  package body Exp_Ch3 is
          --  the C++ side.
 
          if Is_Tagged_Type (Rec_Type)
-           and then not Is_CPP_Class (Rec_Type)
            and then Tagged_Type_Expansion
            and then not No_Run_Time_Mode
          then
-            --  Initialize the primary tag
+            --  Case 1: Ada tagged types with no CPP ancestor. Set the tags of
+            --  the actual object and invoke the IP of the parent (in this
+            --  order). The tag must be initialized before the call to the IP
+            --  of the parent and the assignments to other components because
+            --  the initial value of the components may depend on the tag (eg.
+            --  through a dispatching operation on an access to the current
+            --  type). The tag assignment is not done when initializing the
+            --  parent component of a type extension, because in that case the
+            --  tag is set in the extension.
 
-            Init_Tags_List := New_List (
-              Make_Assignment_Statement (Loc,
-                Name =>
-                  Make_Selected_Component (Loc,
-                    Prefix => Make_Identifier (Loc, Name_uInit),
-                    Selector_Name =>
-                      New_Reference_To (First_Tag_Component (Rec_Type), Loc)),
-
-                Expression =>
-                  New_Reference_To
-                    (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
+            if not Is_CPP_Class (Root_Type (Rec_Type)) then
 
-            --  Ada 2005 (AI-251): Initialize the secondary tags components
-            --  located at fixed positions (tags whose position depends on
-            --  variable size components are initialized later ---see below).
+               --  Initialize the primary tag component
 
-            if Ada_Version >= Ada_05
-              and then not Is_Interface (Rec_Type)
-              and then Has_Interfaces (Rec_Type)
-            then
-               Init_Secondary_Tags
-                 (Typ            => Rec_Type,
-                  Target         => Make_Identifier (Loc, Name_uInit),
-                  Stmts_List     => Init_Tags_List,
-                  Fixed_Comps    => True,
-                  Variable_Comps => False);
-            end if;
+               Init_Tags_List := New_List (
+                 Make_Assignment_Statement (Loc,
+                   Name =>
+                     Make_Selected_Component (Loc,
+                       Prefix => Make_Identifier (Loc, Name_uInit),
+                       Selector_Name =>
+                         New_Reference_To
+                           (First_Tag_Component (Rec_Type), Loc)),
+                   Expression =>
+                     New_Reference_To
+                       (Node
+                         (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
 
-            --  The tag must be inserted before the assignments to other
-            --  components,  because the initial value of the component may
-            --  depend on the tag (eg. through a dispatching operation on
-            --  an access to the current type). The tag assignment is not done
-            --  when initializing the parent component of a type extension,
-            --  because in that case the tag is set in the extension.
-
-            --  Extensions of imported C++ classes add a final complication,
-            --  because we cannot inhibit tag setting in the constructor for
-            --  the parent. In that case we insert the tag initialization
-            --  after the calls to initialize the parent.
+               --  Ada 2005 (AI-251): Initialize the secondary tags components
+               --  located at fixed positions (tags whose position depends on
+               --  variable size components are initialized later ---see below)
+
+               if Ada_Version >= Ada_05
+                 and then not Is_Interface (Rec_Type)
+                 and then Has_Interfaces (Rec_Type)
+               then
+                  Init_Secondary_Tags
+                    (Typ            => Rec_Type,
+                     Target         => Make_Identifier (Loc, Name_uInit),
+                     Stmts_List     => Init_Tags_List,
+                     Fixed_Comps    => True,
+                     Variable_Comps => False);
+               end if;
 
-            if not Is_CPP_Class (Root_Type (Rec_Type)) then
                Prepend_To (Body_Stmts,
                  Make_If_Statement (Loc,
                    Condition => New_Occurrence_Of (Set_Tag, Loc),
                    Then_Statements => Init_Tags_List));
 
-            --  CPP_Class derivation: In this case the dispatch table of the
-            --  parent was built in the C++ side and we copy the table of the
-            --  parent to initialize the new dispatch table.
+            --  Case 2: CPP type. The imported C++ constructor takes care of
+            --  tags initialization. No action needed here because the IP
+            --  is built by Set_CPP_Constructors; in this case the IP is a
+            --  wrapper that invokes the C++ constructor and copies the C++
+            --  tags locally. Done to inherit the C++ slots in Ada derivations
+            --  (see case 3).
+
+            elsif Is_CPP_Class (Rec_Type) then
+               pragma Assert (False);
+               null;
+
+            --  Case 3: Combined hierarchy containing C++ types and Ada tagged
+            --  type derivations. Derivations of imported C++ classes add a
+            --  complication, because we cannot inhibit tag setting in the
+            --  constructor for the parent. Hence we initialize the tag after
+            --  the call to the parent IP (that is, in reverse order compared
+            --  with pure Ada hierarchies ---see comment on case 1).
 
             else
+               --  Initialize the primary tag
+
+               Init_Tags_List := New_List (
+                 Make_Assignment_Statement (Loc,
+                   Name =>
+                     Make_Selected_Component (Loc,
+                       Prefix => Make_Identifier (Loc, Name_uInit),
+                       Selector_Name =>
+                         New_Reference_To
+                           (First_Tag_Component (Rec_Type), Loc)),
+                   Expression =>
+                     New_Reference_To
+                       (Node
+                         (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
+
+               --  Ada 2005 (AI-251): Initialize the secondary tags components
+               --  located at fixed positions (tags whose position depends on
+               --  variable size components are initialized later ---see below)
+
+               if Ada_Version >= Ada_05
+                 and then not Is_Interface (Rec_Type)
+                 and then Has_Interfaces (Rec_Type)
+               then
+                  Init_Secondary_Tags
+                    (Typ            => Rec_Type,
+                     Target         => Make_Identifier (Loc, Name_uInit),
+                     Stmts_List     => Init_Tags_List,
+                     Fixed_Comps    => True,
+                     Variable_Comps => False);
+               end if;
+
+               --  Initialize the tag component after invocation of parent IP.
+
+               --  Generate:
+               --     parent_IP(_init.parent); // Invokes the C++ constructor
+               --     [ typIC; ]               // Inherit C++ slots from parent
+               --     init_tags
+
                declare
-                  Nod : Node_Id;
+                  Ins_Nod : Node_Id;
 
                begin
-                  --  We assume the first init_proc call is for the parent
+                  --  Search for the call to the IP of the parent. We assume
+                  --  that the first init_proc call is for the parent.
 
-                  Nod := First (Body_Stmts);
-                  while Present (Next (Nod))
-                    and then (Nkind (Nod) /= N_Procedure_Call_Statement
-                               or else not Is_Init_Proc (Name (Nod)))
+                  Ins_Nod := First (Body_Stmts);
+                  while Present (Next (Ins_Nod))
+                     and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement
+                                or else not Is_Init_Proc (Name (Ins_Nod)))
                   loop
-                     Nod := Next (Nod);
+                     Next (Ins_Nod);
                   end loop;
 
-                  --  Generate:
-                  --     ancestor_constructor (_init.parent);
-                  --     if Arg2 then
-                  --        inherit_prim_ops (_init._tag, new_dt, num_prims);
-                  --        _init._tag := new_dt;
-                  --     end if;
-
-                  Prepend_To (Init_Tags_List,
-                    Build_Inherit_Prims (Loc,
-                      Typ          => Rec_Type,
-                      Old_Tag_Node =>
-                        Make_Selected_Component (Loc,
-                          Prefix        =>
-                            Make_Identifier (Loc,
-                              Chars => Name_uInit),
-                          Selector_Name =>
-                            New_Reference_To
-                              (First_Tag_Component (Rec_Type), Loc)),
-                      New_Tag_Node =>
-                        New_Reference_To
-                          (Node (First_Elmt (Access_Disp_Table (Rec_Type))),
-                           Loc),
-                      Num_Prims    =>
-                        UI_To_Int
-                          (DT_Entry_Count (First_Tag_Component (Rec_Type)))));
-
-                  Insert_After (Nod,
-                    Make_If_Statement (Loc,
-                      Condition => New_Occurrence_Of (Set_Tag, Loc),
-                      Then_Statements => Init_Tags_List));
-
-                  --  We have inherited table of the parent from the CPP side.
-                  --  Now we fill the slots associated with Ada primitives.
-                  --  This needs more work to avoid its execution each time
-                  --  an object is initialized???
+                  --  The IC routine copies the inherited slots of the C+ part
+                  --  of the dispatch table from the parent and updates the
+                  --  overridden C++ slots.
+
+                  if CPP_Num_Prims (Rec_Type) > 0 then
+                     declare
+                        Init_DT : Entity_Id;
+                        New_Nod : Node_Id;
+
+                     begin
+                        Init_DT := CPP_Init_Proc (Rec_Type);
+                        pragma Assert (Present (Init_DT));
+
+                        New_Nod :=
+                          Make_Procedure_Call_Statement (Loc,
+                            New_Reference_To (Init_DT, Loc));
+                        Insert_After (Ins_Nod, New_Nod);
 
-                  declare
-                     E    : Elmt_Id;
-                     Prim : Node_Id;
+                        --  Update location of init tag statements
 
-                  begin
-                     E := First_Elmt (Primitive_Operations (Rec_Type));
-                     while Present (E) loop
-                        Prim := Node (E);
-
-                        if not Is_Imported (Prim)
-                          and then Convention (Prim) = Convention_CPP
-                          and then not Present (Interface_Alias (Prim))
-                        then
-                           Append_List_To (Init_Tags_List,
-                             Register_Primitive (Loc, Prim => Prim));
-                        end if;
+                        Ins_Nod := New_Nod;
+                     end;
+                  end if;
 
-                        Next_Elmt (E);
-                     end loop;
-                  end;
+                  Insert_List_After (Ins_Nod, Init_Tags_List);
                end;
             end if;
 
@@ -3116,7 +3242,8 @@  package body Exp_Ch3 is
          --     at the other end of the call, even if it does nothing!)
 
          --  Note: the reason we exclude the CPP_Class case is because in this
-         --  case the initialization is performed in the C++ side.
+         --  case the initialization is performed by the C++ constructors, and
+         --  the IP is built by Set_CPP_Constructors.
 
          if Is_CPP_Class (Rec_Id) then
             return False;
@@ -3243,6 +3370,7 @@  package body Exp_Ch3 is
          end if;
 
          Build_Offset_To_Top_Functions;
+         Build_CPP_Init_Procedure;
          Build_Init_Procedure;
          Set_Is_Public (Proc_Id, Is_Public (Pe));
 
@@ -5720,7 +5848,6 @@  package body Exp_Ch3 is
 
          if Is_CPP_Class (Def_Id) then
             Set_All_DT_Position (Def_Id);
-            Set_CPP_Constructors (Def_Id);
 
             --  Create the tag entities with a minimum decoration
 
@@ -5728,6 +5855,8 @@  package body Exp_Ch3 is
                Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id));
             end if;
 
+            Set_CPP_Constructors (Def_Id);
+
          else
             if not Has_Static_DT then
 
@@ -6930,11 +7059,6 @@  package body Exp_Ch3 is
    is
       Loc : constant Source_Ptr := Sloc (Target);
 
-      procedure Inherit_CPP_Tag
-        (Typ       : Entity_Id;
-         Iface     : Entity_Id;
-         Tag_Comp  : Entity_Id;
-         Iface_Tag : Node_Id);
       --  Inherit the C++ tag of the secondary dispatch table of Typ associated
       --  with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
 
@@ -6949,32 +7073,6 @@  package body Exp_Ch3 is
       --  of Typ CPP tagged type we generate code to inherit the contents of
       --  the dispatch table directly from the ancestor.
 
-      ---------------------
-      -- Inherit_CPP_Tag --
-      ---------------------
-
-      procedure Inherit_CPP_Tag
-        (Typ       : Entity_Id;
-         Iface     : Entity_Id;
-         Tag_Comp  : Entity_Id;
-         Iface_Tag : Node_Id)
-      is
-      begin
-         pragma Assert (Is_CPP_Class (Etype (Typ)));
-
-         Append_To (Stmts_List,
-           Build_Inherit_Prims (Loc,
-             Typ          => Iface,
-             Old_Tag_Node =>
-               Make_Selected_Component (Loc,
-                 Prefix        => New_Copy_Tree (Target),
-                 Selector_Name => New_Reference_To (Tag_Comp, Loc)),
-             New_Tag_Node =>
-               New_Reference_To (Iface_Tag, Loc),
-             Num_Prims    =>
-               UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface)))));
-      end Inherit_CPP_Tag;
-
       --------------------
       -- Initialize_Tag --
       --------------------
@@ -7175,26 +7273,85 @@  package body Exp_Ch3 is
       while Present (Iface_Elmt) loop
          Tag_Comp := Node (Iface_Comp_Elmt);
 
+         --  Check if parent of record type has variable size components
+
+         In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp))
+           and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp)));
+
          --  If we are compiling under the CPP full ABI compatibility mode and
          --  the ancestor is a CPP_Pragma tagged type then we generate code to
-         --  inherit the contents of the dispatch table directly from the
-         --  ancestor.
+         --  initialize the secondary tag components from tags that reference
+         --  secondary tables filled with copy of parent slots.
 
-         if Is_CPP_Class (Etype (Full_Typ)) then
-            Inherit_CPP_Tag (Full_Typ,
-              Iface     => Node (Iface_Elmt),
-              Tag_Comp  => Tag_Comp,
-              Iface_Tag => Node (Iface_Tag_Elmt));
+         if Is_CPP_Class (Root_Type (Full_Typ)) then
 
-         --  Otherwise generate code to initialize the tag
+            --  Reject interface components located at variable offset in
+            --  C++ derivations. This is currently unsupported.
 
-         else
-            --  Check if the parent of the record type has variable size
-            --  components.
+            if not Fixed_Comps and then In_Variable_Pos then
+
+               --  Locate the first dynamic component of the record. Done to
+               --  improve the text of the warning.
+
+               declare
+                  Comp     : Entity_Id;
+                  Comp_Typ : Entity_Id;
+
+               begin
+                  Comp := First_Entity (Typ);
+                  while Present (Comp) loop
+                     Comp_Typ := Etype (Comp);
+
+                     if Ekind (Comp) /= E_Discriminant
+                       and then not Is_Tag (Comp)
+                     then
+                        exit when
+                          (Is_Record_Type (Comp_Typ)
+                             and then Is_Variable_Size_Record
+                                        (Base_Type (Comp_Typ)))
+                         or else
+                           (Is_Array_Type (Comp_Typ)
+                              and then Is_Variable_Size_Array (Comp_Typ));
+                     end if;
+
+                     Next_Entity (Comp);
+                  end loop;
+
+                  pragma Assert (Present (Comp));
+                  Error_Msg_Node_2 := Comp;
+                  Error_Msg_NE
+                    ("parent type & with dynamic component & cannot be parent"
+                       & " of 'C'P'P derivation if new interfaces are present",
+                     Typ, Scope (Original_Record_Component (Comp)));
+
+                  Error_Msg_Sloc :=
+                    Sloc (Scope (Original_Record_Component (Comp)));
+                  Error_Msg_NE
+                    ("type derived from 'C'P'P type & defined #",
+                     Typ, Scope (Original_Record_Component (Comp)));
+
+                  --  Avoid duplicated warnings
+
+                  exit;
+               end;
+
+            --  Initialize secondary tags
+
+            else
+               Append_To (Stmts_List,
+                 Make_Assignment_Statement (Loc,
+                   Name =>
+                     Make_Selected_Component (Loc,
+                       Prefix => New_Copy_Tree (Target),
+                       Selector_Name =>
+                         New_Reference_To (Node (Iface_Comp_Elmt), Loc)),
+                   Expression =>
+                     New_Reference_To (Node (Iface_Tag_Elmt), Loc)));
+            end if;
 
-            In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp))
-              and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp)));
+         --  Otherwise generate code to initialize the tag
 
+         else
             if (In_Variable_Pos and then Variable_Comps)
               or else (not In_Variable_Pos and then Fixed_Comps)
             then
@@ -7211,14 +7368,11 @@  package body Exp_Ch3 is
       end loop;
    end Init_Secondary_Tags;
 
-   -----------------------------
-   -- Is_Variable_Size_Record --
-   -----------------------------
+   ----------------------------
+   -- Is_Variable_Size_Array --
+   ----------------------------
 
-   function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
-      Comp     : Entity_Id;
-      Comp_Typ : Entity_Id;
-      Idx      : Node_Id;
+   function Is_Variable_Size_Array (E : Entity_Id) return Boolean is
 
       function Is_Constant_Bound (Exp : Node_Id) return Boolean;
       --  To simplify handling of array components. Determines whether the
@@ -7244,42 +7398,60 @@  package body Exp_Ch3 is
          end if;
       end Is_Constant_Bound;
 
-   --  Start of processing for Is_Variable_Sized_Record
+      --  Local variables
 
-   begin
-      pragma Assert (Is_Record_Type (E));
+      Idx : Node_Id;
 
-      Comp := First_Entity (E);
-      while Present (Comp) loop
-         Comp_Typ := Etype (Comp);
+   --  Start of processing for Is_Variable_Sized_Array
 
-         if Is_Record_Type (Comp_Typ) then
+   begin
+      pragma Assert (Is_Array_Type (E));
 
-            --  Recursive call if the record type has discriminants
+      --  Check if some index is initialized with a non-constant value
 
-            if Has_Discriminants (Comp_Typ)
-              and then Is_Variable_Size_Record (Comp_Typ)
+      Idx := First_Index (E);
+      while Present (Idx) loop
+         if Nkind (Idx) = N_Range then
+            if not Is_Constant_Bound (Low_Bound (Idx))
+              or else not Is_Constant_Bound (High_Bound (Idx))
             then
                return True;
             end if;
+         end if;
 
-         elsif Is_Array_Type (Comp_Typ) then
+         Idx := Next_Index (Idx);
+      end loop;
 
-            --  Check if some index is initialized with a non-constant value
+      return False;
+   end Is_Variable_Size_Array;
 
-            Idx := First_Index (Comp_Typ);
-            while Present (Idx) loop
-               if Nkind (Idx) = N_Range then
-                  if not Is_Constant_Bound (Low_Bound  (Idx))
-                       or else
-                     not Is_Constant_Bound (High_Bound (Idx))
-                  then
-                     return True;
-                  end if;
-               end if;
+   -----------------------------
+   -- Is_Variable_Size_Record --
+   -----------------------------
 
-               Idx := Next_Index (Idx);
-            end loop;
+   function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
+      Comp     : Entity_Id;
+      Comp_Typ : Entity_Id;
+
+   begin
+      pragma Assert (Is_Record_Type (E));
+
+      Comp := First_Entity (E);
+      while Present (Comp) loop
+         Comp_Typ := Etype (Comp);
+
+         --  Recursive call if the record type has discriminants
+
+         if Is_Record_Type (Comp_Typ)
+           and then Has_Discriminants (Comp_Typ)
+           and then Is_Variable_Size_Record (Comp_Typ)
+         then
+            return True;
+
+         elsif Is_Array_Type (Comp_Typ)
+           and then Is_Variable_Size_Array (Comp_Typ)
+         then
+            return True;
          end if;
 
          Next_Entity (Comp);
Index: exp_disp.adb
===================================================================
--- exp_disp.adb	(revision 163054)
+++ exp_disp.adb	(working copy)
@@ -464,6 +464,52 @@  package body Exp_Disp is
       end if;
    end Build_Static_Dispatch_Tables;
 
+   -------------------
+   -- CPP_Num_Prims --
+   -------------------
+
+   function CPP_Num_Prims (Typ : Entity_Id) return Nat is
+      CPP_Typ  : Entity_Id;
+      Tag_Comp : Entity_Id;
+
+   begin
+      if not Is_Tagged_Type (Typ)
+        or else not Is_CPP_Class (Root_Type (Typ))
+      then
+         return 0;
+
+      else
+         CPP_Typ  := Enclosing_CPP_Parent (Typ);
+         Tag_Comp := First_Tag_Component (CPP_Typ);
+
+         --  If the number of primitives is already set in the tag component
+         --  then use it
+
+         if Present (Tag_Comp)
+           and then DT_Entry_Count (Tag_Comp) /= No_Uint
+         then
+            return UI_To_Int (DT_Entry_Count (Tag_Comp));
+
+         --  Otherwise, count the primitives of the enclosing CPP type
+
+         else
+            declare
+               Count : Nat := 0;
+               Elmt  : Elmt_Id;
+
+            begin
+               Elmt := First_Elmt (Primitive_Operations (CPP_Typ));
+               while Present (Elmt) loop
+                  Count := Count + 1;
+                  Next_Elmt (Elmt);
+               end loop;
+
+               return Count;
+            end;
+         end if;
+      end if;
+   end CPP_Num_Prims;
+
    ------------------------------
    -- Default_Prim_Op_Position --
    ------------------------------
@@ -1733,6 +1779,30 @@  package body Exp_Disp is
       end if;
    end Expand_Interface_Thunk;
 
+   --------------------------
+   -- Has_CPP_Constructors --
+   --------------------------
+
+   function Has_CPP_Constructors (Typ : Entity_Id) return Boolean is
+      E : Entity_Id;
+
+   begin
+      --  Look for the constructor entities
+
+      E := Next_Entity (Typ);
+      while Present (E) loop
+         if Ekind (E) = E_Function
+           and then Is_Constructor (E)
+         then
+            return True;
+         end if;
+
+         Next_Entity (E);
+      end loop;
+
+      return False;
+   end Has_CPP_Constructors;
+
    ------------
    -- Has_DT --
    ------------
@@ -3936,7 +4006,8 @@  package body Exp_Disp is
             Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
 
          elsif Is_Abstract_Type (Typ)
-           or else not Building_Static_DT (Typ)
+           or else not Static_Dispatch_Tables
+           or else not Is_Library_Level_Tagged_Type (Typ)
          then
             for J in 1 .. Nb_Prim loop
                Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
@@ -3944,48 +4015,57 @@  package body Exp_Disp is
 
          else
             declare
-               Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
-               Pos        : Nat;
-               Thunk_Code : Node_Id;
-               Thunk_Id   : Entity_Id;
+               CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
+               E            : Entity_Id;
+               Prim_Pos     : Nat;
+               Prim_Table   : array (Nat range 1 .. Nb_Prim) of Entity_Id;
+               Thunk_Code   : Node_Id;
+               Thunk_Id     : Entity_Id;
 
             begin
                Prim_Table := (others => Empty);
 
                Prim_Elmt  := First_Elmt (Primitive_Operations (Typ));
                while Present (Prim_Elmt) loop
-                  Prim := Node (Prim_Elmt);
+                  Prim     := Node (Prim_Elmt);
+                  E        := Ultimate_Alias (Prim);
+                  Prim_Pos := UI_To_Int (DT_Position (E));
 
-                  --  Do not reference predefined primitives because they
-                  --  are located in a separate dispatch table; skip also
-                  --  abstract and eliminated primitives.
+                  --  Do not reference predefined primitives because they are
+                  --  located in a separate dispatch table; skip abstract and
+                  --  eliminated primitives; skip primitives located in the C++
+                  --  part of the dispatch table because their slot is set by
+                  --  the IC routine.
 
                   if not Is_Predefined_Dispatching_Operation (Prim)
                     and then Present (Interface_Alias (Prim))
                     and then not Is_Abstract_Subprogram (Alias (Prim))
                     and then not Is_Eliminated (Alias (Prim))
+                    and then (not Is_CPP_Class (Root_Type (Typ))
+                               or else Prim_Pos > CPP_Nb_Prims)
                     and then Find_Dispatching_Type
                                (Interface_Alias (Prim)) = Iface
 
                      --  Generate the code of the thunk only if the abstract
                      --  interface type is not an immediate ancestor of
-                     --  Tagged_Type; otherwise the DT associated with the
+                     --  Tagged_Type. Otherwise the DT associated with the
                      --  interface is the primary DT.
 
                     and then not Is_Ancestor (Iface, Typ)
                   then
                      if not Build_Thunks then
-                        Pos :=
+                        Prim_Pos :=
                           UI_To_Int (DT_Position (Interface_Alias (Prim)));
-                        Prim_Table (Pos) := Alias (Prim);
+                        Prim_Table (Prim_Pos) := Alias (Prim);
+
                      else
                         Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
 
                         if Present (Thunk_Id) then
-                           Pos :=
+                           Prim_Pos :=
                              UI_To_Int (DT_Position (Interface_Alias (Prim)));
 
-                           Prim_Table (Pos) := Thunk_Id;
+                           Prim_Table (Prim_Pos) := Thunk_Id;
                            Append_To (Result, Thunk_Code);
                         end if;
                      end if;
@@ -4001,6 +4081,7 @@  package body Exp_Disp is
                          Make_Attribute_Reference (Loc,
                            Prefix => New_Reference_To (Prim_Table (J), Loc),
                            Attribute_Name => Name_Unrestricted_Access));
+
                   else
                      New_Node := Make_Null (Loc);
                   end if;
@@ -4238,9 +4319,7 @@  package body Exp_Disp is
       --  register the primitives in the slots will be generated later --- when
       --  each primitive is frozen (see Freeze_Subprogram).
 
-      if Building_Static_DT (Typ)
-        and then not Is_CPP_Class (Typ)
-      then
+      if Building_Static_DT (Typ) then
          declare
             Save      : constant Boolean := Freezing_Library_Level_Tagged_Type;
             Prim      : Entity_Id;
@@ -4297,6 +4376,7 @@  package body Exp_Disp is
 
          AI_Tag_Comp := First_Elmt (Typ_Comps);
          while Present (AI_Tag_Comp) loop
+            pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'P'));
 
             --  Build the secondary table containing pointers to thunks
 
@@ -4311,33 +4391,40 @@  package body Exp_Disp is
               Build_Thunks    => True,
               Result          => Result);
 
-            --  Skip secondary dispatch table and secondary dispatch table of
-            --  predefined primitives
+            --  Skip secondary dispatch table referencing thunks to predefined
+            --  primitives.
 
             Next_Elmt (AI_Tag_Elmt);
+            pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Y'));
+
+            --  Secondary dispatch table referencing user-defined primitives
+            --  covered by this interface.
+
             Next_Elmt (AI_Tag_Elmt);
+            pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'D'));
 
             --  Build the secondary table containing pointers to primitives
             --  (used to give support to Generic Dispatching Constructors).
 
             Make_Secondary_DT
-             (Typ             => Typ,
-              Iface           => Base_Type (Related_Type (Node (AI_Tag_Comp))),
-              Suffix_Index    => -1,
-              Num_Iface_Prims =>  UI_To_Int
-                                   (DT_Entry_Count (Node (AI_Tag_Comp))),
-              Iface_DT_Ptr    => Node (AI_Tag_Elmt),
-              Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
-              Build_Thunks    => False,
-              Result          => Result);
+              (Typ              => Typ,
+               Iface            => Base_Type
+                                     (Related_Type (Node (AI_Tag_Comp))),
+               Suffix_Index     => -1,
+               Num_Iface_Prims  => UI_To_Int
+                                     (DT_Entry_Count (Node (AI_Tag_Comp))),
+               Iface_DT_Ptr     => Node (AI_Tag_Elmt),
+               Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)),
+               Build_Thunks     => False,
+               Result           => Result);
 
-            --  Skip secondary dispatch table and secondary dispatch table of
-            --  predefined primitives
+            --  Skip secondary dispatch table referencing predefined primitives
 
             Next_Elmt (AI_Tag_Elmt);
-            Next_Elmt (AI_Tag_Elmt);
+            pragma Assert (Has_Suffix (Node (AI_Tag_Elmt), 'Z'));
 
             Suffix_Index := Suffix_Index + 1;
+            Next_Elmt (AI_Tag_Elmt);
             Next_Elmt (AI_Tag_Comp);
          end loop;
       end if;
@@ -4942,7 +5029,7 @@  package body Exp_Disp is
                         (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
                      pragma Assert (Has_Thunks (Node (Elmt)));
 
-                     while Ekind (Node (Elmt)) = E_Constant
+                     while Is_Tag (Node (Elmt))
                         and then not
                           Is_Ancestor (Node (AI), Related_Type (Node (Elmt)))
                      loop
@@ -5447,17 +5534,21 @@  package body Exp_Disp is
          if Nb_Prim = 0 then
             Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
 
-         elsif not Building_Static_DT (Typ) then
+         elsif not Static_Dispatch_Tables
+           or else not Is_Library_Level_Tagged_Type (Typ)
+         then
             for J in 1 .. Nb_Prim loop
                Append_To (Prim_Ops_Aggr_List, Make_Null (Loc));
             end loop;
 
          else
             declare
-               Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
-               E          : Entity_Id;
-               Prim       : Entity_Id;
-               Prim_Elmt  : Elmt_Id;
+               CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
+               E            : Entity_Id;
+               Prim         : Entity_Id;
+               Prim_Elmt    : Elmt_Id;
+               Prim_Pos     : Nat;
+               Prim_Table   : array (Nat range 1 .. Nb_Prim) of Entity_Id;
 
             begin
                Prim_Table := (others => Empty);
@@ -5469,19 +5560,24 @@  package body Exp_Disp is
                   --  Retrieve the ultimate alias of the primitive for proper
                   --  handling of renamings and eliminated primitives.
 
-                  E := Ultimate_Alias (Prim);
+                  E        := Ultimate_Alias (Prim);
+                  Prim_Pos := UI_To_Int (DT_Position (E));
 
                   --  Do not reference predefined primitives because they are
                   --  located in a separate dispatch table; skip entities with
                   --  attribute Interface_Alias because they are only required
-                  --  to build secondary dispatch tables; skip also abstract
-                  --  and eliminated primitives.
+                  --  to build secondary dispatch tables; skip abstract and
+                  --  eliminated primitives; for derivations of CPP types skip
+                  --  primitives located in the C++ part of the dispatch table
+                  --  because their slot is initialized by the IC routine.
 
                   if not Is_Predefined_Dispatching_Operation (Prim)
                     and then not Is_Predefined_Dispatching_Operation (E)
                     and then not Present (Interface_Alias (Prim))
                     and then not Is_Abstract_Subprogram (E)
                     and then not Is_Eliminated (E)
+                    and then (not Is_CPP_Class (Root_Type (Typ))
+                               or else Prim_Pos > CPP_Nb_Prims)
                   then
                      pragma Assert
                        (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
@@ -5592,7 +5688,9 @@  package body Exp_Disp is
       --  because the whole dispatch table (including inherited primitives) has
       --  been already built.
 
-      if Building_Static_DT (Typ) then
+      if Static_Dispatch_Tables
+        and then Is_Library_Level_Tagged_Type (Typ)
+      then
          null;
 
       --  If the ancestor is a CPP_Class type we inherit the dispatch tables
@@ -6190,234 +6288,296 @@  package body Exp_Disp is
    --  Start of processing for Make_Tags
 
    begin
-      --  1) Generate the primary and secondary tag entities
-
-      --  Collect the components associated with secondary dispatch tables
-
-      if Has_Interfaces (Typ) then
-         Collect_Interface_Components (Typ, Typ_Comps);
-      end if;
+      pragma Assert (No (Access_Disp_Table (Typ)));
+      Set_Access_Disp_Table (Typ, New_Elmt_List);
 
       --  1) Generate the primary tag entities
 
       --  Primary dispatch table containing user-defined primitives
 
-      DT_Ptr := Make_Defining_Identifier (Loc,
-                  New_External_Name (Tname, 'P'));
-      Set_Etype (DT_Ptr, RTE (RE_Tag));
-
-      --  Primary dispatch table containing predefined primitives
-
-      Predef_Prims_Ptr :=
-        Make_Defining_Identifier (Loc,
-          Chars => New_External_Name (Tname, 'Y'));
-      Set_Etype (Predef_Prims_Ptr, RTE (RE_Address));
-
-      --  Import the forward declaration of the Dispatch Table wrapper record
-      --  (Make_DT will take care of its exportation)
+      DT_Ptr := Make_Defining_Identifier (Loc, New_External_Name (Tname, 'P'));
+      Set_Etype   (DT_Ptr, RTE (RE_Tag));
+      Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
 
-      if Building_Static_DT (Typ) then
-         Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
+      --  Minimum decoration
 
-         DT :=
-           Make_Defining_Identifier (Loc,
-             Chars => New_External_Name (Tname, 'T'));
+      Set_Ekind        (DT_Ptr, E_Variable);
+      Set_Related_Type (DT_Ptr, Typ);
 
-         Import_DT (Typ, DT, Is_Secondary_DT => False);
+      --  For CPP types there is no need to build the dispatch tables since
+      --  they are imported from the C++ side. If the CPP type has an IP
+      --  then we declare now the variable that will store the copy of the
+      --  C++ tag.
 
-         if Has_DT (Typ) then
+      if Is_CPP_Class (Typ) then
+         if Has_CPP_Constructors (Typ) then
             Append_To (Result,
               Make_Object_Declaration (Loc,
                 Defining_Identifier => DT_Ptr,
-                Constant_Present    => True,
                 Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
                 Expression =>
                   Unchecked_Convert_To (RTE (RE_Tag),
-                    Make_Attribute_Reference (Loc,
-                      Prefix =>
-                        Make_Selected_Component (Loc,
-                          Prefix => New_Reference_To (DT, Loc),
-                        Selector_Name =>
-                          New_Occurrence_Of
-                            (RTE_Record_Component (RE_Prims_Ptr), Loc)),
-                      Attribute_Name => Name_Address))));
+                    New_Reference_To (RTE (RE_Null_Address), Loc))));
 
-            --  Generate the SCIL node for the previous object declaration
-            --  because it has a tag initialization.
+            Set_Is_Statically_Allocated (DT_Ptr,
+              Is_Library_Level_Tagged_Type (Typ));
+         end if;
 
-            if Generate_SCIL then
-               New_Node :=
-                 Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
-               Set_SCIL_Entity (New_Node, Typ);
-               Set_SCIL_Node (Last (Result), New_Node);
-            end if;
+      --  Ada types
 
-            Append_To (Result,
-              Make_Object_Declaration (Loc,
-                Defining_Identifier => Predef_Prims_Ptr,
-                Constant_Present    => True,
-                Object_Definition   => New_Reference_To
-                                            (RTE (RE_Address), Loc),
-                Expression =>
-                  Make_Attribute_Reference (Loc,
-                    Prefix =>
-                      Make_Selected_Component (Loc,
-                        Prefix => New_Reference_To (DT, Loc),
-                      Selector_Name =>
-                        New_Occurrence_Of
-                          (RTE_Record_Component (RE_Predef_Prims), Loc)),
-                    Attribute_Name => Name_Address)));
+      else
+         --  Primary dispatch table containing predefined primitives
 
-         --  No dispatch table required
+         Predef_Prims_Ptr :=
+           Make_Defining_Identifier (Loc,
+             Chars => New_External_Name (Tname, 'Y'));
+         Set_Etype   (Predef_Prims_Ptr, RTE (RE_Address));
+         Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
 
-         else
-            Append_To (Result,
-              Make_Object_Declaration (Loc,
-                Defining_Identifier => DT_Ptr,
-                Constant_Present    => True,
-                Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
-                Expression =>
-                  Unchecked_Convert_To (RTE (RE_Tag),
-                    Make_Attribute_Reference (Loc,
-                      Prefix =>
-                        Make_Selected_Component (Loc,
-                          Prefix => New_Reference_To (DT, Loc),
-                        Selector_Name =>
-                          New_Occurrence_Of
-                            (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
-                      Attribute_Name => Name_Address))));
-         end if;
+         --  Import the forward declaration of the Dispatch Table wrapper
+         --  record (Make_DT will take care of its exportation)
 
-         Set_Is_True_Constant (DT_Ptr);
-         Set_Is_Statically_Allocated (DT_Ptr);
-      end if;
+         if Building_Static_DT (Typ) then
+            Set_Dispatch_Table_Wrappers (Typ, New_Elmt_List);
 
-      pragma Assert (No (Access_Disp_Table (Typ)));
-      Set_Access_Disp_Table (Typ, New_Elmt_List);
-      Append_Elmt (DT_Ptr, Access_Disp_Table (Typ));
-      Append_Elmt (Predef_Prims_Ptr, Access_Disp_Table (Typ));
+            DT :=
+              Make_Defining_Identifier (Loc,
+                Chars => New_External_Name (Tname, 'T'));
+
+            Import_DT (Typ, DT, Is_Secondary_DT => False);
+
+            if Has_DT (Typ) then
+               Append_To (Result,
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => DT_Ptr,
+                   Constant_Present    => True,
+                   Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
+                   Expression =>
+                     Unchecked_Convert_To (RTE (RE_Tag),
+                       Make_Attribute_Reference (Loc,
+                         Prefix =>
+                           Make_Selected_Component (Loc,
+                             Prefix => New_Reference_To (DT, Loc),
+                           Selector_Name =>
+                             New_Occurrence_Of
+                               (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+                         Attribute_Name => Name_Address))));
+
+               --  Generate the SCIL node for the previous object declaration
+               --  because it has a tag initialization.
+
+               if Generate_SCIL then
+                  New_Node :=
+                    Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result)));
+                  Set_SCIL_Entity (New_Node, Typ);
+                  Set_SCIL_Node (Last (Result), New_Node);
+               end if;
+
+               Append_To (Result,
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => Predef_Prims_Ptr,
+                   Constant_Present    => True,
+                   Object_Definition   => New_Reference_To
+                                               (RTE (RE_Address), Loc),
+                   Expression =>
+                     Make_Attribute_Reference (Loc,
+                       Prefix =>
+                         Make_Selected_Component (Loc,
+                           Prefix => New_Reference_To (DT, Loc),
+                         Selector_Name =>
+                           New_Occurrence_Of
+                             (RTE_Record_Component (RE_Predef_Prims), Loc)),
+                       Attribute_Name => Name_Address)));
+
+            --  No dispatch table required
+
+            else
+               Append_To (Result,
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => DT_Ptr,
+                   Constant_Present    => True,
+                   Object_Definition   => New_Reference_To (RTE (RE_Tag), Loc),
+                   Expression =>
+                     Unchecked_Convert_To (RTE (RE_Tag),
+                       Make_Attribute_Reference (Loc,
+                         Prefix =>
+                           Make_Selected_Component (Loc,
+                             Prefix => New_Reference_To (DT, Loc),
+                           Selector_Name =>
+                             New_Occurrence_Of
+                               (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
+                         Attribute_Name => Name_Address))));
+            end if;
+
+            Set_Is_True_Constant (DT_Ptr);
+            Set_Is_Statically_Allocated (DT_Ptr);
+         end if;
+      end if;
 
       --  2) Generate the secondary tag entities
 
+      --  Collect the components associated with secondary dispatch tables
+
       if Has_Interfaces (Typ) then
+         Collect_Interface_Components (Typ, Typ_Comps);
 
-         --  Note: The following value of Suffix_Index must be in sync with
-         --  the Suffix_Index values of secondary dispatch tables generated
-         --  by Make_DT.
+         --  For each interface type we build an unique external name
+         --  associated with its secondary dispatch table. This name is used to
+         --  declare an object that references this secondary dispatch table,
+         --  value that will be used for the elaboration of Typ's objects and
+         --  also for the elaboration of objects of derivations of Typ that do
+         --  not override the primitives of this interface type.
 
          Suffix_Index := 1;
 
-         --  For each interface type we build an unique external name
-         --  associated with its corresponding secondary dispatch table.
-         --  This external name will be used to declare an object that
-         --  references this secondary dispatch table, value that will be
-         --  used for the elaboration of Typ's objects and also for the
-         --  elaboration of objects of derivations of Typ that do not
-         --  override the primitive operation of this interface type.
-
-         AI_Tag_Comp := First_Elmt (Typ_Comps);
-         while Present (AI_Tag_Comp) loop
-            Get_Secondary_DT_External_Name
-              (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
-            Typ_Name := Name_Find;
+         --  Note: The value of Suffix_Index must be in sync with the
+         --  Suffix_Index values of secondary dispatch tables generated
+         --  by Make_DT.
 
-            if Building_Static_DT (Typ) then
-               Iface_DT :=
-                 Make_Defining_Identifier (Loc,
-                   Chars => New_External_Name
-                              (Typ_Name, 'T', Suffix_Index => -1));
-               Import_DT
-                 (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
-                  DT      => Iface_DT,
-                  Is_Secondary_DT => True);
-            end if;
+         if Is_CPP_Class (Typ) then
+            AI_Tag_Comp := First_Elmt (Typ_Comps);
+            while Present (AI_Tag_Comp) loop
+               Get_Secondary_DT_External_Name
+                 (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
+               Typ_Name := Name_Find;
 
-            --  Secondary dispatch table referencing thunks to user-defined
-            --  primitives covered by this interface.
+               --  Declare variables that will store the copy of the C++
+               --  secondary tags
 
-            Iface_DT_Ptr :=
-              Make_Defining_Identifier (Loc,
-                Chars => New_External_Name (Typ_Name, 'P'));
-            Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
-            Set_Ekind (Iface_DT_Ptr, E_Constant);
-            Set_Is_Tag (Iface_DT_Ptr);
-            Set_Has_Thunks (Iface_DT_Ptr);
-            Set_Is_Statically_Allocated (Iface_DT_Ptr,
-              Is_Library_Level_Tagged_Type (Typ));
-            Set_Is_True_Constant (Iface_DT_Ptr);
-            Set_Related_Type
-              (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
-            Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+               Iface_DT_Ptr :=
+                 Make_Defining_Identifier (Loc,
+                   Chars => New_External_Name (Typ_Name, 'P'));
+               Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
+               Set_Ekind (Iface_DT_Ptr, E_Variable);
+               Set_Is_Tag (Iface_DT_Ptr);
+
+               Set_Has_Thunks (Iface_DT_Ptr);
+               Set_Related_Type
+                 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+               Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
 
-            if Building_Static_DT (Typ) then
                Append_To (Result,
                  Make_Object_Declaration (Loc,
                    Defining_Identifier => Iface_DT_Ptr,
-                   Constant_Present    => True,
                    Object_Definition   => New_Reference_To
                                             (RTE (RE_Interface_Tag), Loc),
                    Expression =>
                      Unchecked_Convert_To (RTE (RE_Interface_Tag),
-                       Make_Attribute_Reference (Loc,
-                         Prefix =>
-                           Make_Selected_Component (Loc,
-                             Prefix => New_Reference_To (Iface_DT, Loc),
-                           Selector_Name =>
-                             New_Occurrence_Of
-                               (RTE_Record_Component (RE_Prims_Ptr), Loc)),
-                         Attribute_Name => Name_Address))));
-            end if;
+                       New_Reference_To (RTE (RE_Null_Address), Loc))));
 
-            --  Secondary dispatch table referencing thunks to predefined
-            --  primitives.
+               Set_Is_Statically_Allocated (Iface_DT_Ptr,
+                 Is_Library_Level_Tagged_Type (Typ));
 
-            Iface_DT_Ptr :=
-              Make_Defining_Identifier (Loc,
-                Chars => New_External_Name (Typ_Name, 'Y'));
-            Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
-            Set_Ekind (Iface_DT_Ptr, E_Constant);
-            Set_Is_Tag (Iface_DT_Ptr);
-            Set_Has_Thunks (Iface_DT_Ptr);
-            Set_Is_Statically_Allocated (Iface_DT_Ptr,
-              Is_Library_Level_Tagged_Type (Typ));
-            Set_Is_True_Constant (Iface_DT_Ptr);
-            Set_Related_Type
-              (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
-            Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+               Next_Elmt (AI_Tag_Comp);
+            end loop;
 
-            --  Secondary dispatch table referencing user-defined primitives
-            --  covered by this interface.
+         --  This is not a CPP_Class type
 
-            Iface_DT_Ptr :=
-              Make_Defining_Identifier (Loc,
-                Chars => New_External_Name (Typ_Name, 'D'));
-            Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
-            Set_Ekind (Iface_DT_Ptr, E_Constant);
-            Set_Is_Tag (Iface_DT_Ptr);
-            Set_Is_Statically_Allocated (Iface_DT_Ptr,
-              Is_Library_Level_Tagged_Type (Typ));
-            Set_Is_True_Constant (Iface_DT_Ptr);
-            Set_Related_Type
-              (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
-            Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+         else
+            AI_Tag_Comp := First_Elmt (Typ_Comps);
+            while Present (AI_Tag_Comp) loop
+               Get_Secondary_DT_External_Name
+                 (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index);
+               Typ_Name := Name_Find;
 
-            --  Secondary dispatch table referencing predefined primitives
+               if Building_Static_DT (Typ) then
+                  Iface_DT :=
+                    Make_Defining_Identifier (Loc,
+                      Chars => New_External_Name
+                                 (Typ_Name, 'T', Suffix_Index => -1));
+                  Import_DT
+                    (Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
+                     DT      => Iface_DT,
+                     Is_Secondary_DT => True);
+               end if;
 
-            Iface_DT_Ptr :=
-              Make_Defining_Identifier (Loc,
-                Chars => New_External_Name (Typ_Name, 'Z'));
-            Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
-            Set_Ekind (Iface_DT_Ptr, E_Constant);
-            Set_Is_Tag (Iface_DT_Ptr);
-            Set_Is_Statically_Allocated (Iface_DT_Ptr,
-              Is_Library_Level_Tagged_Type (Typ));
-            Set_Is_True_Constant (Iface_DT_Ptr);
-            Set_Related_Type
-              (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
-            Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+               --  Secondary dispatch table referencing thunks to user-defined
+               --  primitives covered by this interface.
 
-            Next_Elmt (AI_Tag_Comp);
-         end loop;
+               Iface_DT_Ptr :=
+                 Make_Defining_Identifier (Loc,
+                   Chars => New_External_Name (Typ_Name, 'P'));
+               Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
+               Set_Ekind (Iface_DT_Ptr, E_Constant);
+               Set_Is_Tag (Iface_DT_Ptr);
+               Set_Has_Thunks (Iface_DT_Ptr);
+               Set_Is_Statically_Allocated (Iface_DT_Ptr,
+                 Is_Library_Level_Tagged_Type (Typ));
+               Set_Is_True_Constant (Iface_DT_Ptr);
+               Set_Related_Type
+                 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+               Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+               if Building_Static_DT (Typ) then
+                  Append_To (Result,
+                    Make_Object_Declaration (Loc,
+                      Defining_Identifier => Iface_DT_Ptr,
+                      Constant_Present    => True,
+                      Object_Definition   => New_Reference_To
+                                               (RTE (RE_Interface_Tag), Loc),
+                      Expression =>
+                        Unchecked_Convert_To (RTE (RE_Interface_Tag),
+                          Make_Attribute_Reference (Loc,
+                            Prefix =>
+                              Make_Selected_Component (Loc,
+                                Prefix => New_Reference_To (Iface_DT, Loc),
+                              Selector_Name =>
+                                New_Occurrence_Of
+                                  (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+                            Attribute_Name => Name_Address))));
+               end if;
+
+               --  Secondary dispatch table referencing thunks to predefined
+               --  primitives.
+
+               Iface_DT_Ptr :=
+                 Make_Defining_Identifier (Loc,
+                   Chars => New_External_Name (Typ_Name, 'Y'));
+               Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
+               Set_Ekind (Iface_DT_Ptr, E_Constant);
+               Set_Is_Tag (Iface_DT_Ptr);
+               Set_Has_Thunks (Iface_DT_Ptr);
+               Set_Is_Statically_Allocated (Iface_DT_Ptr,
+                 Is_Library_Level_Tagged_Type (Typ));
+               Set_Is_True_Constant (Iface_DT_Ptr);
+               Set_Related_Type
+                 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+               Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+               --  Secondary dispatch table referencing user-defined primitives
+               --  covered by this interface.
+
+               Iface_DT_Ptr :=
+                 Make_Defining_Identifier (Loc,
+                   Chars => New_External_Name (Typ_Name, 'D'));
+               Set_Etype (Iface_DT_Ptr, RTE (RE_Interface_Tag));
+               Set_Ekind (Iface_DT_Ptr, E_Constant);
+               Set_Is_Tag (Iface_DT_Ptr);
+               Set_Is_Statically_Allocated (Iface_DT_Ptr,
+                 Is_Library_Level_Tagged_Type (Typ));
+               Set_Is_True_Constant (Iface_DT_Ptr);
+               Set_Related_Type
+                 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+               Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+               --  Secondary dispatch table referencing predefined primitives
+
+               Iface_DT_Ptr :=
+                 Make_Defining_Identifier (Loc,
+                   Chars => New_External_Name (Typ_Name, 'Z'));
+               Set_Etype (Iface_DT_Ptr, RTE (RE_Address));
+               Set_Ekind (Iface_DT_Ptr, E_Constant);
+               Set_Is_Tag (Iface_DT_Ptr);
+               Set_Is_Statically_Allocated (Iface_DT_Ptr,
+                 Is_Library_Level_Tagged_Type (Typ));
+               Set_Is_True_Constant (Iface_DT_Ptr);
+               Set_Related_Type
+                 (Iface_DT_Ptr, Related_Type (Node (AI_Tag_Comp)));
+               Append_Elmt (Iface_DT_Ptr, Access_Disp_Table (Typ));
+
+               Next_Elmt (AI_Tag_Comp);
+            end loop;
+         end if;
       end if;
 
       --  3) At the end of Access_Disp_Table, if the type has user-defined
@@ -6479,6 +6639,13 @@  package body Exp_Disp is
             Analyze_List (Result);
             Set_Suppress_Init_Proc (Base_Type (DT_Prims));
 
+            --  Add the freezing nodes of these declarations; required to avoid
+            --  generating these freezing nodes in wrong scopes (for example in
+            --  the IC routine of a derivation of Typ).
+
+            Append_List_To (Result, Freeze_Entity (DT_Prims, Loc));
+            Append_List_To (Result, Freeze_Entity (DT_Prims_Acc, Loc));
+
             --  Mark entity of dispatch table. Required by the back end to
             --  handle them properly.
 
@@ -6499,7 +6666,12 @@  package body Exp_Disp is
          Set_Is_Dispatch_Table_Entity (Etype (Iface_DT));
       end if;
 
-      Set_Ekind        (DT_Ptr, E_Constant);
+      if Is_CPP_Class (Root_Type (Typ)) then
+         Set_Ekind (DT_Ptr, E_Variable);
+      else
+         Set_Ekind (DT_Ptr, E_Constant);
+      end if;
+
       Set_Is_Tag       (DT_Ptr);
       Set_Related_Type (DT_Ptr, Typ);
 
@@ -6704,17 +6876,24 @@  package body Exp_Disp is
          else
             pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
 
-            DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
-            Append_To (L,
-              Build_Set_Prim_Op_Address (Loc,
-                Typ          => Tag_Typ,
-                Tag_Node     => New_Reference_To (DT_Ptr, Loc),
-                Position     => Pos,
-                Address_Node =>
-                  Unchecked_Convert_To (RTE (RE_Prim_Ptr),
-                    Make_Attribute_Reference (Loc,
-                      Prefix => New_Reference_To (Prim, Loc),
-                      Attribute_Name => Name_Unrestricted_Access))));
+            --  Skip registration of primitives located in the C++ part of the
+            --  dispatch table. Their slot is set by the IC routine.
+
+            if not Is_CPP_Class (Root_Type (Tag_Typ))
+              or else Pos > CPP_Num_Prims (Tag_Typ)
+            then
+               DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
+               Append_To (L,
+                 Build_Set_Prim_Op_Address (Loc,
+                   Typ          => Tag_Typ,
+                   Tag_Node     => New_Reference_To (DT_Ptr, Loc),
+                   Position     => Pos,
+                   Address_Node =>
+                     Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+                       Make_Attribute_Reference (Loc,
+                         Prefix => New_Reference_To (Prim, Loc),
+                         Attribute_Name => Name_Unrestricted_Access))));
+            end if;
          end if;
 
       --  Ada 2005 (AI-251): Primitive associated with an interface type
@@ -6734,6 +6913,16 @@  package body Exp_Disp is
 
          if Is_Ancestor (Iface_Typ, Tag_Typ) then
             return L;
+
+         --  No action needed for primitives located in the C++ part of the
+         --  dispatch table. Their slot is set by the IC routine.
+
+         elsif Is_CPP_Class (Root_Type (Tag_Typ))
+            and then DT_Position (Alias (Prim)) <= CPP_Num_Prims (Tag_Typ)
+            and then not Is_Predefined_Dispatching_Operation (Prim)
+            and then not Is_Predefined_Dispatching_Alias (Prim)
+         then
+            return L;
          end if;
 
          Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
@@ -7327,14 +7516,115 @@  package body Exp_Disp is
    --------------------------
 
    procedure Set_CPP_Constructors (Typ : Entity_Id) is
+
+      procedure Set_CPP_Constructors_Old (Typ : Entity_Id);
+      --  For backward compatibility this routine handles CPP constructors
+      --  of non-tagged types.
+
+      procedure Set_CPP_Constructors_Old (Typ : Entity_Id) is
+         Loc   : Source_Ptr;
+         Init  : Entity_Id;
+         E     : Entity_Id;
+         Found : Boolean := False;
+         P     : Node_Id;
+         Parms : List_Id;
+
+      begin
+         --  Look for the constructor entities
+
+         E := Next_Entity (Typ);
+         while Present (E) loop
+            if Ekind (E) = E_Function
+              and then Is_Constructor (E)
+            then
+               --  Create the init procedure
+
+               Found := True;
+               Loc   := Sloc (E);
+               Init  := Make_Defining_Identifier (Loc,
+                          Make_Init_Proc_Name (Typ));
+               Parms :=
+                 New_List (
+                   Make_Parameter_Specification (Loc,
+                     Defining_Identifier =>
+                       Make_Defining_Identifier (Loc, Name_X),
+                     Parameter_Type =>
+                       New_Reference_To (Typ, Loc)));
+
+               if Present (Parameter_Specifications (Parent (E))) then
+                  P := First (Parameter_Specifications (Parent (E)));
+                  while Present (P) loop
+                     Append_To (Parms,
+                       Make_Parameter_Specification (Loc,
+                         Defining_Identifier =>
+                           Make_Defining_Identifier (Loc,
+                             Chars (Defining_Identifier (P))),
+                         Parameter_Type =>
+                           New_Copy_Tree (Parameter_Type (P))));
+                     Next (P);
+                  end loop;
+               end if;
+
+               Discard_Node (
+                 Make_Subprogram_Declaration (Loc,
+                   Make_Procedure_Specification (Loc,
+                     Defining_Unit_Name => Init,
+                     Parameter_Specifications => Parms)));
+
+               Set_Init_Proc (Typ, Init);
+               Set_Is_Imported    (Init);
+               Set_Interface_Name (Init, Interface_Name (E));
+               Set_Convention     (Init, Convention_C);
+               Set_Is_Public      (Init);
+               Set_Has_Completion (Init);
+            end if;
+
+            Next_Entity (E);
+         end loop;
+
+         --  If there are no constructors, mark the type as abstract since we
+         --  won't be able to declare objects of that type.
+
+         if not Found then
+            Set_Is_Abstract_Type (Typ);
+         end if;
+      end Set_CPP_Constructors_Old;
+
+      --  Local variables
+
       Loc   : Source_Ptr;
-      Init  : Entity_Id;
       E     : Entity_Id;
       Found : Boolean := False;
       P     : Node_Id;
       Parms : List_Id;
 
+      Constructor_Decl_Node : Node_Id;
+      Constructor_Id        : Entity_Id;
+      Wrapper_Id            : Entity_Id;
+      Wrapper_Body_Node     : Node_Id;
+      Actuals               : List_Id;
+      Body_Stmts            : List_Id;
+      Init_Tags_List        : List_Id;
+
    begin
+      pragma Assert (Is_CPP_Class (Typ));
+
+      --  For backward compatibility the compiler accepts C++ classes
+      --  imported through non-tagged record types. In such case the
+      --  wrapper of the C++ constructor is useless because the _tag
+      --  component is not available.
+
+      --  Example:
+      --     type Root is limited record ...
+      --     pragma Import (CPP, Root);
+      --     function New_Root return Root;
+      --     pragma CPP_Constructor (New_Root, ... );
+
+      if not Is_Tagged_Type (Typ) then
+         Set_CPP_Constructors_Old (Typ);
+         return;
+      end if;
+
       --  Look for the constructor entities
 
       E := Next_Entity (Typ);
@@ -7342,16 +7632,16 @@  package body Exp_Disp is
          if Ekind (E) = E_Function
            and then Is_Constructor (E)
          then
-            --  Create the init procedure
-
             Found := True;
             Loc   := Sloc (E);
-            Init  := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
+
+            --  Generate the declaration of the imported C++ constructor
+
             Parms :=
               New_List (
                 Make_Parameter_Specification (Loc,
                   Defining_Identifier =>
-                    Make_Defining_Identifier (Loc, Name_X),
+                    Make_Defining_Identifier (Loc, Name_uInit),
                   Parameter_Type =>
                     New_Reference_To (Typ, Loc)));
 
@@ -7368,18 +7658,128 @@  package body Exp_Disp is
                end loop;
             end if;
 
-            Discard_Node (
+            Constructor_Id := Make_Temporary (Loc, 'P');
+
+            Constructor_Decl_Node :=
               Make_Subprogram_Declaration (Loc,
                 Make_Procedure_Specification (Loc,
-                  Defining_Unit_Name => Init,
-                  Parameter_Specifications => Parms)));
+                  Defining_Unit_Name => Constructor_Id,
+                  Parameter_Specifications => Parms));
 
-            Set_Init_Proc (Typ, Init);
-            Set_Is_Imported    (Init);
-            Set_Interface_Name (Init, Interface_Name (E));
-            Set_Convention     (Init, Convention_C);
-            Set_Is_Public      (Init);
-            Set_Has_Completion (Init);
+            Set_Is_Imported    (Constructor_Id);
+            Set_Interface_Name (Constructor_Id, Interface_Name (E));
+            Set_Convention     (Constructor_Id, Convention_C);
+            Set_Is_Public      (Constructor_Id);
+            Set_Has_Completion (Constructor_Id);
+
+            --  Build the wrapper of this constructor
+
+            Parms :=
+              New_List (
+                Make_Parameter_Specification (Loc,
+                  Defining_Identifier =>
+                    Make_Defining_Identifier (Loc, Name_uInit),
+                  Parameter_Type =>
+                    New_Reference_To (Typ, Loc)));
+
+            if Present (Parameter_Specifications (Parent (E))) then
+               P := First (Parameter_Specifications (Parent (E)));
+               while Present (P) loop
+                  Append_To (Parms,
+                    Make_Parameter_Specification (Loc,
+                      Defining_Identifier =>
+                        Make_Defining_Identifier (Loc,
+                          Chars (Defining_Identifier (P))),
+                      Parameter_Type => New_Copy_Tree (Parameter_Type (P))));
+                  Next (P);
+               end loop;
+            end if;
+
+            Body_Stmts := New_List;
+
+            --  Invoke the C++ constructor
+
+            Actuals := New_List;
+
+            P := First (Parms);
+            while Present (P) loop
+               Append_To (Actuals,
+                 New_Reference_To (Defining_Identifier (P), Loc));
+               Next (P);
+            end loop;
+
+            Append_To (Body_Stmts,
+              Make_Procedure_Call_Statement (Loc,
+                Name => New_Reference_To (Constructor_Id, Loc),
+                Parameter_Associations => Actuals));
+
+            --  Initialize copies of C++ primary and secondary tags
+
+            Init_Tags_List := New_List;
+
+            declare
+               Tag_Elmt : Elmt_Id;
+               Tag_Comp : Node_Id;
+
+            begin
+               Tag_Elmt := First_Elmt (Access_Disp_Table (Typ));
+               Tag_Comp := First_Tag_Component (Typ);
+
+               while Present (Tag_Elmt)
+                 and then Is_Tag (Node (Tag_Elmt))
+               loop
+                  --  Skip the following assertion with primary tags because
+                  --  Related_Type is not set on primary tag components
+
+                  pragma Assert (Tag_Comp = First_Tag_Component (Typ)
+                    or else Related_Type (Node (Tag_Elmt))
+                              = Related_Type (Tag_Comp));
+
+                  Append_To (Init_Tags_List,
+                    Make_Assignment_Statement (Loc,
+                      Name =>
+                        New_Reference_To (Node (Tag_Elmt), Loc),
+                      Expression =>
+                        Make_Selected_Component (Loc,
+                          Prefix => Make_Identifier (Loc, Name_uInit),
+                          Selector_Name =>
+                            New_Reference_To (Tag_Comp, Loc))));
+
+                     Tag_Comp := Next_Tag_Component (Tag_Comp);
+                  Next_Elmt (Tag_Elmt);
+               end loop;
+            end;
+
+            Append_To (Body_Stmts,
+              Make_If_Statement (Loc,
+                Condition =>
+                  Make_Op_Eq (Loc,
+                    Left_Opnd =>
+                      New_Reference_To
+                        (Node (First_Elmt (Access_Disp_Table (Typ))),
+                         Loc),
+                    Right_Opnd =>
+                      Unchecked_Convert_To (RTE (RE_Tag),
+                        New_Reference_To (RTE (RE_Null_Address), Loc))),
+                Then_Statements => Init_Tags_List));
+
+            Wrapper_Id := Make_Defining_Identifier (Loc,
+                            Make_Init_Proc_Name (Typ));
+
+            Wrapper_Body_Node :=
+              Make_Subprogram_Body (Loc,
+                Specification =>
+                  Make_Procedure_Specification (Loc,
+                    Defining_Unit_Name => Wrapper_Id,
+                    Parameter_Specifications => Parms),
+                Declarations => New_List (Constructor_Decl_Node),
+                Handled_Statement_Sequence =>
+                  Make_Handled_Sequence_Of_Statements (Loc,
+                    Statements => Body_Stmts,
+                    Exception_Handlers => No_List));
+
+            Discard_Node (Wrapper_Body_Node);
+            Set_Init_Proc (Typ, Wrapper_Id);
          end if;
 
          Next_Entity (E);
@@ -7391,6 +7791,17 @@  package body Exp_Disp is
       if not Found then
          Set_Is_Abstract_Type (Typ);
       end if;
+
+      --  If the CPP type has constructors then it must import also the default
+      --  C++ constructor. It is required for default initialization of objects
+      --  of the type. It is also required to elaborate objects of Ada types
+      --  that are defined as derivations of this CPP type.
+
+      if Has_CPP_Constructors (Typ)
+        and then No (Init_Proc (Typ))
+      then
+         Error_Msg_N ("?default constructor must be imported from C++", Typ);
+      end if;
    end Set_CPP_Constructors;
 
    --------------------------
@@ -7586,6 +7997,12 @@  package body Exp_Disp is
             Write_Str (" (eliminated)");
          end if;
 
+         if Is_Imported (Prim)
+           and then Convention (Prim) = Convention_CPP
+         then
+            Write_Str (" (C++)");
+         end if;
+
          Write_Eol;
 
          Next_Elmt (Elmt);
Index: exp_disp.ads
===================================================================
--- exp_disp.ads	(revision 163054)
+++ exp_disp.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -186,6 +186,10 @@  package Exp_Disp is
    --  bodies they are added to the end of the list of declarations of the
    --  package body.
 
+   function CPP_Num_Prims (Typ : Entity_Id) return Nat;
+   --  Return the number of primitives of the C++ part of the dispatch table.
+   --  For types that are not derivations of CPP types return 0.
+
    procedure Expand_Dispatching_Call (Call_Node : Node_Id);
    --  Expand the call to the operation through the dispatch table and perform
    --  the required tag checks when appropriate. For CPP types tag checks are
@@ -215,6 +219,9 @@  package Exp_Disp is
    --  Otherwise they are set to the defining identifier and the subprogram
    --  body of the generated thunk.
 
+   function Has_CPP_Constructors (Typ : Entity_Id) return Boolean;
+   --  Returns true if the type has CPP constructors
+
    function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean;
    --  Ada 2005 (AI-251): Determines if E is a predefined primitive operation
 
Index: exp_tss.adb
===================================================================
--- exp_tss.adb	(revision 163054)
+++ exp_tss.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -109,6 +109,35 @@  package body Exp_Tss is
       Prepend_Elmt (TSS, TSS_Elist (FN));
    end Copy_TSS;
 
+   -------------------
+   -- CPP_Init_Proc --
+   -------------------
+
+   function CPP_Init_Proc (Typ  : Entity_Id) return Entity_Id is
+      FN   : constant Node_Id := Freeze_Node (Typ);
+      Elmt : Elmt_Id;
+
+   begin
+      if not Is_CPP_Class (Root_Type (Typ))
+        or else No (FN)
+        or else No (TSS_Elist (FN))
+      then
+         return Empty;
+
+      else
+         Elmt := First_Elmt (TSS_Elist (FN));
+         while Present (Elmt) loop
+            if Is_CPP_Init_Proc (Node (Elmt)) then
+               return Node (Elmt);
+            end if;
+
+            Next_Elmt (Elmt);
+         end loop;
+      end if;
+
+      return Empty;
+   end CPP_Init_Proc;
+
    ------------------------
    -- Find_Inherited_TSS --
    ------------------------
@@ -276,6 +305,18 @@  package body Exp_Tss is
       return Empty;
    end Init_Proc;
 
+   ----------------------
+   -- Is_CPP_Init_Proc --
+   ----------------------
+
+   function Is_CPP_Init_Proc (E : Entity_Id) return Boolean is
+      C1 : Character;
+      C2 : Character;
+   begin
+      Get_Last_Two_Chars (Chars (E), C1, C2);
+      return C1 = TSS_CPP_Init_Proc (1) and then C2 = TSS_CPP_Init_Proc (2);
+   end Is_CPP_Init_Proc;
+
    ------------------
    -- Is_Init_Proc --
    ------------------
@@ -393,7 +434,7 @@  package body Exp_Tss is
       --  Skip this for Init_Proc with No_Default_Initialization, since the
       --  Init proc is a dummy void entity in this case to be ignored.
 
-      if Is_Init_Proc (TSS)
+      if (Is_Init_Proc (TSS) or else Is_CPP_Init_Proc (TSS))
         and then Restriction_Active (No_Default_Initialization)
       then
          null;
Index: exp_tss.ads
===================================================================
--- exp_tss.ads	(revision 163054)
+++ exp_tss.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -84,6 +84,7 @@  package Exp_Tss is
    TSS_Composite_Equality : constant TNT := "EQ";  -- Composite Equality
    TSS_From_Any           : constant TNT := "FA";  -- PolyORB/DSA From_Any
    TSS_Init_Proc          : constant TNT := "IP";  -- Initialization Procedure
+   TSS_CPP_Init_Proc      : constant TNT := "IC";  -- Init C++ dispatch tables
    TSS_RAS_Access         : constant TNT := "RA";  -- RAS type access
    TSS_RAS_Dereference    : constant TNT := "RD";  -- RAS type dereference
    TSS_Rep_To_Pos         : constant TNT := "RP";  -- Rep to Pos conversion
@@ -104,6 +105,7 @@  package Exp_Tss is
       TSS_Composite_Equality,
       TSS_From_Any,
       TSS_Init_Proc,
+      TSS_CPP_Init_Proc,
       TSS_RAS_Access,
       TSS_RAS_Dereference,
       TSS_Rep_To_Pos,
@@ -140,15 +142,18 @@  package Exp_Tss is
    function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id;
    --  Version for init procs, same as Make_TSS_Name (Typ, TSS_Init_Proc)
 
+   function Is_CPP_Init_Proc (E : Entity_Id) return Boolean;
+   --  Version for CPP init procs, same as Is_TSS (E, TSS_CPP_Init_Proc);
+
+   function Is_Init_Proc (E : Entity_Id) return Boolean;
+   --  Version for init procs, same as Is_TSS (E, TSS_Init_Proc);
+
    function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean;
    --  Determines if given entity (E) is the name of a TSS identified by Nam
 
    function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean;
    --  Same test applied directly to a Name_Id value
 
-   function Is_Init_Proc (E : Entity_Id) return Boolean;
-   --  Version for init procs, same as Is_TSS (E, TSS_Init_Proc);
-
    -----------------------------------------
    -- TSS Data structures and Subprograms --
    -----------------------------------------
@@ -188,6 +193,11 @@  package Exp_Tss is
    --  used to initially install a TSS in the case where the subprogram for the
    --  TSS has already been created and its declaration processed.
 
+   function CPP_Init_Proc (Typ : Entity_Id) return Entity_Id;
+   --  Obtains the CPP_Init TSS entity the given type. The CPP_Init TSS is a
+   --  procedure used to initialize the C++ part of the primary and secondary
+   --  dispatch tables of a tagged type derived from CPP types.
+
    function Init_Proc
      (Typ : Entity_Id;
       Ref : Entity_Id := Empty) return Entity_Id;
Index: freeze.ads
===================================================================
--- freeze.ads	(revision 163054)
+++ freeze.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -175,7 +175,7 @@  package Freeze is
    --  do not allow a size clause if the size would not otherwise be known at
    --  compile time in any case.
 
-   function  Is_Atomic_Aggregate
+   function Is_Atomic_Aggregate
      (E   : Entity_Id;
       Typ : Entity_Id) return Boolean;
 
Index: sem_aggr.adb
===================================================================
--- sem_aggr.adb	(revision 163054)
+++ sem_aggr.adb	(working copy)
@@ -2417,6 +2417,36 @@  package body Sem_Aggr is
                Error_Msg_N
                  ("type of limited ancestor part must be constrained", A);
 
+            --  Reject the use of CPP constructors that leave objects partially
+            --  initialized. For example:
+
+            --    type CPP_Root is tagged limited record ...
+            --    pragma Import (CPP, CPP_Root);
+
+            --    type CPP_DT is new CPP_Root and Iface ...
+            --    pragma Import (CPP, CPP_DT);
+
+            --    type Ada_DT is new CPP_DT with ...
+
+            --    Obj : Ada_DT := Ada_DT'(New_CPP_Root with others => <>);
+
+            --  Using the constructor of CPP_Root the slots of the dispatch
+            --  table of CPP_DT cannot be set, and the secondary tag of
+            --  CPP_DT is unknown.
+
+            elsif Nkind (A) = N_Function_Call
+              and then Is_CPP_Constructor_Call (A)
+              and then Enclosing_CPP_Parent (Typ) /= A_Type
+            then
+               Error_Msg_NE
+                 ("?must use 'C'P'P constructor for type &", A,
+                  Enclosing_CPP_Parent (Typ));
+
+               --  The following call is not needed if the previous warning
+               --  is promoted to an error.
+
+               Resolve_Record_Aggregate (N, Typ);
+
             elsif Is_Class_Wide_Type (Etype (A))
               and then Nkind (Original_Node (A)) = N_Function_Call
             then
Index: sem_attr.adb
===================================================================
--- sem_attr.adb	(revision 163063)
+++ sem_attr.adb	(working copy)
@@ -697,6 +697,12 @@  package body Sem_Attr is
                        ("current instance attribute must appear alone", N);
                   end if;
 
+                  if Is_CPP_Class (Root_Type (Typ)) then
+                     Error_Msg_N
+                       ("?current instance unsupported for derivations of "
+                        & "'C'P'P types", N);
+                  end if;
+
                --  OK if we are in initialization procedure for the type
                --  in question, in which case the reference to the type
                --  is rewritten as a reference to the current object.
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 163054)
+++ sem_ch13.adb	(working copy)
@@ -26,7 +26,9 @@ 
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
+with Elists;   use Elists;
 with Errout;   use Errout;
+with Exp_Disp; use Exp_Disp;
 with Exp_Tss;  use Exp_Tss;
 with Exp_Util; use Exp_Util;
 with Lib;      use Lib;
@@ -2385,6 +2387,70 @@  package body Sem_Ch13 is
 
          Add_Internal_Interface_Entities (E);
       end if;
+
+      --  Check CPP types
+
+      if Ekind (E) = E_Record_Type
+        and then Is_CPP_Class (E)
+        and then Is_Tagged_Type (E)
+        and then Tagged_Type_Expansion
+        and then Expander_Active
+      then
+         if CPP_Num_Prims (E) = 0 then
+
+            --  If the CPP type has user defined components then it must import
+            --  primitives from C++. This is required because if the C++ class
+            --  has no primitives then the C++ compiler does not added the _tag
+            --  component to the type.
+
+            pragma Assert (Chars (First_Entity (E)) = Name_uTag);
+
+            if First_Entity (E) /= Last_Entity (E) then
+               Error_Msg_N
+                 ("?'C'P'P type must import at least one primitive from C++",
+                  E);
+            end if;
+         end if;
+
+         --  Check that all its primitives are abstract or imported from C++.
+         --  Check also availability of the C++ constructor.
+
+         declare
+            Has_Constructors : constant Boolean := Has_CPP_Constructors (E);
+            Elmt             : Elmt_Id;
+            Error_Reported   : Boolean := False;
+            Prim             : Node_Id;
+
+         begin
+            Elmt := First_Elmt (Primitive_Operations (E));
+            while Present (Elmt) loop
+               Prim := Node (Elmt);
+
+               if Comes_From_Source (Prim) then
+                  if Is_Abstract_Subprogram (Prim) then
+                     null;
+
+                  elsif not Is_Imported (Prim)
+                    or else Convention (Prim) /= Convention_CPP
+                  then
+                     Error_Msg_N
+                       ("?primitives of 'C'P'P types must be imported from C++"
+                        & " or abstract", Prim);
+
+                  elsif not Has_Constructors
+                     and then not Error_Reported
+                  then
+                     Error_Msg_Name_1 := Chars (E);
+                     Error_Msg_N
+                       ("?'C'P'P constructor required for type %", Prim);
+                     Error_Reported := True;
+                  end if;
+               end if;
+
+               Next_Elmt (Elmt);
+            end loop;
+         end;
+      end if;
    end Analyze_Freeze_Entity;
 
    ------------------------------------------
Index: sem_ch8.adb
===================================================================
--- sem_ch8.adb	(revision 163063)
+++ sem_ch8.adb	(working copy)
@@ -513,6 +513,7 @@  package body Sem_Ch8 is
 
    procedure Write_Scopes;
    pragma Warnings (Off, Write_Scopes);
+   pragma Export (Ada, Write_Scopes);
    --  Debugging information: dump all entities on scope stack
 
    --------------------------------
Index: sem_prag.adb
===================================================================
--- sem_prag.adb	(revision 163063)
+++ sem_prag.adb	(working copy)
@@ -6554,6 +6554,14 @@  package body Sem_Prag is
 
             Def_Id := Entity (Id);
 
+            --  Check if already defined as constructor
+
+            if Is_Constructor (Def_Id) then
+               Error_Msg_N
+                 ("?duplicate argument for pragma 'C'P'P_Constructor", Arg1);
+               return;
+            end if;
+
             if Ekind (Def_Id) = E_Function
               and then (Is_CPP_Class (Etype (Def_Id))
                          or else (Is_Class_Wide_Type (Etype (Def_Id))
Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 163054)
+++ sem_util.adb	(working copy)
@@ -1564,22 +1564,48 @@  package body Sem_Util is
 
       function Search_Tag (Iface : Entity_Id) return Entity_Id is
          ADT : Elmt_Id;
-
       begin
-         ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
+         if not Is_CPP_Class (T) then
+            ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
+         else
+            ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
+         end if;
+
          while Present (ADT)
-            and then Ekind (Node (ADT)) = E_Constant
+            and then Is_Tag (Node (ADT))
             and then Related_Type (Node (ADT)) /= Iface
          loop
-            --  Skip the secondary dispatch tables of Iface
+            --  Skip secondary dispatch table referencing thunks to user
+            --  defined primitives covered by this interface.
 
+            pragma Assert (Has_Suffix (Node (ADT), 'P'));
             Next_Elmt (ADT);
-            Next_Elmt (ADT);
-            Next_Elmt (ADT);
-            Next_Elmt (ADT);
+
+            --  Skip secondary dispatch tables of Ada types
+
+            if not Is_CPP_Class (T) then
+
+               --  Skip secondary dispatch table referencing thunks to
+               --  predefined primitives.
+
+               pragma Assert (Has_Suffix (Node (ADT), 'Y'));
+               Next_Elmt (ADT);
+
+               --  Skip secondary dispatch table referencing user-defined
+               --  primitives covered by this interface.
+
+               pragma Assert (Has_Suffix (Node (ADT), 'D'));
+               Next_Elmt (ADT);
+
+               --  Skip secondary dispatch table referencing predefined
+               --  primitives
+
+               pragma Assert (Has_Suffix (Node (ADT), 'Z'));
+               Next_Elmt (ADT);
+            end if;
          end loop;
 
-         pragma Assert (Ekind (Node (ADT)) = E_Constant);
+         pragma Assert (Is_Tag (Node (ADT)));
          return Node (ADT);
       end Search_Tag;
 
@@ -2499,6 +2525,28 @@  package body Sem_Util is
       end if;
    end Designate_Same_Unit;
 
+   --------------------------
+   -- Enclosing_CPP_Parent --
+   --------------------------
+
+   function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
+      Parent_Typ : Entity_Id := Typ;
+
+   begin
+      while not Is_CPP_Class (Parent_Typ)
+         and then Etype (Parent_Typ) /= Parent_Typ
+      loop
+         Parent_Typ := Etype (Parent_Typ);
+
+         if Is_Private_Type (Parent_Typ) then
+            Parent_Typ := Full_View (Base_Type (Parent_Typ));
+         end if;
+      end loop;
+
+      pragma Assert (Is_CPP_Class (Parent_Typ));
+      return Parent_Typ;
+   end Enclosing_CPP_Parent;
+
    ----------------------------
    -- Enclosing_Generic_Body --
    ----------------------------
@@ -5208,6 +5256,16 @@  package body Sem_Util is
       end if;
    end Has_Stream;
 
+   ----------------
+   -- Has_Suffix --
+   ----------------
+
+   function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
+   begin
+      Get_Name_String (Chars (E));
+      return Name_Buffer (Name_Len) = Suffix;
+   end Has_Suffix;
+
    --------------------------
    -- Has_Tagged_Component --
    --------------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads	(revision 163054)
+++ sem_util.ads	(working copy)
@@ -279,6 +279,9 @@  package Sem_Util is
    --  these names is supposed to be a selected component name, an expanded
    --  name, a defining program unit name or an identifier.
 
+   function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id;
+   --  Returns the closest ancestor of Typ that is a CPP type.
+
    function Enclosing_Generic_Body
      (N : Node_Id) return Node_Id;
    --  Returns the Node_Id associated with the innermost enclosing generic
@@ -578,6 +581,9 @@  package Sem_Util is
    --  applied to the underlying type (or returns False if there is no
    --  underlying type).
 
+   function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean;
+   --  Returns true if the last character of E is Suffix. Used in Assertions.
+
    function Has_Tagged_Component (Typ : Entity_Id) return Boolean;
    --  Returns True if Typ is a composite type (array or record) which is
    --  either itself a tagged type, or has a component (recursively) which is
Index: gcc-interface/Make-lang.in
===================================================================
--- gcc-interface/Make-lang.in	(revision 163054)
+++ gcc-interface/Make-lang.in	(working copy)
@@ -1765,11 +1765,11 @@  ada/exp_ch11.o : ada/ada.ads ada/a-excep
    ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \
    ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
    ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \
-   ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
-   ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \
-   ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
-   ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \
-   ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+   ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+   ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
+   ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+   ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
+   ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
    ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads 
 
 ada/exp_ch12.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
@@ -1845,13 +1845,13 @@  ada/exp_ch3.o : ada/ada.ads ada/a-except
    ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \
    ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \
    ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
-   ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \
-   ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
-   ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
-   ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
-   ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
-   ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
-   ada/urealp.ads ada/validsw.ads 
+   ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
+   ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+   ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+   ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+   ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
+   ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
+   ada/unchdeal.ads ada/urealp.ads ada/validsw.ads 
 
 ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
    ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
@@ -1973,12 +1973,13 @@  ada/exp_ch7.o : ada/ada.ads ada/a-except
    ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \
    ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
    ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \
-   ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
-   ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \
-   ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
-   ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \
-   ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
-   ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads 
+   ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+   ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
+   ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+   ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
+   ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
+   ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
+   ada/urealp.ads ada/validsw.ads 
 
 ada/exp_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
    ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
@@ -2249,11 +2250,11 @@  ada/exp_prag.o : ada/ada.ads ada/a-excep
    ada/sinput.adb ada/snames.ads ada/snames.adb ada/stand.ads \
    ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \
    ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
-   ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \
-   ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
-   ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
-   ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \
-   ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+   ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
+   ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+   ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+   ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+   ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
    ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads 
 
 ada/exp_sel.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
@@ -2476,13 +2477,13 @@  ada/frontend.o : ada/ada.ads ada/a-excep
    ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \
    ada/system.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \
    ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
-   ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \
-   ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
-   ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \
-   ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
-   ada/tbuild.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
-   ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
-   ada/urealp.ads ada/widechar.ads 
+   ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
+   ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+   ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \
+   ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+   ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/types.ads \
+   ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
+   ada/unchdeal.ads ada/urealp.ads ada/widechar.ads 
 
 ada/g-byorma.o : ada/gnat.ads ada/g-byorma.ads ada/g-byorma.adb \
    ada/system.ads 
@@ -2996,18 +2997,19 @@  ada/restrict.o : ada/ada.ads ada/a-excep
    ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \
    ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \
    ada/fname-uf.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \
-   ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
-   ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \
-   ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \
-   ada/rident.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
-   ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \
-   ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \
-   ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \
-   ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
-   ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \
-   ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
-   ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
-   ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads 
+   ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \
+   ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/namet.adb \
+   ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \
+   ada/restrict.ads ada/restrict.adb ada/rident.ads ada/sinfo.ads \
+   ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \
+   ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \
+   ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
+   ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
+   ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+   ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+   ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
+   ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
+   ada/urealp.ads ada/widechar.ads 
 
 ada/rident.o : ada/rident.ads ada/system.ads ada/s-rident.ads 
 
@@ -3302,33 +3304,33 @@  ada/sem_attr.o : ada/ada.ads ada/a-chara
    ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads ada/exp_ch6.ads \
    ada/exp_ch7.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_pakd.ads \
    ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/expander.ads \
-   ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
-   ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \
-   ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib-xref.ads \
-   ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \
-   ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
-   ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \
-   ada/scng.adb ada/sdefault.ads ada/sem.ads ada/sem_aggr.ads \
-   ada/sem_attr.ads ada/sem_attr.adb ada/sem_aux.ads ada/sem_aux.adb \
-   ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch13.ads ada/sem_ch3.ads \
-   ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \
-   ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \
-   ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb \
-   ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \
-   ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \
-   ada/snames.ads ada/snames.adb ada/sprint.ads ada/stand.ads \
-   ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \
-   ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \
-   ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \
-   ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \
-   ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
-   ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
-   ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \
-   ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
-   ada/tbuild.adb ada/tree_io.ads ada/ttypef.ads ada/ttypes.ads \
-   ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \
-   ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \
-   ada/validsw.ads ada/widechar.ads 
+   ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \
+   ada/gnat.ads ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads \
+   ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads \
+   ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \
+   ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
+   ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \
+   ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sdefault.ads \
+   ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_attr.adb \
+   ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch10.ads \
+   ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads \
+   ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \
+   ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads \
+   ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \
+   ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \
+   ada/sinput.ads ada/sinput.adb ada/snames.ads ada/snames.adb \
+   ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \
+   ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \
+   ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \
+   ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \
+   ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \
+   ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+   ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \
+   ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+   ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \
+   ada/ttypef.ads ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads \
+   ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
+   ada/urealp.ads ada/urealp.adb ada/validsw.ads ada/widechar.ads 
 
 ada/sem_aux.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
    ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
@@ -3399,23 +3401,24 @@  ada/sem_ch10.o : ada/ada.ads ada/a-excep
    ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \
    ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
    ada/opt.ads ada/output.ads ada/par_sco.ads ada/restrict.ads \
-   ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \
-   ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \
-   ada/sem_ch10.ads ada/sem_ch10.adb ada/sem_ch3.ads ada/sem_ch6.ads \
-   ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \
-   ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads \
-   ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \
-   ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb \
-   ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \
-   ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \
-   ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \
-   ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \
-   ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
-   ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \
-   ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \
-   ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \
-   ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
-   ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads 
+   ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \
+   ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \
+   ada/sem_aux.ads ada/sem_ch10.ads ada/sem_ch10.adb ada/sem_ch3.ads \
+   ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \
+   ada/sem_dist.ads ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads \
+   ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \
+   ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \
+   ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \
+   ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \
+   ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \
+   ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \
+   ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+   ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
+   ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \
+   ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+   ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
+   ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
+   ada/urealp.ads ada/widechar.ads 
 
 ada/sem_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
    ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \