OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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: r165764
This commit is contained in:
Robert Dewar 2010-10-21 10:33:36 +00:00 committed by Arnaud Charlet
parent fd0ff1cf7e
commit 4818e7b9f8
12 changed files with 594 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
gcc/ada/ChangeLog
View File

@ -1,3 +1,21 @@
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.
* exp_util.ads, exp_util.adb (Make_Predicate_Call): New function.
(Make_Predicate_Check): New function.
* freeze.adb (Freee_Entity): Build predicate function if needed.
* sem_ch13.adb (Build_Predicate_Function): New procedure.
(Analyze_Aspect_Specifications): No third argument for Predicate pragma
built from Predicate aspect.
* sem_ch13.ads (Build_Predicate_Function): New procedure.
* sem_ch3.adb: Add handling for predicates.
* sem_eval.adb (Eval_Membership_Op): Never static if predicate
functions around.
* sem_prag.adb (Analye_Pragma, case Predicate): Does not take a third
argument.
2010-10-21 Robert Dewar <dewar@adacore.com>
* einfo.ads, einfo.adb: Add handling of predicates.

26
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_Procedure);
pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Function);
return Flag250 (Id);
end Has_Predicates;
@ -3864,7 +3864,7 @@ package body Einfo is
procedure Set_Has_Predicates (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id)
or else Ekind (Id) = E_Procedure
or else Ekind (Id) = E_Function
or else Ekind (Id) = E_Void);
Set_Flag250 (Id, V);
end Set_Has_Predicates;
@ -6265,15 +6265,15 @@ package body Einfo is
Ekind (Id) = E_Generic_Package;
end Is_Package_Or_Generic_Package;
-------------------------
-- Predicate_Procedure --
-------------------------
------------------------
-- Predicate_Function --
------------------------
function Predicate_Procedure (Id : E) return E is
function Predicate_Function (Id : E) return E is
S : Entity_Id;
begin
pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
pragma Assert (Is_Type (Id));
if No (Subprograms_For_Type (Id)) then
return Empty;
@ -6290,7 +6290,7 @@ package body Einfo is
return Empty;
end if;
end Predicate_Procedure;
end Predicate_Function;
---------------
-- Is_Prival --
@ -6860,11 +6860,11 @@ package body Einfo is
Set_Subprograms_For_Type (Id, V);
end Set_Invariant_Procedure;
-----------------------------
-- Set_Predicate_Procedure --
-----------------------------
----------------------------
-- Set_Predicate_Function --
----------------------------
procedure Set_Predicate_Procedure (Id : E; V : E) is
procedure Set_Predicate_Function (Id : E; V : E) is
S : Entity_Id;
begin
@ -6882,7 +6882,7 @@ package body Einfo is
end loop;
Set_Subprograms_For_Type (Id, V);
end Set_Predicate_Procedure;
end Set_Predicate_Function;
-----------------
-- Size_Clause --

19
gcc/ada/einfo.ads
View File

