exp_aggr.ads, [...]:

2007-04-20  Javier Miranda  <miranda@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Bob Duff  <duff@adacore.com>
	    Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_aggr.ads, exp_aggr.adb: 
	(Build_Record_Aggr_Code): Add missing initialization of secondary tags
	in extension aggregates.
	(Flatten): Other conditions being met, an aggregate is static if the
	low bound given by component associations is different from the low
	bound of the base index type.
	(Packed_Array_Aggregate_Handled): If the component type is itself a
	packed array or record, the front-end must expand into assignments.
	(Gen_Ctrl_Actions_For_Aggr): In call to Init_Controller, pass False to
	Init_Pr, instead of Ancestor_Is_Expression.
	(Gen_Ctrl_Actions_For_Aggr): When processing an aggregate of a
	coextension chain root, either generate a list controller or use the
	already existing one.
	(Static_Array_Aggregate): New procedure to construct a positional
	aggregate that can be handled by the backend, when all bounds and
	components are compile-time known constants.
	(Expand_Record_Aggregate): Force conversion of aggregates of tagged
	types covering interface types into assignments.
	(Replace_Type): move to Build_Record_Aggr_Code.
	(Expand_Record_Aggr_Code): if the target of the aggregate is an
	interface type, convert to the definite type of the aggregate itself,
	so that needed components are visible.
	(Convert_Aggr_In_Object_Decl): If the aggregate has controlled
	components and the context is an extended return statement do not
	create a transient block for it, to prevent premature finalization
	before the return is executed.
	(Gen_Assign): Do not generate a call to deep adjust routine if the
	component type is itself an array of controlled (sub)-components
	initialized with an inner aggregate.
	(Component_Check): New name for Static_Check. This name is now more
	appropriate, and documentation is added which was missing.
	(Component_Check): Add test for bit aligned component value
	(Component_Not_OK_For_Backend): Renames Has_Delayed_Nested_Aggregate_Or_
	Tagged_Comps, name is more appropriate given added function below.
	(Component_Not_OK_For_Backend): Check for bit aligned component ref.

From-SVN: r125392

2 files changed, 605 insertions, 165 deletions

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 97df2bc..6321dc5 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -36,9 +36,9 @@ with Exp_Ch7;  use Exp_Ch7;
 with Exp_Ch9;  use Exp_Ch9;
 with Exp_Tss;  use Exp_Tss;
 with Freeze;   use Freeze;
-with Hostparm; use Hostparm;
 with Itypes;   use Itypes;
 with Lib;      use Lib;
+with Namet;    use Namet;
 with Nmake;    use Nmake;
 with Nlists;   use Nlists;
 with Opt;      use Opt;
@@ -54,6 +54,7 @@ with Sem_Util; use Sem_Util;
 with Sinfo;    use Sinfo;
 with Snames;   use Snames;
 with Stand;    use Stand;
+with Targparm; use Targparm;
 with Tbuild;   use Tbuild;
 with Uintp;    use Uintp;
 
@@ -121,7 +122,7 @@ package body Exp_Aggr is
    function Build_Record_Aggr_Code
      (N                             : Node_Id;
       Typ                           : Entity_Id;
-      Target                        : Node_Id;
+      Lhs                           : Node_Id;
       Flist                         : Node_Id   := Empty;
       Obj                           : Entity_Id := Empty;
       Is_Limited_Ancestor_Expansion : Boolean   := False) return List_Id;
@@ -262,17 +263,11 @@ package body Exp_Aggr is
    function Make_OK_Assignment_Statement
      (Sloc       : Source_Ptr;
       Name       : Node_Id;
-      Expression : Node_Id;
-      Self_Ref   : Boolean := False) return Node_Id;
+      Expression : Node_Id) return Node_Id;
    --  This is like Make_Assignment_Statement, except that Assignment_OK
    --  is set in the left operand. All assignments built by this unit
    --  use this routine. This is needed to deal with assignments to
    --  initialized constants that are done in place.
-   --  If Self_Ref is true, the aggregate contains an access reference to the
-   --  enclosing type, obtained from a default initialization. The reference
-   --  as to be expanded into a reference to  the enclosing object, which is
-   --  obtained from the Name in the assignment. The value of Self_Ref is
-   --  inherited from the aggregate itself.
 
    function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;
    --  Given an array aggregate, this function handles the case of a packed
@@ -451,32 +446,46 @@ package body Exp_Aggr is
    --    4. The array type of N does not follow the Fortran layout convention
    --       or if it does it must be 1 dimensional.
 
-   --    5. The array component type is tagged, which may necessitate
-   --       reassignment of proper tags.
+   --    5. The array component type may not be tagged (which could necessitate
+   --       reassignment of proper tags).
 
-   --    6. The array component type might have unaligned bit components
+   --    6. The array component type must not have unaligned bit components
+
+   --    7. None of the components of the aggregate may be bit unaligned
+   --       components.
+
+   --    8. There cannot be delayed components, since we do not know enough
+   --       at this stage to know if back end processing is possible.
+
+   --    9. There cannot be any discriminated record components, since the
+   --       back end cannot handle this complex case.
 
    function Backend_Processing_Possible (N : Node_Id) return Boolean is
       Typ : constant Entity_Id := Etype (N);
       --  Typ is the correct constrained array subtype of the aggregate
 
-      function Static_Check (N : Node_Id; Index : Node_Id) return Boolean;
-      --  Recursively checks that N is fully positional, returns true if so
+      function Component_Check (N : Node_Id; Index : Node_Id) return Boolean;
+      --  This routine checks components of aggregate N, enforcing checks
+      --  1, 7, 8, and 9. In the multi-dimensional case, these checks are
+      --  performed on subaggregates. The Index value is the current index
+      --  being checked in the multi-dimensional case.
 
-      ------------------
-      -- Static_Check --
-      ------------------
+      ---------------------
+      -- Component_Check --
+      ---------------------
 
-      function Static_Check (N : Node_Id; Index : Node_Id) return Boolean is
+      function Component_Check (N : Node_Id; Index : Node_Id) return Boolean is
          Expr : Node_Id;
 
       begin
-         --  Check for component associations
+         --  Checks 1: (no component associations)
 
          if Present (Component_Associations (N)) then
             return False;
          end if;
 
+         --  Checks on components
+
          --  Recurse to check subaggregates, which may appear in qualified
          --  expressions. If delayed, the front-end will have to expand.
          --  If the component is a discriminated record, treat as non-static,
@@ -484,10 +493,15 @@ package body Exp_Aggr is
 
          Expr := First (Expressions (N));
          while Present (Expr) loop
+
+            --  Checks 8: (no delayed components)
+
             if Is_Delayed_Aggregate (Expr) then
                return False;
             end if;
 
+            --  Checks 9: (no discriminated records)
+
             if Present (Etype (Expr))
               and then Is_Record_Type (Etype (Expr))
               and then Has_Discriminants (Etype (Expr))
@@ -495,17 +509,27 @@ package body Exp_Aggr is
                return False;
             end if;
 
+            --  Checks 7. Component must not be bit aligned component
+
+            if Possible_Bit_Aligned_Component (Expr) then
+               return False;
+            end if;
+
+            --  Recursion to following indexes for multiple dimension case
+
             if Present (Next_Index (Index))
-               and then not Static_Check (Expr, Next_Index (Index))
+               and then not Component_Check (Expr, Next_Index (Index))
             then
                return False;
             end if;
 
+            --  All checks for that component finished, on to next
+
             Next (Expr);
          end loop;
 
          return True;
-      end Static_Check;
+      end Component_Check;
 
    --  Start of processing for Backend_Processing_Possible
 
@@ -530,21 +554,20 @@ package body Exp_Aggr is
          return False;
       end if;
 
-      --  Checks 1 (aggregate must be fully positional)
+      --  Checks on components
 
-      if not Static_Check (N, First_Index (Typ)) then
+      if not Component_Check (N, First_Index (Typ)) then
          return False;
       end if;
 
