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 <mira...@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.
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 181910)
+++ sem_ch3.adb (working copy)
@@ -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));
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 181910)
+++ exp_attr.adb (working copy)
@@ -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))
Index: einfo.ads
===================================================================
--- einfo.ads (revision 181910)
+++ einfo.ads (working copy)
@@ -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
Index: checks.adb
===================================================================
--- checks.adb (revision 181910)
+++ checks.adb (working copy)
@@ -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;
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 181910)
+++ sem_prag.adb (working copy)
@@ -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)
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 181910)
+++ sem_util.adb (working copy)
@@ -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;
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 181910)
+++ sem_util.ads (working copy)
@@ -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
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 181910)
+++ sem_attr.adb (working copy)
@@ -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;
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 181910)
+++ exp_ch4.adb (working copy)
@@ -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));
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb (revision 181910)
+++ sem_ch4.adb (working copy)
@@ -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;
