[multiple changes]

2009-04-07  Robert Dewar  <dewar@adacore.com>

	* sem_warn.adb (Check_Infinite_Loop_Warning.Test_Ref): Add defence
	against missing parent.

2009-04-07  Thomas Quinot  <quinot@adacore.com>

	* xoscons.adb: Minor reformatting

2009-04-07  Robert Dewar  <dewar@adacore.com>

	* rtsfind.ads: Remove obsolete string concatenation entries

2009-04-07  Robert Dewar  <dewar@adacore.com>

	* exp_ch4.adb (Expand_Concatenate): Redo handling of bounds

2009-04-07  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch10.adb (Check_Body_Required): Handle properly imported
	subprograms.

2009-04-07  Gary Dismukes  <dismukes@adacore.com>

	* exp_ch13.adb (Expand_N_Attribute_Definition_Clause, case
	Attribute_Address): When Init_Or_Norm_Scalars is True and the object
	is of a scalar or string type then suppress the setting of the
	expression to Empty.

	* freeze.adb (Warn_Overlay): Also emit the warnings about default
	initialization for the cases of scalar and string objects when
	Init_Or_Norm_Scalars is True.

From-SVN: r145694

7 files changed, 360 insertions, 150 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index e5fbcba..9211323 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,36 @@
+2009-04-07  Robert Dewar  <dewar@adacore.com>
+
+	* sem_warn.adb (Check_Infinite_Loop_Warning.Test_Ref): Add defence
+	against missing parent.
+
+2009-04-07  Thomas Quinot  <quinot@adacore.com>
+
+	* xoscons.adb: Minor reformatting
+
+2009-04-07  Robert Dewar  <dewar@adacore.com>
+
+	* rtsfind.ads: Remove obsolete string concatenation entries
+
+2009-04-07  Robert Dewar  <dewar@adacore.com>
+
+	* exp_ch4.adb (Expand_Concatenate): Redo handling of bounds
+
+2009-04-07  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch10.adb (Check_Body_Required): Handle properly imported
+	subprograms.
+
+2009-04-07  Gary Dismukes  <dismukes@adacore.com>
+
+	* exp_ch13.adb (Expand_N_Attribute_Definition_Clause, case
+	Attribute_Address): When Init_Or_Norm_Scalars is True and the object
+	is of a scalar or string type then suppress the setting of the
+	expression to Empty.
+
+	* freeze.adb (Warn_Overlay): Also emit the warnings about default
+	initialization for the cases of scalar and string objects when
+	Init_Or_Norm_Scalars is True.
+
 2009-04-07  Bob Duff  <duff@adacore.com>
 
 	* s-secsta.ads, g-pehage.ads, s-fileio.ads: Minor comment fixes
diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb
index af94e1d..ebfd212 100644
--- a/gcc/ada/exp_ch13.adb
+++ b/gcc/ada/exp_ch13.adb
@@ -34,6 +34,7 @@ with Exp_Util; use Exp_Util;
 with Namet;    use Namet;
 with Nlists;   use Nlists;
 with Nmake;    use Nmake;
+with Opt;      use Opt;
 with Rtsfind;  use Rtsfind;
 with Sem;      use Sem;
 with Sem_Ch7;  use Sem_Ch7;
@@ -91,6 +92,14 @@ package body Exp_Ch13 is
             --  call to the init proc, and must be respected. Note that for
             --  packed types we do not build equivalent aggregates.
 