-      --  Checks 5 (if the component type is tagged, then we may need
-      --    to do tag adjustments; perhaps this should be refined to check for
-      --    any component associations that actually need tag adjustment,
-      --    along the lines of the test that is carried out in
-      --    Has_Delayed_Nested_Aggregate_Or_Tagged_Comps for record aggregates
+      --  Checks 5 (if the component type is tagged, then we may need to do
+      --    tag adjustments. Perhaps this should be refined to check for any
+      --    component associations that actually need tag adjustment, similar
+      --    to the test in Component_Not_OK_For_Backend for record aggregates
       --    with tagged components, but not clear whether it's worthwhile ???;
       --    in the case of the JVM, object tags are handled implicitly)
 
-      if Is_Tagged_Type (Component_Type (Typ)) and then not Java_VM then
+      if Is_Tagged_Type (Component_Type (Typ)) and then VM_Target = No_VM then
          return False;
       end if;
 
@@ -556,7 +579,6 @@ package body Exp_Aggr is
 
       --  Backend processing is possible
 
-      Set_Compile_Time_Known_Aggregate (N, True);
       Set_Size_Known_At_Compile_Time (Etype (N), True);
       return True;
    end Backend_Processing_Possible;
@@ -1094,7 +1116,7 @@ package body Exp_Aggr is
 
             if Present (Comp_Type)
               and then Is_Tagged_Type (Comp_Type)
-              and then not Java_VM
+              and then VM_Target = No_VM
             then
                A :=
                  Make_OK_Assignment_Statement (Loc,
@@ -1114,11 +1136,24 @@ package body Exp_Aggr is
                Append_To (L, A);
             end if;
 
-            --  Adjust and Attach the component to the proper final list
-            --  which can be the controller of the outer record object or
-            --  the final list associated with the scope
+            --  Adjust and attach the component to the proper final list, which
+            --  can be the controller of the outer record object or the final
+            --  list associated with the scope.
 
-            if Present (Comp_Type)  and then Controlled_Type (Comp_Type) then
+            --  If the component is itself an array of controlled types, whose
+            --  value is given by a sub-aggregate, then the attach calls have
+            --  been generated when individual subcomponent are assigned, and
+            --  and must not be done again to prevent malformed finalization
+            --  chains (see comments above, concerning the creation of a block
+            --  to hold inner finalization actions).
+
+            if Present (Comp_Type)
+              and then Controlled_Type (Comp_Type)
+              and then
+                (not Is_Array_Type (Comp_Type)
+                   or else not Is_Controlled (Component_Type (Comp_Type))
+                   or else Nkind (Expr) /= N_Aggregate)
+            then
                Append_List_To (L,
                  Make_Adjust_Call (
                    Ref         => New_Copy_Tree (Indexed_Comp),
@@ -1253,7 +1288,17 @@ package body Exp_Aggr is
                           Iteration_Scheme => L_Iteration_Scheme,
                           Statements       => L_Body));
 
-         return S;
+         --  A small optimization: if the aggregate is initialized with a
+         --  box and the component type has no initialization procedure,
+         --  remove the useless empty loop.
+
+         if Nkind (First (S)) = N_Loop_Statement
+           and then Is_Empty_List (Statements (First (S)))
+         then
+            return New_List (Make_Null_Statement (Loc));
+         else
+            return S;
+         end if;
       end Gen_Loop;
 
       ---------------
@@ -1605,7 +1650,7 @@ package body Exp_Aggr is
    function Build_Record_Aggr_Code
      (N                             : Node_Id;
       Typ                           : Entity_Id;
-      Target                        : Node_Id;
+      Lhs                           : Node_Id;
       Flist                         : Node_Id   := Empty;
       Obj                           : Entity_Id := Empty;
       Is_Limited_Ancestor_Expansion : Boolean   := False) return List_Id
@@ -1617,6 +1662,7 @@ package body Exp_Aggr is
       Comp      : Node_Id;
       Instr     : Node_Id;
       Ref       : Node_Id;
+      Target    : Entity_Id;
       F         : Node_Id;
       Comp_Type : Entity_Id;
       Selector  : Entity_Id;
@@ -1639,7 +1685,8 @@ package body Exp_Aggr is
       Attach   : Node_Id;
 
       Ctrl_Stuff_Done : Boolean := False;
-      --  Could use comments here ???
+      --  True if Gen_Ctrl_Actions_For_Aggr has already been called; calls
+      --  after the first do nothing.
 
       function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id;
       --  Returns the value that the given discriminant of an ancestor
@@ -1659,8 +1706,8 @@ package body Exp_Aggr is
       --  assumed that both bounds are integer ranges.
 
       procedure Gen_Ctrl_Actions_For_Aggr;
-      --  Deal with the various controlled type data structure
-      --  initializations.
+      --  Deal with the various controlled type data structure initializations
+      --  (but only if it hasn't been done already).
 
       function Get_Constraint_Association (T : Entity_Id) return Node_Id;
       --  Returns the first discriminant association in the constraint
@@ -1672,10 +1719,10 @@ package body Exp_Aggr is
          F       : Node_Id;
          Attach  : Node_Id;
          Init_Pr : Boolean) return List_Id;
-      --  returns the list of statements necessary to initialize the internal
-      --  controller of the (possible) ancestor typ into target and attach
-      --  it to finalization list F. Init_Pr conditions the call to the
-      --  init proc since it may already be done due to ancestor initialization
+      --  Returns the list of statements necessary to initialize the internal
+      --  controller of the (possible) ancestor typ into target and attach it
+      --  to finalization list F. Init_Pr conditions the call to the init proc
+      --  since it may already be done due to ancestor initialization.
 
       function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean;
       --  Check whether Bounds is a range node and its lower and higher bounds
@@ -1880,7 +1927,7 @@ package body Exp_Aggr is
       end Get_Constraint_Association;
 
       ---------------------
-      -- Init_controller --
+      -- Init_Controller --
       ---------------------
 
       function Init_Controller
@@ -1972,24 +2019,32 @@ package body Exp_Aggr is
       -------------------------------
 
       procedure Gen_Ctrl_Actions_For_Aggr is
+         Alloc : Node_Id := Empty;
+
       begin
-         if not Ctrl_Stuff_Done then
-            Ctrl_Stuff_Done := True;
-         else
+         --  Do the work only the first time this is called
+
+         if Ctrl_Stuff_Done then
             return;
          end if;
 
+         Ctrl_Stuff_Done := True;
+
          if Present (Obj)
-          and then Finalize_Storage_Only (Typ)
-          and then (Is_Library_Level_Entity (Obj)
-            or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) =
-                                                              Standard_True)
+           and then Finalize_Storage_Only (Typ)
+           and then
+             (Is_Library_Level_Entity (Obj)
+                or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) =
+                                                          Standard_True)
+
+            --  why not Is_True (Expr_Value (RTE (RE_Garbaage_Collected) ???
          then
             Attach := Make_Integer_Literal (Loc, 0);
 
          elsif Nkind (Parent (N)) = N_Qualified_Expression
            and then Nkind (Parent (Parent (N))) = N_Allocator
          then
+            Alloc  := Parent (Parent (N));
             Attach := Make_Integer_Literal (Loc, 2);
 
          else
@@ -2003,19 +2058,37 @@ package body Exp_Aggr is
          --  potentially transient current scope.
 
          if Controlled_Type (Typ) then
-            if Present (Flist) then
+
+            --  The current aggregate belongs to an allocator which acts as
+            --  the root of a coextension chain.
+
+            if Present (Alloc)
+              and then Is_Coextension_Root (Alloc)
+            then
+               if No (Associated_Final_Chain (Etype (Alloc))) then
+                  Build_Final_List (Alloc, Etype (Alloc));
+               end if;
+
+               External_Final_List :=
+                 Make_Selected_Component (Loc,
+                   Prefix =>
+                     New_Reference_To (
+                       Associated_Final_Chain (Etype (Alloc)), Loc),
+                   Selector_Name =>
+                     Make_Identifier (Loc, Name_F));
+
+            elsif Present (Flist) then
                External_Final_List := New_Copy_Tree (Flist);
 
             elsif Is_Entity_Name (Target)
               and then Present (Scope (Entity (Target)))
             then
-               External_Final_List
-                 := Find_Final_List (Scope (Entity (Target)));
+               External_Final_List :=
+                 Find_Final_List (Scope (Entity (Target)));
 
             else
                External_Final_List := Find_Final_List (Current_Scope);
             end if;
-
          else
             External_Final_List := Empty;
          end if;
@@ -2037,11 +2110,26 @@ package body Exp_Aggr is
             if not Has_Controlled_Component (Typ) then
                Ref := New_Copy_Tree (Target);
                Set_Assignment_OK (Ref);
-               Append_To (L,
-                 Make_Attach_Call (
-                   Obj_Ref     => Ref,
-                   Flist_Ref   => New_Copy_Tree (External_Final_List),
-                   With_Attach => Attach));
+
+               --  This is an aggregate of a coextension. Do not produce a
+               --  finalization call, but rather attach the reference of the
+               --  aggregate to its coextension chain.
+
+               if Present (Alloc)
+                 and then Is_Coextension (Alloc)
+               then
+                  if No (Coextensions (Alloc)) then
+                     Set_Coextensions (Alloc, New_Elmt_List);
+                  end if;
+
+                  Append_Elmt (Ref, Coextensions (Alloc));
+               else
+                  Append_To (L,
+                    Make_Attach_Call (
+                      Obj_Ref     => Ref,
+                      Flist_Ref   => New_Copy_Tree (External_Final_List),
+                      With_Attach => Attach));
+               end if;
             end if;
          end if;
 
@@ -2162,21 +2250,83 @@ package body Exp_Aggr is
                       Typ     => Init_Typ,
                       F       => F,
                       Attach  => Attach,
-                      Init_Pr => Ancestor_Is_Expression));
+                      Init_Pr => False));
+
+                     --  Note: Init_Pr is False because the ancestor part has
+                     --  already been initialized either way (by default, if
+                     --  given by a type name, otherwise from the expression).
+
                end if;
             end;
          end if;
       end Gen_Ctrl_Actions_For_Aggr;
 
