gcc/testsuite/gnat.dg/missing_acc_check.adb

   1 --  { dg-do run }
   2
   3 procedure Missing_Acc_Check is
   4
   5    Test_Failed : Exception;
   6
   7    type Int_Access is access all Integer;
   8
   9    Save : Int_Access := null;
  10
  11    type Int_Rec is record
  12       Int : aliased Integer;
  13    end record;
  14
  15    type Ltd_Rec (IR_Acc : access Int_Rec) is limited null record;
  16
  17    function Pass_Rec (IR_Acc : access Int_Rec) return Int_Access is
  18    begin
  19       return IR_Acc.Int'Access;  -- Accessibility check here
  20    end Pass_Rec;
  21
  22    procedure Proc is
  23       IR : aliased Int_Rec;
  24       LR : Ltd_Rec (IR'Access);
  25    begin
  26       Save := Pass_Rec (LR.IR_Acc);  -- Must raise Program_Error;
  27
  28       if Save /= null then
  29          raise Test_Failed;
  30       end if;
  31
  32    exception
  33       when Program_Error =>
  34          null;
  35    end Proc;
  36
  37 begin
  38    Proc;
  39 end Missing_Acc_Check;