diff options
Diffstat (limited to 'gcc/ada/sem_ch3.adb')
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 62 |
1 files changed, 60 insertions, 2 deletions
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 |