2007-08-14 Thomas Quinot <quinot@adacore.com>

	    Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* exp_ch3.ads, exp_ch3.adb (Add_Final_Chain): New subprogram.
	(Freeze_Array_Type, Freeze_Record_Type): For the case of a component
	type that is an anonymous access to controlled object, establish
	an associated finalization chain to avoid corrupting the global
	finalization list when a dynamically allocated object designated
	by such a component is deallocated.
	(Make_Controlling_Function_Wrappers): Create wrappers for constructor
	functions that need it, even when not marked Requires_Overriding.
	(Initialize_Tag): Replace call to has_discriminants by call to
	Is_Variable_Size_Record in the circuitry that handles the
	initialization of secondary tags.
	(Is_Variable_Size_Record): New implementation.
	(Expand_N_Object_Declaration): Suppress call to init proc if there is a
	Suppress_Initialization pragma for a derived type.
	(Is_Variable_Size_Record): New subprogram.
	(Build_Offset_To_Top_Functions): New implementation that simplifies the
	initial version of this routine and also fixes problems causing
	incomplete initialization of the table of interfaces.
	(Build_Init_Procedure): Improve the generation of code to initialize the
	the tag components of secondary dispatch tables.
	(Init_Secondary_Tags): New implementation that simplifies the previous
	version of this routine.
	(Make_DT): Add parameter to indicate when type has been frozen by an
	object declaration, for diagnostic purposes.
	(Check_Premature_Freezing): New subsidiary procedure of Make_DT, to
	diagnose attemps to freeze a subprogram when some untagged type of its
	profile is a private type whose full view has not been analyzed yet.
	(Freeze_Array_Type): Generate init proc for packed array if either
	Initialize or Normalize_Scalars is set.
	(Make_Controlling_Function_Wrappers, Make_Null_Procedure_Specs): when
	constructing the new profile, copy the null_exclusion indicator for each
	parameter, to ensure full conformance of the new body with the spec.

	* sem_type.ads, sem_type.adb (Make_Controlling_Function_Wrappers):
	Create wrappers for constructor functions that need it, even when not
	marked Requires_Overriding.
	(Covers): Handle properly designated types of anonymous access types,
	whose non-limited views are themselves incomplete types.
	(Add_Entry): Use an entity to store the abstract operation which hides
	an interpretation.
	(Binary_Op_May_Be_Hidden): Rename to Binary_Op_Interp_Has_Abstract_Op.
	(Collect_Interps): Use Empty as an actual for Abstract_Op in the
	initialization aggregate.
	(Function_Interp_May_Be_Hidden): Rename to
	Function_Interp_Has_Abstract_Op.
	(Has_Compatible_Type): Remove machinery that skips interpretations if
	they are labeled as potentially hidden by an abstract operator.
	(Has_Hidden_Interp): Rename to Has_Abstract_Op.
	(Set_May_Be_Hidden): Rename to Set_Abstract_Op.
	(Write_Overloads): Output the abstract operator if present.
	(Add_Entry): Before inserting a new entry into the interpretation table
	for a node, determine whether the entry will be disabled by an abstract
	operator.
	(Binary_Op_Interp_May_Be_Hidden): New routine.
	(Collect_Interps): Add value for flag May_Be_Hidden in initialization
	aggregate.
	(Function_Interp_May_Be_Hidden): New routine.
	(Has_Compatible_Type): Do not consider interpretations hidden by
	abstract operators when trying to determine whether two types are
	compatible.
	(Has_Hidden_Interp): New routine.
	(Set_May_Be_Hidden_Interp): New routine.
	(Write_Overloads): Write the status of flag May_Be_Hidden.



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

1 files changed, 605 insertions, 472 deletions

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 9f2a60b7375..a178833afdf 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -73,6 +73,10 @@ package body Exp_Ch3 is
    -- Local Subprograms --
    -----------------------
 
+   function Add_Final_Chain (Def_Id : Entity_Id) return Entity_Id;
+   --  Add the declaration of a finalization list to the freeze actions for
+   --  Def_Id, and return its defining identifier.
+
    procedure Adjust_Discriminants (Rtype : Entity_Id);
    --  This is used when freezing a record type. It attempts to construct
    --  more restrictive subtypes for discriminants so that the max size of
@@ -103,7 +107,7 @@ package body Exp_Ch3 is
    function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id;
    --  This function builds a static aggregate that can serve as the initial
    --  value for a record type whose components are scalar and initialized
-   --  with compile-time values, or arrays with similarc initialization or
+   --  with compile-time values, or arrays with similar initialization or
    --  defaults. When possible, initialization of an object of the type can
    --  be achieved by using a copy of the aggregate as an initial value, thus
    --  removing the implicit call that would otherwise constitute elaboration
@@ -206,6 +210,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_Record (E : Entity_Id) return Boolean;
+   --  Returns true if E has variable size components
+
    function Make_Eq_Case
      (E     : Entity_Id;
       CL    : Node_Id;
@@ -341,6 +348,28 @@ package body Exp_Ch3 is
    --  the generation of these operations, as a useful optimization or for
    --  certification purposes.
 
+   ---------------------
+   -- Add_Final_Chain --
+   ---------------------
+
+   function Add_Final_Chain (Def_Id : Entity_Id) return Entity_Id is
+      Loc   : constant Source_Ptr := Sloc (Def_Id);
+      Flist : Entity_Id;
+
+   begin
+      Flist :=
+        Make_Defining_Identifier (Loc,
+          New_External_Name (Chars (Def_Id), 'L'));
+
+      Append_Freeze_Action (Def_Id,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => Flist,
+          Object_Definition   =>
+            New_Reference_To (RTE (RE_List_Controller), Loc)));
+
+      return Flist;
+   end Add_Final_Chain;
+
    --------------------------
    -- Adjust_Discriminants --
    --------------------------
@@ -874,7 +903,7 @@ package body Exp_Ch3 is
                end loop;
 
                Return_Node :=
