procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

einfo.ads, einfo.adb: Add handling of predicates.

Browse source 
2010-10-21  Robert Dewar  <dewar@adacore.com>

	* einfo.ads, einfo.adb: Add handling of predicates.
	Rework handling of invariants.
	* exp_ch3.adb, exp_ch4.adb, exp_util.adb, sem_ch6.adb: Minor changes to
	handing of invariants.
	* par-prag.adb: Add dummy entry for pragma Predicate
	* sem_ch13.adb (Analyze_Aspect_Specifications): Add processing for
	Predicate aspects.
	* sem_prag.adb: Add implementation of pragma Predicate.
	* snames.ads-tmpl: Add entries for pragma Predicate.

2010-10-21  Robert Dewar  <dewar@adacore.com>

	* elists.adb: Minor reformatting.

From-SVN: r165766
This commit is contained in:
Robert Dewar 2010-10-21 10:43:12 +00:00 • committed by Arnaud Charlet
parent c9a410f028
commit 48f91b442f
13 changed files with 432 additions and 376 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
gcc/ada/ChangeLog
View file

@ -1,3 +1,25 @@
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

21
gcc/ada/checks.adb
View file

@ -997,10 +997,15 @@ package body Checks is
Desig_Typ : Entity_Id;
begin
-- No checks inside a generic (check the instantiations)
if Inside_A_Generic then
return;
end if;
elsif Is_Scalar_Type (Typ) then
-- Apply required constaint checks
if Is_Scalar_Type (Typ) then
Apply_Scalar_Range_Check (N, Typ);
elsif Is_Array_Type (Typ) then
@ -1748,6 +1753,20 @@ package body Checks is
(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 --
-----------------------

15
gcc/ada/checks.ads
View file

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -134,10 +134,10 @@ package Checks is
(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;
@ -153,6 +153,11 @@ package Checks is
-- 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)

2
gcc/ada/einfo.adb
View file

@ -1411,7 +1411,7 @@ package body Einfo is
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;

325
gcc/ada/exp_ch13.adb
View file

@ -26,6 +26,7 @@
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;
@ -37,6 +38,8 @@ with Nmake; use Nmake;
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;
@ -50,6 +53,308 @@ with Validsw; use Validsw;
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 --
------------------------------------------
@ -414,6 +719,26 @@ package body Exp_Ch13 is
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);

17
gcc/ada/exp_ch4.adb
View file

@ -8767,7 +8767,6 @@ package body Exp_Ch4 is
-- 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
@ -8933,8 +8932,20 @@ package body Exp_Ch4 is
-- 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;
-----------------------------------

4
gcc/ada/exp_ch5.adb
View file

@ -1626,6 +1626,10 @@ package body Exp_Ch5 is
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:

33
gcc/ada/exp_prag.adb
View file

@ -294,7 +294,7 @@ package body Exp_Prag is
-- 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.
@ -353,22 +353,18 @@ package body Exp_Prag is
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
@ -376,10 +372,21 @@ package body Exp_Prag is
-- 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

22
gcc/ada/freeze.adb
View file

@ -3787,28 +3787,6 @@ package body Freeze is
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.

285
gcc/ada/sem_ch13.adb
View file

@ -3756,291 +3756,6 @@ package body Sem_Ch13 is
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 --
-----------------------------------

13
gcc/ada/sem_ch13.ads
View file

@ -64,19 +64,6 @@ package Sem_Ch13 is
-- 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

36
gcc/ada/sem_ch3.adb
View file

@ -17205,41 +17205,11 @@ package body Sem_Ch3 is
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;

13
gcc/ada/sem_res.adb
View file

@ -3648,6 +3648,19 @@ package body Sem_Res is
-- 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);