@ -1677,7 +1677,7 @@ package Einfo is
-- Present in type and subtype entities and in subprogram entities. Set
-- if a pragma Predicate or Predicate aspect applies to the type, or if
-- it inherits a Predicate aspect from its parent or progenitor types.
-- Also set in the predicate procedure entity, to distinguish it among
-- Also set in the predicate function entity, to distinguish it among
-- entries in the Subprograms_For_Type.
-- Has_Primitive_Operations (Flag120) [base type only]
@ -3276,13 +3276,12 @@ package Einfo is
-- Direct_Primitive_Operations of its CRT; otherwise returns No_Elist.
-- For all the other types returns the Direct_Primitive_Operations.
-- Predicate_Procedure (synthesized)
-- Predicate_Function (synthesized)
-- Present in all types. Set for types for which (Has_Predicates is True)
-- and for which a predicate procedure has been built that tests that the
-- specified predicates are True. Contains the entity for the procedure
-- which takes a single argument of the given type, and returns if the
-- predicate holds, or raises exception Assertion_Error with an exception
-- message if it does not hold.
-- specified predicates are True. Contains the entity for the function
-- which takes a single argument of the given type, and returns True if
-- the predicate holds and False if it does not.
--
-- Note: the reason this is marked as a synthesized attribute is that the
-- way this is stored is as an element of the Subprograms_For_Type field.
@ -3662,7 +3661,7 @@ package Einfo is
-- entity. Basically this is a way of multiplexing the single field to
-- hold more than one entity (since we ran out of space in some type
-- entities). This is currently used for Invariant_Procedure and also
-- for Predicate_Procedure, and clients will always use the latter two
-- for Predicate_Function, and clients will always use the latter two
-- names to access entries in this list.
-- Suppress_Elaboration_Warnings (Flag148)
@ -4832,7 +4831,7 @@ package Einfo is
-- Implementation_Base_Type (synth)
-- Invariant_Procedure (synth)
-- Is_Access_Protected_Subprogram_Type (synth)
-- Predicate_Procedure (synth)
-- Predicate_Function (synth)
-- Root_Type (synth)
-- Size_Clause (synth)
@ -6824,10 +6823,10 @@ package Einfo is
---------------------------------------------------
function Invariant_Procedure (Id : E) return N;
function Predicate_Procedure (Id : E) return N;
function Predicate_Function (Id : E) return N;
procedure Set_Invariant_Procedure (Id : E; V : E);
procedure Set_Predicate_Procedure (Id : E; V : E);
procedure Set_Predicate_Function (Id : E; V : E);
-----------------------------------
-- Field Initialization Routines --

93
gcc/ada/exp_ch4.adb
View File

