===================================================================
@@ -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:
===================================================================
@@ -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.
-
- 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 ");
+ -- For predicate, we generate the string "predicate failed
+ -- at yyy". We prefer all lower case for predicate.
+
+ 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
===================================================================
@@ -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;
===================================================================
@@ -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;
===================================================================
@@ -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;
+
+ -- Apply required constaint checks
- elsif Is_Scalar_Type (Typ) then
+ if Is_Scalar_Type (Typ) then
Apply_Scalar_Range_Check (N, Typ);
elsif Is_Array_Type (Typ) then
@@ -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 --
-----------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- 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)
===================================================================
@@ -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.
===================================================================
@@ -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);
===================================================================
@@ -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;
-----------------------------------
===================================================================
@@ -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);
===================================================================
@@ -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 --
-----------------------------------
===================================================================
@@ -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
This patch is the next step in implementation of predicates, and finally things are starting to work, although there is more to be done. The following test compiled with -gnata12 executes with no output showing predicates working for membership tests, and being properly tested for assignments and subprogram calls. 1. with Ada.Assertions; use Ada.Assertions; 2. procedure Simple_Test_Predicates is 3. 4. type Color is (Red, Orange, Yellow, Green, Blue, Indigo, Violet); 5. subtype RGB is Color with 6. Predicate => RGB = Red or RGB in Green .. Blue; 7. 8. Var : RGB := Red; 9. 10. procedure P (X : RGB) is 11. begin 12. null; 13. end P; 14. 15. begin 16. pragma Assert (Red in RGB); 17. pragma Assert (Blue in RGB); 18. pragma Assert (Orange not in RGB); 19. 20. pragma Assert (Red in RGB'Base); 21. pragma Assert (Blue in RGB'Base); 22. pragma Assert (Orange in RGB'Base); 23. 24. begin 25. Var := Yellow; 26. raise Program_Error; 27. exception 28. when Assertion_Error => 29. null; -- OK 30. end; 31. 32. begin 33. P(Yellow); 34. raise Program_Error; 35. exception 36. when Assertion_Error => 37. null; -- OK 38. end; 39. end Simple_Test_Predicates; Tested on x86_64-pc-linux-gnu, committed on trunk 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.