[multiple changes]

2014-10-20  Robert Dewar  <dewar@adacore.com>

	* sem_ch3.adb, prj-proc.adb, sem_ch4.adb, prj-env.adb, lib.ads,
	sem_ch13.adb: Minor reformatting.

2014-10-20  Javier Miranda  <miranda@adacore.com>

	* exp_ch3.adb (Expand_N_Object_Declaration): Expand the
	declaration of a class-wide limited object containing an
	initializing expression into a renaming declaration.  Required to
	avoid passing such declaration to the backend and also to avoid
	generating an extra copy.

From-SVN: r216475

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index e8a7143a044927a0b1a50cea8674a33ddcdcc5b3..3939bafd83073e29bbd563fd117aa1966b7a9ac8 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,16 @@
+2014-10-20  Robert Dewar  <dewar@adacore.com>
+
+       * sem_ch3.adb, prj-proc.adb, sem_ch4.adb, prj-env.adb, lib.ads,
+       sem_ch13.adb: Minor reformatting.
+
+2014-10-20  Javier Miranda  <miranda@adacore.com>
+
+       * exp_ch3.adb (Expand_N_Object_Declaration): Expand the
+       declaration of a class-wide limited object containing an
+       initializing expression into a renaming declaration.  Required to
+       avoid passing such declaration to the backend and also to avoid
+       generating an extra copy.
+
 2014-10-20  Eric Botcazou  <ebotcazou@adacore.com>
 
        * inline.adb (List_Inlining_Info): Minor tweaks.

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index d57fadca63967fa467f7876521f09ed7f7aacf84..330e168425afc7edab7f6d9e97297c003d802bc7 100644 (file)
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -5875,6 +5875,29 @@ package body Exp_Ch3 is
                Set_Expression (N, Empty);
                return;
 
+            --  Handle initialization of limited tagged types
+
+            elsif Is_Tagged_Type (Typ)
+              and then Is_Class_Wide_Type (Typ)
+              and then Is_Limited_Record (Typ)
+            then
+               --  Given that the type is limited we cannot perform a copy. If
+               --  Expr_Q is the reference to a variable we mark the variable
+               --  as OK_To_Rename to expand this declaration into a renaming
+               --  declaration (see bellow).
+
+               if Is_Entity_Name (Expr_Q) then
+                  Set_OK_To_Rename (Entity (Expr_Q));
+
+               --  If we cannot convert the expression into a renaming we must
+               --  consider it an internal error because the backend does not
+               --  have support to handle it.
+
+               else
+                  pragma Assert (False);
+                  raise Program_Error;
+               end if;
+
             --  For discrete types, set the Is_Known_Valid flag if the
             --  initializing value is known to be valid. Only do this for
             --  source assignments, since otherwise we can end up turning

diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads
index 4a9f7deac5f5911658244262d94a3272a651825f..5bbd4119f2d0708bbe584de20b3e48da3119988a 100644 (file)
--- a/gcc/ada/lib.ads
+++ b/gcc/ada/lib.ads
@@ -750,6 +750,8 @@ private
    pragma Inline (Unit_File_Name);
    pragma Inline (Unit_Name);
 
+   --  The Units Table
+
    type Unit_Record is record
       Unit_File_Name    : File_Name_Type;
       Unit_Name         : Unit_Name_Type;

diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb
index ac5b69f0a97622bf9449412bba202389e2a9d358..b6bb25fcbf8666949f96c95361b03ffafef274df 100644 (file)
--- a/gcc/ada/prj-env.adb
+++ b/gcc/ada/prj-env.adb
@@ -1425,10 +1425,8 @@ package body Prj.Env is
      (Self : Project_Search_Path;
       Name : String) return String_Access
    is
-
-      function Find_Rts_In_Path is new Prj.Env.Find_Name_In_Path
-        (Check_Filename => Is_Directory);
-
+      function Find_Rts_In_Path is
+        new Prj.Env.Find_Name_In_Path (Check_Filename => Is_Directory);
    begin
       return Find_Rts_In_Path (Self, Name);
    end Get_Runtime_Path;

diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb
index f0669f2a294febe5050ae7379fe311ed3119ed11..2b865a27fd730e9d6011aff3798cbf720800ac39 100644 (file)
--- a/gcc/ada/prj-proc.adb
+++ b/gcc/ada/prj-proc.adb
@@ -909,6 +909,7 @@ package body Prj.Proc is
 
                         elsif The_Variable.Default then
                            case The_Variable.Kind is
+
                            when Undefined =>
                               null;
 

diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 8b716f47584b9f6fa6bb5b36968c80bcc6dfdc21..211d9675681f596ea7d5f4cc2891b57f060c6341 100644 (file)
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1677,7 +1677,7 @@ package body Sem_Ch13 is
                   then
                      Error_Msg_N
                        ("indexing aspect can only apply to a tagged type",
-                         Aspect);
+                        Aspect);
                      goto Continue;
                   end if;
 
@@ -2711,7 +2711,7 @@ package body Sem_Ch13 is
 
                when Aspect_Default_Component_Value =>
                   if not (Is_Array_Type (E)
-                            and then Is_Scalar_Type (Component_Type (E)))
+                           and then Is_Scalar_Type (Component_Type (E)))
                   then
                      Error_Msg_N ("aspect Default_Component_Value can only "
                        & "apply to an array of scalar components", N);

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index fcc6e1f9ac2bb1219a4720cf4d1334094c4e49e4..911198f325e3c1f2b166edc82d2e8dbd2931dcf6 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -2237,8 +2237,7 @@ package body Sem_Ch3 is
          Set_Null_Present (Spec, False);
 
          Insert_Before_And_Analyze (Body_Decl,
-           Make_Subprogram_Declaration (Loc,
-             Specification => Spec));
+           Make_Subprogram_Declaration (Loc, Specification => Spec));
       end Handle_Late_Controlled_Primitive;
 
       --------------------------------
@@ -3003,7 +3002,8 @@ package body Sem_Ch3 is
                   T := It.Typ;
 
                elsif It.Typ = Universal_Real
-                 or else It.Typ = Universal_Integer
+                       or else
+                     It.Typ = Universal_Integer
                then
                   --  Choose universal interpretation over any other
 
@@ -4883,8 +4883,8 @@ package body Sem_Ch3 is
         and then
           (Nkind (Parent (Generic_Parent_Type (N))) /=
                                               N_Formal_Type_Declaration
-            or else Nkind
-              (Formal_Type_Definition (Parent (Generic_Parent_Type (N)))) /=
+            or else Nkind (Formal_Type_Definition
+                            (Parent (Generic_Parent_Type (N)))) /=
                                               N_Formal_Private_Type_Definition)
       then
          if Is_Tagged_Type (Id) then
@@ -5329,10 +5329,9 @@ package body Sem_Ch3 is
          Set_Component_Size    (Implicit_Base, Uint_0);
          Set_Packed_Array_Impl_Type (Implicit_Base, Empty);
          Set_Has_Controlled_Component
-                               (Implicit_Base, Has_Controlled_Component
-                                                        (Element_Type)
-                                                 or else Is_Controlled
-                                                        (Element_Type));
+                               (Implicit_Base,
+                                  Has_Controlled_Component (Element_Type)
+                                    or else Is_Controlled  (Element_Type));
          Set_Finalize_Storage_Only
                                (Implicit_Base, Finalize_Storage_Only
                                                         (Element_Type));
@@ -6490,9 +6489,7 @@ package body Sem_Ch3 is
       --  If we did not have a range constraint, then set the range from the
       --  parent type. Otherwise, the Process_Subtype call has set the bounds.
 
