-- function typPredicate (Ixxx : typ) return Boolean is
-- begin
-- return
- -- exp1 and then exp2 and then ...
- -- and then typ1Predicate (typ1 (Ixxx))
+ -- typ1Predicate (typ1 (Ixxx))
-- and then typ2Predicate (typ2 (Ixxx))
-- and then ...;
+ -- exp1 and then exp2 and then ...
-- end typPredicate;
-- Here exp1, and exp2 are expressions from Predicate pragmas. Note that
-- inherited. Note that we do NOT generate Check pragmas, that's because we
-- use this function even if checks are off, e.g. for membership tests.
+ -- Note that the inherited predicates are evaluated first, as required by
+ -- AI12-0071-1.
+
+ -- Note that Sem_Eval.Real_Or_String_Static_Predicate_Matches depends on
+ -- the form of this return expression.
+
-- If the expression has at least one Raise_Expression, then we also build
-- the typPredicateM version of the function, in which any occurrence of a
-- Raise_Expression is converted to "return False".
Raise_Expression_Present : Boolean := False;
-- Set True if Expr has at least one Raise_Expression
- procedure Add_Call (T : Entity_Id);
- -- Includes a call to the predicate function for type T in Expr if T
- -- has predicates and Predicate_Function (T) is non-empty.
+ procedure Add_Condition (Cond : Node_Id);
+ -- Append Cond to Expr using "and then" (or just copy Cond to Expr if
+ -- Expr is empty).
procedure Add_Predicates;
-- Appends expressions for any Predicate pragmas in the rep item chain
-- Inheritance of predicates for the parent type is done by calling the
-- Predicate_Function of the parent type, using Add_Call above.
+ procedure Add_Call (T : Entity_Id);
+ -- Includes a call to the predicate function for type T in Expr if T
+ -- has predicates and Predicate_Function (T) is non-empty.
+
function Process_RE (N : Node_Id) return Traverse_Result;
-- Used in Process REs, tests if node N is a raise expression, and if
-- so, marks it to be converted to return False.
Make_Predicate_Call
(T, Convert_To (T, Make_Identifier (Loc, Object_Name)));
- -- Add call to evolving expression, using AND THEN if needed
+ -- "and"-in the call to evolving expression
- if No (Expr) then
- Expr := Exp;
-
- else
- Expr :=
- Make_And_Then (Sloc (Expr),
- Left_Opnd => Relocate_Node (Expr),
- Right_Opnd => Exp);
- end if;
+ Add_Condition (Exp);
-- Output info message on inheritance if required. Note we do not
-- give this information for generic actual types, since it is
end if;
end Add_Call;
+ -------------------
+ -- Add_Condition --
+ -------------------
+
+ procedure Add_Condition (Cond : Node_Id) is
+ begin
+ -- This is the first predicate expression
+
+ if No (Expr) then
+ Expr := Cond;
+
+ -- Otherwise concatenate to the existing predicate expressions by
+ -- using "and then".
+
+ else
+ Expr :=
+ Make_And_Then (Loc,
+ Left_Opnd => Relocate_Node (Expr),
+ Right_Opnd => Cond);
+ end if;
+ end Add_Condition;
+
--------------------
-- Add_Predicates --
--------------------
-- Check_Aspect_At_xxx routines.
if Present (Asp) then
-
Set_Entity (Identifier (Asp), New_Copy_Tree (Arg2));
end if;
- -- Concatenate to the existing predicate expressions by using
- -- "and then".
-
- if Present (Expr) then
- Expr :=
- Make_And_Then (Loc,
- Left_Opnd => Relocate_Node (Expr),
- Right_Opnd => Relocate_Node (Arg2));
-
- -- Otherwise this is the first predicate expression
+ -- "and"-in the Arg2 condition to evolving expression
- else
- Expr := Relocate_Node (Arg2);
- end if;
+ Add_Condition (Relocate_Node (Arg2));
end if;
end Add_Predicate;
Expr := Empty;
- -- Add Predicates for the current type
-
- Add_Predicates;
-
- -- Add predicates for ancestor if present
+ -- Add predicates for ancestor if present. These must come before the
+ -- ones for the current type, as required by AI12-0071-1.
declare
Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
end if;
end;
+ -- Add Predicates for the current type
+
+ Add_Predicates;
+
-- Case where predicates are present
if Present (Expr) then
-- First a little fiddling to get a nice location for the
-- message. If the expression is of the form (A and then B),
- -- then use the left operand for the Sloc. This avoids getting
- -- confused by a call to a higher-level predicate with a less
- -- convenient source location.
+ -- where A is an inherited predicate, then use the right
+ -- operand for the Sloc. This avoids getting confused by a call
+ -- to an inherited predicate with a less convenient source
+ -- location.
EN := Expr;
- while Nkind (EN) = N_And_Then loop
- EN := Left_Opnd (EN);
+ while Nkind (EN) = N_And_Then
+ and then Nkind (Left_Opnd (EN)) = N_Function_Call
+ and then Is_Predicate_Function
+ (Entity (Name (Left_Opnd (EN))))
+ loop
+ EN := Right_Opnd (EN);
end loop;
-- Now post appropriate message
-- references to inherited predicates, so that the expression we are
-- processing looks like:
- -- expression and then xxPredicate (typ (Inns))
+ -- xxPredicate (typ (Inns)) and then expression
-- Where the call is to a Predicate function for an inherited predicate.
-- We simply ignore such a call, which could be to either a dynamic or
-- First deal with special case of inherited predicate, where the
-- predicate expression looks like:
- -- Expr and then xxPredicate (typ (Ent))
+ -- xxPredicate (typ (Ent)) and then Expr
-- where Expr is the predicate expression for this level, and the
- -- right operand is the call to evaluate the inherited predicate.
+ -- left operand is the call to evaluate the inherited predicate.
if Nkind (Expr) = N_And_Then
- and then Nkind (Right_Opnd (Expr)) = N_Function_Call
+ and then Nkind (Left_Opnd (Expr)) = N_Function_Call
+ and then Is_Predicate_Function (Entity (Name (Left_Opnd (Expr))))
then
-- OK we have the inherited case, so make a call to evaluate the
-- inherited predicate. If that fails, so do we!
if not
Real_Or_String_Static_Predicate_Matches
(Val => Val,
- Typ => Etype (First_Formal (Entity (Name (Right_Opnd (Expr))))))
+ Typ => Etype (First_Formal (Entity (Name (Left_Opnd (Expr))))))
then
return False;
end if;
- -- Use the left operand for the continued processing
+ -- Use the right operand for the continued processing
- Copy := Copy_Separate_Tree (Left_Opnd (Expr));
+ Copy := Copy_Separate_Tree (Right_Opnd (Expr));
-- Case where call to predicate function appears on its own (this means
-- that the predicate at this level is just inherited from the parent).
projects / gcc.git / commitdiff