-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Errout; use Errout;
with Eval_Fat; use Eval_Fat;
with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
with Lib; use Lib;
with Namet; use Namet;
with Nmake; use Nmake;
-- This is the actual cache, with entries consisting of node/value pairs,
-- and the impossible value Node_High_Bound used for unset entries.
+ type Range_Membership is (In_Range, Out_Of_Range, Unknown);
+ -- Range membership may either be statically known to be in range or out
+ -- of range, or not statically known. Used for Test_In_Range below.
+
-----------------------
-- Local Subprograms --
-----------------------
-- used for producing the result of the static evaluation of the
-- logical operators
+ function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
+ -- Check whether an arithmetic operation with universal operands which
+ -- is a rewritten function call with an explicit scope indication is
+ -- ambiguous: P."+" (1, 2) will be ambiguous if there is more than one
+ -- visible numeric type declared in P and the context does not impose a
+ -- type on the result (e.g. in the expression of a type conversion).
+ -- If ambiguous, emit an error and return Empty, else return the result
+ -- type of the operator.
+
procedure Test_Expression_Is_Foldable
(N : Node_Id;
Op1 : Node_Id;
-- Same processing, except applies to an expression N with two operands
-- Op1 and Op2.
+ function Test_In_Range
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Assume_Valid : Boolean;
+ Fixed_Int : Boolean;
+ Int_Real : Boolean) return Range_Membership;
+ -- Common processing for Is_In_Range and Is_Out_Of_Range:
+ -- Returns In_Range or Out_Of_Range if it can be guaranteed at compile time
+ -- that expression N is known to be in or out of range of the subtype Typ.
+ -- If not compile time known, Unknown is returned.
+ -- See documentation of Is_In_Range for complete description of parameters.
+
procedure To_Bits (U : Uint; B : out Bits);
-- Converts a Uint value to a bit string of length B'Length
-- types, since we may have two NaN values and they should never
-- compare equal.
+ -- If the entity is a discriminant, the two expressions may be bounds
+ -- of components of objects of the same discriminated type. The
+ -- values of the discriminants are not static, and therefore the
+ -- result is unknown.
+
+ -- It would be better to comment individual branches of this test ???
+
if Nkind_In (Lf, N_Identifier, N_Expanded_Name)
and then Nkind_In (Rf, N_Identifier, N_Expanded_Name)
and then Entity (Lf) = Entity (Rf)
+ and then Ekind (Entity (Lf)) /= E_Discriminant
and then Present (Entity (Lf))
and then not Is_Floating_Point_Type (Etype (L))
and then not Is_Volatile_Reference (L)
Right : constant Node_Id := Right_Opnd (N);
Ltype : constant Entity_Id := Etype (Left);
Rtype : constant Entity_Id := Etype (Right);
+ Otype : Entity_Id := Empty;
Stat : Boolean;
Fold : Boolean;
return;
end if;
+ if Is_Universal_Numeric_Type (Etype (Left))
+ and then
+ Is_Universal_Numeric_Type (Etype (Right))
+ then
+ Otype := Find_Universal_Operator_Type (N);
+ end if;
+
-- Fold for cases where both operands are of integer type
if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
Fold_Uint (N, Result, Stat);
end;
- -- Cases where at least one operand is a real. We handle the cases
- -- of both reals, or mixed/real integer cases (the latter happen
- -- only for divide and multiply, and the result is always real).
+ -- Cases where at least one operand is a real. We handle the cases of
+ -- both reals, or mixed/real integer cases (the latter happen only for
+ -- divide and multiply, and the result is always real).
elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
declare
Fold_Ureal (N, Result, Stat);
end;
end if;
+
+ -- If the operator was resolved to a specific type, make sure that type
+ -- is frozen even if the expression is folded into a literal (which has
+ -- a universal type).
+
+ if Present (Otype) then
+ Freeze_Before (N, Otype);
+ end if;
end Eval_Arithmetic_Op;
----------------------------
and then Present (Alias (Entity (Name (N))))
and then Is_Enumeration_Type (Base_Type (Typ))
then
- Lit := Alias (Entity (Name (N)));
- while Present (Alias (Lit)) loop
- Lit := Alias (Lit);
- end loop;
+ Lit := Ultimate_Alias (Entity (Name (N)));
if Ekind (Lit) = E_Enumeration_Literal then
if Base_Type (Etype (Lit)) /= Base_Type (Typ) then
end if;
end Eval_Call;
+ --------------------------
+ -- Eval_Case_Expression --
+ --------------------------
+
+ -- Right now we do not attempt folding of any case expressions, and the
+ -- language does not require it, so the only required processing is to
+ -- do the check for all expressions appearing in the case expression.
+
+ procedure Eval_Case_Expression (N : Node_Id) is
+ Alt : Node_Id;
+
+ begin
+ Check_Non_Static_Context (Expression (N));
+
+ Alt := First (Alternatives (N));
+ while Present (Alt) loop
+ Check_Non_Static_Context (Expression (Alt));
+ Next (Alt);
+ end loop;
+ end Eval_Case_Expression;
+
------------------------
-- Eval_Concatenation --
------------------------
-- Eval_Conditional_Expression --
---------------------------------
- -- This GNAT internal construct can never be statically folded, so the
- -- only required processing is to do the check for non-static context
- -- for the two expression operands.
+ -- We can fold to a static expression if the condition and both constituent
+ -- expressions are static. Otherwise, the only required processing is to do
+ -- the check for non-static context for the then and else expressions.
procedure Eval_Conditional_Expression (N : Node_Id) is
- Condition : constant Node_Id := First (Expressions (N));
- Then_Expr : constant Node_Id := Next (Condition);
- Else_Expr : constant Node_Id := Next (Then_Expr);
+ Condition : constant Node_Id := First (Expressions (N));
+ Then_Expr : constant Node_Id := Next (Condition);
+ Else_Expr : constant Node_Id := Next (Then_Expr);
+ Result : Node_Id;
+ Non_Result : Node_Id;
+
+ Rstat : constant Boolean :=
+ Is_Static_Expression (Condition)
+ and then
+ Is_Static_Expression (Then_Expr)
+ and then
+ Is_Static_Expression (Else_Expr);
begin
- Check_Non_Static_Context (Then_Expr);
- Check_Non_Static_Context (Else_Expr);
+ -- If any operand is Any_Type, just propagate to result and do not try
+ -- to fold, this prevents cascaded errors.
+
+ if Etype (Condition) = Any_Type or else
+ Etype (Then_Expr) = Any_Type or else
+ Etype (Else_Expr) = Any_Type
+ then
+ Set_Etype (N, Any_Type);
+ Set_Is_Static_Expression (N, False);
+ return;
+
+ -- Static case where we can fold. Note that we don't try to fold cases
+ -- where the condition is known at compile time, but the result is
+ -- non-static. This avoids possible cases of infinite recursion where
+ -- the expander puts in a redundant test and we remove it. Instead we
+ -- deal with these cases in the expander.
+
+ elsif Rstat then
+
+ -- Select result operand
+
+ if Is_True (Expr_Value (Condition)) then
+ Result := Then_Expr;
+ Non_Result := Else_Expr;
+ else
+ Result := Else_Expr;
+ Non_Result := Then_Expr;
+ end if;
+
+ -- Note that it does not matter if the non-result operand raises a
+ -- Constraint_Error, but if the result raises constraint error then
+ -- we replace the node with a raise constraint error. This will
+ -- properly propagate Raises_Constraint_Error since this flag is
+ -- set in Result.
+
+ if Raises_Constraint_Error (Result) then
+ Rewrite_In_Raise_CE (N, Result);
+ Check_Non_Static_Context (Non_Result);
+
+ -- Otherwise the result operand replaces the original node
+
+ else
+ Rewrite (N, Relocate_Node (Result));
+ end if;
+
+ -- Case of condition not known at compile time
+
+ else
+ Check_Non_Static_Context (Condition);
+ Check_Non_Static_Context (Then_Expr);
+ Check_Non_Static_Context (Else_Expr);
+ end if;
+
+ Set_Is_Static_Expression (N, Rstat);
end Eval_Conditional_Expression;
----------------------
Right_Int : constant Uint := Expr_Value (Right);
begin
-
- -- VMS includes bitwise operations on signed types.
+ -- VMS includes bitwise operations on signed types
if Is_Modular_Integer_Type (Etype (N))
or else Is_VMS_Operator (Entity (N))
-- Ignore if error in either operand, except to make sure that Any_Type
-- is properly propagated to avoid junk cascaded errors.
- if Etype (Left) = Any_Type
- or else Etype (Right) = Any_Type
- then
+ if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
Set_Etype (N, Any_Type);
return;
end if;
+ -- Ignore if types involved have predicates
+
+ if Present (Predicate_Function (Etype (Left)))
+ or else
+ Present (Predicate_Function (Etype (Right)))
+ then
+ return;
+ end if;
+
-- Case of right operand is a subtype name
if Is_Entity_Name (Right) then
declare
Typlen : constant Uint := String_Type_Len (Etype (Right));
Strlen : constant Uint :=
- UI_From_Int (String_Length (Strval (Get_String_Val (Left))));
+ UI_From_Int
+ (String_Length (Strval (Get_String_Val (Left))));
begin
Result := (Typlen = Strlen);
end;
end if;
Fold_Uint (N, Test (Result), True);
+
Warn_On_Known_Condition (N);
end Eval_Membership_Op;
Result : Uint;
begin
- -- Exponentiation of an integer raises the exception
- -- Constraint_Error for a negative exponent (RM 4.5.6)
+ -- Exponentiation of an integer raises Constraint_Error for a
+ -- negative exponent (RM 4.5.6).
if Right_Int < 0 then
Apply_Compile_Time_Constraint_Error
begin
-- Can only fold if target is string or scalar and subtype is static.
- -- Also, do not fold if our parent is an allocator (this is because
- -- the qualified expression is really part of the syntactic structure
- -- of an allocator, and we do not want to end up with something that
+ -- Also, do not fold if our parent is an allocator (this is because the
+ -- qualified expression is really part of the syntactic structure of an
+ -- allocator, and we do not want to end up with something that
-- corresponds to "new 1" where the 1 is the result of folding a
-- qualified expression).
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Typ : constant Entity_Id := Etype (Left);
+ Otype : Entity_Id := Empty;
Result : Boolean;
Stat : Boolean;
Fold : Boolean;
-- entity name, and the two X's are the same and K1 and K2 are
-- known at compile time, in this case, the length can also be
-- computed at compile time, even though the bounds are not
- -- known. A common case of this is e.g. (X'First..X'First+5).
+ -- known. A common case of this is e.g. (X'First .. X'First+5).
Extract_Length : declare
procedure Decompose_Expr
Set_Is_Static_Expression (N, False);
end if;
+ -- For operators on universal numeric types called as functions with
+ -- an explicit scope, determine appropriate specific numeric type, and
+ -- diagnose possible ambiguity.
+
+ if Is_Universal_Numeric_Type (Etype (Left))
+ and then
+ Is_Universal_Numeric_Type (Etype (Right))
+ then
+ Otype := Find_Universal_Operator_Type (N);
+ end if;
+
-- For static real type expressions, we cannot use Compile_Time_Compare
-- since it worries about run-time results which are not exact.
Fold_Uint (N, Test (Result), Stat);
end if;
+ -- For the case of a folded relational operator on a specific numeric
+ -- type, freeze operand type now.
+
+ if Present (Otype) then
+ Freeze_Before (N, Otype);
+ end if;
+
Warn_On_Known_Condition (N);
end Eval_Relational_Op;
-- Eval_Shift --
----------------
- -- Shift operations are intrinsic operations that can never be static,
- -- so the only processing required is to perform the required check for
- -- a non static context for the two operands.
+ -- Shift operations are intrinsic operations that can never be static, so
+ -- the only processing required is to perform the required check for a non
+ -- static context for the two operands.
-- Actually we could do some compile time evaluation here some time ???
-- Eval_Short_Circuit --
------------------------
- -- A short circuit operation is potentially static if both operands
- -- are potentially static (RM 4.9 (13))
+ -- A short circuit operation is potentially static if both operands are
+ -- potentially static (RM 4.9 (13)).
procedure Eval_Short_Circuit (N : Node_Id) is
Kind : constant Node_Kind := Nkind (N);
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Left_Int : Uint;
- Rstat : constant Boolean :=
- Is_Static_Expression (Left)
- and then Is_Static_Expression (Right);
+
+ Rstat : constant Boolean :=
+ Is_Static_Expression (Left)
+ and then
+ Is_Static_Expression (Right);
begin
-- Short circuit operations are never static in Ada 83
- if Ada_Version = Ada_83
- and then Comes_From_Source (N)
- then
+ if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Check_Non_Static_Context (Left);
Check_Non_Static_Context (Right);
return;
-- are a special case, they can still be foldable, even if the right
-- operand raises constraint error.
- -- If either operand is Any_Type, just propagate to result and
- -- do not try to fold, this prevents cascaded errors.
+ -- If either operand is Any_Type, just propagate to result and do not
+ -- try to fold, this prevents cascaded errors.
if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
Set_Etype (N, Any_Type);
if (Kind = N_And_Then and then Is_False (Left_Int))
or else
- (Kind = N_Or_Else and then Is_True (Left_Int))
+ (Kind = N_Or_Else and then Is_True (Left_Int))
then
Fold_Uint (N, Left_Int, Rstat);
return;
-- Eval_Slice --
----------------
- -- Slices can never be static, so the only processing required is to
- -- check for non-static context if an explicit range is given.
+ -- Slices can never be static, so the only processing required is to check
+ -- for non-static context if an explicit range is given.
procedure Eval_Slice (N : Node_Id) is
Drange : constant Node_Id := Discrete_Range (N);
Check_Non_Static_Context (High_Bound (Drange));
end if;
- -- A slice of the form A (subtype), when the subtype is the index of
+ -- A slice of the form A (subtype), when the subtype is the index of
-- the type of A, is redundant, the slice can be replaced with A, and
-- this is worth a warning.
Error_Msg_N ("redundant slice denotes whole array?", N);
end if;
- -- The following might be a useful optimization ????
+ -- The following might be a useful optimization????
-- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
end if;
begin
-- Nothing to do if error type (handles cases like default expressions
- -- or generics where we have not yet fully resolved the type)
+ -- or generics where we have not yet fully resolved the type).
if Bas = Any_Type or else Bas = Any_String then
return;
end if;
-- Here if Etype of string literal is normal Etype (not yet possible,
- -- but may be possible in future!)
+ -- but may be possible in future).
elsif not Is_OK_Static_Expression
(Type_Low_Bound (Etype (First_Index (Typ))))
return;
end if;
- -- Test for illegal Ada 95 cases. A string literal is illegal in
- -- Ada 95 if its bounds are outside the index base type and this
- -- index type is static. This can happen in only two ways. Either
- -- the string literal is too long, or it is null, and the lower
- -- bound is type'First. In either case it is the upper bound that
- -- is out of range of the index type.
+ -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
+ -- if its bounds are outside the index base type and this index type is
+ -- static. This can happen in only two ways. Either the string literal
+ -- is too long, or it is null, and the lower bound is type'First. In
+ -- either case it is the upper bound that is out of range of the index
+ -- type.
if Ada_Version >= Ada_95 then
if Root_Type (Bas) = Standard_String
-- A type conversion is potentially static if its subtype mark is for a
-- static scalar subtype, and its operand expression is potentially static
- -- (RM 4.9 (10))
+ -- (RM 4.9(10)).
procedure Eval_Type_Conversion (N : Node_Id) is
Operand : constant Node_Id := Expression (N);
Fold : Boolean;
function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
- -- Returns true if type T is an integer type, or if it is a
- -- fixed-point type to be treated as an integer (i.e. the flag
- -- Conversion_OK is set on the conversion node).
+ -- Returns true if type T is an integer type, or if it is a fixed-point
+ -- type to be treated as an integer (i.e. the flag Conversion_OK is set
+ -- on the conversion node).
function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
-- Returns true if type T is a floating-point type, or if it is a
-------------------
-- Predefined unary operators are static functions (RM 4.9(20)) and thus
- -- are potentially static if the operand is potentially static (RM 4.9(7))
+ -- are potentially static if the operand is potentially static (RM 4.9(7)).
procedure Eval_Unary_Op (N : Node_Id) is
Right : constant Node_Id := Right_Opnd (N);
+ Otype : Entity_Id := Empty;
Stat : Boolean;
Fold : Boolean;
return;
end if;
+ if Etype (Right) = Universal_Integer
+ or else
+ Etype (Right) = Universal_Real
+ then
+ Otype := Find_Universal_Operator_Type (N);
+ end if;
+
-- Fold for integer case
if Is_Integer_Type (Etype (N)) then
Fold_Ureal (N, Result, Stat);
end;
end if;
+
+ -- If the operator was resolved to a specific type, make sure that type
+ -- is frozen even if the expression is folded into a literal (which has
+ -- a universal type).
+
+ if Present (Otype) then
+ Freeze_Before (N, Otype);
+ end if;
end Eval_Unary_Op;
-------------------------------
if Is_Entity_Name (N) then
Ent := Entity (N);
- -- An enumeration literal that was either in the source or
- -- created as a result of static evaluation.
+ -- An enumeration literal that was either in the source or created
+ -- as a result of static evaluation.
if Ekind (Ent) = E_Enumeration_Literal then
return Enumeration_Rep (Ent);
return Expr_Rep_Value (Constant_Value (Ent));
end if;
- -- An integer literal that was either in the source or created
- -- as a result of static evaluation.
+ -- An integer literal that was either in the source or created as a
+ -- result of static evaluation.
elsif Kind = N_Integer_Literal then
return Intval (N);
pragma Assert (Kind = N_Character_Literal);
Ent := Entity (N);
- -- Since Character literals of type Standard.Character don't
- -- have any defining character literals built for them, they
- -- do not have their Entity set, so just use their Char
- -- code. Otherwise for user-defined character literals use
- -- their Pos value as usual which is the same as the Rep value.
+ -- Since Character literals of type Standard.Character don't have any
+ -- defining character literals built for them, they do not have their
+ -- Entity set, so just use their Char code. Otherwise for user-
+ -- defined character literals use their Pos value as usual which is
+ -- the same as the Rep value.
if No (Ent) then
return Char_Literal_Value (N);
if Is_Entity_Name (N) then
Ent := Entity (N);
- -- An enumeration literal that was either in the source or
- -- created as a result of static evaluation.
+ -- An enumeration literal that was either in the source or created as
+ -- a result of static evaluation.
if Ekind (Ent) = E_Enumeration_Literal then
Val := Enumeration_Pos (Ent);
Val := Expr_Value (Constant_Value (Ent));
end if;
- -- An integer literal that was either in the source or created
- -- as a result of static evaluation.
+ -- An integer literal that was either in the source or created as a
+ -- result of static evaluation.
elsif Kind = N_Integer_Literal then
Val := Intval (N);
return Ureal_0;
end if;
- -- If we fall through, we have a node that cannot be interpreted
- -- as a compile time constant. That is definitely an error.
+ -- If we fall through, we have a node that cannot be interpreted as a
+ -- compile time constant. That is definitely an error.
raise Program_Error;
end Expr_Value_R;
end if;
end Expr_Value_S;
+ ----------------------------------
+ -- Find_Universal_Operator_Type --
+ ----------------------------------
+
+ function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is
+ PN : constant Node_Id := Parent (N);
+ Call : constant Node_Id := Original_Node (N);
+ Is_Int : constant Boolean := Is_Integer_Type (Etype (N));
+
+ Is_Fix : constant Boolean :=
+ Nkind (N) in N_Binary_Op
+ and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N));
+ -- A mixed-mode operation in this context indicates the presence of
+ -- fixed-point type in the designated package.
+
+ Is_Relational : constant Boolean := Etype (N) = Standard_Boolean;
+ -- Case where N is a relational (or membership) operator (else it is an
+ -- arithmetic one).
+
+ In_Membership : constant Boolean :=
+ Nkind (PN) in N_Membership_Test
+ and then
+ Nkind (Right_Opnd (PN)) = N_Range
+ and then
+ Is_Universal_Numeric_Type (Etype (Left_Opnd (PN)))
+ and then
+ Is_Universal_Numeric_Type
+ (Etype (Low_Bound (Right_Opnd (PN))))
+ and then
+ Is_Universal_Numeric_Type
+ (Etype (High_Bound (Right_Opnd (PN))));
+ -- Case where N is part of a membership test with a universal range
+
+ E : Entity_Id;
+ Pack : Entity_Id;
+ Typ1 : Entity_Id := Empty;
+ Priv_E : Entity_Id;
+
+ function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean;
+ -- Check whether one operand is a mixed-mode operation that requires the
+ -- presence of a fixed-point type. Given that all operands are universal
+ -- and have been constant-folded, retrieve the original function call.
+
+ ---------------------------
+ -- Is_Mixed_Mode_Operand --
+ ---------------------------
+
+ function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is
+ Onod : constant Node_Id := Original_Node (Op);
+ begin
+ return Nkind (Onod) = N_Function_Call
+ and then Present (Next_Actual (First_Actual (Onod)))
+ and then Etype (First_Actual (Onod)) /=
+ Etype (Next_Actual (First_Actual (Onod)));
+ end Is_Mixed_Mode_Operand;
+
+ -- Start of processing for Find_Universal_Operator_Type
+
+ begin
+ if Nkind (Call) /= N_Function_Call
+ or else Nkind (Name (Call)) /= N_Expanded_Name
+ then
+ return Empty;
+
+ -- There are several cases where the context does not imply the type of
+ -- the operands:
+ -- - the universal expression appears in a type conversion;
+ -- - the expression is a relational operator applied to universal
+ -- operands;
+ -- - the expression is a membership test with a universal operand
+ -- and a range with universal bounds.
+
+ elsif Nkind (Parent (N)) = N_Type_Conversion
+ or else Is_Relational
+ or else In_Membership
+ then
+ Pack := Entity (Prefix (Name (Call)));
+
+ -- If the prefix is a package declared elsewhere, iterate over its
+ -- visible entities, otherwise iterate over all declarations in the
+ -- designated scope.
+
+ if Ekind (Pack) = E_Package
+ and then not In_Open_Scopes (Pack)
+ then
+ Priv_E := First_Private_Entity (Pack);
+ else
+ Priv_E := Empty;
+ end if;
+
+ Typ1 := Empty;
+ E := First_Entity (Pack);
+ while Present (E) and then E /= Priv_E loop
+ if Is_Numeric_Type (E)
+ and then Nkind (Parent (E)) /= N_Subtype_Declaration
+ and then Comes_From_Source (E)
+ and then Is_Integer_Type (E) = Is_Int
+ and then
+ (Nkind (N) in N_Unary_Op
+ or else Is_Relational
+ or else Is_Fixed_Point_Type (E) = Is_Fix)
+ then
+ if No (Typ1) then
+ Typ1 := E;
+
+ -- Before emitting an error, check for the presence of a
+ -- mixed-mode operation that specifies a fixed point type.
+
+ elsif Is_Relational
+ and then
+ (Is_Mixed_Mode_Operand (Left_Opnd (N))
+ or else Is_Mixed_Mode_Operand (Right_Opnd (N)))
+ and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1)
+
+ then
+ if Is_Fixed_Point_Type (E) then
+ Typ1 := E;
+ end if;
+
+ else
+ -- More than one type of the proper class declared in P
+
+ Error_Msg_N ("ambiguous operation", N);
+ Error_Msg_Sloc := Sloc (Typ1);
+ Error_Msg_N ("\possible interpretation (inherited)#", N);
+ Error_Msg_Sloc := Sloc (E);
+ Error_Msg_N ("\possible interpretation (inherited)#", N);
+ return Empty;
+ end if;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end if;
+
+ return Typ1;
+ end Find_Universal_Operator_Type;
+
--------------------------
-- Flag_Non_Static_Expr --
--------------------------
Ent : Entity_Id;
begin
- -- If we are folding a named number, retain the entity in the
- -- literal, for ASIS use.
+ -- If we are folding a named number, retain the entity in the literal,
+ -- for ASIS use.
if Is_Entity_Name (N)
and then Ekind (Entity (N)) = E_Named_Integer
Ent : Entity_Id;
begin
- -- If we are folding a named number, retain the entity in the
- -- literal, for ASIS use.
+ -- If we are folding a named number, retain the entity in the literal,
+ -- for ASIS use.
if Is_Entity_Name (N)
and then Ekind (Entity (N)) = E_Named_Real
Fixed_Int : Boolean := False;
Int_Real : Boolean := False) return Boolean
is
- Val : Uint;
- Valr : Ureal;
-
- pragma Warnings (Off, Assume_Valid);
- -- For now Assume_Valid is unreferenced since the current implementation
- -- always returns False if N is not a compile time known value, but we
- -- keep the parameter to allow for future enhancements in which we try
- -- to get the information in the variable case as well.
-
begin
- -- Universal types have no range limits, so always in range
-
- if Typ = Universal_Integer or else Typ = Universal_Real then
- return True;
-
- -- Never in range if not scalar type. Don't know if this can
- -- actually happen, but our spec allows it, so we must check!
-
- elsif not Is_Scalar_Type (Typ) then
- return False;
-
- -- Never in range unless we have a compile time known value
-
- elsif not Compile_Time_Known_Value (N) then
- return False;
-
- -- General processing with a known compile time value
-
- else
- declare
- Lo : Node_Id;
- Hi : Node_Id;
- LB_Known : Boolean;
- UB_Known : Boolean;
-
- begin
- Lo := Type_Low_Bound (Typ);
- Hi := Type_High_Bound (Typ);
-
- LB_Known := Compile_Time_Known_Value (Lo);
- UB_Known := Compile_Time_Known_Value (Hi);
-
- -- Fixed point types should be considered as such only in
- -- flag Fixed_Int is set to False.
-
- if Is_Floating_Point_Type (Typ)
- or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
- or else Int_Real
- then
- Valr := Expr_Value_R (N);
-
- if LB_Known and then Valr >= Expr_Value_R (Lo)
- and then UB_Known and then Valr <= Expr_Value_R (Hi)
- then
- return True;
- else
- return False;
- end if;
-
- else
- Val := Expr_Value (N);
-
- if LB_Known and then Val >= Expr_Value (Lo)
- and then UB_Known and then Val <= Expr_Value (Hi)
- then
- return True;
- else
- return False;
- end if;
- end if;
- end;
- end if;
+ return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real)
+ = In_Range;
end Is_In_Range;
-------------------
-- Is_OK_Static_Subtype --
--------------------------
- -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
- -- where neither bound raises constraint error when evaluated.
+ -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
+ -- neither bound raises constraint error when evaluated.
function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
Base_T : constant Entity_Id := Base_Type (Typ);
return True;
else
- -- Scalar_Range (Typ) might be an N_Subtype_Indication, so
- -- use Get_Type_Low,High_Bound.
+ -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
+ -- Get_Type_{Low,High}_Bound.
return Is_OK_Static_Subtype (Anc_Subt)
and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
Fixed_Int : Boolean := False;
Int_Real : Boolean := False) return Boolean
is
- Val : Uint;
- Valr : Ureal;
-
- pragma Warnings (Off, Assume_Valid);
- -- For now Assume_Valid is unreferenced since the current implementation
- -- always returns False if N is not a compile time known value, but we
- -- keep the parameter to allow for future enhancements in which we try
- -- to get the information in the variable case as well.
-
begin
- -- Universal types have no range limits, so always in range
-
- if Typ = Universal_Integer or else Typ = Universal_Real then
- return False;
-
- -- Never out of range if not scalar type. Don't know if this can
- -- actually happen, but our spec allows it, so we must check!
-
- elsif not Is_Scalar_Type (Typ) then
- return False;
-
- -- Never out of range if this is a generic type, since the bounds
- -- of generic types are junk. Note that if we only checked for
- -- static expressions (instead of compile time known values) below,
- -- we would not need this check, because values of a generic type
- -- can never be static, but they can be known at compile time.
-
- elsif Is_Generic_Type (Typ) then
- return False;
-
- -- Never out of range unless we have a compile time known value
-
- elsif not Compile_Time_Known_Value (N) then
- return False;
-
- else
- declare
- Lo : Node_Id;
- Hi : Node_Id;
- LB_Known : Boolean;
- UB_Known : Boolean;
-
- begin
- Lo := Type_Low_Bound (Typ);
- Hi := Type_High_Bound (Typ);
-
- LB_Known := Compile_Time_Known_Value (Lo);
- UB_Known := Compile_Time_Known_Value (Hi);
-
- -- Real types (note that fixed-point types are not treated
- -- as being of a real type if the flag Fixed_Int is set,
- -- since in that case they are regarded as integer types).
-
- if Is_Floating_Point_Type (Typ)
- or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
- or else Int_Real
- then
- Valr := Expr_Value_R (N);
-
- if LB_Known and then Valr < Expr_Value_R (Lo) then
- return True;
-
- elsif UB_Known and then Expr_Value_R (Hi) < Valr then
- return True;
-
- else
- return False;
- end if;
-
- else
- Val := Expr_Value (N);
-
- if LB_Known and then Val < Expr_Value (Lo) then
- return True;
-
- elsif UB_Known and then Expr_Value (Hi) < Val then
- return True;
-
- else
- return False;
- end if;
- end if;
- end;
- end if;
+ return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real)
+ = Out_Of_Range;
end Is_Out_Of_Range;
---------------------
begin
-- If we have the static expression case, then this is an illegality
-- in Ada 95 mode, except that in an instance, we never generate an
- -- error (if the error is legitimate, it was already diagnosed in
- -- the template). The expression to compute the length of a packed
- -- array is attached to the array type itself, and deserves a separate
- -- message.
+ -- error (if the error is legitimate, it was already diagnosed in the
+ -- template). The expression to compute the length of a packed array is
+ -- attached to the array type itself, and deserves a separate message.
if Is_Static_Expression (N)
and then not In_Instance
(N, "value not in range of}", CE_Range_Check_Failed);
end if;
- -- Here we generate a warning for the Ada 83 case, or when we are
- -- in an instance, or when we have a non-static expression case.
+ -- Here we generate a warning for the Ada 83 case, or when we are in an
+ -- instance, or when we have a non-static expression case.
else
Apply_Compile_Time_Constraint_Error
Typ : constant Entity_Id := Etype (N);
begin
- -- If we want to raise CE in the condition of a raise_CE node
- -- we may as well get rid of the condition
+ -- If we want to raise CE in the condition of a N_Raise_CE node
+ -- we may as well get rid of the condition.
if Present (Parent (N))
and then Nkind (Parent (N)) = N_Raise_Constraint_Error
then
Set_Condition (Parent (N), Empty);
- -- If the expression raising CE is a N_Raise_CE node, we can use
- -- that one. We just preserve the type of the context
+ -- If the expression raising CE is a N_Raise_CE node, we can use that
+ -- one. We just preserve the type of the context.
elsif Nkind (Exp) = N_Raise_Constraint_Error then
Rewrite (N, Exp);
Set_Etype (N, Typ);
- -- We have to build an explicit raise_ce node
+ -- Else build an explcit N_Raise_CE
else
Rewrite (N,
T2 : Entity_Id) return Boolean
is
begin
+ -- Scalar types
+
if Is_Scalar_Type (T1) then
-- Definitely compatible if we match
then
return True;
- -- Base types must match, but we don't check that (should
- -- we???) but we do at least check that both types are
- -- real, or both types are not real.
+ -- Base types must match, but we don't check that (should we???) but
+ -- we do at least check that both types are real, or both types are
+ -- not real.
elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
return False;
end;
end if;
+ -- Access types
+
elsif Is_Access_Type (T1) then
- return not Is_Constrained (T2)
- or else Subtypes_Statically_Match
- (Designated_Type (T1), Designated_Type (T2));
+ return (not Is_Constrained (T2)
+ or else (Subtypes_Statically_Match
+ (Designated_Type (T1), Designated_Type (T2))))
+ and then not (Can_Never_Be_Null (T2)
+ and then not Can_Never_Be_Null (T1));
+
+ -- All other cases
else
return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
-- subtype, i.e. both types must be constrained or unconstrained.
-- To understand the requirement for this test, see RM 4.9.1(1).
- -- As is made clear in RM 3.5.4(11), type Integer, for example
- -- is a constrained subtype with constraint bounds matching the
- -- bounds of its corresponding unconstrained base type. In this
- -- situation, Integer and Integer'Base do not statically match,
- -- even though they have the same bounds.
+ -- As is made clear in RM 3.5.4(11), type Integer, for example is
+ -- a constrained subtype with constraint bounds matching the bounds
+ -- of its corresponding unconstrained base type. In this situation,
+ -- Integer and Integer'Base do not statically match, even though
+ -- they have the same bounds.
- -- We only apply this test to types in Standard and types that
- -- appear in user programs. That way, we do not have to be
- -- too careful about setting Is_Constrained right for itypes.
+ -- We only apply this test to types in Standard and types that appear
+ -- in user programs. That way, we do not have to be too careful about
+ -- setting Is_Constrained right for Itypes.
if Is_Numeric_Type (T1)
and then (Is_Constrained (T1) /= Is_Constrained (T2))
then
return False;
- -- A generic scalar type does not statically match its base
- -- type (AI-311). In this case we make sure that the formals,
- -- which are first subtypes of their bases, are constrained.
+ -- A generic scalar type does not statically match its base type
+ -- (AI-311). In this case we make sure that the formals, which are
+ -- first subtypes of their bases, are constrained.
elsif Is_Generic_Type (T1)
and then Is_Generic_Type (T2)
return False;
end if;
- -- If there was an error in either range, then just assume
- -- the types statically match to avoid further junk errors
+ -- If there was an error in either range, then just assume the types
+ -- statically match to avoid further junk errors.
- if Error_Posted (Scalar_Range (T1))
- or else
- Error_Posted (Scalar_Range (T2))
+ if No (Scalar_Range (T1)) or else No (Scalar_Range (T2))
+ or else Error_Posted (Scalar_Range (T1))
+ or else Error_Posted (Scalar_Range (T2))
then
return True;
end if;
then
return False;
- -- If either type has constraint error bounds, then say
- -- that they match to avoid junk cascaded errors here.
+ -- If either type has constraint error bounds, then say that
+ -- they match to avoid junk cascaded errors here.
elsif not Is_OK_Static_Subtype (T1)
or else not Is_OK_Static_Subtype (T2)
return True;
- -- A definite type does not match an indefinite or classwide type
+ -- A definite type does not match an indefinite or classwide type.
-- However, a generic type with unknown discriminants may be
-- instantiated with a type with no discriminants, and conformance
- -- checking on an inherited operation may compare the actual with
- -- the subtype that renames it in the instance.
+ -- checking on an inherited operation may compare the actual with the
+ -- subtype that renames it in the instance.
elsif
Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
elsif Is_Array_Type (T1) then
- -- If either subtype is unconstrained then both must be,
- -- and if both are unconstrained then no further checking
- -- is needed.
+ -- If either subtype is unconstrained then both must be, and if both
+ -- are unconstrained then no further checking is neede.
if not Is_Constrained (T1) or else not Is_Constrained (T2) then
return not (Is_Constrained (T1) or else Is_Constrained (T2));
end if;
- -- Both subtypes are constrained, so check that the index
- -- subtypes statically match.
+ -- Both subtypes are constrained, so check that the index subtypes
+ -- statically match.
declare
Index1 : Node_Id := First_Index (T1);
Set_Etype (N, Any_Type);
return;
- -- If left operand raises constraint error, then replace node N with
- -- the raise constraint error node, and we are obviously not foldable.
+ -- If left operand raises constraint error, then replace node N with the
+ -- Raise_Constraint_Error node, and we are obviously not foldable.
-- Is_Static_Expression is set from the two operands in the normal way,
-- and we check the right operand if it is in a non-static context.
Set_Is_Static_Expression (N, Rstat);
return;
- -- Similar processing for the case of the right operand. Note that
- -- we don't use this routine for the short-circuit case, so we do
- -- not have to worry about that special case here.
+ -- Similar processing for the case of the right operand. Note that we
+ -- don't use this routine for the short-circuit case, so we do not have
+ -- to worry about that special case here.
elsif Raises_Constraint_Error (Op2) then
if not Rstat then
return;
-- If result is not static, then check non-static contexts on operands
- -- since one of them may be static and the other one may not be static
+ -- since one of them may be static and the other one may not be static.
elsif not Rstat then
Check_Non_Static_Context (Op1);
and then Compile_Time_Known_Value (Op2);
return;
- -- Else result is static and foldable. Both operands are static,
- -- and neither raises constraint error, so we can definitely fold.
+ -- Else result is static and foldable. Both operands are static, and
+ -- neither raises constraint error, so we can definitely fold.
else
Set_Is_Static_Expression (N);
end if;
end Test_Expression_Is_Foldable;
+ -------------------
+ -- Test_In_Range --
+ -------------------
+
+ function Test_In_Range
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Assume_Valid : Boolean;
+ Fixed_Int : Boolean;
+ Int_Real : Boolean) return Range_Membership
+ is
+ Val : Uint;
+ Valr : Ureal;
+
+ pragma Warnings (Off, Assume_Valid);
+ -- For now Assume_Valid is unreferenced since the current implementation
+ -- always returns Unknown if N is not a compile time known value, but we
+ -- keep the parameter to allow for future enhancements in which we try
+ -- to get the information in the variable case as well.
+
+ begin
+ -- Universal types have no range limits, so always in range
+
+ if Typ = Universal_Integer or else Typ = Universal_Real then
+ return In_Range;
+
+ -- Never known if not scalar type. Don't know if this can actually
+ -- happen, but our spec allows it, so we must check!
+
+ elsif not Is_Scalar_Type (Typ) then
+ return Unknown;
+
+ -- Never known if this is a generic type, since the bounds of generic
+ -- types are junk. Note that if we only checked for static expressions
+ -- (instead of compile time known values) below, we would not need this
+ -- check, because values of a generic type can never be static, but they
+ -- can be known at compile time.
+
+ elsif Is_Generic_Type (Typ) then
+ return Unknown;
+
+ -- Never known unless we have a compile time known value
+
+ elsif not Compile_Time_Known_Value (N) then
+ return Unknown;
+
+ -- General processing with a known compile time value
+
+ else
+ declare
+ Lo : Node_Id;
+ Hi : Node_Id;
+
+ LB_Known : Boolean;
+ HB_Known : Boolean;
+
+ begin
+ Lo := Type_Low_Bound (Typ);
+ Hi := Type_High_Bound (Typ);
+
+ LB_Known := Compile_Time_Known_Value (Lo);
+ HB_Known := Compile_Time_Known_Value (Hi);
+
+ -- Fixed point types should be considered as such only if flag
+ -- Fixed_Int is set to False.
+
+ if Is_Floating_Point_Type (Typ)
+ or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
+ or else Int_Real
+ then
+ Valr := Expr_Value_R (N);
+
+ if LB_Known and HB_Known then
+ if Valr >= Expr_Value_R (Lo)
+ and then
+ Valr <= Expr_Value_R (Hi)
+ then
+ return In_Range;
+ else
+ return Out_Of_Range;
+ end if;
+
+ elsif (LB_Known and then Valr < Expr_Value_R (Lo))
+ or else
+ (HB_Known and then Valr > Expr_Value_R (Hi))
+ then
+ return Out_Of_Range;
+
+ else
+ return Unknown;
+ end if;
+
+ else
+ Val := Expr_Value (N);
+
+ if LB_Known and HB_Known then
+ if Val >= Expr_Value (Lo)
+ and then
+ Val <= Expr_Value (Hi)
+ then
+ return In_Range;
+ else
+ return Out_Of_Range;
+ end if;
+
+ elsif (LB_Known and then Val < Expr_Value (Lo))
+ or else
+ (HB_Known and then Val > Expr_Value (Hi))
+ then
+ return Out_Of_Range;
+
+ else
+ return Unknown;
+ end if;
+ end if;
+ end;
+ end if;
+ end Test_In_Range;
+
--------------
-- To_Bits --
--------------
E : Entity_Id;
procedure Why_Not_Static_List (L : List_Id);
- -- A version that can be called on a list of expressions. Finds
- -- all non-static violations in any element of the list.
+ -- A version that can be called on a list of expressions. Finds all
+ -- non-static violations in any element of the list.
-------------------------
-- Why_Not_Static_List --
-- Start of processing for Why_Not_Static
begin
- -- If in ACATS mode (debug flag 2), then suppress all these
- -- messages, this avoids massive updates to the ACATS base line.
+ -- If in ACATS mode (debug flag 2), then suppress all these messages,
+ -- this avoids massive updates to the ACATS base line.
if Debug_Flag_2 then
return;
return;
- -- Special case generic types, since again this is a common
- -- source of confusion.
+ -- Special case generic types, since again this is a common source
+ -- of confusion.
elsif Is_Generic_Actual_Type (E)
or else
when N_Type_Conversion =>
Why_Not_Static (Expression (N));
- if not Is_Scalar_Type (Etype (Prefix (N)))
- or else not Is_Static_Subtype (Etype (Prefix (N)))
+ if not Is_Scalar_Type (Entity (Subtype_Mark (N)))
+ or else not Is_Static_Subtype (Entity (Subtype_Mark (N)))
then
Error_Msg_N
("static conversion requires static scalar subtype result " &
OSDN Git Service
