From 6a76d2166ce933df0b010f83004cb10f5dde4fb3 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 28 Aug 2007 11:34:54 +0200 Subject: [PATCH] Add new tests. From-SVN: r127853 --- gcc/testsuite/gnat.dg/prefix2.adb | 31 ++++++++++++++ gcc/testsuite/gnat.dg/prefix2.ads | 17 ++++++++ gcc/testsuite/gnat.dg/remote_type.adb | 26 ++++++++++++ gcc/testsuite/gnat.dg/remote_type.ads | 24 +++++++++++ gcc/testsuite/gnat.dg/specs/ai_116.ads | 23 +++++++++++ gcc/testsuite/gnat.dg/specs/private_with.ads | 16 ++++++++ .../gnat.dg/specs/with_containers.ads | 27 +++++++++++++ gcc/testsuite/gnat.dg/test_table1.adb | 40 +++++++++++++++++++ 8 files changed, 204 insertions(+) create mode 100644 gcc/testsuite/gnat.dg/prefix2.adb create mode 100644 gcc/testsuite/gnat.dg/prefix2.ads create mode 100644 gcc/testsuite/gnat.dg/remote_type.adb create mode 100644 gcc/testsuite/gnat.dg/remote_type.ads create mode 100644 gcc/testsuite/gnat.dg/specs/ai_116.ads create mode 100644 gcc/testsuite/gnat.dg/specs/private_with.ads create mode 100644 gcc/testsuite/gnat.dg/specs/with_containers.ads create mode 100644 gcc/testsuite/gnat.dg/test_table1.adb diff --git a/gcc/testsuite/gnat.dg/prefix2.adb b/gcc/testsuite/gnat.dg/prefix2.adb new file mode 100644 index 00000000000..562bdf495d0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/prefix2.adb @@ -0,0 +1,31 @@ +-- { dg-do compile } + + package body prefix2 is + procedure Positionne (Objet : in out Instance; X, Y : Coordonnee) is + begin + Objet.X := X; + Objet.Y := Y; + end Positionne; + function RetourneX (Objet : in Instance) return Coordonnee is + begin + return Objet.X; + end RetourneX; + function RetourneY (Objet : in Instance) return Coordonnee is + begin + return Objet.Y; + end RetourneY; + procedure Affiche (Objet : in Class; EstVisible : Boolean) is + begin + if EstVisible then + Objet.Allume; + else + Objet.Eteins; + end if; + end Affiche; + procedure Deplace (Objet : in out Class; DX, DY : Coordonnee) is + begin + Objet.Affiche (False); -- erreur + Objet.Positionne (Objet.X + DX, Objet.Y + DY); + Objet.Affiche (True); -- erreur + end Deplace; + end prefix2; diff --git a/gcc/testsuite/gnat.dg/prefix2.ads b/gcc/testsuite/gnat.dg/prefix2.ads new file mode 100644 index 00000000000..5e7b2b27b6b --- /dev/null +++ b/gcc/testsuite/gnat.dg/prefix2.ads @@ -0,0 +1,17 @@ + + package prefix2 is + type Coordonnee is range -100 .. 100; + type Instance is abstract tagged private; + subtype Class is Instance'Class; + procedure Positionne (Objet : in out Instance; X, Y : Coordonnee); + function RetourneX (Objet : in Instance) return Coordonnee; + function RetourneY (Objet : in Instance) return Coordonnee; + procedure Allume (Objet : in Instance) is abstract; + procedure Eteins (Objet : in Instance) is abstract; + procedure Affiche (Objet : in Class; EstVisible : Boolean); + procedure Deplace (Objet : in out Class; DX, DY : Coordonnee); + private + type Instance is abstract tagged record + X, Y : Coordonnee := 0; + end record; + end; diff --git a/gcc/testsuite/gnat.dg/remote_type.adb b/gcc/testsuite/gnat.dg/remote_type.adb new file mode 100644 index 00000000000..788f795889f --- /dev/null +++ b/gcc/testsuite/gnat.dg/remote_type.adb @@ -0,0 +1,26 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +package body remote_type is + procedure Append + (Container : in out List; + New_Item : in Element_Type) + is + begin + null; + end Append; + procedure Read + (S : access Root_Stream_Type'Class; + L : out List) + is + begin + null; + end Read; + procedure Write + (S : access Root_Stream_Type'Class; + L : in List) + is + begin + null; + end Write; +end remote_type; diff --git a/gcc/testsuite/gnat.dg/remote_type.ads b/gcc/testsuite/gnat.dg/remote_type.ads new file mode 100644 index 00000000000..79c27106b78 --- /dev/null +++ b/gcc/testsuite/gnat.dg/remote_type.ads @@ -0,0 +1,24 @@ +with Ada.Streams; +generic + type Element_Type is private; +package remote_type is + pragma Remote_Types; + type List is private; + procedure Append + (Container : in out List; + New_Item : in Element_Type); +private + use Ada.Streams; + type List_Record is record + A : Boolean; + end record; + type List is access List_Record; + procedure Read + (S : access Root_Stream_Type'Class; + L : out List); + for List'Read use Read; + procedure Write + (S : access Root_Stream_Type'Class; + L : in List); + for List'Write use Write; +end remote_type; diff --git a/gcc/testsuite/gnat.dg/specs/ai_116.ads b/gcc/testsuite/gnat.dg/specs/ai_116.ads new file mode 100644 index 00000000000..88d7e987688 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/ai_116.ads @@ -0,0 +1,23 @@ +-- { dg-do compile } + +with Ada.Finalization; use Ada; +package ai_116 is + pragma Preelaborate; + type Buffer_Type is limited interface; + + type Handle is new Finalization.Limited_Controlled and Buffer_Type with + private; + pragma Preelaborable_Initialization(Handle); + + type Ptr is access all String; + Null_Handle : constant Handle; + +private + type Handle is new Finalization.Limited_Controlled and Buffer_Type with + record + Data : Ptr := null; + end record; + + Null_Handle : constant Handle := + (Finalization.Limited_Controlled with Data => null); +end ai_116; diff --git a/gcc/testsuite/gnat.dg/specs/private_with.ads b/gcc/testsuite/gnat.dg/specs/private_with.ads new file mode 100644 index 00000000000..f339e5a43b3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/private_with.ads @@ -0,0 +1,16 @@ +-- { dg-do compile } + +private with Ada.Containers.Ordered_Maps; +with Ada.Containers.Ordered_Sets; +with Ada.Unchecked_Deallocation; +package private_with is + + type String_Access is access String; + + package Index_Sets is new Ada.Containers.Ordered_Sets + (Element_Type => Positive); + + procedure Free is new Ada.Unchecked_Deallocation + (Object => String, + Name => String_Access); +end; diff --git a/gcc/testsuite/gnat.dg/specs/with_containers.ads b/gcc/testsuite/gnat.dg/specs/with_containers.ads new file mode 100644 index 00000000000..f2329cf88ec --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/with_containers.ads @@ -0,0 +1,27 @@ +-- { dg-do compile } + +pragma Warnings (Off); +with Ada.Containers.Doubly_Linked_Lists; +with Ada.Containers.Hashed_Maps; +with Ada.Containers.Hashed_Sets; +with Ada.Containers.Indefinite_Doubly_Linked_Lists; +with Ada.Containers.Indefinite_Hashed_Maps; +with Ada.Containers.Indefinite_Hashed_Sets; +with Ada.Containers.Indefinite_Ordered_Maps; +with Ada.Containers.Indefinite_Ordered_Multisets; +with Ada.Containers.Indefinite_Ordered_Sets; +with Ada.Containers.Indefinite_Vectors; +with Ada.Containers.Ordered_Maps; +with Ada.Containers.Ordered_Multisets; +with Ada.Containers.Ordered_Sets; +with Ada.Containers.Prime_Numbers; +with Ada.Containers.Red_Black_Trees.Generic_Keys; +with Ada.Containers.Red_Black_Trees.Generic_Operations; +with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; +with Ada.Containers.Red_Black_Trees; +with Ada.Containers.Restricted_Doubly_Linked_Lists; +with Ada.Containers.Vectors; + +package With_Containers is + pragma Remote_Types; +end With_Containers; diff --git a/gcc/testsuite/gnat.dg/test_table1.adb b/gcc/testsuite/gnat.dg/test_table1.adb new file mode 100644 index 00000000000..64155bfd81a --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_table1.adb @@ -0,0 +1,40 @@ +-- { dg-do run } + +with GNAT.Table; +with Ada.Text_IO; use Ada.Text_IO; + +procedure test_table1 is + type Rec is record + A, B, C, D, E : Integer := 0; + F, G, H, I, J : Integer := 1; + K, L, M, N, O : Integer := 2; + end record; + + R : Rec; + + package Tab is new GNAT.Table (Rec, Positive, 1, 4, 30); + + Last : Natural; + +begin + R.O := 3; + + Tab.Append (R); + + for J in 1 .. 1_000_000 loop + Last := Tab.Last; + begin + Tab.Append (Tab.Table (Last)); + exception + when others => + Put_Line ("exception raise for J =" & J'Img); + raise; + end; + + if Tab.Table (Tab.Last) /= R then + Put_Line ("Last is not what is expected"); + Put_Line (J'Img); + return; + end if; + end loop; +end; -- 2.30.2