From 04fdb7f8c7c88bea2186581af4e4dea9a9e17cbe Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 16 Aug 2007 15:29:34 +0200 Subject: [PATCH] Add new tests. From-SVN: r127554 --- gcc/testsuite/gnat.dg/access3.adb | 16 +++++++ gcc/testsuite/gnat.dg/access3.ads | 11 +++++ gcc/testsuite/gnat.dg/access4.adb | 9 ++++ gcc/testsuite/gnat.dg/bad_array.adb | 7 +++ gcc/testsuite/gnat.dg/discr4.adb | 47 +++++++++++++++++++++ gcc/testsuite/gnat.dg/dispatch2.adb | 10 +++++ gcc/testsuite/gnat.dg/dispatch2_p.adb | 7 +++ gcc/testsuite/gnat.dg/dispatch2_p.ads | 8 ++++ gcc/testsuite/gnat.dg/renaming2.adb | 61 +++++++++++++++++++++++++++ gcc/testsuite/gnat.dg/specs/gnati.ads | 13 ++++++ gcc/testsuite/gnat.dg/warn3.adb | 15 +++++++ 11 files changed, 204 insertions(+) create mode 100644 gcc/testsuite/gnat.dg/access3.adb create mode 100644 gcc/testsuite/gnat.dg/access3.ads create mode 100644 gcc/testsuite/gnat.dg/access4.adb create mode 100644 gcc/testsuite/gnat.dg/bad_array.adb create mode 100644 gcc/testsuite/gnat.dg/discr4.adb create mode 100644 gcc/testsuite/gnat.dg/dispatch2.adb create mode 100644 gcc/testsuite/gnat.dg/dispatch2_p.adb create mode 100644 gcc/testsuite/gnat.dg/dispatch2_p.ads create mode 100644 gcc/testsuite/gnat.dg/renaming2.adb create mode 100644 gcc/testsuite/gnat.dg/specs/gnati.ads create mode 100644 gcc/testsuite/gnat.dg/warn3.adb diff --git a/gcc/testsuite/gnat.dg/access3.adb b/gcc/testsuite/gnat.dg/access3.adb new file mode 100644 index 00000000000..db109b3d24f --- /dev/null +++ b/gcc/testsuite/gnat.dg/access3.adb @@ -0,0 +1,16 @@ + +package body access3 is + + type IT_Access is not null access all IT'Class; + for IT_Access'Storage_Size use 0; + + procedure Op + (Obj_T2 : in out T2; + Obj_IT : not null access IT'Class) + is + X : constant IT_Access := Obj_IT.all'Unchecked_Access; + begin + null; + end Op; + +end access3; diff --git a/gcc/testsuite/gnat.dg/access3.ads b/gcc/testsuite/gnat.dg/access3.ads new file mode 100644 index 00000000000..18d453b329e --- /dev/null +++ b/gcc/testsuite/gnat.dg/access3.ads @@ -0,0 +1,11 @@ + +package access3 is + type IT is limited interface; + type T is limited new IT with null record; + + type T2 is tagged limited null record; + + procedure Op + (Obj_T2 : in out T2; + Obj_IT : not null access IT'Class); +end access3; diff --git a/gcc/testsuite/gnat.dg/access4.adb b/gcc/testsuite/gnat.dg/access4.adb new file mode 100644 index 00000000000..2b006274135 --- /dev/null +++ b/gcc/testsuite/gnat.dg/access4.adb @@ -0,0 +1,9 @@ +-- { dg-do run } + +with access3; use access3; +procedure access4 is + Obj_IT : aliased T; + Obj_T2 : T2; +begin + Obj_T2.Op (Obj_IT'Access); +end; diff --git a/gcc/testsuite/gnat.dg/bad_array.adb b/gcc/testsuite/gnat.dg/bad_array.adb new file mode 100644 index 00000000000..5d49f9ba68d --- /dev/null +++ b/gcc/testsuite/gnat.dg/bad_array.adb @@ -0,0 +1,7 @@ +-- { dg-do compile } + +procedure Bad_Array is + A1 : array(Character range <> ) of Character := ( 'a', 'b', 'c' ); +begin + null; +end Bad_Array; diff --git a/gcc/testsuite/gnat.dg/discr4.adb b/gcc/testsuite/gnat.dg/discr4.adb new file mode 100644 index 00000000000..859daaf7fe3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr4.adb @@ -0,0 +1,47 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +procedure discr4 is + package Pkg is + type Rec_Comp (D : access Integer) is record + Data : Integer; + end record; +-- + type I is interface; + procedure Test (Obj : I) is abstract; +-- + Num : aliased Integer := 10; +-- + type Root (D : access Integer) is tagged record + C1 : Rec_Comp (D); -- test + end record; +-- + type DT is new Root and I with null record; +-- + procedure Dummy (Obj : DT); + procedure Test (Obj : DT); + end; +-- + package body Pkg is + procedure Dummy (Obj : DT) is + begin + raise Program_Error; + end; +-- + procedure Test (Obj : DT) is + begin + null; + end; + end; +-- + use Pkg; +-- + procedure CW_Test (Obj : I'Class) is + begin + Obj.Test; + end; +-- + Obj : DT (Num'Access); +begin + CW_Test (Obj); +end; diff --git a/gcc/testsuite/gnat.dg/dispatch2.adb b/gcc/testsuite/gnat.dg/dispatch2.adb new file mode 100644 index 00000000000..ed57b13359e --- /dev/null +++ b/gcc/testsuite/gnat.dg/dispatch2.adb @@ -0,0 +1,10 @@ +-- { dg-do run } + +with dispatch2_p; use dispatch2_p; +procedure dispatch2 is + Obj : Object_Ptr := new Object; +begin + if Obj.Get_Ptr /= Obj.Impl_Of then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/dispatch2_p.adb b/gcc/testsuite/gnat.dg/dispatch2_p.adb new file mode 100644 index 00000000000..243c3ca977a --- /dev/null +++ b/gcc/testsuite/gnat.dg/dispatch2_p.adb @@ -0,0 +1,7 @@ +-- +package body dispatch2_p is + function Impl_Of (Self : access Object) return Object_Ptr is + begin + return Object_Ptr (Self); + end Impl_Of; +end; diff --git a/gcc/testsuite/gnat.dg/dispatch2_p.ads b/gcc/testsuite/gnat.dg/dispatch2_p.ads new file mode 100644 index 00000000000..e7852b446b5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/dispatch2_p.ads @@ -0,0 +1,8 @@ +package dispatch2_p is + type Object is tagged null record; + type Object_Ptr is access all Object'CLASS; +-- + function Impl_Of (Self : access Object) return Object_Ptr; + function Get_Ptr (Self : access Object) return Object_Ptr + renames Impl_Of; +end; diff --git a/gcc/testsuite/gnat.dg/renaming2.adb b/gcc/testsuite/gnat.dg/renaming2.adb new file mode 100644 index 00000000000..0ec89c2f3ab --- /dev/null +++ b/gcc/testsuite/gnat.dg/renaming2.adb @@ -0,0 +1,61 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +with Text_IO; +procedure renaming2 is + type RealNodeData; + type RefRealNodeData is access RealNodeData; + + type ExpressionEntry; + type RefExpression is access ExpressionEntry; + + type RefDefUseEntry is access Natural; + + type ExpressionEntry is + record + Number : RefDefUseEntry; + Id : Integer; + end record; + + type RealNodeData is + record + Node : RefExpression; + Id : Integer; + end record; + + for ExpressionEntry use + record + Number at 0 range 0 .. 63; + Id at 8 range 0 .. 31; + end record ; + + for RealNodeData use + record + Node at 0 range 0 .. 63; + Id at 8 range 0 .. 31; + end record ; + + U_Node : RefDefUseEntry := new Natural'(1); + E_Node : RefExpression := new ExpressionEntry'(Number => U_Node, + Id => 2); + R_Node : RefRealNodeData := new RealNodeData'(Node => E_Node, + Id => 3); + + procedure test_routine (NodeRealData : RefRealNodeData) + is + OldHead : RefDefUseEntry renames NodeRealData.all.Node.all.Number; + OldHead1 : constant RefDefUseEntry := OldHead; + begin + NodeRealData.all.Node := new ExpressionEntry'(Number => null, Id => 4); + declare + OldHead2 : constant RefDefUseEntry := OldHead; + begin + if OldHead1 /= OldHead2 + then + Text_IO.Put_Line (" OldHead changed !!!"); + end if; + end; + end; +begin + test_routine (R_Node); +end; diff --git a/gcc/testsuite/gnat.dg/specs/gnati.ads b/gcc/testsuite/gnat.dg/specs/gnati.ads new file mode 100644 index 00000000000..72eff6e2ecd --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/gnati.ads @@ -0,0 +1,13 @@ +-- { dg-do compile } +-- { dg-options "-gnatI" } + +package gnati is + type j is range 1 .. 50; + for j'size use 1; + type n is new integer; + for n'alignment use -99; + type e is (a, b); + for e use (1, 1); + type r is record x : integer; end record; + for r use record x at 0 range 0 .. 0; end record; +end gnati; diff --git a/gcc/testsuite/gnat.dg/warn3.adb b/gcc/testsuite/gnat.dg/warn3.adb new file mode 100644 index 00000000000..66cc79bdba0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/warn3.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } +-- { dg-options "-gnatwu" } + +with Ada.Command_Line; use Ada.Command_Line; +with Text_IO; use Text_IO; +procedure warn3 is + type Weekdays is (Sun, Mon, Tue, Wed, Thu, Fri, Sat); +begin + if Argument_Count > 0 then + Put_Line + (Argument (1) & " is weekday number" + & Integer'Image + (Weekdays'Pos (Weekdays'Value (Argument (1))))); + end if; +end; -- 2.30.2