-                 Make_Return_Statement (Loc,
+                 Make_Simple_Return_Statement (Loc,
                    Expression =>
                      Make_Function_Call (Loc,
                        Name =>
@@ -884,7 +913,7 @@ package body Exp_Ch3 is
 
             else
                Return_Node :=
-                 Make_Return_Statement (Loc,
+                 Make_Simple_Return_Statement (Loc,
                    Expression =>
                      New_Reference_To (Standard_False, Loc));
             end if;
@@ -898,7 +927,7 @@ package body Exp_Ch3 is
          Set_Discrete_Choices (Case_Alt_Node, Choice_List);
 
          Return_Node :=
-           Make_Return_Statement (Loc,
+           Make_Simple_Return_Statement (Loc,
              Expression =>
                New_Reference_To (Standard_True, Loc));
 
@@ -1762,7 +1791,7 @@ package body Exp_Ch3 is
          if Ada_Version >= Ada_05
            and then Can_Never_Be_Null (Etype (Id))            -- Lhs
          then
-            if Nkind (Exp) = N_Null then
+            if Known_Null (Exp) then
                return New_List (
                  Make_Raise_Constraint_Error (Sloc (Exp),
                    Reason => CE_Null_Not_Allowed));
@@ -1996,136 +2025,120 @@ package body Exp_Ch3 is
       -----------------------------------
 
       procedure Build_Offset_To_Top_Functions is
-         ADT       : Elmt_Id;
-         Body_Node : Node_Id;
-         Func_Id   : Entity_Id;
-         Spec_Node : Node_Id;
-         E         : Entity_Id;
 
-         procedure Build_Offset_To_Top_Internal (Typ : Entity_Id);
-         --  Internal subprogram used to recursively traverse all the ancestors
+         procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id);
+         --  Generate:
+         --    function Fxx (O : in Rec_Typ) return Storage_Offset is
+         --    begin
+         --       return O.Iface_Comp'Position;
+         --    end Fxx;
 
-         ----------------------------------
-         -- Build_Offset_To_Top_Internal --
-         ----------------------------------
+         ------------------------------
+         -- Build_Offset_To_Top_Body --
+         ------------------------------
+
+         procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is
+            Body_Node : Node_Id;
+            Func_Id   : Entity_Id;
+            Spec_Node : Node_Id;
 
-         procedure Build_Offset_To_Top_Internal (Typ : Entity_Id) is
          begin
-            --  Climb to the ancestor (if any) handling synchronized interface
-            --  derivations and private types
+            Func_Id :=
+              Make_Defining_Identifier (Loc,
+                Chars => New_Internal_Name ('F'));
 
-            if Is_Concurrent_Record_Type (Typ) then
-               declare
-                  Iface_List : constant List_Id :=
-                                 Abstract_Interface_List (Typ);
-               begin
-                  if Is_Non_Empty_List (Iface_List) then
-                     Build_Offset_To_Top_Internal (Etype (First (Iface_List)));
-                  end if;
-               end;
+            Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id);
 
-            elsif Present (Full_View (Etype (Typ))) then
-               if Full_View (Etype (Typ)) /= Typ then
-                  Build_Offset_To_Top_Internal (Full_View (Etype (Typ)));
-               end if;
+            --  Generate
+            --    function Fxx (O : in Rec_Typ) return Storage_Offset;
 
-            elsif Etype (Typ) /= Typ then
-               Build_Offset_To_Top_Internal (Etype (Typ));
+            Spec_Node := New_Node (N_Function_Specification, Loc);
+            Set_Defining_Unit_Name (Spec_Node, Func_Id);
+            Set_Parameter_Specifications (Spec_Node, New_List (
+              Make_Parameter_Specification (Loc,
+                Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
+                In_Present          => True,
+                Parameter_Type      => New_Reference_To (Rec_Type, Loc))));
+            Set_Result_Definition (Spec_Node,
+              New_Reference_To (RTE (RE_Storage_Offset), Loc));
+
+            --  Generate
+            --    function Fxx (O : in Rec_Typ) return Storage_Offset is
+            --    begin
+            --       return O.Iface_Comp'Position;
+            --    end Fxx;
+
+            Body_Node := New_Node (N_Subprogram_Body, Loc);
+            Set_Specification (Body_Node, Spec_Node);
+            Set_Declarations (Body_Node, New_List);
+            Set_Handled_Statement_Sequence (Body_Node,
+              Make_Handled_Sequence_Of_Statements (Loc,
+                Statements => New_List (
+                  Make_Simple_Return_Statement (Loc,
+                    Expression =>
+                      Make_Attribute_Reference (Loc,
+                        Prefix =>
+                          Make_Selected_Component (Loc,
+                            Prefix => Make_Identifier (Loc, Name_uO),
+                            Selector_Name => New_Reference_To
+                                               (Iface_Comp, Loc)),
+                        Attribute_Name => Name_Position)))));
+
+            Set_Ekind       (Func_Id, E_Function);
+            Set_Mechanism   (Func_Id, Default_Mechanism);
+            Set_Is_Internal (Func_Id, True);
+
+            if not Debug_Generated_Code then
+               Set_Debug_Info_Off (Func_Id);
             end if;
 
-            if Present (Abstract_Interfaces (Typ))
-              and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
-            then
-               E := First_Entity (Typ);
-               while Present (E) loop
-                  if Is_Tag (E)
-                    and then Chars (E) /= Name_uTag
-                  then
-                     if Typ = Rec_Type then
-                        Body_Node := New_Node (N_Subprogram_Body, Loc);
-
-                        Func_Id :=
-                          Make_Defining_Identifier (Loc,
-                            Chars => New_Internal_Name ('F'));
-
-                        Set_DT_Offset_To_Top_Func (E, Func_Id);
-
-                        Spec_Node := New_Node (N_Function_Specification, Loc);
-                        Set_Defining_Unit_Name (Spec_Node, Func_Id);
-                        Set_Parameter_Specifications (Spec_Node, New_List (
-                           Make_Parameter_Specification (Loc,
-                             Defining_Identifier =>
-                               Make_Defining_Identifier (Loc, Name_uO),
-                             In_Present => True,
-                             Parameter_Type => New_Reference_To (Typ, Loc))));
-                        Set_Result_Definition (Spec_Node,
-                          New_Reference_To (RTE (RE_Storage_Offset), Loc));
-
-                        Set_Specification (Body_Node, Spec_Node);
-                        Set_Declarations (Body_Node, New_List);
-                        Set_Handled_Statement_Sequence (Body_Node,
-                          Make_Handled_Sequence_Of_Statements (Loc,
-                            Statements => New_List (
-                              Make_Return_Statement (Loc,
-                                Expression =>
-                                  Make_Attribute_Reference (Loc,
-                                    Prefix =>
-                                      Make_Selected_Component (Loc,
-                                        Prefix => Make_Identifier (Loc,
-                                                    Name_uO),
-                                        Selector_Name => New_Reference_To
-                                                           (E, Loc)),
-                                    Attribute_Name => Name_Position)))));
-
-                        Set_Ekind       (Func_Id, E_Function);
-                        Set_Mechanism   (Func_Id, Default_Mechanism);
-                        Set_Is_Internal (Func_Id, True);
-
-                        if not Debug_Generated_Code then
-                           Set_Debug_Info_Off (Func_Id);
-                        end if;
-
-                        Analyze (Body_Node);
+            Analyze (Body_Node);
 
-                        Append_Freeze_Action (Rec_Type, Body_Node);
-                     end if;
+            Append_Freeze_Action (Rec_Type, Body_Node);
+         end Build_Offset_To_Top_Function;
 
-                     Next_Elmt (ADT);
-                  end if;
+         --  Local variables
 
-                  Next_Entity (E);
-               end loop;
-            end if;
-         end Build_Offset_To_Top_Internal;
+         Ifaces_List      : Elist_Id;
+         Ifaces_Comp_List : Elist_Id;
+         Ifaces_Tag_List  : Elist_Id;
+         Iface_Elmt       : Elmt_Id;
+         Comp_Elmt        : Elmt_Id;
 
       --  Start of processing for Build_Offset_To_Top_Functions
 
       begin
-         if Is_Concurrent_Record_Type (Rec_Type)
-           and then Is_Empty_List (Abstract_Interface_List (Rec_Type))
-         then
-            return;
+         --  Offset_To_Top_Functions are built only for derivations of types
+         --  with discriminants that cover interface types.
 
-         elsif Etype (Rec_Type) = Rec_Type
+         if not Is_Tagged_Type (Rec_Type)
+           or else Etype (Rec_Type) = Rec_Type
            or else not Has_Discriminants (Etype (Rec_Type))
-           or else No (Abstract_Interfaces (Rec_Type))
-           or else Is_Empty_Elmt_List (Abstract_Interfaces (Rec_Type))
          then
             return;
          end if;
 
-         --  Skip the first _Tag, which is the main tag of the tagged type.
-         --  Following tags correspond with abstract interfaces.
+         Collect_Interfaces_Info (Rec_Type,
+           Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List);
 
-         ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Rec_Type)));
+         --  For each interface type with secondary dispatch table we generate
+         --  the Offset_To_Top_Functions (required to displace the pointer in
+         --  interface conversions)
 
-         --  Handle private types
+         Iface_Elmt := First_Elmt (Ifaces_List);
+         Comp_Elmt  := First_Elmt (Ifaces_Comp_List);
+         while Present (Iface_Elmt) loop
 