+            --  Also, if Init_Or_Norm_Scalars applies, then we need to retain
+            --  any default initialization for objects of scalar types and
+            --  types with scalar components. Normally a composite type will
+            --  have an init_proc in the presence of Init_Or_Norm_Scalars,
+            --  so when that flag is set we have just have to do a test for
+            --  scalar and string types (the predefined string types such as
+            --  String and Wide_String don't have an init_proc).
+
             declare
                Decl : constant Node_Id := Declaration_Node (Ent);
                Typ  : constant Entity_Id := Etype (Ent);
@@ -106,6 +115,13 @@ package body Exp_Ch13 is
                       Present (Static_Initialization (Base_Init_Proc (Typ)))
                   then
                      null;
+
+                  elsif Init_Or_Norm_Scalars
+                    and then
+                      (Is_Scalar_Type (Typ) or else Is_String_Type (Typ))
+                  then
+                     null;
+
                   else
                      Set_Expression (Decl, Empty);
                   end if;
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index fb11644..df1d2bb 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -2158,6 +2158,12 @@ package body Exp_Ch4 is
       Concatenation_Error : exception;
       --  Raised if concatenation is sure to raise a CE
 
+      Result_May_Be_Null : Boolean := True;
+      --  Reset to False if at least one operand is encountered which is known
+      --  at compile time to be non-null. Used for handling the special case
+      --  of setting the high bound to the last operand high bound for a null
+      --  result, thus ensuring a proper high bound in the super-flat case.
+
       N : constant Nat := List_Length (Opnds);
       --  Number of concatenation operands including possibly null operands
 
@@ -2177,38 +2183,47 @@ package body Exp_Ch4 is
       --  Set to length of operand. Entries in this array are set only if the
       --  corresponding entry in Is_Fixed_Length is True.
 
-      Fixed_Low_Bound : array (1 .. N) of Uint;
-      --  Set to lower bound of operand. Entries in this array are set only
-      --  if the corresponding entry in Is_Fixed_Length is True.
+      Opnd_Low_Bound : array (1 .. N) of Node_Id;
+      --  Set to lower bound of operand. Either an integer literal in the case
+      --  where the bound is known at compile time, else actual lower bound.
+      --  The operand low bound is of type Ityp.
+
+      Opnd_High_Bound : array (1 .. N) of Node_Id;
+      --  Set to upper bound of operand. Either an integer literal in the case
+      --  where the bound is known at compile time, else actual upper bound.
+      --  The operand bound is of type Ityp.
 
       Var_Length : array (1 .. N) of Entity_Id;
       --  Set to an entity of type Natural that contains the length of an
       --  operand whose length is not known at compile time. Entries in this
       --  array are set only if the corresponding entry in Is_Fixed_Length
-      --  is False.
+      --  is False. The entity is of type Intyp.
 
       Aggr_Length : array (0 .. N) of Node_Id;
       --  The J'th entry in an expression node that represents the total length
       --  of operands 1 through J. It is either an integer literal node, or a
       --  reference to a constant entity with the right value, so it is fine
       --  to just do a Copy_Node to get an appropriate copy. The extra zero'th
-      --  entry always is set to zero.
+      --  entry always is set to zero. The length is of type Intyp.
 
       Low_Bound : Node_Id;
-      --  An tree node representing the low bound of the result. This is either
-      --  an integer literal node, or an identifier reference to a constant
-      --  entity initialized to the appropriate value.
+      --  A tree node representing the low bound of the result (of type Ityp).
+      --  This is either an integer literal node, or an identifier reference to
+      --  a constant entity initialized to the appropriate value.
+
+      High_Bound : Node_Id;
+      --  A tree node representing the high bound of the result (of type Ityp)
 
       Result : Node_Id;
-      --  Result of the concatenation
+      --  Result of the concatenation (of type Ityp)
 
       function To_Intyp (X : Node_Id) return Node_Id;
       --  Given a node of type Ityp, returns the corresponding value of type
       --  Intyp. For non-enumeration types, this is the identity. For enum
-      --  types. the Pos of the value is returned.
+      --  types, the Pos of the value is returned.
 
       function To_Ityp (X : Node_Id) return Node_Id;
-      --  The inverse function (uses Val in the case of enumeration types
+      --  The inverse function (uses Val in the case of enumeration types)
 
       --------------
       -- To_Intyp --
@@ -2247,9 +2262,9 @@ package body Exp_Ch4 is
          --  Case where we will do a type conversion
 
          else
-            --  If the value is known at compile time, and known to be out
-            --  of range of the index type or the base type, we can signal
-            --  that we are sure to have a constraint error at run time.
+            --  If the value is known at compile time, and known to be out of
+            --  range of the index type or the base type, we can signal that
+            --  we are sure to have a constraint error at run time.
 
             --  There are two reasons for doing this. First of all, it is of
             --  course nice to detect situations of certain exceptions, and
@@ -2287,12 +2302,13 @@ package body Exp_Ch4 is
 
       --  Local Declarations
 
-      Opnd : Node_Id;
-      Ent  : Entity_Id;
-      Len  : Uint;
-      J    : Nat;
-      Clen : Node_Id;
-      Set  : Boolean;
+      Opnd     : Node_Id;
+      Opnd_Typ : Entity_Id;
+      Ent      : Entity_Id;
+      Len      : Uint;
+      J        : Nat;
+      Clen     : Node_Id;
+      Set      : Boolean;
 
    begin
       Aggr_Length (0) := Make_Integer_Literal (Loc, 0);
@@ -2312,7 +2328,7 @@ package body Exp_Ch4 is
       --  For enumeration types, we can simply use Standard_Integer, this is
       --  sufficient since the actual number of enumeration literals cannot
       --  possibly exceed the range of integer (remember we will be doing the
-      --  arithmetic with POS values, not represaentation values).
+      --  arithmetic with POS values, not representation values).
 
       if Is_Enumeration_Type (Ityp) then
          Intyp := Standard_Integer;
@@ -2347,6 +2363,7 @@ package body Exp_Ch4 is
       J := 1;
       while J <= N loop
          Opnd := Remove_Head (Opnds);
+         Opnd_Typ := Etype (Opnd);
 
          --  The parent got messed up when we put the operands in a list,
          --  so now put back the proper parent for the saved operand.
@@ -2359,52 +2376,71 @@ package body Exp_Ch4 is
 
          --  Singleton element (or character literal) case
 
-         if Base_Type (Etype (Opnd)) = Ctyp then
+         if Base_Type (Opnd_Typ) = Ctyp then
             NN := NN + 1;
             Operands (NN) := Opnd;
             Is_Fixed_Length (NN) := True;
             Fixed_Length (NN) := Uint_1;
+            Result_May_Be_Null := False;
 
-            --  Set lower bound to lower bound of index subtype. This is not
-            --  right where the index subtype bound is dynamic ???
+            --  Set bounds of operand
 
-            if Compile_Time_Known_Value (Type_Low_Bound (Ityp)) then
-               Fixed_Low_Bound (NN) :=
-                 Expr_Value (Type_Low_Bound (Ityp));
-            else
-               Fixed_Low_Bound (NN) :=
-                 Expr_Value (Type_Low_Bound (Base_Type (Ityp)));
-            end if;
+            Opnd_Low_Bound (NN) :=
+              Make_Attribute_Reference (Loc,
+                Prefix         => New_Reference_To (Ityp, Loc),
+                Attribute_Name => Name_First);
+
+            --  ??? The addition below is dubious, what if Ityp is an enum
+            --  type, shouldn't this be Ityp'Succ (Ityp'First)?
+
+            Opnd_High_Bound (NN) :=
+              Make_Op_Add (Loc,
+                Left_Opnd =>
+                  Make_Attribute_Reference (Loc,
+                    Prefix         => New_Reference_To (Ityp, Loc),
+                    Attribute_Name => Name_First),
+                Right_Opnd => Make_Integer_Literal (Loc, 1));
 
             Set := True;
 
          --  String literal case (can only occur for strings of course)
 
          elsif Nkind (Opnd) = N_String_Literal then
-            Len := UI_From_Int (String_Length (Strval (Opnd)));
+            Len := String_Literal_Length (Opnd_Typ);
 
-            --  We can safely skip null string literals, since they are
-            --  considered to have a lower bound of 1.
+            --  Skip null string literal unless last operand
 
-            if Len = 0 then
+            if J < N and then Len = 0 then
                goto Continue;
             end if;
 
             NN := NN + 1;
             Operands (NN) := Opnd;
             Is_Fixed_Length (NN) := True;
+
+            --  Set length and bounds
+
             Fixed_Length (NN) := Len;
-            Fixed_Low_Bound (NN) := Uint_1;
+
+            Opnd_Low_Bound (NN) :=
+              New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
+
+            Opnd_High_Bound (NN) :=
+              Make_Op_Add (Loc,
+                Left_Opnd  =>
+                  New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)),
+                Right_Opnd => Make_Integer_Literal (Loc, 1));
+
             Set := True;
