[Ada] Membership tests work with extended overflow checks

Arnaud Charlet charlet@adacore.com
Mon Oct 1 13:14:00 GMT 2012


This patch implements membership tests in which the operands
can be out of range in extended overflow checkig modes.

The following is a test program:

     1. pragma Ada_2012;
     2. with Text_IO; use Text_IO;
     3. procedure Overflowm3 is
     4.    subtype Int10 is Integer range 1 .. 5;
     5.    subtype IntP is Integer with Predicate => Intp = 0;
     6.
     7.    function r1
     8.      (a, b, c, d : Integer) return Boolean is
     9.    begin
    10.       return a + b + c + d in Integer'First .. Integer'Last
    11.         and then a + b + c + d in Integer
    12.         and then a + b + c + d in Intp
    13.         and then a + b + c + d not in Int10;
    14.    end;
    15.    function r2
    16.      (a, b, c, d : Integer) return Boolean is
    17.    begin
    18.       return a * b * c * d in Integer'First .. Integer'Last
    19.         and then a * b * c * d in Integer
    20.         and then a * b * c * d in Intp
    21.         and then a * b * c * d not in Int10;
    22.    end;
    23.
    24. begin
    25.    begin
    26.       Put_Line
    27.         ("r1 returns " &
    28.            Boolean'Image
    29.              (r1 (Integer'Last, Integer'Last,
    30.                   -Integer'Last, -Integer'Last)));
    31.    exception
    32.       when Constraint_Error =>
    33.          Put_Line ("r1 raises exception");
    34.    end;
    35.
    36.    begin
    37.       Put_Line
    38.         ("r2 returns " &
    39.            Boolean'Image
    40.              (r2 (Integer'Last, Integer'Last,
    41.                   Integer'Last, 0)));
    42.    exception
    43.       when Constraint_Error =>
    44.          Put_Line ("r2 raises exception");
    45.    end;
    46. end Overflowm3;

In CHECKED mode (-gnato1) we get:

r1 raises exception
r2 raises exception

since the first addition in r1 and the first multiplication
in r2 result in values outside the bounds of Integer'Base.

In MINIMIZED mode (-gnato2) we get:

r1 returns TRUE
r2 raises exception

since we can compute the addition result in Long_Long_Integer,
but the second multiplication yields a value outside this
range, so that causes an overflow.

In ELIMINATE mode (-gnato3) we get:

r1 returns TRUE
r2 returns TRUE

Because now we use Bignum arithmetic for the intermediate
multiplication results, and the final result is in range.

Tested on x86_64-pc-linux-gnu, committed on trunk

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):
	New procedure (Expand_N_In): Use
	Expand_Membership_Minimize_Eliminate_Overflow.
	* rtsfind.ads: Add RE_Bignum_In_LLI_Range.
	* s-bignum.ads, s-bignum.adb (Bignum_In_LLI_Range): New function.
	* sinfo.ads, sinfo.adb (No_Minimize_Eliminate): New flag.

-------------- next part --------------
Index: sinfo.adb
===================================================================
--- sinfo.adb	(revision 191888)
+++ sinfo.adb	(working copy)
@@ -2235,6 +2235,15 @@
       return Flag13 (N);
    end No_Initialization;
 
+   function No_Minimize_Eliminate
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_In
+        or else NT (N).Nkind = N_Not_In);
+      return Flag17 (N);
+   end No_Minimize_Eliminate;
+
    function No_Truncation
       (N : Node_Id) return Boolean is
    begin
@@ -5288,6 +5297,15 @@
       Set_Flag13 (N, Val);
    end Set_No_Initialization;
 
+   procedure Set_No_Minimize_Eliminate
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_In
+        or else NT (N).Nkind = N_Not_In);
+      Set_Flag17 (N, Val);
+   end Set_No_Minimize_Eliminate;
+
    procedure Set_No_Truncation
       (N : Node_Id; Val : Boolean := True) is
    begin
Index: sinfo.ads
===================================================================
--- sinfo.ads	(revision 191913)
+++ sinfo.ads	(working copy)
@@ -1545,6 +1545,11 @@
    --    should not be taken into account (needed for in place initialization
    --    with aggregates).
 
