Skip to content

R
riscv-gcc-1
Commit 80298c3b by Arnaud Charlet
Options

[multiple changes] 

2014-06-13  Robert Dewar  <dewar@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference, case Pred/Succ): Change
	reason to Overflow.

2014-06-13  Robert Dewar  <dewar@adacore.com>

	* makeutl.adb: Minor reformatting.

2014-06-13  Gail Schenker  <schenker@adacore.com>

	* debug.adb, sem_eval.adb (Why_Not_Static): Remove temporary code and
	associated flag (d.z), no longer needed.

2014-06-13  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch13.adb (Analyze_Aspect_Specifications): For Import and
	Export aspects, do not check whether a corresponding Convention
	aspect has been specified. Convention is optional in Ada2012,
	and defaults to Convention_Ada.

From-SVN: r211624
parent 0083dd66
Showing with 192 additions and 274 deletions
gcc/ada/ChangeLog
2014-06-13 Robert Dewar <dewar@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference, case Pred/Succ): Change
reason to Overflow.
2014-06-13 Robert Dewar <dewar@adacore.com>
* makeutl.adb: Minor reformatting.
2014-06-13 Gail Schenker <schenker@adacore.com>
* debug.adb, sem_eval.adb (Why_Not_Static): Remove temporary code and
associated flag (d.z), no longer needed.
2014-06-13 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications): For Import and
Export aspects, do not check whether a corresponding Convention
aspect has been specified. Convention is optional in Ada2012,
and defaults to Convention_Ada.
2014-06-13 Eric Botcazou <ebotcazou@adacore.com> 2014-06-13 Eric Botcazou <ebotcazou@adacore.com>
* checks.adb (Apply_Address_Clause_Check): Only issue the new * checks.adb (Apply_Address_Clause_Check): Only issue the new
......
gcc/ada/debug.adb
...@@ -116,7 +116,7 @@ package body Debug is ...@@ -116,7 +116,7 @@ package body Debug is
-- d.w Do not check for infinite loops -- d.w Do not check for infinite loops
-- d.x No exception handlers -- d.x No exception handlers
-- d.y -- d.y
-- d.z Temporary ASIS kludge for why non-static messages -- d.z
-- d.A Read/write Aspect_Specifications hash table to tree -- d.A Read/write Aspect_Specifications hash table to tree
-- d.B -- d.B
...@@ -599,11 +599,6 @@ package body Debug is ...@@ -599,11 +599,6 @@ package body Debug is
-- fully compiled and analyzed, they just get eliminated from the -- fully compiled and analyzed, they just get eliminated from the
-- code generation step. -- code generation step.
-- d.z Temporary debug switch for control of the why non-static messages
-- generated by Why_Non_Static. Normally these messages are suppressed
-- in ASIS mode (d2), but if d.z is set they are not suppressed. This
-- is a temporary switch to aid in updating ASIS base lines.
-- d.A There seems to be a problem with ASIS if we activate the circuit -- d.A There seems to be a problem with ASIS if we activate the circuit
-- for reading and writing the aspect specification hash table, so -- for reading and writing the aspect specification hash table, so
-- for now, this is controlled by the debug flag d.A. The hash table -- for now, this is controlled by the debug flag d.A. The hash table
......
gcc/ada/exp_attr.adb
...@@ -4536,7 +4536,7 @@ package body Exp_Attr is ...@@ -4536,7 +4536,7 @@ package body Exp_Attr is
Attribute_Name => Name_First, Attribute_Name => Name_First,
Prefix => Prefix =>
New_Occurrence_Of (Base_Type (Ptyp), Loc))), New_Occurrence_Of (Base_Type (Ptyp), Loc))),
Reason => CE_Range_Check_Failed), Reason => CE_Overflow_Check_Failed),
Suppress => All_Checks); Suppress => All_Checks);
end if; end if;
end; end;
...@@ -5611,7 +5611,7 @@ package body Exp_Attr is ...@@ -5611,7 +5611,7 @@ package body Exp_Attr is
Attribute_Name => Name_Last, Attribute_Name => Name_Last,
Prefix => Prefix =>
New_Occurrence_Of (Base_Type (Ptyp), Loc))), New_Occurrence_Of (Base_Type (Ptyp), Loc))),
Reason => CE_Range_Check_Failed), Reason => CE_Overflow_Check_Failed),
Suppress => All_Checks); Suppress => All_Checks);
end if; end if;
end; end;
......
gcc/ada/makeutl.adb
...@@ -309,10 +309,10 @@ package body Makeutl is ...@@ -309,10 +309,10 @@ package body Makeutl is
if Replacement /= No_File then if Replacement /= No_File then
if Verbose_Mode then if Verbose_Mode then
Write_Line Write_Line
("source file" & ("source file"
Get_Name_String (SD.Sfile) & & Get_Name_String (SD.Sfile)
" has been replaced by " & & " has been replaced by "
Get_Name_String (Replacement)); & Get_Name_String (Replacement));
end if; end if;
return No_Name; return No_Name;
...@@ -648,10 +648,10 @@ package body Makeutl is ...@@ -648,10 +648,10 @@ package body Makeutl is
if Sw (J) = Directory_Separator then if Sw (J) = Directory_Separator then
Switch := Switch :=
new String' new String'
(Sw (1 .. Start - 1) & (Sw (1 .. Start - 1)
Parent & & Parent
Directory_Separator & & Directory_Separator
Sw (Start .. Sw'Last)); & Sw (Start .. Sw'Last));
return; return;
end if; end if;
end loop; end loop;
...@@ -659,10 +659,10 @@ package body Makeutl is ...@@ -659,10 +659,10 @@ package body Makeutl is
else else
Switch := Switch :=
new String' new String'
(Sw (1 .. Start - 1) & (Sw (1 .. Start - 1)
Parent & & Parent
Directory_Separator & & Directory_Separator
Sw (Start .. Sw'Last)); & Sw (Start .. Sw'Last));
end if; end if;
end if; end if;
...@@ -1999,8 +1999,8 @@ package body Makeutl is ...@@ -1999,8 +1999,8 @@ package body Makeutl is
if Project.Library then if Project.Library then
Fail_Program Fail_Program
(Tree, (Tree,
"cannot specify a main program " & "cannot specify a main program "
"for a library project file"); & "for a library project file");
end if; end if;
Add_Main (Name => Get_Name_String (Element.Value), Add_Main (Name => Get_Name_String (Element.Value),
...@@ -2118,8 +2118,8 @@ package body Makeutl is ...@@ -2118,8 +2118,8 @@ package body Makeutl is
if Names.Last = 0 then if Names.Last = 0 then
Fail_Program Fail_Program
(Project_Tree, (Project_Tree,
"cannot specify a multi-unit index but no main " & "cannot specify a multi-unit index but no main "
"on the command line"); & "on the command line");
elsif Names.Last > 1 then elsif Names.Last > 1 then
Fail_Program Fail_Program
...@@ -3153,10 +3153,10 @@ package body Makeutl is ...@@ -3153,10 +3153,10 @@ package body Makeutl is
if Current_Verbosity = High then if Current_Verbosity = High then
Debug_Output ("compilation phases: " Debug_Output ("compilation phases: "
& " compile=" & Data.Need_Compilation'Img & " compile=" & Data.Need_Compilation'Img
& " bind=" & Data.Need_Binding'Img & " bind=" & Data.Need_Binding'Img
& " link=" & Data.Need_Linking'Img & " link=" & Data.Need_Linking'Img
& " closure=" & Data.Closure_Needed'Img & " closure=" & Data.Closure_Needed'Img
& " mains=" & Data.Number_Of_Mains'Img, & " mains=" & Data.Number_Of_Mains'Img,
Project.Name); Project.Name);
end if; end if;
end Do_Compute; end Do_Compute;
...@@ -3313,13 +3313,12 @@ package body Makeutl is ...@@ -3313,13 +3313,12 @@ package body Makeutl is
then then
Prj.Err.Error_Msg Prj.Err.Error_Msg
(Env.Flags, (Env.Flags,
"Default_Switches forbidden in presence of " & "Default_Switches forbidden in presence of "
"Global_Compilation_Switches. Use Switches instead.", & "Global_Compilation_Switches. Use Switches instead.",
Project_Tree.Shared.Arrays.Table Project_Tree.Shared.Arrays.Table
(Default_Switches_Array).Location); (Default_Switches_Array).Location);
Fail_Program Fail_Program
(Project_Tree, (Project_Tree, "*** illegal combination of Builder attributes");
"*** illegal combination of Builder attributes");
end if; end if;
if Lang /= No_Name then if Lang /= No_Name then
...@@ -3433,14 +3432,14 @@ package body Makeutl is ...@@ -3433,14 +3432,14 @@ package body Makeutl is
Prj.Err.Error_Msg Prj.Err.Error_Msg
(Env.Flags, (Env.Flags,
'"' & Name_Buffer (1 .. Name_Len) & '"' & Name_Buffer (1 .. Name_Len)
""" is not a builder switch. Consider moving " & & """ is not a builder switch. Consider moving "
"it to Global_Compilation_Switches.", & "it to Global_Compilation_Switches.",
Element.Location); Element.Location);
Fail_Program Fail_Program
(Project_Tree, (Project_Tree,
"*** illegal switch """ & "*** illegal switch """
Get_Name_String (Element.Value) & '"'); & Get_Name_String (Element.Value) & '"');
end if; end if;
end if; end if;
......
gcc/ada/sem_ch13.adb
...@@ -2704,50 +2704,12 @@ package body Sem_Ch13 is ...@@ -2704,50 +2704,12 @@ package body Sem_Ch13 is
Set_Never_Set_In_Source (E, False); Set_Never_Set_In_Source (E, False);
end if; end if;
-- Verify that there is an aspect Convention that will -- In older versions of Ada the corresponding pragmas
-- incorporate the Import/Export aspect, and eventual -- specified a Convention. In Ada 2012 the convention
-- Link/External names. -- is specified as a separate aspect, and it is optional,
-- given that it defaults to Convention_Ada. The code
declare -- that verifed that there was a matching convention
A : Node_Id; -- is now obsolete.
begin
A := First (L);
while Present (A) loop
exit when Chars (Identifier (A)) = Name_Convention;
Next (A);
end loop;
-- It is legal to specify Import for a variable, in
-- order to suppress initialization for it, without
-- specifying explicitly its convention. However this
-- is only legal if the convention of the object type
-- is Ada or similar.
if No (A) then
if Ekind (E) = E_Variable
and then A_Id = Aspect_Import
then
declare
C : constant Convention_Id :=
Convention (Etype (E));
begin
if C = Convention_Ada or else
C = Convention_Ada_Pass_By_Copy or else
C = Convention_Ada_Pass_By_Reference
then
goto Continue;
end if;
end;
end if;
-- Otherwise, Convention must be specified
Error_Msg_N
("missing Convention aspect for Export/Import",
Aspect);
end if;
end;
goto Continue; goto Continue;
end if; end if;
......
gcc/ada/sem_eval.adb
...@@ -102,7 +102,7 @@ package body Sem_Eval is ...@@ -102,7 +102,7 @@ package body Sem_Eval is
type Bits is array (Nat range <>) of Boolean; type Bits is array (Nat range <>) of Boolean;
-- Used to convert unsigned (modular) values for folding logical ops -- Used to convert unsigned (modular) values for folding logical ops
-- The following definitions are used to maintain a cache of nodes that -- The following declarations are used to maintain a cache of nodes that
-- have compile time known values. The cache is maintained only for -- have compile time known values. The cache is maintained only for
-- discrete types (the most common case), and is populated by calls to -- discrete types (the most common case), and is populated by calls to
-- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
...@@ -138,43 +138,43 @@ package body Sem_Eval is ...@@ -138,43 +138,43 @@ package body Sem_Eval is
----------------------- -----------------------
function From_Bits (B : Bits; T : Entity_Id) return Uint; function From_Bits (B : Bits; T : Entity_Id) return Uint;
-- Converts a bit string of length B'Length to a Uint value to be used -- Converts a bit string of length B'Length to a Uint value to be used for
-- for a target of type T, which is a modular type. This procedure -- a target of type T, which is a modular type. This procedure includes the
-- includes the necessary reduction by the modulus in the case of a -- necessary reduction by the modulus in the case of a non-binary modulus
-- non-binary modulus (for a binary modulus, the bit string is the -- (for a binary modulus, the bit string is the right length any way so all
-- right length any way so all is well). -- is well).
function Get_String_Val (N : Node_Id) return Node_Id; function Get_String_Val (N : Node_Id) return Node_Id;
-- Given a tree node for a folded string or character value, returns -- Given a tree node for a folded string or character value, returns the
-- the corresponding string literal or character literal (one of the -- corresponding string literal or character literal (one of the two must
-- two must be available, or the operand would not have been marked -- be available, or the operand would not have been marked as foldable in
-- as foldable in the earlier analysis of the operation). -- the earlier analysis of the operation).
function OK_Bits (N : Node_Id; Bits : Uint) return Boolean; function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
-- Bits represents the number of bits in an integer value to be computed -- Bits represents the number of bits in an integer value to be computed
-- (but the value has not been computed yet). If this value in Bits is -- (but the value has not been computed yet). If this value in Bits is
-- reasonable, a result of True is returned, with the implication that -- reasonable, a result of True is returned, with the implication that the
-- the caller should go ahead and complete the calculation. If the value -- caller should go ahead and complete the calculation. If the value in
-- in Bits is unreasonably large, then an error is posted on node N, and -- Bits is unreasonably large, then an error is posted on node N, and
-- False is returned (and the caller skips the proposed calculation). -- False is returned (and the caller skips the proposed calculation).
procedure Out_Of_Range (N : Node_Id); procedure Out_Of_Range (N : Node_Id);
-- This procedure is called if it is determined that node N, which -- This procedure is called if it is determined that node N, which appears
-- appears in a non-static context, is a compile time known value -- in a non-static context, is a compile time known value which is outside
-- which is outside its range, i.e. the range of Etype. This is used -- its range, i.e. the range of Etype. This is used in contexts where
-- in contexts where this is an illegality if N is static, and should -- this is an illegality if N is static, and should generate a warning
-- generate a warning otherwise. -- otherwise.
procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id); procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
-- N and Exp are nodes representing an expression, Exp is known -- N and Exp are nodes representing an expression, Exp is known to raise
-- to raise CE. N is rewritten in term of Exp in the optimal way. -- CE. N is rewritten in term of Exp in the optimal way.
function String_Type_Len (Stype : Entity_Id) return Uint; function String_Type_Len (Stype : Entity_Id) return Uint;
-- Given a string type, determines the length of the index type, or, -- Given a string type, determines the length of the index type, or, if
-- if this index type is non-static, the length of the base type of -- this index type is non-static, the length of the base type of this index
-- this index type. Note that if the string type is itself static, -- type. Note that if the string type is itself static, then the index type
-- then the index type is static, so the second case applies only -- is static, so the second case applies only if the string type passed is
-- if the string type passed is non-static. -- non-static.
function Test (Cond : Boolean) return Uint; function Test (Cond : Boolean) return Uint;
pragma Inline (Test); pragma Inline (Test);
...@@ -184,13 +184,12 @@ package body Sem_Eval is ...@@ -184,13 +184,12 @@ package body Sem_Eval is
-- logical operators -- logical operators
function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id; function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
-- Check whether an arithmetic operation with universal operands which -- Check whether an arithmetic operation with universal operands which is a
-- is a rewritten function call with an explicit scope indication is -- rewritten function call with an explicit scope indication is ambiguous:
-- ambiguous: P."+" (1, 2) will be ambiguous if there is more than one -- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
-- visible numeric type declared in P and the context does not impose a -- type declared in P and the context does not impose a type on the result
-- type on the result (e.g. in the expression of a type conversion). -- (e.g. in the expression of a type conversion). If ambiguous, emit an
-- If ambiguous, emit an error and return Empty, else return the result -- error and return Empty, else return the result type of the operator.
-- type of the operator.
procedure Test_Expression_Is_Foldable procedure Test_Expression_Is_Foldable
(N : Node_Id; (N : Node_Id;
...@@ -199,29 +198,29 @@ package body Sem_Eval is ...@@ -199,29 +198,29 @@ package body Sem_Eval is
Fold : out Boolean); Fold : out Boolean);
-- Tests to see if expression N whose single operand is Op1 is foldable, -- Tests to see if expression N whose single operand is Op1 is foldable,
-- i.e. the operand value is known at compile time. If the operation is -- i.e. the operand value is known at compile time. If the operation is
-- foldable, then Fold is True on return, and Stat indicates whether -- foldable, then Fold is True on return, and Stat indicates whether the
-- the result is static (i.e. the operand was static). Note that it -- result is static (i.e. the operand was static). Note that it is quite
-- is quite possible for Fold to be True, and Stat to be False, since -- possible for Fold to be True, and Stat to be False, since there are
-- there are cases in which we know the value of an operand even though -- cases in which we know the value of an operand even though it is not
-- it is not technically static (e.g. the static lower bound of a range -- technically static (e.g. the static lower bound of a range whose upper
-- whose upper bound is non-static). -- bound is non-static).
-- --
-- If Stat is set False on return, then Test_Expression_Is_Foldable makes a -- If Stat is set False on return, then Test_Expression_Is_Foldable makes
-- call to Check_Non_Static_Context on the operand. If Fold is False on -- a call to Check_Non_Static_Context on the operand. If Fold is False on
-- return, then all processing is complete, and the caller should -- return, then all processing is complete, and the caller should return,
-- return, since there is nothing else to do. -- since there is nothing else to do.
-- --
-- If Stat is set True on return, then Is_Static_Expression is also set -- If Stat is set True on return, then Is_Static_Expression is also set
-- true in node N. There are some cases where this is over-enthusiastic, -- true in node N. There are some cases where this is over-enthusiastic,
-- e.g. in the two operand case below, for string comparison, the result -- e.g. in the two operand case below, for string comparison, the result is
-- is not static even though the two operands are static. In such cases, -- not static even though the two operands are static. In such cases, the
-- the caller must reset the Is_Static_Expression flag in N. -- caller must reset the Is_Static_Expression flag in N.
-- --
-- If Fold and Stat are both set to False then this routine performs also -- If Fold and Stat are both set to False then this routine performs also
-- the following extra actions: -- the following extra actions:
-- --
-- If either operand is Any_Type then propagate it to result to -- If either operand is Any_Type then propagate it to result to prevent
-- prevent cascaded errors. -- cascaded errors.
-- --
-- If some operand raises constraint error, then replace the node N -- If some operand raises constraint error, then replace the node N
-- with the raise constraint error node. This replacement inherits the -- with the raise constraint error node. This replacement inherits the
...@@ -278,8 +277,8 @@ package body Sem_Eval is ...@@ -278,8 +277,8 @@ package body Sem_Eval is
end if; end if;
-- At this stage we have a scalar type. If we have an expression that -- At this stage we have a scalar type. If we have an expression that
-- raises CE, then we already issued a warning or error msg so there -- raises CE, then we already issued a warning or error msg so there is
-- is nothing more to be done in this routine. -- nothing more to be done in this routine.
if Raises_Constraint_Error (N) then if Raises_Constraint_Error (N) then
return; return;
...@@ -370,7 +369,7 @@ package body Sem_Eval is ...@@ -370,7 +369,7 @@ package body Sem_Eval is
and then Nkind (Parent (N)) in N_Subexpr and then Nkind (Parent (N)) in N_Subexpr
and then and then
(Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer)) (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
or else or else
Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer))) Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
then then
Apply_Compile_Time_Constraint_Error Apply_Compile_Time_Constraint_Error
...@@ -387,9 +386,7 @@ package body Sem_Eval is ...@@ -387,9 +386,7 @@ package body Sem_Eval is
-- appears in a range that could be null (warnings are handled elsewhere -- appears in a range that could be null (warnings are handled elsewhere
-- for this case). -- for this case).
elsif T /= Base_Type (T) elsif T /= Base_Type (T) and then Nkind (Parent (N)) /= N_Range then
and then Nkind (Parent (N)) /= N_Range
then
if Is_In_Range (N, T, Assume_Valid => True) then if Is_In_Range (N, T, Assume_Valid => True) then
null; null;
...@@ -413,8 +410,7 @@ package body Sem_Eval is ...@@ -413,8 +410,7 @@ package body Sem_Eval is
procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
begin begin
if not Raises_Constraint_Error (N) and then Is_Constrained (Ttype) then if not Raises_Constraint_Error (N) and then Is_Constrained (Ttype) then
if if UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
then then
Apply_Compile_Time_Constraint_Error Apply_Compile_Time_Constraint_Error
(N, "string length wrong for}??", (N, "string length wrong for}??",
...@@ -550,9 +546,9 @@ package body Sem_Eval is ...@@ -550,9 +546,9 @@ package body Sem_Eval is
Xtyp := Designated_Type (Xtyp); Xtyp := Designated_Type (Xtyp);
end if; end if;
-- If we don't have an array type at this stage, something -- If we don't have an array type at this stage, something is
-- is peculiar, e.g. another error, and we abandon the attempt -- peculiar, e.g. another error, and we abandon the attempt at
-- at a fixup. -- a fixup.
if not Is_Array_Type (Xtyp) then if not Is_Array_Type (Xtyp) then
return N; return N;
...@@ -567,11 +563,11 @@ package body Sem_Eval is ...@@ -567,11 +563,11 @@ package body Sem_Eval is
if Ekind (Xtyp) = E_String_Literal_Subtype then if Ekind (Xtyp) = E_String_Literal_Subtype then
if Attribute_Name (N) = Name_First then if Attribute_Name (N) = Name_First then
return String_Literal_Low_Bound (Xtyp); return String_Literal_Low_Bound (Xtyp);
else else
return Make_Integer_Literal (Sloc (N), return
Intval => Intval (String_Literal_Low_Bound (Xtyp)) Make_Integer_Literal (Sloc (N),
+ String_Literal_Length (Xtyp)); Intval => Intval (String_Literal_Low_Bound (Xtyp)) +
String_Literal_Length (Xtyp));
end if; end if;
end if; end if;
...@@ -611,7 +607,7 @@ package body Sem_Eval is ...@@ -611,7 +607,7 @@ package body Sem_Eval is
or else Ekind (Entity (Opnd)) = E_In_Parameter or else Ekind (Entity (Opnd)) = E_In_Parameter
or else or else
(Ekind (Entity (Opnd)) in Object_Kind (Ekind (Entity (Opnd)) in Object_Kind
and then Present (Current_Value (Entity (Opnd)))))) and then Present (Current_Value (Entity (Opnd))))))
or else Is_OK_Static_Expression (Opnd); or else Is_OK_Static_Expression (Opnd);
end Is_Known_Valid_Operand; end Is_Known_Valid_Operand;
...@@ -814,7 +810,8 @@ package body Sem_Eval is ...@@ -814,7 +810,8 @@ package body Sem_Eval is
-- Case where comparison involves two compile time known values -- Case where comparison involves two compile time known values
elsif Compile_Time_Known_Value (L) elsif Compile_Time_Known_Value (L)
and then Compile_Time_Known_Value (R) and then
Compile_Time_Known_Value (R)
then then
-- For the floating-point case, we have to be a little careful, since -- For the floating-point case, we have to be a little careful, since
-- at compile time we are dealing with universal exact values, but at -- at compile time we are dealing with universal exact values, but at
...@@ -828,7 +825,6 @@ package body Sem_Eval is ...@@ -828,7 +825,6 @@ package body Sem_Eval is
declare declare
Lo : constant Ureal := Expr_Value_R (L); Lo : constant Ureal := Expr_Value_R (L);
Hi : constant Ureal := Expr_Value_R (R); Hi : constant Ureal := Expr_Value_R (R);
begin begin
if Lo < Hi then if Lo < Hi then
return LE; return LE;
...@@ -880,15 +876,12 @@ package body Sem_Eval is ...@@ -880,15 +876,12 @@ package body Sem_Eval is
declare declare
Lo : constant Uint := Expr_Value (L); Lo : constant Uint := Expr_Value (L);
Hi : constant Uint := Expr_Value (R); Hi : constant Uint := Expr_Value (R);
begin begin
if Lo < Hi then if Lo < Hi then
Diff.all := Hi - Lo; Diff.all := Hi - Lo;
return LT; return LT;
elsif Lo = Hi then elsif Lo = Hi then
return EQ; return EQ;
else else
Diff.all := Lo - Hi; Diff.all := Lo - Hi;
return GT; return GT;
...@@ -902,7 +895,8 @@ package body Sem_Eval is ...@@ -902,7 +895,8 @@ package body Sem_Eval is
-- Remaining checks apply only for discrete types -- Remaining checks apply only for discrete types
if not Is_Discrete_Type (Ltyp) if not Is_Discrete_Type (Ltyp)
or else not Is_Discrete_Type (Rtyp) or else
not Is_Discrete_Type (Rtyp)
then then
return Unknown; return Unknown;
end if; end if;
...@@ -933,9 +927,9 @@ package body Sem_Eval is ...@@ -933,9 +927,9 @@ package body Sem_Eval is
return Unknown; return Unknown;
end if; end if;
-- Replace types by base types for the case of entities which are -- Replace types by base types for the case of entities which are not
-- not known to have valid representations. This takes care of -- known to have valid representations. This takes care of properly
-- properly dealing with invalid representations. -- dealing with invalid representations.
if not Assume_Valid and then not Assume_No_Invalid_Values then if not Assume_Valid and then not Assume_No_Invalid_Values then
if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then
...@@ -977,11 +971,9 @@ package body Sem_Eval is ...@@ -977,11 +971,9 @@ package body Sem_Eval is
if Is_Same_Value (Lnode, Rnode) then if Is_Same_Value (Lnode, Rnode) then
if Loffs = Roffs then if Loffs = Roffs then
return EQ; return EQ;
elsif Loffs < Roffs then elsif Loffs < Roffs then
Diff.all := Roffs - Loffs; Diff.all := Roffs - Loffs;
return LT; return LT;
else else
Diff.all := Loffs - Roffs; Diff.all := Loffs - Roffs;
return GT; return GT;
...@@ -1072,9 +1064,9 @@ package body Sem_Eval is ...@@ -1072,9 +1064,9 @@ package body Sem_Eval is
if not Rec then if not Rec then
-- See if we can get a decisive check against one operand and -- See if we can get a decisive check against one operand and a
-- a bound of the other operand (four possible tests here). -- bound of the other operand (four possible tests here). Note
-- Note that we avoid testing junk bounds of a generic type. -- that we avoid testing junk bounds of a generic type.
if not Is_Generic_Type (Rtyp) then if not Is_Generic_Type (Rtyp) then
case Compile_Time_Compare (L, Type_Low_Bound (Rtyp), case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
...@@ -1351,13 +1343,10 @@ package body Sem_Eval is ...@@ -1351,13 +1343,10 @@ package body Sem_Eval is
-- Other literals and NULL are known at compile time -- Other literals and NULL are known at compile time
elsif elsif
K = N_Character_Literal Nkind_In (K, N_Character_Literal,
or else N_Real_Literal,
K = N_Real_Literal N_String_Literal,
or else N_Null)
K = N_String_Literal
or else
K = N_Null
then then
return True; return True;
...@@ -1422,15 +1411,14 @@ package body Sem_Eval is ...@@ -1422,15 +1411,14 @@ package body Sem_Eval is
if Present (Expressions (Op)) then if Present (Expressions (Op)) then
declare declare
Expr : Node_Id; Expr : Node_Id;
begin begin
Expr := First (Expressions (Op)); Expr := First (Expressions (Op));
while Present (Expr) loop while Present (Expr) loop
if not Compile_Time_Known_Value_Or_Aggr (Expr) then if not Compile_Time_Known_Value_Or_Aggr (Expr) then
return False; return False;
else
Next (Expr);
end if; end if;
Next (Expr);
end loop; end loop;
end; end;
end if; end if;
...@@ -1502,7 +1490,6 @@ package body Sem_Eval is ...@@ -1502,7 +1490,6 @@ package body Sem_Eval is
procedure Eval_Allocator (N : Node_Id) is procedure Eval_Allocator (N : Node_Id) is
Expr : constant Node_Id := Expression (N); Expr : constant Node_Id := Expression (N);
begin begin
if Nkind (Expr) = N_Qualified_Expression then if Nkind (Expr) = N_Qualified_Expression then
Check_Non_Static_Context (Expression (Expr)); Check_Non_Static_Context (Expression (Expr));
...@@ -1553,7 +1540,6 @@ package body Sem_Eval is ...@@ -1553,7 +1540,6 @@ package body Sem_Eval is
begin begin
case Nkind (N) is case Nkind (N) is
when N_Op_Add => when N_Op_Add =>
Result := Left_Int + Right_Int; Result := Left_Int + Right_Int;
...@@ -1577,8 +1563,7 @@ package body Sem_Eval is ...@@ -1577,8 +1563,7 @@ package body Sem_Eval is
if Right_Int = 0 then if Right_Int = 0 then
Apply_Compile_Time_Constraint_Error Apply_Compile_Time_Constraint_Error
(N, "division by zero", (N, "division by zero", CE_Divide_By_Zero,
CE_Divide_By_Zero,
Warn => not Stat); Warn => not Stat);
return; return;
...@@ -1593,8 +1578,7 @@ package body Sem_Eval is ...@@ -1593,8 +1578,7 @@ package body Sem_Eval is
if Right_Int = 0 then if Right_Int = 0 then
Apply_Compile_Time_Constraint_Error Apply_Compile_Time_Constraint_Error
(N, "mod with zero divisor", (N, "mod with zero divisor", CE_Divide_By_Zero,
CE_Divide_By_Zero,
Warn => not Stat); Warn => not Stat);
return; return;
else else
...@@ -1608,8 +1592,7 @@ package body Sem_Eval is ...@@ -1608,8 +1592,7 @@ package body Sem_Eval is
if Right_Int = 0 then if Right_Int = 0 then
Apply_Compile_Time_Constraint_Error Apply_Compile_Time_Constraint_Error
(N, "rem with zero divisor", (N, "rem with zero divisor", CE_Divide_By_Zero,
CE_Divide_By_Zero,
Warn => not Stat); Warn => not Stat);
return; return;
...@@ -1776,7 +1759,6 @@ package body Sem_Eval is ...@@ -1776,7 +1759,6 @@ package body Sem_Eval is
if Is_Static_Expression (Expression (N)) then if Is_Static_Expression (Expression (N)) then
Val := Expr_Value (Expression (N)); Val := Expr_Value (Expression (N));
else else
Check_Non_Static_Context (Expression (N)); Check_Non_Static_Context (Expression (N));
Is_Static := False; Is_Static := False;
...@@ -2246,11 +2228,11 @@ package body Sem_Eval is ...@@ -2246,11 +2228,11 @@ package body Sem_Eval is
-- but those have bounds smaller that those of any integer base type, -- but those have bounds smaller that those of any integer base type,
-- so we can safely ignore these cases. -- so we can safely ignore these cases.
return K = N_Number_Declaration return Nkind_In (K, N_Number_Declaration,
or else K = N_Attribute_Reference N_Attribute_Reference,
or else K = N_Attribute_Definition_Clause N_Attribute_Definition_Clause,
or else K = N_Modular_Type_Definition N_Modular_Type_Definition,
or else K = N_Signed_Integer_Type_Definition; N_Signed_Integer_Type_Definition);
end In_Any_Integer_Context; end In_Any_Integer_Context;
-- Start of processing for Eval_Integer_Literal -- Start of processing for Eval_Integer_Literal
...@@ -2422,7 +2404,6 @@ package body Sem_Eval is ...@@ -2422,7 +2404,6 @@ package body Sem_Eval is
if not Is_String_Type (Def_Id) then if not Is_String_Type (Def_Id) then
Lo := Type_Low_Bound (Def_Id); Lo := Type_Low_Bound (Def_Id);
Hi := Type_High_Bound (Def_Id); Hi := Type_High_Bound (Def_Id);
else else
Lo := Empty; Lo := Empty;
Hi := Empty; Hi := Empty;
...@@ -2480,7 +2461,6 @@ package body Sem_Eval is ...@@ -2480,7 +2461,6 @@ package body Sem_Eval is
elsif Is_Real_Type (Etype (Right)) then elsif Is_Real_Type (Etype (Right)) then
declare declare
Leftval : constant Ureal := Expr_Value_R (Left); Leftval : constant Ureal := Expr_Value_R (Left);
begin begin
Result := Expr_Value_R (Lo) <= Leftval Result := Expr_Value_R (Lo) <= Leftval
and then Leftval <= Expr_Value_R (Hi); and then Leftval <= Expr_Value_R (Hi);
...@@ -2489,7 +2469,6 @@ package body Sem_Eval is ...@@ -2489,7 +2469,6 @@ package body Sem_Eval is
else else
declare declare
Leftval : constant Uint := Expr_Value (Left); Leftval : constant Uint := Expr_Value (Left);
begin begin
Result := Expr_Value (Lo) <= Leftval Result := Expr_Value (Lo) <= Leftval
and then Leftval <= Expr_Value (Hi); and then Leftval <= Expr_Value (Hi);
...@@ -2573,8 +2552,7 @@ package body Sem_Eval is ...@@ -2573,8 +2552,7 @@ package body Sem_Eval is
if Right_Int < 0 then if Right_Int < 0 then
Apply_Compile_Time_Constraint_Error Apply_Compile_Time_Constraint_Error
(N, "integer exponent negative", (N, "integer exponent negative", CE_Range_Check_Failed,
CE_Range_Check_Failed,
Warn => not Stat); Warn => not Stat);
return; return;
...@@ -2606,8 +2584,7 @@ package body Sem_Eval is ...@@ -2606,8 +2584,7 @@ package body Sem_Eval is
if Right_Int < 0 then if Right_Int < 0 then
Apply_Compile_Time_Constraint_Error Apply_Compile_Time_Constraint_Error
(N, "zero ** negative integer", (N, "zero ** negative integer", CE_Range_Check_Failed,
CE_Range_Check_Failed,
Warn => not Stat); Warn => not Stat);
return; return;
else else
...@@ -2657,9 +2634,7 @@ package body Sem_Eval is ...@@ -2657,9 +2634,7 @@ package body Sem_Eval is
if Is_Modular_Integer_Type (Typ) then if Is_Modular_Integer_Type (Typ) then
Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat); Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
else pragma Assert (Is_Boolean_Type (Typ));
else
pragma Assert (Is_Boolean_Type (Typ));
Fold_Uint (N, Test (not Is_True (Rint)), Stat); Fold_Uint (N, Test (not Is_True (Rint)), Stat);
end if; end if;
...@@ -2812,7 +2787,8 @@ package body Sem_Eval is ...@@ -2812,7 +2787,8 @@ package body Sem_Eval is
and then (Nkind (N) = N_Op_Eq or else Nkind (N) = N_Op_Ne) and then (Nkind (N) = N_Op_Eq or else Nkind (N) = N_Op_Ne)
then then
if Raises_Constraint_Error (Left) if Raises_Constraint_Error (Left)
or else Raises_Constraint_Error (Right) or else
Raises_Constraint_Error (Right)
then then
return; return;
end if; end if;
...@@ -2854,10 +2830,8 @@ package body Sem_Eval is ...@@ -2854,10 +2830,8 @@ package body Sem_Eval is
-- The simple case, both bounds are known at compile time -- The simple case, both bounds are known at compile time
if Is_Discrete_Type (T) if Is_Discrete_Type (T)
and then and then Compile_Time_Known_Value (Type_Low_Bound (T))
Compile_Time_Known_Value (Type_Low_Bound (T)) and then Compile_Time_Known_Value (Type_High_Bound (T))
and then
Compile_Time_Known_Value (Type_High_Bound (T))
then then
Len := UI_Max (Uint_0, Len := UI_Max (Uint_0,
Expr_Value (Type_High_Bound (T)) - Expr_Value (Type_High_Bound (T)) -
...@@ -2879,11 +2853,11 @@ package body Sem_Eval is ...@@ -2879,11 +2853,11 @@ package body Sem_Eval is
Ent : out Entity_Id; Ent : out Entity_Id;
Kind : out Character; Kind : out Character;
Cons : out Uint); Cons : out Uint);
-- Given an expression, see if is of the form above, -- Given an expression see if it is of the form given above,
-- X [+/- K]. If so Ent is set to the entity in X, -- X [+/- K]. If so Ent is set to the entity in X, Kind is
-- Kind is 'F','L','E' for 'First/'Last/simple entity, -- 'F','L','E' for 'First/'Last/simple entity, and Cons is
-- and Cons is the value of K. If the expression is -- the value of K. If the expression is not of the required
-- not of the required form, Ent is set to Empty. -- form, Ent is set to Empty.
-------------------- --------------------
-- Decompose_Expr -- -- Decompose_Expr --
...@@ -2940,10 +2914,8 @@ package body Sem_Eval is ...@@ -2940,10 +2914,8 @@ package body Sem_Eval is
if Nkind (Exp) = N_Attribute_Reference then if Nkind (Exp) = N_Attribute_Reference then
if Attribute_Name (Exp) = Name_First then if Attribute_Name (Exp) = Name_First then
Kind := 'F'; Kind := 'F';
elsif Attribute_Name (Exp) = Name_Last then elsif Attribute_Name (Exp) = Name_Last then
Kind := 'L'; Kind := 'L';
else else
Ent := Empty; Ent := Empty;
return; return;
...@@ -2955,8 +2927,7 @@ package body Sem_Eval is ...@@ -2955,8 +2927,7 @@ package body Sem_Eval is
Kind := 'E'; Kind := 'E';
end if; end if;
if Is_Entity_Name (Exp) if Is_Entity_Name (Exp) and then Present (Entity (Exp))
and then Present (Entity (Exp))
then then
Ent := Entity (Exp); Ent := Entity (Exp);
else else
...@@ -3013,7 +2984,8 @@ package body Sem_Eval is ...@@ -3013,7 +2984,8 @@ package body Sem_Eval is
declare declare
Is_Static_Expression : Boolean; Is_Static_Expression : Boolean;
Is_Foldable : Boolean;
Is_Foldable : Boolean;
pragma Unreferenced (Is_Foldable); pragma Unreferenced (Is_Foldable);
begin begin
...@@ -3287,6 +3259,7 @@ package body Sem_Eval is ...@@ -3287,6 +3259,7 @@ package body Sem_Eval is
procedure Eval_Slice (N : Node_Id) is procedure Eval_Slice (N : Node_Id) is
Drange : constant Node_Id := Discrete_Range (N); Drange : constant Node_Id := Discrete_Range (N);
begin begin
if Nkind (Drange) = N_Range then if Nkind (Drange) = N_Range then
Check_Non_Static_Context (Low_Bound (Drange)); Check_Non_Static_Context (Low_Bound (Drange));
...@@ -3301,6 +3274,7 @@ package body Sem_Eval is ...@@ -3301,6 +3274,7 @@ package body Sem_Eval is
declare declare
E : constant Entity_Id := Entity (Prefix (N)); E : constant Entity_Id := Entity (Prefix (N));
T : constant Entity_Id := Etype (E); T : constant Entity_Id := Etype (E);
begin begin
if Ekind (E) = E_Constant if Ekind (E) = E_Constant
and then Is_Array_Type (T) and then Is_Array_Type (T)
...@@ -3345,10 +3319,11 @@ package body Sem_Eval is ...@@ -3345,10 +3319,11 @@ package body Sem_Eval is
-- membership test can be evaluated statically. The caller transforms -- membership test can be evaluated statically. The caller transforms
-- a result of False into a static contraint error. -- a result of False into a static contraint error.
Test := Make_In (Loc, Test :=
Left_Opnd => New_Copy_Tree (N), Make_In (Loc,
Right_Opnd => Empty, Left_Opnd => New_Copy_Tree (N),
Alternatives => Pred); Right_Opnd => Empty,
Alternatives => Pred);
Analyze_And_Resolve (Test, Standard_Boolean); Analyze_And_Resolve (Test, Standard_Boolean);
return Nkind (Test) = N_Identifier return Nkind (Test) = N_Identifier
...@@ -3389,7 +3364,7 @@ package body Sem_Eval is ...@@ -3389,7 +3364,7 @@ package body Sem_Eval is
-- but may be possible in future). -- but may be possible in future).
elsif not Is_OK_Static_Expression elsif not Is_OK_Static_Expression
(Type_Low_Bound (Etype (First_Index (Typ)))) (Type_Low_Bound (Etype (First_Index (Typ))))
then then
Set_Is_Static_Expression (N, False); Set_Is_Static_Expression (N, False);
return; return;
...@@ -3534,7 +3509,6 @@ package body Sem_Eval is ...@@ -3534,7 +3509,6 @@ package body Sem_Eval is
if not Is_Static_Subtype (Target_Type) then if not Is_Static_Subtype (Target_Type) then
Check_Non_Static_Context (Operand); Check_Non_Static_Context (Operand);
return; return;
elsif Error_Posted (N) then elsif Error_Posted (N) then
return; return;
end if; end if;
...@@ -3561,7 +3535,6 @@ package body Sem_Eval is ...@@ -3561,7 +3535,6 @@ package body Sem_Eval is
if Is_String_Type (Target_Type) then if Is_String_Type (Target_Type) then
Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False); Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False);
return; return;
-- Fold conversion, case of integer target type -- Fold conversion, case of integer target type
...@@ -3698,10 +3671,8 @@ package body Sem_Eval is ...@@ -3698,10 +3671,8 @@ package body Sem_Eval is
begin begin
if Nkind (N) = N_Op_Plus then if Nkind (N) = N_Op_Plus then
Result := Rreal; Result := Rreal;
elsif Nkind (N) = N_Op_Minus then elsif Nkind (N) = N_Op_Minus then
Result := UR_Negate (Rreal); Result := UR_Negate (Rreal);
else else
pragma Assert (Nkind (N) = N_Op_Abs); pragma Assert (Nkind (N) = N_Op_Abs);
Result := abs Rreal; Result := abs Rreal;
...@@ -3848,7 +3819,6 @@ package body Sem_Eval is ...@@ -3848,7 +3819,6 @@ package body Sem_Eval is
-- obtain the desired value from Corresponding_Integer_Value. -- obtain the desired value from Corresponding_Integer_Value.
elsif Kind = N_Real_Literal then elsif Kind = N_Real_Literal then
pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N)))); pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
Val := Corresponding_Integer_Value (N); Val := Corresponding_Integer_Value (N);
...@@ -3891,7 +3861,6 @@ package body Sem_Eval is ...@@ -3891,7 +3861,6 @@ package body Sem_Eval is
function Expr_Value_E (N : Node_Id) return Entity_Id is function Expr_Value_E (N : Node_Id) return Entity_Id is
Ent : constant Entity_Id := Entity (N); Ent : constant Entity_Id := Entity (N);
begin begin
if Ekind (Ent) = E_Enumeration_Literal then if Ekind (Ent) = E_Enumeration_Literal then
return Ent; return Ent;
...@@ -4046,10 +4015,9 @@ package body Sem_Eval is ...@@ -4046,10 +4015,9 @@ package body Sem_Eval is
and then Nkind (Parent (E)) /= N_Subtype_Declaration and then Nkind (Parent (E)) /= N_Subtype_Declaration
and then Comes_From_Source (E) and then Comes_From_Source (E)
and then Is_Integer_Type (E) = Is_Int and then Is_Integer_Type (E) = Is_Int
and then and then (Nkind (N) in N_Unary_Op
(Nkind (N) in N_Unary_Op or else Is_Relational
or else Is_Relational or else Is_Fixed_Point_Type (E) = Is_Fix)
or else Is_Fixed_Point_Type (E) = Is_Fix)
then then
if No (Typ1) then if No (Typ1) then
Typ1 := E; Typ1 := E;
...@@ -4141,9 +4109,7 @@ package body Sem_Eval is ...@@ -4141,9 +4109,7 @@ package body Sem_Eval is
-- If we are folding a named number, retain the entity in the literal, -- If we are folding a named number, retain the entity in the literal,
-- for ASIS use. -- for ASIS use.
if Is_Entity_Name (N) if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Integer then
and then Ekind (Entity (N)) = E_Named_Integer
then
Ent := Entity (N); Ent := Entity (N);
else else
Ent := Empty; Ent := Empty;
...@@ -4160,7 +4126,6 @@ package body Sem_Eval is ...@@ -4160,7 +4126,6 @@ package body Sem_Eval is
if Is_Integer_Type (Typ) then if Is_Integer_Type (Typ) then
Rewrite (N, Make_Integer_Literal (Loc, Val)); Rewrite (N, Make_Integer_Literal (Loc, Val));
Set_Original_Entity (N, Ent); Set_Original_Entity (N, Ent);
-- Otherwise we have an enumeration type, and we substitute either -- Otherwise we have an enumeration type, and we substitute either
...@@ -4201,9 +4166,7 @@ package body Sem_Eval is ...@@ -4201,9 +4166,7 @@ package body Sem_Eval is
-- If we are folding a named number, retain the entity in the literal, -- If we are folding a named number, retain the entity in the literal,
-- for ASIS use. -- for ASIS use.
if Is_Entity_Name (N) if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Real then
and then Ekind (Entity (N)) = E_Named_Real
then
Ent := Entity (N); Ent := Entity (N);
else else
Ent := Empty; Ent := Empty;
...@@ -4258,12 +4221,8 @@ package body Sem_Eval is ...@@ -4258,12 +4221,8 @@ package body Sem_Eval is
function Get_String_Val (N : Node_Id) return Node_Id is function Get_String_Val (N : Node_Id) return Node_Id is
begin begin
if Nkind (N) = N_String_Literal then if Nkind_In (N, N_String_Literal, N_Character_Literal) then
return N;
elsif Nkind (N) = N_Character_Literal then
return N; return N;
else else
pragma Assert (Is_Entity_Name (N)); pragma Assert (Is_Entity_Name (N));
return Get_String_Val (Constant_Value (Entity (N))); return Get_String_Val (Constant_Value (Entity (N)));
...@@ -4402,8 +4361,8 @@ package body Sem_Eval is ...@@ -4402,8 +4361,8 @@ package body Sem_Eval is
Int_Real : Boolean := False) return Boolean Int_Real : Boolean := False) return Boolean
is is
begin begin
return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) return
= In_Range; Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) = In_Range;
end Is_In_Range; end Is_In_Range;
------------------- -------------------
...@@ -4422,9 +4381,7 @@ package body Sem_Eval is ...@@ -4422,9 +4381,7 @@ package body Sem_Eval is
if Is_Discrete_Type (Typ) then if Is_Discrete_Type (Typ) then
return Expr_Value (Lo) > Expr_Value (Hi); return Expr_Value (Lo) > Expr_Value (Hi);
else pragma Assert (Is_Real_Type (Typ));
else
pragma Assert (Is_Real_Type (Typ));
return Expr_Value_R (Lo) > Expr_Value_R (Hi); return Expr_Value_R (Lo) > Expr_Value_R (Hi);
end if; end if;
end Is_Null_Range; end Is_Null_Range;
...@@ -4435,8 +4392,7 @@ package body Sem_Eval is ...@@ -4435,8 +4392,7 @@ package body Sem_Eval is
function Is_OK_Static_Expression (N : Node_Id) return Boolean is function Is_OK_Static_Expression (N : Node_Id) return Boolean is
begin begin
return Is_Static_Expression (N) return Is_Static_Expression (N) and then not Raises_Constraint_Error (N);
and then not Raises_Constraint_Error (N);
end Is_OK_Static_Expression; end Is_OK_Static_Expression;
------------------------ ------------------------
...@@ -4528,8 +4484,8 @@ package body Sem_Eval is ...@@ -4528,8 +4484,8 @@ package body Sem_Eval is
Int_Real : Boolean := False) return Boolean Int_Real : Boolean := False) return Boolean
is is
begin begin
return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) =
= Out_Of_Range; Out_Of_Range;
end Is_Out_Of_Range; end Is_Out_Of_Range;
--------------------- ---------------------
...@@ -4544,7 +4500,8 @@ package body Sem_Eval is ...@@ -4544,7 +4500,8 @@ package body Sem_Eval is
function Is_Static_Range (N : Node_Id) return Boolean is function Is_Static_Range (N : Node_Id) return Boolean is
begin begin
return Is_Static_Expression (Low_Bound (N)) return Is_Static_Expression (Low_Bound (N))
and then Is_Static_Expression (High_Bound (N)); and then
Is_Static_Expression (High_Bound (N));
end Is_Static_Range; end Is_Static_Range;
----------------------- -----------------------
...@@ -4620,10 +4577,7 @@ package body Sem_Eval is ...@@ -4620,10 +4577,7 @@ package body Sem_Eval is
if Is_Discrete_Type (Typ) then if Is_Discrete_Type (Typ) then
return Expr_Value (Lo) <= Expr_Value (Hi); return Expr_Value (Lo) <= Expr_Value (Hi);
else pragma Assert (Is_Real_Type (Typ));
else
pragma Assert (Is_Real_Type (Typ));
return Expr_Value_R (Lo) <= Expr_Value_R (Hi); return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
end if; end if;
end Not_Null_Range; end Not_Null_Range;
...@@ -4639,6 +4593,8 @@ package body Sem_Eval is ...@@ -4639,6 +4593,8 @@ package body Sem_Eval is
if Bits < 500_000 then if Bits < 500_000 then
return True; return True;
-- Error if this maximum is exceeded
else else
Error_Msg_N ("static value too large, capacity exceeded", N); Error_Msg_N ("static value too large, capacity exceeded", N);
return False; return False;
...@@ -5104,8 +5060,7 @@ package body Sem_Eval is ...@@ -5104,8 +5060,7 @@ package body Sem_Eval is
-- checking on an inherited operation may compare the actual with the -- checking on an inherited operation may compare the actual with the
-- subtype that renames it in the instance. -- subtype that renames it in the instance.
elsif elsif Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
then then
return return
Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2); Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2);
...@@ -5257,7 +5212,8 @@ package body Sem_Eval is ...@@ -5257,7 +5212,8 @@ package body Sem_Eval is
CRT_Safe : Boolean := False) CRT_Safe : Boolean := False)
is is
Rstat : constant Boolean := Is_Static_Expression (Op1) Rstat : constant Boolean := Is_Static_Expression (Op1)
and then Is_Static_Expression (Op2); and then
Is_Static_Expression (Op2);
begin begin
Stat := False; Stat := False;
...@@ -5435,9 +5391,7 @@ package body Sem_Eval is ...@@ -5435,9 +5391,7 @@ package body Sem_Eval is
Val := Expr_Value (N); Val := Expr_Value (N);
if LB_Known and HB_Known then if LB_Known and HB_Known then
if Val >= Expr_Value (Lo) if Val >= Expr_Value (Lo) and then Val <= Expr_Value (Hi)
and then
Val <= Expr_Value (Hi)
then then
return In_Range; return In_Range;
else else
...@@ -5501,15 +5455,6 @@ package body Sem_Eval is ...@@ -5501,15 +5455,6 @@ package body Sem_Eval is
-- Start of processing for Why_Not_Static -- Start of processing for Why_Not_Static
begin begin
-- If in ACATS mode (debug flag 2), then suppress all these messages,
-- this avoids massive updates to the ACATS base line. But if the flag
-- d.z is set, then don't suppress the messages. This is a temporary
-- kludge to aid in doing the necessary updates to the ACATS base line.
if Debug_Flag_2 and then not Debug_Flag_Dot_Z then
return;
end if;
-- Ignore call on error or empty node -- Ignore call on error or empty node
if No (Expr) or else Nkind (Expr) = N_Error then if No (Expr) or else Nkind (Expr) = N_Error then
...@@ -5530,8 +5475,8 @@ package body Sem_Eval is ...@@ -5530,8 +5475,8 @@ package body Sem_Eval is
if Raises_Constraint_Error (Expr) then if Raises_Constraint_Error (Expr) then
Error_Msg_N Error_Msg_N
("!expression raises exception, cannot be static " & ("!expression raises exception, cannot be static (RM 4.9(34))",
"(RM 4.9(34))", N); N);
return; return;
end if; end if;
...@@ -5592,6 +5537,7 @@ package body Sem_Eval is ...@@ -5592,6 +5537,7 @@ package body Sem_Eval is
if Nkind (Original_Node (N)) = N_Aggregate then if Nkind (Original_Node (N)) = N_Aggregate then
Error_Msg_Sloc := Sloc (Original_Node (N)); Error_Msg_Sloc := Sloc (Original_Node (N));
return True; return True;
elsif Is_Entity_Name (N) elsif Is_Entity_Name (N)
and then Ekind (Entity (N)) = E_Constant and then Ekind (Entity (N)) = E_Constant
and then and then
...@@ -5601,6 +5547,7 @@ package body Sem_Eval is ...@@ -5601,6 +5547,7 @@ package body Sem_Eval is
Error_Msg_Sloc := Error_Msg_Sloc :=
Sloc (Original_Node (Constant_Value (Entity (N)))); Sloc (Original_Node (Constant_Value (Entity (N))));
return True; return True;
else else
return False; return False;
end if; end if;
...@@ -5635,7 +5582,6 @@ package body Sem_Eval is ...@@ -5635,7 +5582,6 @@ package body Sem_Eval is
if Nkind (N) in N_Op_Shift then if Nkind (N) in N_Op_Shift then
Error_Msg_N Error_Msg_N
("!shift functions are never static (RM 4.9(6,18))", N); ("!shift functions are never static (RM 4.9(6,18))", N);
else else
Why_Not_Static (Left_Opnd (N)); Why_Not_Static (Left_Opnd (N));
Why_Not_Static (Right_Opnd (N)); Why_Not_Static (Right_Opnd (N));
...@@ -5667,11 +5613,9 @@ package body Sem_Eval is ...@@ -5667,11 +5613,9 @@ package body Sem_Eval is
-- Flag array cases -- Flag array cases
elsif Is_Array_Type (E) then elsif Is_Array_Type (E) then
if Attribute_Name (N) /= Name_First if not Nam_In (Attribute_Name (N), Name_First,
and then Name_Last,
Attribute_Name (N) /= Name_Last Name_Length)
and then
Attribute_Name (N) /= Name_Length
then then
Error_Msg_N Error_Msg_N
("!static array attribute must be Length, First, or Last " ("!static array attribute must be Length, First, or Last "
...@@ -5690,10 +5634,7 @@ package body Sem_Eval is ...@@ -5690,10 +5634,7 @@ package body Sem_Eval is
-- Special case generic types, since again this is a common source -- Special case generic types, since again this is a common source
-- of confusion. -- of confusion.
elsif Is_Generic_Actual_Type (E) elsif Is_Generic_Actual_Type (E) or else Is_Generic_Type (E) then
or else
Is_Generic_Type (E)
then
Error_Msg_N Error_Msg_N
("!attribute of generic type is never static " ("!attribute of generic type is never static "
& "(RM 4.9(7,8))", N); & "(RM 4.9(7,8))", N);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment