gcc/testsuite/gnat.dg/strub_intf2.adb

   1 --  { dg-do compile }
   2 --  { dg-require-effective-target strub }
   3
   4 --  Check that strub mode mismatches between overrider and overridden
   5 --  subprograms are reported even when the overriders for an
   6 --  interface's subprograms are inherited from a type that is not a
   7 --  descendent of the interface.
   8
   9 procedure Strub_Intf2 is
  10    package Foo is
  11       type A is tagged null record;
  12
  13       procedure P (I : Integer; X : A);
  14       pragma Machine_Attribute (P, "strub", "at-calls"); -- { dg-error "requires the same .strub. mode" }
  15
  16       function F (X : access A) return Integer;
  17
  18       type TX is Interface;
  19
  20       procedure P (I : Integer; X : TX) is abstract;
  21
  22       function F (X : access TX) return Integer is abstract;
  23       pragma Machine_Attribute (F, "strub", "at-calls");
  24
  25       type B is new A and TX with null record; -- { dg-error "requires the same .strub. mode" }
  26
  27    end Foo;
  28
  29    package body Foo is
  30       procedure P (I : Integer; X : A) is
  31       begin
  32          null;
  33       end;
  34
  35       function F (X : access A) return Integer is (0);
  36
  37    end Foo;
  38
  39    use Foo;
  40
  41    procedure Q (X : TX'Class) is
  42    begin
  43       P (-1, X);
  44    end;
  45
  46    XB : aliased B;
  47    I : Integer := 0;
  48    XC : access TX'Class;
  49 begin
  50    Q (XB);
  51
  52    I := I + F (XB'Access);
  53
  54    XC := XB'Access;
  55    I := I + F (XC);
  56 end Strub_Intf2;