+   --  No_Minimize_Eliminate (Flag17-Sem)
+   --    This flag is present in membership operator nodes (N_In/N_Not_In).
+   --    It is used to indicate that processing for extended overflow checking
+   --    modes is not required (this is used to prevent infinite recursion).
+
    --  No_Truncation (Flag17-Sem)
    --    Present in N_Unchecked_Type_Conversion node. This flag has an effect
    --    only if the RM_Size of the source is greater than the RM_Size of the
@@ -3675,6 +3680,7 @@
       --  Left_Opnd (Node2)
       --  Right_Opnd (Node3)
       --  Alternatives (List4) (set to No_List if only one set alternative)
+      --  No_Minimize_Eliminate (Flag17)
       --  plus fields for expression
 
       --  N_Not_In
@@ -3682,6 +3688,7 @@
       --  Left_Opnd (Node2)
       --  Right_Opnd (Node3)
       --  Alternatives (List4) (set to No_List if only one set alternative)
+      --  No_Minimize_Eliminate (Flag17)
       --  plus fields for expression
 
       --------------------
@@ -8794,6 +8801,9 @@
    function No_Initialization
      (N : Node_Id) return Boolean;    -- Flag13
 
+   function No_Minimize_Eliminate
+     (N : Node_Id) return Boolean;    -- Flag17
+
    function No_Truncation
      (N : Node_Id) return Boolean;    -- Flag17
 
@@ -9766,6 +9776,9 @@
    procedure Set_No_Initialization
      (N : Node_Id; Val : Boolean := True);    -- Flag13
 
+   procedure Set_No_Minimize_Eliminate
+     (N : Node_Id; Val : Boolean := True);    -- Flag17
+
    procedure Set_No_Truncation
      (N : Node_Id; Val : Boolean := True);    -- Flag17
 
@@ -12017,6 +12030,7 @@
    pragma Inline (No_Elaboration_Check);
    pragma Inline (No_Entities_Ref_In_Spec);
    pragma Inline (No_Initialization);
+   pragma Inline (No_Minimize_Eliminate);
    pragma Inline (No_Truncation);
    pragma Inline (Null_Present);
    pragma Inline (Null_Exclusion_Present);
@@ -12337,6 +12351,7 @@
    pragma Inline (Set_No_Elaboration_Check);
    pragma Inline (Set_No_Entities_Ref_In_Spec);
    pragma Inline (Set_No_Initialization);
+   pragma Inline (Set_No_Minimize_Eliminate);
    pragma Inline (Set_No_Truncation);
    pragma Inline (Set_Null_Present);
    pragma Inline (Set_Null_Exclusion_Present);
Index: checks.adb
===================================================================
--- checks.adb	(revision 191915)
+++ checks.adb	(working copy)
@@ -1091,6 +1091,12 @@
       if Is_Signed_Integer_Arithmetic_Op (P)
         or else Nkind (Op) in N_Membership_Test
         or else Nkind (Op) in N_Op_Compare
+
+        --  We may also be a range operand in a membership test
+
+        or else (Nkind (Op) = N_Range
+                  and then Nkind (Parent (Op)) in N_Membership_Test)
+
       then
          return;
       end if;
Index: rtsfind.ads
===================================================================
--- rtsfind.ads	(revision 191912)
+++ rtsfind.ads	(working copy)
@@ -778,6 +778,7 @@
      RE_Big_NE,                          -- System.Bignums
 
      RE_Bignum,                          -- System.Bignums
+     RE_Bignum_In_LLI_Range,             -- System.Bignums
      RE_To_Bignum,                       -- System.Bignums
      RE_From_Bignum,                     -- System.Bignums
 
@@ -2021,6 +2022,7 @@
      RE_Big_NE                           => System_Bignums,
 
      RE_Bignum                           => System_Bignums,
+     RE_Bignum_In_LLI_Range              => System_Bignums,
      RE_To_Bignum                        => System_Bignums,
      RE_From_Bignum                      => System_Bignums,
 
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb	(revision 191914)
+++ exp_ch4.adb	(working copy)
@@ -164,6 +164,12 @@
    --  concatenation. The operands can be of any appropriate type, and can
    --  include both arrays and singleton elements.
 
+   procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id);
+   --  N is an N_In membership test mode, with the overflow check mode
+   --  set to Minimized or Eliminated, and the type of the left operand
+   --  is a signed integer type. This is a case where top level processing
+   --  is required to handle overflow checks in subtrees.
+
    procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
    --  N is a N_Op_Divide or N_Op_Multiply node whose result is universal
    --  fixed. We do not have such a type at runtime, so the purpose of this
