===================================================================
@@ -10674,8 +10674,7 @@
return;
end if;
- if (Ekind (T) = E_General_Access_Type
- or else Ada_Version >= Ada_2005)
+ if Ekind (T) = E_General_Access_Type
and then Has_Private_Declaration (Desig_Type)
and then In_Open_Scopes (Scope (Desig_Type))
and then Has_Discriminants (Desig_Type)
@@ -10687,11 +10686,6 @@
-- (Defect Report 8652/0008, Technical Corrigendum 1, checked
-- by ACATS B371001).
- -- Rule updated for Ada 2005: the private type is said to have
- -- a constrained partial view, given that objects of the type
- -- can be declared. Furthermore, the rule applies to all access
- -- types, unlike the rule concerning default discriminants.
-
declare
Pack : constant Node_Id :=
Unit_Declaration_Node (Scope (Desig_Type));
===================================================================
@@ -1559,10 +1559,11 @@
return Is_Aliased_View (Obj)
and then
(Is_Constrained (Etype (Obj))
- or else (Nkind (Obj) = N_Explicit_Dereference
- and then
- not Has_Constrained_Partial_View
- (Base_Type (Etype (Obj)))));
+ or else
+ (Nkind (Obj) = N_Explicit_Dereference
+ and then
+ not Effectively_Has_Constrained_Partial_View
+ (Base_Type (Etype (Obj)))));
end if;
end Is_Constrained_Aliased_View;
@@ -1684,7 +1685,8 @@
or else
(Nkind (Pref) = N_Explicit_Dereference
and then
- not Has_Constrained_Partial_View (Base_Type (Ptyp)))
+ not Effectively_Has_Constrained_Partial_View
+ (Base_Type (Ptyp)))
or else Is_Constrained (Underlying_Type (Ptyp))
or else (Ada_Version >= Ada_2012
and then Is_Tagged_Type (Underlying_Type (Ptyp))
===================================================================
@@ -1420,6 +1420,8 @@
-- type has no discriminants and the full view has discriminants with
-- defaults. In Ada 2005 heap-allocated objects of such types are not
-- constrained, and can change their discriminants with full assignment.
+-- Sem_Util.Effectively_Has_Constrained_Partial_View should be always
+-- used by callers, rather than reading this attribute directly.
-- Has_Contiguous_Rep (Flag181)
-- Present in enumeration types. True if the type as a representation
===================================================================
@@ -1240,7 +1240,7 @@
-- partial view that is constrained.
elsif Ada_Version >= Ada_2005
- and then Has_Constrained_Partial_View (Base_Type (T_Typ))
+ and then Effectively_Has_Constrained_Partial_View (Base_Type (T_Typ))
then
return;
end if;
===================================================================
@@ -1314,34 +1314,6 @@
Subtype_Indication (Component_Definition (Comp));
Typ : constant Entity_Id := Etype (Comp_Id);
- function Inside_Generic_Body (Id : Entity_Id) return Boolean;
- -- Determine whether entity Id appears inside a generic body.
- -- Shouldn't this be in a more general place ???
-
- -------------------------
- -- Inside_Generic_Body --
- -------------------------
-
- function Inside_Generic_Body (Id : Entity_Id) return Boolean is
- S : Entity_Id;
-
- begin
- S := Id;
- while Present (S) and then S /= Standard_Standard loop
- if Ekind (S) = E_Generic_Package
- and then In_Package_Body (S)
- then
- return True;
- end if;
-
- S := Scope (S);
- end loop;
-
- return False;
- end Inside_Generic_Body;
-
- -- Start of processing for Check_Component
-
begin
-- Ada 2005 (AI-216): If a component subtype is subject to a per-
-- object constraint, then the component type shall be an Unchecked_
@@ -1363,7 +1335,7 @@
-- the formal part of the generic unit.
elsif Ada_Version >= Ada_2012
- and then Inside_Generic_Body (UU_Typ)
+ and then In_Generic_Body (UU_Typ)
and then In_Variant_Part
and then Is_Private_Type (Typ)
and then Is_Generic_Type (Typ)
===================================================================
@@ -3039,6 +3039,24 @@
return Extra_Accessibility (Id);
end Effective_Extra_Accessibility;
+ ----------------------------------------------
+ -- Effectively_Has_Constrained_Partial_View --
+ ----------------------------------------------
+
+ function Effectively_Has_Constrained_Partial_View
+ (Typ : Entity_Id;
+ Scop : Entity_Id := Current_Scope) return Boolean is
+ begin
+ return Has_Constrained_Partial_View (Typ)
+ or else (In_Generic_Body (Scop)
+ and then Is_Generic_Type (Base_Type (Typ))
+ and then Is_Private_Type (Base_Type (Typ))
+ and then not Is_Tagged_Type (Typ)
+ and then not (Is_Array_Type (Typ)
+ and then not Is_Constrained (Typ))
+ and then Has_Discriminants (Typ));
+ end Effectively_Has_Constrained_Partial_View;
+
--------------------------
-- Enclosing_CPP_Parent --
--------------------------
@@ -6088,6 +6106,38 @@
return False;
end Implements_Interface;
+ ---------------------
+ -- In_Generic_Body --
+ ---------------------
+
+ function In_Generic_Body (Id : Entity_Id) return Boolean is
+ S : Entity_Id := Id;
+
+ begin
+ while Present (S) and then S /= Standard_Standard loop
+
+ -- Generic package body
+
+ if Ekind (S) = E_Generic_Package
+ and then In_Package_Body (S)
+ then
+ return True;
+
+ -- Generic subprogram body
+
+ elsif Is_Subprogram (S)
+ and then Nkind (Unit_Declaration_Node (S))
+ = N_Generic_Subprogram_Declaration
+ then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end In_Generic_Body;
+
-----------------
-- In_Instance --
-----------------
@@ -6945,7 +6995,7 @@
-- designated object is known to be constrained.
if Ekind (Prefix_Type) = E_Access_Type
- and then not Has_Constrained_Partial_View
+ and then not Effectively_Has_Constrained_Partial_View
(Designated_Type (Prefix_Type))
then
return False;
===================================================================
@@ -368,6 +368,14 @@
-- Same as Einfo.Extra_Accessibility except thtat object renames
-- are looked through.
+ function Effectively_Has_Constrained_Partial_View
+ (Typ : Entity_Id;
+ Scop : Entity_Id := Current_Scope) return Boolean;
+ -- Return True if Typ has attribute Has_Constrained_Partial_View set to
+ -- True; in addition, within a generic body, return True if a subtype is
+ -- a descendant of an untagged generic formal private or derived type, and
+ -- the subtype is not an unconstrained array subtype (RM 3.3(23.10/3)).
+
function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id;
-- Returns the closest ancestor of Typ that is a CPP type.
@@ -717,6 +725,9 @@
Exclude_Parents : Boolean := False) return Boolean;
-- Returns true if the Typ_Ent implements interface Iface_Ent
+ function In_Generic_Body (Id : Entity_Id) return Boolean;
+ -- Determine whether entity Id appears inside a generic body
+
function In_Instance return Boolean;
-- Returns True if the current scope is within a generic instance
===================================================================
@@ -8632,7 +8632,7 @@
and then
(Ada_Version < Ada_2005
or else
- not Has_Constrained_Partial_View
+ not Effectively_Has_Constrained_Partial_View
(Designated_Type (Base_Type (Typ))))
then
null;
===================================================================
@@ -3903,8 +3903,9 @@
and then Present (Discriminant_Default_Value
(First_Discriminant (Typ)))
and then (Ada_Version < Ada_2005
- or else
- not Has_Constrained_Partial_View (Typ))
+ or else not
+ Effectively_Has_Constrained_Partial_View
+ (Typ))
then
Typ := Build_Default_Subtype (Typ, N);
Set_Expression (N, New_Reference_To (Typ, Loc));
===================================================================
@@ -576,10 +576,10 @@
-- and the allocated object is unconstrained.
elsif Ada_Version >= Ada_2005
- and then Has_Constrained_Partial_View (Base_Typ)
+ and then Effectively_Has_Constrained_Partial_View (Base_Typ)
then
Error_Msg_N
- ("constraint no allowed when type " &
+ ("constraint not allowed when type " &
"has a constrained partial view", Constraint (E));
end if;
This patch incorporates the support for AI95-0041. For the purposes of the rules for allowing allocated unconstrained objects, any ancestor that has a constrained partial view causes the rules to apply. In addition, in a generic body, 3.10.2(27.2/2) is checked assuming that any untagged formal private or derived type has a constrained partial view. The following test now compiles with an error: procedure AI95_041 is subtype Index is Integer range 0 .. 255; Smaller_Index : constant Index := 10; Larger_Index : constant Index := 20; generic type T1 (D : Index) is private; package G is type Ref is access all T1; Smaller : aliased T1 (Smaller_Index); Ptr_1 : Ref := Smaller'Access; -- Legal? (Yes.) Ptr : Ref; end G; package body G is begin Ptr := Smaller'Access; -- Legal? (No.) end G; begin null; end; Command: gcc -c -gnat05 ai95_041.adb Output: ai95_041.adb:17:15: object subtype must statically match designated subtype Tested on x86_64-pc-linux-gnu, committed on trunk 2011-12-02 Javier Miranda <miranda@adacore.com> * sem_ch3.adb (Constrain_Access): Enable on Ada 2005 mode the static check of the rule of general access types whose designated type has discriminants. * sem_util.ads, sem_util.adb (Effectively_Has_Constrained_Partial_View): New subprogram. (In_Generic_Body): New subprogram. * einfo.ads (Has_Constrained_Partial_View): Adding documentation. * sem_prag.adb (Inside_Generic_Body): Removed. Replaced by new subprogram In_Generic_Body. * exp_attr.adb, checks.adb, sem_attr.adb, exp_ch4.adb, sem_ch4.adb: In addition, this patch replaces the occurrences of Has_Constrained_Partial_View by Effectively_Has_Constrained_Partial_View.