Add new tests

From-SVN: r125480

gcc/testsuite/gnat.dg/addr1.adb

@@ -0,0 +1,17 @@
+with System;
+package body addr1 is
+   task type T is
+      entry Send (Location : System.Address);
+   end;
+   task body T is
+   begin
+      accept Send (Location : System.Address) do
+        declare
+           Buffer : String (1 .. 100);
+           for Buffer'Address use Location;  --  Test
+        begin
+           null;
+        end;
+     end Send;
+   end;
+end;

gcc/testsuite/gnat.dg/addr1.ads

@@ -0,0 +1,5 @@
+--  { dg-do compile }
+
+package addr1 is
+   pragma Elaborate_Body;
+end;

gcc/testsuite/gnat.dg/array1.adb

@@ -0,0 +1,32 @@
+--  { dg-do compile }
+--  { dg-options "-gnatws" }
+
+package body array1 is
+  
+  subtype Small is Integer range 1 .. MAX;
+  
+  type LFT is record
+    RIC_ID : RIC_TYPE;
+  end record;
+  
+  LF : array (RIC_TYPE, Small) of LFT;
+  
+  procedure Foo (R : RIC_TYPE) is
+    L : Small;
+    T : LFT renames LF (R, L);
+  begin
+    Start_Timer (T'ADDRESS);
+  end;
+  
+  procedure Bar (A : Integer; R : RIC_TYPE) is
+    S : LFT renames LF (R, A);
+  begin
+    null;
+  end;
+  
+  procedure Start_Timer (Q : SYSTEM.ADDRESS) is
+  begin                                                        
+    null;                                                      
+  end;
+
+end array1;

gcc/testsuite/gnat.dg/array1.ads

@@ -0,0 +1,9 @@
+with SYSTEM;
+WITH array2; use array2;
+
+package array1 is
+  
+  procedure Foo (R : RIC_TYPE);
+  procedure Start_Timer (Q : SYSTEM.ADDRESS);
+
+end array1;

gcc/testsuite/gnat.dg/array2.ads

@@ -0,0 +1,8 @@
+package array2 is
+  
+  type RIC_TYPE is (RIC1, RIC2);
+  for RIC_TYPE'SIZE use 32;
+  
+  function MAX return Integer;
+
+end array2;

gcc/testsuite/gnat.dg/conv_bug.adb

@@ -0,0 +1,30 @@
+--  { dg-do run }
+--  { dg-options "-gnatws" }
+
+with discr3; use discr3;
+with Text_IO; use Text_IO;
+procedure Conv_Bug is
+begin
+   begin
+      V2 := S2 (V1);
+   exception
+      when Constraint_Error => null;
+      when others => Put_Line ("Wrong Exception raised");
+   end;
+   
+   begin
+      V2 := S2(V1(V1'Range));
+      Put_Line ("No exception raised - 2");
+   exception
+      when Constraint_Error => null;
+      when others => Put_Line ("Wrong Exception raised");
+   end;
+   
+   begin
+      V2 := S2 (V3);
+      Put_Line ("No exception raised - 3");
+   exception
+      when Constraint_Error => null;
+      when others => Put_Line ("Wrong Exception raised");
+   end;
+end Conv_Bug;

gcc/testsuite/gnat.dg/discr1.ads

@@ -0,0 +1,25 @@
+package discr1 is
+
+  type R is (One, Two);
+
+  type C_Type (Kind : R) is
+  record
+    case Kind is
+      when One =>
+        Name       : Integer;
+      when Two =>
+        Designator : String (1 .. 40);
+    end case;
+  end record;
+  
+  for C_Type use record
+    Name        at   0 range 0.. 31;
+    Designator  at   0 range 0..319;
+    Kind        at  40 range 0..  7;
+  end record;
+  
+  for C_Type'Size use 44 * 8;
+  
+  procedure Assign (Id : String);
+
+end discr1;

gcc/testsuite/gnat.dg/discr2.adb

@@ -0,0 +1,22 @@
+--  { dg-do compile }
+
+with discr1; use discr1;
+
+package body discr2 is
+  
+  procedure Copy (Dataset : in out C_Type) is
+    Last_Char : Positive := 300;
+  begin
+    while (Last_Char > 40) loop
+      Last_Char := Last_Char - 1;
+    end loop;
+    
+    Assign (Dataset.Designator (1 .. Last_Char));
+  end;
+  
+  procedure Dummy is
+  begin
+    null;
+  end Dummy;
+
+end discr2;

gcc/testsuite/gnat.dg/discr2.ads

@@ -0,0 +1,5 @@
+package discr2 is
+  
+  procedure Dummy;
+
+end discr2;

gcc/testsuite/gnat.dg/discr3.ads

@@ -0,0 +1,11 @@
+package discr3 is
+   type E  is range  0..255;
+   type R1 is range  1..5;
+   type R2 is range 11..15;
+   type S1 is array(R1 range <>) of E;
+   type S2 is array(R2 range <>) of E;
+   V1 : S1( 2..3)  := (0,0);
+   V2 : S2(12..13) := (1,1);
+   subtype R3 is R1 range 2..3;
+   V3 : S1 (R3);
+end discr3;

gcc/testsuite/gnat.dg/elab1.ads

@@ -0,0 +1,23 @@
+package elab1 is
+  
+  -- the forward declaration is the trigger
+  type Stream;
+  
+  type Stream_Ptr is access Stream;
+  
+  type Stream is array (Positive range <>) of Character;
+  
+  function Get_Size (S : Stream_Ptr) return Natural;
+  
+  type Rec (Size : Natural) is
+    record
+      B : Boolean;
+    end record;
+  
+  My_Desc : constant Stream_Ptr := new Stream'(1 => ' ');
+  
+  My_Size : constant Natural := Get_Size (My_Desc);
+  
+  subtype My_Rec is Rec (My_Size);
+
+end;

gcc/testsuite/gnat.dg/elab2.adb

@@ -0,0 +1,10 @@
+--  { dg-do compile }
+--  { dg-options "-gnatws" }
+
+with elab1;
+
+procedure elab2 is
+  A : elab1.My_Rec;
+begin
+  null;
+end;

gcc/testsuite/gnat.dg/expect1.adb

@@ -0,0 +1,15 @@
+--  { dg-do run }
+
+with GNAT.Expect; use GNAT.Expect;
+with Ada.Text_IO; use Ada.Text_IO;
+procedure expect1 is
+   Process : Process_Descriptor;
+begin
+   begin
+      Close (Process);
+      raise Program_Error;
+   exception
+      when Invalid_Process =>
+         null;  -- expected
+   end;
+end expect1;

gcc/testsuite/gnat.dg/socket1.adb

@@ -0,0 +1,14 @@
+-- { dg-do run }
+
+with GNAT.Sockets; use GNAT.Sockets;
+procedure socket1 is
+   X : Character;
+begin
+   X := 'x';
+   GNAT.Sockets.Initialize;
+   declare
+      H : Host_Entry_Type := Get_Host_By_Address (Inet_Addr ("127.0.0.1"));
+   begin
+      null;
+   end;
+end socket1;

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

@@ -0,0 +1,13 @@
+-- { dg-do compile }
+
+package constructor is
+   type R (Name_Length : Natural) is record
+      Name     : Wide_String (1..Name_Length);
+      Multiple : Boolean;
+   end record;
+   
+   Null_Params : constant R :=
+     (Name_Length => 0,
+      Name        => "",
+      Multiple    => False);
+end;

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

@@ -0,0 +1,9 @@
+-- { dg-do compile }
+
+with Ada.Finalization;
+package preelab is
+   type T is limited private;
+   pragma Preelaborable_Initialization (T);
+private    
+   type T is new Ada.Finalization.Limited_Controlled with null record;
+end preelab;

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

@@ -0,0 +1,21 @@
+-- { dg-do compile }
+
+with System;
+with System.Storage_Elements;
+with Unchecked_Conversion;
+
+package UC1 is
+
+  function Conv is
+    new Unchecked_Conversion (Source => System.Address, Target => Integer);
+  function Conv is
+    new Unchecked_Conversion (Source => Integer, Target => System.Address);
+
+  M : constant System.Address := System.Storage_Elements.To_Address(0);
+  N : constant System.Address := Conv (Conv (M) + 1);
+  A : constant System.Address := Conv (Conv (N) + 1);
+
+  I : Integer;
+  for I use at A;
+
+end UC1;

gcc/testsuite/gnat.dg/test_enum_io.adb

@@ -0,0 +1,33 @@
+--  { dg-do run }
+
+with Ada.Text_IO;
+use  Ada.Text_IO;
+
+procedure Test_Enum_IO is
+
+  type Enum is (Literal);
+  package Enum_IO is new Enumeration_IO (Enum);
+  use Enum_IO;
+
+  File : File_Type;
+  Value: Enum;
+  Rest : String (1 ..30);
+  Last : Natural; 
+  
+begin
+  
+  Create (File, Mode => Out_File);
+  Put_Line (File, "Literax0000000l note the 'l' at the end");
+  
+  Reset (File, Mode => In_File);
+  Get (File, Value); 
+  Get_Line (File, Rest, Last);
+  
+  Close (File);
+  
+  Put_Line (Enum'Image (Value) & Rest (1 .. Last));
+  raise Program_Error;
+
+exception
+  when Data_Error => null;
+end Test_Enum_IO;

gcc/testsuite/gnat.dg/test_fixed_io.adb

@@ -0,0 +1,34 @@
+--  { dg-do run }
+
+with Ada.Text_IO; use Ada.Text_IO;
+
+procedure test_fixed_io is
+   type FX is delta 0.0001 range -3.0 .. 250.0;
+   for FX'Small use 0.0001;
+   package FXIO is new Fixed_IO (FX);
+   use FXIO;
+   ST : String (1 .. 11)  := (others => ' ');
+   ST2 : String (1 .. 12) := (others => ' ');
+
+   N : constant FX := -2.345;
+begin
+   begin
+      Put (ST, N, 6, 2);
+      Put_Line ("*ERROR* Test1: Exception Layout_Error was not raised");
+      Put_Line ("ST = """ & ST & '"');
+   exception
+      when Layout_Error =>
+         null;
+      when others =>
+         Put_Line ("Test1: Unexpected exception");
+   end;
+
+   begin
+      Put (ST2, N, 6, 2);
+   exception
+      when Layout_Error =>
+         Put_Line ("*ERROR* Test2: Exception Layout_Error was raised");
+      when others =>
+         Put_Line ("Test2: Unexpected exception");
+   end;
+end;

gcc/testsuite/gnat.dg/test_unknown_discrs.adb

@@ -0,0 +1,31 @@
+--  { dg-do compile }
+
+procedure Test_Unknown_Discrs is
+   
+   package Display is
+
+      type Component_Id (<>) is limited private;
+
+      Deferred_Const : constant Component_Id;
+   
+   private
+      
+      type Component_Id is (Clock);
+
+      type Rec1 is record
+         C : Component_Id := Deferred_Const;
+      end record;
+
+      Priv_Cid_Object : Component_Id := Component_Id'First;
+
+      type Rec2 is record
+         C : Component_Id := Priv_Cid_Object;
+      end record;
+
+      Deferred_Const : constant Component_Id := Priv_Cid_Object;
+   
+   end Display;
+
+begin
+   null;
+end Test_Unknown_Discrs;

gcc/testsuite/gnat.dg/warn1.adb

@@ -0,0 +1,12 @@
+--  { dg-do run }
+--  { dg-options "-gnatwae" }
+
+procedure warn1 is
+   pragma Warnings
+     (Off, "variable ""Unused"" is never read and never assigned");
+   Unused : Integer;
+   pragma Warnings
+     (On, "variable ""Unused"" is never read and never assigned");
+begin
+   null;
+end warn1;