+      function Replace_Type (Expr : Node_Id) return Traverse_Result;
+      --  If the aggregate contains a self-reference, traverse each
+      --  expression to replace a possible self-reference with a reference
+      --  to the proper component of the target of the assignment.
+
+      ------------------
+      -- Replace_Type --
+      ------------------
+
+      function Replace_Type (Expr : Node_Id) return Traverse_Result is
+      begin
+         if Nkind (Expr) = N_Attribute_Reference
+           and  then Is_Entity_Name (Prefix (Expr))
+           and then Is_Type (Entity (Prefix (Expr)))
+         then
+            if Is_Entity_Name (Lhs) then
+               Rewrite (Prefix (Expr),
+                 New_Occurrence_Of (Entity (Lhs), Loc));
+
+            elsif Nkind (Lhs) = N_Selected_Component then
+               Rewrite (Expr,
+                 Make_Attribute_Reference (Loc,
+                   Attribute_Name => Name_Unrestricted_Access,
+                   Prefix         => New_Copy_Tree (Prefix (Lhs))));
+               Set_Analyzed (Parent (Expr), False);
+
+            else
+               Rewrite (Expr,
+                 Make_Attribute_Reference (Loc,
+                   Attribute_Name => Name_Unrestricted_Access,
+                   Prefix         => New_Copy_Tree (Lhs)));
+               Set_Analyzed (Parent (Expr), False);
+            end if;
+         end if;
+
+         return OK;
+      end Replace_Type;
+
+      procedure Replace_Self_Reference is
+        new Traverse_Proc (Replace_Type);
+
    --  Start of processing for Build_Record_Aggr_Code
 
    begin
+      if Has_Self_Reference (N) then
+         Replace_Self_Reference (N);
+      end if;
+
+      --  If the target of the aggregate is class-wide, we must convert it
+      --  to the actual type of the aggregate, so that the proper components
+      --  are visible. We know already that the types are compatible.
+
+      if Present (Etype (Lhs))
+        and then Is_Interface (Etype (Lhs))
+      then
+         Target := Unchecked_Convert_To (Typ, Lhs);
+      else
+         Target := Lhs;
+      end if;
+
       --  Deal with the ancestor part of extension aggregates
       --  or with the discriminants of the root type
 
       if Nkind (N) = N_Extension_Aggregate then
          declare
-            A : constant Node_Id := Ancestor_Part (N);
+            A      : constant Node_Id := Ancestor_Part (N);
             Assign : List_Id;
 
          begin
@@ -2280,7 +2430,7 @@ package body Exp_Aggr is
                   Build_Record_Aggr_Code (
                     N                             => Unqualify (A),
                     Typ                           => Etype (Unqualify (A)),
-                    Target                        => Target,
+                    Lhs                           => Target,
                     Flist                         => Flist,
                     Obj                           => Obj,
                     Is_Limited_Ancestor_Expansion => True));
@@ -2316,15 +2466,14 @@ package body Exp_Aggr is
                Assign := New_List (
                  Make_OK_Assignment_Statement (Loc,
                    Name       => Ref,
-                   Expression => A,
-                   Self_Ref   => Has_Self_Reference (N)));
+                   Expression => A));
                Set_No_Ctrl_Actions (First (Assign));
 
                --  Assign the tag now to make sure that the dispatching call in
-               --  the subsequent deep_adjust works properly (unless Java_VM,
+               --  the subsequent deep_adjust works properly (unless VM_Target,
                --  where tags are implicit).
 
-               if not Java_VM then
+               if VM_Target = No_VM then
                   Instr :=
                     Make_OK_Assignment_Statement (Loc,
                       Name =>
@@ -2343,6 +2492,20 @@ package body Exp_Aggr is
 
                   Set_Assignment_OK (Name (Instr));
                   Append_To (Assign, Instr);
+
+                  --  Ada 2005 (AI-251): If tagged type has progenitors we must
+                  --  also initialize tags of the secondary dispatch tables.
+
+                  if Present (Abstract_Interfaces (Base_Type (Typ)))
+                    and then not
+                      Is_Empty_Elmt_List
+                        (Abstract_Interfaces (Base_Type (Typ)))
+                  then
+                     Init_Secondary_Tags
+                       (Typ        => Base_Type (Typ),
+                        Target     => Target,
+                        Stmts_List => Assign);
+                  end if;
                end if;
 
                --  Call Adjust manually
@@ -2690,19 +2853,18 @@ package body Exp_Aggr is
                Instr :=
                  Make_OK_Assignment_Statement (Loc,
                    Name       => Comp_Expr,
-                   Expression => Expression (Comp),
-                   Self_Ref   => Has_Self_Reference (N));
+                   Expression => Expression (Comp));
 
                Set_No_Ctrl_Actions (Instr);
                Append_To (L, Instr);
 
                --  Adjust the tag if tagged (because of possible view
-               --  conversions), unless compiling for the Java VM
-               --  where tags are implicit.
+               --  conversions), unless compiling for a VM where tags are
+               --  implicit.
 
                --    tmp.comp._tag := comp_typ'tag;
 
