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 dfb164b..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);
@@ -1252,6 +1265,12 @@ package body Exp_Aggr is
       function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is
          L_J : Node_Id;
 
+         L_L : Node_Id;
+         --  Index_Base'(L)
+
+         L_H : Node_Id;
+         --  Index_Base'(H)
+
          L_Range : Node_Id;
          --  Index_Base'(L) .. Index_Base'(H)
 
@@ -1330,19 +1349,32 @@ package body Exp_Aggr is
 
          L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
 
-         --  Construct "L .. H"
+         --  Construct "L .. H" in Index_Base. We use a qualified expression
+         --  for the bound to convert to the index base, but we don't need
+         --  to do that if we already have the base type at hand.
+
+         if Etype (L) = Index_Base then
+            L_L := L;
+         else
+            L_L :=
+              Make_Qualified_Expression (Loc,
+                Subtype_Mark => Index_Base_Name,
+                Expression   => L);
+         end if;
+
+         if Etype (H) = Index_Base then
+            L_H := H;
+         else
+            L_H :=
+              Make_Qualified_Expression (Loc,
+                Subtype_Mark => Index_Base_Name,
+                Expression   => H);
+         end if;
 
          L_Range :=
-           Make_Range
-             (Loc,
-              Low_Bound  => Make_Qualified_Expression
-                              (Loc,
-                               Subtype_Mark => Index_Base_Name,
-                               Expression   => L),
-              High_Bound => Make_Qualified_Expression
-                              (Loc,
-                               Subtype_Mark => Index_Base_Name,
-                               Expression => H));
+           Make_Range (Loc,
+             Low_Bound => L_L,
+             High_Bound => L_H);
 
          --  Construct "for L_J in Index_Base range L .. H"
 
@@ -2546,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
@@ -3266,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
@@ -3641,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).
 
       -----------------------------
@@ -3879,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
@@ -4603,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))));