gcc/testsuite/gnat.dg/iprot_test.adb

   1 -- { dg-do run }
   2
   3 procedure iprot_test is
   4       type T1 is tagged  null record;
   5       package PP is
   6          protected type P is
   7             procedure S (X : T1'Class);
   8          private
   9             R2 : access T1'Class;
  10          end P;
  11       end PP;
  12       package body PP is
  13          protected body P is
  14             procedure S (X : T1'Class) is
  15             begin
  16                R2 := new T1'Class'(X);
  17                if R2 /= null then
  18                   null;
  19                end if;
  20             end S;
  21          end P;
  22       end PP;
  23       use PP;
  24       Prot : P;
  25       procedure Proc is
  26          type T2 is new T1 with null record;
  27          X2 : T2;
  28       begin
  29          Prot.S (X2);
  30       end Proc;
  31 begin
  32    Proc;
  33 exception
  34    when Program_Error => null;
  35 end iprot_test;