@@ -2319,6 +2319,13 @@ package body Exp_Ch6 is
-- Adds invariant checks for every intermediate type between the range
-- of a view converted argument to its ancestor (from parent to child).
+ function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean;
+ -- Try to constant-fold a predicate check, which often enough is a
+ -- simple arithmetic expression that can be computed statically if
+ -- its argument is static. This cleans up the output of CCG, even
+ -- though useless predicate checks will be generally removed by
+ -- back-end optimizations.
+
function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
-- Within an instance, a type derived from an untagged formal derived
-- type inherits from the original parent, not from the actual. The
@@ -2467,6 +2474,89 @@ package body Exp_Ch6 is
end if;
end Add_View_Conversion_Invariants;
+ -----------------------------
+ -- Can_Fold_Predicate_Call --
+ -----------------------------
+
+ function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean is
+ Actual : constant Node_Id :=
+ First (Parameter_Associations (Call_Node));
+ Subt : constant Entity_Id := Etype (First_Entity (P));
+ Pred : Node_Id;
+
+ function May_Fold (N : Node_Id) return Traverse_Result;
+ -- The predicate expression is foldable if it only contains operators
+ -- and literals. During this check, we also replace occurrences of
+ -- the formal of the constructed predicate function with the static
+ -- value of the actual. This is done on a copy of the analyzed
+ -- expression for the predicate.
+
+ function May_Fold (N : Node_Id) return Traverse_Result is
+ begin
+ case Nkind (N) is
+ when N_Binary_Op | N_Unary_Op =>
+ return OK;
+
+ when N_Identifier | N_Expanded_Name =>
+ if Ekind (Entity (N)) = E_In_Parameter
+ and then Entity (N) = First_Entity (P)
+ then
+ Rewrite (N, New_Copy (Actual));
+ Set_Is_Static_Expression (N);
+ return OK;
+
+ elsif Ekind (Entity (N)) = E_Enumeration_Literal then
+ return OK;
+
+ else
+ return Abandon;
+ end if;
+
+ when N_If_Expression | N_Case_Expression =>
+ return OK;
+
+ when N_Integer_Literal =>
+ return OK;
+
+ when others =>
+ return Abandon;
+ end case;
+ end May_Fold;
+
+ function Try_Fold is new Traverse_Func (May_Fold);
+
+ -- Start of processing for Can_Fold_Predicate_Call
+
+ begin
+ -- Folding is only interesting if the actual is static and its type
+ -- has a Dynamic_Predicate aspect. For CodePeer we preserve the
+ -- function call.
+
+ if Nkind (Actual) /= N_Integer_Literal
+ or else not Has_Dynamic_Predicate_Aspect (Subt)
+ or else CodePeer_Mode
+ then
+ return False;
+ end if;
+
+ -- Retrieve the analyzed expression for the predicate
+
+ Pred :=
+ New_Copy_Tree
+ (Expression (Find_Aspect (Subt, Aspect_Dynamic_Predicate)));
+
+ if Try_Fold (Pred) = OK then
+ Rewrite (Call_Node, Pred);
+ Analyze_And_Resolve (Call_Node, Standard_Boolean);
+ return True;
+
+ else
+ -- Continue expansion of function call
+
+ return False;
+ end if;
+ end Can_Fold_Predicate_Call;
+
---------------------------
-- Inherited_From_Formal --
---------------------------
@@ -2815,6 +2905,17 @@ package body Exp_Ch6 is
end;
end if;
+ -- if this is a call to a predicate function, try to constant
+ -- fold it.
+
+ if Nkind (Call_Node) = N_Function_Call
+ and then Is_Entity_Name (Name (Call_Node))
+ and then Is_Predicate_Function (Subp)
+ and then Can_Fold_Predicate_Call (Subp)
+ then
+ return;
+ end if;
+
if Modify_Tree_For_C
and then Nkind (Call_Node) = N_Function_Call
and then Is_Entity_Name (Name (Call_Node))
new file mode 100644
@@ -0,0 +1,19 @@
+-- { dg-do compile }
+-- { dg-options "-gnata" }
+
+procedure Predicate11 is
+ type T_BYTES is new Integer range 0 .. 2**15 - 1 with Size => 32;
+ subtype TYPE5_SCALAR is T_BYTES
+ with Dynamic_Predicate => TYPE5_SCALAR mod 4 = 0;
+ subtype Cond is Integer
+ with dynamic_predicate => (if cond < 5 then false else True);
+
+ Thing1 : Type5_Scalar := 7; -- { dg-warning "check will fail at run time" }
+ function OK (C :Type5_scalar) return Boolean is (True);
+ Thing2 : Type5_Scalar;
+ Thing3 : Cond;
+begin
+ if not OK (7) then raise Program_Error; end if; -- { dg-warning "check will fail at run time" }
+ Thing2 := 8;
+ Thing3 := 1; -- { dg-warning "check will fail at run time" }
+end;