CbC/CbC_gcc: gcc/ada/sem_eval.adb comparison

comparison gcc/ada/sem_eval.adb @ 131:84e7813d76e9

gcc-8.2

author	mir3636
date	Thu, 25 Oct 2018 07:37:49 +0900
parents	04ced10e8804
children	1830386684a0

comparison

equal deleted inserted replaced

-:04ced10e8804
+:84e7813d76e9
 --                                                                          --
 --                             S E M _ E V A L                              --
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2017, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2018, 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- --
 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
 type Bits is array (Nat range <>) of Boolean;
 --  Used to convert unsigned (modular) values for folding logical ops
 --  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
 --  Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
 --  since it is possible for the status to change (in particular it is
 --  possible for a node to get replaced by a constraint error node).
 Choices : List_Id) return Match_Result;
 --  This function applies Choice_Matches to each element of Choices. If the
 --  result is No_Match, then it continues and checks the next element. If
 --  the result is Match or Non_Static, this result is immediately given
 --  as the result without checking the rest of the list. Expr can be of
---  discrete, real, or string type and must be a compile time known value
+--  discrete, real, or string type and must be a compile-time-known value
 --  (it is an error to make the call if these conditions are not met).
 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:
 --  Bits is unreasonably large, then an error is posted on node N, and
 --  False is returned (and the caller skips the proposed calculation).
 procedure Out_Of_Range (N : Node_Id);
 --  This procedure is called if it is determined that node N, which appears
---  in a non-static context, is a compile time known value which is outside
+--  in a non-static context, is a compile-time-known value which is outside
 --  its range, i.e. the range of Etype. This is used in contexts where
 --  this is an illegality if N is static, and should generate a warning
 --  otherwise.
 function Real_Or_String_Static_Predicate_Matches
 --  case in which non-static universal integer values can occur, and
 --  furthermore, Check_Non_Static_Context is currently (incorrectly???)
 --  called in contexts like the expression of a number declaration where
 --  we certainly want to allow out of range values.
+--  We inhibit the warning when expansion is disabled, because the
+--  preanalysis of a range of a 64-bit modular type may appear to
+--  violate the constraint on non-static Universal_Integer. If there
+--  is a true overflow it will be diagnosed during full analysis.
 if Etype (N) = Universal_Integer
 and then Nkind (N) = N_Integer_Literal
 and then Nkind (Parent (N)) in N_Subexpr
