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

login
register
mail settings
Submitter Arnaud Charlet
Date Aug. 31, 2011, 9:03 a.m.
Message ID <20110831090343.GA4629@adacore.com>
Download mbox | patch
Permalink /patch/112474/
State New
Headers show

Comments

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

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

Patch

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;