+            Result_May_Be_Null := False;
 
          --  All other cases
 
          else
             --  Check constrained case with known bounds
 
-            if Is_Constrained (Etype (Opnd)) then
+            if Is_Constrained (Opnd_Typ) then
                declare
-                  Opnd_Typ : constant Entity_Id := Etype (Opnd);
                   Index    : constant Node_Id   := First_Index (Opnd_Typ);
                   Indx_Typ : constant Entity_Id := Etype (Index);
                   Lo       : constant Node_Id   := Type_Low_Bound  (Indx_Typ);
@@ -2425,40 +2461,61 @@ package body Exp_Ch4 is
                                   UI_Max (Hival - Loval + 1, Uint_0);
 
                      begin
-                        --  Exclude the null length case where the lower bound
-                        --  is other than 1 or the type is other than string,
-                        --  because annoyingly we need to keep such an operand
-                        --  around in case it is the one that supplies a lower
-                        --  bound to the result.
-
-                        if (Loval = 1 and then Atyp = Standard_String)
-                          or Len > 0
-                        then
-                           --  Skip null string case (lower bound = 1)
-
-                           if Len = 0 then
-                              goto Continue;
-                           end if;
-
-                           NN := NN + 1;
-                           Operands (NN) := Opnd;
-                           Is_Fixed_Length (NN) := True;
-                           Fixed_Length (NN)    := Len;
-                           Fixed_Low_Bound (NN) := Expr_Value (Lo);
-                           Set := True;
+                        if Len > 0 then
+                           Result_May_Be_Null := False;
+                        end if;
+
+                        --  Exclude null length case except for last operand
+                        --  (where we may need it to get proper bounds).
+
+                        if Len = 0 and then J < N then
+                           goto Continue;
                         end if;
+
+                        NN := NN + 1;
+                        Operands (NN) := Opnd;
+                        Is_Fixed_Length (NN) := True;
+                        Fixed_Length (NN)    := Len;
+
+                        --  ??? case where Ityp is an enum type?
+
+                        Opnd_Low_Bound (NN) :=
+                          Make_Integer_Literal (Loc,
+                            Intval => Expr_Value (Lo));
+
+                        Opnd_High_Bound (NN) :=
+                          Make_Integer_Literal (Loc,
+                            Intval => Expr_Value (Hi));
+
+                        Set := True;
                      end;
                   end if;
                end;
             end if;
 
-            --  All cases where the length is not known at compile time, or
-            --  the special case of an operand which is known to be null but
-            --  has a lower bound other than 1 or is other than a string type.
-            --  Capture length of operand in entity.
+            --  All cases where the length is not known at compile time, or the
+            --  special case of an operand which is known to be null but has a
+            --  lower bound other than 1 or is other than a string type.
 
             if not Set then
                NN := NN + 1;
+
+               --  Capture operand bounds
+
+               Opnd_Low_Bound (NN) :=
+                 Make_Attribute_Reference (Loc,
+                   Prefix         =>
+                     Duplicate_Subexpr (Opnd, Name_Req => True),
+                   Attribute_Name => Name_First);
+
+               Opnd_High_Bound (NN) :=
+                 Make_Attribute_Reference (Loc,
+                   Prefix         =>
+                     Duplicate_Subexpr (Opnd, Name_Req => True),
+                   Attribute_Name => Name_Last);
+
+               --  Capture length of operand in entity
+
                Operands (NN) := Opnd;
                Is_Fixed_Length (NN) := False;
 
@@ -2487,7 +2544,7 @@ package body Exp_Ch4 is
          --  Set next entry in aggregate length array
 
          --  For first entry, make either integer literal for fixed length
-         --  or a reference to the saved length for variable length
+         --  or a reference to the saved length for variable length.
 
          if NN = 1 then
             if Is_Fixed_Length (1) then
@@ -2554,9 +2611,7 @@ package body Exp_Ch4 is
 
       if NN = 0 then
          Start_String;
-         Result :=
-           Make_String_Literal (Loc,
-             Strval => End_String);
+         Result := Make_String_Literal (Loc, Strval => End_String);
          goto Done;
       end if;
 
@@ -2586,28 +2641,26 @@ package body Exp_Ch4 is
       --  ancestor is the first subtype of this root type.
 
       if Is_Constrained (First_Subtype (Root_Type (Atyp))) then
-         Low_Bound := To_Intyp (
+         Low_Bound :=
            Make_Attribute_Reference (Loc,
              Prefix         =>
                New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc),
-             Attribute_Name => Name_First));
+             Attribute_Name => Name_First);
 
       --  If the first operand in the list has known length we know that
       --  the lower bound of the result is the lower bound of this operand.
 
       elsif Is_Fixed_Length (1) then
