gcc/testsuite/gnat.dg/strub_disp.adb

   1 --  { dg-do compile }
   2 --  { dg-require-effective-target strub }
   3
   4 procedure Strub_Disp is
   5    package Foo is
   6       type A is tagged null record;
   7
   8       procedure P (I : Integer; X : A);
   9       pragma Machine_Attribute (P, "strub", "at-calls");
  10
  11       function F (X : access A) return Integer;
  12
  13       type B is new A with null record;
  14
  15       overriding
  16       procedure P (I : Integer; X : B); -- { dg-error "requires the same .strub. mode" }
  17
  18       overriding
  19       function F (X : access B) return Integer;
  20       pragma Machine_Attribute (F, "strub", "at-calls"); -- { dg-error "requires the same .strub. mode" }
  21
  22    end Foo;
  23
  24    package body Foo is
  25       procedure P (I : Integer; X : A) is
  26       begin
  27          null;
  28       end;
  29
  30       function F (X : access A) return Integer is (0);
  31
  32       overriding
  33       procedure P (I : Integer; X : B) is
  34       begin
  35          P (I, A (X));
  36       end;
  37
  38       overriding
  39       function F (X : access B) return Integer is (1);
  40    end Foo;
  41
  42    use Foo;
  43
  44    procedure Q (X : A'Class) is
  45    begin
  46       P (-1, X);
  47    end;
  48
  49    XA : aliased A;
  50    XB : aliased B;
  51    I : Integer := 0;
  52    XC : access A'Class;
  53 begin
  54    Q (XA);
  55    Q (XB);
  56
  57    I := I + F (XA'Access);
  58    I := I + F (XB'Access);
  59
  60    XC := XA'Access;
  61    I := I + F (XC);
  62
  63    XC := XB'Access;
  64    I := I + F (XC);
  65 end Strub_Disp;