+and then Expander_Active
 and then
 (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
 or else
 Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
 then
 elsif T /= Base_Type (T) and then Nkind (Parent (N)) /= N_Range then
 if Is_In_Range (N, T, Assume_Valid => True) then
 null;
 elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then
-Apply_Compile_Time_Constraint_Error
-(N, "value not in range of}<<", CE_Range_Check_Failed);
+--  Ignore out of range values for System.Priority in CodePeer
+--  mode since the actual target compiler may provide a wider
+--  range.
+if CodePeer_Mode and then T = RTE (RE_Priority) then
+Set_Do_Range_Check (N, False);
+else
+Apply_Compile_Time_Constraint_Error
+(N, "value not in range of}<<", CE_Range_Check_Failed);
+end if;
 elsif Checks_On then
 Enable_Range_Check (N);
 else
 --  Even if the context does not assume that values are valid, some
 --  simple cases can be recognized.
 function Is_Same_Value (L, R : Node_Id) return Boolean;
 --  Returns True iff L and R represent expressions that definitely have
---  identical (but not necessarily compile time known) values Indeed the
+--  identical (but not necessarily compile-time-known) values Indeed the
 --  caller is expected to have already dealt with the cases of compile
 --  time known values, so these are not tested here.
 -----------------------
 -- Compare_Decompose --
 and then not Is_Volatile_Reference (L)
 and then not Is_Volatile_Reference (R)
 then
 return True;
---  Or if they are compile time known and identical
+--  Or if they are compile-time-known and identical
 elsif Compile_Time_Known_Value (Lf)
 and then
 Compile_Time_Known_Value (Rf)
 and then Expr_Value (Lf) = Expr_Value (Rf)
 else
 return Unknown;
 end if;
---  Case where comparison involves two compile time known values
+--  Case where comparison involves two compile-time-known values
 elsif Compile_Time_Known_Value (L)
 and then
 Compile_Time_Known_Value (R)
 then
 end case;
 end if;
 end if;
 --  Next attempt is to see if we have an entity compared with a
---  compile time known value, where there is a current value
+--  compile-time-known value, where there is a current value
 --  conditional for the entity which can tell us the result.
 declare
 Var : Node_Id;
 --  Entity variable (left operand)
 if Is_Generic_Type (Typ) then
 return False;
 end if;
---  Otherwise check bounds for compile time known
+--  Otherwise check bounds for compile-time-known
 if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
 return False;
 elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then
 return False;
 then
 return False;
 end if;
 --  If we have an entity name, then see if it is the name of a constant
---  and if so, test the corresponding constant value, or the name of
+--  and if so, test the corresponding constant value, or the name of an
---  an enumeration literal, which is always a constant.
+--  enumeration literal, which is always a constant.
 if Present (Etype (Op)) and then Is_Entity_Name (Op) then
 declare
-E : constant Entity_Id := Entity (Op);
+Ent : constant Entity_Id := Entity (Op);
-V : Node_Id;
+Val : Node_Id;
 begin
---  Never known at compile time if it is a packed array value.
+--  Never known at compile time if it is a packed array value. We
---  We might want to try to evaluate these at compile time one
+--  might want to try to evaluate these at compile time one day,
---  day, but we do not make that attempt now.
+--  but we do not make that attempt now.
 if Is_Packed_Array_Impl_Type (Etype (Op)) then
 return False;
-end if;
+elsif Ekind (Ent) = E_Enumeration_Literal then
-if Ekind (E) = E_Enumeration_Literal then
 return True;
-elsif Ekind (E) = E_Constant then
+elsif Ekind (Ent) = E_Constant then
-V := Constant_Value (E);
+Val := Constant_Value (Ent);
-return Present (V) and then Compile_Time_Known_Value (V);
+if Present (Val) then
+--  Guard against an illegal deferred constant whose full
+--  view is initialized with a reference to itself. Treat
+--  this case as a value not known at compile time.
+if Is_Entity_Name (Val) and then Entity (Val) = Ent then
+return False;
+else
+return Compile_Time_Known_Value (Val);
+end if;
+--  Otherwise, the constant does not have a compile-time-known
+--  value.
+else
+return False;
+end if;
 end if;
 end;
---  We have a value, see if it is compile time known
+--  We have a value, see if it is compile-time-known
 else
 --  Integer literals are worth storing in the cache
 if K = N_Integer_Literal then
 return Present (V)
 and then Compile_Time_Known_Value_Or_Aggr (V);
 end if;
 end;
---  We have a value, see if it is compile time known
+--  We have a value, see if it is compile-time-known
 else
 if Compile_Time_Known_Value (Op) then
 return True;
 declare
 Left_Str   : constant Node_Id := Get_String_Val (Left);
 Left_Len   : Nat;
 Right_Str  : constant Node_Id := Get_String_Val (Right);
-Folded_Val : String_Id;
+Folded_Val : String_Id        := No_String;
 begin
 --  Establish new string literal, and store left operand. We make
 --  sure to use the special Start_String that takes an operand if
 --  the left operand is a string literal. Since this is optimized
 Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
 if List_Length (Expressions (Arr)) >= Lin then
 Elm := Pick (Expressions (Arr), Lin);
---  If the resulting expression is compile time known,
+--  If the resulting expression is compile-time-known,
 --  then we can rewrite the indexed component with this
 --  value, being sure to mark the result as non-static.
 --  We also reset the Sloc, in case this generates an
 --  error later on (e.g. 136'Access).
 --  the possibility of turning off the Is_Static_Expression flag after
 --  analysis, but before resolution, when integer literals are generated in
 --  the expander that do not correspond to static expressions.
 procedure Eval_Integer_Literal (N : Node_Id) is
-T : constant Entity_Id := Etype (N);
+function In_Any_Integer_Context (Context : Node_Id) return Boolean;
-function In_Any_Integer_Context return Boolean;
 --  If the literal is resolved with a specific type in a context where
 --  the expected type is Any_Integer, there are no range checks on the
 --  literal. By the time the literal is evaluated, it carries the type
 --  imposed by the enclosing expression, and we must recover the context
 --  to determine that Any_Integer is meant.
 ----------------------------
 -- In_Any_Integer_Context --
 ----------------------------
-function In_Any_Integer_Context return Boolean is
+function In_Any_Integer_Context (Context : Node_Id) return Boolean is
-Par : constant Node_Id   := Parent (N);
-K   : constant Node_Kind := Nkind (Par);
 begin
 --  Any_Integer also appears in digits specifications for real types,
 --  but those have bounds smaller that those of any integer base type,
 --  so we can safely ignore these cases.
-return Nkind_In (K, N_Number_Declaration,
+return
-N_Attribute_Reference,
+Nkind_In (Context, N_Attribute_Definition_Clause,
-N_Attribute_Definition_Clause,
+N_Attribute_Reference,
 N_Modular_Type_Definition,
-N_Signed_Integer_Type_Definition);
+N_Number_Declaration,
+N_Signed_Integer_Type_Definition);
 end In_Any_Integer_Context;
+--  Local variables
+Par : constant Node_Id   := Parent (N);
+Typ : constant Entity_Id := Etype (N);
 --  Start of processing for Eval_Integer_Literal
 begin
 --  If the literal appears in a non-expression context, then it is
 --  certainly appearing in a non-static context, so check it. This is
 --  actually a redundant check, since Check_Non_Static_Context would
 --  check it, but it seems worthwhile to optimize out the call.
---  An exception is made for a literal in an if or case expression
+--  Additionally, when the literal appears within an if or case
+--  expression it must be checked as well. However, due to the literal
-if (Nkind_In (Parent (N), N_If_Expression, N_Case_Expression_Alternative)
+--  appearing within a conditional statement, expansion greatly changes
+--  the nature of its context and performing some of the checks within
+--  Check_Non_Static_Context on an expanded literal may lead to spurious
+--  and misleading warnings.
+if (Nkind_In (Par, N_Case_Expression_Alternative, N_If_Expression)
 or else Nkind (Parent (N)) not in N_Subexpr)
-and then not In_Any_Integer_Context
+and then (not Nkind_In (Par, N_Case_Expression_Alternative,
+N_If_Expression)
+or else Comes_From_Source (N))
+and then not In_Any_Integer_Context (Par)
 then
 Check_Non_Static_Context (N);
 end if;
 --  Modular integer literals must be in their base range
-if Is_Modular_Integer_Type (T)
+if Is_Modular_Integer_Type (Typ)
-and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
+and then Is_Out_Of_Range (N, Base_Type (Typ), Assume_Valid => True)
 then
 Out_Of_Range (N);
 end if;
 end Eval_Integer_Literal;
 --  First easy case string literal
 if Nkind (Expr) = N_String_Literal then
 return UI_From_Int (String_Length (Strval (Expr)));
+--  With frontend inlining as performed in GNATprove mode, a variable
+--  may be inserted that has a string literal subtype. Deal with this
+--  specially as for the previous case.
+elsif Ekind (Etype (Expr)) = E_String_Literal_Subtype then
+return String_Literal_Length (Etype (Expr));
 --  Second easy case, not constrained subtype, so no length
 elsif not Is_Constrained (Etype (Expr)) then
 return Uint_Minus_1;
 end if;
 CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
 Ent    : Entity_Id;
 Val    : Uint;
 begin
---  If already in cache, then we know it's compile time known and we can
+--  If already in cache, then we know it's compile-time-known and we can
 --  return the value that was previously stored in the cache since
---  compile time known values cannot change.
+--  compile-time-known values cannot change.
 if CV_Ent.N = N then
 return CV_Ent.V;
 end if;
 then
 return True;
 end if;
 --  If bounds not comparable at compile time, then the bounds of T2
---  must be compile time known or we cannot answer the query.
+--  must be compile-time-known or we cannot answer the query.
 if not Compile_Time_Known_Value (L2)
 or else not Compile_Time_Known_Value (H2)
 then
 return False;
 -------------------
 -- Is_Null_Range --
 -------------------
 function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
-Typ : constant Entity_Id := Etype (Lo);
+begin
+if Compile_Time_Known_Value (Lo)
-begin
+and then Compile_Time_Known_Value (Hi)
-if not Compile_Time_Known_Value (Lo)
-or else not Compile_Time_Known_Value (Hi)
 then
+declare
+Typ : Entity_Id := Etype (Lo);
+begin
+--  When called from the frontend, as part of the analysis of
+--  potentially static expressions, Typ will be the full view of a
+--  type with all the info needed to answer this query. When called
+--  from the backend, for example to know whether a range of a loop
+--  is null, Typ might be a private type and we need to explicitly
+--  switch to its corresponding full view to access the same info.
+if Is_Incomplete_Or_Private_Type (Typ)
+and then Present (Full_View (Typ))
+then
+Typ := Full_View (Typ);
+end if;
+if Is_Discrete_Type (Typ) then
+return Expr_Value (Lo) > Expr_Value (Hi);
+else pragma Assert (Is_Real_Type (Typ));
+return Expr_Value_R (Lo) > Expr_Value_R (Hi);
+end if;
+end;
+else
 return False;
-end if;
-if Is_Discrete_Type (Typ) then
-return Expr_Value (Lo) > Expr_Value (Hi);
-else pragma Assert (Is_Real_Type (Typ));
-return Expr_Value_R (Lo) > Expr_Value_R (Hi);
 end if;
 end Is_Null_Range;
 -------------------------
 -- Is_OK_Static_Choice --
 --------------------
 -- Not_Null_Range --
 --------------------
 function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
-Typ : constant Entity_Id := Etype (Lo);
+begin
+if Compile_Time_Known_Value (Lo)
-begin
+and then Compile_Time_Known_Value (Hi)
-if not Compile_Time_Known_Value (Lo)
-or else not Compile_Time_Known_Value (Hi)
 then
+declare
+Typ : Entity_Id := Etype (Lo);
+begin
+--  When called from the frontend, as part of the analysis of
+--  potentially static expressions, Typ will be the full view of a
+--  type with all the info needed to answer this query. When called
+--  from the backend, for example to know whether a range of a loop
+--  is null, Typ might be a private type and we need to explicitly
+--  switch to its corresponding full view to access the same info.
+if Is_Incomplete_Or_Private_Type (Typ)
+and then Present (Full_View (Typ))
+then
+Typ := Full_View (Typ);
+end if;
+if Is_Discrete_Type (Typ) then
+return Expr_Value (Lo) <= Expr_Value (Hi);
+else pragma Assert (Is_Real_Type (Typ));
+return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
+end if;
+end;
+else
 return False;
 end if;
-if Is_Discrete_Type (Typ) then
-return Expr_Value (Lo) <= Expr_Value (Hi);
-else pragma Assert (Is_Real_Type (Typ));
-return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
-end if;
 end Not_Null_Range;
 -------------
 -- OK_Bits --
 -------------
 Error_Msg_N
 ("length of packed array must not exceed Integer''Last",
 First_Rep_Item (Parent (N)));
 Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
---  All cases except the special array case
+--  All cases except the special array case.
+--  No message if we are dealing with System.Priority values in
-else
+--  CodePeer mode where the target runtime may have more priorities.
+elsif not CodePeer_Mode or else Etype (N) /= RTE (RE_Priority) then
 Apply_Compile_Time_Constraint_Error
 (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
 -------------------------
 -- Rewrite_In_Raise_CE --
 -------------------------
 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
+Stat : constant Boolean   := Is_Static_Expression (N);
 Typ  : constant Entity_Id := Etype (N);
-Stat : constant Boolean   := Is_Static_Expression (N);
 begin
 --  If we want to raise CE in the condition of a N_Raise_CE node, we
 --  can just clear the condition if the reason is appropriate. We do
 --  not do this operation if the parent has a reason other than range
 Set_Condition (Parent (N), Empty);
 --  Else build an explicit N_Raise_CE
 else
-Rewrite (N,
+if Nkind (Exp) = N_Raise_Constraint_Error then
-Make_Raise_Constraint_Error (Sloc (Exp),
+Rewrite (N,
-Reason => CE_Range_Check_Failed));
+Make_Raise_Constraint_Error (Sloc (Exp),
+Reason => Reason (Exp)));
+else
+Rewrite (N,
+Make_Raise_Constraint_Error (Sloc (Exp),
+Reason => CE_Range_Check_Failed));
+end if;
 Set_Raises_Constraint_Error (N);
 Set_Etype (N, Typ);
 end if;
 --  Set proper flags in result
 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
+--  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
 --  If an error was posted on expression, then return Unknown, we do not
 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
+--  (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;

Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/sem_eval.adb @ 131:84e7813d76e9