-         if Present (Full_View (Rec_Type)) then
-            Build_Offset_To_Top_Internal (Full_View (Rec_Type));
-         else
-            Build_Offset_To_Top_Internal (Rec_Type);
-         end if;
+            --  If the interface is a parent of Rec_Type it shares the primary
+            --  dispatch table and hence there is no need to build the function
+
+            if not Is_Parent (Node (Iface_Elmt), Rec_Type) then
+               Build_Offset_To_Top_Function (Iface_Comp => Node (Comp_Elmt));
+            end if;
+
+            Next_Elmt (Iface_Elmt);
+            Next_Elmt (Comp_Elmt);
+         end loop;
       end Build_Offset_To_Top_Functions;
 
       --------------------------
@@ -2139,7 +2152,7 @@ package body Exp_Ch3 is
          Proc_Spec_Node        : Node_Id;
          Body_Stmts            : List_Id;
          Record_Extension_Node : Node_Id;
-         Init_Tag              : Node_Id;
+         Init_Tags_List        : List_Id;
 
       begin
          Body_Stmts := New_List;
@@ -2241,7 +2254,9 @@ package body Exp_Ch3 is
            and then VM_Target = No_VM
            and then not No_Run_Time_Mode
          then
-            Init_Tag :=
+            --  Initialize the primary tag
+
+            Init_Tags_List := New_List (
               Make_Assignment_Statement (Loc,
                 Name =>
                   Make_Selected_Component (Loc,
@@ -2251,7 +2266,23 @@ package body Exp_Ch3 is
 
                 Expression =>
                   New_Reference_To
-                    (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc));
+                    (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_Abstract_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;
 
             --  The tag must be inserted before the assignments to other
             --  components,  because the initial value of the component may
@@ -2266,12 +2297,10 @@ package body Exp_Ch3 is
             --  after the calls to initialize the parent.
 
             if not Is_CPP_Class (Etype (Rec_Type)) then
-               Init_Tag :=
+               Prepend_To (Body_Stmts,
                  Make_If_Statement (Loc,
                    Condition => New_Occurrence_Of (Set_Tag, Loc),
-                   Then_Statements => New_List (Init_Tag));
-
-               Prepend_To (Body_Stmts, Init_Tag);
+                   Then_Statements => Init_Tags_List));
 
             --  CPP_Class: In this case the dispatch table of the parent was
             --  built in the C++ side and we copy the table of the parent to
@@ -2279,12 +2308,12 @@ package body Exp_Ch3 is
 
             else
                declare
-                  Nod   : Node_Id := First (Body_Stmts);
-                  New_N : Node_Id;
+                  Nod : Node_Id;
 
                begin
                   --  We assume 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)))
@@ -2299,11 +2328,14 @@ package body Exp_Ch3 is
                   --        _init._tag := new_dt;
                   --     end if;
 
-                  New_N :=
+                  Prepend_To (Init_Tags_List,
                     Build_Inherit_Prims (Loc,
+                      Typ          => Rec_Type,
                       Old_Tag_Node =>
                         Make_Selected_Component (Loc,
-                          Prefix => Make_Identifier (Loc, Name_uInit),
+                          Prefix        =>
+                            Make_Identifier (Loc,
+                              Chars => Name_uInit),
                           Selector_Name =>
                             New_Reference_To
                               (First_Tag_Component (Rec_Type), Loc)),
@@ -2311,16 +2343,14 @@ package body Exp_Ch3 is
                         New_Reference_To
                           (Node (First_Elmt (Access_Disp_Table (Rec_Type))),
                            Loc),
-                      Num_Prims =>
+                      Num_Prims    =>
                         UI_To_Int
-                          (DT_Entry_Count (First_Tag_Component (Rec_Type))));
+                          (DT_Entry_Count (First_Tag_Component (Rec_Type)))));
 
-                  Init_Tag :=
+                  Insert_After (Nod,
                     Make_If_Statement (Loc,
                       Condition => New_Occurrence_Of (Set_Tag, Loc),
-                      Then_Statements => New_List (New_N, Init_Tag));
-
-                  Insert_After (Nod, Init_Tag);
+                      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.
@@ -2343,7 +2373,7 @@ package body Exp_Ch3 is
                         then
                            Register_Primitive (Loc,
                              Prim    => Prim,
-                             Ins_Nod => Init_Tag);
+                             Ins_Nod => Last (Init_Tags_List));
                         end if;
 
                         Next_Elmt (E);
@@ -2352,18 +2382,31 @@ package body Exp_Ch3 is
                end;
             end if;
 
-            --  Ada 2005 (AI-251): Initialization of all the tags corresponding
-            --  with abstract interfaces
+            --  Ada 2005 (AI-251): Initialize the secondary tag components
+            --  located at variable positions. We delay the generation of this
+            --  code until here because the value of the attribute 'Position
+            --  applied to variable size components of the parent type that
+            --  depend on discriminants is only safely read at runtime after
+            --  the parent components have been initialized.
 
-            if VM_Target = No_VM
-              and then Ada_Version >= Ada_05
+            if Ada_Version >= Ada_05
               and then not Is_Interface (Rec_Type)
               and then Has_Abstract_Interfaces (Rec_Type)
+              and then Has_Discriminants (Etype (Rec_Type))
+              and then Is_Variable_Size_Record (Etype (Rec_Type))
             then
+               Init_Tags_List := New_List;
+
                Init_Secondary_Tags
-                 (Typ        => Rec_Type,
-                  Target     => Make_Identifier (Loc, Name_uInit),
-                  Stmts_List => Body_Stmts);
+                 (Typ            => Rec_Type,
+                  Target         => Make_Identifier (Loc, Name_uInit),
+                  Stmts_List     => Init_Tags_List,
+                  Fixed_Comps    => False,
+                  Variable_Comps => True);
+
+               if Is_Non_Empty_List (Init_Tags_List) then
+                  Append_List_To (Body_Stmts, Init_Tags_List);
+               end if;
             end if;
          end if;
 
@@ -3498,7 +3541,7 @@ package body Exp_Ch3 is
                     Left_Opnd => New_Reference_To (A, Loc),
                     Right_Opnd => New_Reference_To (B, Loc)),
                 Then_Statements => New_List (
-                  Make_Return_Statement (Loc,
+                  Make_Simple_Return_Statement (Loc,
                     Expression => New_Occurrence_Of (Standard_False, Loc)))));
 
             --  Generate component-by-component comparison. Note that we must
