[multiple changes]

2012-10-01  Robert Dewar  <dewar@adacore.com>

	* checks.adb (Minimize_Eliminate_Overflow_Checks): Changes
	for exponentiation.
	* exp_ch4.adb (Expand_N_Op_Expon): Changes for Minimize/Eliminate
	overflow checks.
	* s-bignum.adb (Compare): Fix bad precondition.

2012-10-01  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Build_Derived_Record_Type): If the derived
	type has new discriminantss that constrain inherited ones, use
	the discriminant type in the original declaration to check for
	conformance, because in the presence of array components with a
	smaller range that are constrained by the origina discriminant,
	the compiler will have created a narrower subtype for that
	discriminant.

From-SVN: r191919

5 files changed, 192 insertions, 46 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 7753077..ef3d7aa 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,23 @@
 2012-10-01  Robert Dewar  <dewar@adacore.com>
 
+	* checks.adb (Minimize_Eliminate_Overflow_Checks): Changes
+	for exponentiation.
+	* exp_ch4.adb (Expand_N_Op_Expon): Changes for Minimize/Eliminate
+	overflow checks.
+	* s-bignum.adb (Compare): Fix bad precondition.
+
+2012-10-01  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch3.adb (Build_Derived_Record_Type): If the derived
+	type has new discriminantss that constrain inherited ones, use
+	the discriminant type in the original declaration to check for
+	conformance, because in the presence of array components with a
+	smaller range that are constrained by the origina discriminant,
+	the compiler will have created a narrower subtype for that
+	discriminant.
+
+2012-10-01  Robert Dewar  <dewar@adacore.com>
+
 	* checks.adb (Apply_Arithmetic_Overflow_Minimized_Eliminated):
 	Handle case of appearing in range in membership test.
 	* exp_ch4.adb (Expand_Membership_Minimize_Eliminate_Overflow):
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index b83c87f..3844d1e 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -6548,7 +6548,7 @@ package body Checks is
 
             when N_Op_Abs =>
                Lo := Uint_0;
-               Hi := UI_Max (UI_Abs (Rlo), UI_Abs (Rhi));
+               Hi := UI_Max (abs Rlo, abs Rhi);
 
             --  Addition
 
@@ -6564,7 +6564,79 @@ package body Checks is
             --  Exponentiation
 
             when N_Op_Expon =>
-               raise Program_Error;
+
+               --  Discard negative values for the exponent, since they will
+               --  simply result in an exception in any case.
+
+               if Rhi < 0 then
+                  Rhi := Uint_0;
+               elsif Rlo < 0 then
+                  Rlo := Uint_0;
+               end if;
+
+               --  Estimate number of bits in result before we go computing
+               --  giant useless bounds. Basically the number of bits in the
+               --  result is the number of bits in the base multiplied by the
+               --  value of the exponent. If this is big enough that the result
+               --  definitely won't fit in Long_Long_Integer, switch to bignum
+               --  mode immediately, and avoid computing giant bounds.
+
+               --  The comparison here is approximate, but conservative, it
+               --  only clicks on cases that are sure to exceed the bounds.
+
+               if Num_Bits (UI_Max (abs Llo, abs Lhi)) * Rhi + 1 > 100 then
+                  Lo := No_Uint;
+                  Hi := No_Uint;
+
+               --  If right operand is zero then result is 1
+
+               elsif Rhi = 0 then
+                  Lo := Uint_1;
+                  Hi := Uint_1;
+
+               else
+                  --  High bound comes either from exponentiation of largest
+                  --  positive value to largest exponent value, or from the
+                  --  exponentiation of most negative value to an odd exponent.
+
+                  declare
+                     Hi1, Hi2 : Uint;
+
+                  begin
+                     if Lhi >= 0 then
+                        Hi1 := Lhi ** Rhi;
+                     else
+                        Hi1 := Uint_0;
+                     end if;
+
+                     if Llo < 0 then
+                        if Rhi mod 2 = 0 then
+                           Hi2 := Llo ** (Rhi - 1);
+                        else
+                           Hi2 := Llo ** Rhi;
+                        end if;
+                     else
+                        Hi2 := Uint_0;
+                     end if;
+
+                     Hi := UI_Max (Hi1, Hi2);
+                  end;
+
+                  --  Result can only be negative if base can be negative
+
+                  if Llo < 0 then
+                     if UI_Mod (Rhi, 2) = 0 then
+                        Lo := Llo ** (Rhi - 1);
+                     else
+                        Lo := Llo ** Rhi;
+                     end if;
+
+                  --  Otherwise low bound is minimium ** minimum
+
+                  else
+                     Lo := Llo ** Rlo;
+                  end if;
+               end if;
 
             --  Negation
 
