[multiple changes]

2011-08-02  Geert Bosch  <bosch@adacore.com>

	* a-calfor.adb (Image): Simplify, removing unnecessary uses of 'Image.

2011-08-02  Eric Botcazou  <ebotcazou@adacore.com>

	* sem_type.adb (Covers): Move trivial case to the top and reuse the
	computed value of Base_Type.

2011-08-02  Yannick Moy  <moy@adacore.com>

	* restrict.adb (Check_Restriction): issue an error for any use of
	class-wide, even if the No_Dispatch restriction is not set.
	* sem_aggr.adb: Correct typos in comments and messages in formal mode
	* sem_ch3.adb (Process_Full_View): issue an error in formal mode is,
	when completing a private extension, the type named in the private part
	is not the same as that named in the visible part.
	* sem_res.adb (Resolve_Call): issue an error in formal mode on the use
	of an inherited primitive operations of a tagged type or type extension
	that returns the tagged type.
	* sem_util.adb, sem_util.ads (Is_Inherited_Operation_For_Type): new
	function which returns True for an implicit operation inherited by the
	derived type declaration for the argument type.
	(Is_SPARK_Object_Reference): move to appropriate place in alphabetic
	order.

From-SVN: r177135

9 files changed, 278 insertions, 257 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 858a947..9ba947a 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,29 @@
+2011-08-02  Geert Bosch  <bosch@adacore.com>
+
+	* a-calfor.adb (Image): Simplify, removing unnecessary uses of 'Image.
+
+2011-08-02  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* sem_type.adb (Covers): Move trivial case to the top and reuse the
+	computed value of Base_Type.
+
+2011-08-02  Yannick Moy  <moy@adacore.com>
+
+	* restrict.adb (Check_Restriction): issue an error for any use of
+	class-wide, even if the No_Dispatch restriction is not set.
+	* sem_aggr.adb: Correct typos in comments and messages in formal mode
+	* sem_ch3.adb (Process_Full_View): issue an error in formal mode is,
+	when completing a private extension, the type named in the private part
+	is not the same as that named in the visible part.
+	* sem_res.adb (Resolve_Call): issue an error in formal mode on the use
+	of an inherited primitive operations of a tagged type or type extension
+	that returns the tagged type.
+	* sem_util.adb, sem_util.ads (Is_Inherited_Operation_For_Type): new
+	function which returns True for an implicit operation inherited by the
+	derived type declaration for the argument type.
+	(Is_SPARK_Object_Reference): move to appropriate place in alphabetic
+	order.
+
 2011-08-02  Ed Schonberg  <schonberg@adacore.com>
 
 	* sem_ch5.adb (Pre_Analyze_Range): new procedure extracted from
diff --git a/gcc/ada/a-calfor.adb b/gcc/ada/a-calfor.adb
index 39c3c0a..41f8c25 100644
--- a/gcc/ada/a-calfor.adb
+++ b/gcc/ada/a-calfor.adb
@@ -139,83 +139,53 @@ package body Ada.Calendar.Formatting is
      (Elapsed_Time          : Duration;
       Include_Time_Fraction : Boolean := False) return String
    is
+      To_Char    : constant array (0 .. 9) of Character := "0123456789";
       Hour       : Hour_Number;
       Minute     : Minute_Number;
       Second     : Second_Number;
       Sub_Second : Duration;
       SS_Nat     : Natural;
 
-      Low  : Integer;
-      High : Integer;
+      --  Determine the two slice bounds for the result string depending on
+      --  whether the input is negative and whether fractions are requested.
+
+      First  : constant Integer := (if Elapsed_Time < 0.0 then 1 else 2);
+      Last   : constant Integer := (if Include_Time_Fraction then 12 else 9);
 
       Result : String := "-00:00:00.00";
 
    begin
       Split (abs (Elapsed_Time), Hour, Minute, Second, Sub_Second);
 
-      --  Determine the two slice bounds for the result string depending on
-      --  whether the input is negative and whether fractions are requested.
+      --  Hour processing, positions 2 and 3
 
-      Low  := (if Elapsed_Time < 0.0 then 1 else 2);
-      High := (if Include_Time_Fraction then 12 else 9);
+      Result (2) := To_Char (Hour / 10);
+      Result (3) := To_Char (Hour mod 10);
 
