New Language: Ada

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45954 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 1278 insertions, 0 deletions

diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
new file mode 100644
index 00000000000..bdddde4a289
--- /dev/null
+++ b/gcc/ada/exp_disp.adb
@@ -0,0 +1,1278 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             E X P _ D I S P                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.79 $
+--                                                                          --
+--          Copyright (C) 1992-2001 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- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Atree;    use Atree;
+with Checks;   use Checks;
+with Einfo;    use Einfo;
+with Elists;   use Elists;
+with Errout;   use Errout;
+with Exp_Ch7;  use Exp_Ch7;
+with Exp_Tss;  use Exp_Tss;
+with Exp_Util; use Exp_Util;
+with Fname;    use Fname;
+with Itypes;   use Itypes;
+with Lib;      use Lib;
+with Nlists;   use Nlists;
+with Nmake;    use Nmake;
+with Opt;      use Opt;
+with Rtsfind;  use Rtsfind;
+with Sem_Disp; use Sem_Disp;
+with Sem_Res;  use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo;    use Sinfo;
+with Snames;   use Snames;
+with Stand;    use Stand;
+with Tbuild;   use Tbuild;
+with Uintp;    use Uintp;
+
+package body Exp_Disp is
+
+   Ada_Actions : constant array (DT_Access_Action) of RE_Id :=
+      (CW_Membership           => RE_CW_Membership,
+       DT_Entry_Size           => RE_DT_Entry_Size,
+       DT_Prologue_Size        => RE_DT_Prologue_Size,
+       Get_Expanded_Name       => RE_Get_Expanded_Name,
+       Get_External_Tag        => RE_Get_External_Tag,
+       Get_Prim_Op_Address     => RE_Get_Prim_Op_Address,
+       Get_RC_Offset           => RE_Get_RC_Offset,
+       Get_Remotely_Callable   => RE_Get_Remotely_Callable,
+       Get_TSD                 => RE_Get_TSD,
+       Inherit_DT              => RE_Inherit_DT,
+       Inherit_TSD             => RE_Inherit_TSD,
+       Register_Tag            => RE_Register_Tag,
+       Set_Expanded_Name       => RE_Set_Expanded_Name,
+       Set_External_Tag        => RE_Set_External_Tag,
+       Set_Prim_Op_Address     => RE_Set_Prim_Op_Address,
+       Set_RC_Offset           => RE_Set_RC_Offset,
+       Set_Remotely_Callable   => RE_Set_Remotely_Callable,
+       Set_TSD                 => RE_Set_TSD,
+       TSD_Entry_Size          => RE_TSD_Entry_Size,
+       TSD_Prologue_Size       => RE_TSD_Prologue_Size);
+
+   CPP_Actions : constant array (DT_Access_Action) of RE_Id :=
+      (CW_Membership           => RE_CPP_CW_Membership,
+       DT_Entry_Size           => RE_CPP_DT_Entry_Size,
+       DT_Prologue_Size        => RE_CPP_DT_Prologue_Size,
+       Get_Expanded_Name       => RE_CPP_Get_Expanded_Name,
+       Get_External_Tag        => RE_CPP_Get_External_Tag,
+       Get_Prim_Op_Address     => RE_CPP_Get_Prim_Op_Address,
+       Get_RC_Offset           => RE_CPP_Get_RC_Offset,
+       Get_Remotely_Callable   => RE_CPP_Get_Remotely_Callable,
+       Get_TSD                 => RE_CPP_Get_TSD,
+       Inherit_DT              => RE_CPP_Inherit_DT,
+       Inherit_TSD             => RE_CPP_Inherit_TSD,
+       Register_Tag            => RE_CPP_Register_Tag,
+       Set_Expanded_Name       => RE_CPP_Set_Expanded_Name,
+       Set_External_Tag        => RE_CPP_Set_External_Tag,
+       Set_Prim_Op_Address     => RE_CPP_Set_Prim_Op_Address,
+       Set_RC_Offset           => RE_CPP_Set_RC_Offset,
+       Set_Remotely_Callable   => RE_CPP_Set_Remotely_Callable,
+       Set_TSD                 => RE_CPP_Set_TSD,
+       TSD_Entry_Size          => RE_CPP_TSD_Entry_Size,
+       TSD_Prologue_Size       => RE_CPP_TSD_Prologue_Size);
+
+   Action_Is_Proc : constant array (DT_Access_Action) of Boolean :=
+      (CW_Membership           => False,
+       DT_Entry_Size           => False,
+       DT_Prologue_Size        => False,
+       Get_Expanded_Name       => False,
+       Get_External_Tag        => False,
+       Get_Prim_Op_Address     => False,
+       Get_Remotely_Callable   => False,
+       Get_RC_Offset           => False,
+       Get_TSD                 => False,
+       Inherit_DT              => True,
+       Inherit_TSD             => True,
+       Register_Tag            => True,
+       Set_Expanded_Name       => True,
+       Set_External_Tag        => True,
+       Set_Prim_Op_Address     => True,
+       Set_RC_Offset           => True,
+       Set_Remotely_Callable   => True,
+       Set_TSD                 => True,
+       TSD_Entry_Size          => False,
+       TSD_Prologue_Size       => False);
+
+   Action_Nb_Arg : constant array (DT_Access_Action) of Int :=
+      (CW_Membership           => 2,
+       DT_Entry_Size           => 0,
+       DT_Prologue_Size        => 0,
+       Get_Expanded_Name       => 1,
+       Get_External_Tag        => 1,
+       Get_Prim_Op_Address     => 2,
+       Get_RC_Offset           => 1,
+       Get_Remotely_Callable   => 1,
+       Get_TSD                 => 1,
+       Inherit_DT              => 3,
+       Inherit_TSD             => 2,
+       Register_Tag            => 1,
+       Set_Expanded_Name       => 2,
+       Set_External_Tag        => 2,
+       Set_Prim_Op_Address     => 3,
+       Set_RC_Offset           => 2,
+       Set_Remotely_Callable   => 2,
+       Set_TSD                 => 2,
+       TSD_Entry_Size          => 0,
+       TSD_Prologue_Size       => 0);
+
+   function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
+   --  Check if the type has a private view or if the public view appears
+   --  in the visible part of a package spec.
+
+   --------------------------
+   -- Expand_Dispatch_Call --
+   --------------------------
+
+   procedure Expand_Dispatch_Call (Call_Node : Node_Id) is
+      Loc      : constant Source_Ptr := Sloc (Call_Node);
+      Call_Typ : constant Entity_Id  := Etype (Call_Node);
+
+      Ctrl_Arg   : constant Node_Id := Controlling_Argument (Call_Node);
+      Param_List : constant List_Id := Parameter_Associations (Call_Node);
+      Subp       : Entity_Id        := Entity (Name (Call_Node));
+
+      CW_Typ        : Entity_Id;
+      New_Call      : Node_Id;
+      New_Call_Name : Node_Id;
+      New_Params    : List_Id := No_List;
+      Param         : Node_Id;
+      Res_Typ       : Entity_Id;
+      Subp_Ptr_Typ  : Entity_Id;
+      Subp_Typ      : Entity_Id;
+      Typ           : Entity_Id;
+      Eq_Prim_Op    : Entity_Id := Empty;
+
+      function New_Value (From : Node_Id) return Node_Id;
+      --  From is the original Expression. New_Value is equivalent to
+      --  Duplicate_Subexpr with an explicit dereference when From is an
+      --  access parameter
+
+      function New_Value (From : Node_Id) return Node_Id is
+         Res : constant Node_Id := Duplicate_Subexpr (From);
+
+      begin
+         if Is_Access_Type (Etype (From)) then
+            return Make_Explicit_Dereference (Sloc (From), Res);
+         else
+            return Res;
+         end if;
+      end New_Value;
+
+   --  Start of processing for Expand_Dispatch_Call
+
+   begin
+      --  If this is an inherited operation that was overriden, the body
+      --  that is being called is its alias.
+
+      if Present (Alias (Subp))
+        and then Is_Inherited_Operation (Subp)
+        and then No (DTC_Entity (Subp))
+      then
+         Subp := Alias (Subp);
+      end if;
+
+      --  Expand_Dispatch is called directly from the semantics, so we need
+      --  a check to see whether expansion is active before proceeding
+
+      if not Expander_Active then
+         return;
+      end if;
+
+      --  Definition of the ClassWide Type and the Tagged type
+
+      if Is_Access_Type (Etype (Ctrl_Arg)) then
+         CW_Typ := Designated_Type (Etype (Ctrl_Arg));
+      else
+         CW_Typ := Etype (Ctrl_Arg);
+      end if;
+
+      Typ := Root_Type (CW_Typ);
+
+      if not Is_Limited_Type (Typ) then
+         Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
+      end if;
+
+      if Is_CPP_Class (Root_Type (Typ)) then
+
+         --  Create a new parameter list with the displaced 'this'
+
+         New_Params := New_List;
+         Param := First_Actual (Call_Node);
+         while Present (Param) loop
+
+            --  We assume that dispatching through the main dispatch table
+            --  (referenced by Tag_Component) doesn't require a displacement
+            --  so the expansion below is only done when dispatching on
+            --  another vtable pointer, in which case the first argument
+            --  is expanded into :
+
+            --     typ!(Displaced_This (Address!(Param)))
+
+            if Param = Ctrl_Arg
+              and then DTC_Entity (Subp) /= Tag_Component (Typ)
+            then
+               Append_To (New_Params,
+
+                 Unchecked_Convert_To (Etype (Param),
+                   Make_Function_Call (Loc,
+                     Name => New_Reference_To (RTE (RE_Displaced_This), Loc),
+                     Parameter_Associations => New_List (
+
+                     --  Current_This
+
+                       Make_Unchecked_Type_Conversion (Loc,
+                         Subtype_Mark =>
+                           New_Reference_To (RTE (RE_Address), Loc),
+                         Expression   => Relocate_Node (Param)),
+
+                     --  Vptr
+
+                       Make_Selected_Component (Loc,
+                          Prefix => Duplicate_Subexpr (Ctrl_Arg),
+                          Selector_Name =>
+                            New_Reference_To (DTC_Entity (Subp), Loc)),
+
+                     --  Position
+
+                       Make_Integer_Literal (Loc, DT_Position (Subp))))));
+
+            else
+               Append_To (New_Params, Relocate_Node (Param));
+            end if;
+
+            Next_Actual (Param);
+         end loop;
+
+      elsif Present (Param_List) then
+
+         --  Generate the Tag checks when appropriate
+
+         New_Params := New_List;
+
+         Param := First_Actual (Call_Node);
+         while Present (Param) loop
+
+            --  No tag check with itself
+
+            if Param = Ctrl_Arg then
+               Append_To (New_Params, Duplicate_Subexpr (Param));
+
+            --  No tag check for parameter whose type is neither tagged nor
+            --  access to tagged (for access parameters)
+
+            elsif No (Find_Controlling_Arg (Param)) then
+               Append_To (New_Params, Relocate_Node (Param));
+
+            --  No tag check for function dispatching on result it the
+            --  Tag given by the context is this one
+
+            elsif Find_Controlling_Arg (Param) = Ctrl_Arg then
+               Append_To (New_Params, Relocate_Node (Param));
+
+            --  "=" is the only dispatching operation allowed to get
+            --  operands with incompatible tags (it just returns false).
+            --  We use Duplicate_subexpr instead of relocate_node because
+            --  the value will be duplicated to check the tags.
+
+            elsif Subp = Eq_Prim_Op then
+               Append_To (New_Params, Duplicate_Subexpr (Param));
+
+            --  No check in presence of suppress flags
+
+            elsif Tag_Checks_Suppressed (Etype (Param))
+              or else (Is_Access_Type (Etype (Param))
+                         and then Tag_Checks_Suppressed
+                                    (Designated_Type (Etype (Param))))
+            then
+               Append_To (New_Params, Relocate_Node (Param));
+
+            --  Optimization: no tag checks if the parameters are identical
+
+            elsif Is_Entity_Name (Param)
+              and then Is_Entity_Name (Ctrl_Arg)
+              and then Entity (Param) = Entity (Ctrl_Arg)
+            then
+               Append_To (New_Params, Relocate_Node (Param));
+
+            --  Now we need to generate the Tag check
+
+            else
+               --  Generate code for tag equality check
+               --  Perhaps should have Checks.Apply_Tag_Equality_Check???
+
+               Insert_Action (Ctrl_Arg,
+                 Make_Implicit_If_Statement (Call_Node,
+                   Condition =>
+                     Make_Op_Ne (Loc,
+                       Left_Opnd =>
+                         Make_Selected_Component (Loc,
+                           Prefix => New_Value (Ctrl_Arg),
+                           Selector_Name =>
+                             New_Reference_To (Tag_Component (Typ), Loc)),
+
+                       Right_Opnd =>
+                         Make_Selected_Component (Loc,
+                           Prefix =>
+                             Unchecked_Convert_To (Typ, New_Value (Param)),
+                           Selector_Name =>
+                             New_Reference_To (Tag_Component (Typ), Loc))),
+
+                   Then_Statements =>
+                     New_List (New_Constraint_Error (Loc))));
+
+               Append_To (New_Params, Relocate_Node (Param));
+            end if;
+
+            Next_Actual (Param);
+         end loop;
+      end if;
+
+      --  Generate the appropriate subprogram pointer type
+
+      if  Etype (Subp) = Typ then
+         Res_Typ := CW_Typ;
+      else
+         Res_Typ :=  Etype (Subp);
+      end if;
+
+      Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
+      Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
+      Set_Etype          (Subp_Typ, Res_Typ);
+      Init_Size_Align    (Subp_Ptr_Typ);
+      Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
+
+      --  Create a new list of parameters which is a copy of the old formal
+      --  list including the creation of a new set of matching entities.
+
+      declare
+         Old_Formal : Entity_Id := First_Formal (Subp);
+         New_Formal : Entity_Id;
+         Extra      : Entity_Id;
+
+      begin
+         if Present (Old_Formal) then
+            New_Formal := New_Copy (Old_Formal);
+            Set_First_Entity (Subp_Typ, New_Formal);
+            Param := First_Actual (Call_Node);
+
+            loop
+               Set_Scope (New_Formal, Subp_Typ);
+
+               --  Change all the controlling argument types to be class-wide
+               --  to avoid a recursion in dispatching
+
+               if Is_Controlling_Actual (Param) then
+                  Set_Etype (New_Formal, Etype (Param));
+               end if;
+
+               if Is_Itype (Etype (New_Formal)) then
+                  Extra := New_Copy (Etype (New_Formal));
+
+                  if Ekind (Extra) = E_Record_Subtype
+                    or else Ekind (Extra) = E_Class_Wide_Subtype
+                  then
+                     Set_Cloned_Subtype (Extra, Etype (New_Formal));
+                  end if;
+
+                  Set_Etype (New_Formal, Extra);
+                  Set_Scope (Etype (New_Formal), Subp_Typ);
+               end if;
+
+               Extra := New_Formal;
+               Next_Formal (Old_Formal);
+               exit when No (Old_Formal);
+
+               Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
+               Next_Entity (New_Formal);
+               Next_Actual (Param);
+            end loop;
+            Set_Last_Entity (Subp_Typ, Extra);
+
+            --  Copy extra formals
+
+            New_Formal := First_Entity (Subp_Typ);
+            while Present (New_Formal) loop
+               if Present (Extra_Constrained (New_Formal)) then
+                  Set_Extra_Formal (Extra,
+                    New_Copy (Extra_Constrained (New_Formal)));
+                  Extra := Extra_Formal (Extra);
+                  Set_Extra_Constrained (New_Formal, Extra);
+
+               elsif Present (Extra_Accessibility (New_Formal)) then
+                  Set_Extra_Formal (Extra,
+                    New_Copy (Extra_Accessibility (New_Formal)));
+                  Extra := Extra_Formal (Extra);
+                  Set_Extra_Accessibility (New_Formal, Extra);
+               end if;
+
+               Next_Formal (New_Formal);
+            end loop;
+         end if;
+      end;
+
+      Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
+      Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
+
+      --  Generate:
+      --   Subp_Ptr_Typ!(Get_Prim_Op_Address (Ctrl._Tag, pos));
+
+      New_Call_Name :=
+        Unchecked_Convert_To (Subp_Ptr_Typ,
+          Make_DT_Access_Action (Typ,
+            Action => Get_Prim_Op_Address,
+            Args => New_List (
+
+            --  Vptr
+
+              Make_Selected_Component (Loc,
+                Prefix => Duplicate_Subexpr (Ctrl_Arg),
+                Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc)),
+
+            --  Position
+
+              Make_Integer_Literal (Loc, DT_Position (Subp)))));
+
+      if Nkind (Call_Node) = N_Function_Call then
+         New_Call :=
+           Make_Function_Call (Loc,
+             Name => New_Call_Name,
+             Parameter_Associations => New_Params);
+
+         --  if this is a dispatching "=", we must first compare the tags so
+         --  we generate: x.tag = y.tag and then x = y
+
+         if Subp = Eq_Prim_Op then
+
+            Param := First_Actual (Call_Node);
+            New_Call :=
+              Make_And_Then (Loc,
+                Left_Opnd =>
+                     Make_Op_Eq (Loc,
+                       Left_Opnd =>
+                         Make_Selected_Component (Loc,
+                           Prefix => New_Value (Param),
+                           Selector_Name =>
+                             New_Reference_To (Tag_Component (Typ), Loc)),
+
+                       Right_Opnd =>
+                         Make_Selected_Component (Loc,
+                           Prefix =>
+                             Unchecked_Convert_To (Typ,
+                               New_Value (Next_Actual (Param))),
+                           Selector_Name =>
+                             New_Reference_To (Tag_Component (Typ), Loc))),
+
+                Right_Opnd => New_Call);
+         end if;
+
+      else
+         New_Call :=
+           Make_Procedure_Call_Statement (Loc,
+             Name => New_Call_Name,
+             Parameter_Associations => New_Params);
+      end if;
+
+      Rewrite (Call_Node, New_Call);
+      Analyze_And_Resolve (Call_Node, Call_Typ);
+   end Expand_Dispatch_Call;
+
+   -------------
+   -- Fill_DT --
+   -------------
+
+   function Fill_DT_Entry
+     (Loc  : Source_Ptr;
+      Prim : Entity_Id)
+      return Node_Id
+   is
+      Typ    : constant Entity_Id := Scope (DTC_Entity (Prim));
+      DT_Ptr : constant Entity_Id := Access_Disp_Table (Typ);
+
+   begin
+      return
+        Make_DT_Access_Action (Typ,
+          Action => Set_Prim_Op_Address,
+          Args   => New_List (
+            New_Reference_To (DT_Ptr, Loc),                     -- DTptr
+
+            Make_Integer_Literal (Loc, DT_Position (Prim)),     -- Position
+
+            Make_Attribute_Reference (Loc,                      -- Value
+              Prefix          => New_Reference_To (Prim, Loc),
+              Attribute_Name  => Name_Address)));
+   end Fill_DT_Entry;
+
+   ---------------------------
+   -- Get_Remotely_Callable --
+   ---------------------------
+
+   function Get_Remotely_Callable (Obj : Node_Id) return Node_Id is
+      Loc : constant Source_Ptr := Sloc (Obj);
+
+   begin
+      return Make_DT_Access_Action
+        (Typ    => Etype (Obj),
+         Action => Get_Remotely_Callable,
+         Args   => New_List (
+           Make_Selected_Component (Loc,
+             Prefix        => Obj,
+             Selector_Name => Make_Identifier (Loc, Name_uTag))));
+   end Get_Remotely_Callable;
+
+   -------------
+   -- Make_DT --
+   -------------
+
+   function Make_DT (Typ : Entity_Id) return List_Id is
+      Loc : constant Source_Ptr := Sloc (Typ);
+
+      Result    : constant List_Id := New_List;
+      Elab_Code : constant List_Id := New_List;
+
+      Tname       : constant Name_Id := Chars (Typ);
+      Name_DT     : constant Name_Id := New_External_Name (Tname, 'T');
+      Name_DT_Ptr : constant Name_Id := New_External_Name (Tname, 'P');
+      Name_TSD    : constant Name_Id := New_External_Name (Tname, 'B');
+      Name_Exname : constant Name_Id := New_External_Name (Tname, 'E');
+      Name_No_Reg : constant Name_Id := New_External_Name (Tname, 'F');
+
+      DT     : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT);
+      DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT_Ptr);
+      TSD    : constant Node_Id := Make_Defining_Identifier (Loc, Name_TSD);
+      Exname : constant Node_Id := Make_Defining_Identifier (Loc, Name_Exname);
+      No_Reg : constant Node_Id := Make_Defining_Identifier (Loc, Name_No_Reg);
+
+      I_Depth         : Int;
+      Generalized_Tag : Entity_Id;
+      Size_Expr_Node  : Node_Id;
+      Old_Tag         : Node_Id;
+      Old_TSD         : Node_Id;
+
+   begin
+      if Is_CPP_Class (Root_Type (Typ)) then
+         Generalized_Tag := RTE (RE_Vtable_Ptr);
+      else
+         Generalized_Tag := RTE (RE_Tag);
+      end if;
+
+      --  Dispatch table and related entities are allocated statically
+
+      Set_Ekind (DT, E_Variable);
+      Set_Is_Statically_Allocated (DT);
+
+      Set_Ekind (DT_Ptr, E_Variable);
+      Set_Is_Statically_Allocated (DT_Ptr);
+
+      Set_Ekind (TSD, E_Variable);
+      Set_Is_Statically_Allocated (TSD);
+
+      Set_Ekind (Exname, E_Variable);
+      Set_Is_Statically_Allocated (Exname);
+
+      Set_Ekind (No_Reg, E_Variable);
+      Set_Is_Statically_Allocated (No_Reg);
+
+      --  Generate code to create the storage for the Dispatch_Table object:
+
+      --   DT : Storage_Array (1..DT_Prologue_Size+nb_prim*DT_Entry_Size);
+      --   for DT'Alignment use Address'Alignment
+
+      Size_Expr_Node :=
+        Make_Op_Add (Loc,
+          Left_Opnd  => Make_DT_Access_Action (Typ, DT_Prologue_Size, No_List),
+          Right_Opnd =>
+            Make_Op_Multiply (Loc,
+              Left_Opnd  =>
+                Make_DT_Access_Action (Typ, DT_Entry_Size, No_List),
+              Right_Opnd =>
+                Make_Integer_Literal (Loc,
+                  DT_Entry_Count (Tag_Component (Typ)))));
+
+      Append_To (Result,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => DT,
+          Aliased_Present     => True,
+          Object_Definition   =>
+            Make_Subtype_Indication (Loc,
+              Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
+              Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
+                Constraints => New_List (
+                  Make_Range (Loc,
+                    Low_Bound  => Make_Integer_Literal (Loc, 1),
+                    High_Bound => Size_Expr_Node))))));
+
+      Append_To (Result,
+        Make_Attribute_Definition_Clause (Loc,
+          Name       => New_Reference_To (DT, Loc),
+          Chars      => Name_Alignment,
+          Expression =>
+            Make_Attribute_Reference (Loc,
+              Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
+              Attribute_Name => Name_Alignment)));
+
+      --  Generate code to create the pointer to the dispatch table
+
+      --    DT_Ptr : Tag := Tag!(DT'Address);                 Ada case
+      --  or
+      --    DT_Ptr : Vtable_Ptr := Vtable_Ptr!(DT'Address);   CPP case
+
+      Append_To (Result,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => DT_Ptr,
+          Constant_Present    => True,
+          Object_Definition   => New_Reference_To (Generalized_Tag, Loc),
+          Expression          =>
+            Unchecked_Convert_To (Generalized_Tag,
+              Make_Attribute_Reference (Loc,
+                Prefix         => New_Reference_To (DT, Loc),
+                Attribute_Name => Name_Address))));
+
+      --  Generate code to define the boolean that controls registration, in
+      --  order to avoid multiple registrations for tagged types defined in
+      --  multiple-called scopes
+
+      Append_To (Result,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => No_Reg,
+          Object_Definition   => New_Reference_To (Standard_Boolean, Loc),
+          Expression          => New_Reference_To (Standard_True, Loc)));
+
+      --  Set Access_Disp_Table field to be the dispatch table pointer
+
+      Set_Access_Disp_Table (Typ, DT_Ptr);
+
+      --  Count ancestors to compute the inheritance depth. For private
+      --  extensions, always go to the full view in order to compute the real
+      --  inheritance depth.
+
+      declare
+         Parent_Type : Entity_Id := Typ;
+         P           : Entity_Id;
+
+      begin
+         I_Depth := 0;
+
+         loop
+            P := Etype (Parent_Type);
+
+            if Is_Private_Type (P) then
+               P := Full_View (Base_Type (P));
+            end if;
+
+            exit when P = Parent_Type;
+
+            I_Depth := I_Depth + 1;
+            Parent_Type := P;
+         end loop;
+      end;
+
+      --  Generate code to create the storage for the type specific data object
+
+      --   TSD: Storage_Array (1..TSD_Prologue_Size+(1+Idepth)*TSD_Entry_Size);
+      --   for TSD'Alignment use Address'Alignment
+
+      Size_Expr_Node :=
+        Make_Op_Add (Loc,
+          Left_Opnd  =>
+            Make_DT_Access_Action (Typ, TSD_Prologue_Size, No_List),
+          Right_Opnd =>
+            Make_Op_Multiply (Loc,
+              Left_Opnd  =>
+                Make_DT_Access_Action (Typ, TSD_Entry_Size, No_List),
+              Right_Opnd =>
+                Make_Op_Add (Loc,
+                  Left_Opnd  => Make_Integer_Literal (Loc, 1),
+                  Right_Opnd =>
+                    Make_Integer_Literal (Loc, I_Depth))));
+
+      Append_To (Result,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => TSD,
+          Aliased_Present     => True,
+          Object_Definition   =>
+            Make_Subtype_Indication (Loc,
+              Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
+              Constraint   => Make_Index_Or_Discriminant_Constraint (Loc,
+                Constraints => New_List (
+                  Make_Range (Loc,
+                    Low_Bound  => Make_Integer_Literal (Loc, 1),
+                    High_Bound => Size_Expr_Node))))));
+
+      Append_To (Result,
+        Make_Attribute_Definition_Clause (Loc,
+          Name       => New_Reference_To (TSD, Loc),
+          Chars      => Name_Alignment,
+          Expression =>
+            Make_Attribute_Reference (Loc,
+              Prefix => New_Reference_To (RTE (RE_Integer_Address), Loc),
+              Attribute_Name => Name_Alignment)));
+
+      --  Generate code to put the Address of the TSD in the dispatch table
+      --    Set_TSD (DT_Ptr, TSD);
+
+      Append_To (Elab_Code,
+        Make_DT_Access_Action (Typ,
+          Action => Set_TSD,
+          Args   => New_List (
+            New_Reference_To (DT_Ptr, Loc),                  -- DTptr
+              Make_Attribute_Reference (Loc,                 -- Value
+              Prefix          => New_Reference_To (TSD, Loc),
+              Attribute_Name  => Name_Address))));
+
+      if Typ = Etype (Typ)
+        or else Is_CPP_Class (Etype (Typ))
+      then
+         Old_Tag :=
+           Unchecked_Convert_To (Generalized_Tag,
+             Make_Integer_Literal (Loc, 0));
+
+         Old_TSD :=
+           Unchecked_Convert_To (RTE (RE_Address),
+             Make_Integer_Literal (Loc, 0));
+
+      else
+         Old_Tag := New_Reference_To (Access_Disp_Table (Etype (Typ)), Loc);
+         Old_TSD :=
+           Make_DT_Access_Action (Typ,
+             Action => Get_TSD,
+             Args   => New_List (
+               New_Reference_To (Access_Disp_Table (Etype (Typ)), Loc)));
+      end if;
+
+      --  Generate: Inherit_DT (parent'tag, DT_Ptr, nb_prim of parent);
+
+      Append_To (Elab_Code,
+        Make_DT_Access_Action (Typ,
+          Action => Inherit_DT,
+          Args   => New_List (
+            Node1 => Old_Tag,
+            Node2 => New_Reference_To (DT_Ptr, Loc),
+            Node3 => Make_Integer_Literal (Loc,
+                       DT_Entry_Count (Tag_Component (Etype (Typ)))))));
+
+      --  Generate: Inherit_TSD (Get_TSD (parent), DT_Ptr);
+
+      Append_To (Elab_Code,
+        Make_DT_Access_Action (Typ,
+          Action => Inherit_TSD,
+          Args   => New_List (
+            Node1 => Old_TSD,
+            Node2 => New_Reference_To (DT_Ptr, Loc))));
+
+      --  Generate: Exname : constant String := full_qualified_name (typ);
+      --  The type itself may be an anonymous parent type, so use the first
+      --  subtype to have a user-recognizable name.
+
+      Append_To (Result,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => Exname,
+          Constant_Present    => True,
+          Object_Definition   => New_Reference_To (Standard_String, Loc),
+          Expression =>
+            Make_String_Literal (Loc,
+              Full_Qualified_Name (First_Subtype (Typ)))));
+
+      --  Generate: Set_Expanded_Name (DT_Ptr, exname'Address);
+
+      Append_To (Elab_Code,
+        Make_DT_Access_Action (Typ,
+          Action => Set_Expanded_Name,
+          Args   => New_List (
+            Node1 => New_Reference_To (DT_Ptr, Loc),
+            Node2 =>
+              Make_Attribute_Reference (Loc,
+                Prefix => New_Reference_To (Exname, Loc),
+                Attribute_Name => Name_Address))));
+
+      --  for types with no controlled components
+      --    Generate: Set_RC_Offset (DT_Ptr, 0);
+      --  for simple types with controlled components
+      --    Generate: Set_RC_Offset (DT_Ptr, type._record_controller'position);
+      --  for complex types with controlled components where the position
+      --  of the record controller
+      --    Generate: Set_RC_Offset (DT_Ptr, -1);
+
+      declare
+         Position : Node_Id;
+
+      begin
+         if not Has_Controlled_Component (Typ) then
+            Position := Make_Integer_Literal (Loc, 0);
+
+         elsif Etype (Typ) /= Typ and then Has_Discriminants (Etype (Typ)) then
+            Position := Make_Integer_Literal (Loc, -1);
+
+         else
+            Position :=
+              Make_Attribute_Reference (Loc,
+                Prefix =>
+                  Make_Selected_Component (Loc,
+                    Prefix => New_Reference_To (Typ, Loc),
+                    Selector_Name =>
+                      New_Reference_To (Controller_Component (Typ), Loc)),
+                Attribute_Name => Name_Position);
+
+            --  This is not proper Ada code to use the attribute component
+            --  on something else than an object but this is supported by
+            --  the back end (see comment on the Bit_Component attribute in
+            --  sem_attr). So we avoid semantic checking here.
+
+            Set_Analyzed (Position);
+            Set_Etype (Prefix (Position), RTE (RE_Record_Controller));
+            Set_Etype (Prefix (Prefix (Position)), Typ);
+            Set_Etype (Selector_Name (Prefix (Position)),
+              RTE (RE_Record_Controller));
+            Set_Etype (Position, RTE (RE_Storage_Offset));
+
+         end if;
+
+         Append_To (Elab_Code,
+           Make_DT_Access_Action (Typ,
+             Action => Set_RC_Offset,
+             Args   => New_List (
+               Node1 => New_Reference_To (DT_Ptr, Loc),
+               Node2 => Position)));
+      end;
+
+      --  Generate: Set_Remotely_Callable (DT_Ptr, status);
+      --  where status is described in E.4 (18)
+
+      declare
+         Status : Entity_Id;
+
+      begin
+         if Is_Pure (Typ)
+           or else Is_Shared_Passive (Typ)
+           or else
+             ((Is_Remote_Types (Typ) or else Is_Remote_Call_Interface (Typ))
+                 and then Original_View_In_Visible_Part (Typ))
+           or else not Comes_From_Source (Typ)
+         then
+            Status := Standard_True;
+         else
+            Status := Standard_False;
+         end if;
+
+         Append_To (Elab_Code,
+           Make_DT_Access_Action (Typ,
+             Action => Set_Remotely_Callable,
+             Args   => New_List (
+               New_Occurrence_Of (DT_Ptr, Loc),
+               New_Occurrence_Of (Status, Loc))));
+      end;
+
+      --  Generate: Set_External_Tag (DT_Ptr, exname'Address);
+      --  Should be the external name not the qualified name???
+
+      if not Has_External_Tag_Rep_Clause (Typ) then
+         Append_To (Elab_Code,
+           Make_DT_Access_Action (Typ,
+             Action => Set_External_Tag,
+             Args   => New_List (
+               Node1 => New_Reference_To (DT_Ptr, Loc),
+               Node2 =>
+                 Make_Attribute_Reference (Loc,
+                   Prefix => New_Reference_To (Exname, Loc),
+                   Attribute_Name => Name_Address))));
+
+      --  Generate code to register the Tag in the External_Tag hash
+      --  table for the pure Ada type only. We skip this in No_Run_Time
+      --  mode where the External_Tag attribute is not allowed anyway.
+
+      --        Register_Tag (Dt_Ptr);
+
+         if Is_RTE (Generalized_Tag, RE_Tag)
+           and then not No_Run_Time
+         then
+            Append_To (Elab_Code,
+              Make_Procedure_Call_Statement (Loc,
+                Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
+                Parameter_Associations =>
+                  New_List (New_Reference_To (DT_Ptr, Loc))));
+         end if;
+      end if;
+
+      --  Generate:
+      --     if No_Reg then
+      --        <elab_code>
+      --        No_Reg := False;
+      --     end if;
+
+      Append_To (Elab_Code,
+        Make_Assignment_Statement (Loc,
+          Name       => New_Reference_To (No_Reg, Loc),
+          Expression => New_Reference_To (Standard_False, Loc)));
+
+      Append_To (Result,
+        Make_Implicit_If_Statement (Typ,
+          Condition       => New_Reference_To (No_Reg, Loc),
+          Then_Statements => Elab_Code));
+
+      return Result;
+   end Make_DT;
+
+   ---------------------------
+   -- Make_DT_Access_Action --
+   ---------------------------
+
+   function Make_DT_Access_Action
+     (Typ    : Entity_Id;
+      Action : DT_Access_Action;
+      Args   : List_Id)
+      return Node_Id
+   is
+      Action_Name : Entity_Id;
+      Loc         : Source_Ptr;
+
+   begin
+      if Is_CPP_Class (Root_Type (Typ)) then
+         Action_Name := RTE (CPP_Actions (Action));
+      else
+         Action_Name := RTE (Ada_Actions (Action));
+      end if;
+
+      if No (Args) then
+
+         --  This is a constant
+
+         return New_Reference_To (Action_Name, Sloc (Typ));
+      end if;
+
+      pragma Assert (List_Length (Args) = Action_Nb_Arg (Action));
+
+      Loc := Sloc (First (Args));
+
+      if Action_Is_Proc (Action) then
+         return
+           Make_Procedure_Call_Statement (Loc,
+             Name => New_Reference_To (Action_Name, Loc),
+             Parameter_Associations => Args);
+
+      else
+         return
+           Make_Function_Call (Loc,
+             Name => New_Reference_To (Action_Name, Loc),
+             Parameter_Associations => Args);
+      end if;
+   end Make_DT_Access_Action;
+
+   -----------------------------------
+   -- Original_View_In_Visible_Part --
+   -----------------------------------
+
+   function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
+      Scop : constant Entity_Id := Scope (Typ);
+
+   begin
+      --  The scope must be a package
+
+      if Ekind (Scop) /= E_Package
+        and then Ekind (Scop) /= E_Generic_Package
+      then
+         return False;
+      end if;
+
+      --  A type with a private declaration has a private view declared in
+      --  the visible part.
+
+      if Has_Private_Declaration (Typ) then
+         return True;
+      end if;
+
+      return List_Containing (Parent (Typ)) =
+        Visible_Declarations (Specification (Unit_Declaration_Node (Scop)));
+   end Original_View_In_Visible_Part;
+
+   -------------------------
+   -- Set_All_DT_Position --
+   -------------------------
+
+   procedure Set_All_DT_Position (Typ : Entity_Id) is
+      Parent_Typ : constant Entity_Id := Etype (Typ);
+      Root_Typ   : constant Entity_Id := Root_Type (Typ);
+      First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
+      The_Tag    : constant Entity_Id := Tag_Component (Typ);
+      Adjusted   : Boolean := False;
+      Finalized  : Boolean := False;
+      Parent_EC  : Int;
+      Nb_Prim    : Int;
+      Prim       : Entity_Id;
+      Prim_Elmt  : Elmt_Id;
+
+   begin
+
+      --  Get Entry_Count of the parent
+
+      if Parent_Typ /= Typ
+        and then DT_Entry_Count (Tag_Component (Parent_Typ)) /= No_Uint
+      then
+         Parent_EC := UI_To_Int (DT_Entry_Count (Tag_Component (Parent_Typ)));
+      else
+         Parent_EC := 0;
+      end if;
+
+      --  C++ Case, check that pragma CPP_Class, CPP_Virtual and CPP_Vtable
+      --  give a coherent set of information
+
+      if Is_CPP_Class (Root_Typ) then
+
+         --  Compute the number of primitive operations in the main Vtable
+         --  Set their position:
+         --    - where it was set if overriden or inherited
+         --    - after the end of the parent vtable otherwise
+
+         Prim_Elmt := First_Prim;
+         Nb_Prim := 0;
+         while Present (Prim_Elmt) loop
+            Prim := Node (Prim_Elmt);
+
+            if not Is_CPP_Class (Typ) then
+               Set_DTC_Entity (Prim, The_Tag);
+
+            elsif Present (Alias (Prim)) then
+               Set_DTC_Entity (Prim, DTC_Entity (Alias (Prim)));
+               Set_DT_Position (Prim, DT_Position (Alias (Prim)));
+
+            elsif No (DTC_Entity (Prim)) and then Is_CPP_Class (Typ) then
+                  Error_Msg_NE ("is a primitive operation of&," &
+                    " pragma Cpp_Virtual required", Prim, Typ);
+            end if;
+
+            if DTC_Entity (Prim) = The_Tag then
+
+               --  Get the slot from the parent subprogram if any
+
+               declare
+                  H : Entity_Id := Homonym (Prim);
+
+               begin
+                  while Present (H) loop
+                     if Present (DTC_Entity (H))
+                       and then Root_Type (Scope (DTC_Entity (H))) = Root_Typ
+                     then
+                        Set_DT_Position (Prim, DT_Position (H));
+                        exit;
+                     end if;
+
+                     H := Homonym (H);
+                  end loop;
+               end;
+
+               --  Otherwise take the canonical slot after the end of the
+               --  parent Vtable
+
+               if DT_Position (Prim) = No_Uint then
+                  Nb_Prim := Nb_Prim + 1;
+                  Set_DT_Position (Prim, UI_From_Int (Parent_EC + Nb_Prim));
+
+               elsif UI_To_Int (DT_Position (Prim)) > Parent_EC then
+                  Nb_Prim := Nb_Prim + 1;
+               end if;
+            end if;
+
+            Next_Elmt (Prim_Elmt);
+         end loop;
+
+         --  Check that the declared size of the Vtable is bigger or equal
+         --  than the number of primitive operations (if bigger it means that
+         --  some of the c++ virtual functions were not imported, that is
+         --  allowed)
+
+         if DT_Entry_Count (The_Tag) = No_Uint
+           or else not Is_CPP_Class (Typ)
+         then
+            Set_DT_Entry_Count (The_Tag, UI_From_Int (Parent_EC + Nb_Prim));
+
+         elsif UI_To_Int (DT_Entry_Count (The_Tag)) < Parent_EC + Nb_Prim then
+            Error_Msg_N ("not enough room in the Vtable for all virtual"
+              & " functions", The_Tag);
+         end if;
+
+         --  Check that Positions are not duplicate nor outside the range of
+         --  the Vtable
+
+         declare
+            Size : constant Int := UI_To_Int (DT_Entry_Count (The_Tag));
+            Pos  : Int;
+            Prim_Pos_Table : array (1 .. Size) of Entity_Id :=
+                                                        (others => Empty);
+
+         begin
+            Prim_Elmt := First_Prim;
+            while Present (Prim_Elmt) loop
+               Prim := Node (Prim_Elmt);
+
+               if DTC_Entity (Prim) = The_Tag then
+                  Pos := UI_To_Int (DT_Position (Prim));
+
+                  if Pos not in Prim_Pos_Table'Range then
+                     Error_Msg_N
+                       ("position not in range of virtual table", Prim);
+
+                  elsif Present (Prim_Pos_Table (Pos)) then
+                     Error_Msg_NE ("cannot be at the same position in the"
+                       & " vtable than&", Prim, Prim_Pos_Table (Pos));
+
+                  else
+                     Prim_Pos_Table (Pos) := Prim;
+                  end if;
+               end if;
+
+               Next_Elmt (Prim_Elmt);
+            end loop;
+         end;
+
+      --  For regular Ada tagged types, just set the DT_Position for
+      --  each primitive operation. Perform some sanity checks to avoid
+      --  to build completely inconsistant dispatch tables.
+
+      else
+
+         Nb_Prim := 0;
+         Prim_Elmt := First_Prim;
+         while Present (Prim_Elmt) loop
+            Nb_Prim := Nb_Prim + 1;
+            Prim := Node (Prim_Elmt);
+            Set_DTC_Entity (Prim, The_Tag);
+            Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
+
+            if Chars (Prim) = Name_Finalize
+              and then (Is_Predefined_File_Name
+                          (Unit_File_Name (Current_Sem_Unit))
+                         or else
+                        not Is_Predefined_File_Name
+                          (Unit_File_Name (Get_Source_Unit (Prim))))
+            then
+               Finalized := True;
+            end if;
+
+            if Chars (Prim) = Name_Adjust then
+               Adjusted := True;
+            end if;
+
+            --  An abstract operation cannot be declared in the private part
+            --  for a visible abstract type, because it could never be over-
+            --  ridden. For explicit declarations this is checked at the point
+            --  of declaration, but for inherited operations it must be done
+            --  when building the dispatch table. Input is excluded because
+            --  Limited_Controlled inherits a useless Input stream operation
+            --  from Root_Controlled, which cannot be overridden.
+
+            if Is_Abstract (Typ)
+              and then Is_Abstract (Prim)
+              and then Present (Alias (Prim))
+              and then Is_Derived_Type (Typ)
+              and then In_Private_Part (Current_Scope)
+              and then List_Containing (Parent (Prim))
+               =  Private_Declarations
+                   (Specification (Unit_Declaration_Node (Current_Scope)))
+              and then Original_View_In_Visible_Part (Typ)
+              and then Chars (Prim) /= Name_uInput
+            then
+               Error_Msg_NE ("abstract inherited private operation&"
+                  & " must be overriden", Parent (Typ), Prim);
+            end if;
+            Next_Elmt (Prim_Elmt);
+         end loop;
+
+         if Is_Controlled (Typ) then
+            if not Finalized then
+               Error_Msg_N
+                 ("controlled type has no explicit Finalize method?", Typ);
+
+            elsif not Adjusted then
+               Error_Msg_N
+                 ("controlled type has no explicit Adjust method?", Typ);
+            end if;
+         end if;
+
+         Set_DT_Entry_Count (The_Tag, UI_From_Int (Nb_Prim));
+
+         --  The derived type must have at least as many components than
+         --  its parent (for root types, the etype points back to itself
+         --  and the test should not fail)
+
+         pragma Assert (
+           DT_Entry_Count (The_Tag) >=
+           DT_Entry_Count (Tag_Component (Parent_Typ)));
+      end if;
+   end Set_All_DT_Position;
+
+   -----------------------------
+   -- Set_Default_Constructor --
+   -----------------------------
+
+   procedure Set_Default_Constructor (Typ : Entity_Id) is
+      Loc   : Source_Ptr;
+      Init  : Entity_Id;
+      Param : Entity_Id;
+      Decl  : Node_Id;
+      E     : Entity_Id;
+
+   begin
+      --  Look for the default constructor entity. For now only the
+      --  default constructor has the flag Is_Constructor.
+
+      E := Next_Entity (Typ);
+      while Present (E)
+        and then (Ekind (E) /= E_Function or else not Is_Constructor (E))
+      loop
+         Next_Entity (E);
+      end loop;
+
+      --  Create the init procedure
+
+      if Present (E) then
+         Loc   := Sloc (E);
+         Init  := Make_Defining_Identifier (Loc, Name_uInit_Proc);
+         Param := Make_Defining_Identifier (Loc, Name_X);
+         Decl  :=
+           Make_Subprogram_Declaration (Loc,
+             Make_Procedure_Specification (Loc,
+               Defining_Unit_Name => Init,
+               Parameter_Specifications => New_List (
+                 Make_Parameter_Specification (Loc,
+                   Defining_Identifier => Param,
+                   Parameter_Type      => New_Reference_To (Typ, Loc)))));
+
+         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);
+
+      --  if there are no constructors, mark the type as abstract since we
+      --  won't be able to declare objects of that type.
+
+      else
+         Set_Is_Abstract (Typ);
+      end if;
+   end Set_Default_Constructor;
+
+end Exp_Disp;