@@ -3522,7 +3565,7 @@ package body Exp_Ch3 is
       end if;
 
       Append_To (Stmts,
-        Make_Return_Statement (Loc,
+        Make_Simple_Return_Statement (Loc,
           Expression => New_Reference_To (Standard_True, Loc)));
 
       Set_TSS (Typ, F);
@@ -3944,6 +3987,33 @@ package body Exp_Ch3 is
          return;
       end if;
 
+      --  Force construction of dispatch tables of library level tagged types
+
+      if VM_Target = No_VM
+        and then Static_Dispatch_Tables
+        and then Is_Library_Level_Entity (Def_Id)
+        and then Is_Library_Level_Tagged_Type (Typ)
+        and then (Ekind (Typ) = E_Record_Type
+                    or else Ekind (Typ) = E_Protected_Type
+                    or else Ekind (Typ) = E_Task_Type)
+        and then not Has_Dispatch_Table (Typ)
+      then
+         declare
+            New_Nodes : List_Id := No_List;
+
+         begin
+            if Is_Concurrent_Type (Typ) then
+               New_Nodes := Make_DT (Corresponding_Record_Type (Typ), N);
+            else
+               New_Nodes := Make_DT (Typ, N);
+            end if;
+
+            if not Is_Empty_List (New_Nodes) then
+               Insert_List_Before (N, New_Nodes);
+            end if;
+         end;
+      end if;
+
       --  Make shared memory routines for shared passive variable
 
       if Is_Shared_Passive (Def_Id) then
@@ -3960,10 +4030,15 @@ package body Exp_Ch3 is
          Build_Master_Entity (Def_Id);
       end if;
 
-      --  Build a list controller for declarations of the form
-      --    Obj : access Some_Type [:= Expression];
+      --  Build a list controller for declarations where the type is anonymous
+      --  access and the designated type is controlled. Only declarations from
+      --  source files receive such controllers in order to provide the same
+      --  lifespan for any potential coextensions that may be associated with
+      --  the object. Finalization lists of internal controlled anonymous
+      --  access objects are already handled in Expand_N_Allocator.
 
-      if Ekind (Typ) = E_Anonymous_Access_Type
+      if Comes_From_Source (N)
+        and then Ekind (Typ) = E_Anonymous_Access_Type
         and then Is_Controlled (Directly_Designated_Type (Typ))
         and then No (Associated_Final_Chain (Typ))
       then
@@ -4040,12 +4115,26 @@ package body Exp_Ch3 is
          --  Call type initialization procedure if there is one. We build the
          --  call and put it immediately after the object declaration, so that
          --  it will be expanded in the usual manner. Note that this will
-         --  result in proper handling of defaulted discriminants. The call
-         --  to the Init_Proc is suppressed if No_Initialization is set.
+         --  result in proper handling of defaulted discriminants.
+
+         --  Need call if there is a base init proc
 
          if Has_Non_Null_Base_Init_Proc (Typ)
-           and then not No_Initialization (N)
-           and then not Is_Value_Type (Typ)
+
+            --  Suppress call if No_Initialization set on declaration
+
+            and then not No_Initialization (N)
+
+            --  Suppress call for special case of value type for VM
+
+            and then not Is_Value_Type (Typ)
+
+            --  Suppress call if Suppress_Init_Proc set on the type. This is
+            --  needed for the derived type case, where Suppress_Initialization
+            --  may be set for the derived type, even if there is an init proc
+            --  defined for the root type.
+
+            and then not Suppress_Init_Proc (Typ)
          then
             --  The call to the initialization procedure does NOT freeze the
             --  object being initialized. This is because the call is not a
@@ -4556,9 +4645,9 @@ package body Exp_Ch3 is
                --  Ada 2005 (AI-251): The following condition covers secondary
                --  tags but also the adjacent component contanining the offset
                --  to the base of the object (component generated if the parent
-               --  has discriminants ---see Add_Interface_Tag_Components). This
-               --  is required to avoid the addition of the controller between
-               --  the secondary tag and its adjacent component.
+               --  has discriminants --- see Add_Interface_Tag_Components).
+               --  This is required to avoid the addition of the controller
+               --  between the secondary tag and its adjacent component.
 
                    or else Present
                              (Related_Interface
@@ -4695,8 +4784,9 @@ package body Exp_Ch3 is
    -----------------------
 
    procedure Freeze_Array_Type (N : Node_Id) is
-      Typ  : constant Entity_Id  := Entity (N);
-      Base : constant Entity_Id  := Base_Type (Typ);
+      Typ      : constant Entity_Id  := Entity (N);
+      Comp_Typ : constant Entity_Id := Component_Type (Typ);
+      Base     : constant Entity_Id  := Base_Type (Typ);
 
    begin
       if not Is_Bit_Packed_Array (Typ) then
@@ -4706,10 +4796,10 @@ package body Exp_Ch3 is
          --  been a private type at the point of definition. Same if component
          --  type is controlled.
 
-         Set_Has_Task (Base, Has_Task (Component_Type (Typ)));
+         Set_Has_Task (Base, Has_Task (Comp_Typ));
          Set_Has_Controlled_Component (Base,
-           Has_Controlled_Component (Component_Type (Typ))
-             or else Is_Controlled (Component_Type (Typ)));
+           Has_Controlled_Component (Comp_Typ)
+             or else Is_Controlled (Comp_Typ));
 
          if No (Init_Proc (Base)) then
 
@@ -4746,22 +4836,30 @@ package body Exp_Ch3 is
             end if;
          end if;
 
-         if Typ = Base and then Has_Controlled_Component (Base) then
-            Build_Controlling_Procs (Base);
+         if Typ = Base then
+            if Has_Controlled_Component (Base) then
+               Build_Controlling_Procs (Base);
 
-            if not Is_Limited_Type (Component_Type (Typ))
-              and then Number_Dimensions (Typ) = 1
+               if not Is_Limited_Type (Comp_Typ)
+                 and then Number_Dimensions (Typ) = 1
+               then
+                  Build_Slice_Assignment (Typ);
+               end if;
+
+            elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type
+              and then Controlled_Type (Directly_Designated_Type (Comp_Typ))
             then
-               Build_Slice_Assignment (Typ);
+               Set_Associated_Final_Chain (Comp_Typ, Add_Final_Chain (Typ));
             end if;
          end if;
 
-      --  For packed case, there is a default initialization, except if the
-      --  component type is itself a packed structure with an initialization
-      --  procedure.
+      --  For packed case, default initialization, except if the component type
+      --  is itself a packed structure with an initialization procedure, or
+      --  initialize/normalize scalars active, and we have a base type.
 
-      elsif Present (Init_Proc (Component_Type (Base)))
-        and then No (Base_Init_Proc (Base))
+      elsif (Present (Init_Proc (Component_Type (Base)))
+               and then No (Base_Init_Proc (Base)))
+        or else (Init_Or_Norm_Scalars and then Base = Typ)
       then
          Build_Array_Init_Proc (Base, N);
       end if;
@@ -4788,14 +4886,14 @@ package body Exp_Ch3 is
       pragma Warnings (Off, Func);
 
    begin
-      --  Various optimization are possible if the given representation is
-      --  contiguous.
+      --  Various optimizations possible if given representation is contiguous
 
       Is_Contiguous := True;
+
       Ent := First_Literal (Typ);
       Last_Repval := Enumeration_Rep (Ent);
-      Next_Literal (Ent);
 
+      Next_Literal (Ent);
       while Present (Ent) loop
          if Enumeration_Rep (Ent) - Last_Repval /= 1 then
             Is_Contiguous := False;
@@ -4968,7 +5066,7 @@ package body Exp_Ch3 is
                       Make_Integer_Literal (Loc, Intval => Last_Repval))),
 
                 Statements => New_List (
-                  Make_Return_Statement (Loc,
+                  Make_Simple_Return_Statement (Loc,
                     Expression => Pos_Expr))));
 
       else
@@ -4981,7 +5079,7 @@ package body Exp_Ch3 is
                     Intval => Enumeration_Rep (Ent))),
 
                 Statements => New_List (
-                  Make_Return_Statement (Loc,
+                  Make_Simple_Return_Statement (Loc,
                     Expression =>
                       Make_Integer_Literal (Loc,
                         Intval => Enumeration_Pos (Ent))))));
@@ -5000,7 +5098,7 @@ package body Exp_Ch3 is
                Make_Raise_Constraint_Error (Loc,
                  Condition => Make_Identifier (Loc, Name_uF),
                  Reason    => CE_Invalid_Data),
-               Make_Return_Statement (Loc,
+               Make_Simple_Return_Statement (Loc,
                  Expression =>
                    Make_Integer_Literal (Loc, -1)))));
 
@@ -5013,7 +5111,7 @@ package body Exp_Ch3 is
            Make_Case_Statement_Alternative (Loc,
              Discrete_Choices => New_List (Make_Others_Choice (Loc)),
              Statements => New_List (
-               Make_Return_Statement (Loc,
+               Make_Simple_Return_Statement (Loc,
                  Expression =>
                    Make_Integer_Literal (Loc, -1)))));
       end if;
@@ -5068,12 +5166,18 @@ package body Exp_Ch3 is
    ------------------------
 
    procedure Freeze_Record_Type (N : Node_Id) is
