gcc/testsuite/gnat.dg/sso/r6.adb

   1 -- { dg-do run }
   2
   3 with Init6; use Init6;
   4 with Text_IO; use Text_IO;
   5 with Dump;
   6
   7 procedure R6 is
   8
   9   function Get_Elem (R : R1) return Integer is
  10     Tmp : R1 := R;
  11   begin
  12     return Tmp.A(1);
  13   end;
  14
  15   procedure Set_Elem (R : access R1; I : Integer) is
  16     Tmp : R1 := R.all;
  17   begin
  18     Tmp.A(1) := I;
  19     R.all := Tmp;
  20   end;
  21
  22   function Get_Elem (R : R2) return Integer is
  23     Tmp : R2 := R;
  24   begin
  25     return Tmp.A(1);
  26   end;
  27
  28   procedure Set_Elem (R : access R2; I : Integer) is
  29     Tmp : R2 := R.all;
  30   begin
  31     Tmp.A(1) := I;
  32     R.all := Tmp;
  33   end;
  34
  35   A1 : aliased R1 := My_R1;
  36   A2 : aliased R2 := My_R2;
  37
  38 begin
  39
  40   Put ("A1 :");
  41   Dump (A1'Address, R1'Max_Size_In_Storage_Elements);
  42   New_Line;
  43   -- { dg-output "A1 : 78 56 34 12 00 ab 00 12 00 cd 00 34 00 ef 00 56.*\n" }
  44
  45   Put ("A2 :");
  46   Dump (A2'Address, R1'Max_Size_In_Storage_Elements);
  47   New_Line;
  48   -- { dg-output "A2 : 12 34 56 78 12 00 ab 00 34 00 cd 00 56 00 ef 00.*\n" }
  49
  50   if Get_Elem (A1) /= 16#AB0012# then
  51     raise Program_Error;
  52   end if;
  53
  54   Set_Elem (A1'Access, 16#CD0034#);
  55   if Get_Elem (A1) /= 16#CD0034# then
  56     raise Program_Error;
  57   end if;
  58
  59   if Get_Elem (A2) /= 16#AB0012# then
  60     raise Program_Error;
  61   end if;
  62
  63   Set_Elem (A2'Access, 16#CD0034#);
  64   if Get_Elem (A2) /= 16#CD0034# then
  65     raise Program_Error;
  66   end if;
  67
  68 end;