Patchwork [Ada] Type compatibility of anonymous access to extensions of constrained types

login
register
mail settings
Submitter Arnaud Charlet
Date June 18, 2010, 9:07 a.m.
Message ID <20100618090716.GA1039@adacore.com>
Download mbox | patch
Permalink /patch/56153/
State New
Headers show

Comments

Arnaud Charlet - June 18, 2010, 9:07 a.m.
If the context is an anonymous access whose designated type is class_wide,
the designated type of the expression must be a descendant of the designated
type of the context. In the presence of private extensions of constrained types,
the type of the expression may be private, and we must examine its full view to
determine whether the expression is legal. The predicate Ancestor examined the
full view for one of its arguments only. This patch makes this privacy-breaking
symmetric.

The following must compile quietly:

with P; use P;
package X is
   type Child_1_3_Ptr is access all P.Child_1_3;
   type Child_1_3_Ptr_Class is access all P.Child_1_3'Class;

   procedure Call;
end X;
---
package body X is
   procedure Proc (This : access Child_1_3'Class) is
   begin
      null;
   end Proc;

   procedure Call is
      Res : Child_1_3_Ptr_Class := new Child_1_3;
      Res2 : Child_1_3_Ptr_Class := new Child_1_3'Class'(Res.all);

      V1 : Child_1_3_Ptr := new Child_1_3;
   begin
      Proc (V1);
   end Call;

end X;
---
package P is
   type Root_1 (V : Integer) is tagged record
      null;
   end record;

   type Child_1_3 is new Root_1 (1) with private;

private
   type Child_1_3 is new Root_1 (1) with null record;
end P;

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

2010-06-18  Ed Schonberg  <schonberg@adacore.com>

	* sem_type.adb (Is_Ancestor): If either type is private, examine full
	view.

Patch

Index: sem_type.adb
===================================================================
--- sem_type.adb	(revision 160959)
+++ sem_type.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -2554,9 +2554,9 @@  package body Sem_Type is
       BT1 := Base_Type (T1);
       BT2 := Base_Type (T2);
 
-      --  Handle underlying view of records with unknown discriminants
-      --  using the original entity that motivated the construction of
-      --  this underlying record view (see Build_Derived_Private_Type).
+      --  Handle underlying view of records with unknown discriminants using
+      --  the original entity that motivated the construction of this
+      --  underlying record view (see Build_Derived_Private_Type).
 
       if Is_Underlying_Record_View (BT1) then
          BT1 := Underlying_Record_View (BT1);
@@ -2569,12 +2569,20 @@  package body Sem_Type is
       if BT1 = BT2 then
          return True;
 
+      --  The predicate must look past privacy
+
       elsif Is_Private_Type (T1)
         and then Present (Full_View (T1))
         and then BT2 = Base_Type (Full_View (T1))
       then
          return True;
 
+      elsif Is_Private_Type (T2)
+        and then Present (Full_View (T2))
+        and then BT1 = Base_Type (Full_View (T2))
+      then
+         return True;
+
       else
          Par := Etype (BT2);