-         Low_Bound :=
-           Make_Integer_Literal (Loc,
-             Intval => Fixed_Low_Bound (1));
+         Low_Bound := Opnd_Low_Bound (1);
 
       --  OK, we don't know the lower bound, we have to build a horrible
       --  expression actions node of the form
 
       --     if Cond1'Length /= 0 then
-      --        Opnd1'First
+      --        Opnd1 low bound
       --     else
       --        if Opnd2'Length /= 0 then
-      --          Opnd2'First
+      --          Opnd2 low bound
       --        else
       --           ...
 
@@ -2626,23 +2679,9 @@ package body Exp_Ch4 is
             ---------------------
 
             function Get_Known_Bound (J : Nat) return Node_Id is
-               Lo : Node_Id;
-
             begin
-               if Is_Fixed_Length (J) then
-                  return
-                    Make_Integer_Literal (Loc,
-                      Intval => Fixed_Low_Bound (J));
-               end if;
-
-               Lo := To_Intyp (
-                 Make_Attribute_Reference (Loc,
-                   Prefix =>
-                     Duplicate_Subexpr (Operands (J), Name_Req => True),
-                   Attribute_Name => Name_First));
-
-               if J = NN then
-                  return Lo;
+               if Is_Fixed_Length (J) or else J = NN then
+                  return New_Copy (Opnd_Low_Bound (J));
 
                else
                   return
@@ -2653,7 +2692,7 @@ package body Exp_Ch4 is
                           Left_Opnd  => New_Reference_To (Var_Length (J), Loc),
                           Right_Opnd => Make_Integer_Literal (Loc, 0)),
 
-                        Lo,
+                        New_Copy (Opnd_Low_Bound (J)),
                         Get_Known_Bound (J + 1)));
                end if;
             end Get_Known_Bound;
@@ -2667,8 +2706,7 @@ package body Exp_Ch4 is
               Make_Object_Declaration (Loc,
                 Defining_Identifier => Ent,
                 Constant_Present    => True,
-                Object_Definition   =>
-                  New_Occurrence_Of (Intyp, Loc),
+                Object_Definition   => New_Occurrence_Of (Ityp, Loc),
                 Expression          => Get_Known_Bound (1)),
               Suppress => All_Checks);
 
@@ -2676,8 +2714,32 @@ package body Exp_Ch4 is
          end;
       end if;
 
-      --  Now we build the result, which is a reference to the array entity
-      --  we will construct with appropriate bounds.
+      --  Now find the upper bound. This is normally the Low_Bound + Length - 1
+      --  but there is one exception, namely when the result is null in which
+      --  case the bounds come from the last operand (so that we get the proper
+      --  bounds if the last operand is super-flat).
+
+      High_Bound :=
+        To_Ityp (
+          Make_Op_Add (Loc,
+            Left_Opnd  => To_Intyp (New_Copy (Low_Bound)),
+            Right_Opnd =>
+              Make_Op_Subtract (Loc,
+                Left_Opnd  => New_Copy (Aggr_Length (NN)),
+                Right_Opnd => Make_Integer_Literal (Loc, 1))));
+
+      if Result_May_Be_Null then
+         High_Bound :=
+           Make_Conditional_Expression (Loc,
+             Expressions => New_List (
+               Make_Op_Eq (Loc,
+                 Left_Opnd  => New_Copy (Aggr_Length (NN)),
+                 Right_Opnd => Make_Integer_Literal (Loc, 0)),
+               Opnd_High_Bound (NN),
+               High_Bound));
+      end if;
+
+      --  Now we construct an array object with appropriate bounds
 
       Ent :=
         Make_Defining_Identifier (Loc,
@@ -2686,7 +2748,6 @@ package body Exp_Ch4 is
       Insert_Action (Cnode,
         Make_Object_Declaration (Loc,
           Defining_Identifier => Ent,
-
           Object_Definition   =>
             Make_Subtype_Indication (Loc,
               Subtype_Mark => New_Occurrence_Of (Atyp, Loc),
@@ -2694,16 +2755,8 @@ package body Exp_Ch4 is
                 Make_Index_Or_Discriminant_Constraint (Loc,
                   Constraints => New_List (
                     Make_Range (Loc,
-                      Low_Bound => To_Ityp (New_Copy (Low_Bound)),
-                      High_Bound => To_Ityp (
-                        Make_Op_Add (Loc,
-                          Left_Opnd  => New_Copy (Low_Bound),
-                          Right_Opnd =>
-                            Make_Op_Subtract (Loc,
-                              Left_Opnd  => New_Copy (Aggr_Length (NN)),
-                              Right_Opnd =>
-                                Make_Integer_Literal (Loc,
-                                  Intval => Uint_1))))))))),
+                      Low_Bound  => Low_Bound,
+                      High_Bound => High_Bound))))),
 
         Suppress => All_Checks);
 
