Loc : constant Source_Ptr := Sloc (Op);
P : constant Node_Id := Parent (Op);
+ LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
+ -- Operands and results are of this type when we convert
+
Result_Type : constant Entity_Id := Etype (Op);
-- Original result type
-- Bignum case
- elsif Etype (Op) = RTE (RE_Bignum) then
+ elsif Is_RTE (Etype (Op), RE_Bignum) then
-- We need a sequence that looks like
-- declare
-- M : Mark_Id := SS_Mark;
-- begin
- -- Rnn := Long_Long_Integer (From_Bignum (Op));
+ -- Rnn := Long_Long_Integer'Base (From_Bignum (Op));
-- SS_Release (M);
-- end;
-- A,B,C : Integer;
-- ...
- -- X := Long_Long_Integer (A * (B ** C));
+ -- X := Long_Long_Integer'Base (A * (B ** C));
-- Now the product may fit in Long_Long_Integer but not in Integer.
-- In Minimize/Eliminate mode, we don't want to introduce an overflow
-- exception for this intermediate value.
declare
- Blk : constant Node_Id := Make_Bignum_Block (Loc);
+ Blk : constant Node_Id := Make_Bignum_Block (Loc);
Rnn : constant Entity_Id := Make_Temporary (Loc, 'R', Op);
RHS : Node_Id;
RHS := Convert_From_Bignum (Op);
if Nkind (P) /= N_Type_Conversion then
- RHS := Convert_To (Result_Type, Op);
+ Convert_To_And_Rewrite (Result_Type, RHS);
Rtype := Result_Type;
-- Interesting question, do we need a check on that conversion
-- looked at later ???
else
- Rtype := Standard_Long_Long_Integer;
+ Rtype := LLIB;
end if;
Insert_Before
Analyze_And_Resolve (Op);
end;
- -- Here if the result is Long_Long_Integer
+ -- Here we know the result is Long_Long_Integer'Base
else
- pragma Assert (Etype (Op) = Standard_Long_Long_Integer);
+ pragma Assert (Etype (Op) = LLIB);
-- All we need to do here is to convert the result to the proper
-- result type. As explained above for the Bignum case, we can
Llo, Lhi : Uint;
-- Ranges of values for left operand
+ LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
+ -- Operands and results are of this type when we convert
+
LLLo, LLHi : Uint;
-- Bounds of Long_Long_Integer
-- Multiplication
when N_Op_Multiply =>
- raise Program_Error;
+
+ -- Possible bounds of multiplication must come from multiplying
+ -- end values of the input ranges (four possibilities).
+
+ declare
+ Mrk : constant Uintp.Save_Mark := Mark;
+ -- Mark so we can release the Ev values
+
+ Ev1 : constant Uint := Llo * Rlo;
+ Ev2 : constant Uint := Llo * Rhi;
+ Ev3 : constant Uint := Lhi * Rlo;
+ Ev4 : constant Uint := Lhi * Rhi;
+
+ begin
+ Lo := UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4));
+ Hi := UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4));
+
+ -- Release the Ev values
+
+ Release_And_Save (Mrk, Lo, Hi);
+ end;
-- Plus operator (affirmation)
-- 0 .. 1, but the cases are rare and it is not worth the effort.
-- Failing to do this switching back is only an efficiency issue.
- LLLo := Intval (Type_Low_Bound (Standard_Long_Long_Integer));
- LLHi := Intval (Type_High_Bound (Standard_Long_Long_Integer));
+ LLLo := Intval (Type_Low_Bound (LLIB));
+ LLHi := Intval (Type_High_Bound (LLIB));
if Lo = No_Uint or else Lo < LLLo or else Hi > LLHi then
-- Long_Long_Integer and mark the result type as Long_Long_Integer.
else
- Convert_To_And_Rewrite
- (Standard_Long_Long_Integer, Right_Opnd (N));
+ -- 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
- (Standard_Long_Long_Integer, Left_Opnd (N));
+ if Nkind (N) /= N_Op_Expon then
+ Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
end if;
- Set_Etype (N, Standard_Long_Long_Integer);
+ -- Convert left operand to Long_Long_Integer for binary case
- -- Clear entity field, since we have modified the type and mark
- -- the node as analyzed to prevent junk infinite recursion
+ 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);
- Set_Analyzed (N, True);
+ Set_Do_Overflow_Check (N, False);
- -- Turn off the overflow check flag, since this is precisely the
- -- case where we have avoided an intermediate overflow check.
+ -- Now analyze this new node with checks off (since we know that
+ -- we do not need an overflow check).
- Set_Do_Overflow_Check (N, False);
+ Analyze_And_Resolve (N, LLIB, Suppress => All_Checks);
end if;
end Minimize_Eliminate_Overflow_Checks;
with System.Secondary_Stack; use System.Secondary_Stack;
with System.Storage_Elements; use System.Storage_Elements;
-with Unchecked_Conversion;
-
package body System.Bignums is
use Interfaces;
function Allocate_Bignum (Len : Length) return Bignum is
Addr : Address;
- -- The following definitions are to allow us to set the discriminant
-
- type Header is record
- Len : Length;
- Neg : Boolean;
- end record;
-
- for Header use record
- Len at 0 range 0 .. 23;
- Neg at 3 range 0 .. 7;
- end record;
-
- type Header_Ptr is access all Header;
-
- function To_Header_Ptr is new Unchecked_Conversion (Address, Header_Ptr);
- function To_Bignum is new Unchecked_Conversion (Address, Bignum);
-
begin
- if True then
+ -- Change the if False here to if True to get allocation on the heap
+ -- instead of the secondary stack, which is convenient for debugging
+ -- System.Bignum itself.
+
+ if False then
declare
B : Bignum;
begin
return B;
end;
+ -- Normal case of allocation on the secondary stack
+
else
+ -- Note: The approach used here is designed to avoid strict aliasing
+ -- warnings that appeared previously using unchecked conversion.
+
SS_Allocate (Addr, Storage_Offset (4 + 4 * Len));
- To_Header_Ptr (Addr).Len := Len;
- return To_Bignum (Addr);
+
+ declare
+ B : Bignum;
+ for B'Address use Addr'Address;
+ pragma Import (Ada, B);
+
+ BD : Bignum_Data (Len);
+ for BD'Address use Addr;
+ pragma Import (Ada, BD);
+
+ -- Expose a writable view of discriminant BD.Len so that we can
+ -- initialize it.
+
+ BL : Length;
+ for BL'Address use BD.Len'Address;
+ pragma Import (Ada, BL);
+
+ begin
+ BL := Len;
+ return B;
+ end;
end if;
end Allocate_Bignum;
-- Do_Overflow_Check (Flag17-Sem) set if overflow check needed
-- Has_Private_View (Flag11-Sem) set in generic units.
- -- Note on use of entity field. This field is set during analysis
- -- and is used in carrying out semantic checking, but it has no
- -- significance to the back end, which is driven by the Etype's
- -- of the operands, and the Etype of the result. During processing
- -- in the exapander for overflow checks, these types may be modified
- -- and there is no point in trying to set a proper Entity value, so
- -- it just gets cleared to Empty in this situation.
-
-- "plus fields for unary operator"
-- Chars (Name1) Name_Id for the operator
-- Right_Opnd (Node3) right operand expression
-- Do_Overflow_Check (Flag17-Sem) set if overflow check needed
-- Has_Private_View (Flag11-Sem) set in generic units.
- -- See note on use of Entity field above (same situation).
-
-- "plus fields for expression"
-- Paren_Count number of parentheses levels
-- Etype (Node5-Sem) type of the expression
projects / thirdparty / gcc.git / commitdiff