@ -4318,14 +4318,17 @@ package body Exp_Ch4 is
procedure Expand_N_In (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Rtyp : constant Entity_Id := Etype (N);
Restyp : constant Entity_Id := Etype (N);
Lop : constant Node_Id := Left_Opnd (N);
Rop : constant Node_Id := Right_Opnd (N);
Static : constant Boolean := Is_OK_Static_Expression (N);
Ltyp : Entity_Id;
Rtyp : Entity_Id;
procedure Expand_Set_Membership;
-- For each disjunct we create a simple equality or membership test.
-- The whole membership is rewritten as a short-circuit disjunction.
-- For each choice we create a simple equality or membership test.
-- The whole membership is rewritten connecting these with OR ELSE.
---------------------------
-- Expand_Set_Membership --
@ -4400,7 +4403,7 @@ package body Exp_Ch4 is
Prefix => Relocate_Node (Lop),
Attribute_Name => Name_Valid));
Analyze_And_Resolve (N, Rtyp);
Analyze_And_Resolve (N, Restyp);
Error_Msg_N ("?explicit membership test may be optimized away", N);
Error_Msg_N -- CODEFIX
@ -4411,24 +4414,32 @@ package body Exp_Ch4 is
-- Start of processing for Expand_N_In
begin
-- If set membersip case, expand with separate procedure
if Present (Alternatives (N)) then
Remove_Side_Effects (Lop);
Expand_Set_Membership;
return;
end if;
-- Not set membership, proceed with expansion
Ltyp := Etype (Left_Opnd (N));
Rtyp := Etype (Right_Opnd (N));
-- Check case of explicit test for an expression in range of its
-- subtype. This is suspicious usage and we replace it with a 'Valid
-- test and give a warning. For floating point types however, this is a
-- standard way to check for finite numbers, and using 'Valid would
-- typically be a pessimization.
if Is_Scalar_Type (Etype (Lop))
and then not Is_Floating_Point_Type (Etype (Lop))
if Is_Scalar_Type (Ltyp)
and then not Is_Floating_Point_Type (Ltyp)
and then Nkind (Rop) in N_Has_Entity
and then Etype (Lop) = Entity (Rop)
and then Ltyp = Entity (Rop)
and then Comes_From_Source (N)
and then VM_Target = No_VM
and then No (Predicate_Function (Rtyp))
then
Substitute_Valid_Check;
return;
@ -4448,8 +4459,6 @@ package body Exp_Ch4 is
Lo : constant Node_Id := Low_Bound (Rop);
Hi : constant Node_Id := High_Bound (Rop);
Ltyp : constant Entity_Id := Etype (Lop);
Lo_Orig : constant Node_Id := Original_Node (Lo);
Hi_Orig : constant Node_Id := Original_Node (Hi);
@ -4493,7 +4502,7 @@ package body Exp_Ch4 is
and then VM_Target = No_VM
then
Substitute_Valid_Check;
return;
goto Leave;
end if;
-- If bounds of type are known at compile time, and the end points
@ -4517,7 +4526,7 @@ package body Exp_Ch4 is
and then not In_Instance
then
Substitute_Valid_Check;
return;
goto Leave;
end if;
-- If we have an explicit range, do a bit of optimization based on
@ -4537,10 +4546,9 @@ package body Exp_Ch4 is
end if;
Rewrite (N, New_Reference_To (Standard_False, Loc));
Analyze_And_Resolve (N, Rtyp);
Analyze_And_Resolve (N, Restyp);
Set_Is_Static_Expression (N, Static);
return;
goto Leave;
-- If both checks are known to succeed, replace result by True,
-- since we know we are in range.
@ -4552,10 +4560,9 @@ package body Exp_Ch4 is
end if;
Rewrite (N, New_Reference_To (Standard_True, Loc));
Analyze_And_Resolve (N, Rtyp);
Analyze_And_Resolve (N, Restyp);
Set_Is_Static_Expression (N, Static);
return;
goto Leave;
-- If lower bound check succeeds and upper bound check is not
-- known to succeed or fail, then replace the range check with
@ -4571,9 +4578,8 @@ package body Exp_Ch4 is
Make_Op_Le (Loc,
Left_Opnd => Lop,
Right_Opnd => High_Bound (Rop)));
Analyze_And_Resolve (N, Rtyp);
return;
Analyze_And_Resolve (N, Restyp);
goto Leave;
-- If upper bound check succeeds and lower bound check is not
-- known to succeed or fail, then replace the range check with
@ -4589,9 +4595,8 @@ package body Exp_Ch4 is
Make_Op_Ge (Loc,
Left_Opnd => Lop,
Right_Opnd => Low_Bound (Rop)));
Analyze_And_Resolve (N, Rtyp);
return;
Analyze_And_Resolve (N, Restyp);
goto Leave;
end if;
-- We couldn't optimize away the range check, but there is one
@ -4632,7 +4637,7 @@ package body Exp_Ch4 is
-- For all other cases of an explicit range, nothing to be done
return;
goto Leave;
-- Here right operand is a subtype mark
@ -4660,7 +4665,7 @@ package body Exp_Ch4 is
if Tagged_Type_Expansion then
Tagged_Membership (N, SCIL_Node, New_N);
Rewrite (N, New_N);
Analyze_And_Resolve (N, Rtyp);
Analyze_And_Resolve (N, Restyp);
-- Update decoration of relocated node referenced by the
-- SCIL node.
@ -4670,7 +4675,7 @@ package body Exp_Ch4 is
end if;
end if;
return;
goto Leave;
-- If type is scalar type, rewrite as x in t'First .. t'Last.
-- This reason we do this is that the bounds may have the wrong
@ -4689,8 +4694,8 @@ package body Exp_Ch4 is
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
Prefix => New_Reference_To (Typ, Loc))));
Analyze_And_Resolve (N, Rtyp);
return;
Analyze_And_Resolve (N, Restyp);
goto Leave;
-- Ada 2005 (AI-216): Program_Error is raised when evaluating
-- a membership test if the subtype mark denotes a constrained
@ -4709,7 +4714,7 @@ package body Exp_Ch4 is
-- test as False.
Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
return;
goto Leave;
end if;
-- Here we have a non-scalar type
@ -4720,7 +4725,7 @@ package body Exp_Ch4 is
if not Is_Constrained (Typ) then
Rewrite (N, New_Reference_To (Standard_True, Loc));
Analyze_And_Resolve (N, Rtyp);
Analyze_And_Resolve (N, Restyp);
-- For the constrained array case, we have to check the subscripts
-- for an exact match if the lengths are non-zero (the lengths
@ -4788,7 +4793,7 @@ package body Exp_Ch4 is
end if;
Rewrite (N, Cond);
Analyze_And_Resolve (N, Rtyp);
Analyze_And_Resolve (N, Restyp);
end Check_Subscripts;
-- These are the cases where constraint checks may be required,
@ -4819,10 +4824,34 @@ package body Exp_Ch4 is
end if;
Rewrite (N, Cond);
Analyze_And_Resolve (N, Rtyp);
Analyze_And_Resolve (N, Restyp);
end if;
end;
end if;
-- At this point, we have done the processing required for the basic
-- membership test, but not yet dealt with the predicate.
<<Leave>>
-- If a predicate is present, then we do the predicate test
if Present (Predicate_Function (Rtyp)) then
Rewrite (N,
Make_And_Then (Loc,
Left_Opnd => Relocate_Node (N),
Right_Opnd => Make_Predicate_Call (Rtyp, Lop)));
-- Analyze new expression, mark left operand as analyzed to
-- avoid infinite recursion adding predicate calls.
Set_Analyzed (Left_Opnd (N));
Analyze_And_Resolve (N, Standard_Boolean);
-- All done, skip attempt at compile time determination of result
return;
end if;
end Expand_N_In;
--------------------------------

45
gcc/ada/exp_util.adb
View File

@ -4086,6 +4086,51 @@ package body Exp_Util is
Make_Integer_Literal (Loc, 0));
end Make_Non_Empty_Check;
-------------------------
-- Make_Predicate_Call --
-------------------------
function Make_Predicate_Call
(Typ : Entity_Id;
Expr : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Expr);
begin
pragma Assert (Present (Predicate_Function (Typ)));
return
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (Predicate_Function (Typ), Loc),
Parameter_Associations => New_List (Relocate_Node (Expr)));
end Make_Predicate_Call;
--------------------------
-- Make_Predicate_Check --
--------------------------
function Make_Predicate_Check
(Typ : Entity_Id;
Expr : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Expr);
begin
return
Make_Pragma (Loc,
Pragma_Identifier =>
Make_Identifier (Loc,
Name_Check),
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression =>
Make_Identifier (Loc,
Chars => Name_Predicate)),
Make_Pragma_Argument_Association (Loc,
Expression => Make_Predicate_Call (Typ, Expr))));
end Make_Predicate_Check;
----------------------------
-- Make_Subtype_From_Expr --
----------------------------