@@ -875,7 +881,7 @@
          end;
       end if;
 
-      --  Would be nice to comment the branches of this very long if ???
+      --  Case of tagged type or type requiring finalization
 
       if Is_Tagged_Type (T) or else Needs_Finalization (T) then
          if Is_CPP_Constructor_Call (Exp) then
@@ -3705,6 +3711,332 @@
          --  Set_Etype (Cnode, Atyp);
    end Expand_Concatenate;
 
+   ---------------------------------------------------
+   -- Expand_Membership_Minimize_Eliminate_Overflow --
+   ---------------------------------------------------
+
+   procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id) is
+      pragma Assert (Nkind (N) = N_In);
+      --  Despite the name, this routine applies only to N_In, not to
+      --  N_Not_In. The latter is always rewritten as not (X in Y).
+
+      Loc   : constant Source_Ptr := Sloc (N);
+      Lop   : constant Node_Id    := Left_Opnd (N);
+      Rop   : constant Node_Id    := Right_Opnd (N);
+      Ltype : constant Entity_Id  := Etype (Lop);
+      Rtype : constant Entity_Id  := Etype (Rop);
+
+      Restype : constant Entity_Id := Etype (N);
+      --  Save result type
+
+      Lo, Hi : Uint;
+      --  Bounds in Minimize calls, not used yet ???
+
+      LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
+      --  Entity for Long_Long_Integer'Base (Standard should export this???)
+
+   begin
+      Minimize_Eliminate_Overflow_Checks (Lop, Lo, Hi);
+
+      --  If right operand is a subtype name, and the subtype name has no
+      --  predicate, then we can just replace the right operand with an
+      --  explicit range T'First .. T'Last, and use the explicit range code.
+
+      if Nkind (Rop) /= N_Range and then No (Predicate_Function (Rtype)) then
+         Rewrite (Rop,
+           Make_Range (Loc,
+             Low_Bound =>
+               Make_Attribute_Reference (Loc,
+                 Attribute_Name => Name_First,
+                 Prefix         => New_Reference_To (Rtype, Loc)),
+
+             High_Bound =>
+               Make_Attribute_Reference (Loc,
+                 Attribute_Name => Name_Last,
+                 Prefix         => New_Reference_To (Rtype, Loc))));
+         Analyze_And_Resolve (Rop, Rtype, Suppress => All_Checks);
+      end if;
+
+      --  Here for the explicit range case. Note that the bounds of the range
+      --  have not been processed for minimized or eliminated checks.
+
+      if Nkind (Rop) = N_Range then
+         Minimize_Eliminate_Overflow_Checks (Low_Bound (Rop),  Lo, Hi);
+         Minimize_Eliminate_Overflow_Checks (High_Bound (Rop), Lo, Hi);
+
+         --  We have A in B .. C, treated as  A >= B and then A <= C
+
+         --  Bignum case
+
+         if Is_RTE (Ltype, RE_Bignum)
+           or else Is_RTE (Etype (Low_Bound (Rop)), RE_Bignum)
+           or else Is_RTE (Etype (High_Bound (Rop)), RE_Bignum)
+         then
+            declare
+               Blk    : constant Node_Id   := Make_Bignum_Block (Loc);
+               Bnn    : constant Entity_Id := Make_Temporary (Loc, 'B', N);
+               Lopnd  : constant Node_Id   := Convert_To_Bignum (Lop);
+               Lbound : constant Node_Id   :=
+                          Convert_To_Bignum (Low_Bound (Rop));
+               Hbound : constant Node_Id   :=
+                          Convert_To_Bignum (High_Bound (Rop));
+
+            --  Now we insert code that looks like
+
+            --    Bnn : Boolean;
+
+            --    declare
+            --       M : Mark_Id := SS_Mark;
+            --       L : Bignum  := Lopnd;
+            --    begin
+            --       Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
+            --       SS_Release (M);
+            --    end;
+
+            --  and rewrite the membership test as a reference to Bnn
+
+            begin
+               Insert_After
+                 (Last (Declarations (Blk)),
+                  Make_Object_Declaration (Loc,
+                    Defining_Identifier => Bnn,
+                    Object_Definition   =>
+                      New_Occurrence_Of (RTE (RE_Bignum), Loc),
+                    Expression          => Lopnd));
+
+               Insert_Before
+                 (First (Statements (Handled_Statement_Sequence (Blk))),
+                  Make_Assignment_Statement (Loc,
+                    Name       => New_Occurrence_Of (Bnn, Loc),
+                    Expression =>
+                      Make_And_Then (Loc,
+                        Left_Opnd =>
+                          Make_Function_Call (Loc,
+                            Name                   =>
+                              New_Occurrence_Of (RTE (RE_Big_GE), Loc),
+                            Parameter_Associations => New_List (Lbound)),
+                        Right_Opnd =>
+                          Make_Function_Call (Loc,
+                            Name                   =>
+                              New_Occurrence_Of (RTE (RE_Big_GE), Loc),
+                            Parameter_Associations => New_List (Hbound)))));
+
+               Insert_Actions (N, New_List (
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => Bnn,
+                   Object_Definition   =>
+                     New_Occurrence_Of (Standard_Boolean, Loc)),
+                 Blk));
+
+               Rewrite (N, New_Occurrence_Of (Bnn, Loc));
+               Analyze_And_Resolve (N);
+               return;
+            end;
+
+         --  Here if no bignums around
+
+         else
+            --  Case where types are all the same
+
+            if Ltype = Etype (Low_Bound (Rop))
+                 and then
+               Ltype = Etype (High_Bound (Rop))
+            then
+               null;
+
+            --  If types are not all the same, it means that we have rewritten
+            --  at least one of them to be of type Long_Long_Integer, and we
+            --  will convert the other operands to Long_Long_Integer.
+
+            else
+               Convert_To_And_Rewrite (LLIB, Lop);
+               Analyze_And_Resolve (Lop, LLIB, Suppress => All_Checks);
+
+               Convert_To_And_Rewrite (LLIB, Low_Bound (Rop));
+               Convert_To_And_Rewrite (LLIB, High_Bound (Rop));
+               Set_Analyzed (Rop, False);
+               Analyze_And_Resolve (Rop, LLIB, Suppress => All_Checks);
+            end if;
+
+            --  Now the three operands are of the same signed integer type,
+            --  so we can use the normal expansion routine for membership.
+
+            Set_No_Minimize_Eliminate (N);
+            Expand_N_In (N);
+         end if;
+
+      --  Right operand is a subtype name and the subtype has a predicate. We
+      --  have to make sure predicate is checked, and for that we need to use
+      --  the standard N_In circuitry with appropriate types.
+
+      else
+         pragma Assert (Present (Predicate_Function (Rtype)));
+
+         --  If types are "right", just call Expand_N_In preventing recursion
+
+         if Base_Type (Ltype) = Base_Type (Rtype) then
+            Set_No_Minimize_Eliminate (N);
+            Expand_N_In (N);
+
+         --  Bignum case
+
+         elsif Is_RTE (Ltype, RE_Bignum) then
+
+            --  For X in T, we want to insert code that looks like
+
+            --    Bnn : Boolean;
+
+            --    declare
+            --       M   : Mark_Id := SS_Mark;
+            --       Lnn : Long_Long_Integer'Base
+            --       Nnn : Bignum;
+
+            --    begin
+            --      Nnn := X;
+
+            --      if not Bignum_In_LLI_Range (Nnn) then
+            --         Bnn := False;
+            --      else
+            --         Lnn := From_Bignum (Nnn);
+            --         Bnn := Lnn in T'Base and then T'Base (Lnn) in T;
+            --      end if;
+            --
+            --       SS_Release (M);
+            --    end;
+
+            --  And then rewrite the original membership as a reference to Bnn.
+            --  A bit gruesome, but here goes.
+
+            declare
+               Blk    : constant Node_Id   := Make_Bignum_Block (Loc);
+               Bnn    : constant Entity_Id := Make_Temporary (Loc, 'B', N);
+               Lnn    : constant Entity_Id := Make_Temporary (Loc, 'L', N);
+               Nnn    : constant Entity_Id := Make_Temporary (Loc, 'N', N);
+               Nin    : Node_Id;
+
+            begin
+               --  The last membership test is marked to prevent recursion
+
+               Nin :=
+                 Make_In (Loc,
+                   Left_Opnd =>
+                     Convert_To (Base_Type (Rtype),
+                       New_Occurrence_Of (Lnn, Loc)),
+                   Right_Opnd => New_Occurrence_Of (Rtype, Loc));
+               Set_No_Minimize_Eliminate (Nin);
+
+               --  Now decorate the block
+
+               Insert_After
+                 (Last (Declarations (Blk)),
+                  Make_Object_Declaration (Loc,
+                    Defining_Identifier => Lnn,
+                    Object_Definition   => New_Occurrence_Of (LLIB, Loc)));
+
+               Insert_After
+                 (Last (Declarations (Blk)),
+                  Make_Object_Declaration (Loc,
+                    Defining_Identifier => Nnn,
+                    Object_Definition   =>
+                      New_Occurrence_Of (RTE (RE_Bignum), Loc)));
+
+               Insert_List_Before
+                 (First (Statements (Handled_Statement_Sequence (Blk))),
+                  New_List (
+                    Make_Assignment_Statement (Loc,
+                      Name       => New_Occurrence_Of (Nnn, Loc),
+                      Expression => Relocate_Node (Lop)),
+
+                    Make_If_Statement (Loc,
+                      Condition =>
+                        Make_Function_Call (Loc,
+                          Name =>
+                            New_Occurrence_Of
+                              (RTE (RE_Bignum_In_LLI_Range), Loc),
+                          Parameter_Associations => New_List (
+                            New_Occurrence_Of (Nnn, Loc))),
+
+                      Then_Statements => New_List (
+                        Make_Assignment_Statement (Loc,
+                          Name       => New_Occurrence_Of (Bnn, Loc),
+                          Expression =>
+                            New_Occurrence_Of (Standard_False, Loc))),
+
+                      Else_Statements => New_List (
+                        Make_Assignment_Statement (Loc,
+                          Name => New_Occurrence_Of (Lnn, Loc),
+                          Expression =>
+                            Make_Function_Call (Loc,
+                              Name                   =>
+                                New_Occurrence_Of (RTE (RE_From_Bignum), Loc),
+                              Parameter_Associations => New_List (
+                                  New_Occurrence_Of (Nnn, Loc)))),
+
+                        Make_Assignment_Statement (Loc,
+                          Name => New_Occurrence_Of (Bnn, Loc),
+                          Expression =>
+                            Make_And_Then (Loc,
+                              Left_Opnd =>
+                                Make_In (Loc,
+                                  Left_Opnd  =>
+                                    New_Occurrence_Of (Lnn, Loc),
+                                  Right_Opnd =>
+                                    New_Occurrence_Of
+                                      (Base_Type (Rtype), Loc)),
+                              Right_Opnd => Nin))))));
+
+               Insert_Actions (N, New_List (
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => Bnn,
+                   Object_Definition   =>
+                     New_Occurrence_Of (Standard_Boolean, Loc)),
+                 Blk));
+
+               Rewrite (N, New_Occurrence_Of (Bnn, Loc));
+               Analyze_And_Resolve (N);
+               return;
+            end;
+
+         --  Not bignum case, but types don't match (this means we rewrote the
+         --  left operand to be Long_Long_Integer.
+
+         else
+            pragma Assert (Base_Type (Ltype) = LLIB);
+
+            --  We rewrite the membership test as
+
+            --    Lop in T'Base and then T'Base (Lop) in T
+
+            declare
+               Nin : Node_Id;
+
+            begin
+               --  The last membership test is marked to prevent recursion
+
+               Nin :=
+                 Make_In (Loc,
+                   Left_Opnd =>
+                     Convert_To (Base_Type (Rtype), Duplicate_Subexpr (Lop)),
+                   Right_Opnd => New_Occurrence_Of (Rtype, Loc));
+               Set_No_Minimize_Eliminate (Nin);
+
+               --  Now do the rewrite
+
+               Rewrite (N,
+                 Make_And_Then (Loc,
+                   Left_Opnd =>
+                     Make_In (Loc,
+                       Left_Opnd  => Lop,
+                       Right_Opnd =>
+                         New_Occurrence_Of (Base_Type (Ltype), Loc)),
+                   Right_Opnd => Nin));
+
+               Analyze_And_Resolve (N, Restype, Suppress => All_Checks);
+            end;
+         end if;
+      end if;
+   end Expand_Membership_Minimize_Eliminate_Overflow;
+
    ------------------------
    -- Expand_N_Allocator --
    ------------------------
