S : Entity_Id;
begin
- if Predicate_Checks_Suppressed (Empty) then
- return;
-
- elsif Predicates_Ignored (Typ) then
+ if not Predicate_Enabled (Typ)
+ or else not Predicate_Check_In_Scope (N)
+ then
return;
+ end if;
- elsif Present (Predicate_Function (Typ)) then
- S := Current_Scope;
- while Present (S) and then not Is_Subprogram (S) loop
- S := Scope (S);
- end loop;
-
- -- A predicate check does not apply within internally generated
- -- subprograms, such as TSS functions.
+ S := Current_Scope;
+ while Present (S) and then not Is_Subprogram (S) loop
+ S := Scope (S);
+ end loop;
- if Within_Internal_Subprogram then
- return;
+ -- If the check appears within the predicate function itself, it means
+ -- that the user specified a check whose formal is the predicated
+ -- subtype itself, rather than some covering type. This is likely to be
+ -- a common error, and thus deserves a warning.
- -- If the check appears within the predicate function itself, it
- -- means that the user specified a check whose formal is the
- -- predicated subtype itself, rather than some covering type. This
- -- is likely to be a common error, and thus deserves a warning.
+ if Present (S) and then S = Predicate_Function (Typ) then
+ Error_Msg_NE
+ ("predicate check includes a call to& that requires a "
+ & "predicate check??", Parent (N), Fun);
+ Error_Msg_N
+ ("\this will result in infinite recursion??", Parent (N));
- elsif Present (S) and then S = Predicate_Function (Typ) then
+ if Is_First_Subtype (Typ) then
Error_Msg_NE
- ("predicate check includes a call to& that requires a "
- & "predicate check??", Parent (N), Fun);
- Error_Msg_N
- ("\this will result in infinite recursion??", Parent (N));
+ ("\use an explicit subtype of& to carry the predicate",
+ Parent (N), Typ);
+ end if;
- if Is_First_Subtype (Typ) then
- Error_Msg_NE
- ("\use an explicit subtype of& to carry the predicate",
- Parent (N), Typ);
- end if;
+ Insert_Action (N,
+ Make_Raise_Storage_Error (Sloc (N),
+ Reason => SE_Infinite_Recursion));
+ return;
+ end if;
- Insert_Action (N,
- Make_Raise_Storage_Error (Sloc (N),
- Reason => SE_Infinite_Recursion));
+ -- Normal case of predicate active
- -- Here for normal case of predicate active
+ -- If the expression is an IN parameter, the predicate will have
+ -- been applied at the point of call. An additional check would
+ -- be redundant, or will lead to out-of-scope references if the
+ -- call appears within an aspect specification for a precondition.
- else
- -- If the expression is an IN parameter, the predicate will have
- -- been applied at the point of call. An additional check would
- -- be redundant, or will lead to out-of-scope references if the
- -- call appears within an aspect specification for a precondition.
-
- -- However, if the reference is within the body of the subprogram
- -- that declares the formal, the predicate can safely be applied,
- -- which may be necessary for a nested call whose formal has a
- -- different predicate.
-
- if Is_Entity_Name (N)
- and then Ekind (Entity (N)) = E_In_Parameter
- then
- declare
- In_Body : Boolean := False;
- P : Node_Id := Parent (N);
+ -- However, if the reference is within the body of the subprogram
+ -- that declares the formal, the predicate can safely be applied,
+ -- which may be necessary for a nested call whose formal has a
+ -- different predicate.
- begin
- while Present (P) loop
- if Nkind (P) = N_Subprogram_Body
- and then
- ((Present (Corresponding_Spec (P))
- and then
- Corresponding_Spec (P) = Scope (Entity (N)))
- or else
- Defining_Unit_Name (Specification (P)) =
- Scope (Entity (N)))
- then
- In_Body := True;
- exit;
- end if;
+ if Is_Entity_Name (N)
+ and then Ekind (Entity (N)) = E_In_Parameter
+ then
+ declare
+ In_Body : Boolean := False;
+ P : Node_Id := Parent (N);
- P := Parent (P);
- end loop;
+ begin
+ while Present (P) loop
+ if Nkind (P) = N_Subprogram_Body
+ and then
+ ((Present (Corresponding_Spec (P))
+ and then
+ Corresponding_Spec (P) = Scope (Entity (N)))
+ or else
+ Defining_Unit_Name (Specification (P)) =
+ Scope (Entity (N)))
+ then
+ In_Body := True;
+ exit;
+ end if;
- if not In_Body then
- return;
- end if;
- end;
+ P := Parent (P);
+ end loop;
+
+ if not In_Body then
+ return;
end if;
+ end;
+ end if;
- -- If the type has a static predicate and the expression is known
- -- at compile time, see if the expression satisfies the predicate.
+ -- If the type has a static predicate and the expression is known
+ -- at compile time, see if the expression satisfies the predicate.
- Check_Expression_Against_Static_Predicate (N, Typ);
+ Check_Expression_Against_Static_Predicate (N, Typ);
- if not Expander_Active then
- return;
- end if;
+ if not Expander_Active then
+ return;
+ end if;
- Par := Parent (N);
- if Nkind (Par) = N_Qualified_Expression then
- Par := Parent (Par);
- end if;
+ Par := Parent (N);
+ if Nkind (Par) = N_Qualified_Expression then
+ Par := Parent (Par);
+ end if;
- -- For an entity of the type, generate a call to the predicate
- -- function, unless its type is an actual subtype, which is not
- -- visible outside of the enclosing subprogram.
+ -- For an entity of the type, generate a call to the predicate
+ -- function, unless its type is an actual subtype, which is not
+ -- visible outside of the enclosing subprogram.
- if Is_Entity_Name (N)
- and then not Is_Actual_Subtype (Typ)
- then
- Insert_Action (N,
- Make_Predicate_Check
- (Typ, New_Occurrence_Of (Entity (N), Sloc (N))));
-
- -- If the expression is an aggregate in an assignment, apply the
- -- check to the LHS after the assignment, rather than create a
- -- redundant temporary. This is only necessary in rare cases
- -- of array types (including strings) initialized with an
- -- aggregate with an "others" clause, either coming from source
- -- or generated by an Initialize_Scalars pragma.
-
- elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate)
- and then Nkind (Par) = N_Assignment_Statement
- then
- Insert_Action_After (Par,
- Make_Predicate_Check
- (Typ, Duplicate_Subexpr (Name (Par))));
+ if Is_Entity_Name (N)
+ and then not Is_Actual_Subtype (Typ)
+ then
+ Insert_Action (N,
+ Make_Predicate_Check
+ (Typ, New_Occurrence_Of (Entity (N), Sloc (N))));
+ return;
- -- Similarly, if the expression is an aggregate in an object
- -- declaration, apply it to the object after the declaration.
- -- This is only necessary in rare cases of tagged extensions
- -- initialized with an aggregate with an "others => <>" clause.
+ elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
- elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate)
- and then Nkind (Par) = N_Object_Declaration
- then
- Insert_Action_After (Par,
- Make_Predicate_Check (Typ,
- New_Occurrence_Of (Defining_Identifier (Par), Sloc (N))));
+ -- If the expression is an aggregate in an assignment, apply the
+ -- check to the LHS after the assignment, rather than create a
+ -- redundant temporary. This is only necessary in rare cases
+ -- of array types (including strings) initialized with an
+ -- aggregate with an "others" clause, either coming from source
+ -- or generated by an Initialize_Scalars pragma.
- -- If the expression is not an entity it may have side effects,
- -- and the following call will create an object declaration for
- -- it. We disable checks during its analysis, to prevent an
- -- infinite recursion.
+ if Nkind (Par) = N_Assignment_Statement then
+ Insert_Action_After (Par,
+ Make_Predicate_Check
+ (Typ, Duplicate_Subexpr (Name (Par))));
+ return;
- else
- Insert_Action (N,
- Make_Predicate_Check
- (Typ, Duplicate_Subexpr (N)), Suppress => All_Checks);
- end if;
+ -- Similarly, if the expression is an aggregate in an object
+ -- declaration, apply it to the object after the declaration.
+ -- This is only necessary in rare cases of tagged extensions
+ -- initialized with an aggregate with an "others => <>" clause.
+
+ elsif Nkind (Par) = N_Object_Declaration then
+ Insert_Action_After (Par,
+ Make_Predicate_Check (Typ,
+ New_Occurrence_Of (Defining_Identifier (Par), Sloc (N))));
+ return;
end if;
end if;
+
+ -- If the expression is not an entity it may have side effects,
+ -- and the following call will create an object declaration for
+ -- it. We disable checks during its analysis, to prevent an
+ -- infinite recursion.
+
+ Insert_Action (N,
+ Make_Predicate_Check
+ (Typ, Duplicate_Subexpr (N)), Suppress => All_Checks);
end Apply_Predicate_Check;
-----------------------
-- if components are static it is much more efficient to construct a
-- one-dimensional equivalent array with static components.
+ -- Finally we also use a small limit when we're within a subprogram
+ -- since we want to favor loops (potentially transformed to memset
+ -- calls) in this context.
+
if CodePeer_Mode then
return 100;
elsif Restriction_Active (No_Elaboration_Code)
and then Static_Elaboration_Desired (Current_Scope))
then
return 2 ** 24;
+ elsif Ekind (Current_Scope) in Subprogram_Kind then
+ return 64;
else
return Default_Size;
end if;
-- which provides for a better error message.
if Comes_From_Source (Exp)
- and then Has_Predicates (Typ)
- and then not Predicate_Checks_Suppressed (Empty)
- and then not Predicates_Ignored (Typ)
+ and then Predicate_Enabled (Typ)
then
Append (Make_Predicate_Check (Typ, Exp), Res);
end if;
- if Nkind (Exp) = N_Allocator
- and then Nkind (Expression (Exp)) = N_Qualified_Expression
- then
- declare
- Subtype_Entity : constant Entity_Id
- := Entity (Subtype_Mark (Expression (Exp)));
- begin
- if Has_Predicates (Subtype_Entity) then
- Append (Make_Predicate_Check
- (Subtype_Entity, Expression (Expression (Exp))), Res);
- end if;
- end;
- end if;
-
return Res;
exception
-- subtypes to which these checks do not apply.
elsif Has_Invariants (Def_Id) then
- if Within_Internal_Subprogram
+ if not Predicate_Check_In_Scope (Def_Id)
or else (Ekind (Current_Scope) = E_Function
and then Is_Predicate_Function (Current_Scope))
then
-- guard is necessary to prevent infinite recursions when we generate
-- internal conversions for the purpose of checking predicates.
- if Present (Predicate_Function (Target_Type))
- and then not Predicates_Ignored (Target_Type)
+ if Predicate_Enabled (Target_Type)
and then Target_Type /= Operand_Type
and then Comes_From_Source (N)
then
New_Expr : constant Node_Id := Duplicate_Subexpr (N);
begin
- -- Avoid infinite recursion on the subsequent expansion of
- -- of the copy of the original type conversion. When needed,
- -- a range check has already been applied to the expression.
+ -- Avoid infinite recursion on the subsequent expansion of the
+ -- copy of the original type conversion. When needed, a range
+ -- check has already been applied to the expression.
Set_Comes_From_Source (New_Expr, False);
Insert_Action (N,
- Make_Predicate_Check (Target_Type, New_Expr),
- Suppress => Range_Check);
+ Make_Predicate_Check (Target_Type, New_Expr),
+ Suppress => Range_Check);
end;
end if;
end Expand_N_Type_Conversion;
Atyp := Aund;
end if;
- if Has_Predicates (Atyp)
- and then Present (Predicate_Function (Atyp))
+ if Predicate_Enabled (Atyp)
-- Skip predicate checks for special cases
return Make_Null_Statement (Loc);
end if;
- -- Do not generate a check within an internal subprogram (stream
- -- functions and the like, including predicate functions).
+ -- Do not generate a check within stream functions and the like.
- if Within_Internal_Subprogram then
+ if not Predicate_Check_In_Scope (Expr) then
return Make_Null_Statement (Loc);
end if;
return False;
end Within_Case_Or_If_Expression;
- --------------------------------
- -- Within_Internal_Subprogram --
- --------------------------------
+ ------------------------------
+ -- Predicate_Check_In_Scope --
+ ------------------------------
- function Within_Internal_Subprogram return Boolean is
+ function Predicate_Check_In_Scope (N : Node_Id) return Boolean is
S : Entity_Id;
begin
S := Scope (S);
end loop;
- return Present (S)
- and then Get_TSS_Name (S) /= TSS_Null
- and then not Is_Predicate_Function (S)
- and then not Is_Predicate_Function_M (S);
- end Within_Internal_Subprogram;
+ if Present (S) then
+
+ -- Predicate checks should only be enabled in init procs for
+ -- expressions coming from source.
+
+ if Is_Init_Proc (S) then
+ return Comes_From_Source (N);
+
+ elsif Get_TSS_Name (S) /= TSS_Null
+ and then not Is_Predicate_Function (S)
+ and then not Is_Predicate_Function_M (S)
+ then
+ return False;
+ end if;
+ end if;
+
+ return True;
+ end Predicate_Check_In_Scope;
end Exp_Util;
function Within_Case_Or_If_Expression (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N is within a case or an if expression
- function Within_Internal_Subprogram return Boolean;
- -- Indicates that some expansion is taking place within the body of a
- -- predefined primitive operation. Some expansion activity (e.g. predicate
- -- checks) is disabled in such. Because we want to detect invalid uses
- -- of function calls within predicates (which lead to infinite recursion)
- -- predicate functions themselves are not considered internal here.
+ function Predicate_Check_In_Scope (N : Node_Id) return Boolean;
+ -- Return True if predicate checks should be generated in the current
+ -- scope on the given node. Will return False for example when the current
+ -- scope is a predefined primitive operation.
private
pragma Inline (Duplicate_Subexpr);
Parent_P : Node_Id;
Typ : Entity_Id;
+ Allocator_Typ : Entity_Id := Empty;
+
Freeze_Outside : Boolean := False;
-- This flag is set true if the entity must be frozen outside the
-- current subprogram. This happens in the case of expander generated
when N_Allocator =>
Desig_Typ := Designated_Type (Etype (N));
+ if Nkind (Expression (N)) = N_Qualified_Expression then
+ Allocator_Typ := Entity (Subtype_Mark (Expression (N)));
+ end if;
+
when N_Aggregate =>
if Is_Array_Type (Etype (N))
and then Is_Access_Type (Component_Type (Etype (N)))
if No (Typ)
and then No (Nam)
and then No (Desig_Typ)
+ and then No (Allocator_Typ)
then
return;
end if;
In_Spec_Expression := False;
+ -- Freeze the subtype mark before a qualified expression on an
+ -- allocator as per AARM 13.14(4.a). This is needed in particular to
+ -- generate predicate functions.
+
+ if Present (Allocator_Typ) then
+ Freeze_Before (P, Allocator_Typ);
+ end if;
+
-- Freeze the designated type of an allocator (RM 13.14(13))
if Present (Desig_Typ) then
-- If an aggregate component has a type with predicates, an explicit
-- predicate check must be applied, as for an assignment statement,
- -- because the aggegate might not be expanded into individual
+ -- because the aggregate might not be expanded into individual
-- component assignments. If the expression covers several components
-- the analysis and the predicate check take place later.
-- If an aggregate component has a type with predicates, an explicit
-- predicate check must be applied, as for an assignment statement,
- -- because the aggegate might not be expanded into individual
+ -- because the aggregate might not be expanded into individual
-- component assignments.
if Has_Predicates (Expr_Type)
Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
-- If we have a type with predicates, build predicate function. This is
- -- not needed in the generic case, nor within TSS subprograms and other
- -- predefined primitives. For a derived type, ensure that the parent
- -- type is already frozen so that its predicate function has been
+ -- not needed in the generic case, nor within e.g. TSS subprograms and
+ -- other predefined primitives. For a derived type, ensure that the
+ -- parent type is already frozen so that its predicate function has been
-- constructed already. This is necessary if the parent is declared
-- in a nested package and its own freeze point has not been reached.
if Is_Type (E)
and then Nongeneric_Case
- and then not Within_Internal_Subprogram
and then Has_Predicates (E)
+ and then Predicate_Check_In_Scope (N)
then
declare
Atyp : constant Entity_Id := Nearest_Ancestor (E);
-- the predicate still applies.
if not Suppress_Assignment_Checks (N)
- and then Present (Predicate_Function (T))
- and then not Predicates_Ignored (T)
+ and then Predicate_Enabled (T)
and then
(not No_Initialization (N)
or else (Present (E) and then Nkind (E) = N_Aggregate))
return Kind;
end Policy_In_Effect;
+ -----------------------
+ -- Predicate_Enabled --
+ -----------------------
+
+ function Predicate_Enabled (Typ : Entity_Id) return Boolean is
+ begin
+ return Present (Predicate_Function (Typ))
+ and then not Predicates_Ignored (Typ)
+ and then not Predicate_Checks_Suppressed (Empty);
+ end Predicate_Enabled;
+
----------------------------------
-- Predicate_Tests_On_Arguments --
----------------------------------
-- Given a policy, return the policy identifier associated with it. If no
-- such policy is in effect, the value returned is No_Name.
+ function Predicate_Enabled (Typ : Entity_Id) return Boolean;
+ -- Return True if a predicate check should be emitted for the given type
+ -- Typ, taking into account Predicates_Ignored and
+ -- Predicate_Checks_Suppressed.
+
function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean;
-- Subp is the entity for a subprogram call. This function returns True if
-- predicate tests are required for the arguments in this call (this is the
if Present (Expression (Node))
and then Expression (Node) /= Error
+ and then not No_Initialization (Node)
then
Write_Str (" := ");
Sprint_Node (Expression (Node));
projects / gcc.git / commitdiff