16
gcc/ada/exp_util.ads
View File

@ -566,7 +566,21 @@ package Exp_Util is
-- Expr is an object of a type which Has_Invariants set (and which thus
-- also has an Invariant_Procedure set). If invariants are enabled, this
-- function returns a call to the Invariant procedure passing Expr as the
-- argument.
-- argument, and returns it unanalyzed. If invariants are not enabled,
-- returns a null statement.
function Make_Predicate_Call
(Typ : Entity_Id;
Expr : Node_Id) return Node_Id;
-- Typ is a type with Predicate_Function set. This routine builds a call to
-- this function passing Expr as the argument, and returns it unanalyzed.
function Make_Predicate_Check
(Typ : Entity_Id;
Expr : Node_Id) return Node_Id;
-- Typ is a type with Predicate_Function set. This routine builds a Check
-- pragma whose first argument is Predicate, and the second argument is a
-- call to the this predicate function with Expr as the argument.
function Make_Subtype_From_Expr
(E : Node_Id;

22
gcc/ada/freeze.adb
View File

@ -3787,6 +3787,28 @@ 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.

337
gcc/ada/sem_ch13.adb
View File

@ -1008,14 +1008,14 @@ package body Sem_Ch13 is
goto Continue;
end;
-- Invariant and Predicate aspects generate a corresponding
-- pragma with a first argument that is the entity, and the
-- second argument is the expression. This is inserted right
-- after the declaration, to get the required pragma placement.
-- The pragma processing takes care of the required delay.
-- Invariant aspects generate a corresponding pragma with a
-- first argument that is the entity, and the second argument
-- is the expression and anthird argument with an appropriate
-- message. This is inserted right after the declaration, to
-- get the required pragma placement. The pragma processing
-- takes care of the required delay.
when Aspect_Invariant |
Aspect_Predicate =>
when Aspect_Invariant =>
-- Construct the pragma
@ -1025,14 +1025,14 @@ package body Sem_Ch13 is
New_List (Ent, Relocate_Node (Expr)),
Class_Present => Class_Present (Aspect),
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Chars (Id)));
Make_Identifier (Sloc (Id), Name_Invariant));
-- Add message unless exception messages are suppressed
if not Opt.Exception_Locations_Suppressed then
Append_To (Pragma_Argument_Associations (Aitem),
Make_Pragma_Argument_Association (Eloc,
Chars => Name_Message,
Chars => Name_Message,
Expression =>
Make_String_Literal (Eloc,
Strval => "failed invariant from "
@ -1041,10 +1041,36 @@ package body Sem_Ch13 is
Set_From_Aspect_Specification (Aitem, True);
-- For Invariant and Predicate cases, insert immediately
-- after the entity declaration. We do not have to worry
-- about delay issues since the pragma processing takes
-- care of this.
-- For Invariant case, insert immediately after the entity
-- declaration. We do not have to worry about delay issues
-- since the pragma processing takes care of this.
Insert_After (N, Aitem);
goto Continue;
-- Predicate aspects generate a corresponding pragma with a
-- first argument that is the entity, and the second argument
-- is the expression. This is inserted immediately after the
-- declaration, to get the required pragma placement. The
-- pragma processing takes care of the required delay.
when Aspect_Predicate =>
-- Construct the pragma
Aitem :=
Make_Pragma (Loc,
Pragma_Argument_Associations =>
New_List (Ent, Relocate_Node (Expr)),
Class_Present => Class_Present (Aspect),
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Name_Predicate));
Set_From_Aspect_Specification (Aitem, True);
-- For Predicate case, insert immediately after the entity
-- declaration. We do not have to worry about delay issues
-- since the pragma processing takes care of this.
Insert_After (N, Aitem);
goto Continue;
@ -3730,6 +3756,291 @@ 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 --
-----------------------------------

20
gcc/ada/sem_ch13.ads
View File

@ -57,11 +57,25 @@ package Sem_Ch13 is
PDecl : out Node_Id;
PBody : out Node_Id);
-- If Typ has Invariants (indicated by Has_Invariants being set for Typ,
-- indicating the presence of Pragma Invariant entries on the rep chain,
-- indicating the presence of pragma Invariant entries on the rep chain,
-- note that Invariant aspects are converted to pragma Invariant), then
-- this procedure builds the spec and body for the corresponding Invariant
-- procedure, returning themn in PDecl and PBody. In some error situations
-- no procedure is built, in which case PDecl/PBody are empty on return.
-- procedure, returning themn in PDecl and PBody. Invariant_Procedure 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

60
gcc/ada/sem_ch3.adb
View File

@ -484,8 +484,8 @@ package body Sem_Ch3 is
-- operations of progenitors of Tagged_Type, and replace the subsidiary
-- subtypes with Tagged_Type, to build the specs of the inherited interface
-- primitives. The derived primitives are aliased to those of the
-- interface. This routine takes care also of transferring to the full-view
-- subprograms associated with the partial-view of Tagged_Type that cover
-- interface. This routine takes care also of transferring to the full view
-- subprograms associated with the partial view of Tagged_Type that cover
-- interface primitives.
procedure Derived_Standard_Character
@ -1359,6 +1359,12 @@ package body Sem_Ch3 is
pragma Assert (Is_Tagged_Type (Iface)
and then Is_Interface (Iface));
-- This is a reasonable place to propagate predicates
if Has_Predicates (Iface) then
Set_Has_Predicates (Typ);
end if;
Def :=
Make_Component_Definition (Loc,
Aliased_Present => True,
@ -2300,7 +2306,7 @@ package body Sem_Ch3 is
end if;
if Etype (T) = Any_Type then
goto Leave;
return;
end if;
-- Some common processing for all types
@ -2395,8 +2401,9 @@ package body Sem_Ch3 is
Set_Optimize_Alignment_Flags (Def_Id);
Check_Eliminated (Def_Id);
<<Leave>>
if Nkind (N) = N_Full_Type_Declaration then
Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N));
end if;
end Analyze_Full_Type_Declaration;
----------------------------------
@ -3835,6 +3842,7 @@ package body Sem_Ch3 is
Set_Is_Ada_2005_Only (Id, Is_Ada_2005_Only (T));
Set_Is_Ada_2012_Only (Id, Is_Ada_2012_Only (T));
Set_Convention (Id, Convention (T));
Set_Has_Predicates (Id, Has_Predicates (T));
-- In the case where there is no constraint given in the subtype
-- indication, Process_Subtype just returns the Subtype_Mark, so its
@ -7668,6 +7676,12 @@ package body Sem_Ch3 is
Set_Has_Invariants (Derived_Type);
end if;
-- We similarly inherit predicates
if Has_Predicates (Parent_Type) then
Set_Has_Predicates (Derived_Type);
end if;
-- The derived type inherits the representation clauses of the parent.
-- However, for a private type that is completed by a derivation, there
-- may be operation attributes that have been specified already (stream
@ -17186,6 +17200,44 @@ package body Sem_Ch3 is
-- Copy Invariant procedure to private declaration
Set_Invariant_Procedure (Priv_T, Invariant_Procedure (Full_T));
Set_Has_Invariants (Priv_T);
end if;
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.
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;
end if;

9
gcc/ada/sem_eval.adb
View File

@ -2282,6 +2282,15 @@ package body Sem_Eval is
return;
end if;
-- Ignore if types involved have predicates
if Present (Predicate_Function (Etype (Left)))
or else
Present (Predicate_Function (Etype (Right)))
then
return;
end if;
-- Case of right operand is a subtype name
if Is_Entity_Name (Right) then

15
gcc/ada/sem_prag.adb
View File

@ -11172,8 +11172,7 @@ package body Sem_Prag is
-- pragma Predicate
-- ([Entity =>] type_LOCAL_NAME,
-- [Check =>] EXPRESSION
-- [,[Message =>] String_Expression]);
-- [Check =>] EXPRESSION);
when Pragma_Predicate => Predicate : declare
Type_Id : Node_Id;
@ -11184,16 +11183,10 @@ package body Sem_Prag is
begin
GNAT_Pragma;
Check_At_Least_N_Arguments (2);
Check_At_Most_N_Arguments (3);
Check_Arg_Count (2);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Optional_Identifier (Arg2, Name_Check);
if Arg_Count = 3 then
Check_Optional_Identifier (Arg3, Name_Message);
Check_Arg_Is_Static_Expression (Arg3, Standard_String);
end if;
Check_Arg_Is_Local_Name (Arg1);
Type_Id := Get_Pragma_Arg (Arg1);
@ -11206,8 +11199,10 @@ package body Sem_Prag is
-- The remaining processing is simply to link the pragma on to
-- the rep item chain, for processing when the type is frozen.
-- This is accomplished by a call to Rep_Item_Too_Late.
-- This is accomplished by a call to Rep_Item_Too_Late. We also
-- mark the type as having predicates.
Set_Has_Predicates (Typ);
Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
end Predicate;