@@ -5130,6 +5462,18 @@
       Ltyp := Etype (Left_Opnd  (N));
       Rtyp := Etype (Right_Opnd (N));
 
+      --  If Minimize/Eliminate overflow mode and type is a signed integer
+      --  type, then expand with a separate procedure. Note the use of the
+      --  flag No_Minimize_Eliminate to prevent infinite recursion.
+
+      if Overflow_Check_Mode (Empty) in Minimized_Or_Eliminated
+        and then Is_Signed_Integer_Type (Ltyp)
+        and then not No_Minimize_Eliminate (N)
+      then
+         Expand_Membership_Minimize_Eliminate_Overflow (N);
+         return;
+      end if;
+
       --  Check case of explicit test for an expression in range of its
       --  subtype. This is suspicious usage and we replace it with a 'Valid
       --  test and give a warning. For floating point types however, this is a
@@ -5225,9 +5569,9 @@
               and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
               and then Expr_Value (Type_Low_Bound  (Ltyp)) = Expr_Value (Lo)
 
-               --  Kill warnings in instances, since they may be cases where we
-               --  have a test in the generic that makes sense with some types
-               --  and not with other types.
+              --  Kill warnings in instances, since they may be cases where we
+              --  have a test in the generic that makes sense with some types
+              --  and not with other types.
 
               and then not In_Instance
             then
