The compiler incorrectly rejects a generic instantiation that passes an
undiscriminated private type when the full type has discriminants and
the generic does an assignment to a dereferenced access value denoting
an object of the formal type. The error message complains that the type
has no discriminants because, in the instance, the compiler expands
a record subtype whose base type is the actual private type, though
the underlying type is a discriminated record type. It turns out to be
problematic to change the subtype to have the record type as its base
type (breaks lots of existing tests), and the fix adopted is to add a
test to go to the underlying type in this case prior to expanding the
discriminant check for this already specially handled form of assignment.
The following test must compile and execute quietly:
procedure Priv_Discrim_Inst_Bug is
generic
type Data is private;
package Gen is
procedure Assign (X: in Data);
private
type Acc_Data is access all Data;
Default_Object : aliased Data;
end Gen;
package body Gen is
procedure Assign (X: in Data) is
A : constant Acc_Data := Default_Object'Access;
begin
A.all := X; -- Discriminant check required for instance Inst
end Assign;
end Gen;
package Pkg is
type Priv is private;
function Return_Priv (B : Boolean) return Priv;
private
type Priv (Discr : Boolean := True) is null record;
end Pkg;
package body Pkg is
function Return_Priv (B : Boolean) return Priv is
begin
return (Discr => B);
end Return_Priv;
end Pkg;
package Inst is new Gen (Pkg.Priv); -- OK (but GNAT says no discriminants)
begin
begin
Inst.Assign (Pkg.Return_Priv (False)); -- Should raise exception
exception
when others => null;
end;
Inst.Assign (Pkg.Return_Priv (True)); -- Should not raise exception
end Priv_Discrim_Inst_Bug;
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-31 Gary Dismukes <dismu...@adacore.com>
* exp_ch5.adb (Expand_N_Assignment_Statement): When a discriminant
check is needed for a left-hand side that is a dereference, and the
base type is private without discriminants (whereas the full type does
have discriminants), an extra retrieval of the underlying type may be
needed in the case where the subtype is a record subtype whose base
type is private. Update comments.
Index: exp_ch5.adb
===================================================================
--- exp_ch5.adb (revision 178361)
+++ exp_ch5.adb (working copy)
@@ -1788,9 +1788,8 @@
-- If the type is private without discriminants, and the full type
-- has discriminants (necessarily with defaults) a check may still be
- -- necessary if the Lhs is aliased. The private determinants must be
+ -- necessary if the Lhs is aliased. The private discriminants must be
-- visible to build the discriminant constraints.
- -- What is a "determinant"???
-- Only an explicit dereference that comes from source indicates
-- aliasing. Access to formals of protected operations and entries
@@ -1802,11 +1801,28 @@
and then Comes_From_Source (Lhs)
then
declare
- Lt : constant Entity_Id := Etype (Lhs);
+ Lt : constant Entity_Id := Etype (Lhs);
+ Ubt : Entity_Id := Base_Type (Typ);
+
begin
- Set_Etype (Lhs, Typ);
- Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs));
- Apply_Discriminant_Check (Rhs, Typ, Lhs);
+ -- In the case of an expander-generated record subtype whose base
+ -- type still appears private, Typ will have been set to that
+ -- private type rather than the underlying record type (because
+ -- Underlying type will have returned the record subtype), so it's
+ -- necessary to apply Underlying_Type again to the base type to
+ -- get the record type we need for the discriminant check. Such
+ -- subtypes can be created for assignments in certain cases, such
+ -- as within an instantiation passed this kind of private type.
+ -- It would be good to avoid this special test, but making changes
+ -- to prevent this odd form of record subtype seems difficult. ???
+
+ if Is_Private_Type (Ubt) then
+ Ubt := Underlying_Type (Ubt);
+ end if;
+
+ Set_Etype (Lhs, Ubt);
+ Rewrite (Rhs, OK_Convert_To (Base_Type (Ubt), Rhs));
+ Apply_Discriminant_Check (Rhs, Ubt, Lhs);
Set_Etype (Lhs, Lt);
end;