@@ -6623,13 +6695,13 @@ package body Checks is
 
             when others =>
                raise Program_Error;
-
          end case;
       end if;
 
       --  Case where we do the operation in Bignum mode. This happens either
       --  because one of our operands is in Bignum mode already, or because
-      --  the computed bounds are outside the bounds of Long_Long_Integer.
+      --  the computed bounds are outside the bounds of Long_Long_Integer,
+      --  which in some cases can be indicated by Hi and Lo being No_Uint.
 
       --  Note: we could do better here and in some cases switch back from
       --  Bignum mode to normal mode, e.g. big mod 2 must be in the range
@@ -6641,21 +6713,13 @@ package body Checks is
 
       if Lo = No_Uint or else Lo < LLLo or else Hi > LLHi then
 
-         --  In MINIMIZED mode, just give up and apply an overflow check
+         --  In MINIMIZED mode, note that an overflow check is required
          --  Note that we know we don't have a Bignum, since Bignums only
          --  appear in Eliminated mode.
 
          if Check_Mode = Minimized then
-            pragma Assert (Lo /= No_Uint);
             Enable_Overflow_Check (N);
 
-            --  It's fine to just return here, we may generate an overflow
-            --  exception, but this is the case in MINIMIZED mode where we
-            --  can't avoid this possibility.
-
-            Apply_Arithmetic_Overflow_Normal (N);
-            return;
-
          --  Otherwise we are in ELIMINATED mode, switch to bignum
 
          else
@@ -6721,38 +6785,64 @@ package body Checks is
                    Name                   => New_Occurrence_Of (Fent, Loc),
                    Parameter_Associations => Args));
                Analyze_And_Resolve (N, RTE (RE_Bignum));
+               return;
             end;
          end if;
 
       --  Otherwise we are in range of Long_Long_Integer, so no overflow
-      --  check is required, at least not yet. Adjust the operands to
-      --  Long_Long_Integer and mark the result type as Long_Long_Integer.
+      --  check is required, at least not yet.
 
       else
-         --  Convert right or only operand to Long_Long_Integer, except that
-         --  we do not touch the exponentiation right operand.
+         Set_Do_Overflow_Check (N, False);
+      end if;
 
-         if Nkind (N) /= N_Op_Expon then
-            Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
-         end if;
+      --  Here we will do the operation in Long_Long_Integer. We do this even
+      --  if we know an overflow check is required, better to do this in long
+      --  long integer mode, since we are less likely to overflow!
 
-         --  Convert left operand to Long_Long_Integer for binary case
+      --  Convert right or only operand to Long_Long_Integer, except that
+      --  we do not touch the exponentiation right operand.
 
-         if Binary then
-            Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
-         end if;
+      if Nkind (N) /= N_Op_Expon then
+         Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
+      end if;
 
-         --  Reset node to unanalyzed
+      --  Convert left operand to Long_Long_Integer for binary case
 
-         Set_Analyzed (N, False);
-         Set_Etype (N, Empty);
-         Set_Entity (N, Empty);
-         Set_Do_Overflow_Check (N, False);
+      if Binary then
+         Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
+      end if;
+
+      --  Reset node to unanalyzed
+
+      Set_Analyzed (N, False);
+      Set_Etype (N, Empty);
+      Set_Entity (N, Empty);
+
+      --  Now analyze this new node
 
-         --  Now analyze this new node with checks off (since we know that
-         --  we do not need an overflow check).
+      --  If no overflow check, suppress all checks
 
+      if not Do_Overflow_Check (N) then
          Analyze_And_Resolve (N, LLIB, Suppress => All_Checks);
+
+      --  If an overflow check is required, do it in normal CHECKED mode.
+      --  That avoids an infinite recursion, makes sure we get a normal
+      --  overflow check, and also completes expansion of Exponentiation.
+
+      else
+         declare
+            SG : constant Overflow_Check_Type :=
+                   Scope_Suppress.Overflow_Checks_General;
+            SA : constant Overflow_Check_Type :=
+                   Scope_Suppress.Overflow_Checks_Assertions;
+         begin
+            Scope_Suppress.Overflow_Checks_General    := Checked;
+            Scope_Suppress.Overflow_Checks_Assertions := Checked;
+            Analyze_And_Resolve (N, LLIB);
+            Scope_Suppress.Overflow_Checks_General    := SG;
+            Scope_Suppress.Overflow_Checks_Assertions := SA;
+         end;
       end if;
    end Minimize_Eliminate_Overflow_Checks;
 
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 0da3554..d87dd8f 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -3708,7 +3708,6 @@ package body Exp_Ch4 is
            (N      => Cnode,
             Msg    => "concatenation result upper bound out of range?",
             Reason => CE_Range_Check_Failed);
-         --  Set_Etype (Cnode, Atyp);
    end Expand_Concatenate;
 
    ---------------------------------------------------
@@ -7134,7 +7133,7 @@ package body Exp_Ch4 is
                 Reason => PE_Unchecked_Union_Restriction));
 
             --  Prevent Gigi from generating incorrect code by rewriting the
-            --  equality as a standard False.
+            --  equality as a standard False. (is this documented somewhere???)
 
             Rewrite (N,
               New_Occurrence_Of (Standard_False, Loc));
@@ -7161,7 +7160,7 @@ package body Exp_Ch4 is
                    Reason => PE_Unchecked_Union_Restriction));
 
                --  Prevent Gigi from generating incorrect code by rewriting
-               --  the equality as a standard False.
+               --  the equality as a standard False (documented where???).
 
                Rewrite (N,
                  New_Occurrence_Of (Standard_False, Loc));
@@ -7260,6 +7259,23 @@ package body Exp_Ch4 is
          end;
       end if;
 
+      --  Normally we complete expansion of exponentiation (e.g. converting
+      --  to multplications) right here, but there is one exception to this.
+      --  If we have a signed integer type and the overflow checking mode
+      --  is MINIMIZED or ELIMINATED and overflow checking is activated, then
+      --  we don't yet want to expand, since that will intefere with handling
+      --  of extended precision intermediate value. In this situation we just
+      --  apply the arithmetic overflow check, and then the overflow check
+      --  circuit will re-expand the exponentiation node in CHECKED mode.
+
+      if Is_Signed_Integer_Type (Rtyp)
+        and then Overflow_Check_Mode (Typ) in Minimized_Or_Eliminated
+        and then Do_Overflow_Check (N)
+      then
+         Apply_Arithmetic_Overflow_Check (N);
+         return;
+      end if;
+
       --  Test for case of known right argument
 
       if Compile_Time_Known_Value (Exp) then
@@ -10157,7 +10173,7 @@ package body Exp_Ch4 is
          then
             --  To prevent Gigi from generating illegal code, we generate a
             --  Program_Error node, but we give it the target type of the
-            --  conversion.
+            --  conversion (is this requirement documented somewhere ???)
 
             declare
                PE : constant Node_Id := Make_Raise_Program_Error (Loc,
diff --git a/gcc/ada/s-bignum.adb b/gcc/ada/s-bignum.adb
index 3474e1b..f8d2132 100644
--- a/gcc/ada/s-bignum.adb
+++ b/gcc/ada/s-bignum.adb
@@ -81,7 +81,7 @@ package body System.Bignums is
    function Compare
      (X, Y         : Digit_Vector;
       X_Neg, Y_Neg : Boolean) return Compare_Result
-   with Pre => X'First = 1 and then X'Last = 1;
+   with Pre => X'First = 1 and then Y'First = 1;
    --  Compare (X with sign X_Neg) with (Y with sign Y_Neg), and return the
    --  result of the signed comparison.
 
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 483e705..017318c 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -7541,16 +7541,38 @@ package body Sem_Ch3 is
                --  subtype must be statically compatible with the parent
                --  discriminant's subtype (3.7(15)).
 
-               if Present (Corresponding_Discriminant (Discrim))
-                 and then
-                   not Subtypes_Statically_Compatible
-                         (Etype (Discrim),
-                          Etype (Corresponding_Discriminant (Discrim)))
-               then
-                  Error_Msg_N
-                    ("subtype must be compatible with parent discriminant",
-                     Discrim);
-               end if;
+               --  However, if the record contains an array constrained by
+               --  the discriminant but with some different bound, the compiler
+               --  attemps to create a smaller range for the discriminant type.
+               --  (See exp_ch3.Adjust_Discriminants). In this case, where
+               --  the discriminant type is a scalar type, the check must use
+               --  the original discriminant type in the parent declaration.
+
+               declare
+                  Corr_Disc : constant Entity_Id :=
+                      Corresponding_Discriminant (Discrim);
+                  Disc_Type : constant Entity_Id := Etype (Discrim);
+                  Corr_Type : Entity_Id;
+
+               begin
+                  if Present (Corr_Disc) then
+                     if Is_Scalar_Type (Disc_Type) then
+                        Corr_Type :=
+                           Entity (Discriminant_Type (Parent (Corr_Disc)));
+                     else
+                        Corr_Type := Etype (Corr_Disc);
+                     end if;
+
+                     if not
+                        Subtypes_Statically_Compatible (Disc_Type, Corr_Type)
+                     then
+                        Error_Msg_N
+                          ("subtype must be compatible "
+                           & "with parent discriminant",
+                           Discrim);
+                     end if;
+                  end if;
+               end;
 
                Next_Discriminant (Discrim);
             end loop;