Commit 4818e7b9 by Robert Dewar Committed by Arnaud Charlet

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

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
parent fd0ff1cf
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.
Rework handling of invariants.
* exp_ch3.adb, exp_ch4.adb, exp_util.adb, sem_ch6.adb: Minor changes to
......
......@@ -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 --
......
......@@ -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 --
......
......@@ -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;
--------------------------------
......
......@@ -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 --
----------------------------
......
......@@ -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;
......
......@@ -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.
......
......@@ -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
......
......@@ -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;
......
......@@ -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
......
......@@ -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;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment