* [Ada] Spurious error on instantiation with type with unknown discriminants
@ 2018-05-23 10:35 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2018-05-23 10:35 UTC (permalink / raw)
To: gcc-patches; +Cc: Ed Schonberg
[-- Attachment #1: Type: text/plain, Size: 1998 bytes --]
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.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-05-23 Ed Schonberg <schonberg@adacore.com>
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.
[-- Attachment #2: patch.diff --]
[-- Type: text/x-diff, Size: 13238 bytes --]
--- gcc/ada/einfo.adb
+++ 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;
--- gcc/ada/einfo.ads
+++ 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);
--- gcc/ada/exp_util.adb
+++ 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
--- gcc/ada/sem_aggr.adb
+++ 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
--- gcc/ada/sem_ch3.adb
+++ 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;
--- /dev/null
new file mode 100644
+++ 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;
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2018-05-23 10:35 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2018-05-23 10:35 [Ada] Spurious error on instantiation with type with unknown discriminants Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).