-      --  Prevent rounding when converting to natural
+      --  Minute processing, positions 5 and 6
 
-      Sub_Second := Sub_Second * 100.0;
+      Result (5) := To_Char (Minute / 10);
+      Result (6) := To_Char (Minute mod 10);
 
-      if Sub_Second > 0.0 then
-         Sub_Second := Sub_Second - 0.5;
-      end if;
+      --  Second processing, positions 8 and 9
 
-      SS_Nat := Natural (Sub_Second);
+      Result (8) := To_Char (Second / 10);
+      Result (9) := To_Char (Second mod 10);
 
-      declare
-         Hour_Str   : constant String := Hour_Number'Image (Hour);
-         Minute_Str : constant String := Minute_Number'Image (Minute);
-         Second_Str : constant String := Second_Number'Image (Second);
-         SS_Str     : constant String := Natural'Image (SS_Nat);
+      --  Optional sub second processing, positions 11 and 12
 
-      begin
-         --  Hour processing, positions 2 and 3
+      if Include_Time_Fraction and then Sub_Second > 0.0 then
 
-         if Hour < 10 then
-            Result (3) := Hour_Str (2);
-         else
-            Result (2) := Hour_Str (2);
-            Result (3) := Hour_Str (3);
-         end if;
-
-         --  Minute processing, positions 5 and 6
+         --  Prevent rounding up when converting to natural, avoiding the zero
+         --  case to prevent rounding down to a negative number.
 
-         if Minute < 10 then
-            Result (6) := Minute_Str (2);
-         else
-            Result (5) := Minute_Str (2);
-            Result (6) := Minute_Str (3);
-         end if;
+         SS_Nat := Natural (Duration'(Sub_Second * 100.0) - 0.5);
 
-         --  Second processing, positions 8 and 9
-
-         if Second < 10 then
-            Result (9) := Second_Str (2);
-         else
-            Result (8) := Second_Str (2);
-            Result (9) := Second_Str (3);
-         end if;
-
-         --  Optional sub second processing, positions 11 and 12
-
-         if Include_Time_Fraction then
-            if SS_Nat < 10 then
-               Result (12) := SS_Str (2);
-            else
-               Result (11) := SS_Str (2);
-               Result (12) := SS_Str (3);
-            end if;
-         end if;
+         Result (11) := To_Char (SS_Nat / 10);
+         Result (12) := To_Char (SS_Nat mod 10);
+      end if;
 
-         return Result (Low .. High);
-      end;
+      return Result (First .. Last);
    end Image;
 
    -----------
@@ -227,6 +197,8 @@ package body Ada.Calendar.Formatting is
       Include_Time_Fraction : Boolean := False;
       Time_Zone             : Time_Zones.Time_Offset := 0) return String
    is
+      To_Char    : constant array (0 .. 9) of Character := "0123456789";
+
       Year        : Year_Number;
       Month       : Month_Number;
       Day         : Day_Number;
@@ -237,99 +209,60 @@ package body Ada.Calendar.Formatting is
       SS_Nat      : Natural;
       Leap_Second : Boolean;
 
+      --  The result length depends on whether fractions are requested.
+
       Result : String := "0000-00-00 00:00:00.00";
+      Last   : constant Positive
+                 := Result'Last - (if Include_Time_Fraction then 0 else 3);
 
    begin
       Split (Date, Year, Month, Day,
              Hour, Minute, Second, Sub_Second, Leap_Second, Time_Zone);
 
-      --  Prevent rounding when converting to natural
-
-      Sub_Second := Sub_Second * 100.0;
-
-      if Sub_Second > 0.0 then
-         Sub_Second := Sub_Second - 0.5;
-      end if;
-
-      SS_Nat := Natural (Sub_Second);
+      --  Year processing, positions 1, 2, 3 and 4
 
-      declare
-         Year_Str   : constant String := Year_Number'Image (Year);
-         Month_Str  : constant String := Month_Number'Image (Month);
-         Day_Str    : constant String := Day_Number'Image (Day);
-         Hour_Str   : constant String := Hour_Number'Image (Hour);
-         Minute_Str : constant String := Minute_Number'Image (Minute);
-         Second_Str : constant String := Second_Number'Image (Second);
-         SS_Str     : constant String := Natural'Image (SS_Nat);
+      Result (1) := To_Char (Year / 1000);
+      Result (2) := To_Char (Year / 100 mod 10);
+      Result (3) := To_Char (Year / 10 mod 10);
+      Result (4) := To_Char (Year mod 10);
 