-      Comp        : Entity_Id;
-      Def_Id      : constant Node_Id := Entity (N);
-      Predef_List : List_Id;
-      Type_Decl   : constant Node_Id := Parent (Def_Id);
-
-      Renamed_Eq  : Node_Id := Empty;
+      Def_Id        : constant Node_Id := Entity (N);
+      Type_Decl     : constant Node_Id := Parent (Def_Id);
+      Comp          : Entity_Id;
+      Comp_Typ      : Entity_Id;
+      Has_Static_DT : Boolean := False;
+      Predef_List   : List_Id;
+
+      Flist : Entity_Id := Empty;
+      --  Finalization list allocated for the case of a type with anonymous
+      --  access components whose designated type is potentially controlled.
+
+      Renamed_Eq : Node_Id := Empty;
       --  Could use some comments ???
 
       Wrapper_Decl_List   : List_Id := No_List;
@@ -5082,11 +5186,11 @@ package body Exp_Ch3 is
 
    begin
       --  Build discriminant checking functions if not a derived type (for
-      --  derived types that are not tagged types, we always use the
-      --  discriminant checking functions of the parent type). However, for
-      --  untagged types the derivation may have taken place before the
-      --  parent was frozen, so we copy explicitly the discriminant checking
-      --  functions from the parent into the components of the derived type.
+      --  derived types that are not tagged types, always use the discriminant
+      --  checking functions of the parent type). However, for untagged types
+      --  the derivation may have taken place before the parent was frozen, so
+      --  we copy explicitly the discriminant checking functions from the
+      --  parent into the components of the derived type.
 
       if not Is_Derived_Type (Def_Id)
         or else Has_New_Non_Standard_Rep (Def_Id)
@@ -5139,14 +5243,25 @@ package body Exp_Ch3 is
       Comp := First_Component (Def_Id);
 
       while Present (Comp) loop
-         if Has_Task (Etype (Comp)) then
+         Comp_Typ := Etype (Comp);
+
+         if Has_Task (Comp_Typ) then
             Set_Has_Task (Def_Id);
 
-         elsif Has_Controlled_Component (Etype (Comp))
+         elsif Has_Controlled_Component (Comp_Typ)
            or else (Chars (Comp) /= Name_uParent
-                     and then Is_Controlled (Etype (Comp)))
+                     and then Is_Controlled (Comp_Typ))
          then
             Set_Has_Controlled_Component (Def_Id);
+
+         elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type
+           and then Controlled_Type (Directly_Designated_Type (Comp_Typ))
+         then
+            if No (Flist) then
+               Flist := Add_Final_Chain (Def_Id);
+            end if;
+
+            Set_Associated_Final_Chain (Comp_Typ, Flist);
          end if;
 
          Next_Component (Comp);
@@ -5159,31 +5274,28 @@ package body Exp_Ch3 is
       --  just use it.
 
       if Is_Tagged_Type (Def_Id) then
+         Has_Static_DT :=
+           Static_Dispatch_Tables
+             and then Is_Library_Level_Tagged_Type (Def_Id);
 
-         if Is_CPP_Class (Def_Id) then
-
-            --  Because of the new C++ ABI compatibility we now allow the
-            --  programmer to use the Ada tag (and in this case we must do
-            --  the normal expansion of the tag)
+         --  Add the _Tag component
 
-            if Etype (First_Component (Def_Id)) = RTE (RE_Tag)
-              and then Underlying_Type (Etype (Def_Id)) = Def_Id
-            then
-               Expand_Tagged_Root (Def_Id);
-            end if;
+         if Underlying_Type (Etype (Def_Id)) = Def_Id then
+            Expand_Tagged_Root (Def_Id);
+         end if;
 
+         if Is_CPP_Class (Def_Id) then
             Set_All_DT_Position (Def_Id);
             Set_Default_Constructor (Def_Id);
 
-            --  With CPP_Class types Make_DT does a minimum decoration of the
-            --  Access_Disp_Table list.
+            --  Create the tag entities with a minimum decoration
 
             if VM_Target = No_VM then
-               Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
+               Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id));
             end if;
 
          else
-            if not Static_Dispatch_Tables then
+            if not Has_Static_DT then
 
                --  Usually inherited primitives are not delayed but the first
                --  Ada extension of a CPP_Class is an exception since the
@@ -5221,10 +5333,6 @@ package body Exp_Ch3 is
                end;
             end if;
 
-            if Underlying_Type (Etype (Def_Id)) = Def_Id then
-               Expand_Tagged_Root (Def_Id);
-            end if;
-
             --  Unfreeze momentarily the type to add the predefined primitives
             --  operations. The reason we unfreeze is so that these predefined
             --  operations will indeed end up as primitive operations (which
@@ -5280,12 +5388,22 @@ package body Exp_Ch3 is
                Expand_Record_Controller (Def_Id);
             end if;
 
-            --  Build the dispatch table. Suppress its creation when VM_Target
-            --  because the dispatching mechanism is handled internally by the
-            --  VMs.
+            --  Create and decorate the tags. Suppress their creation when
+            --  VM_Target because the dispatching mechanism is handled
+            --  internally by the VMs.
 
             if VM_Target = No_VM then
-               Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
+               Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id));
+
+               --  Generate dispatch table of locally defined tagged type.
+               --  Dispatch tables of library level tagged types are built
+               --  later (see Analyze_Declarations).
+
+               if VM_Target = No_VM
+                 and then not Has_Static_DT
+               then
+                  Append_Freeze_Actions (Def_Id, Make_DT (Def_Id));
+               end if;
             end if;
 
             --  Make sure that the primitives Initialize, Adjust and Finalize
@@ -5409,19 +5527,6 @@ package body Exp_Ch3 is
          if Present (Wrapper_Body_List) then
             Append_Freeze_Actions (Def_Id, Wrapper_Body_List);
          end if;
-
-         --  Populate the two auxiliary tables used for dispatching
-         --  asynchronous, conditional and timed selects for synchronized
-         --  types that implement a limited interface.
-
-         if Ada_Version >= Ada_05
-           and then not Restriction_Active (No_Dispatching_Calls)
-           and then Is_Concurrent_Record_Type (Def_Id)
-           and then Has_Abstract_Interfaces (Def_Id)
-         then
-            Append_Freeze_Actions (Def_Id,
-              Make_Select_Specific_Data_Table (Def_Id));
-         end if;
       end if;
    end Freeze_Record_Type;
 
@@ -5786,15 +5891,7 @@ package body Exp_Ch3 is
 
               or else Has_Controlled_Coextensions (Desig_Type)
             then
-               Set_Associated_Final_Chain (Def_Id,
-                 Make_Defining_Identifier (Loc,
-                   New_External_Name (Chars (Def_Id), 'L')));
-
-               Append_Freeze_Action (Def_Id,
-                 Make_Object_Declaration (Loc,
-                   Defining_Identifier => Associated_Final_Chain (Def_Id),
-                   Object_Definition   =>
-                     New_Reference_To (RTE (RE_List_Controller), Loc)));
+               Set_Associated_Final_Chain (Def_Id, Add_Final_Chain (Def_Id));
             end if;
          end;
 
@@ -6337,33 +6434,58 @@ package body Exp_Ch3 is
    -------------------------
 
    procedure Init_Secondary_Tags
-     (Typ        : Entity_Id;
-      Target     : Node_Id;
-      Stmts_List : List_Id)
+     (Typ            : Entity_Id;
+      Target         : Node_Id;
+      Stmts_List     : List_Id;
+      Fixed_Comps    : Boolean := True;
+      Variable_Comps : Boolean := True)
    is
-      Loc         : constant Source_Ptr := Sloc (Target);
-      ADT         : Elmt_Id;
-      Full_Typ    : Entity_Id;
-      AI_Tag_Comp : Entity_Id;
+      Loc : constant Source_Ptr := Sloc (Target);
 
