From 73c25d9b9d65cef556afa3782c58e47422bdea0b Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 20 May 2008 12:49:20 +0000 Subject: [PATCH] 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 --- gcc/testsuite/ChangeLog | 7 ++++ gcc/testsuite/gnat.dg/modular1.adb | 15 +++++++++ gcc/testsuite/gnat.dg/specs/tag2.ads | 2 +- gcc/testsuite/gnat.dg/test_iface_aggr.adb | 40 +++++++++++++++++++++++ gcc/testsuite/gnat.dg/testint.adb | 13 ++++++++ 5 files changed, 76 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gnat.dg/modular1.adb create mode 100644 gcc/testsuite/gnat.dg/test_iface_aggr.adb create mode 100644 gcc/testsuite/gnat.dg/testint.adb 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 + + * 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 * 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; -- 2.30.2