-               if Is_Tagged_Type (Comp_Type) and then not Java_VM then
+               if Is_Tagged_Type (Comp_Type) and then VM_Target = No_VM then
                   Instr :=
                     Make_OK_Assignment_Statement (Loc,
                       Name =>
@@ -2762,13 +2924,45 @@ package body Exp_Aggr is
 
                pragma Assert (Present (D_Val));
 
-               Append_To (L,
-               Make_Raise_Constraint_Error (Loc,
-                 Condition =>
-                   Make_Op_Ne (Loc,
-                     Left_Opnd => New_Copy_Tree (Node (D_Val)),
-                     Right_Opnd => Expression (Comp)),
-                 Reason => CE_Discriminant_Check_Failed));
+               --  This check cannot performed for components that are
+               --  constrained by a current instance, because this is not a
+               --  value that can be compared with the actual constraint.
+
+               if Nkind (Node (D_Val)) /= N_Attribute_Reference
+                 or else not Is_Entity_Name (Prefix (Node (D_Val)))
+                 or else not Is_Type (Entity (Prefix (Node (D_Val))))
+               then
+                  Append_To (L,
+                  Make_Raise_Constraint_Error (Loc,
+                    Condition =>
+                      Make_Op_Ne (Loc,
+                        Left_Opnd => New_Copy_Tree (Node (D_Val)),
+                        Right_Opnd => Expression (Comp)),
+                      Reason => CE_Discriminant_Check_Failed));
+
+               else
+                  --  Find self-reference in previous discriminant
+                  --  assignment, and replace with proper expression.
+
+                  declare
+                     Ass : Node_Id;
+
+                  begin
+                     Ass := First (L);
+                     while Present (Ass) loop
+                        if Nkind (Ass) = N_Assignment_Statement
+                          and then Nkind (Name (Ass)) = N_Selected_Component
+                          and then Chars (Selector_Name (Name (Ass))) =
+                             Chars (Disc)
+                        then
+                           Set_Expression
+                             (Ass, New_Copy_Tree (Expression (Comp)));
+                           exit;
+                        end if;
+                        Next (Ass);
+                     end loop;
+                  end;
+               end if;
             end;
          end if;
 
@@ -2785,7 +2979,7 @@ package body Exp_Aggr is
       if Ancestor_Is_Expression then
          null;
 
-      elsif Is_Tagged_Type (Typ) and then not Java_VM then
+      elsif Is_Tagged_Type (Typ) and then VM_Target = No_VM then
          Instr :=
            Make_OK_Assignment_Statement (Loc,
              Name =>
@@ -2878,8 +3072,12 @@ package body Exp_Aggr is
             --  ??? Dubious actual for Obj: expect 'the original object
             --  being initialized'
 
-            Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts);
-            Insert_Actions_After (Decl, L);
+            if Has_Task (Typ) then
+               Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts);
+               Insert_Actions_After (Decl, L);
+            else
+               Insert_Actions_After (Decl, Init_Stmts);
+            end if;
          end;
 
       else
@@ -3010,7 +3208,15 @@ package body Exp_Aggr is
          return;
       end if;
 
-      if Requires_Transient_Scope (Typ) then
+      --  If the context is an extended return statement, it has its own
+      --  finalization machinery (i.e. works like a transient scope) and
+      --  we do not want to create an additional one, because objects on
+      --  the finalization list of the return must be moved to the caller's
+      --  finalization list to complete the return.
+
+      if Requires_Transient_Scope (Typ)
+        and then Ekind (Current_Scope) /= E_Return_Statement
+      then
          Establish_Transient_Scope (Aggr, Sec_Stack =>
            Is_Controlled (Typ) or else Has_Controlled_Component (Typ));
       end if;
@@ -3088,15 +3294,22 @@ package body Exp_Aggr is
       end if;
 
       --  Just set the Delay flag in the following cases where the
-      --  transformation will be done top down from above
+      --  transformation will be done top down from above:
 
       --    - internal aggregate (transformed when expanding the parent)
+
       --    - allocators  (see Convert_Aggr_In_Allocator)
+
       --    - object decl (see Convert_Aggr_In_Object_Decl)
+
       --    - safe assignments (see Convert_Aggr_Assignments)
       --      so far only the assignments in the init procs are taken
       --      into account
 
+      --    - (Ada 2005) A limited type in a return statement, which will
+      --       be rewritten as an extended return and may have its own
+      --       finalization machinery.
+
       if Parent_Kind = N_Aggregate
         or else Parent_Kind = N_Extension_Aggregate
         or else Parent_Kind = N_Component_Association
@@ -3104,6 +3317,10 @@ package body Exp_Aggr is
         or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl)
         or else (Parent_Kind = N_Assignment_Statement
                   and then Inside_Init_Proc)
+        or else
+          (Is_Limited_Record (Typ)
+            and then Present (Parent (Parent (N)))
+            and then Nkind (Parent (Parent (N))) = N_Return_Statement)
       then
          Set_Expansion_Delayed (N);
          return;
@@ -3144,6 +3361,13 @@ package body Exp_Aggr is
    is
       Typ : constant Entity_Id := Etype (N);
 
+      Static_Components : Boolean := True;
+
+      procedure Check_Static_Components;
+      --  Check whether all components of the aggregate are compile-time
+      --  known values, and can be passed as is to the back-end without
+      --  further expansion.
+
       function Flatten
         (N   : Node_Id;
          Ix  : Node_Id;
@@ -3156,6 +3380,56 @@ package body Exp_Aggr is
       --  Return True iff the array N is flat (which is not rivial
       --  in the case of multidimensionsl aggregates).
 
+      -----------------------------
+      -- Check_Static_Components --
+      -----------------------------
+
+      procedure Check_Static_Components is
+         Expr : Node_Id;
+
+      begin
+         Static_Components := True;
+
+         if Nkind (N) = N_String_Literal then
+            null;
+
+         elsif Present (Expressions (N)) then
+            Expr := First (Expressions (N));
+            while Present (Expr) loop
+               if Nkind (Expr) /= N_Aggregate
+                 or else not Compile_Time_Known_Aggregate (Expr)
+                 or else Expansion_Delayed (Expr)
+               then
+                  Static_Components := False;
+                  exit;
+               end if;
+
+               Next (Expr);
+            end loop;
+         end if;
+
+         if Nkind (N) = N_Aggregate
+           and then  Present (Component_Associations (N))
+         then
+            Expr := First (Component_Associations (N));
+            while Present (Expr) loop
+               if Nkind (Expression (Expr)) = N_Integer_Literal then
+                  null;
+
+               elsif Nkind (Expression (Expr)) /= N_Aggregate
+                 or else
+                   not Compile_Time_Known_Aggregate (Expression (Expr))
+                 or else Expansion_Delayed (Expression (Expr))
+               then
+                  Static_Components := False;
+                  exit;
+               end if;
+
+               Next (Expr);
+            end loop;
+         end if;
+      end Check_Static_Components;
+
       -------------
       -- Flatten --
       -------------
@@ -3177,18 +3451,17 @@ package body Exp_Aggr is
             return True;
          end if;
 
-         --  Only handle bounds starting at the base type low bound
-         --  for now since the compiler isn't able to handle different low
-         --  bounds yet. Case such as new String'(3..5 => ' ') will get
-         --  the wrong bounds, though it seems that the aggregate should
-         --  retain the bounds set on its Etype (see C64103E and CC1311B).
+         if not Compile_Time_Known_Value (Lo)
+           or else not Compile_Time_Known_Value (Hi)
+         then
+            return False;
+         end if;
 
          Lov := Expr_Value (Lo);
          Hiv := Expr_Value (Hi);
 
          if Hiv < Lov
            or else not Compile_Time_Known_Value (Blo)
-           or else (Lov /= Expr_Value (Blo))
          then
             return False;
          end if;
@@ -3418,10 +3691,29 @@ package body Exp_Aggr is
          return;
       end if;
 
+      Check_Static_Components;
+
+      --  If the size is known, or all the components are static, try to
+      --  build a fully positional aggregate.
+
+      --  The size of the type  may not be known for an aggregate with
+      --  discriminated array components, but if the components are static
+      --  it is still possible to verify statically that the length is
+      --  compatible with the upper bound of the type, and therefore it is
+      --  worth flattening such aggregates as well.
+
+      --  For now the back-end expands these aggregates into individual
+      --  assignments to the target anyway, but it is conceivable that
+      --  it will eventually be able to treat such aggregates statically???
+
       if Aggr_Size_OK (Typ)
-        and then
-          Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ)))
+        and then Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ)))
       then
+         if Static_Components then
+            Set_Compile_Time_Known_Aggregate (N);
+            Set_Expansion_Delayed (N, False);
+         end if;
+
          Analyze_And_Resolve (N, Typ);
       end if;
    end Convert_To_Positional;
@@ -4393,7 +4685,14 @@ package body Exp_Aggr is
 
       --  At this point we try to convert to positional form
 
-      Convert_To_Positional (N);
+      if Ekind (Current_Scope) = E_Package
+        and then Static_Elaboration_Desired (Current_Scope)
+      then
+         Convert_To_Positional (N, Max_Others_Replicate => 100);
+
+      else
+         Convert_To_Positional (N);
+      end if;
 
       --  if the result is no longer an aggregate (e.g. it may be a string
       --  literal, or a temporary which has the needed value), then we are
@@ -4411,6 +4710,14 @@ package body Exp_Aggr is
          return;
       end if;
 
+      --  If all aggregate components are compile-time known and
+      --  the aggregate has been flattened, nothing left to do.
+
+      if Compile_Time_Known_Aggregate (N) then
+         Set_Expansion_Delayed (N, False);
+         return;
+      end if;
+
       --  Now see if back end processing is possible
 
       if Backend_Processing_Possible (N) then
@@ -4467,8 +4774,15 @@ package body Exp_Aggr is
         or else (Parent_Kind = N_Assignment_Statement
                   and then Inside_Init_Proc)
       then
-         Set_Expansion_Delayed (N);
-         return;
+         if Static_Array_Aggregate (N)
+           or else Compile_Time_Known_Aggregate (N)
+         then
+            Set_Expansion_Delayed (N, False);
+            return;
+         else
+            Set_Expansion_Delayed (N);
+            return;
+         end if;
       end if;
 
       --  STEP 4
@@ -4682,7 +4996,6 @@ package body Exp_Aggr is
       else
          Expand_Array_Aggregate (N);
       end if;
-
    exception
       when RE_Not_Available =>
          return;
@@ -4721,17 +5034,16 @@ package body Exp_Aggr is
       else
          Set_Etype (N, Typ);
 
-         --  No tag is needed in the case of Java_VM
-
-         if Java_VM then
-            Expand_Record_Aggregate (N,
-              Parent_Expr => A);
-         else
+         if VM_Target = No_VM then
             Expand_Record_Aggregate (N,
               Orig_Tag    =>
                 New_Occurrence_Of
                   (Node (First_Elmt (Access_Disp_Table (Typ))), Loc),
               Parent_Expr => A);
+         else
+            --  No tag is needed in the case of a VM
+            Expand_Record_Aggregate (N,
+              Parent_Expr => A);
          end if;
       end if;
 
@@ -4754,15 +5066,23 @@ package body Exp_Aggr is
       Typ      : constant Entity_Id  := Etype (N);
       Base_Typ : constant Entity_Id  := Base_Type (Typ);
 
-      function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean;
-      --  Checks the presence of a nested aggregate which needs Late_Expansion
-      --  or the presence of tagged components which may need tag adjustment.
+      Static_Components : Boolean := True;
+      --  Flag to indicate whether all components are compile-time known,
+      --  and the aggregate can be constructed statically and handled by
+      --  the back-end.
 
