===================================================================
@@ -9300,6 +9300,15 @@
if Ekind (Id) = E_Record_Type_With_Private then
return Full_View (Id);
+ -- If we have a class-wide type that comes from the limited view then
+ -- we return the Underlying_Type of its nonlimited view.
+
+ elsif Ekind (Id) = E_Class_Wide_Type
+ and then From_Limited_With (Id)
+ and then Present (Non_Limited_View (Id))
+ then
+ return Underlying_Type (Non_Limited_View (Id));
+
elsif Ekind (Id) in Incomplete_Or_Private_Kind then
-- If we have an incomplete or private type with a full view,
@@ -9324,9 +9333,8 @@
then
return Underlying_Type (Underlying_Full_View (Id));
- -- If we have an incomplete entity that comes from the limited
- -- view then we return the Underlying_Type of its non-limited
- -- view.
+ -- If we have an incomplete entity that comes from the limited view
+ -- then we return the Underlying_Type of its nonlimited view.
elsif From_Limited_With (Id)
and then Present (Non_Limited_View (Id))
===================================================================
@@ -2235,7 +2235,7 @@
-- issues are taken care of by the virtual machine.
elsif Is_Class_Wide_Type (Ptyp)
- and then Is_Interface (Ptyp)
+ and then Is_Interface (Underlying_Type (Ptyp))
and then Tagged_Type_Expansion
and then not (Nkind (Pref) in N_Has_Entity
and then Is_Subprogram (Entity (Pref)))
@@ -6241,7 +6241,7 @@
elsif Comes_From_Source (N)
and then Is_Class_Wide_Type (Etype (Prefix (N)))
- and then Is_Interface (Etype (Prefix (N)))
+ and then Is_Interface (Underlying_Type (Etype (Prefix (N))))
then
-- Generate:
-- (To_Tag_Ptr (Prefix'Address)).all
If the designated type of an access to a class-wide interface type is visible through a limited-with clause, and attribute 'Tag is applied to the dereference of a pointer of such type, and such 'Tag value is used to invoke the routines of the Ada.Tags runtime package then the Ada.Tags routine may return a wrong value or raise an exception. After this patch the following test compiles and executes fine. with Pkg_Iface_Ptr; package Pkg_Iface is type Iface is interface; end; limited with Pkg_Iface; package Pkg_Iface_Ptr is type Lim_Iface_Ptr is access all Pkg_Iface.Iface'Class; end; with Pkg_Iface; use Pkg_Iface; package Types is type Root is abstract tagged null record; type DT is new Root and Iface with null record; end; with Pkg_Iface; package Pkg_Aux is end; with Pkg_Aux; with Pkg_Iface_Ptr; use Pkg_Iface_Ptr; package Pkg_Test is function Do_Test (Ptr : Lim_Iface_Ptr) return String; end; with Ada.Tags; package body Pkg_Test is function Do_Test (Ptr : Lim_Iface_Ptr) return String is begin return Ada.Tags.External_Tag (Ptr.all'Tag); -- Test end; end; with Types; use Types; with Pkg_Test; use Pkg_Test; with GNAT.IO; use GNAT.IO; procedure Main is begin GNAT.IO.Put_Line (Do_Test (new DT)); end; Command: gnatmake -q main; ./main Output: TYPES.DT Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-08 Javier Miranda <miranda@adacore.com> * einfo.adb (Underlying_Type): Add missing support for class-wide types that come from the limited view. * exp_attr.adb (Attribute_Address): Check class-wide type interfaces using the underlying type to handle limited-withed types. (Attribute_Tag): Check class-wide type interfaces using the underlying type to handle limited-withed types.