diff mbox

[Ada] Spurious conformance error with instance and child unit

Message ID 20141023104009.GA23334@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Oct. 23, 2014, 10:40 a.m. UTC 
This patch fixes a spurious subtype conformance error in a child unit when
the actual is a private type declared in a package instantiation, whose full
view is a constrained discriminated type.

The following must compile quietly:

gcc -c new_bounded_strings-child.adb

---
with G_Instance;
package body New_Bounded_Strings.Child is
   procedure P (S : New_Bounded_Strings.NBString) is null;
begin
   G_Instance.R (P'Access);
end;
---
package New_Bounded_Strings.Child is -- Needs to be a child package
   procedure P (S : New_Bounded_Strings.NBString);
end;
--
with Ada.Strings.Bounded;
package Bounded_Strings_Instance is
   package BS is new Ada.Strings.Bounded.Generic_Bounded_Length (10);
   type BString is new BS.Bounded_String;
end;
--
generic
   type T is private;
package G is
   type Proc is access procedure (X : T);
   procedure R (P : Proc);
end;
--
with G;
with New_Bounded_Strings;
package G_Instance is new G (New_Bounded_Strings.NBString);
--
with Bounded_Strings_Instance;
package New_Bounded_Strings is
   type NBString is private; -- compiles if not private
private
   type NBString is new Bounded_Strings_Instance.BString;
end;

Tested on x86_64-pc-linux-gnu, committed on trunk

2014-10-23  Ed Schonberg  <schonberg@adacore.com>

	* sem_eval.adb (Subtypes_Statically_Match): For a generic actual
	type, check for the presence of discriminants in its parent type,
	against the presence of discriminants in the context type.
diff mbox

Patch

Index: sem_eval.adb
===================================================================
--- sem_eval.adb	(revision 216582)
+++ sem_eval.adb	(working copy)
@@ -5737,7 +5737,17 @@ 
          --  same base type.
 
          if Has_Discriminants (T1) /= Has_Discriminants (T2) then
-            if In_Instance then
+            --  A generic actual type is declared through a subtype declaration
+            --  and may have an inconsistent indication of the presence of
+            --  discriminants, so check the type it renames.
+
+            if Is_Generic_Actual_Type (T1)
+              and then not Has_Discriminants (Etype (T1))
+              and then not Has_Discriminants (T2)
+            then
+               return True;
+
+            elsif In_Instance then
                if Is_Private_Type (T2)
                  and then Present (Full_View (T2))
                  and then Has_Discriminants (Full_View (T2))