From ffdd52487888d3c45cf02e66b79587d2cf2839a3 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Wed, 23 May 2018 10:23:48 +0000 Subject: [PATCH] [Ada] Spurious error on instantiation with type with unknown discriminants This patch fixes a spurious error when instantiating an indefinite container with a private type with unknown discriminants, when its full view is an unconstrained array type. It also cleans up the inheritance of dynamic predicates inherited by anonymous subtypes of array types. 2018-05-23 Ed Schonberg gcc/ada/ * einfo.ads: New attribute on types: Predicated_Parent, to simplify the retrieval of the applicable predicate function to an itype created for a constrained array component. * einfo.adb: Subprograms for Predicated_Parent. (Predicate_Function): Use new attribute. * exp_util.adb (Make_Predicate_Call): If the predicate function is not available for a subtype, retrieve it from the base type, which may have been frozen after the subtype declaration and not captured by the subtype declaration. * sem_aggr.adb (Resolve_Array_Aggregate): An Others association is legal within a generated initiqlization procedure, as may happen with a predicate check on a component, when the predicate function applies to the base type of the component. * sem_ch3.adb (Analyze_Subtype_Declaration): Clean up inheritance of predicates for subtype declarations and for subtype indications in other contexts. (Process_Subtype): Likewise. Handle properly the case of a private type with unknown discriminants whose full view is an unconstrained array. Use Predicated_Parent to indicate source of predicate function on an itype whose parent is itself an itype. (Complete_Private_Subtype): If the private view has unknown discriminants and the full view is an unconstrained array, set base type of completion to the full view of parent. (Inherit_Predicate_Flags): Prevent double assignment of predicate function and flags. (Build_Subtype): For a constrained array component, propagate predicate information from original component type declaration. gcc/testsuite/ * gnat.dg/discr51.adb: New testcase. From-SVN: r260596 --- gcc/ada/ChangeLog | 30 ++++++++++++ gcc/ada/einfo.adb | 21 ++++++++ gcc/ada/einfo.ads | 12 +++++ gcc/ada/exp_util.adb | 5 +- gcc/ada/sem_aggr.adb | 5 +- gcc/ada/sem_ch3.adb | 79 +++++++++++++++++++++++++++---- gcc/testsuite/ChangeLog | 4 ++ gcc/testsuite/gnat.dg/discr51.adb | 32 +++++++++++++ 8 files changed, 176 insertions(+), 12 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/discr51.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f2e6fde15f6..2be21310c98 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,33 @@ +2018-05-23 Ed Schonberg + + * einfo.ads: New attribute on types: Predicated_Parent, to simplify the + retrieval of the applicable predicate function to an itype created for + a constrained array component. + * einfo.adb: Subprograms for Predicated_Parent. + (Predicate_Function): Use new attribute. + * exp_util.adb (Make_Predicate_Call): If the predicate function is not + available for a subtype, retrieve it from the base type, which may have + been frozen after the subtype declaration and not captured by the + subtype declaration. + * sem_aggr.adb (Resolve_Array_Aggregate): An Others association is + legal within a generated initiqlization procedure, as may happen with a + predicate check on a component, when the predicate function applies to + the base type of the component. + * sem_ch3.adb (Analyze_Subtype_Declaration): Clean up inheritance of + predicates for subtype declarations and for subtype indications in + other contexts. + (Process_Subtype): Likewise. Handle properly the case of a private type + with unknown discriminants whose full view is an unconstrained array. + Use Predicated_Parent to indicate source of predicate function on an + itype whose parent is itself an itype. + (Complete_Private_Subtype): If the private view has unknown + discriminants and the full view is an unconstrained array, set base + type of completion to the full view of parent. + (Inherit_Predicate_Flags): Prevent double assignment of predicate + function and flags. + (Build_Subtype): For a constrained array component, propagate predicate + information from original component type declaration. + 2018-05-23 Boris Yakobowski * libgnat/a-ngelfu.ads (Arctanh, Arccoth): Fix faulty preconditions. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 6d5c7eace85..7ba43278ef5 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -276,6 +276,7 @@ package body Einfo is -- Nested_Scenarios Elist36 -- Validated_Object Node36 + -- Predicated_Parent Node36 -- Class_Wide_Clone Node38 @@ -3082,6 +3083,12 @@ package body Einfo is return Node14 (Id); end Postconditions_Proc; + function Predicated_Parent (Id : E) return E is + begin + pragma Assert (Is_Type (Id)); + return Node36 (Id); + end Predicated_Parent; + function Predicates_Ignored (Id : E) return B is begin pragma Assert (Is_Type (Id)); @@ -6311,6 +6318,12 @@ package body Einfo is Set_Node14 (Id, V); end Set_Postconditions_Proc; + procedure Set_Predicated_Parent (Id : E; V : E) is + begin + pragma Assert (Is_Type (Id)); + Set_Node36 (Id, V); + end Set_Predicated_Parent; + procedure Set_Predicates_Ignored (Id : E; V : B) is begin pragma Assert (Is_Type (Id)); @@ -8829,6 +8842,9 @@ package body Einfo is then Typ := Full_View (Id); + elsif Is_Itype (Id) and then Present (Predicated_Parent (Id)) then + Typ := Predicated_Parent (Id); + else Typ := Id; end if; @@ -11200,6 +11216,11 @@ package body Einfo is when E_Variable => Write_Str ("Validated_Object"); + when E_Array_Subtype + | E_Record_Subtype + => + Write_Str ("predicated parent"); + when others => Write_Str ("Field36??"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 7f8f0e21272..1baac0551f6 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3932,6 +3932,14 @@ package Einfo is -- is the special version created for membership tests, where if one of -- these raise expressions is executed, the result is to return False. +-- Predicated_Parent (Node36) +-- Defined on itypes created by subtype indications, when the parent +-- subtype has predicates. The itype shares the Predicate_Function +-- of the predicated parent, but this function may not have been built +-- at the point the Itype is constructed, so this attribute allows its +-- retrieval at the point a predicate check needs to be generated. +-- The utility Predicate_Function takes this link into account. + -- Predicates_Ignored (Flag288) -- Defined on all types. Indicates whether the subtype declaration is in -- a context where Assertion_Policy is Ignore, in which case no checks @@ -7427,6 +7435,7 @@ package Einfo is function Partial_View_Has_Unknown_Discr (Id : E) return B; function Pending_Access_Types (Id : E) return L; function Postconditions_Proc (Id : E) return E; + function Predicated_Parent (Id : E) return E; function Predicates_Ignored (Id : E) return B; function Prival (Id : E) return E; function Prival_Link (Id : E) return E; @@ -7789,6 +7798,7 @@ package Einfo is procedure Set_Depends_On_Private (Id : E; V : B := True); procedure Set_Derived_Type_Link (Id : E; V : E); procedure Set_Digits_Value (Id : E; V : U); + procedure Set_Predicated_Parent (Id : E; V : E); procedure Set_Predicates_Ignored (Id : E; V : B); procedure Set_Direct_Primitive_Operations (Id : E; V : L); procedure Set_Directly_Designated_Type (Id : E; V : E); @@ -8988,6 +8998,7 @@ package Einfo is pragma Inline (Partial_View_Has_Unknown_Discr); pragma Inline (Pending_Access_Types); pragma Inline (Postconditions_Proc); + pragma Inline (Predicated_Parent); pragma Inline (Predicates_Ignored); pragma Inline (Prival); pragma Inline (Prival_Link); @@ -9475,6 +9486,7 @@ package Einfo is pragma Inline (Set_Partial_View_Has_Unknown_Discr); pragma Inline (Set_Pending_Access_Types); pragma Inline (Set_Postconditions_Proc); + pragma Inline (Set_Predicated_Parent); pragma Inline (Set_Predicates_Ignored); pragma Inline (Set_Prival); pragma Inline (Set_Prival_Link); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 610ba9a517a..5a8541dd0b7 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -9261,7 +9261,8 @@ package body Exp_Util is Func_Id : Entity_Id; begin - pragma Assert (Present (Predicate_Function (Typ))); + Func_Id := Predicate_Function (Typ); + pragma Assert (Present (Func_Id)); -- The related type may be subject to pragma Ghost. Set the mode now to -- ensure that the call is properly marked as Ghost. @@ -9272,8 +9273,6 @@ package body Exp_Util is if Mem and then Present (Predicate_Function_M (Typ)) then Func_Id := Predicate_Function_M (Typ); - else - Func_Id := Predicate_Function (Typ); end if; -- Case of calling normal predicate function diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index a03494ed6fb..5eaf4622d80 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1068,7 +1068,9 @@ package body Sem_Aggr is -- object may be its unconstrained nominal type. However, if the -- context is an assignment, we assume that OTHERS is allowed, -- because the target of the assignment will have a constrained - -- subtype when fully compiled. + -- subtype when fully compiled. Ditto if the context is an + -- initialization procedure where a component may have a predicate + -- function that carries the base type. -- Note that there is no node for Explicit_Actual_Parameter. -- To test for this context we therefore have to test for node @@ -1083,6 +1085,7 @@ package body Sem_Aggr is Set_Etype (N, Aggr_Typ); -- May be overridden later on if Pkind = N_Assignment_Statement + or else Inside_Init_Proc or else (Is_Constrained (Typ) and then (Pkind = N_Parameter_Association or else diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 3316ff7e329..50b99100296 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -5338,11 +5338,13 @@ package body Sem_Ch3 is if not Comes_From_Source (N) then Set_Ekind (Id, Ekind (T)); - if Present (Predicate_Function (T)) then + if Present (Predicate_Function (Id)) then + null; + + elsif Present (Predicate_Function (T)) then Set_Predicate_Function (Id, Predicate_Function (T)); elsif Present (Ancestor_Subtype (T)) - and then Has_Predicates (Ancestor_Subtype (T)) and then Present (Predicate_Function (Ancestor_Subtype (T))) then Set_Predicate_Function (Id, @@ -5443,7 +5445,6 @@ package body Sem_Ch3 is Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Known_Valid (Id, Is_Known_Valid (T)); Set_RM_Size (Id, RM_Size (T)); - Inherit_Predicate_Flags (Id, T); when Ordinary_Fixed_Point_Kind => Set_Ekind (Id, E_Ordinary_Fixed_Point_Subtype); @@ -5469,7 +5470,6 @@ package body Sem_Ch3 is Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Known_Valid (Id, Is_Known_Valid (T)); Set_RM_Size (Id, RM_Size (T)); - Inherit_Predicate_Flags (Id, T); when Modular_Integer_Kind => Set_Ekind (Id, E_Modular_Integer_Subtype); @@ -5477,7 +5477,6 @@ package body Sem_Ch3 is Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Known_Valid (Id, Is_Known_Valid (T)); Set_RM_Size (Id, RM_Size (T)); - Inherit_Predicate_Flags (Id, T); when Class_Wide_Kind => Set_Ekind (Id, E_Class_Wide_Subtype); @@ -5694,6 +5693,11 @@ package body Sem_Ch3 is when others => raise Program_Error; end case; + + -- If there is no constraint in the subtype indication, the + -- declared entity inherits predicates from the parent. + + Inherit_Predicate_Flags (Id, T); end if; if Etype (Id) = Any_Type then @@ -12345,6 +12349,15 @@ package body Sem_Ch3 is Set_RM_Size (Full, RM_Size (Full_Base)); Set_Is_Itype (Full); + -- For the unusual case of a type with unknown discriminants whose + -- completion is an array, use the proper full base. + + if Is_Array_Type (Full_Base) + and then Has_Unknown_Discriminants (Priv) + then + Set_Etype (Full, Full_Base); + end if; + -- A subtype of a private-type-without-discriminants, whose full-view -- has discriminants with default expressions, is not constrained. @@ -13427,6 +13440,27 @@ package body Sem_Ch3 is Analyze (Subtyp_Decl, Suppress => All_Checks); + if Is_Itype (Def_Id) and then Has_Predicates (T) then + Inherit_Predicate_Flags (Def_Id, T); + + -- Indicate where the predicate function may be found. + + if Is_Itype (T) then + if Present (Predicate_Function (Def_Id)) then + null; + + elsif Present (Predicate_Function (T)) then + Set_Predicate_Function (Def_Id, Predicate_Function (T)); + + else + Set_Predicated_Parent (Def_Id, Predicated_Parent (T)); + end if; + + elsif No (Predicate_Function (Def_Id)) then + Set_Predicated_Parent (Def_Id, T); + end if; + end if; + return Def_Id; end Build_Subtype; @@ -18550,6 +18584,10 @@ package body Sem_Ch3 is procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is begin + if Present (Predicate_Function (Subt)) then + return; + end if; + Set_Has_Predicates (Subt, Has_Predicates (Par)); Set_Has_Static_Predicate_Aspect (Subt, Has_Static_Predicate_Aspect (Par)); @@ -21606,7 +21644,6 @@ package body Sem_Ch3 is when Enumeration_Kind => Constrain_Enumeration (Def_Id, S); - Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); when Ordinary_Fixed_Point_Kind => Constrain_Ordinary_Fixed (Def_Id, S); @@ -21616,7 +21653,6 @@ package body Sem_Ch3 is when Integer_Kind => Constrain_Integer (Def_Id, S); - Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); when Class_Wide_Kind | E_Incomplete_Type @@ -21630,7 +21666,21 @@ package body Sem_Ch3 is end if; when Private_Kind => - Constrain_Discriminated_Type (Def_Id, S, Related_Nod); + + -- A private type with unknown discriminants may be completed + -- by an unconstrained array type. + + if Has_Unknown_Discriminants (Subtype_Mark_Id) + and then Present (Full_View (Subtype_Mark_Id)) + and then Is_Array_Type (Full_View (Subtype_Mark_Id)) + then + Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix); + + -- ... but more comonly by a discriminated record type. + + else + Constrain_Discriminated_Type (Def_Id, S, Related_Nod); + end if; -- The base type may be private but Def_Id may be a full view -- in an instance. @@ -21696,6 +21746,19 @@ package body Sem_Ch3 is Set_Rep_Info (Def_Id, (Subtype_Mark_Id)); Set_Convention (Def_Id, Convention (Subtype_Mark_Id)); + -- The anonymous subtype created for the subtype indication + -- inherits the predicates of the parent. + + if Has_Predicates (Subtype_Mark_Id) then + Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); + + -- Indicate where the predicate function may be found. + + if No (Predicate_Function (Def_Id)) then + Set_Predicated_Parent (Def_Id, Subtype_Mark_Id); + end if; + end if; + return Def_Id; end if; end Process_Subtype; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index cd836e89340..254db69dfd6 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-05-23 Ed Schonberg + + * gnat.dg/discr51.adb: New testcase. + 2018-05-23 Javier Miranda * gnat.dg/valid_scalars1.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/discr51.adb b/gcc/testsuite/gnat.dg/discr51.adb new file mode 100644 index 00000000000..71a342050fd --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr51.adb @@ -0,0 +1,32 @@ +-- { dg-do compile } + +with Ada.Containers.Indefinite_Holders; + +procedure Discr51 is + + package Inner is + type Str (<>) is private; + private + type Str is array (Positive range <>) of Character; + end Inner; + + package Inner2 is + type Str2 (<>) is private; + private + type str2 is new inner.Str; + end Inner2; + + type Str3 is new Inner.str; + + package Str_Holders is new Ada.Containers.Indefinite_Holders + (Inner.Str, Inner."="); + + package Str2_Holders is new Ada.Containers.Indefinite_Holders + (Inner2.Str2, Inner2."="); + + package Str3_Holders is new Ada.Containers.Indefinite_Holders + (Str3, "="); + +begin + null; +end Discr51; -- 2.30.2