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 <mira...@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.
Index: einfo.adb =================================================================== --- einfo.adb (revision 251863) +++ einfo.adb (working copy) @@ -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)) Index: exp_attr.adb =================================================================== --- exp_attr.adb (revision 251863) +++ exp_attr.adb (working copy) @@ -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