-      Is_Synch_Typ : Boolean := False;
-      --  In case of non concurrent-record-types each parent-type has the
-      --  tags associated with the interface types that are not implemented
-      --  by the ancestors; concurrent-record-types have their whole list of
-      --  interface tags (and this case requires some special management).
+      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.
 
       procedure Initialize_Tag
         (Typ       : Entity_Id;
          Iface     : Entity_Id;
-         Tag_Comp  : in out Entity_Id;
+         Tag_Comp  : Entity_Id;
          Iface_Tag : Node_Id);
       --  Initialize the tag of the secondary dispatch table of Typ associated
       --  with Iface. Tag_Comp is the component of Typ that stores Iface_Tag.
+      --  Compiling under the CPP full ABI compatibility mode, if the ancestor
+      --  of Typ CPP tagged type we generate code to inherit the contents of
+      --  the dispatch table directly from the ancestor.
 
-      procedure Init_Secondary_Tags_Internal (Typ : Entity_Id);
-      --  Internal subprogram used to recursively climb to the root type.
-      --  We assume that all the primitives of the imported C++ class are
-      --  defined in the C side.
+      ---------------------
+      -- 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 --
@@ -6372,261 +6494,166 @@ package body Exp_Ch3 is
       procedure Initialize_Tag
         (Typ       : Entity_Id;
          Iface     : Entity_Id;
-         Tag_Comp  : in out Entity_Id;
+         Tag_Comp  : Entity_Id;
          Iface_Tag : Node_Id)
       is
-         Prev_E : Entity_Id;
+         Comp_Typ           : Entity_Id;
+         Offset_To_Top_Comp : Entity_Id := Empty;
 
       begin
-         --  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 pointer to the secondary DT associated with the
+         --  interface.
 
-         if Is_CPP_Class (Etype (Typ)) then
+         if not Is_Parent (Iface, Typ) then
             Append_To (Stmts_List,
-              Build_Inherit_Prims (Loc,
-                Old_Tag_Node =>
+              Make_Assignment_Statement (Loc,
+                Name =>
                   Make_Selected_Component (Loc,
-                    Prefix        => New_Copy_Tree (Target),
+                    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)))));
+                Expression =>
+                  New_Reference_To (Iface_Tag, Loc)));
          end if;
 
-         --  Initialize the pointer to the secondary DT associated with the
-         --  interface.
-
-         Append_To (Stmts_List,
-           Make_Assignment_Statement (Loc,
-             Name =>
-               Make_Selected_Component (Loc,
-                 Prefix => New_Copy_Tree (Target),
-                 Selector_Name => New_Reference_To (Tag_Comp, Loc)),
-             Expression =>
-               New_Reference_To (Iface_Tag, Loc)));
+         --  Issue error if Set_Offset_To_Top is not available in a
+         --  configurable run-time environment.
 
-         --  If the ancestor is CPP_Class, nothing else to do here
-
-         if Is_CPP_Class (Etype (Typ)) then
-            null;
-
-         --  Otherwise, comment required ???
-
-         else
-            --  Issue error if Set_Offset_To_Top is not available in a
-            --  configurable run-time environment.
-
-            if not RTE_Available (RE_Set_Offset_To_Top) then
-               Error_Msg_CRT ("abstract interface types", Typ);
-               return;
-            end if;
+         if not RTE_Available (RE_Set_Offset_To_Top) then
+            Error_Msg_CRT ("abstract interface types", Typ);
+            return;
+         end if;
 
-            --  We generate a different call when the parent of the type has
-            --  discriminants.
+         Comp_Typ := Scope (Tag_Comp);
 
-            if Typ /= Etype (Typ)
-              and then Has_Discriminants (Etype (Typ))
-            then
-               pragma Assert
-                 (Present (DT_Offset_To_Top_Func (Tag_Comp)));
-
-               --  Generate:
-               --    Set_Offset_To_Top
-               --      (This         => Init,
-               --       Interface_T  => Iface'Tag,
-               --       Is_Constant  => False,
-               --       Offset_Value => n,
-               --       Offset_Func  => Fn'Address)
-
-               Append_To (Stmts_List,
-                 Make_Procedure_Call_Statement (Loc,
-                   Name => New_Reference_To
-                             (RTE (RE_Set_Offset_To_Top), Loc),
-                   Parameter_Associations => New_List (
-                     Make_Attribute_Reference (Loc,
-                       Prefix => New_Copy_Tree (Target),
-                       Attribute_Name => Name_Address),
+         --  Initialize the entries of the table of interfaces. We generate a
+         --  different call when the parent of the type has variable size
+         --  components.
 
-                     Unchecked_Convert_To (RTE (RE_Tag),
-                       New_Reference_To
-                         (Node (First_Elmt (Access_Disp_Table (Iface))),
-                          Loc)),
+         if Comp_Typ /= Etype (Comp_Typ)
+           and then Is_Variable_Size_Record (Etype (Comp_Typ))
+           and then Chars (Tag_Comp) /= Name_uTag
+         then
+            pragma Assert
+              (Present (DT_Offset_To_Top_Func (Tag_Comp)));
 
-                     New_Occurrence_Of (Standard_False, Loc),
+            --  Generate:
+            --    Set_Offset_To_Top
+            --      (This         => Init,
+            --       Interface_T  => Iface'Tag,
+            --       Is_Constant  => False,
+            --       Offset_Value => n,
+            --       Offset_Func  => Fn'Address)
 
-                     Unchecked_Convert_To
-                       (RTE (RE_Storage_Offset),
-                        Make_Attribute_Reference (Loc,
-                          Prefix         =>
-                            Make_Selected_Component (Loc,
-                              Prefix => New_Copy_Tree (Target),
-                              Selector_Name =>
-                                New_Reference_To (Tag_Comp, Loc)),
-                          Attribute_Name => Name_Position)),
-
-                     Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr),
-                       Make_Attribute_Reference (Loc,
-                         Prefix => New_Reference_To
-                                     (DT_Offset_To_Top_Func (Tag_Comp), Loc),
-                         Attribute_Name => Name_Address)))));
+            Append_To (Stmts_List,
+              Make_Procedure_Call_Statement (Loc,
+                Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
+                Parameter_Associations => New_List (
+                  Make_Attribute_Reference (Loc,
+                    Prefix => New_Copy_Tree (Target),
+                    Attribute_Name => Name_Address),
 
-               --  In this case the next component stores the value of the
-               --  offset to the top.
+                  Unchecked_Convert_To (RTE (RE_Tag),
+                    New_Reference_To
+                      (Node (First_Elmt (Access_Disp_Table (Iface))),
+                       Loc)),
 
-               Prev_E := Tag_Comp;
-               Next_Entity (Tag_Comp);
-               pragma Assert (Present (Tag_Comp));
+                  New_Occurrence_Of (Standard_False, Loc),
 
-               Append_To (Stmts_List,
-                 Make_Assignment_Statement (Loc,
-                   Name =>
-                     Make_Selected_Component (Loc,
-                       Prefix => New_Copy_Tree (Target),
-                       Selector_Name => New_Reference_To (Tag_Comp, Loc)),
-                   Expression =>
+                  Unchecked_Convert_To
+                    (RTE (RE_Storage_Offset),
                      Make_Attribute_Reference (Loc,
                        Prefix         =>
                          Make_Selected_Component (Loc,
                            Prefix => New_Copy_Tree (Target),
                            Selector_Name =>
-                             New_Reference_To (Prev_E, Loc)),
-                     Attribute_Name => Name_Position)));
+                             New_Reference_To (Tag_Comp, Loc)),
+                       Attribute_Name => Name_Position)),
 
-            --  Normal case: No discriminants in the parent type
-
-            else
-               --  Generate:
-               --    Set_Offset_To_Top
-               --      (This         => Init,
-               --       Interface_T  => Iface'Tag,
-               --       Is_Constant  => True,
-               --       Offset_Value => n,
-               --       Offset_Func  => null);
-
-               Append_To (Stmts_List,
-                 Make_Procedure_Call_Statement (Loc,
-                   Name => New_Reference_To
-                             (RTE (RE_Set_Offset_To_Top), Loc),
-                   Parameter_Associations => New_List (
-                     Make_Attribute_Reference (Loc,
-                       Prefix => New_Copy_Tree (Target),
-                       Attribute_Name => Name_Address),
-
-                     Unchecked_Convert_To (RTE (RE_Tag),
-                       New_Reference_To
-                         (Node (First_Elmt
-                                (Access_Disp_Table (Iface))),
-                          Loc)),
-
-                     New_Occurrence_Of (Standard_True, Loc),
-
-                     Unchecked_Convert_To
-                       (RTE (RE_Storage_Offset),
-                        Make_Attribute_Reference (Loc,
-                          Prefix =>
-                            Make_Selected_Component (Loc,
-                              Prefix => New_Copy_Tree (Target),
-                              Selector_Name  =>
-                                New_Reference_To (Tag_Comp, Loc)),
-                         Attribute_Name => Name_Position)),
-
-                     Make_Null (Loc))));
-            end if;
-         end if;
-      end Initialize_Tag;
-
-      ----------------------------------
-      -- Init_Secondary_Tags_Internal --
-      ----------------------------------
-
-      procedure Init_Secondary_Tags_Internal (Typ : Entity_Id) is
-         AI_Elmt : Elmt_Id;
-
-      begin
-         --  Climb to the ancestor (if any) handling synchronized interface
-         --  derivations and private types
+                  Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr),
+                    Make_Attribute_Reference (Loc,
+                      Prefix => New_Reference_To
+                                  (DT_Offset_To_Top_Func (Tag_Comp), Loc),
+                      Attribute_Name => Name_Address)))));
 
