===================================================================
@@ -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;
===================================================================
@@ -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;
===================================================================
@@ -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 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_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 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_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 --
===================================================================
@@ -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;
===================================================================
@@ -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.
===================================================================
@@ -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;
--------------------------------
===================================================================
@@ -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
===================================================================
@@ -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 --
-----------------------------------
===================================================================
@@ -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