-- 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
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
-- 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 --
------------------------
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
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
-- 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
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;
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;
-- not in Char_Code range.
function Num_Bits (Input : Uint) return Nat;
- -- Approximate number of binary bits in given universal integer.
- -- This function is used for capacity checks, and it can be one
- -- bit off without affecting its usage.
+ -- Approximate number of binary bits in given universal integer. This
+ -- function is used for capacity checks, and it can be one bit off
+ -- without affecting its usage.
---------------------
-- Output Routines --
type UI_Format is (Hex, Decimal, Auto);
-- Used to determine whether UI_Image/UI_Write output is in hexadecimal
- -- or decimal format. Auto, the default setting, lets the routine make
- -- a decision based on the value.
+ -- or decimal format. Auto, the default setting, lets the routine make a
+ -- decision based on the value.
UI_Image_Max : constant := 48; -- Enough for a 128-bit number
UI_Image_Buffer : String (1 .. UI_Image_Max);
-- followed by the value in UI_Image_Buffer. The form of the value is an
-- integer literal in either decimal (no base) or hexadecimal (base 16)
-- format. If Hex is True on entry, then hex mode is forced, otherwise
- -- UI_Image makes a guess at which output format is more convenient. The
- -- value must fit in UI_Image_Buffer. If necessary, the result is an
+ -- UI_Image makes a guess at which output format is more convenient.
+ -- The value must fit in UI_Image_Buffer. If necessary, the result is an
-- approximation of the proper value, using an exponential format. The
-- image of No_Uint is output as a single question mark.
-- Writes a representation of Uint, consisting of a possible minus sign,
-- followed by the value to the output file. The form of the value is an
-- integer literal in either decimal (no base) or hexadecimal (base 16)
- -- format as appropriate. UI_Format shows which format to use. Auto,
- -- the default, asks UI_Write to make a guess at which output format
- -- will be more convenient to read.
+ -- format as appropriate. UI_Format shows which format to use. Auto, the
+ -- default, asks UI_Write to make a guess at which output format will be
+ -- more convenient to read.
procedure pid (Input : Uint);
pragma Export (Ada, pid);
-- Mark/Release Processing --
-----------------------------
- -- The space used by Uint data is not automatically reclaimed. However,
- -- a mark-release regime is implemented which allows storage to be
- -- released back to a previously noted mark. This is used for example
- -- when doing comparisons, where only intermediate results get stored
- -- that do not need to be saved for future use.
+ -- The space used by Uint data is not automatically reclaimed. However, a
+ -- mark-release regime is implemented which allows storage to be released
+ -- back to a previously noted mark. This is used for example when doing
+ -- comparisons, where only intermediate results get stored that do not
+ -- need to be saved for future use.
type Save_Mark is private;
-- Release storage allocated since mark was noted
procedure Release_And_Save (M : Save_Mark; UI : in out Uint);
- -- Like Release, except that the given Uint value (which is typically
- -- among the data being released) is recopied after the release, so
- -- that it is the most recent item, and UI is updated to point to
- -- its copied location.
+ -- Like Release, except that the given Uint value (which is typically among
+ -- the data being released) is recopied after the release, so that it is
+ -- the most recent item, and UI is updated to point to its copied location.
procedure Release_And_Save (M : Save_Mark; UI1, UI2 : in out Uint);
-- Like Release, except that the given Uint values (which are typically
- -- among the data being released) are recopied after the release, so
- -- that they are the most recent items, and UI1 and UI2 are updated if
- -- necessary to point to the copied locations. This routine is careful
- -- to do things in the right order, so that the values do not clobber
- -- one another.
+ -- among the data being released) are recopied after the release, so that
+ -- they are the most recent items, and UI1 and UI2 are updated if necessary
+ -- to point to the copied locations. This routine is careful to do things
+ -- in the right order, so that the values do not clobber one another.
-----------------------------------
-- Representation of Uint Values --
type UI_Vector is array (Pos range <>) of Int;
-- Vector containing the integer values of a Uint value
- -- Note: An earlier version of this package used pointers of arrays
- -- of Ints (dynamically allocated) for the Uint type. The change
- -- leads to a few less natural idioms used throughout this code, but
- -- eliminates all uses of the heap except for the table package itself.
- -- For example, Uint parameters are often converted to UI_Vectors for
- -- internal manipulation. This is done by creating the local UI_Vector
- -- using the function N_Digits on the Uint to find the size needed for
- -- the vector, and then calling Init_Operand to copy the values out
- -- of the table into the vector.
+ -- Note: An earlier version of this package used pointers of arrays of Ints
+ -- (dynamically allocated) for the Uint type. The change leads to a few
+ -- less natural idioms used throughout this code, but eliminates all uses
+ -- of the heap except for the table package itself. For example, Uint
+ -- parameters are often converted to UI_Vectors for internal manipulation.
+ -- This is done by creating the local UI_Vector using the function N_Digits
+ -- on the Uint to find the size needed for the vector, and then calling
+ -- Init_Operand to copy the values out of the table into the vector.
type Uint_Entry is record
Length : Pos;
projects / platform / upstream / linaro-gcc.git / commitdiff