From 024d33d837c172088236be33fd52b7a6ac8e4e9d Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Mon, 2 Mar 2015 11:11:01 +0000 Subject: [PATCH] exp_ch9.adb (Build_Corresponding_Record): Propagate type invariants to the corresponding record type. 2015-03-02 Javier Miranda * exp_ch9.adb (Build_Corresponding_Record): Propagate type invariants to the corresponding record type. * exp_disp.ad[sb] (Set_DT_Position_Value): New subprogram which sets the value of the DTC_Entity associated with a given primitive of a tagged type and propagates the value to the wrapped subprogram. (Set_DTC_Entity_Value): Propagate the DTC value to the wrapped entity. * sem_ch13.adb (Build_Invariant_Procedure): Append the code associated with invariants of progenitors. * sem_ch3.adb (Build_Derived_Record_Type): Inherit type invariants of parents and progenitors. (Process_Full_View): Check hidden inheritance of class-wide type invariants. * sem_ch7.adb (Analyze_Package_Specification): Do not generate the invariant procedure for interface types; build the invariant procedure for tagged types inheriting invariants from their progenitors. * sem_prag.adb (Pragma_Invariant) Allow invariants in interface types but do not build their invariant procedure since their invariants will be propagated to the invariant procedure of types covering the interface. * exp_ch6.adb, exp_disp.adb, sem_ch3.adb, sem_ch7.adb, sem_ch8.adb, sem_disp.adb: Replace all calls to Set_DT_Position by calls to Set_DT_Position_Value. From-SVN: r221113 --- gcc/ada/ChangeLog | 28 ++++++++++++++++++++ gcc/ada/exp_ch6.adb | 2 +- gcc/ada/exp_ch9.adb | 6 +++++ gcc/ada/exp_disp.adb | 56 +++++++++++++++++++++++++++++---------- gcc/ada/exp_disp.ads | 16 +++++++----- gcc/ada/sem_ch13.adb | 24 +++++++++++++++++ gcc/ada/sem_ch3.adb | 62 ++++++++++++++++++++++++++++++++++++++++++-- gcc/ada/sem_ch7.adb | 47 +++++++++++++++++++++++---------- gcc/ada/sem_ch8.adb | 3 ++- gcc/ada/sem_disp.adb | 6 ++--- gcc/ada/sem_prag.adb | 15 +++++++++-- 11 files changed, 223 insertions(+), 42 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1c8ef6a8f46..d05d5c41a9a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,31 @@ +2015-03-02 Javier Miranda + + * exp_ch9.adb (Build_Corresponding_Record): Propagate type + invariants to the corresponding record type. + * exp_disp.ad[sb] (Set_DT_Position_Value): New subprogram + which sets the value of the DTC_Entity associated with a given + primitive of a tagged type and propagates the value to the + wrapped subprogram. + (Set_DTC_Entity_Value): Propagate the DTC + value to the wrapped entity. + * sem_ch13.adb (Build_Invariant_Procedure): Append the code + associated with invariants of progenitors. + * sem_ch3.adb (Build_Derived_Record_Type): Inherit type invariants + of parents and progenitors. + (Process_Full_View): Check hidden inheritance of class-wide type + invariants. + * sem_ch7.adb (Analyze_Package_Specification): Do not generate + the invariant procedure for interface types; build the invariant + procedure for tagged types inheriting invariants from their + progenitors. + * sem_prag.adb (Pragma_Invariant) Allow invariants in interface + types but do not build their invariant procedure since their + invariants will be propagated to the invariant procedure of + types covering the interface. + * exp_ch6.adb, exp_disp.adb, sem_ch3.adb, sem_ch7.adb, + sem_ch8.adb, sem_disp.adb: Replace all calls to Set_DT_Position + by calls to Set_DT_Position_Value. + 2015-03-02 Hristian Kirtchev * sem_attr.adb (Analyze_Attribute): Factor out heavily indented diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 370f3e20d44..4210968c0ce 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -671,7 +671,7 @@ package body Exp_Ch6 is and then Is_Hidden (Par_Op) and then Type_Conformant (Prim_Op, Subp) then - Set_DT_Position (Subp, DT_Position (Prim_Op)); + Set_DT_Position_Value (Subp, DT_Position (Prim_Op)); end if; Next_Elmt (Op_Elmt); diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 6c1858bd595..9fa05009dbd 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -1240,6 +1240,12 @@ package body Exp_Ch9 is Set_Stored_Constraint (Rec_Ent, No_Elist); Cdecls := New_List; + -- Propagate type invariants to the corresponding record type + + Set_Has_Invariants (Rec_Ent, Has_Invariants (Ctyp)); + Set_Has_Inheritable_Invariants (Rec_Ent, + Has_Inheritable_Invariants (Ctyp)); + -- Use discriminals to create list of discriminants for record, and -- create new discriminals for use in default expressions, etc. It is -- worth noting that a task discriminant gives rise to 5 entities; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index c0613bb80ce..e8fb0897fa6 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -64,7 +64,6 @@ with Stringt; use Stringt; with SCIL_LL; use SCIL_LL; with Targparm; use Targparm; with Tbuild; use Tbuild; -with Uintp; use Uintp; package body Exp_Disp is @@ -8046,7 +8045,7 @@ package body Exp_Disp is -- way we ensure that the final position of all the primitives is -- established by the following stages of this algorithm. - Set_DT_Position (Prim, No_Uint); + Set_DT_Position_Value (Prim, No_Uint); Next_Elmt (Prim_Elmt); end loop; @@ -8104,8 +8103,9 @@ package body Exp_Disp is if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp) and then Type_Conformant (Prim_Op, Node (Op_Elmt_2)) then - Set_DT_Position (Prim_Op, DT_Position (Parent_Subp)); - Set_DT_Position (Node (Op_Elmt_2), + Set_DT_Position_Value (Prim_Op, + DT_Position (Parent_Subp)); + Set_DT_Position_Value (Node (Op_Elmt_2), DT_Position (Parent_Subp)); Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op))); @@ -8163,10 +8163,11 @@ package body Exp_Disp is if In_Predef_Prims_DT (Prim) then if Is_Predefined_Dispatching_Operation (Prim) then - Set_DT_Position (Prim, Default_Prim_Op_Position (Prim)); + Set_DT_Position_Value (Prim, + Default_Prim_Op_Position (Prim)); else pragma Assert (Present (Alias (Prim))); - Set_DT_Position (Prim, + Set_DT_Position_Value (Prim, Default_Prim_Op_Position (Ultimate_Alias (Prim))); end if; @@ -8181,12 +8182,12 @@ package body Exp_Disp is and then Present (DTC_Entity (Interface_Alias (Prim)))); E := Interface_Alias (Prim); - Set_DT_Position (Prim, DT_Position (E)); + Set_DT_Position_Value (Prim, DT_Position (E)); pragma Assert (DT_Position (Alias (Prim)) = No_Uint or else DT_Position (Alias (Prim)) = DT_Position (E)); - Set_DT_Position (Alias (Prim), DT_Position (E)); + Set_DT_Position_Value (Alias (Prim), DT_Position (E)); Set_Fixed_Prim (UI_To_Int (DT_Position (Prim))); -- Overriding primitives must use the same entry as the @@ -8202,7 +8203,7 @@ package body Exp_Disp is and then Present (DTC_Entity (Alias (Prim))) then E := Alias (Prim); - Set_DT_Position (Prim, DT_Position (E)); + Set_DT_Position_Value (Prim, DT_Position (E)); if not Is_Predefined_Dispatching_Alias (E) then Set_Fixed_Prim (UI_To_Int (DT_Position (E))); @@ -8239,7 +8240,7 @@ package body Exp_Disp is exit when not Fixed_Prim (Nb_Prim); end loop; - Set_DT_Position (Prim, UI_From_Int (Nb_Prim)); + Set_DT_Position_Value (Prim, UI_From_Int (Nb_Prim)); Set_Fixed_Prim (Nb_Prim); end if; @@ -8268,14 +8269,14 @@ package body Exp_Disp is Use_Full_View => True) then pragma Assert (DT_Position (Alias (Prim)) /= No_Uint); - Set_DT_Position (Prim, DT_Position (Alias (Prim))); + Set_DT_Position_Value (Prim, DT_Position (Alias (Prim))); -- Otherwise it will be placed in the secondary DT else pragma Assert (DT_Position (Interface_Alias (Prim)) /= No_Uint); - Set_DT_Position (Prim, + Set_DT_Position_Value (Prim, DT_Position (Interface_Alias (Prim))); end if; end if; @@ -8713,6 +8714,25 @@ package body Exp_Disp is end if; end Set_CPP_Constructors; + --------------------------- + -- Set_DT_Position_Value -- + --------------------------- + + procedure Set_DT_Position_Value (Prim : Entity_Id; Value : Uint) is + begin + Set_DT_Position (Prim, Value); + + -- Propagate the value to the wrapped subprogram (if one is present) + + if Ekind_In (Prim, E_Function, E_Procedure) + and then Is_Primitive_Wrapper (Prim) + and then Present (Wrapped_Entity (Prim)) + and then Is_Dispatching_Operation (Wrapped_Entity (Prim)) + then + Set_DT_Position (Wrapped_Entity (Prim), Value); + end if; + end Set_DT_Position_Value; + -------------------------- -- Set_DTC_Entity_Value -- -------------------------- @@ -8734,6 +8754,16 @@ package body Exp_Disp is Set_DTC_Entity (Prim, First_Tag_Component (Tagged_Type)); end if; + + -- Propagate the value to the wrapped subprogram (if one is present) + + if Ekind_In (Prim, E_Function, E_Procedure) + and then Is_Primitive_Wrapper (Prim) + and then Present (Wrapped_Entity (Prim)) + and then Is_Dispatching_Operation (Wrapped_Entity (Prim)) + then + Set_DTC_Entity (Wrapped_Entity (Prim), DTC_Entity (Prim)); + end if; end Set_DTC_Entity_Value; ----------------- diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 67b8be0d4b5..9a364660b33 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -4,9 +4,9 @@ -- -- -- E X P _ D I S P -- -- -- --- S p e c -- +-- GS p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -27,6 +27,7 @@ -- dispatching expansion. with Types; use Types; +with Uintp; use Uintp; package Exp_Disp is @@ -379,11 +380,14 @@ package Exp_Disp is -- target object in its first argument; such implicit argument is explicit -- in the IP procedures built here. - procedure Set_DTC_Entity_Value - (Tagged_Type : Entity_Id; - Prim : Entity_Id); + procedure Set_DT_Position_Value (Prim : Entity_Id; Value : Uint); + -- Set the position of a dispatching primitive its dispatch table. For + -- subprogram wrappers propagate the value to the wrapped subprogram. + + procedure Set_DTC_Entity_Value (Tagged_Type : Entity_Id; Prim : Entity_Id); -- Set the definite value of the DTC_Entity value associated with a given - -- primitive of a tagged type. + -- primitive of a tagged type. For subprogram wrappers propagat the value + -- to the wrapped subprogram. procedure Write_DT (Typ : Entity_Id); pragma Export (Ada, Write_DT); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 629b9ea5f7a..5883e4c5e92 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -7966,6 +7966,30 @@ package body Sem_Ch13 is end loop; end; + -- Add invariants of progenitors + + if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then + declare + Ifaces_List : Elist_Id; + AI : Elmt_Id; + Iface : Entity_Id; + + begin + Collect_Interfaces (Typ, Ifaces_List); + + AI := First_Elmt (Ifaces_List); + while Present (AI) loop + Iface := Node (AI); + + if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then + Add_Invariants (Iface, Inherit => True); + end if; + + Next_Elmt (AI); + end loop; + end; + end if; + -- Build the procedure if we generated at least one Check pragma if Stmts /= No_List then diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 537be5ea6f3..681e47cfd89 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -8640,6 +8640,36 @@ package body Sem_Ch3 is end; end if; + -- Propagate inherited invariant information of parents + -- and progenitors + + if Ada_Version >= Ada_2012 + and then not Is_Interface (Derived_Type) + then + if Has_Inheritable_Invariants (Parent_Type) then + Set_Has_Invariants (Derived_Type); + Set_Has_Inheritable_Invariants (Derived_Type); + + elsif not Is_Empty_Elmt_List (Ifaces_List) then + declare + AI : Elmt_Id; + + begin + AI := First_Elmt (Ifaces_List); + while Present (AI) loop + if Has_Inheritable_Invariants (Node (AI)) then + Set_Has_Invariants (Derived_Type); + Set_Has_Inheritable_Invariants (Derived_Type); + + exit; + end if; + + Next_Elmt (AI); + end loop; + end; + end if; + end if; + -- A type extension is automatically Ghost when one of its -- progenitors is Ghost (SPARK RM 6.9(9)). This property is -- also inherited when the parent type is Ghost, but this is @@ -14811,7 +14841,7 @@ package body Sem_Ch3 is if Present (DTC_Entity (Actual_Subp)) then Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp)); - Set_DT_Position (New_Subp, DT_Position (Actual_Subp)); + Set_DT_Position_Value (New_Subp, DT_Position (Actual_Subp)); end if; end if; @@ -19681,7 +19711,7 @@ package body Sem_Ch3 is if not Is_Dispatching_Operation (Prim) then Append_Elmt (Prim, Full_List); Set_Is_Dispatching_Operation (Prim, True); - Set_DT_Position (Prim, No_Uint); + Set_DT_Position_Value (Prim, No_Uint); end if; elsif Is_Dispatching_Operation (Prim) @@ -19837,6 +19867,34 @@ package body Sem_Ch3 is Set_Has_Inheritable_Invariants (Full_T); end if; + -- Check hidden inheritance of class-wide type invariants + + if Ada_Version >= Ada_2012 + and then not Has_Inheritable_Invariants (Full_T) + and then In_Private_Part (Current_Scope) + and then Has_Interfaces (Full_T) + then + declare + Ifaces : Elist_Id; + AI : Elmt_Id; + + begin + Collect_Interfaces (Full_T, Ifaces, Exclude_Parents => True); + + AI := First_Elmt (Ifaces); + while Present (AI) loop + if Has_Inheritable_Invariants (Node (AI)) then + Error_Msg_N + ("hidden inheritance of class-wide type invariants " & + "not allowed", N); + exit; + end if; + + Next_Elmt (AI); + end loop; + end; + end if; + -- Propagate predicates to full type, and predicate function if already -- defined. It is not clear that this can actually happen? the partial -- view cannot be frozen yet, and the predicate function has not been diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 4d0bf159b3e..8af1f346ebc 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1482,7 +1482,7 @@ package body Sem_Ch7 is end if; -- If invariants are present, build the invariant procedure for a - -- private type, but not any of its subtypes. + -- private type, but not any of its subtypes or interface types. if Has_Invariants (E) then if Ekind (E) = E_Private_Subtype then @@ -1665,23 +1665,42 @@ package body Sem_Ch7 is if Is_Type (E) and then Has_Private_Declaration (E) and then Nkind (Parent (E)) = N_Full_Type_Declaration - and then Has_Aspects (Parent (E)) then declare - ASN : Node_Id; + IP_Built : Boolean := False; begin - ASN := First (Aspect_Specifications (Parent (E))); - while Present (ASN) loop - if Nam_In (Chars (Identifier (ASN)), Name_Invariant, - Name_Type_Invariant) - then - Build_Invariant_Procedure (E, N); - exit; - end if; + if Has_Aspects (Parent (E)) then + declare + ASN : Node_Id; + + begin + ASN := First (Aspect_Specifications (Parent (E))); + while Present (ASN) loop + if Nam_In (Chars (Identifier (ASN)), + Name_Invariant, + Name_Type_Invariant) + then + Build_Invariant_Procedure (E, N); + IP_Built := True; + exit; + end if; - Next (ASN); - end loop; + Next (ASN); + end loop; + end; + end if; + + -- Invariants may have been inherited from progenitors + + if not IP_Built + and then Has_Interfaces (E) + and then Has_Inheritable_Invariants (E) + and then not Is_Interface (E) + and then not Is_Class_Wide_Type (E) + then + Build_Invariant_Procedure (E, N); + end if; end; end if; @@ -1987,7 +2006,7 @@ package body Sem_Ch7 is and then Present (DTC_Entity (Alias (Prim_Op))) then Set_DTC_Entity_Value (E, New_Op); - Set_DT_Position (New_Op, + Set_DT_Position_Value (New_Op, DT_Position (Alias (Prim_Op))); end if; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 5695033171d..b86e1514efc 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -28,6 +28,7 @@ with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; +with Exp_Disp; use Exp_Disp; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Fname; use Fname; @@ -3261,7 +3262,7 @@ package body Sem_Ch8 is if Present (DTC_Entity (Old_S)) then Set_DTC_Entity (New_S, DTC_Entity (Old_S)); - Set_DT_Position (New_S, DT_Position (Old_S)); + Set_DT_Position_Value (New_S, DT_Position (Old_S)); end if; end if; end; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index b49913dd57a..bc36c27cb4b 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -1122,7 +1122,7 @@ package body Sem_Disp is if Present (DTC_Entity (Old_Subp)) then Set_DTC_Entity (Subp, DTC_Entity (Old_Subp)); - Set_DT_Position (Subp, DT_Position (Old_Subp)); + Set_DT_Position_Value (Subp, DT_Position (Old_Subp)); if not Restriction_Active (No_Dispatching_Calls) then if Building_Static_DT (Tagged_Type) then @@ -1419,7 +1419,7 @@ package body Sem_Disp is end if; if not Body_Is_Last_Primitive then - Set_DT_Position (Subp, No_Uint); + Set_DT_Position_Value (Subp, No_Uint); elsif Has_Controlled_Component (Tagged_Type) and then Nam_In (Chars (Subp), Name_Initialize, @@ -1678,7 +1678,7 @@ package body Sem_Disp is Check_Controlling_Formals (Tagged_Type, Old_Subp); Set_Is_Dispatching_Operation (Old_Subp, True); - Set_DT_Position (Old_Subp, No_Uint); + Set_DT_Position_Value (Old_Subp, No_Uint); end if; -- If the old subprogram is an explicit renaming of some other diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9e216c642fe..602c411e056 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -15277,6 +15277,11 @@ package body Sem_Prag is if Typ = Any_Type then return; + -- Invariants allowed in interface types (RM 7.3.2(3/3)) + + elsif Is_Interface (Typ) then + null; + -- An invariant must apply to a private type, or appear in the -- private part of a package spec and apply to a completion. -- a class-wide invariant can only appear on a private declaration @@ -15318,8 +15323,14 @@ package body Sem_Prag is -- procedure declaration, so that calls to it can be generated -- before the body is built (e.g. within an expression function). - Insert_After_And_Analyze - (N, Build_Invariant_Procedure_Declaration (Typ)); + -- Interface types have no invariant procedure; their invariants + -- are propagated to the build invariant procedure of all the + -- types covering the interface type. + + if not Is_Interface (Typ) then + Insert_After_And_Analyze + (N, Build_Invariant_Procedure_Declaration (Typ)); + end if; if Class_Present (N) then Set_Has_Inheritable_Invariants (Typ); -- 2.30.2