2010-10-21 Robert Dewar <dewar@adacore.com>
+ * checks.ads, checks.adb (Apply_Predicate_Check): New procedure
+ Minor code reorganization.
+ * einfo.adb (Has_Predicates): Fix assertion.
+ * exp_ch13.adb (Build_Predicate_Function): Move from Sem_Ch13 spec to
+ Exp_Ch13 body.
+ (Expand_N_Freeze_Entity): Call build predicate function.
+ * exp_ch4.adb (Expand_N_Type_Conversion): Add predicate check.
+ * exp_ch5.adb (Expand_N_Assignment_Statement): Add predicate check.
+ * exp_prag.adb (Expand_Pragma_Check): Use all lower case for name of
+ check.
+ * freeze.adb (Freeze_Entity): Move building of predicate function to
+ Exp_Ch13.
+ * sem_ch13.adb (Build_Predicate_Function): Move from Sem_Ch13 to
+ Exp_Ch13.
+ * sem_ch13.ads (Build_Predicate_Function): Move from Sem_Ch13 to
+ Exp_Ch13.
+ * sem_ch3.adb (Analyze_Declarations): Remove call to build predicate
+ function.
+ * sem_res.adb (Resolve_Actuals): Apply predicate check.
+
+2010-10-21 Robert Dewar <dewar@adacore.com>
+
* einfo.ads, einfo.adb: Replace Predicate_Procedure by
Predicate_Functions.
* exp_ch4.adb (Expand_N_In): Handle predicates.
Desig_Typ : Entity_Id;
begin
+ -- No checks inside a generic (check the instantiations)
+
if Inside_A_Generic then
return;
+ end if;
+
+ -- Apply required constaint checks
- elsif Is_Scalar_Type (Typ) then
+ if Is_Scalar_Type (Typ) then
Apply_Scalar_Range_Check (N, Typ);
elsif Is_Array_Type (Typ) then
(Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
end Apply_Length_Check;
+ ---------------------------
+ -- Apply_Predicate_Check --
+ ---------------------------
+
+ procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id) is
+ begin
+ if Etype (N) /= Typ
+ and then Present (Predicate_Function (Typ))
+ then
+ Insert_Action (N,
+ Make_Predicate_Check (Typ, Duplicate_Subexpr (N)));
+ end if;
+ end Apply_Predicate_Check;
+
-----------------------
-- Apply_Range_Check --
-----------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
(N : Node_Id;
Typ : Entity_Id;
No_Sliding : Boolean := False);
- -- Top-level procedure, calls all the others depending on the class of Typ.
- -- Checks that expression N satisfies the constraint of type Typ.
- -- No_Sliding is only relevant for constrained array types, if set to True,
- -- it checks that indexes are in range.
+ -- Top-level procedure, calls all the others depending on the class of
+ -- Typ. Checks that expression N satisfies the constraint of type Typ.
+ -- No_Sliding is only relevant for constrained array types, if set to
+ -- True, it checks that indexes are in range.
procedure Apply_Discriminant_Check
(N : Node_Id;
-- formals, the check is peformed only if the corresponding actual is
-- constrained, i.e., whether Lhs'Constrained is True.
+ procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id);
+ -- N is an expression to which a predicate check may need to be applied
+ -- for Typ, if Typ has a predicate function. The check is applied only
+ -- if the type of N does not match Typ.
+
function Build_Discriminant_Checks
(N : Node_Id;
T_Typ : Entity_Id)
function Has_Predicates (Id : E) return B is
begin
- pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Function);
+ pragma Assert (Is_Type (Id) or else Is_Subprogram (Id));
return Flag250 (Id);
end Has_Predicates;
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
+with Elists; use Elists;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Imgv; use Exp_Imgv;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch3; use Sem_Ch3;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
package body Exp_Ch13 is
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Build_Predicate_Function
+ (Typ : Entity_Id;
+ FDecl : out Node_Id;
+ FBody : out Node_Id);
+ -- If Typ has predicates (indicated by Has_Predicates being set for Typ,
+ -- then either there are pragma Invariant entries on the rep chain for the
+ -- type (note that Predicate aspects are converted to pragam Predicate), or
+ -- there are inherited aspects from a parent type, or ancestor subtypes,
+ -- or interfaces. This procedure builds the spec and body for the Predicate
+ -- function that tests these predicates, returning them in PDecl and Pbody
+ -- and setting Predicate_Procedure for Typ. In some error situations no
+ -- procedure is built, in which case PDecl/PBody are empty on return.
+
+ ------------------------------
+ -- Build_Predicate_Function --
+ ------------------------------
+
+ -- The procedure that is constructed here has the form
+
+ -- function typPredicate (Ixxx : typ) return Boolean is
+ -- begin
+ -- return
+ -- exp1 and then exp2 and then ...
+ -- and then typ1Predicate (typ1 (Ixxx))
+ -- and then typ2Predicate (typ2 (Ixxx))
+ -- and then ...;
+ -- end typPredicate;
+
+ -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that
+ -- this is the point at which these expressions get analyzed, providing the
+ -- required delay, and typ1, typ2, are entities from which predicates are
+ -- 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.
+
+ procedure Build_Predicate_Function
+ (Typ : Entity_Id;
+ FDecl : out Node_Id;
+ FBody : out Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Spec : Node_Id;
+ SId : Entity_Id;
+
+ Expr : Node_Id;
+ -- This is the expression for the return statement in the function. It
+ -- is build by connecting the component predicates with AND THEN.
+
+ procedure Add_Call (T : Entity_Id);
+ -- Includes a call statement to the predicate function for type T in
+ -- Expr if T has predicates and Predicate_Function (T) is non-empty.
+
+ procedure Add_Predicates;
+ -- Appends expressions for any Predicate pragmas in the rep item chain
+ -- Typ to Expr. Note that we look only at items for this exact entity.
+ -- Inheritance of predicates for the parent type is done by calling the
+ -- Predicate_Function of the parent type, using Add_Call above.
+
+ Object_Name : constant Name_Id := New_Internal_Name ('I');
+ -- Name for argument of Predicate procedure
+
+ --------------
+ -- Add_Call --
+ --------------
+
+ procedure Add_Call (T : Entity_Id) is
+ Exp : Node_Id;
+
+ begin
+ if Present (T)
+ and then Present (Predicate_Function (T))
+ then
+ Exp :=
+ Make_Predicate_Call
+ (T,
+ Convert_To (T,
+ Make_Identifier (Loc,
+ Chars => Object_Name)));
+
+ if No (Expr) then
+ Expr := Exp;
+ else
+ Expr :=
+ Make_And_Then (Loc,
+ Left_Opnd => Relocate_Node (Expr),
+ Right_Opnd => Exp);
+ end if;
+ end if;
+ end Add_Call;
+
+ --------------------
+ -- Add_Predicates --
+ --------------------
+
+ procedure Add_Predicates is
+ Ritem : Node_Id;
+ Arg1 : Node_Id;
+ Arg2 : Node_Id;
+
+ function Replace_Node (N : Node_Id) return Traverse_Result;
+ -- Process single node for traversal to replace type references
+
+ procedure Replace_Type is new Traverse_Proc (Replace_Node);
+ -- Traverse an expression changing every occurrence of an entity
+ -- reference to type T with a reference to the object argument.
+
+ ------------------
+ -- Replace_Node --
+ ------------------
+
+ function Replace_Node (N : Node_Id) return Traverse_Result is
+ begin
+ -- Case of entity name referencing the type
+
+ if Is_Entity_Name (N)
+ and then Entity (N) = Typ
+ then
+ -- Replace with object
+
+ Rewrite (N,
+ Make_Identifier (Loc,
+ Chars => Object_Name));
+
+ -- All done with this node
+
+ return Skip;
+
+ -- Not an instance of the type entity, keep going
+
+ else
+ return OK;
+ end if;
+ end Replace_Node;
+
+ begin
+ Ritem := First_Rep_Item (Typ);
+ while Present (Ritem) loop
+ if Nkind (Ritem) = N_Pragma
+ and then Pragma_Name (Ritem) = Name_Predicate
+ then
+ Arg1 := First (Pragma_Argument_Associations (Ritem));
+ Arg2 := Next (Arg1);
+
+ Arg1 := Get_Pragma_Arg (Arg1);
+ Arg2 := Get_Pragma_Arg (Arg2);
+
+ -- We need to replace any occurrences of the name of the type
+ -- with references to the object. We do this by first doing a
+ -- preanalysis, to identify all the entities, then we traverse
+ -- looking for the type entity, doing the needed substitution.
+ -- The preanalysis is done with the special OK_To_Reference
+ -- flag set on the type, so that if we get an occurrence of
+ -- this type, it will be reognized as legitimate.
+
+ Set_OK_To_Reference (Typ, True);
+ Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
+ Set_OK_To_Reference (Typ, False);
+ Replace_Type (Arg2);
+
+ -- See if this predicate pragma is for the current type
+
+ if Entity (Arg1) = Typ then
+
+ -- We have a match, add the expression
+
+ if No (Expr) then
+ Expr := Relocate_Node (Arg2);
+ else
+ Expr :=
+ Make_And_Then (Loc,
+ Left_Opnd => Relocate_Node (Expr),
+ Right_Opnd => Relocate_Node (Arg2));
+ end if;
+ end if;
+ end if;
+
+ Next_Rep_Item (Ritem);
+ end loop;
+ end Add_Predicates;
+
+ -- Start of processing for Build_Predicate_Function
+
+ begin
+ -- Initialize for construction of statement list
+
+ Expr := Empty;
+ FDecl := Empty;
+ FBody := Empty;
+
+ -- Return if already built or if type does not have predicates
+
+ if not Has_Predicates (Typ)
+ or else Present (Predicate_Function (Typ))
+ then
+ return;
+ end if;
+
+ -- Add Predicates for the current type
+
+ Add_Predicates;
+
+ -- Deal with ancestor subtype and parent type
+
+ declare
+ Atyp : constant Entity_Id := Ancestor_Subtype (Typ);
+
+ begin
+ -- If ancestor subtype present, add its predicates
+
+ if Present (Atyp) then
+ Add_Call (Atyp);
+
+ -- Else if this is derived, add predicates of parent type
+
+ elsif Is_Derived_Type (Typ) then
+ Add_Call (Etype (Base_Type (Typ)));
+ end if;
+ end;
+
+ -- Add predicates of any interfaces of a tagged type
+
+ if Is_Tagged_Type (Typ) then
+ declare
+ Iface_List : Elist_Id;
+ Elmt : Elmt_Id;
+
+ begin
+ Collect_Interfaces (Typ, Iface_List);
+
+ if Present (Iface_List) then
+ loop
+ Elmt := First_Elmt (Iface_List);
+ exit when No (Elmt);
+ Add_Call (Node (Elmt));
+ Remove_Elmt (Iface_List, Elmt);
+ end loop;
+ end if;
+ end;
+ end if;
+
+ if Present (Expr) then
+
+ -- Build function declaration
+
+ pragma Assert (Has_Predicates (Typ));
+ SId :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "Predicate"));
+ Set_Has_Predicates (SId);
+ Set_Predicate_Function (Typ, SId);
+
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => SId,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Object_Name),
+ Parameter_Type =>
+ New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
+
+ FDecl :=
+ Make_Subprogram_Declaration (Loc,
+ Specification => Spec);
+
+ -- Build function body
+
+ SId :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "Predicate"));
+
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => SId,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Object_Name),
+ Parameter_Type =>
+ New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
+
+ FBody :=
+ Make_Subprogram_Body (Loc,
+ Specification => Spec,
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression => Expr))));
+ end if;
+ end Build_Predicate_Function;
+
------------------------------------------
-- Expand_N_Attribute_Definition_Clause --
------------------------------------------
Rewrite (N, Make_Null_Statement (Sloc (N)));
end if;
+ -- If freezing a type entity which has predicates, this is where we
+ -- build and insert the predicate function for the type.
+
+ if Is_Type (E) and then Has_Predicates (E) then
+ declare
+ FDecl : Node_Id;
+ FBody : Node_Id;
+
+ begin
+ Build_Predicate_Function (E, FDecl, FBody);
+
+ if Present (FDecl) then
+ Insert_After (N, FBody);
+ Insert_After (N, FDecl);
+ end if;
+ end;
+ end if;
+
+ -- Pop scope if we intalled one for the analysis
+
if In_Other_Scope then
if Ekind (Current_Scope) = E_Package then
End_Package_Scope (E_Scope);
-- this case, see Handle_Changed_Representation.
elsif Is_Array_Type (Target_Type) then
-
if Is_Constrained (Target_Type) then
Apply_Length_Check (Operand, Target_Type);
else
-- Here at end of processing
- <<Done>>
- null;
+ <<Done>>
+ -- Apply predicate check if required. Note that we can't just call
+ -- Apply_Predicate_Check here, because the type looks right after
+ -- the conversion and it would omit the check. The Comes_From_Source
+ -- 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 Target_Type /= Operand_Type
+ and then Comes_From_Source (N)
+ then
+ Insert_Action (N,
+ Make_Predicate_Check (Target_Type, Duplicate_Subexpr (N)));
+ end if;
end Expand_N_Type_Conversion;
-----------------------------------
Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed);
end if;
+ -- Generate predicate check if required
+
+ Apply_Predicate_Check (Rhs, Typ);
+
-- Check for a special case where a high level transformation is
-- required. If we have either of:
-- where Str is the message if one is present, or the default of
-- name failed at file:line if no message is given (the "name failed
-- at" is omitted for name = Assertion, since it is redundant, given
- -- that the name of the exception is Assert_Failure.
+ -- that the name of the exception is Assert_Failure.)
-- An alternative expansion is used when the No_Exception_Propagation
-- restriction is active and there is a local Assert_Failure handler.
Msg_Loc : constant String := Build_Location_String (Loc);
begin
+ Name_Len := 0;
+
-- For Assert, we just use the location
if Nam = Name_Assertion then
- Name_Len := 0;
+ null;
- -- For any check except Precondition/Postcondition, the
- -- string is "xxx failed at yyy" where xxx is the name of
- -- the check with current source file casing.
+ -- For predicate, we generate the string "predicate failed
+ -- at yyy". We prefer all lower case for predicate.
- elsif Nam /= Name_Precondition
- and then
- Nam /= Name_Postcondition
- then
- Get_Name_String (Nam);
- Set_Casing (Identifier_Casing (Current_Source_File));
- Add_Str_To_Name_Buffer (" failed at ");
+ elsif Nam = Name_Predicate then
+ Add_Str_To_Name_Buffer ("predicate failed at ");
-- For special case of Precondition/Postcondition the string is
-- "failed xx from yy" where xx is precondition/postcondition
-- that the failure is not at the point of occurrence of the
-- pragma, unlike the other Check cases.
- else
+ elsif Nam = Name_Precondition
+ or else
+ Nam = Name_Postcondition
+ then
Get_Name_String (Nam);
Insert_Str_In_Name_Buffer ("failed ", 1);
Add_Str_To_Name_Buffer (" from ");
+
+ -- For all other checks, the string is "xxx failed at yyy"
+ -- where xxx is the check name with current source file casing.
+
+ else
+ Get_Name_String (Nam);
+ Set_Casing (Identifier_Casing (Current_Source_File));
+ Add_Str_To_Name_Buffer (" failed at ");
end if;
-- In all cases, add location string
end if;
end if;
- -- If we have predicates, then this is where we build the predicate
- -- function, and return the spec and body as freeze actions.
-
- if Has_Predicates (E) then
- declare
- FDecl : Node_Id;
- FBody : Node_Id;
-
- begin
- Build_Predicate_Function (E, FDecl, FBody);
-
- if Present (FDecl) then
- if No (Result) then
- Result := Empty_List;
- end if;
-
- Append_To (Result, FDecl);
- Append_To (Result, FBody);
- end if;
- end;
- end if;
-
-- Generic types are never seen by the back-end, and are also not
-- processed by the expander (since the expander is turned off for
-- generic processing), so we never need freeze nodes for them.
end if;
end Build_Invariant_Procedure;
- ------------------------------
- -- Build_Predicate_Function --
- ------------------------------
-
- -- The procedure that is constructed here has the form
-
- -- function typPredicate (Ixxx : typ) return Boolean is
- -- begin
- -- return
- -- exp1 and then exp2 and then ...
- -- and then typ1Predicate (typ1 (Ixxx))
- -- and then typ2Predicate (typ2 (Ixxx))
- -- and then ...;
- -- end typPredicate;
-
- -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that
- -- this is the point at which these expressions get analyzed, providing the
- -- required delay, and typ1, typ2, are entities from which predicates are
- -- 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.
-
- procedure Build_Predicate_Function
- (Typ : Entity_Id;
- FDecl : out Node_Id;
- FBody : out Node_Id)
- is
- Loc : constant Source_Ptr := Sloc (Typ);
- Spec : Node_Id;
- SId : Entity_Id;
-
- Expr : Node_Id;
- -- This is the expression for the return statement in the function. It
- -- is build by connecting the component predicates with AND THEN.
-
- procedure Add_Call (T : Entity_Id);
- -- Includes a call statement to the predicate function for type T in
- -- Expr if T has predicates and Predicate_Function (T) is non-empty.
-
- procedure Add_Predicates;
- -- Appends expressions for any Predicate pragmas in the rep item chain
- -- Typ to Expr. Note that we look only at items for this exact entity.
- -- Inheritance of predicates for the parent type is done by calling the
- -- Predicate_Function of the parent type, using Add_Call above.
-
- Object_Name : constant Name_Id := New_Internal_Name ('I');
- -- Name for argument of Predicate procedure
-
- --------------
- -- Add_Call --
- --------------
-
- procedure Add_Call (T : Entity_Id) is
- Exp : Node_Id;
-
- begin
- if Present (T)
- and then Present (Predicate_Function (T))
- then
- Exp :=
- Make_Predicate_Call
- (T,
- Convert_To (T,
- Make_Identifier (Loc,
- Chars => Object_Name)));
-
- if No (Expr) then
- Expr := Exp;
- else
- Expr :=
- Make_And_Then (Loc,
- Left_Opnd => Relocate_Node (Expr),
- Right_Opnd => Exp);
- end if;
- end if;
- end Add_Call;
-
- --------------------
- -- Add_Predicates --
- --------------------
-
- procedure Add_Predicates is
- Ritem : Node_Id;
- Arg1 : Node_Id;
- Arg2 : Node_Id;
-
- function Replace_Node (N : Node_Id) return Traverse_Result;
- -- Process single node for traversal to replace type references
-
- procedure Replace_Type is new Traverse_Proc (Replace_Node);
- -- Traverse an expression changing every occurrence of an entity
- -- reference to type T with a reference to the object argument.
-
- ------------------
- -- Replace_Node --
- ------------------
-
- function Replace_Node (N : Node_Id) return Traverse_Result is
- begin
- -- Case of entity name referencing the type
-
- if Is_Entity_Name (N)
- and then Entity (N) = Typ
- then
- -- Replace with object
-
- Rewrite (N,
- Make_Identifier (Loc,
- Chars => Object_Name));
-
- -- All done with this node
-
- return Skip;
-
- -- Not an instance of the type entity, keep going
-
- else
- return OK;
- end if;
- end Replace_Node;
-
- begin
- Ritem := First_Rep_Item (Typ);
- while Present (Ritem) loop
- if Nkind (Ritem) = N_Pragma
- and then Pragma_Name (Ritem) = Name_Predicate
- then
- Arg1 := First (Pragma_Argument_Associations (Ritem));
- Arg2 := Next (Arg1);
-
- Arg1 := Get_Pragma_Arg (Arg1);
- Arg2 := Get_Pragma_Arg (Arg2);
-
- -- We need to replace any occurrences of the name of the type
- -- with references to the object. We do this by first doing a
- -- preanalysis, to identify all the entities, then we traverse
- -- looking for the type entity, doing the needed substitution.
- -- The preanalysis is done with the special OK_To_Reference
- -- flag set on the type, so that if we get an occurrence of
- -- this type, it will be reognized as legitimate.
-
- Set_OK_To_Reference (Typ, True);
- Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
- Set_OK_To_Reference (Typ, False);
- Replace_Type (Arg2);
-
- -- See if this predicate pragma is for the current type
-
- if Entity (Arg1) = Typ then
-
- -- We have a match, add the expression
-
- if No (Expr) then
- Expr := Relocate_Node (Arg2);
- else
- Expr :=
- Make_And_Then (Loc,
- Left_Opnd => Relocate_Node (Expr),
- Right_Opnd => Relocate_Node (Arg2));
- end if;
- end if;
- end if;
-
- Next_Rep_Item (Ritem);
- end loop;
- end Add_Predicates;
-
- -- Start of processing for Build_Predicate_Function
-
- begin
- -- Initialize for construction of statement list
-
- Expr := Empty;
- FDecl := Empty;
- FBody := Empty;
-
- -- Return if already built or if type does not have predicates
-
- if not Has_Predicates (Typ)
- or else Present (Predicate_Function (Typ))
- then
- return;
- end if;
-
- -- Add Predicates for the current type
-
- Add_Predicates;
-
- -- Deal with ancestor subtype and parent type
-
- declare
- Atyp : constant Entity_Id := Ancestor_Subtype (Typ);
-
- begin
- -- If ancestor subtype present, add its predicates
-
- if Present (Atyp) then
- Add_Call (Atyp);
-
- -- Else if this is derived, add predicates of parent type
-
- elsif Is_Derived_Type (Typ) then
- Add_Call (Etype (Base_Type (Typ)));
- end if;
- end;
-
- -- Add predicates of any interfaces of a tagged type
-
- if Is_Tagged_Type (Typ) then
- declare
- Iface_List : Elist_Id;
- Elmt : Elmt_Id;
-
- begin
- Collect_Interfaces (Typ, Iface_List);
-
- if Present (Iface_List) then
- loop
- Elmt := First_Elmt (Iface_List);
- exit when No (Elmt);
- Add_Call (Node (Elmt));
- Remove_Elmt (Iface_List, Elmt);
- end loop;
- end if;
- end;
- end if;
-
- if Present (Expr) then
-
- -- Build function declaration
-
- pragma Assert (Has_Predicates (Typ));
- SId :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Predicate"));
- Set_Has_Predicates (SId);
- Set_Predicate_Function (Typ, SId);
-
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Object_Name),
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
-
- FDecl :=
- Make_Subprogram_Declaration (Loc,
- Specification => Spec);
-
- -- Build function body
-
- SId :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Predicate"));
-
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Object_Name),
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
-
- FBody :=
- Make_Subprogram_Body (Loc,
- Specification => Spec,
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Expression => Expr))));
- end if;
- end Build_Predicate_Function;
-
-----------------------------------
-- Check_Constant_Address_Clause --
-----------------------------------
-- set for Typ. In some error situations no procedure is built, in which
-- case PDecl/PBody are empty on return.
- procedure Build_Predicate_Function
- (Typ : Entity_Id;
- FDecl : out Node_Id;
- FBody : out Node_Id);
- -- If Typ has predicates (indicated by Has_Predicates being set for Typ,
- -- then either there are pragma Invariant entries on the rep chain for the
- -- type (note that Predicate aspects are converted to pragam Predicate), or
- -- there are inherited aspects from a parent type, or ancestor subtypes,
- -- or interfaces. This procedure builds the spec and body for the Predicate
- -- function that tests these predicates, returning them in PDecl and Pbody
- -- and setting Predicate_Procedure for Typ. In some error situations no
- -- procedure is built, in which case PDecl/PBody are empty on return.
-
procedure Check_Record_Representation_Clause (N : Node_Id);
-- This procedure completes the analysis of a record representation clause
-- N. It is called at freeze time after adjustment of component clause bit
end;
end if;
- -- Propagate predicates to full type, and also build the predicate
- -- procedure at this time, in the same way as we did for invariants.
+ -- Propagate predicates to full type
if Has_Predicates (Priv_T) then
- declare
- FDecl : Entity_Id;
- FBody : Entity_Id;
- Packg : constant Node_Id := Declaration_Node (Scope (Priv_T));
-
- begin
- Build_Predicate_Function (Full_T, FDecl, FBody);
-
- -- Error defense, normally this should be set
-
- if Present (FDecl) then
-
- -- Spec goes at the end of the public part of the package.
- -- That's behind us, so we have to manually analyze the
- -- inserted spec.
-
- Append_To (Visible_Declarations (Packg), FDecl);
- Analyze (FDecl);
-
- -- Body goes at the end of the private part of the package.
- -- That's ahead of us so it will get analyzed later on when
- -- we come to it.
-
- Append_To (Private_Declarations (Packg), FBody);
-
- -- Copy Predicate procedure to private declaration
-
- Set_Predicate_Function (Priv_T, Predicate_Function (Full_T));
- Set_Has_Predicates (Priv_T);
- end if;
- end;
+ Set_Predicate_Function (Priv_T, Predicate_Function (Full_T));
+ Set_Has_Predicates (Priv_T);
end if;
end Process_Full_View;
-- any analysis. More thought required about this ???
if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then
+
+ -- Apply predicate checks, unless this is a call to the
+ -- predicate check function itself, which would cause an
+ -- infinite recursion.
+
+ if not (Ekind (Nam) = E_Function
+ and then Has_Predicates (Nam))
+ then
+ Apply_Predicate_Check (A, F_Typ);
+ end if;
+
+ -- Apply required constraint checks
+
if Is_Scalar_Type (Etype (A)) then
Apply_Scalar_Range_Check (A, F_Typ);
OSDN Git Service
