From: Arnaud Charlet Date: Fri, 6 Apr 2007 09:44:51 +0000 (+0200) Subject: New test cases. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=0874ee9b767e78ab00f2cc82ac9f9acf8ac9ad56;p=gcc.git New test cases. From-SVN: r123612 --- diff --git a/gcc/testsuite/gnat.dg/access1.adb b/gcc/testsuite/gnat.dg/access1.adb new file mode 100644 index 00000000000..c6100051ae1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/access1.adb @@ -0,0 +1,22 @@ +-- { dg-do compile } + +procedure access1 is + protected Objet is + procedure p; + end Objet; + protected body Objet is + procedure p is + begin + null; + end p; + end Objet; + type wrapper is record + Ptr : access protected procedure := Objet.p'access; + end record; + It : wrapper; + PP : access protected procedure; +begin + PP := Objet.p'access; + PP.all; + It.Ptr.all; +end; diff --git a/gcc/testsuite/gnat.dg/access2.adb b/gcc/testsuite/gnat.dg/access2.adb new file mode 100644 index 00000000000..fd91dbea96e --- /dev/null +++ b/gcc/testsuite/gnat.dg/access2.adb @@ -0,0 +1,18 @@ +-- { dg-do compile } + +procedure access2 is + Arr : array (1..10) of aliased Float; + type Acc is access all Float; + procedure Set (X : integer) is + Buffer: String (1..8); + for Buffer'address use Arr (4)'address; + begin + Arr (X) := 31.1415; + end; + function Get (C : Integer) return Acc is + begin + return Arr (C)'access; + end; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/access_test.adb b/gcc/testsuite/gnat.dg/access_test.adb new file mode 100644 index 00000000000..6266b725a79 --- /dev/null +++ b/gcc/testsuite/gnat.dg/access_test.adb @@ -0,0 +1,33 @@ +-- { dg-do run } + +procedure Access_Test is + + type T1 is tagged null record; + + procedure Proc_1 (P : access T1'Class) is + type Ref is access T1'Class; + X : Ref := new T1'Class'(P.all); -- Should always work (no exception) + + begin + null; + end; + + procedure Proc_2 is + type T2 is new T1 with null record; + X2 : aliased T2; + + begin + Proc_1 (X2'access); + + declare + type T3 is new T1 with null record; + X3 : aliased T3; + + begin + Proc_1 (X3'access); + end; + end; + +begin + Proc_2; +end; diff --git a/gcc/testsuite/gnat.dg/aggr1.adb b/gcc/testsuite/gnat.dg/aggr1.adb new file mode 100644 index 00000000000..256b3951be0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr1.adb @@ -0,0 +1,50 @@ +-- { dg-do run } + +procedure aggr1 is + package Coord is + type T is private; + private + type T is record + A, B, C : Float; + end record; + end Coord; +-- + generic + type T is private; + package gen is + type Rec (Discr : Boolean := True) is record + needs_update : Boolean; + case Discr is + when True => null; + when False => Value : T; + end case; + end record; + end gen; +-- + subtype Graph_Range is integer range 1..1665; + type arr is array (Graph_Range) of Coord.T; +-- + package Inst is new Gen (arr); +-- + subtype Index is integer range 1 .. 1; +-- + type Graph_Node (Active : Boolean := False) is + record + case Active is + when True => + Comp1 : Inst.Rec; + Comp2 : Inst.Rec; + Comp3 : Inst.Rec; + when False => + Needs_Update : Boolean; + end case; + end record; +-- + Null_Graph_Node : constant Graph_Node := (False, True); + type Graph_Table_T is array (Index) of Graph_Node; +-- + Graph_Table : Graph_Table_T := (others => (Null_Graph_Node)); + Graph_Table_1 : Graph_Table_T := (others => (False, True)); +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/aggr2.adb b/gcc/testsuite/gnat.dg/aggr2.adb new file mode 100644 index 00000000000..3e9dc40f8b1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr2.adb @@ -0,0 +1,21 @@ +-- { dg-do compile } + +procedure aggr2 is + task type T_Task; +-- + task body T_Task is begin null; end; +-- + type Lim_Rec is record + T : T_Task; + end record; +-- + generic + Formal : Lim_Rec; + package P_G is + end P_G; +-- + package P is new P_G (Formal => (T => <>)); +begin + null; +end; + diff --git a/gcc/testsuite/gnat.dg/alignment2.adb b/gcc/testsuite/gnat.dg/alignment2.adb new file mode 100644 index 00000000000..9f1be3c5902 --- /dev/null +++ b/gcc/testsuite/gnat.dg/alignment2.adb @@ -0,0 +1,47 @@ +-- { dg-do run } + +procedure alignment2 is + + pragma COMPONENT_ALIGNMENT(STORAGE_UNIT); + + MAX_LIST_SIZE : constant INTEGER := 128*16; + + LEVEL2_SIZE : constant INTEGER := 128; + + LEVEL1_SIZE : constant INTEGER + := (MAX_LIST_SIZE - 1) / LEVEL2_SIZE + 1; + + type LEVEL2_ARRAY_TYPE is + array (1..LEVEL2_SIZE) of Integer; + + type LEVEL2_TYPE is + record + NUM : INTEGER := 0; + DATA : LEVEL2_ARRAY_TYPE := ( others => 0 ); + end record; + + type LEVEL2_PTR_TYPE is access all LEVEL2_TYPE; + + type LEVEL1_ARRAY_TYPE is + array( 1..LEVEL1_SIZE ) of LEVEL2_PTR_TYPE; + + type LEVEL1_TYPE is + record + LAST_LINE : INTEGER := 0; + LEVEL2_PTR : LEVEL1_ARRAY_TYPE; + end record; + + L1 : LEVEL1_TYPE; + L2 : aliased LEVEL2_TYPE; + + procedure q (LA : in out LEVEL1_ARRAY_TYPE) is + begin + LA (1) := L2'Access; + end; + +begin + q (L1.LEVEL2_PTR); + if L1.LEVEL2_PTR (1) /= L2'Access then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/alignment3.adb b/gcc/testsuite/gnat.dg/alignment3.adb new file mode 100644 index 00000000000..2776f5b8aaa --- /dev/null +++ b/gcc/testsuite/gnat.dg/alignment3.adb @@ -0,0 +1,35 @@ +-- { dg-do compile } + +with System, Ada.Unchecked_Conversion; +procedure alignment3 is + + type Value_Type (Is_Short : Boolean) is record + case Is_Short is + when True => V : Natural; + when others => A, B : Natural; + end case; + end record; + + type Link_Type (Short_Values : Boolean) is record + Input, Output : Value_Type (Short_Values); + Initialized : Boolean; + N_Probes : Natural; + end record; + + type Link_Access is access Link_Type; + + type Natural_Access is access all Natural; + function To_Natural_Access is + new Ada.Unchecked_Conversion (System.Address, Natural_Access); + + Ptr : Natural_Access; + + procedure N_Probes_For (Link : Link_Access) is + begin + Ptr := To_Natural_Access (Link.N_Probes'address); + Ptr := To_Natural_Access (Link.Initialized'address); + end; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/check1.adb b/gcc/testsuite/gnat.dg/check1.adb new file mode 100644 index 00000000000..f3d32333cd9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/check1.adb @@ -0,0 +1,8 @@ +-- { dg-do compile } + +package body Check1 is + function FD (X : access R) return P2 is + begin + return P2 (X.Disc); + end FD; +end Check1; diff --git a/gcc/testsuite/gnat.dg/check1.ads b/gcc/testsuite/gnat.dg/check1.ads new file mode 100644 index 00000000000..baeeda007a0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/check1.ads @@ -0,0 +1,6 @@ +package Check1 is + type Arr is array (Integer range <>) of Integer; + type P2 is access all Arr; + type R (Disc : access Arr) is limited null record; + function FD (X : access R) return P2; +end Check1; diff --git a/gcc/testsuite/gnat.dg/debug1.ads b/gcc/testsuite/gnat.dg/debug1.ads new file mode 100644 index 00000000000..3ce148cf7b3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/debug1.ads @@ -0,0 +1,21 @@ +package debug1 is + + type Vector is array (Natural range <>) of Natural; + type Vector_Access is access Vector; + + type Data_Line is record + Length : Vector (1 .. 1); + Line : Vector_Access; + end record; + + type Data_Block is array (1 .. 5) of Data_Line; + type Data_Block_Access is access Data_Block; + + type Vector_Ptr is access Vector; + + type Meta_Data is record + Vector_View : Vector_Ptr; + Block_View : Data_Block_Access; + end record; + +end; diff --git a/gcc/testsuite/gnat.dg/entry_queues.adb b/gcc/testsuite/gnat.dg/entry_queues.adb new file mode 100644 index 00000000000..5740cebb5fc --- /dev/null +++ b/gcc/testsuite/gnat.dg/entry_queues.adb @@ -0,0 +1,54 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +procedure entry_queues is + F1_Poe : Integer := 18; + function F1 return Integer is + begin + F1_Poe := F1_Poe - 1; + return F1_Poe; + end F1; + generic + type T is limited private; + with function Is_Ok (X : T) return Boolean; + procedure Check; + procedure Check is + begin + declare + type Poe is new T; + X : Poe; + Y : Poe; + begin + null; + end; + declare + type Poe is new T; + type Arr is array (1 .. 2) of Poe; + X : Arr; + B : Boolean := Is_Ok (T (X (1))); + begin + null; + end; + end; + protected type Poe (D3 : Integer := F1) is + entry E (D3 .. F1); -- F1 evaluated + function Is_Ok return Boolean; + end Poe; + protected body Poe is + Entry E (for I in D3 .. F1) when True is + begin + null; + end E; + function Is_Ok return Boolean is + begin + return False; + end Is_Ok; + end Poe; + function Is_Ok (C : Poe) return Boolean is + begin + return C.Is_Ok; + end Is_Ok; + procedure Chk is new Check (Poe, Is_Ok); +begin + Chk; +end; diff --git a/gcc/testsuite/gnat.dg/equal1.ads b/gcc/testsuite/gnat.dg/equal1.ads new file mode 100644 index 00000000000..0b6ed726149 --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal1.ads @@ -0,0 +1,8 @@ +package equal1 is + type Basic_Connection_Status_T is (Connected, Temporary_Disconnected, + Disconnected); + for Basic_Connection_Status_T'Size use 8; + type Application_Connection_Status_T is (Connected, Disconnected); + for Application_Connection_Status_T'Size use 8; +end equal1; + diff --git a/gcc/testsuite/gnat.dg/ext1.ads b/gcc/testsuite/gnat.dg/ext1.ads new file mode 100644 index 00000000000..db58e284abf --- /dev/null +++ b/gcc/testsuite/gnat.dg/ext1.ads @@ -0,0 +1,12 @@ +package ext1 is + type I_Smiley is interface; + procedure Set_Mood (Obj : out I_Smiley) is abstract; +-- + type Smiley (Max : Positive) is abstract new I_Smiley with record + S : String (1 .. Max); + end record; +-- + type Regular_Smiley is new Smiley (3) with null record; + overriding + procedure Set_Mood (Obj : out Regular_Smiley); +end ext1; diff --git a/gcc/testsuite/gnat.dg/finalized.adb b/gcc/testsuite/gnat.dg/finalized.adb new file mode 100644 index 00000000000..36400d53ecc --- /dev/null +++ b/gcc/testsuite/gnat.dg/finalized.adb @@ -0,0 +1,9 @@ +-- { dg-do compile } + +with Ada.Finalization; use Ada.Finalization; +procedure finalized is + type Rec is new Controlled with null record; + Obj : access Rec := new Rec'(Controlled with null record); +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/graphic.adb b/gcc/testsuite/gnat.dg/graphic.adb new file mode 100644 index 00000000000..282f46dddc8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/graphic.adb @@ -0,0 +1,20 @@ +-- { dg-do compile } + +with Ada.Tags.Generic_Dispatching_Constructor; +package body Graphic is +-- + function Dispatching_Input is new Tags.Generic_Dispatching_Constructor + (T => Object, + Parameters => Streams.Root_Stream_Type'Class, + Constructor => Object'Input); +-- + function XML_Input + (S : access Streams.Root_Stream_Type'Class) return Object'Class + is + Result : constant Object'Class := + Dispatching_Input (Tags.Internal_Tag (" "), S); + begin + return Result; + end XML_Input; +end Graphic; + diff --git a/gcc/testsuite/gnat.dg/graphic.ads b/gcc/testsuite/gnat.dg/graphic.ads new file mode 100644 index 00000000000..a1153de649d --- /dev/null +++ b/gcc/testsuite/gnat.dg/graphic.ads @@ -0,0 +1,9 @@ +with Ada.Streams; +with Ada.Tags; +package Graphic is + use Ada; +-- + type Object is abstract tagged null record; + function XML_Input (S : access Streams.Root_Stream_Type'Class) + return Object'Class; +end Graphic; diff --git a/gcc/testsuite/gnat.dg/interface1.adb b/gcc/testsuite/gnat.dg/interface1.adb new file mode 100644 index 00000000000..b22b949593b --- /dev/null +++ b/gcc/testsuite/gnat.dg/interface1.adb @@ -0,0 +1,23 @@ +-- { dg-do run } + +with System; +procedure Interface1 is + package Pkg is + type I1 is interface; + type Root is tagged record + Data : string (1 .. 300); + end record; + type DT is new Root and I1 with null record; + end Pkg; + use Pkg; + use type System.Address; + Obj : DT; + procedure IW (O : I1'Class) is + begin + if O'Address /= Obj'Address then + raise Program_Error; + end if; + end IW; +begin + IW (Obj); +end Interface1; diff --git a/gcc/testsuite/gnat.dg/interface2.adb b/gcc/testsuite/gnat.dg/interface2.adb new file mode 100644 index 00000000000..903d3308f80 --- /dev/null +++ b/gcc/testsuite/gnat.dg/interface2.adb @@ -0,0 +1,22 @@ +-- { dg-do run } + +procedure interface2 is + package Types is + type Iface is synchronized interface; + type Any_Iface is access all Iface'Class; +-- + protected type T_PO (S : Integer) is new Iface with end; + task type T_Task (R : Any_Iface); +-- + Obj_1 : aliased T_PO (0); + Obj_2 : T_Task (Obj_1'Access); -- Test + end Types; +-- + package body Types is + protected body T_PO is end; + task body T_Task is begin null; end; + end Types; +-- +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/iprot_test.adb b/gcc/testsuite/gnat.dg/iprot_test.adb new file mode 100644 index 00000000000..17c20215575 --- /dev/null +++ b/gcc/testsuite/gnat.dg/iprot_test.adb @@ -0,0 +1,35 @@ +-- { dg-do run } + +procedure iprot_test is + type T1 is tagged null record; + package PP is + protected type P is + procedure S (X : T1'Class); + private + R2 : access T1'Class; + end P; + end PP; + package body PP is + protected body P is + procedure S (X : T1'Class) is + begin + R2 := new T1'Class'(X); + if R2 /= null then + null; + end if; + end S; + end P; + end PP; + use PP; + Prot : P; + procedure Proc is + type T2 is new T1 with null record; + X2 : T2; + begin + Prot.S (X2); + end Proc; +begin + Proc; +exception + when Program_Error => null; +end iprot_test; diff --git a/gcc/testsuite/gnat.dg/md5_test.adb b/gcc/testsuite/gnat.dg/md5_test.adb new file mode 100644 index 00000000000..e687bdf4a01 --- /dev/null +++ b/gcc/testsuite/gnat.dg/md5_test.adb @@ -0,0 +1,15 @@ +-- { dg-do run } + +with GNAT.MD5; use GNAT.MD5; +procedure md5_test is + TEST7 : constant String := "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"; + + Expected : constant Message_Digest := + "8215ef0796a20bcaaae116d3876c664a"; + MD : Context; +begin + Update (MD, TEST7); + if Digest (MD) /= Expected then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/mutable1.adb b/gcc/testsuite/gnat.dg/mutable1.adb new file mode 100644 index 00000000000..274b52375e7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/mutable1.adb @@ -0,0 +1,29 @@ +-- { dg-do run } + +procedure mutable1 is + + type Object (Valid : Boolean := False) is record + case Valid is + when True => Stamp : Natural; + when False => null; + end case; + end record; + + function Dummy_Object (Should_Be_There : Boolean) Return Object is + begin + if not Should_Be_There then + raise Program_Error; + end if; + return Object'(Valid => False); + end; + + procedure Check (Create_Dummy : Boolean) is + B : Boolean; + begin + B := Create_Dummy and then Dummy_Object (Create_Dummy).Valid; + end; + +begin + Check (Create_Dummy => False); + Check (Create_Dummy => True); +end; diff --git a/gcc/testsuite/gnat.dg/named_test.adb b/gcc/testsuite/gnat.dg/named_test.adb new file mode 100644 index 00000000000..1d271ba5cd9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/named_test.adb @@ -0,0 +1,26 @@ +-- { dg-do run } + +with Text_IO; use Text_IO; +procedure Named_Test is + type Base is tagged limited record + Flag : boolean; + Value : integer; + end record; +-- + function Build (X : Integer; Y : Integer) return Base is + begin + return Result : Base do + Result.Flag := (X = Y); + Result.Value := X * Y; + end return; + end; +-- + type Table is array (1..1) of Base; + It : Table := (1 => Build ( Y => 17, X => 11)); +begin + if It (1).Flag + or else It (1).Value /= 187 + then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/nat1.ads b/gcc/testsuite/gnat.dg/nat1.ads new file mode 100644 index 00000000000..9504c163bc5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/nat1.ads @@ -0,0 +1,5 @@ + with System; + package NAT1 is + Nat_One_Storage : constant Natural := 1; + One_Address : constant System.Address := Nat_One_Storage'Address; + end; diff --git a/gcc/testsuite/gnat.dg/nat1r.adb b/gcc/testsuite/gnat.dg/nat1r.adb new file mode 100644 index 00000000000..91a17ba3a63 --- /dev/null +++ b/gcc/testsuite/gnat.dg/nat1r.adb @@ -0,0 +1,11 @@ +-- { dg-do run } + + with System, NAT1; use NAT1; + procedure Nat1R is + use type System.Address; + begin + if One_Address /= Nat_One_Storage'Address then + raise Constraint_Error; + end if; + end; + diff --git a/gcc/testsuite/gnat.dg/no_final.adb b/gcc/testsuite/gnat.dg/no_final.adb new file mode 100644 index 00000000000..b1a63cdf0ea --- /dev/null +++ b/gcc/testsuite/gnat.dg/no_final.adb @@ -0,0 +1,29 @@ +-- { dg-do run } + +pragma Restrictions (No_Finalization); +procedure no_final is + package P is + type T is tagged null record; + type T1 is new T with record + A : String (1..80); + end record; + function F return T'Class; + end P; + + Str : String (1..80) := (1..80=>'x'); + + package body P is + function F return T'Class is + X : T1 := T1'(A => Str); + begin + return X; + end F; + end P; + + Obj : P.T'class := P.F; +begin + if P.T1 (Obj).A /= Str then + raise Constraint_Error; + end if; +end; + diff --git a/gcc/testsuite/gnat.dg/prefix1.adb b/gcc/testsuite/gnat.dg/prefix1.adb new file mode 100644 index 00000000000..70e11368e15 --- /dev/null +++ b/gcc/testsuite/gnat.dg/prefix1.adb @@ -0,0 +1,8 @@ +package body prefix1 is + Counter : Integer := 2; + Table : Arr := (2, 4, 8, 16, 32, 64, 128, 256, 512, 1024); + function Func (Object : T) return Arr is + begin + return Table; + end; +end prefix1; diff --git a/gcc/testsuite/gnat.dg/prefix1.ads b/gcc/testsuite/gnat.dg/prefix1.ads new file mode 100644 index 00000000000..3dbaa63e91c --- /dev/null +++ b/gcc/testsuite/gnat.dg/prefix1.ads @@ -0,0 +1,5 @@ +package prefix1 is + type Arr is array (1..10) of Natural; + type T is tagged null record; + function Func (Object : T) return Arr; +end prefix1; diff --git a/gcc/testsuite/gnat.dg/rational_arithmetic.ads b/gcc/testsuite/gnat.dg/rational_arithmetic.ads new file mode 100644 index 00000000000..f4398c5143c --- /dev/null +++ b/gcc/testsuite/gnat.dg/rational_arithmetic.ads @@ -0,0 +1,37 @@ +package Rational_Arithmetic is + -- Whole numbers + type Whole is new Integer; +-- + -- Undefine unwanted operations + function "/" (Left, Right: Whole) return Whole is abstract; +-- + -- Rational numbers +-- + type Rational is private; +-- + -- Constructors +-- + function "/" (Left, Right: Whole) return Rational; +-- + -- Rational operations +-- + function "-" (Left, Right: Rational) return Rational; +-- + -- Mixed operations +-- + function "+" (Left: Whole ; Right: Rational) return Rational; + function "-" (Left: Whole ; Right: Rational) return Rational; + function "-" (Left: Rational; Right: Whole ) return Rational; + function "/" (Left: Whole ; Right: Rational) return Rational; + function "*" (Left: Whole ; Right: Rational) return Rational; + function "*" (Left: Rational; Right: Whole ) return Rational; +-- + -- Relational +-- + function "=" (Left: Rational; Right: Whole) return Boolean; +-- +private + type Rational is record + Numerator, Denominator: Whole; + end record; +end Rational_Arithmetic; diff --git a/gcc/testsuite/gnat.dg/renaming1.adb b/gcc/testsuite/gnat.dg/renaming1.adb new file mode 100644 index 00000000000..8f5e5150f8f --- /dev/null +++ b/gcc/testsuite/gnat.dg/renaming1.adb @@ -0,0 +1,14 @@ +-- { dg-do compile} +-- { dg-options "-gnatwa" } + +with Text_IO; +use Text_IO; +use type Text_IO.File_Access; +package body renaming1 is + procedure Fo (A : Text_IO.File_Access) is + begin + if A = Text_IO.Standard_Output then + null; + end if; + end Fo; +end; diff --git a/gcc/testsuite/gnat.dg/renaming1.ads b/gcc/testsuite/gnat.dg/renaming1.ads new file mode 100644 index 00000000000..893f423d532 --- /dev/null +++ b/gcc/testsuite/gnat.dg/renaming1.ads @@ -0,0 +1,4 @@ +with Text_IO; +package renaming1 is + procedure Fo (A : Text_IO.File_Access); +end; diff --git a/gcc/testsuite/gnat.dg/return1.adb b/gcc/testsuite/gnat.dg/return1.adb new file mode 100644 index 00000000000..2039f85ebfb --- /dev/null +++ b/gcc/testsuite/gnat.dg/return1.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } +-- { dg-options "-gnatwa" } + +package body return1 is + function X_Func (O : access Child) return access Base'Class is + begin + return X_Local : access Child'Class do + X_Local := O; + end return; + end X_Func; +end return1; diff --git a/gcc/testsuite/gnat.dg/return1.ads b/gcc/testsuite/gnat.dg/return1.ads new file mode 100644 index 00000000000..6948fdabcf0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/return1.ads @@ -0,0 +1,7 @@ +package return1 is + type Base is abstract tagged null record; + type Child is new Base with record + Anon_Access : access Base'Class; + end record; + function X_Func (O : access Child) return access Base'Class; +end return1; diff --git a/gcc/testsuite/gnat.dg/slice1.adb b/gcc/testsuite/gnat.dg/slice1.adb new file mode 100644 index 00000000000..4c24975f7a2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/slice1.adb @@ -0,0 +1,19 @@ +-- { dg-do compile } +-- { dg-options "-O2" } + +function slice1 (Offset : Integer) return String is + + Convert : constant String := "0123456789abcdef"; + Buffer : String (1 .. 32); + Pos : Natural := Buffer'Last; + Value : Long_Long_Integer := Long_Long_Integer (Offset); + +begin + while Value > 0 loop + Buffer (Pos) := Convert (Integer (Value mod 16)); + Pos := Pos - 1; + Value := Value / 16; + end loop; + + return Buffer (Pos + 1 .. Buffer'Last); +end; diff --git a/gcc/testsuite/gnat.dg/specs/pack2.ads b/gcc/testsuite/gnat.dg/specs/pack2.ads new file mode 100644 index 00000000000..7272048a1bd --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/pack2.ads @@ -0,0 +1,10 @@ +-- { dg-do compile } + +package Pack2 is + type Rec is record + Ptr: access Character; + Int :Integer; + end record; + type Table is array (1..2) of rec; + pragma Pack (Table); +end Pack2; diff --git a/gcc/testsuite/gnat.dg/test_debug1.adb b/gcc/testsuite/gnat.dg/test_debug1.adb new file mode 100644 index 00000000000..f4d362f30bb --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_debug1.adb @@ -0,0 +1,9 @@ +-- { dg-do compile } +-- { dg-options "-g" } + +with debug1; use debug1; +procedure test_debug1 is + Blob : Meta_Data; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/test_delay.adb b/gcc/testsuite/gnat.dg/test_delay.adb new file mode 100644 index 00000000000..aaedf7f4028 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_delay.adb @@ -0,0 +1,8 @@ +-- { dg-do run } + +with Ada.Real_Time; + +procedure Test_Delay is +begin + delay until Ada.Real_Time.Clock; +end Test_Delay; diff --git a/gcc/testsuite/gnat.dg/test_equal1.adb b/gcc/testsuite/gnat.dg/test_equal1.adb new file mode 100644 index 00000000000..7731f0c513a --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_equal1.adb @@ -0,0 +1,13 @@ +-- { dg-do compile } + +with equal1; +procedure test_equal1 is + subtype Boolean_T is Boolean; + function "=" (L, R : in equal1.Basic_Connection_Status_T) + return Boolean_T renames equal1."="; + Status : equal1.Basic_Connection_Status_T; + Result : Boolean_T; +begin + Status := equal1.Temporary_Disconnected; + Result := Status /= equal1.Connected; +end; diff --git a/gcc/testsuite/gnat.dg/test_ext1.adb b/gcc/testsuite/gnat.dg/test_ext1.adb new file mode 100644 index 00000000000..8accc70d042 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_ext1.adb @@ -0,0 +1,8 @@ +-- { dg-do compile } + +with ext1; use ext1; +procedure test_ext1 is + X : Regular_Smiley; +begin + X.Set_Mood; +end; diff --git a/gcc/testsuite/gnat.dg/test_prefix1.adb b/gcc/testsuite/gnat.dg/test_prefix1.adb new file mode 100644 index 00000000000..1dd6ab7f52d --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_prefix1.adb @@ -0,0 +1,15 @@ +-- {dg-do run } + +with prefix1; use prefix1; +procedure test_prefix1 is + Val : Natural; + Obj : T; +-- +begin + for J in Obj.Func'Range loop + Val := Obj.Func (J); + if Val /= 2 ** J then + raise Program_Error; + end if; + end loop; +end test_prefix1; diff --git a/gcc/testsuite/gnat.dg/test_rational_arithmetic.adb b/gcc/testsuite/gnat.dg/test_rational_arithmetic.adb new file mode 100644 index 00000000000..d33ea393a87 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_rational_arithmetic.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } + +with Rational_Arithmetic; +use Rational_Arithmetic; +procedure Test_Rational_Arithmetic is + R: Rational := 10/2; + B: Boolean := R = 5/1; -- RHS cannot be a Whole + -- ("/" has been "undefined") + C: Boolean := R = Rational' (5/1); + D: Boolean := (6/3) = R; + E: Boolean := (2/1 = 4/2); +begin + R := 1+1/(4/8); + R := 2*(3/2)-(7/3)*3; +end Test_Rational_Arithmetic; diff --git a/gcc/testsuite/gnat.dg/unc.adb b/gcc/testsuite/gnat.dg/unc.adb new file mode 100644 index 00000000000..c75dfbe66e6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/unc.adb @@ -0,0 +1,26 @@ +-- { dg-do compile } + +with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; +procedure Unc is + type Arr is array (1..4) of integer; + type Bytes is array (positive range <>) of Character; + type Buffer (D : Boolean := False) is record + case D is + when False => + Chars: Bytes (1..16); + when True => + Values : Arr; + end case; + end record; +-- + pragma Unchecked_Union (Buffer); + pragma Warnings (Off); + Val : Buffer; +-- + F : File_Type; + S : Stream_Access; +begin + Create (F, Out_File); + S := Stream (F); + Buffer'Output (S, Val); +end; diff --git a/gcc/testsuite/gnat.dg/volatile1.ads b/gcc/testsuite/gnat.dg/volatile1.ads new file mode 100644 index 00000000000..62bf17a598e --- /dev/null +++ b/gcc/testsuite/gnat.dg/volatile1.ads @@ -0,0 +1,22 @@ +package volatile1 is + + type Command is (Nothing, Get); + + type Data is + record + Time : Duration; + end record; + + type Data_Array is array (Integer range <>) of Data; + + type Command_Data (Kind : Command; Length : Integer) is + record + case Kind is + when Nothing => + null; + when Get => + Data : Data_Array (1 .. Length); + end case; + end record; + +end; diff --git a/gcc/testsuite/gnat.dg/volatile2.adb b/gcc/testsuite/gnat.dg/volatile2.adb new file mode 100644 index 00000000000..57df26e7adf --- /dev/null +++ b/gcc/testsuite/gnat.dg/volatile2.adb @@ -0,0 +1,22 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +package body volatile2 is + + procedure Copy is + R : Result; + M : Integer; + subtype Get_Data is Command_Data (Get, R.Data'Last); + begin + declare + G : Get_Data; + for G'Address use M'Address; + begin + for I in 1 .. R.Data'Last loop + G.Data (I) := (Time => R.Data (I).Time); + end loop; + end; + end; + +end volatile2; + diff --git a/gcc/testsuite/gnat.dg/volatile2.ads b/gcc/testsuite/gnat.dg/volatile2.ads new file mode 100644 index 00000000000..0f7ed071c2b --- /dev/null +++ b/gcc/testsuite/gnat.dg/volatile2.ads @@ -0,0 +1,16 @@ +with volatile1; use volatile1; + +package volatile2 is + + type PData_Array is access Data_Array; + + type Result_Desc is + record + Data : PData_Array; + end record; + + type Result is access Result_Desc; + + procedure Copy; + +end volatile2;