2010-01-27 Vincent Celier <celier@adacore.com>

[pf3gnuchains/gcc-fork.git] / gcc / ada / exp_aggr.adb

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 15338e4..6e3edc1 100644 (file)
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -56,6 +56,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;
 
@@ -216,7 +217,7 @@ package body Exp_Aggr is
 
    function Backend_Processing_Possible (N : Node_Id) return Boolean;
    --  This function checks if array aggregate N can be processed directly
-   --  by Gigi. If this is the case True is returned.
+   --  by the backend. If this is the case True is returned.
 
    function Build_Array_Aggr_Code
      (N           : Node_Id;
@@ -508,6 +509,8 @@ package body Exp_Aggr is
 
    --   10. No controlled actions need to be generated for components
 
+   --   11. For a VM back end, the array should have no aliased components
+
    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
@@ -634,6 +637,16 @@ package body Exp_Aggr is
          return False;
       end if;
 
+      --  Checks 11: Array aggregates with aliased components are currently
+      --  not well supported by the VM backend; disable temporarily this
+      --  backend processing until it is definitely supported.
+
+      if VM_Target /= No_VM
+        and then Has_Aliased_Components (Base_Type (Typ))
+      then
+         return False;
+      end if;
+
       --  Backend processing is possible
 
       Set_Size_Known_At_Compile_Time (Etype (N), True);
@@ -2565,19 +2578,21 @@ package body Exp_Aggr is
                Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
                Set_Assignment_OK (Ref);
 
-               Append_List_To (L,
-                 Build_Initialization_Call (Loc,
-                   Id_Ref            => Ref,
-                   Typ               => Init_Typ,
-                   In_Init_Proc      => Within_Init_Proc,
-                   With_Default_Init => Has_Default_Init_Comps (N)
-                                          or else
-                                        Has_Task (Base_Type (Init_Typ))));
-
-               if Is_Constrained (Entity (A))
-                 and then Has_Discriminants (Entity (A))
-               then
-                  Check_Ancestor_Discriminants (Entity (A));
+               if not Is_Interface (Init_Typ) then
+                  Append_List_To (L,
+                    Build_Initialization_Call (Loc,
+                      Id_Ref            => Ref,
+                      Typ               => Init_Typ,
+                      In_Init_Proc      => Within_Init_Proc,
+                      With_Default_Init => Has_Default_Init_Comps (N)
+                                             or else
+                                           Has_Task (Base_Type (Init_Typ))));
+
+                  if Is_Constrained (Entity (A))
+                    and then Has_Discriminants (Entity (A))
+                  then
+                     Check_Ancestor_Discriminants (Entity (A));
+                  end if;
                end if;
 
             --  Handle calls to C++ constructors
@@ -3285,8 +3300,14 @@ package body Exp_Aggr is
                                               N_Discriminant_Specification
       then
          Flist := Empty;
-      else
+
+      elsif Needs_Finalization (Typ) then
          Flist := Find_Final_List (Access_Type);
+
+      --  Otherwise there are no controlled actions to be performed.
+
+      else
+         Flist := Empty;
       end if;
 
       if Is_Array_Type (Typ) then
@@ -3660,7 +3681,7 @@ package body Exp_Aggr is
       --  total number of components is safe enough to expand.
 
       function Is_Flat (N : Node_Id; Dims : Int) return Boolean;
-      --  Return True iff the array N is flat (which is not rivial in the case
+      --  Return True iff the array N is flat (which is not trivial in the case
       --  of multidimensionsl aggregates).
 
       -----------------------------
@@ -3898,7 +3919,7 @@ package body Exp_Aggr is
                      end if;
                   end if;
 
-                  --  Range cases merge with Lo,Hi said
+                  --  Range cases merge with Lo,Hi set
 
                   if not Compile_Time_Known_Value (Lo)
                        or else
@@ -4622,6 +4643,7 @@ package body Exp_Aggr is
             end if;
 
             Aggr_In := First_Index (Etype (N));
+
             if Nkind (Parent (N)) = N_Assignment_Statement then
                Obj_In  := First_Index (Etype (Name (Parent (N))));