@@ -2713,18 +2766,16 @@ package body Exp_Ch4 is
          declare
             Lo : constant Node_Id :=
                    Make_Op_Add (Loc,
-                     Left_Opnd  => New_Copy (Low_Bound),
+                     Left_Opnd  => To_Intyp (New_Copy (Low_Bound)),
                      Right_Opnd => Aggr_Length (J - 1));
 
             Hi : constant Node_Id :=
                    Make_Op_Add (Loc,
-                     Left_Opnd  => New_Copy (Low_Bound),
+                     Left_Opnd  => To_Intyp (New_Copy (Low_Bound)),
                      Right_Opnd =>
                        Make_Op_Subtract (Loc,
                          Left_Opnd  => Aggr_Length (J),
-                         Right_Opnd =>
-                           Make_Integer_Literal (Loc,
-                             Intval => 1)));
+                         Right_Opnd => Make_Integer_Literal (Loc, 1)));
 
          begin
             --  Singleton case, simple assignment
@@ -2757,6 +2808,8 @@ package body Exp_Ch4 is
          end;
       end loop;
 
+      --  Finally we build the result, which is a reference to the array object
+
       Result := New_Reference_To (Ent, Loc);
 
    <<Done>>
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index f77e1e7..9a2372e 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -5509,13 +5509,19 @@ package body Freeze is
       end if;
 
       --  We only give the warning for non-imported entities of a type for
-      --  which a non-null base init proc is defined (or for access types which
-      --  have implicit null initialization).
+      --  which a non-null base init proc is defined, or for objects of access
+      --  types with implicit null initialization, or when Initialize_Scalars
+      --  applies and the type is scalar or a string type (the latter being
+      --  tested for because predefined String types are initialized by inline
+      --  code rather than by an init_proc).
 
       if Present (Expr)
-        and then (Has_Non_Null_Base_Init_Proc (Typ)
-                    or else Is_Access_Type (Typ))
         and then not Is_Imported (Ent)
+        and then (Has_Non_Null_Base_Init_Proc (Typ)
+                    or else Is_Access_Type (Typ)
+                    or else (Init_Or_Norm_Scalars
+                              and then (Is_Scalar_Type (Typ)
+                                         or else Is_String_Type (Typ))))
       then
          if Nkind (Expr) = N_Attribute_Reference
            and then Is_Entity_Name (Prefix (Expr))
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index 5404fcd..314dc83 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -322,10 +322,6 @@ package Rtsfind is
       System_Storage_Elements,
       System_Storage_Pools,
       System_Stream_Attributes,
-      System_String_Ops,
-      System_String_Ops_Concat_3,
-      System_String_Ops_Concat_4,
-      System_String_Ops_Concat_5,
       System_Task_Info,
       System_Tasking,
       System_Threads,
@@ -1320,17 +1316,6 @@ package Rtsfind is
      RE_W_WC,                            -- System.Stream_Attributes
      RE_W_WWC,                           -- System.Stream_Attributes
 
-     RE_Str_Concat,                      -- System.String_Ops
-     RE_Str_Concat_CC,                   -- System.String_Ops
-     RE_Str_Concat_CS,                   -- System.String_Ops
-     RE_Str_Concat_SC,                   -- System.String_Ops
-
-     RE_Str_Concat_3,                    -- System.String_Ops_Concat_3
-
-     RE_Str_Concat_4,                    -- System.String_Ops_Concat_4
-
-     RE_Str_Concat_5,                    -- System.String_Ops_Concat_5
-
      RE_String_Input,                    -- System.Strings.Stream_Ops
      RE_String_Input_Blk_IO,             -- System.Strings.Stream_Ops
      RE_String_Output,                   -- System.Strings.Stream_Ops