-      --------------------------------------------------
-      -- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps --
-      --------------------------------------------------
+      function Component_Not_OK_For_Backend return Boolean;
+      --  Check for presence of component which makes it impossible for the
+      --  backend to process the aggregate, thus requiring the use of a series
+      --  of assignment statements. Cases checked for are a nested aggregate
+      --  needing Late_Expansion, the presence of a tagged component which may
+      --  need tag adjustment, and a bit unaligned component reference.
 
-      function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean is
+      ----------------------------------
+      -- Component_Not_OK_For_Backend --
+      ----------------------------------
+
+      function Component_Not_OK_For_Backend return Boolean is
          C      : Node_Id;
          Expr_Q : Node_Id;
 
@@ -4784,27 +5104,44 @@ package body Exp_Aggr is
             --  These are cases where the source expression may have
             --  a tag that could differ from the component tag (e.g.,
             --  can occur for type conversions and formal parameters).
-            --  (Tag adjustment is not needed if Java_VM because object
+            --  (Tag adjustment is not needed if VM_Target because object
             --  tags are implicit in the JVM.)
 
             if Is_Tagged_Type (Etype (Expr_Q))
               and then (Nkind (Expr_Q) = N_Type_Conversion
-                or else (Is_Entity_Name (Expr_Q)
-                          and then Ekind (Entity (Expr_Q)) in Formal_Kind))
-              and then not Java_VM
+                         or else (Is_Entity_Name (Expr_Q)
+                                   and then
+                                    Ekind (Entity (Expr_Q)) in Formal_Kind))
+              and then VM_Target = No_VM
             then
+               Static_Components := False;
                return True;
-            end if;
 
-            if Is_Delayed_Aggregate (Expr_Q) then
+            elsif Is_Delayed_Aggregate (Expr_Q) then
+               Static_Components := False;
+               return True;
+
+            elsif Possible_Bit_Aligned_Component (Expr_Q) then
+               Static_Components := False;
                return True;
             end if;
 
+            if Is_Scalar_Type (Etype (Expr_Q)) then
+               if not Compile_Time_Known_Value (Expr_Q) then
+                  Static_Components := False;
+               end if;
+
+            elsif Nkind (Expr_Q) /= N_Aggregate
+              or else not Compile_Time_Known_Aggregate (Expr_Q)
+            then
+               Static_Components := False;
+            end if;
+
             Next (C);
          end loop;
 
          return False;
-      end Has_Delayed_Nested_Aggregate_Or_Tagged_Comps;
+      end Component_Not_OK_For_Backend;
 
       --  Remaining Expand_Record_Aggregate variables
 
@@ -4860,7 +5197,9 @@ package body Exp_Aggr is
       elsif Has_Default_Init_Comps (N) then
          Convert_To_Assignments (N, Typ);
 
-      elsif Has_Delayed_Nested_Aggregate_Or_Tagged_Comps then
+      --  Check components
+
+      elsif Component_Not_OK_For_Backend then
          Convert_To_Assignments (N, Typ);
 
       --  If an ancestor is private, some components are not inherited and
@@ -4875,6 +5214,13 @@ package body Exp_Aggr is
       elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then
          Convert_To_Assignments (N, Typ);
 
+      --  If the tagged types covers interface types we need to initialize all
+      --  the hidden components containing the pointers to secondary dispatch
+      --  tables.
+
+      elsif Is_Tagged_Type (Typ) and then Has_Abstract_Interfaces (Typ) then
+         Convert_To_Assignments (N, Typ);
+
       --  If some components are mutable, the size of the aggregate component
       --  may be disctinct from the default size of the type component, so
       --  we need to expand to insure that the back-end copies the proper
@@ -4893,6 +5239,17 @@ package body Exp_Aggr is
       --  can be handled by gigi.
 
       else
+         if Nkind (N) = N_Aggregate then
+
+            --  If the aggregate is static and can be handled by the
+            --  back-end, nothing left to do.
+
+            if Static_Components then
+               Set_Compile_Time_Known_Aggregate (N);
+               Set_Expansion_Delayed (N, False);
+            end if;
+         end if;
+
          --  If no discriminants, nothing special to do
 
          if not Has_Discriminants (Typ) then
@@ -5092,7 +5449,7 @@ package body Exp_Aggr is
 
             if Present (Orig_Tag) then
                Tag_Value := Orig_Tag;
-            elsif Java_VM then
+            elsif VM_Target /= No_VM then
                Tag_Value := Empty;
             else
                Tag_Value :=
@@ -5154,9 +5511,9 @@ package body Exp_Aggr is
                end;
 
             --  For a root type, the tag component is added (unless compiling
-            --  for the Java VM, where tags are implicit).
+            --  for the VMs, where tags are implicit).
 
-            elsif not Java_VM then
+            elsif VM_Target = No_VM then
                declare
                   Tag_Name  : constant Node_Id :=
                                 New_Occurrence_Of
@@ -5175,6 +5532,7 @@ package body Exp_Aggr is
             end if;
          end if;
       end if;
+
    end Expand_Record_Aggregate;
 
    ----------------------------
@@ -5284,50 +5642,11 @@ package body Exp_Aggr is
    function Make_OK_Assignment_Statement
      (Sloc       : Source_Ptr;
       Name       : Node_Id;
-      Expression : Node_Id;
-      Self_Ref   : Boolean := False) return Node_Id
+      Expression : Node_Id) return Node_Id
    is
-      function Replace_Type (Expr : Node_Id) return Traverse_Result;
-      --  If the aggregate contains a self-reference, traverse each
-      --  expression to replace a possible self-reference with a reference
-      --  to the proper component of the target of the assignment.
-
-      ------------------
-      -- Replace_Type --
-      ------------------
-
-      function Replace_Type (Expr : Node_Id) return Traverse_Result is
-      begin
-         if Nkind (Expr) = N_Attribute_Reference
-           and  then Is_Entity_Name (Prefix (Expr))
-           and then Is_Type (Entity (Prefix (Expr)))
-         then
-            if Is_Entity_Name (Prefix (Name)) then
-               Rewrite (Prefix (Expr),
-                 New_Occurrence_Of (Entity (Prefix (Name)), Sloc));
-            else
-               Rewrite (Expr,
-                 Make_Attribute_Reference (Sloc,
-                   Attribute_Name => Name_Unrestricted_Access,
-                   Prefix         => New_Copy_Tree (Prefix (Name))));
-               Set_Analyzed (Parent (Expr), False);
-            end if;
-         end if;
-         return OK;
-      end Replace_Type;
-
-      procedure Replace_Self_Reference is
-        new Traverse_Proc (Replace_Type);
-
-   --  Start of processing for Make_OK_Assignment_Statement
-
    begin
       Set_Assignment_OK (Name);
 
-      if Self_Ref then
-         Replace_Self_Reference (Expression);
-      end if;
-
       return Make_Assignment_Statement (Sloc, Name, Expression);
    end Make_OK_Assignment_Statement;
 
@@ -5393,6 +5712,12 @@ package body Exp_Aggr is
          return False;
       end if;
 
+      if not Is_Scalar_Type (Component_Type (Typ))
+        and then Has_Non_Standard_Rep (Component_Type (Typ))
+      then
+         return False;
+      end if;
+
       declare
          Csiz  : constant Nat := UI_To_Int (Component_Size (Typ));
 
@@ -5774,4 +6099,109 @@ package body Exp_Aggr is
       end loop;
    end Sort_Case_Table;
 
+   ----------------------------
+   -- Static_Array_Aggregate --
+   ----------------------------
+
+   function Static_Array_Aggregate (N : Node_Id) return Boolean is
+      Bounds : constant Node_Id := Aggregate_Bounds (N);
+
+      Typ       : constant Entity_Id := Etype (N);
+      Comp_Type : constant Entity_Id := Component_Type (Typ);
+      Agg       : Node_Id;
+      Expr      : Node_Id;
+      Lo        : Node_Id;
+      Hi        : Node_Id;
+
+   begin
+      if Is_Tagged_Type (Typ)
+        or else Is_Controlled (Typ)
+        or else Is_Packed (Typ)
+      then
+         return False;
+      end if;
+
+      if Present (Bounds)
+        and then Nkind (Bounds) = N_Range
+        and then Nkind (Low_Bound  (Bounds)) = N_Integer_Literal
+        and then Nkind (High_Bound (Bounds)) = N_Integer_Literal
+      then
+         Lo := Low_Bound  (Bounds);
+         Hi := High_Bound (Bounds);
+
+         if No (Component_Associations (N)) then
+
+            --  Verify that all components are static integers.
+
+            Expr := First (Expressions (N));
+            while Present (Expr) loop
+               if Nkind (Expr) /= N_Integer_Literal then
+                  return False;
+               end if;
+
+               Next (Expr);
+            end loop;
+
+            return True;
+
+         else
+            --  We allow only a single named association, either a static
+            --  range or an others_clause, with a static expression.
+
+            Expr := First (Component_Associations (N));
+
+            if Present (Expressions (N)) then
+               return False;
+
+            elsif Present (Next (Expr)) then
+               return False;
+
+            elsif Present (Next (First (Choices (Expr)))) then
+               return False;
+
+            else
+               --  The aggregate is static if all components are literals,
+               --  or else all its components are static aggregates for the
+               --  component type.
+
+               if Is_Array_Type (Comp_Type)
+                 or else Is_Record_Type (Comp_Type)
+               then
+                  if Nkind (Expression (Expr)) /= N_Aggregate
+                    or else
+                      not Compile_Time_Known_Aggregate (Expression (Expr))
+                  then
+                     return False;
+                  end if;
+
+               elsif Nkind (Expression (Expr)) /= N_Integer_Literal then
+                  return False;
+               end if;
+
+               --  Create a positional aggregate with the right number of
+               --  copies of the expression.
+
+               Agg := Make_Aggregate (Sloc (N), New_List, No_List);
+
+               for I in UI_To_Int (Intval (Lo)) .. UI_To_Int (Intval (Hi))
+               loop
+                  Append_To
+                    (Expressions (Agg), New_Copy (Expression (Expr)));
+                  Set_Etype (Last (Expressions (Agg)), Component_Type (Typ));
+               end loop;
+
+               Set_Aggregate_Bounds (Agg, Bounds);
+               Set_Etype (Agg, Typ);
+               Set_Analyzed (Agg);
+               Rewrite (N, Agg);
+               Set_Compile_Time_Known_Aggregate (N);
+
+               return True;
+            end if;
+         end if;
+
+      else
+         return False;
+      end if;
+   end Static_Array_Aggregate;
 end Exp_Aggr;
diff --git a/gcc/ada/exp_aggr.ads b/gcc/ada/exp_aggr.ads
index 65897df..4a26511 100644
--- a/gcc/ada/exp_aggr.ads
+++ b/gcc/ada/exp_aggr.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -47,6 +47,16 @@ package Exp_Aggr is
    --  assignment in the newly allocated object.
 
    procedure Convert_Aggr_In_Assignment (N : Node_Id);
-   --  ??? documentation needed
-
+   --  If the right-hand side of an assignment is an aggregate, expand the
+   --  statement into a series of individual component assignments. This is
+   --  done if there are non-static values involved in either the bounds or
+   --  the components, and the aggregate cannot be handled as a whole by the
+   --  backend.
+
+   function Static_Array_Aggregate (N : Node_Id) return Boolean;
+   --  N is an array aggregate that may have a component association with
+   --  an others clause and a range. If bounds are static and the expressions
+   --  are compile-time known constants, rewrite N as a purely positional
+   --  aggregate, to be use to initialize variables and components of the type
+   --  without generating elaboration code.
 end Exp_Aggr;