diff options
Diffstat (limited to 'gcc/ada/sem_eval.adb')
| -rw-r--r-- | gcc/ada/sem_eval.adb | 429 |
1 files changed, 274 insertions, 155 deletions
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 8d47589..a3a2864 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2021, 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- -- @@ -23,39 +23,43 @@ -- -- ------------------------------------------------------------------------------ -with Aspects; use Aspects; -with Atree; use Atree; -with Checks; use Checks; -with Debug; use Debug; -with Einfo; use Einfo; -with Elists; use Elists; -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; -with Nlists; use Nlists; -with Opt; use Opt; -with Par_SCO; use Par_SCO; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Cat; use Sem_Cat; -with Sem_Ch3; use Sem_Ch3; -with Sem_Ch6; use Sem_Ch6; -with Sem_Ch8; use Sem_Ch8; -with Sem_Elab; use Sem_Elab; -with Sem_Res; use Sem_Res; -with Sem_Util; use Sem_Util; -with Sem_Type; use Sem_Type; -with Sem_Warn; use Sem_Warn; -with Sinfo; use Sinfo; -with Snames; use Snames; -with Stand; use Stand; -with Stringt; use Stringt; -with Tbuild; use Tbuild; +with Aspects; use Aspects; +with Atree; use Atree; +with Checks; use Checks; +with Debug; use Debug; +with Einfo; use Einfo; +with Einfo.Entities; use Einfo.Entities; +with Einfo.Utils; use Einfo.Utils; +with Elists; use Elists; +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; +with Nlists; use Nlists; +with Opt; use Opt; +with Par_SCO; use Par_SCO; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Elab; use Sem_Elab; +with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; +with Sem_Type; use Sem_Type; +with Sem_Warn; use Sem_Warn; +with Sinfo; use Sinfo; +with Sinfo.Nodes; use Sinfo.Nodes; +with Sinfo.Utils; use Sinfo.Utils; +with Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Tbuild; use Tbuild; package body Sem_Eval is @@ -136,12 +140,22 @@ package body Sem_Eval is Checking_For_Potentially_Static_Expression : Boolean := False; -- Global flag that is set True during Analyze_Static_Expression_Function -- in order to verify that the result expression of a static expression - -- function is a potentially static function (see RM202x 6.8(5.3)). + -- function is a potentially static function (see RM2022 6.8(5.3)). ----------------------- -- Local Subprograms -- ----------------------- + procedure Check_Non_Static_Context_For_Overflow + (N : Node_Id; + Stat : Boolean; + Result : Uint); + -- For a signed integer type, check non-static overflow in Result when + -- Stat is False. This applies also inside inlined code, where the static + -- property may be an effect of the inlining, which should not be allowed + -- to remove run-time checks (whether during compilation, or even more + -- crucially in the special inlining-for-proof in GNATprove mode). + function Choice_Matches (Expr : Node_Id; Choice : Node_Id) return Match_Result; @@ -649,6 +663,34 @@ package body Sem_Eval is end if; end Check_Non_Static_Context; + ------------------------------------------- + -- Check_Non_Static_Context_For_Overflow -- + ------------------------------------------- + + procedure Check_Non_Static_Context_For_Overflow + (N : Node_Id; + Stat : Boolean; + Result : Uint) + is + begin + if (not Stat or else In_Inlined_Body) + and then Is_Signed_Integer_Type (Etype (N)) + then + declare + BT : constant Entity_Id := Base_Type (Etype (N)); + Lo : constant Uint := Expr_Value (Type_Low_Bound (BT)); + Hi : constant Uint := Expr_Value (Type_High_Bound (BT)); + begin + if Result < Lo or else Result > Hi then + Apply_Compile_Time_Constraint_Error + (N, "value not in range of }??", + CE_Overflow_Check_Failed, + Ent => BT); + end if; + end; + end if; + end Check_Non_Static_Context_For_Overflow; + --------------------------------- -- Check_String_Literal_Length -- --------------------------------- @@ -2086,7 +2128,6 @@ package body Sem_Eval is Apply_Compile_Time_Constraint_Error (N, "division by zero", CE_Divide_By_Zero, Warn => not Stat or SPARK_Mode = On); - Set_Raises_Constraint_Error (N); return; -- Otherwise we can do the division @@ -2143,25 +2184,10 @@ package body Sem_Eval is if Is_Modular_Integer_Type (Ltype) then Result := Result mod Modulus (Ltype); - - -- For a signed integer type, check non-static overflow - - elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then - declare - BT : constant Entity_Id := Base_Type (Ltype); - Lo : constant Uint := Expr_Value (Type_Low_Bound (BT)); - Hi : constant Uint := Expr_Value (Type_High_Bound (BT)); - begin - if Result < Lo or else Result > Hi then - Apply_Compile_Time_Constraint_Error - (N, "value not in range of }??", - CE_Overflow_Check_Failed, - Ent => BT); - return; - end if; - end; end if; + Check_Non_Static_Context_For_Overflow (N, Stat, Result); + -- If we get here we can fold the result Fold_Uint (N, Result, Stat); @@ -2277,7 +2303,7 @@ package body Sem_Eval is then Eval_Intrinsic_Call (N, Entity (Name (N))); - -- Ada 202x (AI12-0075): If checking for potentially static expressions + -- Ada 2022 (AI12-0075): If checking for potentially static expressions -- is enabled and we have a call to a static function, substitute a -- static value for the call, to allow folding the expression. This -- supports checking the requirement of RM 6.8(5.3/5) in @@ -2568,7 +2594,7 @@ package body Sem_Eval is return; end if; - -- Ada 202x (AI12-0075): If checking for potentially static expressions + -- Ada 2022 (AI12-0075): If checking for potentially static expressions -- is enabled and we have a reference to a formal parameter of mode in, -- substitute a static value for the reference, to allow folding the -- expression. This supports checking the requirement of RM 6.8(5.3/5) @@ -2969,10 +2995,12 @@ package body Sem_Eval is -- static if both operands are potentially static (RM 4.9(7), 4.9(20)). procedure Eval_Logical_Op (N : Node_Id) is - Left : constant Node_Id := Left_Opnd (N); - Right : constant Node_Id := Right_Opnd (N); - Stat : Boolean; - Fold : Boolean; + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); + Left_Int : Uint := No_Uint; + Right_Int : Uint := No_Uint; + Stat : Boolean; + Fold : Boolean; begin -- If not foldable we are done @@ -2985,64 +3013,88 @@ package body Sem_Eval is -- Compile time evaluation of logical operation - declare - Left_Int : constant Uint := Expr_Value (Left); - Right_Int : constant Uint := Expr_Value (Right); + if Is_Modular_Integer_Type (Etype (N)) then + Left_Int := Expr_Value (Left); + Right_Int := Expr_Value (Right); - begin - if Is_Modular_Integer_Type (Etype (N)) then - declare - Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); - Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); + declare + Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); + Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); - begin - To_Bits (Left_Int, Left_Bits); - To_Bits (Right_Int, Right_Bits); + begin + To_Bits (Left_Int, Left_Bits); + To_Bits (Right_Int, Right_Bits); - -- Note: should really be able to use array ops instead of - -- these loops, but they break the build with a cryptic error - -- during the bind of gnat1 likely due to a wrong computation - -- of a date or checksum. + -- Note: should really be able to use array ops instead of + -- these loops, but they break the build with a cryptic error + -- during the bind of gnat1 likely due to a wrong computation + -- of a date or checksum. - if Nkind (N) = N_Op_And then - for J in Left_Bits'Range loop - Left_Bits (J) := Left_Bits (J) and Right_Bits (J); - end loop; + if Nkind (N) = N_Op_And then + for J in Left_Bits'Range loop + Left_Bits (J) := Left_Bits (J) and Right_Bits (J); + end loop; - elsif Nkind (N) = N_Op_Or then - for J in Left_Bits'Range loop - Left_Bits (J) := Left_Bits (J) or Right_Bits (J); - end loop; + elsif Nkind (N) = N_Op_Or then + for J in Left_Bits'Range loop + Left_Bits (J) := Left_Bits (J) or Right_Bits (J); + end loop; - else - pragma Assert (Nkind (N) = N_Op_Xor); + else + pragma Assert (Nkind (N) = N_Op_Xor); - for J in Left_Bits'Range loop - Left_Bits (J) := Left_Bits (J) xor Right_Bits (J); - end loop; - end if; + for J in Left_Bits'Range loop + Left_Bits (J) := Left_Bits (J) xor Right_Bits (J); + end loop; + end if; - Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat); - end; + Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat); + end; - else - pragma Assert (Is_Boolean_Type (Etype (N))); + else + pragma Assert (Is_Boolean_Type (Etype (N))); - if Nkind (N) = N_Op_And then + if Compile_Time_Known_Value (Left) + and then Compile_Time_Known_Value (Right) + then + Right_Int := Expr_Value (Right); + Left_Int := Expr_Value (Left); + end if; + + if Nkind (N) = N_Op_And then + + -- If Left or Right are not compile time known values it means + -- that the result is always False as per + -- Test_Expression_Is_Foldable. + -- Note that in this case, both Right_Int and Left_Int are set + -- to No_Uint, so need to test for both. + + if Right_Int = No_Uint then + Fold_Uint (N, Uint_0, Stat); + else Fold_Uint (N, Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat); + end if; + elsif Nkind (N) = N_Op_Or then - elsif Nkind (N) = N_Op_Or then - Fold_Uint (N, - Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat); + -- If Left or Right are not compile time known values it means + -- that the result is always True. as per + -- Test_Expression_Is_Foldable. + -- Note that in this case, both Right_Int and Left_Int are set + -- to No_Uint, so need to test for both. + if Right_Int = No_Uint then + Fold_Uint (N, Uint_1, Stat); else - pragma Assert (Nkind (N) = N_Op_Xor); Fold_Uint (N, - Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat); + Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat); end if; + else + pragma Assert (Nkind (N) = N_Op_Xor); + Fold_Uint (N, + Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat); end if; - end; + end if; end Eval_Logical_Op; ------------------------ @@ -3202,6 +3254,8 @@ package body Sem_Eval is Result := Result mod Modulus (Etype (N)); end if; + Check_Non_Static_Context_For_Overflow (N, Stat, Result); + Fold_Uint (N, Result, Stat); end if; end; @@ -3408,7 +3462,7 @@ package body Sem_Eval is -- Relational operations are static functions, so the result is static if -- both operands are static (RM 4.9(7), 4.9(20)), except that up to Ada -- 2012, for strings the result is never static, even if the operands are. - -- The string case was relaxed in Ada 2020, see AI12-0201. + -- The string case was relaxed in Ada 2022, see AI12-0201. -- However, for internally generated nodes, we allow string equality and -- inequality to be static. This is because we rewrite A in "ABC" as an @@ -3749,12 +3803,12 @@ package body Sem_Eval is and then Right_Len /= Uint_Minus_1 and then Left_Len /= Right_Len then - -- AI12-0201: comparison of string is static in Ada 202x + -- AI12-0201: comparison of string is static in Ada 2022 Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), - Static => Ada_Version >= Ada_2020 + Static => Ada_Version >= Ada_2022 and then Is_String_Type (Left_Typ)); Warn_On_Known_Condition (N); return; @@ -3774,16 +3828,16 @@ package body Sem_Eval is (N, Left, Right, Is_Static_Expression, Fold); -- Comparisons of scalars can give static results. - -- In addition starting with Ada 202x (AI12-0201), comparison of strings + -- In addition starting with Ada 2022 (AI12-0201), comparison of strings -- can also give static results, and as noted above, we also allow for -- earlier Ada versions internally generated equality and inequality for -- strings. - -- ??? The Comes_From_Source test below isn't correct and will accept - -- some cases that are illegal in Ada 2012. and before. Now that Ada - -- 202x has relaxed the rules, this doesn't really matter. + -- The Comes_From_Source test below isn't correct and will accept + -- some cases that are illegal in Ada 2012 and before. Now that Ada + -- 2022 has relaxed the rules, this doesn't really matter. if Is_String_Type (Left_Typ) then - if Ada_Version < Ada_2020 + if Ada_Version < Ada_2022 and then (Comes_From_Source (N) or else Nkind (N) not in N_Op_Eq | N_Op_Ne) then @@ -3830,6 +3884,11 @@ package body Sem_Eval is ----------------------------- procedure Eval_Selected_Component (N : Node_Id) is + Node : Node_Id; + Comp : Node_Id; + C : Node_Id; + Nam : Name_Id; + begin -- If an attribute reference or a LHS, nothing to do. -- Also do not fold if N is an [in] out subprogram parameter. @@ -3839,7 +3898,34 @@ package body Sem_Eval is and then Is_LHS (N) = No and then not Is_Actual_Out_Or_In_Out_Parameter (N) then - Fold (N); + -- Simplify a selected_component on an aggregate by extracting + -- the field directly. + + Node := Unqualify (Prefix (N)); + + if Nkind (Node) = N_Aggregate + and then Compile_Time_Known_Aggregate (Node) + then + Comp := First (Component_Associations (Node)); + Nam := Chars (Selector_Name (N)); + + while Present (Comp) loop + C := First (Choices (Comp)); + + while Present (C) loop + if Chars (C) = Nam then + Rewrite (N, Relocate_Node (Expression (Comp))); + return; + end if; + + Next (C); + end loop; + + Next (Comp); + end loop; + else + Fold (N); + end if; end if; end Eval_Selected_Component; @@ -4047,7 +4133,7 @@ package body Sem_Eval is end if; -- If original node was a type conversion, then result if non-static - -- up to Ada 2012. AI12-0201 changes that with Ada 202x. + -- up to Ada 2012. AI12-0201 changes that with Ada 2022. if Nkind (Original_Node (N)) = N_Type_Conversion and then Ada_Version <= Ada_2012 @@ -4079,7 +4165,7 @@ package body Sem_Eval is Len := String_Length (Strval (N)); - if UI_From_Int (Len) > String_Type_Len (Bas) then + if Len > String_Type_Len (Bas) then -- Issue message. Note that this message is a warning if the -- string literal is not marked as static (happens in some cases @@ -4209,13 +4295,13 @@ package body Sem_Eval is -- Conversion_OK is set, in which case it counts as integer. -- Fold conversion, case of string type. The result is static starting - -- with Ada 202x (AI12-0201). + -- with Ada 2022 (AI12-0201). if Is_String_Type (Target_Type) then Fold_Str (N, Strval (Get_String_Val (Operand)), - Static => Ada_Version >= Ada_2020); + Static => Ada_Version >= Ada_2022); return; -- Fold conversion, case of integer target type @@ -4306,10 +4392,7 @@ package body Sem_Eval is return; end if; - if Etype (Right) = Universal_Integer - or else - Etype (Right) = Universal_Real - then + if Is_Universal_Numeric_Type (Etype (Right)) then Otype := Find_Universal_Operator_Type (N); end if; @@ -4343,6 +4426,8 @@ package body Sem_Eval is Result := abs Rint; end if; + Check_Non_Static_Context_For_Overflow (N, Stat, Result); + Fold_Uint (N, Result, Stat); end; @@ -4928,7 +5013,7 @@ package body Sem_Eval is end if; end Check_Elab_Call; - Modulus : Uint; + Modulus, Val : Uint; begin if Compile_Time_Known_Value (Left) @@ -4939,23 +5024,25 @@ package body Sem_Eval is if Op = N_Op_Shift_Left then Check_Elab_Call; - declare - Modulus : Uint; - begin - if Is_Modular_Integer_Type (Typ) then - Modulus := Einfo.Modulus (Typ); - else - Modulus := Uint_2 ** RM_Size (Typ); - end if; + if Is_Modular_Integer_Type (Typ) then + Modulus := Einfo.Entities.Modulus (Typ); + else + Modulus := Uint_2 ** RM_Size (Typ); + end if; - -- Fold Shift_Left (X, Y) by computing (X * 2**Y) rem modulus + -- Fold Shift_Left (X, Y) by computing + -- (X * 2**Y) rem modulus [- Modulus] - Fold_Uint - (N, - (Expr_Value (Left) * (Uint_2 ** Expr_Value (Right))) - rem Modulus, - Static => Static); - end; + Val := (Expr_Value (Left) * (Uint_2 ** Expr_Value (Right))) + rem Modulus; + + if Is_Modular_Integer_Type (Typ) + or else Val < Modulus / Uint_2 + then + Fold_Uint (N, Val, Static => Static); + else + Fold_Uint (N, Val - Modulus, Static => Static); + end if; elsif Op = N_Op_Shift_Right then Check_Elab_Call; @@ -4966,7 +5053,7 @@ package body Sem_Eval is Fold_Uint (N, Expr_Value (Left), Static => Static); else if Is_Modular_Integer_Type (Typ) then - Modulus := Einfo.Modulus (Typ); + Modulus := Einfo.Entities.Modulus (Typ); else Modulus := Uint_2 ** RM_Size (Typ); end if; @@ -4987,10 +5074,10 @@ package body Sem_Eval is Check_Elab_Call; declare - Two_Y : constant Uint := Uint_2 ** Expr_Value (Right); + Two_Y : constant Uint := Uint_2 ** Expr_Value (Right); begin if Is_Modular_Integer_Type (Typ) then - Modulus := Einfo.Modulus (Typ); + Modulus := Einfo.Entities.Modulus (Typ); else Modulus := Uint_2 ** RM_Size (Typ); end if; @@ -5494,23 +5581,16 @@ package body Sem_Eval is return False; end if; - Anc_Subt := Ancestor_Subtype (Typ); - - if Anc_Subt = Empty then - Anc_Subt := Base_T; - end if; - - if Is_Generic_Type (Root_Type (Base_T)) - or else Is_Generic_Actual_Type (Base_T) - then - return False; + -- Then, check if the subtype is strictly static. This takes care of + -- checking for generics and predicates. - elsif Has_Dynamic_Predicate_Aspect (Typ) then + if not Is_Static_Subtype (Typ) then return False; + end if; -- String types - elsif Is_String_Type (Typ) then + if Is_String_Type (Typ) then return Ekind (Typ) = E_String_Literal_Subtype or else @@ -5524,6 +5604,12 @@ package body Sem_Eval is return True; else + Anc_Subt := Ancestor_Subtype (Typ); + + if No (Anc_Subt) then + Anc_Subt := Base_T; + end if; + -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use -- Get_Type_{Low,High}_Bound. @@ -6045,7 +6131,9 @@ package body Sem_Eval is -- No message if we are dealing with System.Priority values in -- CodePeer mode where the target runtime may have more priorities. - elsif not CodePeer_Mode or else Etype (N) /= RTE (RE_Priority) then + elsif not CodePeer_Mode + or else not Is_RTE (Etype (N), RE_Priority) + then -- Determine if the out-of-range violation constitutes a warning -- or an error based on context, according to RM 4.9 (34/3). @@ -6135,7 +6223,7 @@ package body Sem_Eval is end; else - -- TBD: Implement Interval_Lists for real types + -- ??? Need to implement Interval_Lists for real types return False; end if; @@ -6393,11 +6481,10 @@ package body Sem_Eval is procedure Set_Checking_Potentially_Static_Expression (Value : Boolean) is begin - -- Verify that we're not currently checking for a potentially static - -- expression unless we're disabling such checking. + -- Verify that we only start/stop checking for a potentially static + -- expression and do not start or stop it twice in a row. - pragma Assert - (not Checking_For_Potentially_Static_Expression or else not Value); + pragma Assert (Checking_For_Potentially_Static_Expression /= Value); Checking_For_Potentially_Static_Expression := Value; end Set_Checking_Potentially_Static_Expression; @@ -6535,7 +6622,7 @@ package body Sem_Eval is -- match if they are set (unless checking an actual for a formal derived -- type). The use of 'Object_Size can cause this to be false even if the -- types would otherwise match in the Ada 95 RM sense, but this deviation - -- is adopted by AI12-059 which introduces Object_Size in Ada 2020. + -- is adopted by AI12-059 which introduces Object_Size in Ada 2022. function Subtypes_Statically_Match (T1 : Entity_Id; @@ -7131,6 +7218,38 @@ package body Sem_Eval is and then Compile_Time_Known_Value (Op2); end if; + if not Fold + and then not Is_Modular_Integer_Type (Etype (N)) + then + case Nkind (N) is + when N_Op_And => + + -- (False and XXX) = (XXX and False) = False + + Fold := + (Compile_Time_Known_Value (Op1) + and then Is_False (Expr_Value (Op1)) + and then Side_Effect_Free (Op2)) + or else (Compile_Time_Known_Value (Op2) + and then Is_False (Expr_Value (Op2)) + and then Side_Effect_Free (Op1)); + + when N_Op_Or => + + -- (True and XXX) = (XXX and True) = True + + Fold := + (Compile_Time_Known_Value (Op1) + and then Is_True (Expr_Value (Op1)) + and then Side_Effect_Free (Op2)) + or else (Compile_Time_Known_Value (Op2) + and then Is_True (Expr_Value (Op2)) + and then Side_Effect_Free (Op1)); + + when others => null; + end case; + end if; + return; -- Else result is static and foldable. Both operands are static, and @@ -7182,7 +7301,7 @@ package body Sem_Eval is -- Universal types have no range limits, so always in range - elsif Typ = Universal_Integer or else Typ = Universal_Real then + elsif Is_Universal_Numeric_Type (Typ) then return In_Range; -- Never known if not scalar type. Don't know if this can actually |