From a03cc04adeb5fc670bab991aa2380e83dbf0b988 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 26 Mar 2008 09:07:07 +0100 Subject: [PATCH] New tests From-SVN: r133593 --- gcc/testsuite/gnat.dg/forward_anon.adb | 8 ++++++ gcc/testsuite/gnat.dg/forward_anon.ads | 9 +++++++ gcc/testsuite/gnat.dg/iface1.ads | 12 +++++++++ gcc/testsuite/gnat.dg/iface2.adb | 7 ++++++ gcc/testsuite/gnat.dg/iface2.ads | 6 +++++ gcc/testsuite/gnat.dg/init_scalar1.adb | 16 ++++++++++++ gcc/testsuite/gnat.dg/self1.adb | 21 ++++++++++++++++ .../gnat.dg/specs/restricted_pkg.ads | 10 ++++++++ gcc/testsuite/gnat.dg/test_bip_no_alloc.adb | 24 ++++++++++++++++++ gcc/testsuite/gnat.dg/too_many_tasks.adb | 25 +++++++++++++++++++ 10 files changed, 138 insertions(+) create mode 100644 gcc/testsuite/gnat.dg/forward_anon.adb create mode 100644 gcc/testsuite/gnat.dg/forward_anon.ads create mode 100644 gcc/testsuite/gnat.dg/iface1.ads create mode 100644 gcc/testsuite/gnat.dg/iface2.adb create mode 100644 gcc/testsuite/gnat.dg/iface2.ads create mode 100644 gcc/testsuite/gnat.dg/init_scalar1.adb create mode 100644 gcc/testsuite/gnat.dg/self1.adb create mode 100644 gcc/testsuite/gnat.dg/specs/restricted_pkg.ads create mode 100644 gcc/testsuite/gnat.dg/test_bip_no_alloc.adb create mode 100644 gcc/testsuite/gnat.dg/too_many_tasks.adb diff --git a/gcc/testsuite/gnat.dg/forward_anon.adb b/gcc/testsuite/gnat.dg/forward_anon.adb new file mode 100644 index 00000000000..bce495e228e --- /dev/null +++ b/gcc/testsuite/gnat.dg/forward_anon.adb @@ -0,0 +1,8 @@ +-- { dg-do compile } + +package body Forward_Anon is + function Get_Current return access Object is + begin + return Current_Object; + end; +end; diff --git a/gcc/testsuite/gnat.dg/forward_anon.ads b/gcc/testsuite/gnat.dg/forward_anon.ads new file mode 100644 index 00000000000..ff68ff400d3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/forward_anon.ads @@ -0,0 +1,9 @@ +package Forward_Anon is + type Object is null record; + function Get_Current return access Object; + Current_Object : constant access Object; + + private + One_Object : aliased Object; + Current_Object : constant access Object := One_Object'Access; +end; diff --git a/gcc/testsuite/gnat.dg/iface1.ads b/gcc/testsuite/gnat.dg/iface1.ads new file mode 100644 index 00000000000..bfe90a30320 --- /dev/null +++ b/gcc/testsuite/gnat.dg/iface1.ads @@ -0,0 +1,12 @@ +generic + type Data is private; +package Iface1 is + type Future is synchronized interface; + type Any_Future is access all Future; + + procedure Get (This : in out Future; P : out Data) is abstract; + procedure Set (This : in out Future; P : in Data) is abstract; + + type Reusable_Future is synchronized interface and Future; + type Any_Reusable_Future is access all Reusable_Future'Class; +end Iface1; diff --git a/gcc/testsuite/gnat.dg/iface2.adb b/gcc/testsuite/gnat.dg/iface2.adb new file mode 100644 index 00000000000..c565599521e --- /dev/null +++ b/gcc/testsuite/gnat.dg/iface2.adb @@ -0,0 +1,7 @@ +-- { dg-do compile } +package body Iface2 is + procedure change (This, That : Prot.Any_Future) is + begin + null; + end; +end Iface2; diff --git a/gcc/testsuite/gnat.dg/iface2.ads b/gcc/testsuite/gnat.dg/iface2.ads new file mode 100644 index 00000000000..d25bc4246c0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/iface2.ads @@ -0,0 +1,6 @@ +with Iface1; +generic + with package Prot is new Iface1 (<>); +package Iface2 is + procedure change (This, That : Prot.Any_Future); +end Iface2; diff --git a/gcc/testsuite/gnat.dg/init_scalar1.adb b/gcc/testsuite/gnat.dg/init_scalar1.adb new file mode 100644 index 00000000000..2688e929896 --- /dev/null +++ b/gcc/testsuite/gnat.dg/init_scalar1.adb @@ -0,0 +1,16 @@ +-- { dg-do run } +-- { dg-options "-gnatws -gnatVa" } + +pragma Initialize_Scalars; +procedure init_scalar1 is + type Fixed_3T is delta 2.0 ** (- 4) + range - 2.0 ** 19 .. (2.0 ** 19 - 2.0 ** (- 4)); + for Fixed_3T'Size use 3*8; + + Write_Value : constant Fixed_3T := Fixed_3T(524287.875); + type singleton is array (1 .. 1) of Fixed_3T; + pragma Pack (singleton); + it : Singleton; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/self1.adb b/gcc/testsuite/gnat.dg/self1.adb new file mode 100644 index 00000000000..dc6f485b8fe --- /dev/null +++ b/gcc/testsuite/gnat.dg/self1.adb @@ -0,0 +1,21 @@ +-- { dg-do compile } + +procedure Self1 is + type Event; + + type Link (E : access Event) is limited record + Val : Integer; + end record; + + type Ptr is access all Event; + + type Event is tagged limited record + Inner : Link (Event'access); + Size : Integer; + end record; + + Obj2 : Ptr := new Event'(Inner => (Event'access, 15), + Size => Link'size); +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/specs/restricted_pkg.ads b/gcc/testsuite/gnat.dg/specs/restricted_pkg.ads new file mode 100644 index 00000000000..cfd84699426 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/restricted_pkg.ads @@ -0,0 +1,10 @@ +-- { dg-do compile } +-- { dg-options "-gnatc" } + +pragma Restrictions (No_Entry_Queue); +package Restricted_Pkg is + type Iface is limited interface; + protected type PO is new Iface with + procedure Dummy; + end; +end; diff --git a/gcc/testsuite/gnat.dg/test_bip_no_alloc.adb b/gcc/testsuite/gnat.dg/test_bip_no_alloc.adb new file mode 100644 index 00000000000..82973147e3a --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_bip_no_alloc.adb @@ -0,0 +1,24 @@ +-- { dg-do compile } + +pragma Restrictions (No_Allocators); +procedure Test_BIP_No_Alloc is + + type LR (B : Boolean) is limited record + X : Integer; + end record; + + function FLR return LR is + begin + -- A return statement in a function with a limited and unconstrained + -- result subtype can result in expansion of an allocator for the + -- secondary stack, but that should not result in a violation of the + -- restriction No_Allocators. + + return (B => False, X => 123); + end FLR; + + Obj : LR := FLR; + +begin + null; +end Test_BIP_No_Alloc; diff --git a/gcc/testsuite/gnat.dg/too_many_tasks.adb b/gcc/testsuite/gnat.dg/too_many_tasks.adb new file mode 100644 index 00000000000..5d01570d634 --- /dev/null +++ b/gcc/testsuite/gnat.dg/too_many_tasks.adb @@ -0,0 +1,25 @@ +-- { dg-do run } + +procedure too_many_tasks is + Global : Natural := 0; + function Output return Integer is + begin + Global := Global + 1; + return Global; + end Output; + + task type A; + task type B; + + task body A is + I : Integer := Output; + T : B; + begin null; end A; + + task body B is + I : Integer := Output; + T : A; + begin null; end B; + + T : A; +begin null; end; -- 2.30.2