-      begin
-         --  Year processing, positions 1, 2, 3 and 4
+      --  Month processing, positions 6 and 7
 
-         Result (1) := Year_Str (2);
-         Result (2) := Year_Str (3);
-         Result (3) := Year_Str (4);
-         Result (4) := Year_Str (5);
+      Result (6) := To_Char (Month / 10);
+      Result (7) := To_Char (Month mod 10);
 
-         --  Month processing, positions 6 and 7
+      --  Day processing, positions 9 and 10
 
-         if Month < 10 then
-            Result (7) := Month_Str (2);
-         else
-            Result (6) := Month_Str (2);
-            Result (7) := Month_Str (3);
-         end if;
+      Result (9)  := To_Char (Day / 10);
+      Result (10) := To_Char (Day mod 10);
 
-         --  Day processing, positions 9 and 10
+      Result (12) := To_Char (Hour / 10);
+      Result (13) := To_Char (Hour mod 10);
 
-         if Day < 10 then
-            Result (10) := Day_Str (2);
-         else
-            Result (9)  := Day_Str (2);
-            Result (10) := Day_Str (3);
-         end if;
+      --  Minute processing, positions 15 and 16
 
-         --  Hour processing, positions 12 and 13
+      Result (15) := To_Char (Minute / 10);
+      Result (16) := To_Char (Minute mod 10);
 
-         if Hour < 10 then
-            Result (13) := Hour_Str (2);
-         else
-            Result (12) := Hour_Str (2);
-            Result (13) := Hour_Str (3);
-         end if;
+      --  Second processing, positions 18 and 19
 
-         --  Minute processing, positions 15 and 16
+      Result (18) := To_Char (Second / 10);
+      Result (19) := To_Char (Second mod 10);
 
-         if Minute < 10 then
-            Result (16) := Minute_Str (2);
-         else
-            Result (15) := Minute_Str (2);
-            Result (16) := Minute_Str (3);
-         end if;
+      --  Optional sub second processing, positions 21 and 22
 
-         --  Second processing, positions 18 and 19
+      if Include_Time_Fraction and then Sub_Second > 0.0 then
 
-         if Second < 10 then
-            Result (19) := Second_Str (2);
-         else
-            Result (18) := Second_Str (2);
-            Result (19) := Second_Str (3);
-         end if;
+         --  Prevent rounding up when converting to natural, avoiding the zero
+         --  case to prevent rounding down to a negative number.
 