@@ -2474,17 +2459,6 @@ package Rtsfind is
      RE_W_WC                             => System_Stream_Attributes,
      RE_W_WWC                            => System_Stream_Attributes,
 
-     RE_Str_Concat                       => System_String_Ops,
-     RE_Str_Concat_CC                    => System_String_Ops,
-     RE_Str_Concat_CS                    => System_String_Ops,
-     RE_Str_Concat_SC                    => System_String_Ops,
-
-     RE_Str_Concat_3                     => System_String_Ops_Concat_3,
-
-     RE_Str_Concat_4                     => System_String_Ops_Concat_4,
-
-     RE_Str_Concat_5                     => System_String_Ops_Concat_5,
-
      RE_String_Input                     => System_Strings_Stream_Ops,
      RE_String_Input_Blk_IO              => System_Strings_Stream_Ops,
      RE_String_Output                    => System_Strings_Stream_Ops,
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index cbdda92..a135cd9 100644
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -3905,9 +3905,6 @@ package body Sem_Ch10 is
       -- Check_Body_Required --
       -------------------------
 
-      --  ??? misses pragma Import on subprograms
-      --  ??? misses pragma Import on renamed subprograms
-
       procedure Check_Body_Required is
          PA : constant List_Id :=
                 Pragmas_After (Aux_Decls_Node (Parent (P_Unit)));
@@ -3923,6 +3920,97 @@ package body Sem_Ch10 is
             Decl             : Node_Id;
             Incomplete_Decls : constant Elist_Id := New_Elmt_List;
 
+            Subp_List        : constant Elist_Id := New_Elmt_List;
+
+            procedure Check_Pragma_Import (P : Node_Id);
+            --  If a pragma import applies to a previous subprogram, the
+            --  enclosing unit may not need a body. The processing is
+            --  syntactic and does not require a declaration to be analyzed,
+            --  The code below also handles pragma import when applied to
+            --  a subprogram that renames another. In this case the pragma
+            --  applies to the renamed entity
+            --  Chains of multiple renames are not handled by the code below.
+            --  It is probably impossible to handle all cases without proper
+            --  name resolution. In such cases the algorithm is conservative
+            --  and will indicate that a body is needed???
+
+            -------------------------
+            -- Check_Pragma_Import --
+            -------------------------
+
+            procedure Check_Pragma_Import (P : Node_Id) is
+               Arg      : Node_Id;
+               Prev_Id  : Elmt_Id;
+               Subp_Id  : Elmt_Id;
+               Imported : Node_Id;
+
+               procedure Remove_Homonyms (E : Node_Id);
+               --  Make one pass over list of subprograms, Called again if
+               --  subprogram is a renaming. E is known to be an identifier.
+
+               ---------------------
+               -- Remove_Homonyms --
+               ---------------------
+
+               procedure Remove_Homonyms (E : Entity_Id) is
+                  R : Entity_Id := Empty;
+                  --  Name of renamed entity, if any.
+
+               begin
+                  Subp_Id := First_Elmt (Subp_List);
+
+                  while Present (Subp_Id) loop
+                     if Chars (Node (Subp_Id)) = Chars (E) then
+                        if Nkind (Parent (Parent (Node (Subp_Id))))
+                          /=  N_Subprogram_Renaming_Declaration
+                        then
+                           Prev_Id := Subp_Id;
+                           Next_Elmt (Subp_Id);
+                           Remove_Elmt (Subp_List, Prev_Id);
+                        else
+                           R := Name (Parent (Parent (Node (Subp_Id))));
+                           exit;
+                        end if;
+                     else
+                        Next_Elmt (Subp_Id);
+                     end if;
+                  end loop;
+
+                  if Present (R) then
+                     if Nkind (R) = N_Identifier then
+                        Remove_Homonyms (R);
+
+                     elsif Nkind (R) = N_Selected_Component then
+                        Remove_Homonyms (Selector_Name (R));
+
+                     else
+                        --  renaming of attribute
+
+                        null;
+                     end if;
+                  end if;
+               end Remove_Homonyms;
+
+               --  Start of processing for Check_Pragma_Import
+
+            begin
+
+               --  Find name of entity in Import pragma. We have not analyzed
+               --  the construct, so we must guard against syntax errors.
+
+               Arg := Next (First (Pragma_Argument_Associations (P)));
+
+               if No (Arg)
+                 or else Nkind (Expression (Arg)) /= N_Identifier
+               then
+                  return;
+               else
+                  Imported := Expression (Arg);
+               end if;
+
+               Remove_Homonyms (Imported);
+            end Check_Pragma_Import;
+
          begin
             --  Search for Elaborate Body pragma
 