@@ -5388,8 +5732,8 @@
             --  type if they come from the original type definition. Also this
             --  way we get all the processing above for an explicit range.
 
-               --  Don't do this for predicated types, since in this case we
-               --  want to check the predicate!
+            --  Don't do this for predicated types, since in this case we
+            --  want to check the predicate!
 
             elsif Is_Scalar_Type (Typ) then
                if No (Predicate_Function (Typ)) then
@@ -5398,12 +5742,12 @@
                       Low_Bound =>
                         Make_Attribute_Reference (Loc,
                           Attribute_Name => Name_First,
-                          Prefix => New_Reference_To (Typ, Loc)),
+                          Prefix         => New_Reference_To (Typ, Loc)),
 
                       High_Bound =>
                         Make_Attribute_Reference (Loc,
                           Attribute_Name => Name_Last,
-                          Prefix => New_Reference_To (Typ, Loc))));
+                          Prefix         => New_Reference_To (Typ, Loc))));
                   Analyze_And_Resolve (N, Restyp);
                end if;
 
@@ -5423,7 +5767,7 @@
                    Reason => PE_Unchecked_Union_Restriction));
 
                --  Prevent Gigi from generating incorrect code by rewriting the
-               --  test as False.
+               --  test as False. What is this undocumented thing about ???
 
                Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
                goto Leave;