-         --  Optional sub second processing, positions 21 and 22
+         SS_Nat := Natural (Duration'(Sub_Second * 100.0) - 0.5);
 
-         if Include_Time_Fraction then
-            if SS_Nat < 10 then
-               Result (22) := SS_Str (2);
-            else
-               Result (21) := SS_Str (2);
-               Result (22) := SS_Str (3);
-            end if;
+         Result (21) := To_Char (SS_Nat / 10);
+         Result (22) := To_Char (SS_Nat mod 10);
+      end if;
 
-            return Result;
-         else
-            return Result (1 .. 19);
-         end if;
-      end;
+      return Result (Result'First .. Last);
    end Image;
 
    ------------
diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb
index 5a9f0b2..215a21f 100644
--- a/gcc/ada/restrict.adb
+++ b/gcc/ada/restrict.adb
@@ -331,6 +331,13 @@ package body Restrict is
          return;
       end if;
 
+      --  In formal mode, issue an error for any use of class-wide, even if the
+      --  No_Dispatch restriction is not set.
+
+      if R = No_Dispatch then
+         Check_Formal_Restriction ("class-wide is not allowed", N);
+      end if;
+
       if UI_Is_In_Int_Range (V) then
          VV := Integer (UI_To_Int (V));
       else
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 6e15379..28193ef 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -2375,11 +2375,11 @@ package body Sem_Aggr is
    --  components of the given type mark.
 
    --  b) If the ancestor part is an expression, it must be unambiguous, and
-   --  once we have its type we can also compute the needed  components as in
+   --  once we have its type we can also compute the needed components as in
    --  the previous case. In both cases, if the ancestor type is not the
    --  immediate ancestor, we have to build this ancestor recursively.
 
-   --  In both cases discriminants of the ancestor type do not play a role in
+   --  In both cases, discriminants of the ancestor type do not play a role in
    --  the resolution of the needed components, because inherited discriminants
    --  cannot be used in a type extension. As a result we can compute
    --  independently the list of components of the ancestor type and of the
@@ -2483,13 +2483,12 @@ package body Sem_Aggr is
       Analyze (A);
       Check_Parameterless_Call (A);
 
-      --  In SPARK or ALFA, the ancestor part cannot be a subtype mark
+      --  In SPARK or ALFA, the ancestor part cannot be a type mark
 
       if Is_Entity_Name (A)
         and then Is_Type (Entity (A))
       then
-         Check_Formal_Restriction
-           ("ancestor part cannot be a subtype mark", A);
+         Check_Formal_Restriction ("ancestor part cannot be a type mark", A);
       end if;
 
       if not Is_Tagged_Type (Typ) then
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 627e993..2a8d7c1 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -17275,89 +17275,108 @@ package body Sem_Ch3 is
               ("parent of full type must descend from parent"
                   & " of private extension", Full_Indic);
 
-         --  Check the rules of 7.3(10): if the private extension inherits
-         --  known discriminants, then the full type must also inherit those
-         --  discriminants from the same (ancestor) type, and the parent
-         --  subtype of the full type must be constrained if and only if
-         --  the ancestor subtype of the private extension is constrained.
-
-         elsif No (Discriminant_Specifications (Parent (Priv_T)))
-           and then not Has_Unknown_Discriminants (Priv_T)
-           and then Has_Discriminants (Base_Type (Priv_Parent))
-         then
-            declare
-               Priv_Indic  : constant Node_Id :=
-                               Subtype_Indication (Parent (Priv_T));
+         --  First check a formal restriction, and then proceed with checking
+         --  Ada rules. Since the formal restriction is not a serious error, we
+         --  don't prevent further error detection for this check, hence the
+         --  ELSE.
 
-               Priv_Constr : constant Boolean :=
-                               Is_Constrained (Priv_Parent)
-                                 or else
-                                   Nkind (Priv_Indic) = N_Subtype_Indication
-                                 or else Is_Constrained (Entity (Priv_Indic));
+         else
 
-               Full_Constr : constant Boolean :=
-                               Is_Constrained (Full_Parent)
-                                 or else
-                                   Nkind (Full_Indic) = N_Subtype_Indication
-                                 or else Is_Constrained (Entity (Full_Indic));
+            --  In formal mode, when completing a private extension the type
+            --  named in the private part must be exactly the same as that
+            --  named in the visible part.
 
-               Priv_Discr : Entity_Id;
-               Full_Discr : Entity_Id;
+            if Priv_Parent /= Full_Parent then
+               Error_Msg_Name_1 := Chars (Priv_Parent);
+               Check_Formal_Restriction ("% expected", Full_Indic);
+            end if;
 
-            begin
-               Priv_Discr := First_Discriminant (Priv_Parent);
-               Full_Discr := First_Discriminant (Full_Parent);
-               while Present (Priv_Discr) and then Present (Full_Discr) loop
-                  if Original_Record_Component (Priv_Discr) =
-                     Original_Record_Component (Full_Discr)
-                    or else
-                     Corresponding_Discriminant (Priv_Discr) =
-                     Corresponding_Discriminant (Full_Discr)
-                  then
-                     null;
-                  else
-                     exit;
-                  end if;
+            --  Check the rules of 7.3(10): if the private extension inherits
+            --  known discriminants, then the full type must also inherit those
+            --  discriminants from the same (ancestor) type, and the parent
+            --  subtype of the full type must be constrained if and only if
+            --  the ancestor subtype of the private extension is constrained.
 
-                  Next_Discriminant (Priv_Discr);
-                  Next_Discriminant (Full_Discr);
-               end loop;
+            if No (Discriminant_Specifications (Parent (Priv_T)))
+              and then not Has_Unknown_Discriminants (Priv_T)
+              and then Has_Discriminants (Base_Type (Priv_Parent))
+            then
+               declare
+                  Priv_Indic  : constant Node_Id :=
+                                  Subtype_Indication (Parent (Priv_T));
+
+                  Priv_Constr : constant Boolean :=
+                                  Is_Constrained (Priv_Parent)
+                                    or else
+                                      Nkind (Priv_Indic) = N_Subtype_Indication
+                                        or else
+                                          Is_Constrained (Entity (Priv_Indic));
+
+                  Full_Constr : constant Boolean :=
+                                  Is_Constrained (Full_Parent)
+                                    or else
+                                      Nkind (Full_Indic) = N_Subtype_Indication
+                                        or else
+                                          Is_Constrained (Entity (Full_Indic));
+
+                  Priv_Discr : Entity_Id;
+                  Full_Discr : Entity_Id;
 
-               if Present (Priv_Discr) or else Present (Full_Discr) then
-                  Error_Msg_N
-                    ("full view must inherit discriminants of the parent type"
-                     & " used in the private extension", Full_Indic);
+               begin
+                  Priv_Discr := First_Discriminant (Priv_Parent);
+                  Full_Discr := First_Discriminant (Full_Parent);
+                  while Present (Priv_Discr) and then Present (Full_Discr) loop
+                     if Original_Record_Component (Priv_Discr) =
+                       Original_Record_Component (Full_Discr)
+                       or else
+                         Corresponding_Discriminant (Priv_Discr) =
+                         Corresponding_Discriminant (Full_Discr)
+                     then
+                        null;
+                     else
+                        exit;
+                     end if;
 
-               elsif Priv_Constr and then not Full_Constr then
-                  Error_Msg_N
-                    ("parent subtype of full type must be constrained",
-                     Full_Indic);
+                     Next_Discriminant (Priv_Discr);
+                     Next_Discriminant (Full_Discr);
+                  end loop;
 
-               elsif Full_Constr and then not Priv_Constr then
-                  Error_Msg_N
-                    ("parent subtype of full type must be unconstrained",
-                     Full_Indic);
-               end if;
-            end;
+                  if Present (Priv_Discr) or else Present (Full_Discr) then
+                     Error_Msg_N
+                       ("full view must inherit discriminants of the parent"
+                        & " type used in the private extension", Full_Indic);
 
-         --  Check the rules of 7.3(12): if a partial view has neither known
-         --  or unknown discriminants, then the full type declaration shall
-         --  define a definite subtype.
+                  elsif Priv_Constr and then not Full_Constr then
+                     Error_Msg_N
+                       ("parent subtype of full type must be constrained",
+                        Full_Indic);
 
-         elsif      not Has_Unknown_Discriminants (Priv_T)
-           and then not Has_Discriminants (Priv_T)
-           and then not Is_Constrained (Full_T)
-         then
-            Error_Msg_N
-              ("full view must define a constrained type if partial view"
-                & " has no discriminants", Full_T);
-         end if;
+                  elsif Full_Constr and then not Priv_Constr then
+                     Error_Msg_N
+                       ("parent subtype of full type must be unconstrained",
+                        Full_Indic);
+                  end if;
+               end;
+
+               --  Check the rules of 7.3(12): if a partial view has neither
+               --  known or unknown discriminants, then the full type
+               --  declaration shall define a definite subtype.
 
-         --  ??????? Do we implement the following properly ?????
-         --  If the ancestor subtype of a private extension has constrained
-         --  discriminants, then the parent subtype of the full view shall
-         --  impose a statically matching constraint on those discriminants
-         --  [7.3(13)].
+            elsif      not Has_Unknown_Discriminants (Priv_T)
+              and then not Has_Discriminants (Priv_T)
+              and then not Is_Constrained (Full_T)
+            then
+               Error_Msg_N
+                 ("full view must define a constrained type if partial view"
+                  & " has no discriminants", Full_T);
+            end if;
+
+            --  ??????? Do we implement the following properly ?????
+            --  If the ancestor subtype of a private extension has constrained
+            --  discriminants, then the parent subtype of the full view shall
+            --  impose a statically matching constraint on those discriminants
+            --  [7.3(13)].
+         end if;
 
       else
          --  For untagged types, verify that a type without discriminants
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 22234c8..00115cc 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -5734,6 +5734,22 @@ package body Sem_Res is
          Check_For_Eliminated_Subprogram (Subp, Nam);
       end if;
 
+      --  In formal mode, the primitive operations of a tagged type or type
+      --  extension do not include functions that return the tagged type.
+
+      --  Commented out as the call to Is_Inherited_Operation_For_Type may
+      --  cause an error because the type entity of the parent node of
+      --  Entity (Name (N) may not be set.
+
+--      if Nkind (N) = N_Function_Call
+--        and then Is_Tagged_Type (Etype (N))
+--        and then Is_Entity_Name (Name (N))
+--        and then Is_Inherited_Operation_For_Type
+--         (Entity (Name (N)), Etype (N))
+--      then
+--         Check_Formal_Restriction ("function not inherited", N);
+--      end if;
+
       --  All done, evaluate call and deal with elaboration issues
 
       Eval_Call (N);
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index 2e0eb7a..02f6a6f 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -737,22 +737,12 @@ package body Sem_Type is
          else
             raise Program_Error;
          end if;
+      end if;
 
-      else
-         BT1 := Base_Type (T1);
-         BT2 := Base_Type (T2);
-
-         --  Handle underlying view of records with unknown discriminants
-         --  using the original entity that motivated the construction of
-         --  this underlying record view (see Build_Derived_Private_Type).
-
-         if Is_Underlying_Record_View (BT1) then
-            BT1 := Underlying_Record_View (BT1);
-         end if;
+      --  Trivial case: same types are always compatible
 
-         if Is_Underlying_Record_View (BT2) then
-            BT2 := Underlying_Record_View (BT2);
-         end if;
+      if T1 = T2 then
+         return True;
       end if;
 
       --  First check for Standard_Void_Type, which is special. Subsequent
@@ -762,26 +752,38 @@ package body Sem_Type is
 
       if (T1 = Standard_Void_Type) /= (T2 = Standard_Void_Type) then
          return False;
+      end if;
+
+      BT1 := Base_Type (T1);
+      BT2 := Base_Type (T2);
 
-      --  Simplest case: same types are compatible, and types that have the
-      --  same base type and are not generic actuals are compatible. Generic
-      --  actuals  belong to their class but are not compatible with other
-      --  types of their class, and in particular with other generic actuals.
-      --  They are however compatible with their own subtypes, and itypes
-      --  with the same base are compatible as well. Similarly, constrained
-      --  subtypes obtained from expressions of an unconstrained nominal type
-      --  are compatible with the base type (may lead to spurious ambiguities
-      --  in obscure cases ???)
+      --  Handle underlying view of records with unknown discriminants
+      --  using the original entity that motivated the construction of
+      --  this underlying record view (see Build_Derived_Private_Type).
+
+      if Is_Underlying_Record_View (BT1) then
+         BT1 := Underlying_Record_View (BT1);
+      end if;
+
+      if Is_Underlying_Record_View (BT2) then
+         BT2 := Underlying_Record_View (BT2);
+      end if;
+
+      --  Simplest case: types that have the same base type and are not generic
+      --  actuals are compatible. Generic actuals belong to their class but are
+      --  not compatible with other types of their class, and in particular
+      --  with other generic actuals. They are however compatible with their
+      --  own subtypes, and itypes with the same base are compatible as well.
+      --  Similarly, constrained subtypes obtained from expressions of an
+      --  unconstrained nominal type are compatible with the base type (may
+      --  lead to spurious ambiguities in obscure cases ???)
 
       --  Generic actuals require special treatment to avoid spurious ambi-
       --  guities in an instance, when two formal types are instantiated with
       --  the same actual, so that different subprograms end up with the same
       --  signature in the instance.
 
-      elsif T1 = T2 then
-         return True;
-
-      elsif BT1 = BT2
+      if BT1 = BT2
         or else BT1 = T2
         or else BT2 = T1
       then
@@ -830,7 +832,7 @@ package body Sem_Type is
         and then Is_Interface (Etype (T1))
         and then Is_Concurrent_Type (T2)
         and then Interface_Present_In_Ancestor
-                   (Typ   => Base_Type (T2),
+                   (Typ   => BT2,
                     Iface => Etype (T1))
       then
          return True;
@@ -889,7 +891,7 @@ package body Sem_Type is
       elsif Is_Class_Wide_Type (T2)
         and then
           (Class_Wide_Type (T1) = T2
-             or else Base_Type (Root_Type (T2)) = Base_Type (T1))
+             or else Base_Type (Root_Type (T2)) = BT1)
       then
          return True;
 
@@ -1037,7 +1039,7 @@ package body Sem_Type is
 
       --  The actual type may be the result of a previous error
 
-      elsif Base_Type (T2) = Any_Type then
+      elsif BT2 = Any_Type then
          return True;
 
       --  A packed array type covers its corresponding non-packed type. This is
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 8f285d7..91cc812 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6745,6 +6745,18 @@ package body Sem_Util is
                   and then Is_Derived_Type (Etype (E)));
    end Is_Inherited_Operation;
 
+   -------------------------------------
+   -- Is_Inherited_Operation_For_Type --
+   -------------------------------------
+
+   function Is_Inherited_Operation_For_Type
+     (E, Typ : Entity_Id) return Boolean
+   is
+   begin
+      return Is_Inherited_Operation (E)
+        and then Etype (Parent (E)) = Typ;
+   end Is_Inherited_Operation_For_Type;
+
    -----------------------------
    -- Is_Library_Level_Entity --
    -----------------------------
@@ -6845,27 +6857,6 @@ package body Sem_Util is
       end if;
    end Is_Object_Reference;
 
-   -------------------------------
-   -- Is_SPARK_Object_Reference --
-   -------------------------------
-
-   function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is
-   begin
-      if Is_Entity_Name (N) then
-         return Present (Entity (N))
-           and then
-             (Ekind_In (Entity (N), E_Constant, E_Variable)
-               or else Ekind (Entity (N)) in Formal_Kind);
-
-      else
-         if Nkind (N) = N_Selected_Component then
-            return Is_SPARK_Object_Reference (Prefix (N));
-         else
-            return False;
-         end if;
-      end if;
-   end Is_SPARK_Object_Reference;
-
    -----------------------------------
    -- Is_OK_Variable_For_Out_Formal --
    -----------------------------------
@@ -7377,6 +7368,29 @@ package body Sem_Util is
       end if;
    end Is_Selector_Name;
 
+   -------------------------------
+   -- Is_SPARK_Object_Reference --
+   -------------------------------
+
+   function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is
+   begin
+      if Is_Entity_Name (N) then
+         return Present (Entity (N))
+           and then
+             (Ekind_In (Entity (N), E_Constant, E_Variable)
+              or else Ekind (Entity (N)) in Formal_Kind);
+
+      else
+         case Nkind (N) is
+            when N_Selected_Component =>
+               return Is_SPARK_Object_Reference (Prefix (N));
+
+            when others =>
+               return False;
+         end case;
+      end if;
+   end Is_SPARK_Object_Reference;
+
    ------------------
    -- Is_Statement --
    ------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 6625d3f..715fc1b 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -748,7 +748,12 @@ package Sem_Util is
 
    function Is_Inherited_Operation (E : Entity_Id) return Boolean;
    --  E is a subprogram. Return True is E is an implicit operation inherited
-   --  by a derived type declarations.
+   --  by a derived type declaration.
+
+   function Is_Inherited_Operation_For_Type
+     (E, Typ : Entity_Id) return Boolean;
+   --  E is a subprogram. Return True is E is an implicit operation inherited
+   --  by the derived type declaration for type Typ.
 
    function Is_LHS (N : Node_Id) return Boolean;
    --  Returns True iff N is used as Name in an assignment statement
@@ -766,9 +771,6 @@ package Sem_Util is
    --  Determines if the tree referenced by N represents an object. Both
    --  variable and constant objects return True (compare Is_Variable).
 
-   function Is_SPARK_Object_Reference (N : Node_Id) return Boolean;
-   --  Determines if the tree referenced by N represents an object in SPARK
-
    function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean;
    --  Used to test if AV is an acceptable formal for an OUT or IN OUT formal.
    --  Note that the Is_Variable function is not quite the right test because
@@ -826,6 +828,9 @@ package Sem_Util is
    --  represent use of the N_Identifier node for a true identifier, when
    --  normally such nodes represent a direct name.
 
+   function Is_SPARK_Object_Reference (N : Node_Id) return Boolean;
+   --  Determines if the tree referenced by N represents an object in SPARK
+
    function Is_Statement (N : Node_Id) return Boolean;
    pragma Inline (Is_Statement);
    --  Check if the node N is a statement node. Note that this includes