From b554177a8f33e3cfaf29125a1c22a9671fbf2c3a Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 14:07:59 +0200 Subject: [PATCH] [multiple changes] 2017-04-25 Justin Squirek * exp_ch3.adb (Freeze_Type): Add condition to always treat interface types as a partial view of a private type for the generation of invariant procedure bodies. * exp_util.adb, exp_util.ads (Add_Inherited_Invariants): Add a condition to get the Corresponding_Record_Type for concurrent types, add condition to return in the absence of a class in the pragma, remove call to Replace_Type_References, and add call to Replace_References. (Add_Interface_Invariatns), (Add_Parent_Invariants): Modify call to Add_Inherited_Invariants to including the working type T. (Add_Own_Invariants): Remove legacy condition for separate units, remove dispatching for ASIS and save a copy of the expression in the pragma expression. (Build_Invariant_Procedure_Body): Default initalize vars, remove return condition on interfaces, always use the private type for interfaces, and move the processing of types until after the processing of invariants for the full view. (Build_Invariant_Procedure_Declaration): Remove condition to return if an interface type is encountered and add condition to convert the formal parameter to its class-wide counterpart if Work_Typ is abstract. (Replace_Type): Add call to Remove_Controlling_Arguments. (Replace_Type_Ref): Remove class-wide dispatching for the current instance of the type. (Replace_Type_References): Remove parameter "Derived" (Remove_Controlling_Arguments): Created in order to removing the controlliong argument from calls to primitives in the case of the formal parameter being an class-wide abstract type. * sem_ch3.adb (Build_Assertion_Bodies_For_Type): Almost identical to the change made to Freeze_Type in exp_ch3. Add a condition to treat interface types as a partial view. * sem_prag.adb (Analyze_Pragma): Modify parameters in the call to Build_Invariant_Procedure_Declaration to properly generate a "partial" invariant procedure when Typ is an interface. 2017-04-25 Bob Duff * a-numeri.ads: Go back to using brackets encoding for the Greek letter pi. From-SVN: r247204 --- gcc/ada/ChangeLog | 43 +++++ gcc/ada/a-numeri.ads | 8 +- gcc/ada/exp_ch3.adb | 17 +- gcc/ada/exp_util.adb | 445 +++++++++++++++++++++++++------------------ gcc/ada/exp_util.ads | 7 +- gcc/ada/sem_ch3.adb | 29 ++- gcc/ada/sem_prag.adb | 12 +- 7 files changed, 357 insertions(+), 204 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e1cc3fc8ceb..93ace03de42 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,46 @@ +2017-04-25 Justin Squirek + + * exp_ch3.adb (Freeze_Type): Add condition to always treat + interface types as a partial view of a private type for the + generation of invariant procedure bodies. + * exp_util.adb, exp_util.ads (Add_Inherited_Invariants): + Add a condition to get the Corresponding_Record_Type for + concurrent types, add condition to return in the absence of a + class in the pragma, remove call to Replace_Type_References, + and add call to Replace_References. + (Add_Interface_Invariatns), + (Add_Parent_Invariants): Modify call to Add_Inherited_Invariants + to including the working type T. + (Add_Own_Invariants): Remove + legacy condition for separate units, remove dispatching for ASIS + and save a copy of the expression in the pragma expression. + (Build_Invariant_Procedure_Body): Default initalize vars, + remove return condition on interfaces, always use the + private type for interfaces, and move the processing of types + until after the processing of invariants for the full view. + (Build_Invariant_Procedure_Declaration): Remove condition + to return if an interface type is encountered and add + condition to convert the formal parameter to its class-wide + counterpart if Work_Typ is abstract. + (Replace_Type): Add call to Remove_Controlling_Arguments. + (Replace_Type_Ref): Remove class-wide dispatching for the current + instance of the type. + (Replace_Type_References): Remove parameter "Derived" + (Remove_Controlling_Arguments): Created in order to removing + the controlliong argument from calls to primitives in the case + of the formal parameter being an class-wide abstract type. + * sem_ch3.adb (Build_Assertion_Bodies_For_Type): Almost identical + to the change made to Freeze_Type in exp_ch3. Add a condition + to treat interface types as a partial view. + * sem_prag.adb (Analyze_Pragma): Modify parameters in the call + to Build_Invariant_Procedure_Declaration to properly generate a + "partial" invariant procedure when Typ is an interface. + +2017-04-25 Bob Duff + + * a-numeri.ads: Go back to using brackets encoding for the Greek + letter pi. + 2017-04-25 Ed Schonberg * sem_ch3.adb (Derive_Subprogram): Implement rule in RM 6.1.1 diff --git a/gcc/ada/a-numeri.ads b/gcc/ada/a-numeri.ads index c4f4f848b55..805fa5670ba 100644 --- a/gcc/ada/a-numeri.ads +++ b/gcc/ada/a-numeri.ads @@ -18,20 +18,14 @@ package Ada.Numerics is Argument_Error : exception; - pragma Wide_Character_Encoding (UTF8); - -- For the Greek letter Pi below. Note that this pragma cannot immediately - -- precede that character, because then the encoding gets set too late. - Pi : constant := 3.14159_26535_89793_23846_26433_83279_50288_41971_69399_37511; - π : constant := Pi; + ["03C0"] : constant := Pi; -- This is the Greek letter Pi (for Ada 2005 AI-388). Note that it is -- conforming to have this constant present even in Ada 95 mode, as there -- is no way for a normal mode Ada 95 program to reference this identifier. - pragma Wide_Character_Encoding (BRACKETS); - e : constant := 2.71828_18284_59045_23536_02874_71352_66249_77572_47093_69996; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 63a1e601def..b67ee2d4254 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -7529,7 +7529,22 @@ package body Exp_Ch3 is -- class-wide invariants from parent types or interfaces, and invariants -- on array elements or record components. - if Has_Invariants (Def_Id) then + if Is_Interface (Def_Id) then + + -- Interfaces are treated as the partial view of a private type in + -- order to achieve uniformity with the general case. As a result, an + -- interface receives only a "partial" invariant procedure which is + -- never called. + + if Has_Own_Invariants (Def_Id) then + Build_Invariant_Procedure_Body + (Typ => Def_Id, + Partial_Invariant => Is_Interface (Def_Id)); + end if; + + -- Non-interface types + + elsif Has_Invariants (Def_Id) then Build_Invariant_Procedure_Body (Def_Id); end if; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index db6a8582adb..3a79f61444c 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1989,7 +1989,7 @@ package body Exp_Util is -- NOTE: all Add_xxx_Invariants routines are reactive. In other words -- they emit checks, loops (for arrays) and case statements (for record -- variant parts) only when there are invariants to verify. This keeps - -- the body of the invariant procedure free from useless code. + -- the body of the invariant procedure free of useless code. procedure Add_Array_Component_Invariants (T : Entity_Id; @@ -2000,14 +2000,16 @@ package body Exp_Util is -- invariant procedure. All created checks are added to list Checks. procedure Add_Inherited_Invariants - (Full_Typ : Entity_Id; - Priv_Typ : Entity_Id; - Obj_Id : Entity_Id; - Checks : in out List_Id); + (T : Entity_Id; + Priv_Typ : Entity_Id; + Full_Typ : Entity_Id; + Obj_Id : Entity_Id; + Checks : in out List_Id); -- Generate an invariant check for each inherited class-wide invariant - -- coming from all parent types of type T. Obj_Id denotes the entity of - -- the _object formal parameter of the invariant procedure. All created - -- checks are added to list Checks. + -- coming from all parent types of type T. Priv_Typ and Full_Typ denote + -- the partial and full view of the parent type. Obj_Id denotes the + -- entity of the _object formal parameter of the invariant procedure. + -- All created checks are added to list Checks. procedure Add_Interface_Invariants (T : Entity_Id; @@ -2196,7 +2198,6 @@ package body Exp_Util is Attribute_Name => Name_Range, Expressions => New_List ( Make_Integer_Literal (Loc, Dim))))), - Statements => Comp_Checks)); end if; end if; @@ -2216,25 +2217,36 @@ package body Exp_Util is ------------------------------ procedure Add_Inherited_Invariants - (Full_Typ : Entity_Id; - Priv_Typ : Entity_Id; - Obj_Id : Entity_Id; - Checks : in out List_Id) + (T : Entity_Id; + Priv_Typ : Entity_Id; + Full_Typ : Entity_Id; + Obj_Id : Entity_Id; + Checks : in out List_Id) is - Arg1 : Node_Id; - Arg2 : Node_Id; - Expr : Node_Id; - Prag : Node_Id; + Deriv_Typ : Entity_Id; + Expr : Node_Id; + Prag : Node_Id; + Prag_Expr : Node_Id; + Prag_Expr_Arg : Node_Id; + Prag_Typ : Node_Id; + Prag_Typ_Arg : Node_Id; + + Par_Proc : Entity_Id; + -- The "partial" invariant procedure of Par_Typ - Rep_Typ : Entity_Id; - -- The replacement type used in the substitution of the current - -- instance of a type with the _object formal parameter + Par_Typ : Entity_Id; + -- The suitable view of the parent type used in the substitution of + -- type attributes. begin if not Present (Priv_Typ) and then not Present (Full_Typ) then return; end if; + -- Determine which rep item chain to use. Precedence is given to that + -- of the parent type's partial view since it usually carries all the + -- class-wide invariants. + if Present (Priv_Typ) then Prag := First_Rep_Item (Priv_Typ); else @@ -2249,49 +2261,89 @@ package body Exp_Util is if Contains (Pragmas_Seen, Prag) then return; + + -- Nothing to do when the caller requests the processing of all + -- inherited class-wide invariants, but the pragma does not + -- fall in this category. + + elsif not Class_Present (Prag) then + return; end if; -- Extract the arguments of the invariant pragma - Arg1 := First (Pragma_Argument_Associations (Prag)); - Arg2 := Get_Pragma_Arg (Next (Arg1)); - Arg1 := Get_Pragma_Arg (Arg1); + Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag)); + Prag_Expr_Arg := Next (Prag_Typ_Arg); + Prag_Expr := Expression_Copy (Prag_Expr_Arg); + Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg); - -- The pragma applies to the partial view + -- The pragma applies to the partial view of the parent type - if Present (Priv_Typ) and then Entity (Arg1) = Priv_Typ then - Rep_Typ := Priv_Typ; + if Present (Priv_Typ) + and then Entity (Prag_Typ) = Priv_Typ + then + Par_Typ := Priv_Typ; - -- The pragma applies to the full view + -- The pragma applies to the full view of the parent type - elsif Present (Full_Typ) and then Entity (Arg1) = Full_Typ then - Rep_Typ := Full_Typ; + elsif Present (Full_Typ) + and then Entity (Prag_Typ) = Full_Typ + then + Par_Typ := Full_Typ; - -- Otherwise the pragma applies to a parent type and will be - -- processed at a later step by routine Add_Parent_Invariants - -- or Add_Interface_Invariants. + -- Otherwise the pragma does not belong to the parent type and + -- should not be considered. else return; end if; - -- Nothing to do when the caller requests the processing of all - -- inherited class-wide invariants, but the pragma does not - -- fall in this category. + -- Perform the following substitutions: - if not Class_Present (Prag) then - return; + -- * Replace a reference to the _object parameter of the + -- parent type's partial invariant procedure with a + -- reference to the _object parameter of the derived + -- type's full invariant procedure. + + -- * Replace a reference to a discriminant of the parent type + -- with a suitable value from the point of view of the + -- derived type. + + -- * Replace a call to an overridden parent primitive with a + -- call to the overriding derived type primitive. + + -- * Replace a call to an inherited parent primitive with a + -- call to the internally-generated inherited derived type + -- primitive. + + Expr := New_Copy_Tree (Prag_Expr); + + -- When the type inheriting the class-wide invariant is a task + -- or protected type, use the corresponding record type because + -- it contains all primitive operations of the concurren type + -- and allows for proper substitution. + + if Is_Concurrent_Type (T) then + Deriv_Typ := Corresponding_Record_Type (T); + else + Deriv_Typ := T; end if; - Expr := New_Copy_Tree (Arg2); + pragma Assert (Present (Deriv_Typ)); - -- Substitute all references to type T with references to the - -- _object formal parameter. + -- The parent type must have a "partial" invariant procedure + -- because class-wide invariants are captured exclusively by + -- it. - -- ??? Dispatching must be removed due to AI12-0150-1 + Par_Proc := Partial_Invariant_Procedure (Par_Typ); + pragma Assert (Present (Par_Proc)); - Replace_Type_References - (Expr, Rep_Typ, Obj_Id, Dispatch => Class_Present (Prag)); + Replace_References + (Expr => Expr, + Par_Typ => Par_Typ, + Deriv_Typ => Deriv_Typ, + Par_Obj => First_Formal (Par_Proc), + Deriv_Obj => Obj_Id); Add_Invariant_Check (Prag, Expr, Checks, Inherited => True); end if; @@ -2323,11 +2375,17 @@ package body Exp_Util is Iface_Elmt := First_Elmt (Ifaces); while Present (Iface_Elmt) loop + + -- The Full_Typ parameter is intentionally left Empty because + -- interfaces are treated as the partial view of a private type + -- in order to achieve uniformity with the general case. + Add_Inherited_Invariants - (Full_Typ => Node (Iface_Elmt), - Priv_Typ => Empty, - Obj_Id => Obj_Id, - Checks => Checks); + (T => T, + Priv_Typ => Node (Iface_Elmt), + Full_Typ => Empty, + Obj_Id => Obj_Id, + Checks => Checks); Next_Elmt (Iface_Elmt); end loop; @@ -2358,7 +2416,7 @@ package body Exp_Util is if Is_Ignored (Prag) then null; - -- Otherwise the invariant is checked. Build a Check pragma to verify + -- Otherwise the invariant is checked. Build a pragma Check to verify -- the expression at runtime. else @@ -2479,10 +2537,11 @@ package body Exp_Util is end if; Add_Inherited_Invariants - (Full_Typ => Full_Typ, - Priv_Typ => Priv_Typ, - Obj_Id => Obj_Id, - Checks => Checks); + (T => T, + Priv_Typ => Priv_Typ, + Full_Typ => Full_Typ, + Obj_Id => Obj_Id, + Checks => Checks); Curr_Typ := Par_Typ; end loop; @@ -2498,13 +2557,14 @@ package body Exp_Util is Checks : in out List_Id; Priv_Item : Node_Id := Empty) is - Arg1 : Node_Id; - Arg2 : Node_Id; - ASIS_Expr : Node_Id; - Asp : Node_Id; - Expr : Node_Id; - Ploc : Source_Ptr; - Prag : Node_Id; + ASIS_Expr : Node_Id; + Expr : Node_Id; + Prag : Node_Id; + Prag_Asp : Node_Id; + Prag_Expr : Node_Id; + Prag_Expr_Arg : Node_Id; + Prag_Typ : Node_Id; + Prag_Typ_Arg : Node_Id; begin if not Present (T) then @@ -2531,49 +2591,49 @@ package body Exp_Util is -- Extract the arguments of the invariant pragma - Arg1 := First (Pragma_Argument_Associations (Prag)); - Arg2 := Get_Pragma_Arg (Next (Arg1)); - Arg1 := Get_Pragma_Arg (Arg1); - Asp := Corresponding_Aspect (Prag); - Ploc := Sloc (Prag); + Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag)); + Prag_Expr_Arg := Next (Prag_Typ_Arg); + Prag_Expr := Get_Pragma_Arg (Prag_Expr_Arg); + Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg); + Prag_Asp := Corresponding_Aspect (Prag); -- Verify the pragma belongs to T, otherwise the pragma applies -- to a parent type in which case it will be processed later by -- Add_Parent_Invariants or Add_Interface_Invariants. - if Entity (Arg1) /= T then + if Entity (Prag_Typ) /= T then return; end if; - Expr := New_Copy_Tree (Arg2); + Expr := New_Copy_Tree (Prag_Expr); -- Substitute all references to type T with references to the -- _object formal parameter. - Replace_Type_References - (Expr => Expr, - Typ => T, - Obj_Id => Obj_Id, - Dispatch => Class_Present (Prag)); + Replace_Type_References (Expr, T, Obj_Id); -- Preanalyze the invariant expression to detect errors and at -- the same time capture the visibility of the proper package -- part. - -- Historical note: the old implementation of invariants used - -- node N as the parent, but a package specification as parent - -- of an expression is bizarre. - - Set_Parent (Expr, Parent (Arg2)); + Set_Parent (Expr, Parent (Prag_Expr)); Preanalyze_Assert_Expression (Expr, Any_Boolean); + -- Save a copy of the expression when T is tagged to detect + -- errors and capture the visibility of the proper package part + -- for the generation of inherited type invariants. + + if Is_Tagged_Type (T) then + Set_Expression_Copy (Prag_Expr_Arg, New_Copy_Tree (Expr)); + end if; + -- If the pragma comes from an aspect specification, replace -- the saved expression because all type references must be -- substituted for the call to Preanalyze_Spec_Expression in -- Check_Aspect_At_xxx routines. - if Present (Asp) then - Set_Entity (Identifier (Asp), New_Copy_Tree (Expr)); + if Present (Prag_Asp) then + Set_Entity (Identifier (Prag_Asp), New_Copy_Tree (Expr)); end if; -- Analyze the original invariant expression for ASIS @@ -2582,43 +2642,17 @@ package body Exp_Util is ASIS_Expr := Empty; if Comes_From_Source (Prag) then - ASIS_Expr := Arg2; - elsif Present (Asp) then - ASIS_Expr := Expression (Asp); + ASIS_Expr := Prag_Expr; + elsif Present (Prag_Asp) then + ASIS_Expr := Expression (Prag_Asp); end if; if Present (ASIS_Expr) then - Replace_Type_References - (Expr => ASIS_Expr, - Typ => T, - Obj_Id => Obj_Id, - Dispatch => Class_Present (Prag)); - + Replace_Type_References (ASIS_Expr, T, Obj_Id); Preanalyze_Assert_Expression (ASIS_Expr, Any_Boolean); end if; end if; - -- A class-wide invariant may be inherited in a separate unit, - -- where the corresponding expression cannot be resolved by - -- visibility, because it refers to a local function. Propagate - -- semantic information to the original representation item, to - -- be used when an invariant procedure for a derived type is - -- constructed. - - -- ??? Unclear how to handle class-wide invariants that are not - -- function calls. - - if Class_Present (Prag) - and then Nkind (Expr) = N_Function_Call - and then Nkind (Arg2) = N_Indexed_Component - then - Rewrite (Arg2, - Make_Function_Call (Ploc, - Name => - New_Occurrence_Of (Entity (Name (Expr)), Ploc), - Parameter_Associations => Expressions (Arg2))); - end if; - Add_Invariant_Check (Prag, Expr, Checks); end if; @@ -2863,25 +2897,25 @@ package body Exp_Util is Proc_Id : Entity_Id; Stmts : List_Id := No_List; - CRec_Typ : Entity_Id; + CRec_Typ : Entity_Id := Empty; -- The corresponding record type of Full_Typ - Full_Proc : Entity_Id; + Full_Proc : Entity_Id := Empty; -- The entity of the "full" invariant procedure - Full_Typ : Entity_Id; + Full_Typ : Entity_Id := Empty; -- The full view of the working type - Obj_Id : Entity_Id; + Obj_Id : Entity_Id := Empty; -- The _object formal parameter of the invariant procedure - Part_Proc : Entity_Id; + Part_Proc : Entity_Id := Empty; -- The entity of the "partial" invariant procedure - Priv_Typ : Entity_Id; + Priv_Typ : Entity_Id := Empty; -- The partial view of the working type - Work_Typ : Entity_Id; + Work_Typ : Entity_Id := Empty; -- The working type -- Start of processing for Build_Invariant_Procedure_Body @@ -2917,16 +2951,17 @@ package body Exp_Util is pragma Assert (Has_Invariants (Work_Typ)); - -- Nothing to do for interface types as their class-wide invariants are - -- inherited by implementing types. + -- Interfaces are treated as the partial view of a private type in order + -- to achieve uniformity with the general case. if Is_Interface (Work_Typ) then - goto Leave; - end if; + Priv_Typ := Work_Typ; - -- Obtain both views of the type + -- Otherwise obtain both views of the type - Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy, CRec_Typ); + else + Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy, CRec_Typ); + end if; -- The caller requests a body for the partial invariant procedure @@ -2990,10 +3025,10 @@ package body Exp_Util is goto Leave; end if; - -- Emulate the environment of the invariant procedure by installing - -- its scope and formal parameters. Note that this is not needed, but - -- having the scope of the invariant procedure installed helps with - -- the detection of invariant-related errors. + -- Emulate the environment of the invariant procedure by installing its + -- scope and formal parameters. Note that this is not needed, but having + -- the scope installed helps with the detection of invariant-related + -- errors. Push_Scope (Proc_Id); Install_Formals (Proc_Id); @@ -3084,17 +3119,6 @@ package body Exp_Util is end if; end if; - -- Process the elements of an array type - - if Is_Array_Type (Full_Typ) then - Add_Array_Component_Invariants (Full_Typ, Obj_Id, Stmts); - - -- Process the components of a record type - - elsif Ekind (Full_Typ) = E_Record_Type then - Add_Record_Component_Invariants (Full_Typ, Obj_Id, Stmts); - end if; - -- Process the invariants of the full view and in certain cases those -- of the partial view. This also handles any invariants on array or -- record components. @@ -3111,7 +3135,19 @@ package body Exp_Util is Checks => Stmts, Priv_Item => Priv_Item); - if Present (CRec_Typ) then + -- Process the elements of an array type + + if Is_Array_Type (Full_Typ) then + Add_Array_Component_Invariants (Full_Typ, Obj_Id, Stmts); + + -- Process the components of a record type + + elsif Ekind (Full_Typ) = E_Record_Type then + Add_Record_Component_Invariants (Full_Typ, Obj_Id, Stmts); + + -- Process the components of a corresponding record + + elsif Present (CRec_Typ) then Add_Record_Component_Invariants (CRec_Typ, Obj_Id, Stmts); end if; @@ -3144,7 +3180,7 @@ package body Exp_Util is end if; -- Generate: - -- procedure [Partial_]Invariant (_object : ) is + -- procedure [Partial_]Invariant (_object : ) is -- begin -- -- end [Partial_]Invariant; @@ -3226,6 +3262,9 @@ package body Exp_Util is Obj_Id : Entity_Id; -- The _object formal parameter of the invariant procedure + Obj_Typ : Entity_Id; + -- The type of the _object formal parameter + Priv_Typ : Entity_Id; -- The partial view of working type @@ -3263,15 +3302,9 @@ package body Exp_Util is pragma Assert (Has_Invariants (Work_Typ)); - -- Nothing to do for interface types as their class-wide invariants are - -- inherited by implementing types. - - if Is_Interface (Work_Typ) then - goto Leave; - -- Nothing to do if the type already has a "partial" invariant procedure - elsif Partial_Invariant then + if Partial_Invariant then if Present (Partial_Invariant_Procedure (Work_Typ)) then goto Leave; end if; @@ -3352,16 +3385,41 @@ package body Exp_Util is Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject); + -- When generating an invariant procedure declaration for an abstract + -- type (including interfaces), use the class-wide type as the _object + -- type. This has several desirable effects: + + -- * The invariant procedure does not become a primitive of the type. + -- This eliminates the need to either special case the treatment of + -- invariant procedures, or to make it a predefined primitive and + -- force every derived type to potentially provide an empty body. + + -- * The invariant procedure does not need to be declared as abstract. + -- This allows for a proper body which in turn avoids redundant + -- processing of the same invariants for types with multiple views. + + -- * The class-wide type allows for calls to abstract primitives + -- within a non-abstract subprogram. The calls are treated as + -- dispatching and require additional processing when they are + -- remapped to call primitives of derived types. See routine + -- Replace_References for details. + + if Is_Abstract_Type (Work_Typ) then + Obj_Typ := Class_Wide_Type (Work_Typ); + else + Obj_Typ := Work_Typ; + end if; + -- Perform minor decoration in case the declaration is not analyzed Set_Ekind (Obj_Id, E_In_Parameter); - Set_Etype (Obj_Id, Work_Typ); + Set_Etype (Obj_Id, Obj_Typ); Set_Scope (Obj_Id, Proc_Id); Set_First_Entity (Proc_Id, Obj_Id); -- Generate: - -- procedure [Partial_]Invariant (_object : ); + -- procedure [Partial_]Invariant (_object : ); Proc_Decl := Make_Subprogram_Declaration (Loc, @@ -3371,8 +3429,7 @@ package body Exp_Util is Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Obj_Id, - Parameter_Type => - New_Occurrence_Of (Work_Typ, Loc))))); + Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc))))); -- The declaration should not be inserted into the tree when the context -- is ASIS or a generic unit because it is not part of the template. @@ -11448,6 +11505,37 @@ package body Exp_Util is ----------------- function Replace_Ref (Ref : Node_Id) return Traverse_Result is + procedure Remove_Controlling_Arguments (From_Arg : Node_Id); + -- Reset the Controlling_Argument of all function calls which + -- encapsulate node From_Arg. + + ---------------------------------- + -- Remove_Controlling_Arguments -- + ---------------------------------- + + procedure Remove_Controlling_Arguments (From_Arg : Node_Id) is + Par : Node_Id; + + begin + Par := From_Arg; + while Present (Par) loop + if Nkind (Par) = N_Function_Call + and then Present (Controlling_Argument (Par)) + then + Set_Controlling_Argument (Par, Empty); + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Par) then + exit; + end if; + + Par := Parent (Par); + end loop; + end Remove_Controlling_Arguments; + + -- Local variables + Context : constant Node_Id := Parent (Ref); Loc : constant Source_Ptr := Sloc (Ref); Ref_Id : Entity_Id; @@ -11463,6 +11551,8 @@ package body Exp_Util is Val : Node_Or_Entity_Id; -- The corresponding value of Ref from the type map + -- Start of processing for Replace_Ref + begin -- Assume that the input reference is to be replaced and that the -- traversal should examine the children of the reference. @@ -11529,7 +11619,7 @@ package body Exp_Util is end if; -- The reference mentions the _object parameter of the parent - -- type's DIC procedure. Replace as follows: + -- type's DIC or type invariant procedure. Replace as follows: -- _object -> _object @@ -11539,6 +11629,23 @@ package body Exp_Util is then New_Ref := New_Occurrence_Of (Deriv_Obj, Loc); + -- The type of the _object parameter is class-wide when the + -- expression comes from an assertion pragma which applies to + -- an abstract parent type or an interface. The class-wide type + -- facilitates the preanalysis of the expression by treating + -- calls to abstract primitives which mention the current + -- instance of the type as dispatching. Once the calls are + -- remapped to invoke overriding or inherited primitives, the + -- calls no longer need to be dispatching. Examine all function + -- calls which encapsule the _object parameter and reset their + -- Controlling_Argument attribute. + + if Is_Class_Wide_Type (Etype (Par_Obj)) + and then Is_Abstract_Type (Root_Type (Etype (Par_Obj))) + then + Remove_Controlling_Arguments (Old_Ref); + end if; + -- The reference to _object acts as an actual parameter in a -- subprogram call which may be invoking a primitive of the -- parent type: @@ -11659,10 +11766,9 @@ package body Exp_Util is ----------------------------- procedure Replace_Type_References - (Expr : Node_Id; - Typ : Entity_Id; - Obj_Id : Entity_Id; - Dispatch : Boolean := False) + (Expr : Node_Id; + Typ : Entity_Id; + Obj_Id : Entity_Id) is procedure Replace_Type_Ref (N : Node_Id); -- Substitute a single reference of the current instance of type Typ @@ -11673,9 +11779,6 @@ package body Exp_Util is ---------------------- procedure Replace_Type_Ref (N : Node_Id) is - Nloc : constant Source_Ptr := Sloc (N); - Ref : Node_Id; - begin -- Decorate the reference to Typ even though it may be rewritten -- further down. This is done for two reasons: @@ -11698,33 +11801,9 @@ package body Exp_Util is -- Perform the following substitution: - -- Typ -> _object - - Ref := Make_Identifier (Sloc (N), Chars (Obj_Id)); - Set_Entity (Ref, Obj_Id); - Set_Etype (Ref, Typ); - - -- When the pragma denotes a class-wide and the Dispatch flag is set - -- perform the following substitution. Note: dispatching in this - -- fashion is illegal Ada according to AI12-0150-1 because class-wide - -- aspects like type invariants and default initial conditions be - -- evaluated statically. Currently it is used only for class-wide - -- type invariants, but this will be fixed. - - -- Rep_Typ --> Rep_Typ'Class (_object) - - if Dispatch then - Ref := - Make_Type_Conversion (Nloc, - Subtype_Mark => - Make_Attribute_Reference (Nloc, - Prefix => - New_Occurrence_Of (Typ, Nloc), - Attribute_Name => Name_Class), - Expression => Ref); - end if; + -- Typ --> _object - Rewrite (N, Ref); + Rewrite (N, New_Occurrence_Of (Obj_Id, Sloc (N))); Set_Comes_From_Source (N, True); end Replace_Type_Ref; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index ee12a240d41..5b44d6929a2 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -1062,10 +1062,9 @@ package Exp_Util is -- the internally-generated inherited primitive of Deriv_Typ. procedure Replace_Type_References - (Expr : Node_Id; - Typ : Entity_Id; - Obj_Id : Entity_Id; - Dispatch : Boolean := False); + (Expr : Node_Id; + Typ : Entity_Id; + Obj_Id : Entity_Id); -- Substitute all references of the current instance of type Typ with -- references to formal parameter Obj_Id within expression Expr. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 38c6b20108a..f40d142ec74 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2279,12 +2279,32 @@ package body Sem_Ch3 is if Nkind (Context) = N_Package_Specification then + -- Preanalyze and resolve the class-wide invariants of an + -- interface at the end of whichever declarative part has the + -- interface type. Note that an interface may be declared in + -- any non-package declarative part, but reaching the end of + -- such a declarative part will always freeze the type and + -- generate the invariant procedure (see Freeze_Type). + + if Is_Interface (Typ) then + + -- Interfaces are treated as the partial view of a private + -- type in order to achieve uniformity with the general + -- case. As a result, an interface receives only a "partial" + -- invariant procedure which is never called. + + if Has_Own_Invariants (Typ) then + Build_Invariant_Procedure_Body + (Typ => Typ, + Partial_Invariant => True); + end if; + -- Preanalyze and resolve the invariants of a private type -- at the end of the visible declarations to catch potential -- errors. Inherited class-wide invariants are not included -- because they have already been resolved. - if Decls = Visible_Declarations (Context) + elsif Decls = Visible_Declarations (Context) and then Ekind_In (Typ, E_Limited_Private_Type, E_Private_Type, E_Record_Type_With_Private) @@ -15315,10 +15335,9 @@ package body Sem_Ch3 is New_Overloaded_Entity (New_Subp, Derived_Type); - -- Implement rule in 6.1.1 (15) : if subprogram inherits non-conforming - -- classwide preconditions and the derived type is abstract, the - -- derived operation is abstract as well if parent subprogram is not - -- abstract or null. + -- Ada RM 6.1.1 (15): If a subprogram inherits non-conforming class-wide + -- preconditions and the derived type is abstract, the derived operation + -- is abstract as well if parent subprogram is not abstract or null. if Is_Abstract_Type (Derived_Type) and then Has_Non_Trivial_Precondition (Parent_Subp) diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 079e52a1db5..d67beeb0b10 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -17113,10 +17113,14 @@ package body Sem_Prag is Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); -- Create the declaration of the invariant procedure which will - -- verify the invariant at run-time. Note that interfaces do not - -- carry such a declaration. - - Build_Invariant_Procedure_Declaration (Typ); + -- verify the invariant at run-time. Interfaces are treated as the + -- partial view of a private type in order to achieve uniformity + -- with the general case. As a result, an interface receives only + -- a "partial" invariant procedure which is never called. + + Build_Invariant_Procedure_Declaration + (Typ => Typ, + Partial_Invariant => Is_Interface (Typ)); end Invariant; ---------------- -- 2.30.2