gcc/testsuite/gnat.dg/inline_tagged.adb

   1 -- { dg-do run }
   2 -- { dg-options "-gnatN" }
   3
   4 with Text_IO; use Text_IO;
   5 with system; use system;
   6 procedure inline_tagged is
   7    package Pkg is
   8       type T_Inner is tagged record
   9          Value : Integer;
  10       end record;
  11       type T_Inner_access is access all T_Inner;
  12       procedure P2 (This : in T_Inner; Ptr : address);
  13       pragma inline (P2);
  14       type T_Outer is record
  15            Inner : T_Inner_Access;
  16       end record;
  17       procedure P1 (This : access T_Outer);
  18    end Pkg;
  19    package body Pkg is
  20       procedure P2 (This : in T_Inner; Ptr : address) is
  21       begin
  22          if this'address /= Ptr then
  23             raise Program_Error;
  24          end if;
  25       end;
  26       procedure P1 (This : access T_Outer) is
  27       begin
  28          P2 (This.Inner.all, This.Inner.all'Address);
  29       end P1;
  30    end Pkg;
  31    use Pkg;
  32    Thing : aliased T_Outer := (inner => new T_Inner);
  33 begin
  34    P1 (Thing'access);
  35 end;