[Ada] Error on instantiation with private type that has discriminated full type

Message ID 20110831090343.GA4629@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Aug. 31, 2011, 9:03 a.m.
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

     type Data is private;
  package Gen is

    procedure Assign (X: in Data);


    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;
       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;


    type Priv (Discr : Boolean := True) is null record;

  end Pkg;

  package body Pkg is

    function Return_Priv (B : Boolean) return Priv is
       return (Discr => B);
    end Return_Priv;

  end Pkg;

  package Inst is new Gen (Pkg.Priv);  -- OK (but GNAT says no discriminants)

      Inst.Assign (Pkg.Return_Priv (False));  -- Should raise exception
      when others => null;

   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  <dismukes@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)
-            Lt : constant Entity_Id := Etype (Lhs);
+            Lt  : constant Entity_Id := Etype (Lhs);
+            Ubt : Entity_Id          := Base_Type (Typ);
-            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);