@@ -3942,15 +4030,15 @@ package body Sem_Ch10 is
 
             while Present (Decl) loop
 
-               --  Subprogram that comes from source means body required
-               --  This is where a test for Import is missing ???
+               --  Subprogram that comes from source means body may be needed.
+               --  Save for subsequent examination of import pragmas.
 
                if Comes_From_Source (Decl)
                  and then (Nkind_In (Decl, N_Subprogram_Declaration,
+                                           N_Subprogram_Renaming_Declaration,
                                            N_Generic_Subprogram_Declaration))
                then
-                  Set_Body_Required (Library_Unit (N));
-                  return;
+                  Append_Elmt (Defining_Entity (Decl), Subp_List);
 
                --  Package declaration of generic package declaration. We need
                --  to recursively examine nested declarations.
@@ -3959,6 +4047,11 @@ package body Sem_Ch10 is
                                      N_Generic_Package_Declaration)
                then
                   Check_Declarations (Specification (Decl));
+
+               elsif Nkind (Decl) = N_Pragma
+                 and then Pragma_Name (Decl) = Name_Import
+               then
+                  Check_Pragma_Import (Decl);
                end if;
 
                Next (Decl);
@@ -3972,9 +4065,10 @@ package body Sem_Ch10 is
             while Present (Decl) loop
                if Comes_From_Source (Decl)
                  and then (Nkind_In (Decl, N_Subprogram_Declaration,
+                                           N_Subprogram_Renaming_Declaration,
                                            N_Generic_Subprogram_Declaration))
                then
-                  Set_Body_Required (Library_Unit (N));
+                  Append_Elmt (Defining_Entity (Decl), Subp_List);
 
                elsif Nkind_In (Decl, N_Package_Declaration,
                                      N_Generic_Package_Declaration)
@@ -3985,6 +4079,11 @@ package body Sem_Ch10 is
 
                elsif Nkind (Decl) = N_Incomplete_Type_Declaration then
                   Append_Elmt (Decl, Incomplete_Decls);
+
+               elsif Nkind (Decl) = N_Pragma
+                 and then Pragma_Name (Decl) = Name_Import
+               then
+                  Check_Pragma_Import (Decl);
                end if;
 
                Next (Decl);
@@ -4022,6 +4121,29 @@ package body Sem_Ch10 is
                   Next_Elmt (Inc);
                end loop;
             end;
+
+            --  Finally, check whether there are subprograms that still
+            --  require a body.
+
+            if not Is_Empty_Elmt_List (Subp_List) then
+               declare
+                  Subp_Id : Elmt_Id;
+
+               begin
+                  Subp_Id := First_Elmt (Subp_List);
+
+                  while Present (Subp_Id) loop
+                     if Nkind (Parent (Parent (Node (Subp_Id))))
+                        /= N_Subprogram_Renaming_Declaration
+                     then
+                        Set_Body_Required (Library_Unit (N));
+                        return;
+                     end if;
+
+                     Next_Elmt (Subp_Id);
+                  end loop;
+               end;
+            end if;
          end Check_Declarations;
 
       --  Start of processing for Check_Body_Required
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index 5e420c6..31f931e 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -490,7 +490,13 @@ package body Sem_Warn is
                   P := Parent (P);
                   exit when P = Loop_Statement;
 
-                  if Nkind (P) = N_Procedure_Call_Statement then
+                  --  Abandon if at procedure call, or something strange is
+                  --  going on (perhaps a node with no parent that should
+                  --  have one but does not?) As always, for a warning we
+                  --  prefer to just abandon the warning than get into the
+                  --  business of complaining about the tree structure here!
+
+                  if No (P) or else Nkind (P) = N_Procedure_Call_Statement then
                      return Abandon;
                   end if;
                end loop;