gcc/testsuite/gnat.dg/aliased_prefix_accessibility.adb

   1 --  { dg-do run }
   2
   3 with Tagged_Type_Pkg;  use Tagged_Type_Pkg;
   4 with Ada.Text_IO;      use Ada.Text_IO;
   5
   6 procedure Aliased_Prefix_Accessibility is
   7
   8   T_Obj : aliased TT;
   9
  10    T_Obj_Acc : access TT'Class := T_Obj'Access;
  11
  12    type Nested_TT is limited record
  13       TT_Comp : aliased TT;
  14    end record;
  15
  16    NTT_Obj : Nested_TT;
  17
  18    ATT_Obj : array (1 .. 2) of aliased TT;
  19
  20 begin
  21    begin
  22       T_Obj_Acc := Pass_TT_Access (T_Obj'Access);
  23       Put_Line ("FAILED (1): call should have raised an exception");
  24    exception
  25       when others =>
  26          null;
  27    end;
  28
  29    begin
  30       T_Obj_Acc := T_Obj.Pass_TT_Access;
  31       Put_Line ("FAILED (2): call should have raised an exception");
  32    exception
  33       when others =>
  34          null;
  35    end;
  36
  37    begin
  38       T_Obj_Acc := Pass_TT_Access (NTT_Obj.TT_Comp'Access);
  39       Put_Line ("FAILED (3): call should have raised an exception");
  40    exception
  41       when others =>
  42          null;
  43    end;
  44
  45    begin
  46       T_Obj_Acc := NTT_Obj.TT_Comp.Pass_TT_Access;
  47       Put_Line ("FAILED (4): call should have raised an exception");
  48    exception
  49       when others =>
  50          null;
  51    end;
  52
  53    begin
  54       T_Obj_Acc := Pass_TT_Access (ATT_Obj (1)'Access);
  55       Put_Line ("FAILED (5): call should have raised an exception");
  56    exception
  57       when others =>
  58          null;
  59    end;
  60
  61    begin
  62       T_Obj_Acc := ATT_Obj (2).Pass_TT_Access;
  63       Put_Line ("FAILED (6): call should have raised an exception");
  64    exception
  65       when others =>
  66          null;
  67    end;
  68 end Aliased_Prefix_Accessibility;