-         if Is_Concurrent_Record_Type (Typ) then
-            declare
-               Iface_List : constant List_Id := Abstract_Interface_List (Typ);
+            --  In this case the next component stores the value of the
+            --  offset to the top.
 
-            begin
-               if Is_Non_Empty_List (Iface_List) then
-                  Init_Secondary_Tags_Internal (Etype (First (Iface_List)));
-               end if;
-            end;
+            Offset_To_Top_Comp := Next_Entity (Tag_Comp);
+            pragma Assert (Present (Offset_To_Top_Comp));
 
-         elsif Present (Full_View (Etype (Typ))) then
-            if Full_View (Etype (Typ)) /= Typ then
-               Init_Secondary_Tags_Internal (Full_View (Etype (Typ)));
-            end if;
+            Append_To (Stmts_List,
+              Make_Assignment_Statement (Loc,
+                Name =>
+                  Make_Selected_Component (Loc,
+                    Prefix => New_Copy_Tree (Target),
+                    Selector_Name => New_Reference_To
+                                       (Offset_To_Top_Comp, Loc)),
+                Expression =>
+                  Make_Attribute_Reference (Loc,
+                    Prefix         =>
+                      Make_Selected_Component (Loc,
+                        Prefix => New_Copy_Tree (Target),
+                        Selector_Name =>
+                          New_Reference_To (Tag_Comp, Loc)),
+                  Attribute_Name => Name_Position)));
 
-         elsif Etype (Typ) /= Typ then
-            Init_Secondary_Tags_Internal (Etype (Typ));
-         end if;
+         --  Normal case: No discriminants in the parent type
 
-         if Is_Interface (Typ) then
+         else
             --  Generate:
             --    Set_Offset_To_Top
             --      (This         => Init,
             --       Interface_T  => Iface'Tag,
             --       Is_Constant  => True,
-            --       Offset_Value => 0,
-            --       Offset_Func  => null)
+            --       Offset_Value => n,
+            --       Offset_Func  => null);
 
             Append_To (Stmts_List,
               Make_Procedure_Call_Statement (Loc,
-                Name => New_Reference_To (RTE (RE_Set_Offset_To_Top), Loc),
+                Name => New_Reference_To
+                          (RTE (RE_Set_Offset_To_Top), Loc),
                 Parameter_Associations => New_List (
                   Make_Attribute_Reference (Loc,
                     Prefix => New_Copy_Tree (Target),
                     Attribute_Name => Name_Address),
+
                   Unchecked_Convert_To (RTE (RE_Tag),
                     New_Reference_To
-                      (Node (First_Elmt (Access_Disp_Table (Typ))),
+                      (Node (First_Elmt
+                             (Access_Disp_Table (Iface))),
                        Loc)),
+
                   New_Occurrence_Of (Standard_True, Loc),
-                  Make_Integer_Literal (Loc, Uint_0),
-                  Make_Null (Loc))));
-         end if;
 
-         if Present (Abstract_Interfaces (Typ))
-           and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
-         then
-            if not Is_Synch_Typ then
-               AI_Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
-               pragma Assert (Present (AI_Tag_Comp));
-            end if;
+                  Unchecked_Convert_To
+                    (RTE (RE_Storage_Offset),
+                     Make_Attribute_Reference (Loc,
+                       Prefix =>
+                         Make_Selected_Component (Loc,
+                           Prefix => New_Copy_Tree (Target),
+                           Selector_Name  =>
+                             New_Reference_To (Tag_Comp, Loc)),
+                      Attribute_Name => Name_Position)),
 
-            AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
-            while Present (AI_Elmt) loop
-               pragma Assert (Present (Node (ADT)));
+                  Make_Null (Loc))));
+         end if;
+      end Initialize_Tag;
 
-               Initialize_Tag
-                 (Typ       => Typ,
-                  Iface     => Node (AI_Elmt),
-                  Tag_Comp  => AI_Tag_Comp,
-                  Iface_Tag => Node (ADT));
+      --  Local variables
 
-               Next_Elmt (ADT);
-               AI_Tag_Comp := Next_Tag_Component (AI_Tag_Comp);
-               Next_Elmt (AI_Elmt);
-            end loop;
-         end if;
-      end Init_Secondary_Tags_Internal;
+      Full_Typ         : Entity_Id;
+      Ifaces_List      : Elist_Id;
+      Ifaces_Comp_List : Elist_Id;
+      Ifaces_Tag_List  : Elist_Id;
+      Iface_Elmt       : Elmt_Id;
+      Iface_Comp_Elmt  : Elmt_Id;
+      Iface_Tag_Elmt   : Elmt_Id;
+      Tag_Comp         : Node_Id;
+      In_Variable_Pos  : Boolean;
 
    --  Start of processing for Init_Secondary_Tags
 
    begin
-      --  Skip the first _Tag, which is the main tag of the tagged type.
-      --  Following tags correspond with abstract interfaces.
-
-      ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
-
       --  Handle private types
 
       if Present (Full_View (Typ)) then
@@ -6635,14 +6662,106 @@ package body Exp_Ch3 is
          Full_Typ := Typ;
       end if;
 
-      if Is_Concurrent_Record_Type (Typ) then
-         Is_Synch_Typ := True;
-         AI_Tag_Comp  := Next_Tag_Component (First_Tag_Component (Typ));
-      end if;
+      Collect_Interfaces_Info
+        (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List);
 
-      Init_Secondary_Tags_Internal (Full_Typ);
+      Iface_Elmt      := First_Elmt (Ifaces_List);
+      Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List);
+      Iface_Tag_Elmt  := First_Elmt (Ifaces_Tag_List);
+      while Present (Iface_Elmt) loop
+         Tag_Comp := Node (Iface_Comp_Elmt);
+
+         --  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.
+
+         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));
+
+         --  Otherwise we generate code to initialize the tag
+
+         else
+            --  Check if the parent of the 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 (In_Variable_Pos and then Variable_Comps)
+              or else (not In_Variable_Pos and then Fixed_Comps)
+            then
+               Initialize_Tag (Full_Typ,
+                 Iface     => Node (Iface_Elmt),
+                 Tag_Comp  => Tag_Comp,
+                 Iface_Tag => Node (Iface_Tag_Elmt));
+            end if;
+         end if;
+
+         Next_Elmt (Iface_Elmt);
+         Next_Elmt (Iface_Comp_Elmt);
+         Next_Elmt (Iface_Tag_Elmt);
+      end loop;
    end Init_Secondary_Tags;
 
