+2018-05-23 Ed Schonberg <schonberg@adacore.com>
+
+ * 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 <yakobowski@adacore.com>
* libgnat/a-ngelfu.ads (Arctanh, Arccoth): Fix faulty preconditions.
-- Nested_Scenarios Elist36
-- Validated_Object Node36
+ -- Predicated_Parent Node36
-- Class_Wide_Clone Node38
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));
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));
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;
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;
-- 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
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;
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);
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);
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);
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.
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
-- 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
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
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,
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);
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);
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);
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
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.
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;
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));
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);
when Integer_Kind =>
Constrain_Integer (Def_Id, S);
- Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
when Class_Wide_Kind
| E_Incomplete_Type
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.
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;
+2018-05-23 Ed Schonberg <schonberg@adacore.com>
+
+ * gnat.dg/discr51.adb: New testcase.
+
2018-05-23 Javier Miranda <miranda@adacore.com>
* gnat.dg/valid_scalars1.adb: New testcase.
--- /dev/null
+-- { 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;
projects / gcc.git / commitdiff