-      if No_Constraint
-        or else not Has_Range_Constraint (Indic)
-      then
+      if No_Constraint or else not Has_Range_Constraint (Indic) then
          Set_Scalar_Range (Derived_Type,
            Make_Range (Loc,
              Low_Bound  => New_Copy_Tree (Type_Low_Bound  (Parent_Type)),
@@ -7695,7 +7692,7 @@ package body Sem_Ch3 is
          if not Has_Discriminants (Parent_Base)
            or else
              (Has_Unknown_Discriminants (Parent_Base)
-                and then Is_Private_Type (Parent_Base))
+               and then Is_Private_Type (Parent_Base))
          then
             Error_Msg_N
               ("invalid constraint: type has no discriminant",
@@ -8636,8 +8633,7 @@ package body Sem_Ch3 is
 
       --  Set SSO default for record or array type
 
-      if (Is_Array_Type (Derived_Type)
-           or else Is_Record_Type (Derived_Type))
+      if (Is_Array_Type (Derived_Type) or else Is_Record_Type (Derived_Type))
         and then Is_Base_Type (Derived_Type)
       then
          Set_Default_SSO (Derived_Type);
@@ -8818,7 +8814,8 @@ package body Sem_Ch3 is
       --  and in family bounds.
 
       if Is_Concurrent_Type (Current_Scope)
-        or else Is_Limited_Type (Current_Scope)
+           or else
+         Is_Limited_Type    (Current_Scope)
       then
          CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
 
@@ -11878,14 +11875,17 @@ package body Sem_Ch3 is
          Constrain_Discriminated_Type (Desig_Subtype, S, Related_Nod,
            For_Access => True);
 
-      elsif (Is_Task_Type (Desig_Type) or else Is_Protected_Type (Desig_Type))
+      elsif Is_Concurrent_Type (Desig_Type)
         and then not Is_Constrained (Desig_Type)
       then
          Constrain_Concurrent (Desig_Subtype, S, Related_Nod, Desig_Type, ' ');
 
       else
          Error_Msg_N ("invalid constraint on access type", S);
-         Desig_Subtype := Desig_Type; -- Ignore invalid constraint
+
+         --  We simply ignore an invalid constraint
+
+         Desig_Subtype := Desig_Type;
          Constraint_OK := False;
       end if;
 
@@ -15517,7 +15517,8 @@ package body Sem_Ch3 is
 
       if Present (Discriminant_Specifications (N)) then
          if (Is_Elementary_Type (Parent_Type)
-              or else Is_Array_Type (Parent_Type))
+               or else
+             Is_Array_Type      (Parent_Type))
            and then not Error_Posted (N)
          then
             Error_Msg_N
@@ -20048,12 +20049,11 @@ package body Sem_Ch3 is
          if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type
            and then
              not (Ada_Version >= Ada_2005
-                    and then
-                       (Nkind (Parent (T)) = N_Subtype_Declaration
-                          or else
-                            (Nkind (Parent (T)) = N_Subtype_Indication
-                               and then Nkind (Parent (Parent (T))) =
-                                          N_Subtype_Declaration)))
+                   and then
+                     (Nkind (Parent (T)) = N_Subtype_Declaration
+                       or else (Nkind (Parent (T)) = N_Subtype_Indication
+                                 and then Nkind (Parent (Parent (T))) =
+                                                   N_Subtype_Declaration)))
          then
             Error_Msg_N ("invalid use of type before its full declaration", T);
          end if;

diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 167aae85c73ab70f27cfd04d60d277687803de0f..be1b321b253e0213e8067c1e605333b60239a08e 100644 (file)
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -2198,10 +2198,10 @@ package body Sem_Ch4 is
               and then Is_Discrete_Type (Entity (Actual))
             then
                Replace (N,
-                  Make_Slice (Loc,
-                    Prefix => P,
-                    Discrete_Range =>
-                       New_Occurrence_Of (Entity (Actual), Loc)));
+                 Make_Slice (Loc,
+                   Prefix         => P,
+                   Discrete_Range =>
+                     New_Occurrence_Of (Entity (Actual), Loc)));
                Analyze (N);
                return;