+   -----------------------------
+   -- Is_Variable_Size_Record --
+   -----------------------------
+
+   function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
+      Comp     : Entity_Id;
+      Comp_Typ : Entity_Id;
+      Idx      : Node_Id;
+
+   begin
+      pragma Assert (Is_Record_Type (E));
+
+      Comp := First_Entity (E);
+      while Present (Comp) loop
+         Comp_Typ := Etype (Comp);
+
+         if Is_Record_Type (Comp_Typ) then
+
+            --  Recursive call if the record type has discriminants
+
+            if Has_Discriminants (Comp_Typ)
+              and then Is_Variable_Size_Record (Comp_Typ)
+            then
+               return True;
+            end if;
+
+         elsif Is_Array_Type (Comp_Typ) then
+
+            --  Check if some index is initialized with a non-constant value
+
+            Idx := First_Index (Comp_Typ);
+            while Present (Idx) loop
+               if Nkind (Idx) = N_Range then
+                  if (Nkind (Low_Bound (Idx)) = N_Identifier
+                      and then Present (Entity (Low_Bound (Idx)))
+                      and then Ekind (Entity (Low_Bound (Idx))) /= E_Constant)
+                    or else
+                     (Nkind (High_Bound (Idx)) = N_Identifier
+                      and then Present (Entity (High_Bound (Idx)))
+                      and then Ekind (Entity (High_Bound (Idx))) /= E_Constant)
+                  then
+                     return True;
+                  end if;
+               end if;
+
+               Idx := Next_Index (Idx);
+            end loop;
+         end if;
+
+         Next_Entity (Comp);
+      end loop;
+
+      return False;
+   end Is_Variable_Size_Record;
+
    ----------------------------------------
    -- Make_Controlling_Function_Wrappers --
    ----------------------------------------
@@ -6684,19 +6803,28 @@ package body Exp_Ch3 is
          --  Input constructed by the expander. The test for Comes_From_Source
          --  is needed to distinguish inherited operations from renamings
          --  (which also have Alias set).
+
          --  The function may be abstract, or require_Overriding may be set
          --  for it, because tests for null extensions may already have reset
-         --  the Is_Abstract_Subprogram_Flag.
-
-         if (Is_Abstract_Subprogram (Subp)
-               or else Requires_Overriding (Subp))
-           and then Present (Alias (Subp))
-           and then not Is_Abstract_Subprogram (Alias (Subp))
-           and then not Comes_From_Source (Subp)
-           and then Ekind (Subp) = E_Function
-           and then Has_Controlling_Result (Subp)
-           and then not Is_Access_Type (Etype (Subp))
-           and then not Is_TSS (Subp, TSS_Stream_Input)
+         --  the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not
+         --  set, functions that need wrappers are recognized by having an
+         --  alias that returns the parent type.
+
+         if Comes_From_Source (Subp)
+           or else No (Alias (Subp))
+           or else Ekind (Subp) /= E_Function
+           or else not Has_Controlling_Result (Subp)
+           or else Is_Access_Type (Etype (Subp))
+           or else Is_Abstract_Subprogram (Alias (Subp))
+           or else Is_TSS (Subp, TSS_Stream_Input)
+         then
+            goto Next_Prim;
+
+         elsif Is_Abstract_Subprogram (Subp)
+           or else Requires_Overriding (Subp)
+           or else
+             (Is_Null_Extension (Etype (Subp))
+               and then Etype (Alias (Subp)) /= Etype (Subp))
          then
             Formal_List := No_List;
             Formal := First_Formal (Subp);
@@ -6713,6 +6841,8 @@ package body Exp_Ch3 is
                             Chars => Chars (Formal)),
                         In_Present  => In_Present (Parent (Formal)),
                         Out_Present => Out_Present (Parent (Formal)),
+                        Null_Exclusion_Present =>
+                          Null_Exclusion_Present (Parent (Formal)),
                         Parameter_Type =>
                           New_Reference_To (Etype (Formal), Loc),
                         Expression =>
@@ -6725,11 +6855,11 @@ package body Exp_Ch3 is
 
             Func_Spec :=
               Make_Function_Specification (Loc,
-                Defining_Unit_Name =>
-                  Make_Defining_Identifier (Loc, Chars (Subp)),
-                Parameter_Specifications =>
-                  Formal_List,
-                Result_Definition =>
+                Defining_Unit_Name       =>
+                  Make_Defining_Identifier (Loc,
+                    Chars => Chars (Subp)),
+                Parameter_Specifications => Formal_List,
+                Result_Definition        =>
                   New_Reference_To (Etype (Subp), Loc));
 
             Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
@@ -6775,7 +6905,7 @@ package body Exp_Ch3 is
             end loop;
 
             Return_Stmt :=
-              Make_Return_Statement (Loc,
+              Make_Simple_Return_Statement (Loc,
                 Expression =>
                   Make_Extension_Aggregate (Loc,
                     Ancestor_Part =>
@@ -6805,6 +6935,7 @@ package body Exp_Ch3 is
               (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec));
          end if;
 
+      <<Next_Prim>>
          Next_Elmt (Prim_Elmt);
       end loop;
    end Make_Controlling_Function_Wrappers;
@@ -6951,7 +7082,7 @@ package body Exp_Ch3 is
               Make_Implicit_If_Statement (E,
                 Condition => Cond,
                 Then_Statements => New_List (
-                  Make_Return_Statement (Loc,
+                  Make_Simple_Return_Statement (Loc,
                     Expression => New_Occurrence_Of (Standard_False, Loc))));
          end if;
       end if;
@@ -7021,6 +7152,8 @@ package body Exp_Ch3 is
                            Chars => Chars (Formal)),
                        In_Present  => In_Present (Parent (Formal)),
                        Out_Present => Out_Present (Parent (Formal)),
+                       Null_Exclusion_Present =>
+                         Null_Exclusion_Present (Parent (Formal)),
                        Parameter_Type =>
                          New_Reference_To (Etype (Formal), Loc),
                        Expression =>
@@ -7591,7 +7724,7 @@ package body Exp_Ch3 is
 
       Set_Handled_Statement_Sequence (Decl,
         Make_Handled_Sequence_Of_Statements (Loc, New_List (
-          Make_Return_Statement (Loc,
+          Make_Simple_Return_Statement (Loc,
             Expression =>
               Make_Attribute_Reference (Loc,
                 Prefix => Make_Identifier (Loc, Name_X),
@@ -7614,7 +7747,7 @@ package body Exp_Ch3 is
 
       Set_Handled_Statement_Sequence (Decl,
         Make_Handled_Sequence_Of_Statements (Loc, New_List (
-          Make_Return_Statement (Loc,
+          Make_Simple_Return_Statement (Loc,
             Expression =>
               Make_Attribute_Reference (Loc,
                 Prefix => Make_Identifier (Loc, Name_X),
@@ -7741,12 +7874,12 @@ package body Exp_Ch3 is
                     Make_Eq_If (Tag_Typ, Discriminant_Specifications (Def)));
                   Append_List_To (Stmts, Make_Eq_Case (Tag_Typ, Comps));
                   Append_To (Stmts,
-                    Make_Return_Statement (Loc,
+                    Make_Simple_Return_Statement (Loc,
                       Expression => New_Reference_To (Standard_True, Loc)));
 
                else
                   Append_To (Stmts,
-                    Make_Return_Statement (Loc,
+                    Make_Simple_Return_Statement (Loc,
                       Expression =>
                         Expand_Record_Equality (Tag_Typ,
                           Typ => Tag_Typ,