From: Robert Dewar Date: Thu, 21 Oct 2010 10:43:12 +0000 (+0000) Subject: einfo.ads, einfo.adb: Add handling of predicates. X-Git-Tag: upstream/12.2.0~89177 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=48f91b442f810e5bae8cd52bf2f84e9c0f43b948;p=platform%2Fupstream%2Fgcc.git einfo.ads, einfo.adb: Add handling of predicates. 2010-10-21 Robert Dewar * 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 * elists.adb: Minor reformatting. From-SVN: r165766 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 907bac8..52dc9f2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,27 @@ 2010-10-21 Robert Dewar + * checks.ads, checks.adb (Apply_Predicate_Check): New procedure + Minor code reorganization. + * einfo.adb (Has_Predicates): Fix assertion. + * exp_ch13.adb (Build_Predicate_Function): Move from Sem_Ch13 spec to + Exp_Ch13 body. + (Expand_N_Freeze_Entity): Call build predicate function. + * exp_ch4.adb (Expand_N_Type_Conversion): Add predicate check. + * exp_ch5.adb (Expand_N_Assignment_Statement): Add predicate check. + * exp_prag.adb (Expand_Pragma_Check): Use all lower case for name of + check. + * freeze.adb (Freeze_Entity): Move building of predicate function to + Exp_Ch13. + * sem_ch13.adb (Build_Predicate_Function): Move from Sem_Ch13 to + Exp_Ch13. + * sem_ch13.ads (Build_Predicate_Function): Move from Sem_Ch13 to + Exp_Ch13. + * sem_ch3.adb (Analyze_Declarations): Remove call to build predicate + function. + * sem_res.adb (Resolve_Actuals): Apply predicate check. + +2010-10-21 Robert Dewar + * einfo.ads, einfo.adb: Replace Predicate_Procedure by Predicate_Functions. * exp_ch4.adb (Expand_N_In): Handle predicates. diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 9873eee..0b783fa 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -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 -- ----------------------- diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 1acdab1..c544cfe 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -134,10 +134,10 @@ package Checks is (N : Node_Id; Typ : Entity_Id; No_Sliding : Boolean := False); - -- Top-level procedure, calls all the others depending on the class of Typ. - -- Checks that expression N satisfies the constraint of type Typ. - -- No_Sliding is only relevant for constrained array types, if set to True, - -- it checks that indexes are in range. + -- Top-level procedure, calls all the others depending on the class of + -- Typ. Checks that expression N satisfies the constraint of type Typ. + -- No_Sliding is only relevant for constrained array types, if set to + -- True, it checks that indexes are in range. procedure Apply_Discriminant_Check (N : Node_Id; @@ -153,6 +153,11 @@ package Checks is -- formals, the check is peformed only if the corresponding actual is -- constrained, i.e., whether Lhs'Constrained is True. + procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id); + -- N is an expression to which a predicate check may need to be applied + -- for Typ, if Typ has a predicate function. The check is applied only + -- if the type of N does not match Typ. + function Build_Discriminant_Checks (N : Node_Id; T_Typ : Entity_Id) diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index d8e2a7a..96f1e52 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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; diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 9cdef48..bee3325 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -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); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 7d914f5..613e9c8 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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 - <> - null; + <> + -- 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; ----------------------------------- diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 42fcf15..6694fdf 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -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: diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index cb896ec..1717ba7 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -294,7 +294,7 @@ package body Exp_Prag is -- where Str is the message if one is present, or the default of -- name failed at file:line if no message is given (the "name failed -- at" is omitted for name = Assertion, since it is redundant, given - -- that the name of the exception is Assert_Failure. + -- that the name of the exception is Assert_Failure.) -- An alternative expansion is used when the No_Exception_Propagation -- restriction is active and there is a local Assert_Failure handler. @@ -353,22 +353,18 @@ package body Exp_Prag is Msg_Loc : constant String := Build_Location_String (Loc); begin + Name_Len := 0; + -- For Assert, we just use the location if Nam = Name_Assertion then - Name_Len := 0; + null; - -- For any check except Precondition/Postcondition, the - -- string is "xxx failed at yyy" where xxx is the name of - -- the check with current source file casing. + -- For predicate, we generate the string "predicate failed + -- at yyy". We prefer all lower case for predicate. - elsif Nam /= Name_Precondition - and then - Nam /= Name_Postcondition - then - Get_Name_String (Nam); - Set_Casing (Identifier_Casing (Current_Source_File)); - Add_Str_To_Name_Buffer (" failed at "); + elsif Nam = Name_Predicate then + Add_Str_To_Name_Buffer ("predicate failed at "); -- For special case of Precondition/Postcondition the string is -- "failed xx from yy" where xx is precondition/postcondition @@ -376,10 +372,21 @@ package body Exp_Prag is -- that the failure is not at the point of occurrence of the -- pragma, unlike the other Check cases. - else + elsif Nam = Name_Precondition + or else + Nam = Name_Postcondition + then Get_Name_String (Nam); Insert_Str_In_Name_Buffer ("failed ", 1); Add_Str_To_Name_Buffer (" from "); + + -- For all other checks, the string is "xxx failed at yyy" + -- where xxx is the check name with current source file casing. + + else + Get_Name_String (Nam); + Set_Casing (Identifier_Casing (Current_Source_File)); + Add_Str_To_Name_Buffer (" failed at "); end if; -- In all cases, add location string diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index cfe3227..5bbcab0 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 3914337..b1f619c 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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 -- ----------------------------------- diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 46d6cb8..8d0245d 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -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 diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index e13e5c8..f453bcc 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index b30f46f..03c8171 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -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);