gcc/testsuite/gnat.dg/tagged3.adb

   1 --  { dg-do run }
   2
   3 with Tagged3_Pkg; use Tagged3_Pkg;
   4 procedure Tagged3 is
   5    package SP is
   6       type Ref is tagged private;
   7
   8       procedure Set (Self : in out Ref'Class; Data : Parent'Class);
   9
  10       type Reference_Type (Element : access Parent'Class)
  11          is limited null record with Implicit_Dereference => Element;
  12
  13       function Get (Self : Ref'Class) return Reference_Type;
  14
  15    private
  16       type Element_Access is access all Parent'Class;
  17       type Ref is tagged record
  18          Data : Element_Access;
  19       end record;
  20    end;
  21
  22    package body SP is
  23       procedure Set (Self : in out Ref'Class; Data : Parent'Class) is
  24       begin
  25          Self.Data := new Parent'Class'(Data);
  26       end;
  27
  28       function Get (Self : Ref'Class) return Reference_Type is
  29       begin
  30          return Reference_Type'(Element => Self.Data);
  31       end;
  32    end;
  33
  34    DC : Child;
  35    RC : SP.Ref;
  36 begin
  37    RC.Set (DC);
  38    Prim1 (RC.Get.Element); -- Test
  39    if not Tagged3_Pkg.Child_Prim1_Called then
  40      raise Program_Error;
  41    end if;
  42 end;