New test cases.

From-SVN: r123612

gcc/testsuite/gnat.dg/access1.adb

@@ -0,0 +1,22 @@
+-- { dg-do compile }
+
+procedure access1 is
+   protected Objet is
+      procedure p;
+   end Objet;
+   protected body Objet is
+      procedure p is
+      begin
+         null;
+      end p;
+   end Objet;
+   type wrapper is record
+      Ptr : access protected procedure := Objet.p'access;
+   end record;
+   It : wrapper;
+   PP : access protected procedure;
+begin
+   PP := Objet.p'access;
+   PP.all;
+   It.Ptr.all;
+end;

gcc/testsuite/gnat.dg/access2.adb

@@ -0,0 +1,18 @@
+-- { dg-do compile }
+
+procedure access2 is
+  Arr : array (1..10) of aliased Float;
+  type Acc is access all Float;
+  procedure Set (X : integer) is
+     Buffer: String (1..8);
+     for Buffer'address use Arr (4)'address;
+  begin
+     Arr (X) := 31.1415;
+  end;
+  function Get (C : Integer) return Acc is
+  begin
+     return Arr (C)'access;
+  end;
+begin
+   null;
+end;

gcc/testsuite/gnat.dg/access_test.adb

@@ -0,0 +1,33 @@
+-- { dg-do run }
+
+procedure Access_Test is
+
+   type T1 is tagged null record;
+
+   procedure Proc_1 (P : access T1'Class)  is
+      type Ref is access T1'Class;
+      X : Ref := new T1'Class'(P.all);  -- Should always work (no exception)
+
+   begin
+      null;
+   end;
+
+   procedure Proc_2 is
+      type T2 is new T1 with null record;
+      X2 : aliased T2;
+
+   begin
+      Proc_1 (X2'access);
+
+      declare
+         type T3 is new T1 with null record;
+         X3 :  aliased T3;
+
+      begin
+         Proc_1 (X3'access);
+      end;
+   end;
+
+begin
+   Proc_2;
+end;

gcc/testsuite/gnat.dg/aggr1.adb

@@ -0,0 +1,50 @@
+-- { dg-do run }
+
+procedure aggr1 is
+   package Coord is
+      type T is private;
+   private 
+      type T is record
+          A, B, C : Float;
+      end record;
+   end Coord;
+--
+   generic 
+      type T is private;
+   package gen is
+      type Rec (Discr : Boolean := True) is record
+         needs_update : Boolean;
+         case Discr is
+            when True => null;
+            when False =>  Value : T;
+         end case;
+      end record;
+   end gen;
+--
+   subtype Graph_Range is integer range 1..1665;
+   type arr is array (Graph_Range) of Coord.T;
+--
+   package Inst is new Gen (arr);
+--
+   subtype Index is integer range 1 .. 1;
+--
+   type Graph_Node (Active : Boolean := False) is
+      record
+         case Active is
+            when True =>
+               Comp1 : Inst.Rec;
+               Comp2 : Inst.Rec;
+               Comp3 : Inst.Rec;
+            when False =>
+               Needs_Update : Boolean;
+         end case;
+      end record;
+--   
+   Null_Graph_Node : constant Graph_Node := (False, True);
+   type Graph_Table_T is array (Index) of Graph_Node;
+--
+   Graph_Table   : Graph_Table_T := (others => (Null_Graph_Node));
+   Graph_Table_1 : Graph_Table_T := (others => (False, True));
+begin
+   null;
+end;

gcc/testsuite/gnat.dg/aggr2.adb

@@ -0,0 +1,21 @@
+-- { dg-do compile }
+
+procedure aggr2 is
+   task type T_Task;
+-- 
+   task body T_Task is begin null; end;
+-- 
+   type Lim_Rec is record
+      T : T_Task;
+   end record;
+-- 
+   generic
+      Formal : Lim_Rec;
+   package P_G is
+   end P_G;
+-- 
+   package P is new P_G (Formal => (T => <>));
+begin
+   null;
+end;
+

gcc/testsuite/gnat.dg/alignment2.adb

@@ -0,0 +1,47 @@
+-- { dg-do run }
+
+procedure alignment2 is
+   
+   pragma COMPONENT_ALIGNMENT(STORAGE_UNIT);
+   
+   MAX_LIST_SIZE : constant INTEGER := 128*16;
+   
+   LEVEL2_SIZE : constant INTEGER := 128;
+           
+           LEVEL1_SIZE : constant INTEGER
+              := (MAX_LIST_SIZE - 1) / LEVEL2_SIZE + 1;
+           
+           type LEVEL2_ARRAY_TYPE is
+              array (1..LEVEL2_SIZE) of Integer;
+           
+           type LEVEL2_TYPE is
+              record
+                 NUM  : INTEGER := 0;
+                 DATA : LEVEL2_ARRAY_TYPE := ( others => 0 );
+              end record;
+           
+           type LEVEL2_PTR_TYPE is access all LEVEL2_TYPE;
+           
+           type LEVEL1_ARRAY_TYPE is
+              array( 1..LEVEL1_SIZE ) of LEVEL2_PTR_TYPE;
+           
+           type LEVEL1_TYPE is
+              record
+                 LAST_LINE  : INTEGER := 0;
+                 LEVEL2_PTR : LEVEL1_ARRAY_TYPE;
+              end record;
+           
+           L1 : LEVEL1_TYPE;
+           L2 : aliased LEVEL2_TYPE;
+   
+   procedure q (LA : in out LEVEL1_ARRAY_TYPE) is
+   begin
+      LA (1) := L2'Access;
+   end;
+
+begin
+   q (L1.LEVEL2_PTR);
+   if L1.LEVEL2_PTR (1) /= L2'Access then
+     raise Program_Error;
+   end if;
+end;

gcc/testsuite/gnat.dg/alignment3.adb

@@ -0,0 +1,35 @@
+-- { dg-do compile }
+
+with System, Ada.Unchecked_Conversion;
+procedure alignment3 is
+   
+   type Value_Type (Is_Short : Boolean) is record
+      case Is_Short is
+         when True =>   V : Natural;
+         when others => A, B : Natural;
+      end case;
+   end record;
+   
+   type Link_Type (Short_Values : Boolean) is record
+      Input, Output : Value_Type (Short_Values);
+      Initialized : Boolean;
+      N_Probes    : Natural;
+   end record;
+   
+   type Link_Access is access Link_Type;
+   
+   type Natural_Access is access all Natural;
+   function To_Natural_Access is
+      new Ada.Unchecked_Conversion (System.Address, Natural_Access);
+   
+   Ptr : Natural_Access;
+   
+   procedure N_Probes_For (Link : Link_Access)  is
+   begin
+      Ptr := To_Natural_Access (Link.N_Probes'address);
+      Ptr := To_Natural_Access (Link.Initialized'address);
+   end;
+
+begin
+   null;
+end;

gcc/testsuite/gnat.dg/check1.adb

@@ -0,0 +1,8 @@
+-- { dg-do compile }
+
+package body Check1 is
+   function FD (X : access R) return P2 is
+   begin
+      return P2 (X.Disc);
+   end FD;
+end Check1;

gcc/testsuite/gnat.dg/check1.ads

@@ -0,0 +1,6 @@
+package Check1 is
+   type Arr is array (Integer range <>) of Integer;
+   type P2 is access all Arr;
+   type R (Disc : access Arr) is limited null record;
+   function FD (X : access R) return P2;
+end Check1;

gcc/testsuite/gnat.dg/debug1.ads

@@ -0,0 +1,21 @@
+package debug1 is
+  
+  type Vector is array (Natural range <>) of Natural;
+  type Vector_Access is access Vector;
+        
+  type Data_Line is record
+    Length : Vector (1 .. 1);
+    Line   : Vector_Access;
+  end record;
+  
+  type Data_Block is array (1 .. 5) of Data_Line;
+  type Data_Block_Access is access Data_Block;
+        
+  type Vector_Ptr is access Vector;
+        
+  type Meta_Data is record
+    Vector_View : Vector_Ptr;
+    Block_View  : Data_Block_Access;
+  end record;
+        
+end;    

gcc/testsuite/gnat.dg/entry_queues.adb

@@ -0,0 +1,54 @@
+-- { dg-do run }
+-- { dg-options "-gnatws" }
+
+procedure entry_queues is
+  F1_Poe : Integer := 18;
+  function F1 return Integer is
+  begin
+    F1_Poe := F1_Poe - 1;
+    return F1_Poe;
+  end F1;
+  generic
+    type T is limited private;
+    with function Is_Ok (X : T) return Boolean;
+  procedure Check; 
+  procedure Check is
+  begin
+    declare
+      type Poe is new T;
+      X : Poe;
+      Y : Poe;
+    begin
+      null;
+    end;
+    declare
+      type Poe is new T;
+      type Arr is array (1 .. 2) of Poe;
+      X : Arr;
+      B : Boolean := Is_Ok (T (X (1)));
+    begin
+      null; 
+    end;
+  end;
+  protected type Poe (D3 : Integer := F1) is
+    entry E (D3 .. F1);    -- F1 evaluated
+    function Is_Ok return Boolean;
+  end Poe;
+  protected body Poe is
+    Entry E (for I in D3 .. F1) when True is
+    begin
+      null;
+    end E;
+    function Is_Ok return Boolean is
+    begin
+      return False;
+    end Is_Ok;
+  end Poe;
+  function Is_Ok (C : Poe) return Boolean is
+  begin
+    return C.Is_Ok;
+  end Is_Ok;
+  procedure Chk is new Check (Poe, Is_Ok);
+begin
+   Chk;
+end;

gcc/testsuite/gnat.dg/equal1.ads

@@ -0,0 +1,8 @@
+package equal1 is
+  type Basic_Connection_Status_T is (Connected, Temporary_Disconnected,
+     Disconnected);
+  for Basic_Connection_Status_T'Size use 8;
+  type Application_Connection_Status_T is (Connected, Disconnected);
+  for Application_Connection_Status_T'Size use 8;
+end equal1;
+

gcc/testsuite/gnat.dg/ext1.ads

@@ -0,0 +1,12 @@
+package ext1 is
+    type I_Smiley is interface;
+    procedure Set_Mood (Obj : out I_Smiley) is abstract;
+--      
+    type Smiley (Max : Positive) is abstract new I_Smiley with record
+       S : String (1 .. Max);
+    end record; 
+--      
+    type Regular_Smiley is new Smiley (3) with null record; 
+    overriding
+    procedure Set_Mood (Obj : out Regular_Smiley);
+end ext1;

gcc/testsuite/gnat.dg/finalized.adb

@@ -0,0 +1,9 @@
+-- { dg-do compile }
+
+with Ada.Finalization; use Ada.Finalization;
+procedure finalized is
+   type Rec is new Controlled with null record;
+   Obj : access Rec := new Rec'(Controlled with null record);
+begin
+   null;
+end;

gcc/testsuite/gnat.dg/graphic.adb

@@ -0,0 +1,20 @@
+-- { dg-do compile }
+
+with Ada.Tags.Generic_Dispatching_Constructor;
+package body Graphic is
+--
+  function Dispatching_Input is new Tags.Generic_Dispatching_Constructor
+    (T           => Object,
+     Parameters  => Streams.Root_Stream_Type'Class,
+    Constructor => Object'Input);
+--
+  function XML_Input
+    (S : access Streams.Root_Stream_Type'Class) return Object'Class
+  is
+    Result : constant Object'Class :=
+        Dispatching_Input (Tags.Internal_Tag (" "), S);
+    begin
+      return Result;
+    end XML_Input;
+end Graphic;
+

gcc/testsuite/gnat.dg/graphic.ads

@@ -0,0 +1,9 @@
+with Ada.Streams;
+with Ada.Tags;
+package Graphic is
+  use Ada;
+--
+  type Object is abstract tagged null record;
+  function XML_Input (S : access Streams.Root_Stream_Type'Class)
+     return Object'Class;
+end Graphic;

gcc/testsuite/gnat.dg/interface1.adb

@@ -0,0 +1,23 @@
+-- { dg-do run }
+
+with System;
+procedure Interface1 is
+   package Pkg is
+      type I1 is interface;
+      type Root is tagged record
+         Data : string (1 .. 300);
+      end record;
+      type DT is new Root and I1 with null record;
+   end Pkg;
+   use Pkg; 
+   use type System.Address; 
+   Obj : DT;
+   procedure IW (O : I1'Class) is 
+   begin
+      if O'Address /= Obj'Address then
+         raise Program_Error;
+      end if;
+   end IW;
+begin   
+   IW (Obj);
+end Interface1;

gcc/testsuite/gnat.dg/interface2.adb

@@ -0,0 +1,22 @@
+-- { dg-do run }
+
+procedure interface2 is
+ package Types is
+    type Iface     is synchronized interface;
+    type Any_Iface is access all Iface'Class;
+--  
+    protected type T_PO (S : Integer) is new Iface with end;
+    task type T_Task    (R : Any_Iface);
+--  
+    Obj_1 : aliased T_PO (0);
+    Obj_2 : T_Task (Obj_1'Access); --  Test
+  end Types;
+--
+  package body Types is
+    protected body T_PO is end;
+    task body T_Task    is begin null; end;
+  end Types;
+--
+begin
+   null;
+end;

gcc/testsuite/gnat.dg/iprot_test.adb

@@ -0,0 +1,35 @@
+-- { dg-do run }
+
+procedure iprot_test is
+      type T1 is tagged  null record;
+      package PP is
+         protected type P is
+            procedure S (X : T1'Class);
+         private
+            R2 : access T1'Class;
+         end P;
+      end PP;
+      package body PP is
+         protected body P is
+            procedure S (X : T1'Class) is
+            begin
+               R2 := new T1'Class'(X);
+               if R2 /= null then
+                  null;
+               end if;
+            end S;
+         end P;
+      end PP;
+      use PP;
+      Prot : P;
+      procedure Proc is
+         type T2 is new T1 with null record;
+         X2 : T2;
+      begin
+         Prot.S (X2);
+      end Proc;
+begin
+   Proc;
+exception
+   when Program_Error => null;
+end iprot_test;

gcc/testsuite/gnat.dg/md5_test.adb

@@ -0,0 +1,15 @@
+-- { dg-do run }
+
+with GNAT.MD5; use GNAT.MD5;
+procedure md5_test is
+   TEST7  : constant String := "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq";
+        
+   Expected : constant Message_Digest :=
+      "8215ef0796a20bcaaae116d3876c664a";
+   MD : Context;
+begin   
+   Update (MD, TEST7);
+   if Digest (MD) /= Expected then
+      raise Program_Error;
+   end if;
+end;

gcc/testsuite/gnat.dg/mutable1.adb

@@ -0,0 +1,29 @@
+-- { dg-do run }
+
+procedure mutable1 is
+            
+   type Object (Valid : Boolean := False) is record
+      case Valid is
+         when True  => Stamp : Natural;
+         when False => null;
+      end case;
+   end record;
+      
+   function Dummy_Object (Should_Be_There : Boolean) Return Object is
+   begin 
+      if not Should_Be_There then
+         raise Program_Error;
+      end if;
+      return Object'(Valid => False);
+   end;
+
+   procedure Check (Create_Dummy : Boolean) is
+      B : Boolean;
+   begin
+      B := Create_Dummy and then Dummy_Object (Create_Dummy).Valid;
+   end;
+
+begin
+   Check (Create_Dummy => False); 
+   Check (Create_Dummy => True);
+end;

gcc/testsuite/gnat.dg/named_test.adb

@@ -0,0 +1,26 @@
+-- { dg-do run }
+
+with Text_IO; use Text_IO;
+procedure Named_Test is
+   type Base is tagged limited record
+      Flag  : boolean;
+      Value : integer;
+   end record;
+-- 
+   function Build (X : Integer; Y : Integer) return Base is
+   begin
+      return Result : Base do
+         Result.Flag := (X = Y);
+         Result.Value := X * Y;
+      end return;
+   end;
+-- 
+   type Table is array (1..1) of Base;
+   It : Table := (1 => Build ( Y => 17, X => 11));
+begin
+  if It (1).Flag
+    or else It (1).Value /= 187
+  then
+     raise Program_Error;
+  end if;
+end;

gcc/testsuite/gnat.dg/nat1.ads

@@ -0,0 +1,5 @@
+   with System;
+   package NAT1 is
+      Nat_One_Storage : constant Natural := 1;
+      One_Address : constant System.Address := Nat_One_Storage'Address;
+   end;

gcc/testsuite/gnat.dg/nat1r.adb

@@ -0,0 +1,11 @@
+-- { dg-do run }
+
+   with System, NAT1; use NAT1;
+   procedure Nat1R is
+      use type System.Address;
+   begin
+      if One_Address /= Nat_One_Storage'Address then
+         raise Constraint_Error;
+      end if;
+   end;
+

gcc/testsuite/gnat.dg/no_final.adb

@@ -0,0 +1,29 @@
+-- { dg-do run }
+
+pragma Restrictions (No_Finalization);
+procedure no_final is
+   package P is
+      type T is tagged null record;
+      type T1 is new T with record
+         A : String (1..80);
+      end record;
+      function F return T'Class;
+   end P;
+   
+   Str : String (1..80) := (1..80=>'x');
+   
+   package body P is
+      function F return T'Class is
+         X : T1 := T1'(A => Str);
+      begin
+         return X;
+      end F;
+   end P;
+   
+   Obj : P.T'class := P.F;
+begin
+   if P.T1 (Obj).A /= Str then
+      raise Constraint_Error;
+   end if;
+end;
+

gcc/testsuite/gnat.dg/prefix1.adb

@@ -0,0 +1,8 @@
+package body prefix1 is
+   Counter : Integer := 2;
+   Table : Arr := (2, 4, 8, 16, 32, 64, 128, 256, 512, 1024);
+   function Func (Object : T) return Arr is
+   begin
+      return Table;
+   end; 
+end prefix1;

gcc/testsuite/gnat.dg/prefix1.ads

@@ -0,0 +1,5 @@
+package prefix1 is
+   type Arr is array (1..10) of Natural;
+   type T is tagged null record;
+   function Func (Object : T) return Arr;
+end prefix1;

gcc/testsuite/gnat.dg/rational_arithmetic.ads

@@ -0,0 +1,37 @@
+package Rational_Arithmetic is
+  -- Whole numbers
+  type Whole is new Integer;
+--
+  -- Undefine unwanted operations
+  function "/" (Left, Right: Whole) return Whole is abstract;
+--
+  -- Rational numbers
+--
+  type Rational is private;
+--
+  -- Constructors
+--
+  function "/" (Left, Right: Whole) return Rational;
+--
+  -- Rational operations
+--
+  function "-" (Left, Right: Rational) return Rational;
+--
+  -- Mixed operations
+--
+  function "+" (Left: Whole   ; Right: Rational) return Rational;
+  function "-" (Left: Whole   ; Right: Rational) return Rational;
+  function "-" (Left: Rational; Right: Whole   ) return Rational;
+  function "/" (Left: Whole   ; Right: Rational) return Rational;
+  function "*" (Left: Whole   ; Right: Rational) return Rational;
+  function "*" (Left: Rational; Right: Whole   ) return Rational;
+--
+  -- Relational
+--
+  function "=" (Left: Rational; Right: Whole) return Boolean;
+--
+private
+  type Rational is record
+    Numerator, Denominator: Whole;
+  end record;
+end Rational_Arithmetic;

gcc/testsuite/gnat.dg/renaming1.adb

@@ -0,0 +1,14 @@
+-- { dg-do compile}
+-- { dg-options "-gnatwa" }
+
+with Text_IO;
+use Text_IO;
+use type Text_IO.File_Access;
+package body renaming1 is
+   procedure Fo (A : Text_IO.File_Access) is
+   begin
+      if A = Text_IO.Standard_Output then
+         null;
+      end if;
+   end Fo;
+end;

gcc/testsuite/gnat.dg/renaming1.ads

@@ -0,0 +1,4 @@
+with Text_IO;
+package renaming1 is
+   procedure Fo (A : Text_IO.File_Access);
+end;

gcc/testsuite/gnat.dg/return1.adb

@@ -0,0 +1,11 @@
+-- { dg-do compile }
+-- { dg-options "-gnatwa" }
+
+package body return1 is
+    function X_Func (O : access Child) return access Base'Class is
+    begin
+       return X_Local : access Child'Class do
+          X_Local := O;
+       end return;
+    end X_Func;
+end return1;

gcc/testsuite/gnat.dg/return1.ads

@@ -0,0 +1,7 @@
+package return1 is
+    type Base is abstract tagged null record;
+    type Child is new Base with record
+       Anon_Access : access Base'Class;
+    end record;
+    function X_Func (O : access Child) return access Base'Class;
+end return1;

gcc/testsuite/gnat.dg/slice1.adb

@@ -0,0 +1,19 @@
+-- { dg-do compile }
+-- { dg-options "-O2" }
+
+function slice1 (Offset : Integer) return String is
+   
+   Convert : constant String := "0123456789abcdef";
+   Buffer  : String (1 .. 32);
+   Pos     : Natural := Buffer'Last;
+   Value   : Long_Long_Integer := Long_Long_Integer (Offset);
+
+begin
+   while Value > 0 loop
+      Buffer (Pos) := Convert (Integer (Value mod 16));
+      Pos := Pos - 1;
+      Value := Value / 16;
+   end loop;
+   
+   return Buffer (Pos + 1 .. Buffer'Last);
+end;

gcc/testsuite/gnat.dg/specs/pack2.ads

@@ -0,0 +1,10 @@
+-- { dg-do compile }
+
+package Pack2 is 
+   type Rec is record
+       Ptr: access Character;
+       Int :Integer;
+   end record;
+   type Table is array (1..2) of rec;
+   pragma Pack (Table);
+end Pack2;

gcc/testsuite/gnat.dg/test_debug1.adb

@@ -0,0 +1,9 @@
+-- { dg-do compile }
+-- { dg-options "-g" }
+
+with debug1; use debug1;
+procedure test_debug1 is
+  Blob : Meta_Data;
+begin
+  null;
+end;

gcc/testsuite/gnat.dg/test_delay.adb

@@ -0,0 +1,8 @@
+-- { dg-do run }
+
+with Ada.Real_Time;
+        
+procedure Test_Delay is
+begin
+   delay until Ada.Real_Time.Clock;
+end Test_Delay;

gcc/testsuite/gnat.dg/test_equal1.adb

@@ -0,0 +1,13 @@
+-- { dg-do compile }
+
+with equal1;
+procedure test_equal1 is
+  subtype Boolean_T is Boolean;
+  function "=" (L, R : in equal1.Basic_Connection_Status_T)
+    return Boolean_T renames equal1."=";
+  Status : equal1.Basic_Connection_Status_T;
+  Result : Boolean_T;
+begin
+  Status := equal1.Temporary_Disconnected;
+  Result := Status /= equal1.Connected;
+end;

gcc/testsuite/gnat.dg/test_ext1.adb

@@ -0,0 +1,8 @@
+-- { dg-do compile }
+
+with ext1; use ext1;
+procedure test_ext1 is
+    X : Regular_Smiley;
+begin
+    X.Set_Mood;
+end;

gcc/testsuite/gnat.dg/test_prefix1.adb

@@ -0,0 +1,15 @@
+-- {dg-do run }
+
+with prefix1; use prefix1;
+procedure test_prefix1 is
+   Val : Natural;
+   Obj  : T;
+--
+begin
+   for J in Obj.Func'Range loop
+      Val := Obj.Func (J);
+      if Val /= 2 ** J then
+         raise Program_Error;
+      end if;
+   end loop;
+end test_prefix1;

gcc/testsuite/gnat.dg/test_rational_arithmetic.adb

@@ -0,0 +1,15 @@
+-- { dg-do compile }
+
+with Rational_Arithmetic;
+use  Rational_Arithmetic;
+procedure Test_Rational_Arithmetic is
+  R: Rational := 10/2;
+  B: Boolean  := R = 5/1;  -- RHS cannot be a Whole
+                           -- ("/" has been "undefined")
+  C: Boolean  := R = Rational' (5/1);
+  D: Boolean  := (6/3) = R;
+  E: Boolean  := (2/1 = 4/2);
+begin
+  R := 1+1/(4/8);
+  R := 2*(3/2)-(7/3)*3;
+end Test_Rational_Arithmetic;

gcc/testsuite/gnat.dg/unc.adb

@@ -0,0 +1,26 @@
+-- { dg-do compile }
+
+with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
+procedure Unc is
+   type Arr is array (1..4) of integer;
+   type Bytes is array (positive range <>) of Character;
+   type Buffer (D : Boolean := False) is record
+      case D is 
+        when False =>
+           Chars: Bytes (1..16);
+        when True =>
+           Values : Arr;
+      end case;
+   end record;
+--
+   pragma Unchecked_Union (Buffer);
+   pragma Warnings (Off);
+   Val : Buffer;
+--      
+   F : File_Type;
+   S : Stream_Access;
+begin
+   Create (F, Out_File);
+   S := Stream (F);
+   Buffer'Output (S, Val);
+end;

gcc/testsuite/gnat.dg/volatile1.ads

@@ -0,0 +1,22 @@
+package volatile1 is
+
+   type Command is (Nothing, Get);
+
+   type Data is
+      record
+         Time : Duration;
+      end record;
+
+   type Data_Array is array (Integer range <>) of Data;
+
+   type Command_Data (Kind : Command; Length : Integer) is
+      record
+         case Kind is
+            when Nothing =>
+               null;
+            when Get =>
+               Data : Data_Array (1 .. Length);
+         end case;
+      end record;
+
+end;

gcc/testsuite/gnat.dg/volatile2.adb

@@ -0,0 +1,22 @@
+-- { dg-do compile }
+-- { dg-options "-gnatws" }
+
+package body volatile2 is
+  
+  procedure Copy is
+    R : Result;
+    M : Integer;
+    subtype Get_Data is Command_Data (Get, R.Data'Last);       
+  begin                                                        
+    declare
+      G : Get_Data;
+      for G'Address use M'Address;
+    begin
+      for I in 1 .. R.Data'Last loop
+        G.Data (I) := (Time => R.Data (I).Time);
+      end loop;
+    end;
+  end;
+
+end volatile2;
+

gcc/testsuite/gnat.dg/volatile2.ads

@@ -0,0 +1,16 @@
+with volatile1; use volatile1;
+
+package volatile2 is
+   
+   type PData_Array is access Data_Array;
+   
+   type Result_Desc is
+      record
+         Data : PData_Array;
+      end record;
+   
+   type Result is access Result_Desc;
+   
+   procedure Copy;
+
+end volatile2;