From: Arnaud Charlet <charlet@adacore.com>
Date: Tue, 20 May 2008 12:49:20 +0000 (+0000)
Subject: testint.adb: New test.
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=73c25d9b9d65cef556afa3782c58e47422bdea0b;p=gcc.git

testint.adb: New test.

	* gnat.dg/testint.adb: New test.
	* gnat.dg/modular1.adb: New test.
	* gnat.dg/test_iface_aggr.adb: New test.
	* gnat.dg/specs/tag2.ads: Adjust.

From-SVN: r135635
---

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index ffbddf63f42..22155ecab85 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2008-05-20  Arnaud Charlet  <charlet@adacore.com>
+
+	* gnat.dg/testint.adb: New test.
+	* gnat.dg/modular1.adb: New test.
+	* gnat.dg/test_iface_aggr.adb: New test.
+	* gnat.dg/specs/tag2.ads: Adjust.
+
 2008-05-20  Richard Guenther  <rguenther@suse.de>
 
 	* gcc.dg/tree-ssa/ssa-sink-1.c: Adjust.
diff --git a/gcc/testsuite/gnat.dg/modular1.adb b/gcc/testsuite/gnat.dg/modular1.adb
new file mode 100644
index 00000000000..b9fcde95fd6
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/modular1.adb
@@ -0,0 +1,15 @@
+--  { dg-do run }
+
+with Ada.Text_IO;
+procedure Modular1 is
+   type T1 is mod 9;
+   package T1_IO is new Ada.Text_IO.Modular_IO(T1);
+   X: T1 := 8;
+   J1: constant := 5;
+begin                                                                              for J2 in 5..5 loop
+      pragma Assert(X*(2**J1) = X*(2**J2));
+      if X*(2**J1) /= X*(2**J2) then
+         raise Program_Error;
+      end if;
+   end loop;
+end Modular1;
diff --git a/gcc/testsuite/gnat.dg/specs/tag2.ads b/gcc/testsuite/gnat.dg/specs/tag2.ads
index 8e09f25a059..67b44978dbf 100644
--- a/gcc/testsuite/gnat.dg/specs/tag2.ads
+++ b/gcc/testsuite/gnat.dg/specs/tag2.ads
@@ -10,7 +10,7 @@ package tag2 is
    type T6 is tagged;
    protected type T1 is end T1; -- { dg-error "must be a tagged type" }
    task type T2;                -- { dg-error "must be a tagged type" }
-   type T3 is null record;      -- { dg-error "must be tagged" }
+   type T3 is null record;      -- { dg-error "must be a tagged type" }
    task type T4 is new I with end;
    protected type T5 is new I with end;
    type T6 is tagged null record;
diff --git a/gcc/testsuite/gnat.dg/test_iface_aggr.adb b/gcc/testsuite/gnat.dg/test_iface_aggr.adb
new file mode 100644
index 00000000000..85c1ceb0fbc
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/test_iface_aggr.adb
@@ -0,0 +1,40 @@
+--  { dg-do run }
+
+with Ada.Text_IO, Ada.Tags;
+procedure Test_Iface_Aggr is
+   package Pkg is
+     type Iface is interface;
+     function Constructor (S: Iface) return Iface'Class is abstract;
+     procedure Do_Test (It : Iface'class);
+     type Root is abstract tagged record
+        Comp_1 : Natural := 0; 
+     end record;
+     type DT_1 is new Root and Iface with record
+         Comp_2, Comp_3 : Natural := 0;
+     end record;
+     function Constructor (S: DT_1) return Iface'Class;
+     type DT_2 is new DT_1 with null record;  --  Test
+     function Constructor (S: DT_2) return Iface'Class;
+   end; 
+   package body Pkg is
+      procedure Do_Test (It: in Iface'Class) is
+         Obj : Iface'Class := Constructor (It);
+         S   : String := Ada.Tags.External_Tag (Obj'Tag);
+      begin
+         null;
+      end;
+     function Constructor (S: DT_1) return Iface'Class is
+     begin
+       return Iface'Class(DT_1'(others => <>));
+     end;
+     function Constructor (S: DT_2) return Iface'Class is
+       Result : DT_2;
+     begin
+       return Iface'Class(DT_2'(others => <>));    --  Test
+     end;
+   end;
+   use Pkg;
+   Obj: DT_2;
+begin
+   Do_Test (Obj);
+end;
diff --git a/gcc/testsuite/gnat.dg/testint.adb b/gcc/testsuite/gnat.dg/testint.adb
new file mode 100644
index 00000000000..a5faf4a57ff
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/testint.adb
@@ -0,0 +1,13 @@
+--  { dg-do run }
+--  { dg-options "-gnato" }
+
+with Text_IO; use Text_IO;
+procedure testint is
+   function m1 (a, b : short_integer) return integer is
+   begin                          
+      return integer (a + b);
+   end m1;
+   f : integer;
+begin   
+   f := m1 (short_integer'Last, short_integer'Last);
+end testint;