Index: s-bignum.adb
===================================================================
--- s-bignum.adb	(revision 191913)
+++ s-bignum.adb	(working copy)
@@ -963,6 +963,33 @@
       raise Constraint_Error with "expression value out of range";
    end From_Bignum;
 
+   -------------------------
+   -- Bignum_In_LLI_Range --
+   -------------------------
+
+   function Bignum_In_LLI_Range (X : Bignum) return Boolean is
+   begin
+      --  If length is 0 or 1, definitely fits
+
+      if X.Len <= 1 then
+         return True;
+
+      --  If length is greater than 2, definitely does not fit
+
+      elsif X.Len > 2 then
+         return False;
+
+      --  Length is 2, more tests needed
+
+      else
+         declare
+            Mag : constant DD := X.D (1) & X.D (2);
+         begin
+            return Mag < 2 ** 63 or else (X.Neg and then Mag = 2 ** 63);
+         end;
+      end if;
+   end Bignum_In_LLI_Range;
+
    ---------------
    -- Normalize --
    ---------------
Index: s-bignum.ads
===================================================================
--- s-bignum.ads	(revision 191912)
+++ s-bignum.ads	(working copy)
@@ -91,6 +91,10 @@
    --  Perform indicated comparison on bignums, returning result as Boolean.
    --  No exception raised for any input arguments.
 
+   function Bignum_In_LLI_Range (X : Bignum) return Boolean;
+   --  Returns True if the Bignum value is in the range of Long_Long_Integer,
+   --  so that a call to From_Bignum is guaranteed not to raise an exception.
+
    function To_Bignum (X : Long_Long_Integer) return Bignum;
    --  Convert Long_Long_Integer to Bignum. No exception can be raised for any
    --  input argument.


More information about the Gcc-patches mailing list