gcc/testsuite/gnat.dg/bip_aggregate_bug.adb

   1 --  { dg-do run }
   2
   3 procedure BIP_Aggregate_Bug is
   4
   5    package Limited_Types is
   6
   7       type Lim_Tagged is tagged limited record
   8          Root_Comp : Integer;
   9       end record;
  10
  11       type Lim_Ext is new Lim_Tagged with record
  12          Ext_Comp : Integer;
  13       end record;
  14
  15       function Func_Lim_Tagged (Choice : Integer) return Lim_Tagged'Class;
  16
  17    end Limited_Types;
  18
  19    package body Limited_Types is
  20
  21       function Func_Lim_Tagged (Choice : Integer) return Lim_Tagged'Class is
  22       begin
  23          case Choice is
  24             when 111 =>
  25                return Lim_Ext'(Root_Comp => Choice, Ext_Comp => Choice);
  26             when 222 =>
  27                return Result : Lim_Tagged'Class
  28                         := Lim_Ext'(Root_Comp => Choice, Ext_Comp => Choice);
  29             when others =>
  30                return Lim_Tagged'(Root_Comp => Choice);
  31          end case;
  32       end Func_Lim_Tagged;
  33
  34    end Limited_Types;
  35
  36    use Limited_Types;
  37
  38    LT_Root : Lim_Tagged'Class := Func_Lim_Tagged (Choice => 999);
  39    LT_Ext1 : Lim_Tagged'Class := Func_Lim_Tagged (Choice => 111);
  40    LT_Ext2 : Lim_Tagged'Class := Func_Lim_Tagged (Choice => 222);
  41
  42 begin
  43    if LT_Root.Root_Comp /= 999
  44      or else Lim_Ext (LT_Ext1).Ext_Comp /= 111
  45      or else Lim_Ext (LT_Ext2).Ext_Comp /= 222
  46    then
  47       raise Program_Error;
  48    end if;
  49 end BIP_Aggregate_Bug;