@@ -13460,16 +13460,26 @@ package body Exp_Util is
-- A binary operator is side effect free if and both operands are
-- side effect free. For this purpose binary operators include
- -- membership tests and short circuit forms.
+ -- short circuit forms.
when N_Binary_Op
- | N_Membership_Test
| N_Short_Circuit
=>
return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
and then
Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
+ -- Membership tests may have either Right_Opnd or Alternatives set
+
+ when N_Membership_Test =>
+ return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
+ and then
+ (if Present (Right_Opnd (N))
+ then Side_Effect_Free
+ (Right_Opnd (N), Name_Req, Variable_Ref)
+ else Side_Effect_Free
+ (Alternatives (N), Name_Req, Variable_Ref));
+
-- An explicit dereference is side effect free only if it is
-- a side effect free prefixed reference.
@@ -2995,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
@@ -3011,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;
------------------------
@@ -7193,6 +7219,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