diff options
| author | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
|---|---|---|
| committer | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
| commit | 554fd8c5195424bdbcabf5de30fdc183aba391bd (patch) | |
| tree | 976dc5ab7fddf506dadce60ae936f43f58787092 /gcc/testsuite/gnat.dg | |
| download | cbb-gcc-4.6.4-upstream.tar.bz2 cbb-gcc-4.6.4-upstream.tar.xz | |
obtained gcc-4.6.4.tar.bz2 from upstream website;upstream
verified gcc-4.6.4.tar.bz2.sig;
imported gcc-4.6.4 source tree from verified upstream tarball.
downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.
if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
Diffstat (limited to 'gcc/testsuite/gnat.dg')
855 files changed, 16987 insertions, 0 deletions
diff --git a/gcc/testsuite/gnat.dg/abstract1.adb b/gcc/testsuite/gnat.dg/abstract1.adb new file mode 100644 index 000000000..97508fac2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/abstract1.adb @@ -0,0 +1,31 @@ +-- { dg-do compile } +with Ada.Tags.Generic_Dispatching_Constructor; use Ada.Tags; +package body abstract1 is + + function New_T (Stream : not null access Root_Stream_Type'Class) + return T'Class is + function Construct is + new Generic_Dispatching_Constructor (T, Root_Stream_Type'Class, Input); + E : constant String := String'Input (Stream); + I : constant Tag := Internal_Tag (E); + + begin + return Construct (I, Stream); + end New_T; + + function Input (Stream : not null access Root_Stream_Type'Class) + return IT is + begin + return O : IT do + Integer'Read (Stream, O.I); + end return; + end Input; + + function Input (Stream : not null access Root_Stream_Type'Class) + return FT is + begin + return O : FT do + Float'Read (Stream, O.F); + end return; + end Input; +end abstract1; diff --git a/gcc/testsuite/gnat.dg/abstract1.ads b/gcc/testsuite/gnat.dg/abstract1.ads new file mode 100644 index 000000000..bad9ee698 --- /dev/null +++ b/gcc/testsuite/gnat.dg/abstract1.ads @@ -0,0 +1,19 @@ +with Ada.Streams; use Ada.Streams; +package abstract1 is + type T is abstract tagged limited null record; + function Input (Stream : not null access Root_Stream_Type'Class) return T + is abstract; + + function New_T (Stream : not null access Root_Stream_Type'Class) + return T'Class; + + type IT is limited new T with record + I : Integer; + end record; + function Input (Stream : not null access Root_Stream_Type'Class) return IT; + + type FT is limited new T with record + F : Float; + end record; + function Input (Stream : not null access Root_Stream_Type'Class) return FT; +end abstract1; diff --git a/gcc/testsuite/gnat.dg/abstract_with_anonymous_result.adb b/gcc/testsuite/gnat.dg/abstract_with_anonymous_result.adb new file mode 100644 index 000000000..af0f43e64 --- /dev/null +++ b/gcc/testsuite/gnat.dg/abstract_with_anonymous_result.adb @@ -0,0 +1,37 @@ +-- { dg-do run } + +procedure Abstract_With_Anonymous_Result is + + package Pkg is + type I is abstract tagged null record; + type Acc_I_Class is access all I'Class; + function Func (V : I) return access I'Class is abstract; + procedure Proc (V : access I'Class); + type New_I is new I with null record; + function Func (V : New_I) return access I'Class; + end Pkg; + + package body Pkg is + X : aliased New_I; + + procedure Proc (V : access I'Class) is begin null; end Proc; + + function Func (V : New_I) return access I'Class is + begin + X := V; + return X'Access; + end Func; + end Pkg; + + use Pkg; + + New_I_Obj : aliased New_I; + + procedure Proc2 (V : access I'Class) is + begin + Proc (Func (V.all)); -- Call to Func causes gigi abort 122 + end Proc2; + +begin + Proc2 (New_I_Obj'Access); +end Abstract_With_Anonymous_Result; diff --git a/gcc/testsuite/gnat.dg/access1.adb b/gcc/testsuite/gnat.dg/access1.adb new file mode 100644 index 000000000..c6100051a --- /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 000000000..fd91dbea9 --- /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/access3.adb b/gcc/testsuite/gnat.dg/access3.adb new file mode 100644 index 000000000..db109b3d2 --- /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 000000000..18d453b32 --- /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 000000000..2b0062741 --- /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/access_discr.adb b/gcc/testsuite/gnat.dg/access_discr.adb new file mode 100644 index 000000000..a036f554a --- /dev/null +++ b/gcc/testsuite/gnat.dg/access_discr.adb @@ -0,0 +1,22 @@ +-- { dg-do compile } + +procedure access_discr is + + type One; + + type Iface is limited interface; + type Base is tagged limited null record; + + type Two_Alone (Parent : access One) is limited null record; + type Two_Iface (Parent : access One) is limited new Iface with null record; + type Two_Base (Parent : access One) is new Base with null record; + + type One is limited record + TA : Two_Alone (One'Access); + TI : Two_Iface (One'Access); -- OFFENDING LINE + TB : Two_Base (One'Access); + end record; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/access_discr2.adb b/gcc/testsuite/gnat.dg/access_discr2.adb new file mode 100644 index 000000000..ceeeb4645 --- /dev/null +++ b/gcc/testsuite/gnat.dg/access_discr2.adb @@ -0,0 +1,10 @@ +-- { dg-do run } + +procedure access_discr2 is + type X (I : not null access Integer) is tagged null record; + + I : aliased Integer := 8; + Y : X (I'Access); +begin + null; +end access_discr2; diff --git a/gcc/testsuite/gnat.dg/access_func.adb b/gcc/testsuite/gnat.dg/access_func.adb new file mode 100644 index 000000000..8354e7453 --- /dev/null +++ b/gcc/testsuite/gnat.dg/access_func.adb @@ -0,0 +1,10 @@ +-- { dg-do compile } + +procedure access_func is + type Abomination is access + function (X : Integer) return access + function (Y : Float) return access + function return Integer; +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 000000000..6266b725a --- /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/addr1.adb b/gcc/testsuite/gnat.dg/addr1.adb new file mode 100644 index 000000000..5f5ff5356 --- /dev/null +++ b/gcc/testsuite/gnat.dg/addr1.adb @@ -0,0 +1,19 @@ +-- { dg-do compile } + +with System; +package body addr1 is + task type T is + entry Send (Location : System.Address); + end; + task body T is + begin + accept Send (Location : System.Address) do + declare + Buffer : String (1 .. 100); + for Buffer'Address use Location; -- Test + begin + null; + end; + end Send; + end; +end; diff --git a/gcc/testsuite/gnat.dg/addr1.ads b/gcc/testsuite/gnat.dg/addr1.ads new file mode 100644 index 000000000..99496cd51 --- /dev/null +++ b/gcc/testsuite/gnat.dg/addr1.ads @@ -0,0 +1,3 @@ +package addr1 is + pragma Elaborate_Body; +end; diff --git a/gcc/testsuite/gnat.dg/addr2.adb b/gcc/testsuite/gnat.dg/addr2.adb new file mode 100644 index 000000000..15d51e30d --- /dev/null +++ b/gcc/testsuite/gnat.dg/addr2.adb @@ -0,0 +1,10 @@ +-- { dg-do run } + +with addr2_p; use addr2_p; +procedure addr2 is +begin + Process (B1); + Process (Blk => B1); + Process (B2); + Process (Blk => B2); +end; diff --git a/gcc/testsuite/gnat.dg/addr2_p.adb b/gcc/testsuite/gnat.dg/addr2_p.adb new file mode 100644 index 000000000..82e151cd7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/addr2_p.adb @@ -0,0 +1,11 @@ + +with System; +package body addr2_p is + procedure Process (Blk : Block) is + use type System.Address; + begin + if Blk'Address /= B1'Address and then Blk'Address /= B2'Address then + raise Program_Error; + end if; + end; +end; diff --git a/gcc/testsuite/gnat.dg/addr2_p.ads b/gcc/testsuite/gnat.dg/addr2_p.ads new file mode 100644 index 000000000..dd409d6f6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/addr2_p.ads @@ -0,0 +1,10 @@ + +package addr2_p is + + type Block is array (1 .. 9) of Integer; + + procedure Process (Blk : Block); + + B1 : constant Block := Block'((1,2,3,4,5, others => 0)); + B2 : constant Block := (1,2,3,4,5, others => 0); +end; diff --git a/gcc/testsuite/gnat.dg/addr3.adb b/gcc/testsuite/gnat.dg/addr3.adb new file mode 100644 index 000000000..837035ab3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/addr3.adb @@ -0,0 +1,36 @@ +-- { dg-do compile } + +with text_io; +with System; +procedure addr3 is + + Type T_SAME_TYPE is new System.Address; + + Type T_OTHER_TYPE is new System.Address; + + I : constant integer := 0; + procedure dum ( i : INTEGER ) is + begin + text_io.put_line ("Integer op"); + null; + end; + + procedure dum ( i : system.ADDRESS ) is + begin + null; + end; + + procedure dum ( i : T_SAME_TYPE ) is + begin + null; + end; + + procedure dum ( i : T_OTHER_TYPE ) is + begin + null; + end; + +begin + dum( I ); + dum( 1 ); +end; diff --git a/gcc/testsuite/gnat.dg/addr4.adb b/gcc/testsuite/gnat.dg/addr4.adb new file mode 100644 index 000000000..8bb3f2c97 --- /dev/null +++ b/gcc/testsuite/gnat.dg/addr4.adb @@ -0,0 +1,12 @@ +-- { dg-do compile } +-- { dg-options "-g" } + +procedure Addr4 is + function F return String is begin return ""; end F; + S1 : String renames F; + subtype ST is String (1 .. S1'Length); + S2 : ST; + for S2'Address use S1'Address; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/addr5.adb b/gcc/testsuite/gnat.dg/addr5.adb new file mode 100644 index 000000000..e331dfdc0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/addr5.adb @@ -0,0 +1,10 @@ +-- { dg-do compile } +-- { dg-options "-g" } + +procedure Addr5 (Len : Integer) is + S : aliased String (1 .. Len) := (others => ' '); + C : Character; + for C'Address use S'Address; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/addr6.adb b/gcc/testsuite/gnat.dg/addr6.adb new file mode 100644 index 000000000..e357132d6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/addr6.adb @@ -0,0 +1,31 @@ +-- { dg-do compile } + +procedure Addr6 is + + type Byte is mod 2**8; + + type Byte_Arr1 is array (Positive range <>) of Byte; + for Byte_Arr1'Alignment use 4; + + type Byte_Arr2 is array (Positive range <>) of Byte; + + function Length return Natural is + begin + return 1; + end; + + function Empty return Byte_Arr2 is + Null_Arr : Byte_Arr2 (1 .. 0); + begin + return Null_Arr; + end; + + A1 : Byte_Arr1 (1 .. Length); + + A2 : Byte_Arr2 (A1'Range); + for A2'Alignment use 4; + for A2'Address use A1'Address; + +begin + A2 := Empty; +end; diff --git a/gcc/testsuite/gnat.dg/addr_slice.adb b/gcc/testsuite/gnat.dg/addr_slice.adb new file mode 100644 index 000000000..250614808 --- /dev/null +++ b/gcc/testsuite/gnat.dg/addr_slice.adb @@ -0,0 +1,19 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +procedure Addr_Slice is + type Item_Type is record + I : Integer; + end record; + + type Index_Type is (A, B); + for Index_Type use (A => 1, B => 10); + + Item_Array : constant array (Index_Type) of Item_Type + := (A => (I => 10), B => (I => 22)); + + Item : Item_Type; + for Item'Address use Item_Array(Index_Type)'Address; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/address_conversion.adb b/gcc/testsuite/gnat.dg/address_conversion.adb new file mode 100644 index 000000000..5813638c4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/address_conversion.adb @@ -0,0 +1,24 @@ +-- { dg-do run } +-- { dg-options "-O2" } + +with System.Address_To_Access_Conversions; + +procedure address_conversion is + + type Integer_type1 is new Integer; + type Integer_type2 is new Integer; + + package AA is new System.Address_To_Access_Conversions (Integer_type1); + + K1 : Integer_type1; + K2 : Integer_type2; + +begin + K1 := 1; + K2 := 2; + + AA.To_Pointer(K2'Address).all := K1; + if K2 /= 1 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/address_null_init.ads b/gcc/testsuite/gnat.dg/address_null_init.ads new file mode 100644 index 000000000..58c1c314b --- /dev/null +++ b/gcc/testsuite/gnat.dg/address_null_init.ads @@ -0,0 +1,8 @@ +package Address_Null_Init is + + type Acc is access Integer; + A : Acc := new Integer'(123); + B : Acc; -- Variable must be set to null (and A overwritten by null) + for B'Address use A'Address; + +end Address_Null_Init; diff --git a/gcc/testsuite/gnat.dg/aggr1.adb b/gcc/testsuite/gnat.dg/aggr1.adb new file mode 100644 index 000000000..256b3951b --- /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/aggr10.adb b/gcc/testsuite/gnat.dg/aggr10.adb new file mode 100644 index 000000000..6fbb8ed5d --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr10.adb @@ -0,0 +1,23 @@ +-- { dg-do compile } +-- { dg-options "-O2" } + +with Aggr10_Pkg; use Aggr10_Pkg; + +procedure Aggr10 is + + No_Name_Location : constant Name_Location := + (Name => Name_Id'First, + Location => Int'First, + Source => Source_Id'First, + Except => False, + Found => False); + + Name_Loc : Name_Location; + +begin + Name_Loc := Get; + if Name_Loc = No_Name_Location then -- { dg-bogus "comparison always false" } + raise Program_Error; + end if; + Set (Name_Loc); +end; diff --git a/gcc/testsuite/gnat.dg/aggr10_pkg.ads b/gcc/testsuite/gnat.dg/aggr10_pkg.ads new file mode 100644 index 000000000..92400f990 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr10_pkg.ads @@ -0,0 +1,18 @@ +package Aggr10_Pkg is + + type Name_Id is range 300_000_000 .. 399_999_999; + type Int is range -2 ** 31 .. +2 ** 31 - 1; + type Source_Id is range 5_000_000 .. 5_999_999; + + type Name_Location is record + Name : Name_Id; + Location : Int; + Source : Source_Id; + Except : Boolean; + Found : Boolean := False; + end record; + + function Get return Name_Location; + procedure Set (Name_Loc : Name_Location); + +end Aggr10_Pkg; diff --git a/gcc/testsuite/gnat.dg/aggr11.adb b/gcc/testsuite/gnat.dg/aggr11.adb new file mode 100644 index 000000000..1771d62ca --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr11.adb @@ -0,0 +1,17 @@ +-- { dg-do compile }
+-- { dg-options "-O" }
+
+with Aggr11_Pkg; use Aggr11_Pkg;
+
+procedure Aggr11 is
+
+ A : Arr := ((1 => (Kind => No_Error, B => True),
+ 2 => (Kind => Error),
+ 3 => (Kind => Error),
+ 4 => (Kind => No_Error, B => True),
+ 5 => (Kind => No_Error, B => True),
+ 6 => (Kind => No_Error, B => True)));
+
+begin
+ null;
+end;
diff --git a/gcc/testsuite/gnat.dg/aggr11_pkg.ads b/gcc/testsuite/gnat.dg/aggr11_pkg.ads new file mode 100644 index 000000000..37008605a --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr11_pkg.ads @@ -0,0 +1,14 @@ +package Aggr11_Pkg is
+
+ type Error_Type is (No_Error, Error);
+
+ type Rec (Kind : Error_Type := No_Error) is record
+ case Kind is
+ when Error => null;
+ when others => B : Boolean;
+ end case;
+ end record;
+
+ type Arr is array (1..6) of Rec;
+
+end Aggr11_Pkg;
diff --git a/gcc/testsuite/gnat.dg/aggr12.adb b/gcc/testsuite/gnat.dg/aggr12.adb new file mode 100644 index 000000000..8a18291f7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr12.adb @@ -0,0 +1,20 @@ +-- { dg-do compile } +-- { dg-options "-fdump-tree-original" } + +package body Aggr12 is + + procedure Print (Data : String) is + begin + null; + end; + + procedure Test is + begin + Print (Hair_Color_Type'Image (A.I1)); + Print (Hair_Color_Type'Image (A.I2)); + end; + +end Aggr12; + +-- { dg-final { scan-tree-dump-not "{.i1=0, .i2=2}" "original" } } +-- { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gnat.dg/aggr12.ads b/gcc/testsuite/gnat.dg/aggr12.ads new file mode 100644 index 000000000..32084176e --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr12.ads @@ -0,0 +1,15 @@ +package Aggr12 is + + type Hair_Color_Type is (Black, Brown, Blonde, Grey, White, Red); + + type Rec is record + I1, I2 : Hair_Color_Type; + end record; + + A : constant Rec := (Black, Blonde); + + procedure Print (Data : String); + + procedure Test; + +end Aggr12; diff --git a/gcc/testsuite/gnat.dg/aggr13.adb b/gcc/testsuite/gnat.dg/aggr13.adb new file mode 100644 index 000000000..add223c0b --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr13.adb @@ -0,0 +1,23 @@ +-- { dg-do compile } +-- { dg-options "-fdump-tree-gimple" } + +procedure Aggr13 is + + type A is array (Integer range 1 .. 3) of Short_Short_Integer; + + X : A := (1, 2, 3); + + function F return A is + begin + if X /= (1, 2, 3) then + raise Program_Error; + end if; + return (1, 1, 1); + end; + +begin + X := F; +end; + +-- { dg-final { scan-tree-dump-not "= {}" "gimple" } } +-- { dg-final { cleanup-tree-dump "gimple" } } diff --git a/gcc/testsuite/gnat.dg/aggr14.adb b/gcc/testsuite/gnat.dg/aggr14.adb new file mode 100644 index 000000000..46f5af42a --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr14.adb @@ -0,0 +1,8 @@ +-- { dg-do run } + +with Aggr14_Pkg; use Aggr14_Pkg; + +procedure Aggr14 is +begin + Proc; +end; diff --git a/gcc/testsuite/gnat.dg/aggr14_pkg.adb b/gcc/testsuite/gnat.dg/aggr14_pkg.adb new file mode 100644 index 000000000..ce129601d --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr14_pkg.adb @@ -0,0 +1,16 @@ +package body Aggr14_Pkg is + + function F return A is + begin + if X /= (1, 2, 3) then + raise Program_Error; + end if; + return (1, 1, 1); + end; + + procedure Proc is + begin + X := F; + end; + +end Aggr14_Pkg; diff --git a/gcc/testsuite/gnat.dg/aggr14_pkg.ads b/gcc/testsuite/gnat.dg/aggr14_pkg.ads new file mode 100644 index 000000000..874e30949 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr14_pkg.ads @@ -0,0 +1,9 @@ +package Aggr14_Pkg is + + type A is array (Integer range 1 .. 3) of Short_Short_Integer; + + X : A := (1, 2, 3); + + procedure Proc; + +end Aggr14_Pkg; diff --git a/gcc/testsuite/gnat.dg/aggr15.adb b/gcc/testsuite/gnat.dg/aggr15.adb new file mode 100644 index 000000000..e69e9d346 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr15.adb @@ -0,0 +1,18 @@ +-- { dg-do compile }
+-- { dg-options "-gnatws" }
+
+package body Aggr15 is
+
+ function CREATE return DATA_T is
+ D : DATA_T;
+ begin
+ return D;
+ end;
+
+ function ALL_CREATE return ALL_DATA_T is
+ C : constant ALL_DATA_T := (others => (others => Create));
+ begin
+ return C;
+ end;
+
+end Aggr15;
diff --git a/gcc/testsuite/gnat.dg/aggr15.ads b/gcc/testsuite/gnat.dg/aggr15.ads new file mode 100644 index 000000000..23f26a8df --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr15.ads @@ -0,0 +1,15 @@ +package Aggr15 is
+
+ type T is tagged record
+ I : Integer;
+ end record;
+
+ type DATA_T is record
+ D : T;
+ end record;
+
+ type ALL_DATA_T is array (1..2, 1..2) of DATA_T;
+
+ function ALL_CREATE return ALL_DATA_T;
+
+end Aggr15;
diff --git a/gcc/testsuite/gnat.dg/aggr16.adb b/gcc/testsuite/gnat.dg/aggr16.adb new file mode 100644 index 000000000..2f559da25 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr16.adb @@ -0,0 +1,26 @@ +-- { dg-do compile } + +with Aggr16_Pkg; use Aggr16_Pkg; + +package body Aggr16 is + + type Arr is array (1 .. 4) of Time; + + type Change_Type is (One, Two, Three); + + type Change (D : Change_Type) is record + case D is + when Three => + A : Arr; + when Others => + B : Boolean; + end case; + end record; + + procedure Proc is + C : Change (Three); + begin + C.A := (others => Null_Time); + end; + +end Aggr16; diff --git a/gcc/testsuite/gnat.dg/aggr16.ads b/gcc/testsuite/gnat.dg/aggr16.ads new file mode 100644 index 000000000..3a4b0d1df --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr16.ads @@ -0,0 +1,5 @@ +package Aggr16 is + + procedure Proc; + +end Aggr16; diff --git a/gcc/testsuite/gnat.dg/aggr16_pkg.ads b/gcc/testsuite/gnat.dg/aggr16_pkg.ads new file mode 100644 index 000000000..8bacbc9b0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr16_pkg.ads @@ -0,0 +1,27 @@ +package Aggr16_Pkg is + + type Time_Type is (A, B); + + type Time (D : Time_Type := A) is private; + + Null_Time : constant Time; + +private + + type Hour is record + I1 : Integer; + I2 : Integer; + end record; + + type Time (D : Time_Type := A) is record + case D is + when A => + A_Time : Integer; + when B => + B_Time : Hour; + end case; + end record; + + Null_Time : constant Time := (A, 0); + +end Aggr16_Pkg; diff --git a/gcc/testsuite/gnat.dg/aggr2.adb b/gcc/testsuite/gnat.dg/aggr2.adb new file mode 100644 index 000000000..3e9dc40f8 --- /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/aggr3.adb b/gcc/testsuite/gnat.dg/aggr3.adb new file mode 100644 index 000000000..dd6cec159 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr3.adb @@ -0,0 +1,36 @@ +-- { dg-do run } + +with Ada.Tags; use Ada.Tags; +with Ada.Text_IO; use Ada.Text_IO; +procedure aggr3 is + package Pkg is + type Element is interface; + type Event is tagged record + V1 : Natural; + V2 : Natural; + end record; + function Create return Event; + type D_Event is new Event and Element with null record; + function Create return D_Event; + end; + package body Pkg is + function Create return Event is + Obj : Event; + begin + Obj.V1 := 0; + return Obj; + end; + function Create return D_Event is + begin + return (Event'(Create) with null record); + end; + end; + use Pkg; + procedure CW_Test (Obj : Element'Class) is + S : Constant String := Expanded_Name (Obj'Tag); + begin + null; + end; +begin + CW_Test (Create); +end; diff --git a/gcc/testsuite/gnat.dg/aggr4.adb b/gcc/testsuite/gnat.dg/aggr4.adb new file mode 100644 index 000000000..3604967c2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr4.adb @@ -0,0 +1,27 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +procedure aggr4 is + type Byte is range 0 .. 2**8 - 1; + for Byte'Size use 8; + + type Time is array (1 .. 3) of Byte; + + type UTC_Time is record + Values : Time; + end record; + + type Local_Time is record + Values : Time; + end record; + for Local_Time use record + Values at 0 range 1 .. 24; + end record; + + LOC : Local_Time; + UTC : UTC_Time; + +begin + UTC.Values := LOC.Values; + UTC := (Values => LOC.Values); +end; diff --git a/gcc/testsuite/gnat.dg/aggr7.adb b/gcc/testsuite/gnat.dg/aggr7.adb new file mode 100644 index 000000000..9ebec1ca8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr7.adb @@ -0,0 +1,34 @@ +-- { dg-do compile } + +procedure aggr7 is + + package P is + type T is limited private; + type TT is limited private; + type TTT is tagged limited private; + private + type T is limited + record + Self : access T := T'Unchecked_Access; + end record; + type TT is tagged limited + record + Self : access TT := TT'Unchecked_Access; + end record; + type TTT is tagged limited + record + Self : access TTT := TTT'Unchecked_Access; + end record; + end P; + + package body P is + X : T := (Self => <>); + XX : TT := (Self => <>); + XXX : TTT := (Self => <>); + Y : T := (others => <>); + YY : TT := (others => <>); + YYY : TTT := (others => <>); + end P; +begin + null; +end aggr7; diff --git a/gcc/testsuite/gnat.dg/aggr8.adb b/gcc/testsuite/gnat.dg/aggr8.adb new file mode 100644 index 000000000..457150e16 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr8.adb @@ -0,0 +1,22 @@ +-- { dg-do compile } + +procedure aggr8 is + + type Byte is mod 2 ** 8; + subtype two is integer range 1..2; + -- type Sequence is array (1 .. 2) of Byte; + type Sequence is array (Two) of Byte; + + type Block is record + Head : Sequence := (11, 22); + end record; + + procedure Nest is + Blk : Block; pragma Unreferenced (Blk); + begin + null; + end; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/aggr9.adb b/gcc/testsuite/gnat.dg/aggr9.adb new file mode 100644 index 000000000..70d026fdd --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr9.adb @@ -0,0 +1,12 @@ +-- { dg-do compile } +-- { dg-options "-O" } + +package body Aggr9 is + + procedure Proc (X : R1) is + M : R2 := (F => X); + begin + Send (M); + end; + +end Aggr9; diff --git a/gcc/testsuite/gnat.dg/aggr9.ads b/gcc/testsuite/gnat.dg/aggr9.ads new file mode 100644 index 000000000..cb5757b64 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr9.ads @@ -0,0 +1,7 @@ +with Aggr9_Pkg; use Aggr9_Pkg; + +package Aggr9 is + + procedure Proc (X : R1); + +end Aggr9; diff --git a/gcc/testsuite/gnat.dg/aggr9_pkg.ads b/gcc/testsuite/gnat.dg/aggr9_pkg.ads new file mode 100644 index 000000000..c7c7b9e10 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aggr9_pkg.ads @@ -0,0 +1,17 @@ +package Aggr9_Pkg is + + type Byte is range 0 .. 255; + + type R1 is + record + A,B : Byte; + end record; + + type R2 is + record + F : R1; + end record; + + procedure Send (M : R2); + +end Aggr9_Pkg; diff --git a/gcc/testsuite/gnat.dg/aliased1.adb b/gcc/testsuite/gnat.dg/aliased1.adb new file mode 100644 index 000000000..774ffe5f7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aliased1.adb @@ -0,0 +1,34 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +procedure aliased1 is + + type E is (One, Two); + + type R (D : E := One) is record + case D is + when One => + I1 : Integer; + I2 : Integer; + when Two => + B1 : Boolean; + end case; + end record; + + type Data_Type is record + Data : R; + end record; + + type Array_Type is array (Natural range <>) of Data_Type; + + function Get return Array_Type is + Ret : Array_Type (1 .. 2); + begin + return Ret; + end; + + Object : aliased Array_Type := Get; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/aliased_prefix_accessibility.adb b/gcc/testsuite/gnat.dg/aliased_prefix_accessibility.adb new file mode 100644 index 000000000..c41a4bcf3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aliased_prefix_accessibility.adb @@ -0,0 +1,68 @@ +-- { dg-do run } + +with Tagged_Type_Pkg; use Tagged_Type_Pkg; +with Ada.Text_IO; use Ada.Text_IO; + +procedure Aliased_Prefix_Accessibility is + + T_Obj : aliased TT; + + T_Obj_Acc : access TT'Class := T_Obj'Access; + + type Nested_TT is limited record + TT_Comp : aliased TT; + end record; + + NTT_Obj : Nested_TT; + + ATT_Obj : array (1 .. 2) of aliased TT; + +begin + begin + T_Obj_Acc := Pass_TT_Access (T_Obj'Access); + Put_Line ("FAILED (1): call should have raised an exception"); + exception + when others => + null; + end; + + begin + T_Obj_Acc := T_Obj.Pass_TT_Access; + Put_Line ("FAILED (2): call should have raised an exception"); + exception + when others => + null; + end; + + begin + T_Obj_Acc := Pass_TT_Access (NTT_Obj.TT_Comp'Access); + Put_Line ("FAILED (3): call should have raised an exception"); + exception + when others => + null; + end; + + begin + T_Obj_Acc := NTT_Obj.TT_Comp.Pass_TT_Access; + Put_Line ("FAILED (4): call should have raised an exception"); + exception + when others => + null; + end; + + begin + T_Obj_Acc := Pass_TT_Access (ATT_Obj (1)'Access); + Put_Line ("FAILED (5): call should have raised an exception"); + exception + when others => + null; + end; + + begin + T_Obj_Acc := ATT_Obj (2).Pass_TT_Access; + Put_Line ("FAILED (6): call should have raised an exception"); + exception + when others => + null; + end; +end Aliased_Prefix_Accessibility; diff --git a/gcc/testsuite/gnat.dg/aliasing1.adb b/gcc/testsuite/gnat.dg/aliasing1.adb new file mode 100644 index 000000000..b2b7d123b --- /dev/null +++ b/gcc/testsuite/gnat.dg/aliasing1.adb @@ -0,0 +1,22 @@ +-- { dg-do compile } +-- { dg-options "-O2 -gnatp -fdump-tree-optimized" } + +-- The raise statement must be optimized away by +-- virtue of DECL_NONADDRESSABLE_P set on R.I. + +package body Aliasing1 is + + function F (P : Ptr) return Integer is + begin + R.I := 0; + P.all := 1; + if R.I /= 0 then + raise Program_Error; + end if; + return 0; + end; + +end Aliasing1; + +-- { dg-final { scan-tree-dump-not "__gnat_rcheck" "optimized" } } +-- { dg-final { cleanup-tree-dump "optimized" } } diff --git a/gcc/testsuite/gnat.dg/aliasing1.ads b/gcc/testsuite/gnat.dg/aliasing1.ads new file mode 100644 index 000000000..9ebfd6206 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aliasing1.ads @@ -0,0 +1,13 @@ +package Aliasing1 is + + type Rec is record + I : Integer; + end record; + + type Ptr is access all Integer; + + R : Rec; + + function F (P : Ptr) return Integer; + +end Aliasing1; diff --git a/gcc/testsuite/gnat.dg/aliasing2.adb b/gcc/testsuite/gnat.dg/aliasing2.adb new file mode 100644 index 000000000..7b3c3f777 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aliasing2.adb @@ -0,0 +1,22 @@ +-- { dg-do compile } +-- { dg-options "-O2 -gnatp -fdump-tree-optimized" } + +-- The raise statement must be optimized away by +-- virtue of TYPE_NONALIASED_COMPONENT set on A. + +package body Aliasing2 is + + function F (P : Ptr) return Integer is + begin + A (1) := 0; + P.all := 1; + if A(1) /= 0 then + raise Program_Error; + end if; + return 0; + end; + +end Aliasing2; + +-- { dg-final { scan-tree-dump-not "gnat_rcheck" "optimized" } } +-- { dg-final { cleanup-tree-dump "optimized" } } diff --git a/gcc/testsuite/gnat.dg/aliasing2.ads b/gcc/testsuite/gnat.dg/aliasing2.ads new file mode 100644 index 000000000..7a7e411fa --- /dev/null +++ b/gcc/testsuite/gnat.dg/aliasing2.ads @@ -0,0 +1,10 @@ +package Aliasing2 is + + type Arr is Array (1..4) of Integer; + type Ptr is access all Integer; + + A : Arr; + + function F (P : Ptr) return Integer; + +end Aliasing2; diff --git a/gcc/testsuite/gnat.dg/aliasing3.adb b/gcc/testsuite/gnat.dg/aliasing3.adb new file mode 100644 index 000000000..916821c55 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aliasing3.adb @@ -0,0 +1,10 @@ +-- { dg-do run } +-- { dg-options "-O2 -gnatn" } + +with Aliasing3_Pkg; use Aliasing3_Pkg; + +procedure Aliasing3 is +begin + Pointer.A(1) := 5; + Test (Block.A); +end; diff --git a/gcc/testsuite/gnat.dg/aliasing3_pkg.adb b/gcc/testsuite/gnat.dg/aliasing3_pkg.adb new file mode 100644 index 000000000..73c1e3e2c --- /dev/null +++ b/gcc/testsuite/gnat.dg/aliasing3_pkg.adb @@ -0,0 +1,10 @@ +package body Aliasing3_Pkg is + + procedure Test (A : Arr) is + begin + if A(1) /= 5 then + raise Program_Error; + end if; + end; + +end Aliasing3_Pkg; diff --git a/gcc/testsuite/gnat.dg/aliasing3_pkg.ads b/gcc/testsuite/gnat.dg/aliasing3_pkg.ads new file mode 100644 index 000000000..4704a7c53 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aliasing3_pkg.ads @@ -0,0 +1,19 @@ +package Aliasing3_Pkg is + + type Arr is array (1..3) of Integer; + + procedure Test (A : Arr); + pragma Inline (Test); + + type My_Arr is new Arr; + + type Rec is record + A : My_Arr; + end record; + + type Ptr is access all Rec; + + Block : aliased Rec; + Pointer : Ptr := Block'Access; + +end Aliasing3_Pkg; diff --git a/gcc/testsuite/gnat.dg/align_check.adb b/gcc/testsuite/gnat.dg/align_check.adb new file mode 100644 index 000000000..b8490f40c --- /dev/null +++ b/gcc/testsuite/gnat.dg/align_check.adb @@ -0,0 +1,21 @@ +-- { dg-do run } + +with System; +procedure align_check is + N_Allocated_Buffers : Natural := 0; +-- + function New_Buffer (N_Bytes : Natural) return System.Address is + begin + N_Allocated_Buffers := N_Allocated_Buffers + 1; + return System.Null_Address; + end; +-- + Buffer_Address : constant System.Address := New_Buffer (N_Bytes => 8); + N : Natural; + for N'Address use Buffer_Address; +-- +begin + if N_Allocated_Buffers /= 1 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/align_max.adb b/gcc/testsuite/gnat.dg/align_max.adb new file mode 100644 index 000000000..26597ea96 --- /dev/null +++ b/gcc/testsuite/gnat.dg/align_max.adb @@ -0,0 +1,137 @@ +-- { dg-do run } + +with System.Storage_Elements; use System.Storage_Elements; +with Ada.Unchecked_Deallocation; + +procedure Align_MAX is + + Align : constant := Standard'Maximum_Alignment; + + generic + type Data_Type (<>) is private; + type Access_Type is access Data_Type; + with function Allocate return Access_Type; + with function Address (Ptr : Access_Type) return System.Address; + package Check is + -- The hooks below just force asm generation that helps associating + -- obscure nested function names with their package instance name. + Hook_Allocate : System.Address := Allocate'Address; + Hook_Address : System.Address := Address'Address; + pragma Volatile (Hook_Allocate); + pragma Volatile (Hook_Address); + + procedure Run (Announce : String); + end; + + package body Check is + + procedure Free is new + Ada.Unchecked_Deallocation (Data_Type, Access_Type); + + procedure Run (Announce : String) is + Addr : System.Address; + Blocks : array (1 .. 1024) of Access_Type; + begin + for J in Blocks'Range loop + Blocks (J) := Allocate; + Addr := Address (Blocks (J)); + if Addr mod Data_Type'Alignment /= 0 then + raise Program_Error; + end if; + end loop; + + for J in Blocks'Range loop + Free (Blocks (J)); + end loop; + end; + end; + +begin + declare + type Array_Type is array (Integer range <>) of Integer; + for Array_Type'Alignment use Align; + + type FAT_Array_Access is access all Array_Type; + + function Allocate return FAT_Array_Access is + begin + return new Array_Type (1 .. 1); + end; + + function Address (Ptr : FAT_Array_Access) return System.Address is + begin + return Ptr(1)'Address; + end; + package Check_FAT is new + Check (Array_Type, FAT_Array_Access, Allocate, Address); + begin + Check_FAT.Run ("Checking FAT pointer to UNC array"); + end; + + declare + type Array_Type is array (Integer range <>) of Integer; + for Array_Type'Alignment use Align; + + type THIN_Array_Access is access all Array_Type; + for THIN_Array_Access'Size use Standard'Address_Size; + + function Allocate return THIN_Array_Access is + begin + return new Array_Type (1 .. 1); + end; + + function Address (Ptr : THIN_Array_Access) return System.Address is + begin + return Ptr(1)'Address; + end; + package Check_THIN is new + Check (Array_Type, THIN_Array_Access, Allocate, Address); + begin + Check_THIN.Run ("Checking THIN pointer to UNC array"); + end; + + declare + type Array_Type is array (Integer range 1 .. 1) of Integer; + for Array_Type'Alignment use Align; + + type Array_Access is access all Array_Type; + + function Allocate return Array_Access is + begin + return new Array_Type; + end; + + function Address (Ptr : Array_Access) return System.Address is + begin + return Ptr(1)'Address; + end; + package Check_Array is new + Check (Array_Type, Array_Access, Allocate, Address); + begin + Check_Array.Run ("Checking pointer to constrained array"); + end; + + declare + type Record_Type is record + Value : Integer; + end record; + for Record_Type'Alignment use Align; + + type Record_Access is access all Record_Type; + + function Allocate return Record_Access is + begin + return new Record_Type; + end; + + function Address (Ptr : Record_Access) return System.Address is + begin + return Ptr.all'Address; + end; + package Check_Record is new + Check (Record_Type, Record_Access, Allocate, Address); + begin + Check_Record.Run ("Checking pointer to record"); + end; +end; + diff --git a/gcc/testsuite/gnat.dg/aligned_vla.adb b/gcc/testsuite/gnat.dg/aligned_vla.adb new file mode 100644 index 000000000..bd3eb7158 --- /dev/null +++ b/gcc/testsuite/gnat.dg/aligned_vla.adb @@ -0,0 +1,23 @@ +-- { dg-do run } + +procedure Aligned_Vla is + + type Table is array (Integer range <>) of Integer; + for Table'Alignment use Long_Float'Alignment; + + K : constant := 1; + Konstants : Table (1 .. 4) := (others => K); + + procedure Check_Copy (Len : Integer) is + My_Konstants : Table (1 .. Len) := Konstants (1 .. 1 + Len - 1); + begin + for I in My_Konstants'Range loop + if My_Konstants (I) /= K then + raise Program_Error; + end if; + end loop; + end; + +begin + Check_Copy (Len => 4); +end; diff --git a/gcc/testsuite/gnat.dg/alignment1.adb b/gcc/testsuite/gnat.dg/alignment1.adb new file mode 100644 index 000000000..169e11c41 --- /dev/null +++ b/gcc/testsuite/gnat.dg/alignment1.adb @@ -0,0 +1,16 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +procedure alignment1 is + + type My_Integer is record + Element : Integer; + end record; + + F : My_Integer; + +begin + if F'Alignment /= F.Element'Alignment then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/alignment2.adb b/gcc/testsuite/gnat.dg/alignment2.adb new file mode 100644 index 000000000..9f1be3c59 --- /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 000000000..2776f5b8a --- /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/alignment4.adb b/gcc/testsuite/gnat.dg/alignment4.adb new file mode 100644 index 000000000..c23bcfe48 --- /dev/null +++ b/gcc/testsuite/gnat.dg/alignment4.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } +-- { dg-options "-gnatws -fdump-tree-gimple" } + +procedure Alignment4 is + + type Stream is array (1..3) of Character; + + S1, S2 : Stream; + +begin + S1 := S2; +end; + +-- { dg-final { scan-tree-dump-not ".\F" "gimple" } } +-- { dg-final { cleanup-tree-dump "gimple" } } diff --git a/gcc/testsuite/gnat.dg/alignment5.adb b/gcc/testsuite/gnat.dg/alignment5.adb new file mode 100644 index 000000000..8a89f5ef8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/alignment5.adb @@ -0,0 +1,31 @@ +-- { dg-do compile } +-- { dg-options "-gnatws -fdump-tree-gimple" } + +procedure Alignment5 is + + type MY_REC is + record + A1 : INTEGER range -3 .. 3 ; -- symmetric + A2 : BOOLEAN ; + A3 : INTEGER range 0 .. 15 ; -- positive + A4 : INTEGER range 10 .. 100 ; -- arbitrary + A5 : BOOLEAN ; --5 + end record ; + + for MY_REC use + record + A1 at 0 range 0 .. 2 ; + A2 at 0 range 3 .. 3 ; + A3 at 0 range 4 .. 7 ; + A4 at 0 range 8 .. 15 ; + A5 at 0 range 16 .. 16 ; + end record ; + + A_REC, B_REC : MY_REC; + +begin + A_REC := B_REC; +end; + +-- { dg-final { scan-tree-dump-not "\.F" "gimple" } } +-- { dg-final { cleanup-tree-dump "gimple" } } diff --git a/gcc/testsuite/gnat.dg/alignment6.adb b/gcc/testsuite/gnat.dg/alignment6.adb new file mode 100644 index 000000000..f2889a50e --- /dev/null +++ b/gcc/testsuite/gnat.dg/alignment6.adb @@ -0,0 +1,32 @@ +-- { dg-do compile } +-- { dg-options "-gnatws -fdump-tree-gimple" } + +procedure Alignment6 is + + type MY_REC is + record + A1 : INTEGER range -3 .. 3 ; -- symmetric + A2 : BOOLEAN ; + A3 : INTEGER range 0 .. 15 ; -- positive + A4 : INTEGER range 10 .. 100 ; -- arbitrary + A5 : BOOLEAN ; --5 + end record ; + + for MY_REC use + record + A1 at 0 range 0 .. 2 ; + A2 at 0 range 3 .. 3 ; + A3 at 0 range 4 .. 7 ; + A4 at 0 range 8 .. 15 ; + A5 at 0 range 16 .. 16 ; + end record ; + + A_REC : MY_REC := ( 1 , TRUE , 7 , 11 , FALSE ); + B_REC : MY_REC; + +begin + B_REC := A_REC; +end; + +-- { dg-final { scan-tree-dump-not "VIEW_CONVERT_EXPR" "gimple" } } +-- { dg-final { cleanup-tree-dump "gimple" } } diff --git a/gcc/testsuite/gnat.dg/alignment7.adb b/gcc/testsuite/gnat.dg/alignment7.adb new file mode 100644 index 000000000..5a3b8eb43 --- /dev/null +++ b/gcc/testsuite/gnat.dg/alignment7.adb @@ -0,0 +1,24 @@ +-- { dg-do run } + +with System; + +procedure Alignment7 is + + type R is record + I : Integer; + F : Long_Float; + end record; + for R'Alignment use 8; + + procedure Q (A : System.Address) is + F : Long_Float; + for F'Address use A; + begin + F := 0.0; + end; + + V : R; + +begin + Q (V.F'Address); +end; diff --git a/gcc/testsuite/gnat.dg/alignment8.adb b/gcc/testsuite/gnat.dg/alignment8.adb new file mode 100644 index 000000000..06136c36e --- /dev/null +++ b/gcc/testsuite/gnat.dg/alignment8.adb @@ -0,0 +1,24 @@ +-- { dg-do run } + +with System; + +procedure Alignment8 is + + type R is record + I : Integer; + F : Long_Long_Integer; + end record; + for R'Alignment use 8; + + procedure Q (A : System.Address) is + F : Long_Long_Integer; + for F'Address use A; + begin + F := 0; + end; + + V : R; + +begin + Q (V.F'Address); +end; diff --git a/gcc/testsuite/gnat.dg/alignment9.adb b/gcc/testsuite/gnat.dg/alignment9.adb new file mode 100644 index 000000000..ae7a7f67e --- /dev/null +++ b/gcc/testsuite/gnat.dg/alignment9.adb @@ -0,0 +1,30 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +procedure Alignment9 is + + type Kind is (Small, Large); + for Kind'Size use 8; + + type Header is + record + K : Kind; + I : Integer; + end record; + + for Header use + record + K at 4 range 0..7; + I at 0 range 0..31; + end record; + + for Header'Size use 5*8; + for Header'Alignment use 1; + + H : Header; + +begin + if H'Size /= 40 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/allocator_maxalign1.adb b/gcc/testsuite/gnat.dg/allocator_maxalign1.adb new file mode 100644 index 000000000..062c39bbf --- /dev/null +++ b/gcc/testsuite/gnat.dg/allocator_maxalign1.adb @@ -0,0 +1,42 @@ +-- { dg-do run } + +with System.Storage_Elements; use System.Storage_Elements; +with Ada.Unchecked_Deallocation; + +procedure Allocator_Maxalign1 is + + Max_Alignment : constant := Standard'Maximum_Alignment; + + type Block is record + X : Integer; + end record; + for Block'Alignment use Standard'Maximum_Alignment; + + type Block_Access is access all Block; + procedure Free is new Ada.Unchecked_Deallocation (Block, Block_Access); + + N_Blocks : constant := 500; + Blocks : array (1 .. N_Blocks) of Block_Access; +begin + if Block'Alignment /= Max_Alignment then + raise Program_Error; + end if; + + for K in 1 .. 4 loop + + for I in Blocks'Range loop + Blocks (I) := new Block; + if Blocks (I).all'Address mod Block'Alignment /= 0 then + raise Program_Error; + end if; + Blocks(I).all.X := I; + end loop; + + for I in Blocks'Range loop + Free (Blocks (I)); + end loop; + + end loop; + +end; + diff --git a/gcc/testsuite/gnat.dg/allocator_maxalign2.adb b/gcc/testsuite/gnat.dg/allocator_maxalign2.adb new file mode 100644 index 000000000..10644ea6b --- /dev/null +++ b/gcc/testsuite/gnat.dg/allocator_maxalign2.adb @@ -0,0 +1,33 @@ +with System, System.Storage_Elements; +use System.Storage_Elements; + +package body Allocator_Maxalign2 is + + Max_Align : constant Storage_Offset := Standard'Maximum_Alignment; + + procedure Validate is + use type System.Address; + begin + if Addr mod Max_Align /= 0 then + raise Program_Error; + end if; + end; + + procedure Check is + I : Integer; + B : Block; + type Block_Access is access all Block; + A : Block_Access; + begin + Addr := I'Address; + Addr := B'Address; + Validate; + for I in 1 .. 50 loop + A := new Block; + Addr := A.all'Address; + Validate; + end loop; + + end; + +end; diff --git a/gcc/testsuite/gnat.dg/allocator_maxalign2.ads b/gcc/testsuite/gnat.dg/allocator_maxalign2.ads new file mode 100644 index 000000000..43c01081c --- /dev/null +++ b/gcc/testsuite/gnat.dg/allocator_maxalign2.ads @@ -0,0 +1,12 @@ +with System; + +package Allocator_Maxalign2 is + type Block is record + X : Integer; + end record; + for Block'Alignment use Standard'Maximum_Alignment; + + Addr : System.Address; + + procedure Check; +end; diff --git a/gcc/testsuite/gnat.dg/ancestor_type.adb b/gcc/testsuite/gnat.dg/ancestor_type.adb new file mode 100644 index 000000000..b5e9e2c5c --- /dev/null +++ b/gcc/testsuite/gnat.dg/ancestor_type.adb @@ -0,0 +1,13 @@ +-- { dg-do compile } + +package body Ancestor_Type is + + package body B is + function make return T is + begin + return (T with n => 0); -- { dg-error "expect ancestor" } + end make; + + end B; + +end Ancestor_Type; diff --git a/gcc/testsuite/gnat.dg/ancestor_type.ads b/gcc/testsuite/gnat.dg/ancestor_type.ads new file mode 100644 index 000000000..2ed1f19c2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/ancestor_type.ads @@ -0,0 +1,13 @@ +package Ancestor_Type is + + type T is tagged private; + + package B is + function make return T; + end B; + +private + type T is tagged record + n: Natural; + end record; +end Ancestor_Type; diff --git a/gcc/testsuite/gnat.dg/anon1.ads b/gcc/testsuite/gnat.dg/anon1.ads new file mode 100644 index 000000000..d3aaa560d --- /dev/null +++ b/gcc/testsuite/gnat.dg/anon1.ads @@ -0,0 +1,4 @@ + +package anon1 is + function F return access Integer; +end anon1; diff --git a/gcc/testsuite/gnat.dg/anon2.adb b/gcc/testsuite/gnat.dg/anon2.adb new file mode 100644 index 000000000..c114fcc85 --- /dev/null +++ b/gcc/testsuite/gnat.dg/anon2.adb @@ -0,0 +1,9 @@ +-- { dg-do compile } + +with anon1; +procedure anon2 is +begin + if anon1.F /= null then + null; + end if; +end anon2; diff --git a/gcc/testsuite/gnat.dg/array1.adb b/gcc/testsuite/gnat.dg/array1.adb new file mode 100644 index 000000000..0540f8876 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array1.adb @@ -0,0 +1,32 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +package body array1 is + + subtype Small is Integer range 1 .. MAX; + + type LFT is record + RIC_ID : RIC_TYPE; + end record; + + LF : array (RIC_TYPE, Small) of LFT; + + procedure Foo (R : RIC_TYPE) is + L : Small; + T : LFT renames LF (R, L); + begin + Start_Timer (T'ADDRESS); + end; + + procedure Bar (A : Integer; R : RIC_TYPE) is + S : LFT renames LF (R, A); + begin + null; + end; + + procedure Start_Timer (Q : SYSTEM.ADDRESS) is + begin + null; + end; + +end array1; diff --git a/gcc/testsuite/gnat.dg/array1.ads b/gcc/testsuite/gnat.dg/array1.ads new file mode 100644 index 000000000..8f8ecc070 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array1.ads @@ -0,0 +1,9 @@ +with SYSTEM; +WITH array2; use array2; + +package array1 is + + procedure Foo (R : RIC_TYPE); + procedure Start_Timer (Q : SYSTEM.ADDRESS); + +end array1; diff --git a/gcc/testsuite/gnat.dg/array10.adb b/gcc/testsuite/gnat.dg/array10.adb new file mode 100644 index 000000000..37ee8ffb4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array10.adb @@ -0,0 +1,25 @@ +-- { dg-do run } +-- Verify that an array of non-aliased zero-sized element is zero-sized + +procedure Array10 is + + type Rec is null record; + + type Arr1 is array (1..8) of Rec; + type Arr2 is array (Long_Integer) of Rec; + + R : Rec; + A1 : Arr1; + A2 : Arr2; + +begin + if Rec'Size /= 0 then + raise Program_Error; + end if; + if Arr1'Size /= 0 then + raise Program_Error; + end if; + if Arr2'Size /= 0 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/array11.adb b/gcc/testsuite/gnat.dg/array11.adb new file mode 100644 index 000000000..7be61c4b6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array11.adb @@ -0,0 +1,16 @@ +-- { dg-do compile } + +procedure Array11 is + + type Rec is null record; + type Ptr is access all Rec; + + type Arr1 is array (1..8) of aliased Rec; -- { dg-warning "padded" } + type Arr2 is array (Long_Integer) of aliased Rec; -- { dg-warning "padded" } + + A1 : Arr1; + A2 : Arr2; -- { dg-warning "Storage_Error" } + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/array12.adb b/gcc/testsuite/gnat.dg/array12.adb new file mode 100644 index 000000000..3748d5ec2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array12.adb @@ -0,0 +1,20 @@ +-- { dg-do run } + +procedure Array12 is + + function N return Integer is + begin + return 0; + end; + + subtype Element is String (1 .. N); + type Ptr is access all Element; + type Vector is array (Positive range <>) of aliased Element; + + V : Vector (1..2); + +begin + if Ptr'(V(1)'Access) = V(2)'Access then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/array13.adb b/gcc/testsuite/gnat.dg/array13.adb new file mode 100644 index 000000000..245d40af2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array13.adb @@ -0,0 +1,14 @@ +-- PR ada/38394 +-- Reporter: Michael Völske <michael.voelske@medien.uni-weimar.de> + +-- { dg-do assemble } + +package body Array13 is + + procedure Foo is + X, Y : T; + begin + null; + end; + +end Array13; diff --git a/gcc/testsuite/gnat.dg/array13.ads b/gcc/testsuite/gnat.dg/array13.ads new file mode 100644 index 000000000..0d0a8df50 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array13.ads @@ -0,0 +1,13 @@ +package Array13 is + + Max : Natural := 1; + + type Arr is array (Natural range 0..Max) of Natural; + + type T is record + A : Arr := (others => 0); + end record; + + procedure Foo; + +end Array13; diff --git a/gcc/testsuite/gnat.dg/array2.ads b/gcc/testsuite/gnat.dg/array2.ads new file mode 100644 index 000000000..323374f09 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array2.ads @@ -0,0 +1,8 @@ +package array2 is + + type RIC_TYPE is (RIC1, RIC2); + for RIC_TYPE'SIZE use 32; + + function MAX return Integer; + +end array2; diff --git a/gcc/testsuite/gnat.dg/array3.adb b/gcc/testsuite/gnat.dg/array3.adb new file mode 100644 index 000000000..797692563 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array3.adb @@ -0,0 +1,37 @@ +-- { dg-do run } + +with Ada.Containers.Vectors; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +procedure array3 is + type Method_Kinds is (Signal, Slot, Method); + + package Unbounded_String_Vectors is + new Ada.Containers.Vectors + (Positive, Ada.Strings.Unbounded.Unbounded_String); + + Params_Vector : Unbounded_String_Vectors.Vector; + + type Method_Info is record + Name : Ada.Strings.Unbounded.Unbounded_String; + Signature : Ada.Strings.Unbounded.Unbounded_String; + Parameters : Unbounded_String_Vectors.Vector; + Kind : Method_Kinds; + end record; + + package Method_Info_Vectors is + new Ada.Containers.Vectors (Positive, Method_Info); + + Signals : Method_Info_Vectors.Vector; +begin + + Unbounded_String_Vectors.Append + (Params_Vector, + Ada.Strings.Unbounded.To_Unbounded_String ("AAA")); + + Method_Info_Vectors.Append + (Signals, + (Name => To_Unbounded_String (""), + Signature => To_Unbounded_String (""), + Parameters => Params_Vector, + Kind => Signal)); +end; diff --git a/gcc/testsuite/gnat.dg/array4.adb b/gcc/testsuite/gnat.dg/array4.adb new file mode 100644 index 000000000..048698a54 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array4.adb @@ -0,0 +1,37 @@ +-- { dg-do run } + +procedure Array4 is + + type A is array (1..5) of Integer; + f : constant A := (1, 2, 3, 4, 5); + + i1 : integer renames f(1); + i2 : integer renames f(2); + i3 : integer renames f(3); + i4 : integer renames f(4); + i5 : integer renames f(5); + + procedure Link_Failure; + pragma Import (C, Link_Failure); + +begin + if i1 /= 1 then + Link_Failure; + end if; + + if i2 /= 2 then + Link_Failure; + end if; + + if i3 /= 3 then + Link_Failure; + end if; + + if i4 /= 4 then + Link_Failure; + end if; + + if i5 /= 5 then + Link_Failure; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/array5.adb b/gcc/testsuite/gnat.dg/array5.adb new file mode 100644 index 000000000..72a5df821 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array5.adb @@ -0,0 +1,34 @@ +-- { dg-do run } +-- { dg-options "-O" } + +procedure Array5 is + + type myint is range 0 .. 100_000; + Bla : constant myint := 359; + + type my_array is array (1 .. 2) of myint; + + type item is record + Length : Integer; + Content : my_array; + end record; + + procedure create_item (M : out item) is + begin + M.Length := 1; + M.Content := (others => Bla); + end; + + Var : item; + +begin + create_item (Var); + + if Var.Length = 1 + and then Var.Content (1) = Bla + then + null; + else + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/array6.adb b/gcc/testsuite/gnat.dg/array6.adb new file mode 100644 index 000000000..1cc9d1093 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array6.adb @@ -0,0 +1,25 @@ +-- { dg-do run } + +with Interfaces; use Interfaces; + +procedure Array6 is + + type buf_t is array (unsigned_32 range <>) of character; + type v_str_t (first, last : unsigned_32) is + record + buf : buf_t (first .. last) := (others => ' '); + end record; + type v_str_ptr_t is access all v_str_t; + + v_str : v_str_ptr_t; + + function build_v_str (f, l : unsigned_32) return v_str_ptr_t is + vp : v_str_ptr_t := new v_str_t (f, l); + begin + return vp; + end; + +begin + v_str := build_v_str (unsigned_32'last/2 - 256, + unsigned_32'last/2 + 1024*1024); +end; diff --git a/gcc/testsuite/gnat.dg/array7.adb b/gcc/testsuite/gnat.dg/array7.adb new file mode 100644 index 000000000..d83a55a48 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array7.adb @@ -0,0 +1,23 @@ +-- { dg-do compile } +-- { dg-options "-O -gnatp -fdump-tree-optimized" } + +package body Array7 is + + package body Range_Subtype is + function Get_Arr (Nbr : My_Range) return Arr_Acc is + begin + return new Arr (1 .. Nbr); + end; + end; + + package body Range_Type is + function Get_Arr (Nbr : My_Range) return Arr_Acc is + begin + return new Arr (1 .. Nbr); + end; + end; + +end Array7; + +-- { dg-final { scan-tree-dump-not "MAX_EXPR" "optimized" } } +-- { dg-final { cleanup-tree-dump "optimized" } } diff --git a/gcc/testsuite/gnat.dg/array7.ads b/gcc/testsuite/gnat.dg/array7.ads new file mode 100644 index 000000000..bd8ec9331 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array7.ads @@ -0,0 +1,20 @@ +package Array7 is + + package Range_Subtype is + type Arr is array (Positive range <>) of Integer; + type Arr_Acc is access Arr; + + subtype My_Range is Integer range 1 .. 25; + function Get_Arr (Nbr : My_Range) return Arr_Acc; + end; + + package Range_Type is + + type My_Range is range 1 .. 25; + type Arr is array (My_Range range <>) of Integer; + type Arr_Acc is access Arr; + + function Get_Arr (Nbr : My_Range) return Arr_Acc; + end; + +end Array7; diff --git a/gcc/testsuite/gnat.dg/array8.adb b/gcc/testsuite/gnat.dg/array8.adb new file mode 100644 index 000000000..6e18ecadf --- /dev/null +++ b/gcc/testsuite/gnat.dg/array8.adb @@ -0,0 +1,34 @@ +-- { dg-do compile } +-- { dg-options "-O2" } + +PROCEDURE Array8 IS + + function ID (I : Integer) return Integer is + begin + return I; + end; + + SUBTYPE STB IS INTEGER RANGE ID(-8) .. -5; + + TYPE TB IS ARRAY (STB RANGE <>) OF INTEGER; + + GENERIC + B1 : TB; + PROCEDURE PROC1; + + PROCEDURE PROC1 IS + BEGIN + IF B1'FIRST /= -8 THEN + raise Program_Error; + ELSIF B1'LAST /= ID(-5) THEN + raise Program_Error; + ELSIF B1 /= (7, 6, 5, 4) THEN + raise Program_Error; + END IF; + END; + + PROCEDURE PROC2 IS NEW PROC1 ((7, 6, ID(5), 4)); + +BEGIN + PROC2; +END; diff --git a/gcc/testsuite/gnat.dg/array9.adb b/gcc/testsuite/gnat.dg/array9.adb new file mode 100644 index 000000000..4a1387618 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array9.adb @@ -0,0 +1,20 @@ +-- { dg-do run } + +procedure Array9 is + + V1 : String(1..10) := "1234567890"; + V2 : String(1..-1) := ""; + + procedure Compare (S : String) is + begin + if S'Size /= 8*S'Length then + raise Program_Error; + end if; + end; + +begin + Compare (""); + Compare ("1234"); + Compare (V1); + Compare (V2); +end; diff --git a/gcc/testsuite/gnat.dg/array_bounds_test.adb b/gcc/testsuite/gnat.dg/array_bounds_test.adb new file mode 100644 index 000000000..5be27ff80 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array_bounds_test.adb @@ -0,0 +1,15 @@ +-- { dg-do run } + +with Ada.Streams; use Ada.Streams; +procedure Array_Bounds_Test is + One : constant Stream_Element := 1; + Two : constant Stream_Element := 2; + Sample : constant Stream_Element_Array := (0 => One) & Two; +begin + if Sample'First /= 0 then + raise Program_Error; + end if; + if Sample'Last /= 1 then + raise Program_Error; + end if; +end Array_Bounds_Test; diff --git a/gcc/testsuite/gnat.dg/assert.ads b/gcc/testsuite/gnat.dg/assert.ads new file mode 100644 index 000000000..81a912a8a --- /dev/null +++ b/gcc/testsuite/gnat.dg/assert.ads @@ -0,0 +1,5 @@ +package Assert is + + procedure Assert (Condition : Boolean); + +end Assert; diff --git a/gcc/testsuite/gnat.dg/assert1.adb b/gcc/testsuite/gnat.dg/assert1.adb new file mode 100644 index 000000000..d761cd0d9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/assert1.adb @@ -0,0 +1,39 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +pragma Assertion_Policy (Check); +with Text_IO; use Text_IO; +procedure assert1 is + type p1 is array (1 .. 113) of Boolean; + pragma Pack (p1); + type p2 is array (1 .. 13) of Boolean; + pragma Pack (p2); + type p3 is array (1 .. 113) of Boolean; + pragma Pack (p3); + for p3'size use 113; + type p4 is array (1 .. 13) of Boolean; + pragma Pack (p4); + for p4'size use 13; + v1 : p1; + v2 : p2; + v3 : p3; + v4 : p4; +begin + pragma Assert (p1'Size = 120); + pragma Assert (p2'Size = 13); + pragma Assert (p3'Size = 113); + pragma Assert (p4'Size = 13); + pragma Assert (p1'Value_Size = 120); + pragma Assert (p2'Value_Size = 13); + pragma Assert (p3'Value_Size = 113); + pragma Assert (p4'Value_Size = 13); + pragma Assert (p1'Object_Size = 120); + pragma Assert (p2'Object_Size = 16); + pragma Assert (p3'Object_Size = 120); + pragma Assert (p4'Object_Size = 16); + pragma Assert (v1'Size = 120); + pragma Assert (v2'Size = 16); + pragma Assert (v3'Size = 120); + pragma Assert (v4'Size = 16); + null; +end; diff --git a/gcc/testsuite/gnat.dg/assign_from_packed.adb b/gcc/testsuite/gnat.dg/assign_from_packed.adb new file mode 100644 index 000000000..24399a011 --- /dev/null +++ b/gcc/testsuite/gnat.dg/assign_from_packed.adb @@ -0,0 +1,15 @@ +-- { dg-do run } + +with assign_from_packed_pixels; +use assign_from_packed_pixels; + +procedure assign_from_packed is + + A : Integer := Minus_One; + Pos : Position; +begin + Pos := Pix.Pos; + if A /= Minus_One then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/assign_from_packed_pixels.ads b/gcc/testsuite/gnat.dg/assign_from_packed_pixels.ads new file mode 100644 index 000000000..66ade8a84 --- /dev/null +++ b/gcc/testsuite/gnat.dg/assign_from_packed_pixels.ads @@ -0,0 +1,18 @@ + +package Assign_From_Packed_Pixels is + + type U16 is mod 2 ** 16; + + type Position is record + X, Y, Z : U16; + end record; + for Position'Size use 48; + + type Pixel is record + Pos : Position; + end record; + pragma Pack (Pixel); + + Minus_One : Integer := -1; + Pix : Pixel := (Pos => (X => 0, Y => 0, Z => 0)); +end; diff --git a/gcc/testsuite/gnat.dg/asynch.adb b/gcc/testsuite/gnat.dg/asynch.adb new file mode 100644 index 000000000..024af725c --- /dev/null +++ b/gcc/testsuite/gnat.dg/asynch.adb @@ -0,0 +1,24 @@ +-- { dg-do compile } + +package body asynch is + function null_ctrl return t_ctrl is + begin + return (Ada.Finalization.Controlled with stuff => 0); + end null_ctrl; + + procedure Proc (msg : String; c : t_ctrl := null_ctrl) is + begin + null; + end Proc; + + task type tsk; + task body tsk is + begin + select + delay 10.0; + Proc ("A message."); + then abort + null; + end select; + end tsk; +end asynch; diff --git a/gcc/testsuite/gnat.dg/asynch.ads b/gcc/testsuite/gnat.dg/asynch.ads new file mode 100644 index 000000000..c9b70aaf0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/asynch.ads @@ -0,0 +1,8 @@ +with Ada.Finalization; +package asynch is + type t_ctrl is new Ada.Finalization.Controlled with record + stuff : Natural := 0; + end record; + + function null_ctrl return t_ctrl; +end asynch; diff --git a/gcc/testsuite/gnat.dg/atomic1.adb b/gcc/testsuite/gnat.dg/atomic1.adb new file mode 100644 index 000000000..59e1be201 --- /dev/null +++ b/gcc/testsuite/gnat.dg/atomic1.adb @@ -0,0 +1,18 @@ +-- { dg-do compile } +-- { dg-options "-O0 -fdump-tree-gimple" } + +with Atomic1_Pkg; use Atomic1_Pkg; + +procedure Atomic1 is + + C_16 : constant R16 := (2, 3, 5, 7); + C_32 : constant R32 := (1, 1, 2, 3, 5, 8, 13, 5); + +begin + V_16 := C_16; + V_32 := C_32; +end; + +-- { dg-final { scan-tree-dump-times "v_16" 1 "gimple"} } +-- { dg-final { scan-tree-dump-times "v_32" 1 "gimple"} } +-- { dg-final { cleanup-tree-dump "gimple" } } diff --git a/gcc/testsuite/gnat.dg/atomic1_pkg.ads b/gcc/testsuite/gnat.dg/atomic1_pkg.ads new file mode 100644 index 000000000..809c3e3aa --- /dev/null +++ b/gcc/testsuite/gnat.dg/atomic1_pkg.ads @@ -0,0 +1,47 @@ +package Atomic1_Pkg is + + type Four_Bits is mod 2 ** 4; + + type R16 is record + F1 : Four_Bits; + F2 : Four_Bits; + F3 : Four_Bits; + F4 : Four_Bits; + end record; + for R16 use record + F1 at 0 range 0 .. 3; + F2 at 0 range 4 .. 7; + F3 at 0 range 8 .. 11; + F4 at 0 range 12 .. 15; + end record; + + type R32 is record + F1 : Four_Bits; + F2 : Four_Bits; + F3 : Four_Bits; + F4 : Four_Bits; + F5 : Four_Bits; + F6 : Four_Bits; + F7 : Four_Bits; + F8 : Four_Bits; + end record; + for R32 use record + F1 at 0 range 0 .. 3; + F2 at 0 range 4 .. 7; + F3 at 0 range 8 .. 11; + F4 at 0 range 12 .. 15; + F5 at 0 range 16 .. 19; + F6 at 0 range 20 .. 23; + F7 at 0 range 24 .. 27; + F8 at 0 range 28 .. 31; + end record; + + C_16 : constant R16 := (2, 3, 5, 7); + C_32 : constant R32 := (1, 1, 2, 3, 5, 8, 13, 5); + + V_16 : R16; + pragma Atomic (V_16); + V_32 : R32; + pragma Atomic (V_32); + +end Atomic1_Pkg; diff --git a/gcc/testsuite/gnat.dg/atomic2.adb b/gcc/testsuite/gnat.dg/atomic2.adb new file mode 100644 index 000000000..c14d21e13 --- /dev/null +++ b/gcc/testsuite/gnat.dg/atomic2.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } + +procedure Atomic2 is + + type Big is array (1..4) of Integer; + type Arr is array (1..10) of Big; + pragma Atomic_Components (Arr); -- { dg-warning "cannot be guaranteed" } + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/atomic3.adb b/gcc/testsuite/gnat.dg/atomic3.adb new file mode 100644 index 000000000..592a856ca --- /dev/null +++ b/gcc/testsuite/gnat.dg/atomic3.adb @@ -0,0 +1,24 @@ +-- { dg-do compile } + +procedure Atomic3 is + + type Unsigned_32_T is mod 2 ** 32; + for Unsigned_32_T'Size use 32; + + type Id_T is (One, Two, Three); + + type Array_T is array (Id_T) of Unsigned_32_T; + pragma Atomic_Components (Array_T); + + A : Array_T := (others => 0); + + function Get_Array return Array_T is + begin + return A; + end; + + X : Array_T; + +begin + X := Get_Array; +end; diff --git a/gcc/testsuite/gnat.dg/atomic4.adb b/gcc/testsuite/gnat.dg/atomic4.adb new file mode 100644 index 000000000..99f4ee14c --- /dev/null +++ b/gcc/testsuite/gnat.dg/atomic4.adb @@ -0,0 +1,12 @@ +-- { dg-do compile } +-- { dg-options "-O -gnatn" } + +package body Atomic4 is + + procedure Next (Self : in out Reader'Class) is + begin + Self.Current_Reference := Self.Reference_Stack.Last_Element; + Self.Reference_Stack.Delete_Last; + end Next; + +end Atomic4; diff --git a/gcc/testsuite/gnat.dg/atomic4.ads b/gcc/testsuite/gnat.dg/atomic4.ads new file mode 100644 index 000000000..a0e95bbff --- /dev/null +++ b/gcc/testsuite/gnat.dg/atomic4.ads @@ -0,0 +1,23 @@ +with Ada.Containers.Vectors; + +package Atomic4 is + + type String is limited null record; + type String_Access is access all String; + pragma Atomic (String_Access); + + type Reference is record + Text : String_Access; + end record; + + package Reference_Vectors is + new Ada.Containers.Vectors (Natural, Reference); + + type Reader is tagged limited record + Current_Reference : Reference; + Reference_Stack : Reference_Vectors.Vector; + end record; + + procedure Next (Self : in out Reader'Class); + +end Atomic4; diff --git a/gcc/testsuite/gnat.dg/atomic5.adb b/gcc/testsuite/gnat.dg/atomic5.adb new file mode 100644 index 000000000..d17e6ff1c --- /dev/null +++ b/gcc/testsuite/gnat.dg/atomic5.adb @@ -0,0 +1,22 @@ +-- { dg-do compile } + +package body Atomic5 is + + function Create return R is + begin + return (A => 0, B => 1, C => 2, D => 4); + end; + + procedure Proc1 is + I : Unsigned_32; + begin + I := Conv(Create); + end; + + procedure Proc2 is + I : Unsigned_32; + begin + I := Conv(R'(A => 0, B => 1, C => 2, D => 4)); + end; + +end Atomic5; diff --git a/gcc/testsuite/gnat.dg/atomic5.ads b/gcc/testsuite/gnat.dg/atomic5.ads new file mode 100644 index 000000000..ce702ba1c --- /dev/null +++ b/gcc/testsuite/gnat.dg/atomic5.ads @@ -0,0 +1,23 @@ +with Unchecked_Conversion; + +package Atomic5 is + + type Byte is mod 2 ** 8; + for Byte'Size use 8; + + type Unsigned_32 is mod 2 ** 32; + for Unsigned_32'Size use 32; + + type R is record + A,B,C,D : Byte; + end record; + for R'Alignment use 4; + pragma Atomic (R); + + function Conv is new Unchecked_Conversion (R, Unsigned_32); + + procedure Proc1; + + procedure Proc2; + +end Atomic5; diff --git a/gcc/testsuite/gnat.dg/bad_array.adb b/gcc/testsuite/gnat.dg/bad_array.adb new file mode 100644 index 000000000..5d49f9ba6 --- /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/biased_uc.adb b/gcc/testsuite/gnat.dg/biased_uc.adb new file mode 100644 index 000000000..af90f420a --- /dev/null +++ b/gcc/testsuite/gnat.dg/biased_uc.adb @@ -0,0 +1,54 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +with Unchecked_Conversion; +procedure biased_uc is +begin + -- Case (f) target type is biased, source is unbiased + + declare + type a is new integer range 0 .. 255; + for a'size use 8; + + type b is new integer range 200 .. 455; + for b'size use 8; + + av : a; + bv : b; + + for av'size use 8; + for bv'size use 8; + + function a2b is new Unchecked_Conversion (a,b); + + begin + bv := a2b (200); + if bv = 200 then + raise Program_Error; + end if; + end; + + -- Case (g) target type is biased, source object is biased + + declare + type a is new integer range 1 .. 256; + for a'size use 16; + + type b is new integer range 1 .. 65536; + for b'size use 16; + + av : a; + bv : b; + + for av'size use 8; + for bv'size use 16; + + function a2b is new Unchecked_Conversion (a,b); + + begin + bv := a2b (1); + if bv /= 2 then + raise Program_Error; + end if; + end; +end; diff --git a/gcc/testsuite/gnat.dg/bip_aggregate_bug.adb b/gcc/testsuite/gnat.dg/bip_aggregate_bug.adb new file mode 100644 index 000000000..ce8daeb5e --- /dev/null +++ b/gcc/testsuite/gnat.dg/bip_aggregate_bug.adb @@ -0,0 +1,49 @@ +-- { dg-do run } + +procedure BIP_Aggregate_Bug is + + package Limited_Types is + + type Lim_Tagged is tagged limited record + Root_Comp : Integer; + end record; + + type Lim_Ext is new Lim_Tagged with record + Ext_Comp : Integer; + end record; + + function Func_Lim_Tagged (Choice : Integer) return Lim_Tagged'Class; + + end Limited_Types; + + package body Limited_Types is + + function Func_Lim_Tagged (Choice : Integer) return Lim_Tagged'Class is + begin + case Choice is + when 111 => + return Lim_Ext'(Root_Comp => Choice, Ext_Comp => Choice); + when 222 => + return Result : Lim_Tagged'Class + := Lim_Ext'(Root_Comp => Choice, Ext_Comp => Choice); + when others => + return Lim_Tagged'(Root_Comp => Choice); + end case; + end Func_Lim_Tagged; + + end Limited_Types; + + use Limited_Types; + + LT_Root : Lim_Tagged'Class := Func_Lim_Tagged (Choice => 999); + LT_Ext1 : Lim_Tagged'Class := Func_Lim_Tagged (Choice => 111); + LT_Ext2 : Lim_Tagged'Class := Func_Lim_Tagged (Choice => 222); + +begin + if LT_Root.Root_Comp /= 999 + or else Lim_Ext (LT_Ext1).Ext_Comp /= 111 + or else Lim_Ext (LT_Ext2).Ext_Comp /= 222 + then + raise Program_Error; + end if; +end BIP_Aggregate_Bug; diff --git a/gcc/testsuite/gnat.dg/bip_prim_func.adb b/gcc/testsuite/gnat.dg/bip_prim_func.adb new file mode 100644 index 000000000..6529fe50a --- /dev/null +++ b/gcc/testsuite/gnat.dg/bip_prim_func.adb @@ -0,0 +1,14 @@ +-- { dg-do compile } + +package body BIP_Prim_Func is + + type NTT is new TT with record + J : Integer; + end record; + + function Prim_Func return NTT is + begin + return Result : NTT := (I => 1, J => 2); + end Prim_Func; + +end BIP_Prim_Func; diff --git a/gcc/testsuite/gnat.dg/bip_prim_func.ads b/gcc/testsuite/gnat.dg/bip_prim_func.ads new file mode 100644 index 000000000..37f7ac0fd --- /dev/null +++ b/gcc/testsuite/gnat.dg/bip_prim_func.ads @@ -0,0 +1,11 @@ + +package BIP_Prim_Func is + pragma Elaborate_Body; + + type TT is abstract tagged limited record + I : Integer; + end record; + + function Prim_Func return TT is abstract; + +end BIP_Prim_Func; diff --git a/gcc/testsuite/gnat.dg/bit_packed_array1.adb b/gcc/testsuite/gnat.dg/bit_packed_array1.adb new file mode 100644 index 000000000..10fd2921f --- /dev/null +++ b/gcc/testsuite/gnat.dg/bit_packed_array1.adb @@ -0,0 +1,16 @@ +-- PR ada/33788 +-- Origin: Oliver Kellogg <oliver.kellogg@eads.com> + +-- { dg-do compile } + +package body Bit_Packed_Array1 is + + procedure Generate_Callforward is + Compiler_Crash : String := + Laser_Illuminator_Code_Group_T'Image + (MADR.ISF.Laser_Illuminator_Code (0)); + begin + null; + end Generate_Callforward; + +end Bit_Packed_Array1; diff --git a/gcc/testsuite/gnat.dg/bit_packed_array1.ads b/gcc/testsuite/gnat.dg/bit_packed_array1.ads new file mode 100644 index 000000000..a0d5ab7a8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/bit_packed_array1.ads @@ -0,0 +1,34 @@ +with Interfaces; + +package Bit_Packed_Array1 is + + type laser_illuminator_code_group_t is (zero, one); + pragma Convention (C, laser_illuminator_code_group_t); + + subtype lic_array_index_t is Interfaces.Unsigned_8 range 0 .. 3; + + type lic_array_t is array (lic_array_index_t) + of laser_illuminator_code_group_t; + pragma Convention (C, lic_array_t); + + type Eighty_Bytes_T is array (1 .. 80) of Interfaces.Unsigned_8; + + type Mission_Assignment_T is record + Eighty_Bytes : Eighty_Bytes_T; + Laser_Illuminator_Code : lic_array_t; + end record; + + for Mission_Assignment_T use record + Eighty_Bytes at 0 range 0 .. 639; + Laser_Illuminator_Code at 0 range 653 .. 780; + end record; + + type Mission_Assignment_Dbase_Rec_T is record + ISF : Mission_Assignment_T; + end record; + + MADR : Mission_Assignment_Dbase_Rec_T; + + procedure Generate_Callforward; + +end Bit_Packed_Array1; diff --git a/gcc/testsuite/gnat.dg/bit_packed_array2.adb b/gcc/testsuite/gnat.dg/bit_packed_array2.adb new file mode 100644 index 000000000..b403122f5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/bit_packed_array2.adb @@ -0,0 +1,19 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +procedure Bit_Packed_Array2 is + + type Bit_Array is array (integer range <>) of Boolean; + pragma Pack(Bit_Array); + + b1 : Bit_Array(1..64); + b2 : Bit_array(1..64); + res : Bit_array(1..64); + +begin + + if (not((not b1) or (not b2))) /= res then + null; + end if; + +end; diff --git a/gcc/testsuite/gnat.dg/bit_packed_array3.adb b/gcc/testsuite/gnat.dg/bit_packed_array3.adb new file mode 100644 index 000000000..0b121efdc --- /dev/null +++ b/gcc/testsuite/gnat.dg/bit_packed_array3.adb @@ -0,0 +1,40 @@ +-- { dg-do run } +-- { dg-options "-O2 -gnatp" } + +procedure Bit_Packed_Array3 is + + type Bitmap_T is array (1 .. 10) of Boolean; + pragma Pack (Bitmap_T); + + type Maps_T is record + M1 : Bitmap_T; + end record; + pragma Pack (Maps_T); + for Maps_T'Size use 10; + pragma Suppress_Initialization (Maps_T); + + Tmap : constant Bitmap_T := (others => True); + Fmap : constant Bitmap_T := (others => False); + Amap : constant Bitmap_T := + (1 => False, 2 => True, 3 => False, 4 => True, 5 => False, + 6 => True, 7 => False, 8 => True, 9 => False, 10 => True); + + function Some_Maps return Maps_T is + Value : Maps_T := (M1 => Amap); + begin + return Value; + end; + pragma Inline (Some_Maps); + + Maps : Maps_T; +begin + Maps := Some_Maps; + + for I in Maps.M1'Range loop + if (I mod 2 = 0 and then not Maps.M1 (I)) + or else (I mod 2 /= 0 and then Maps.M1 (I)) + then + raise Program_Error; + end if; + end loop; +end; diff --git a/gcc/testsuite/gnat.dg/bit_packed_array4.adb b/gcc/testsuite/gnat.dg/bit_packed_array4.adb new file mode 100644 index 000000000..35088a7eb --- /dev/null +++ b/gcc/testsuite/gnat.dg/bit_packed_array4.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } + +package body Bit_Packed_Array4 is + + procedure Process (M : Message_Type) is + D : Data_Type; + begin + D := M.Data; + end; + +end Bit_Packed_Array4; diff --git a/gcc/testsuite/gnat.dg/bit_packed_array4.ads b/gcc/testsuite/gnat.dg/bit_packed_array4.ads new file mode 100644 index 000000000..7713e8f3e --- /dev/null +++ b/gcc/testsuite/gnat.dg/bit_packed_array4.ads @@ -0,0 +1,18 @@ +package Bit_Packed_Array4 is + + type Data_Type is array (1 .. 39) of Boolean; + pragma Pack (Data_Type); + for Data_Type'Alignment use 1; + + type Message_Type is record + Valid : Boolean; + Data : Data_Type; + end record; + for Message_Type use record + Valid at 0 range 0 .. 0; + Data at 0 range 1 .. 39; + end record; + + procedure Process (M : Message_Type); + +end Bit_Packed_Array4; diff --git a/gcc/testsuite/gnat.dg/blkextract_from_reg.adb b/gcc/testsuite/gnat.dg/blkextract_from_reg.adb new file mode 100644 index 000000000..204d71964 --- /dev/null +++ b/gcc/testsuite/gnat.dg/blkextract_from_reg.adb @@ -0,0 +1,49 @@ +-- { dg-do run } + +with System, Ada.Unchecked_Conversion; use System; + +procedure BLKextract_From_Reg is + + type Byte is range 0 .. +255; + for Byte'size use 8; + + type RGB is array (1 .. 3) of Byte; + for RGB'Size use 24; + + type RAW_Packet is range 0 .. 2 ** 32 - 1; + for RAW_Packet'Size use 32; + + type Composite_Packet is record + Values : RGB; + Pad : Byte; + end record; + for Composite_Packet use record + Values at 0 range 0 .. 23; + Pad at 3 range 0 .. 7; + end record; + for Composite_Packet'Size use 32; + + function To_Composite_Packet is + new Ada.Unchecked_Conversion (RAW_Packet, Composite_Packet); + + function Blob return RGB is + RAW_Blob : RAW_Packet := 16#01020304#; + begin + return To_Composite_Packet (RAW_Blob).Values; + end; + + Blob_Color : RGB := Blob; + Expected_Color : RGB; +begin + if System.Default_Bit_Order = High_Order_First then + Expected_Color := (1 => 1, 2 => 2, 3 => 3); + else + Expected_Color := (1 => 4, 2 => 3, 3 => 2); + end if; + + for I in Blob_Color'Range loop + if Blob_Color (I) /= Expected_Color (I) then + raise Program_Error; + end if; + end loop; +end; diff --git a/gcc/testsuite/gnat.dg/bltins.adb b/gcc/testsuite/gnat.dg/bltins.adb new file mode 100644 index 000000000..0ceb0b95b --- /dev/null +++ b/gcc/testsuite/gnat.dg/bltins.adb @@ -0,0 +1,12 @@ +-- { dg-do run } + +procedure Bltins is + + function Sqrt (F : Float) return Float; + pragma Import (Intrinsic, Sqrt, "__builtin_sqrtf"); + + F : Float := 4.0; + R : Float; +begin + R := Sqrt (F); +end; diff --git a/gcc/testsuite/gnat.dg/boolean_bitfield.adb b/gcc/testsuite/gnat.dg/boolean_bitfield.adb new file mode 100644 index 000000000..5909f7c4a --- /dev/null +++ b/gcc/testsuite/gnat.dg/boolean_bitfield.adb @@ -0,0 +1,44 @@ +-- { dg-do run } +-- { dg-options "-O" } + +with System; use System; + +procedure Boolean_Bitfield is + + Units_Per_Integer : constant := + (Integer'Size + System.Storage_Unit - 1) / System.Storage_Unit; + + type E_type is (Red, Blue, Green); + + type Parent_Type is record + I : Integer range 0 .. 127 := 127; + C : Character := 'S'; + B : Boolean := False; + E : E_Type := Blue; + end record; + + for Parent_Type use record + C at 0 * Units_Per_Integer range 0 .. Character'Size - 1; + B at 1 * Units_Per_Integer range 0 .. Boolean'Size - 1; + I at 2 * Units_Per_Integer range 0 .. Integer'Size/2 - 1; + E at 3 * Units_Per_Integer range 0 .. Character'Size - 1; + end record; + + type Derived_Type is new Parent_Type; + + for Derived_Type use record + C at 1 * Units_Per_Integer range 1 .. Character'Size + 1; + B at 3 * Units_Per_Integer range 1 .. Boolean'Size + 1; + I at 5 * Units_Per_Integer range 1 .. Integer'Size/2 + 1; + E at 7 * Units_Per_Integer range 1 .. Character'Size + 1; + end record; + + Rec : Derived_Type; + +begin + Rec := (12, 'T', True, Red); + + if (Rec.I /= 12) or (Rec.C /= 'T') or (not Rec.B) or (Rec.E /= Red) then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/boolean_conv.adb b/gcc/testsuite/gnat.dg/boolean_conv.adb new file mode 100644 index 000000000..7a9b4f3e8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/boolean_conv.adb @@ -0,0 +1,34 @@ +-- { dg-do run } + +with System; use System; + +procedure Boolean_Conv is + subtype B1 is Boolean; + subtype B2 is Boolean; + A0, A1, A2 : Address; + + B : aliased B1; + + procedure P2 (X2 : access B2) is + begin + A2 := X2.all'Address; + end P2; + + procedure P1 (X1 : access B1) is + begin + A1 := X1.all'Address; + P2 (B2 (X1.all)'Unrestricted_Access); + end P1; + +begin + A0 := B'Address; + P1 (B'Access); + + if A1 /= A0 then + raise Program_Error; + end if; + + if A2 /= A0 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/boolean_expr1.adb b/gcc/testsuite/gnat.dg/boolean_expr1.adb new file mode 100644 index 000000000..ddfe32bfb --- /dev/null +++ b/gcc/testsuite/gnat.dg/boolean_expr1.adb @@ -0,0 +1,30 @@ +-- PR middle-end/36554 +-- Origin: Laurent Guerby <laurent@guerby.net> + +-- { dg-do compile } +-- { dg-options "-O2" } + +package body Boolean_Expr1 is + + function Long_Float_Is_Valid (X : in Long_Float) return Boolean is + Is_Nan : constant Boolean := X /= X; + Is_P_Inf : constant Boolean := X > Long_Float'Last; + Is_M_Inf : constant Boolean := X < Long_Float'First; + Is_Invalid : constant Boolean := Is_Nan or Is_P_Inf or Is_M_Inf; + begin + return not Is_Invalid; + end Long_Float_Is_Valid; + + function S (V : in Long_Float) return String is + begin + if not Long_Float_Is_Valid (V) then + return "INVALID"; + else + return "OK"; + end if; + exception + when others => + return "ERROR"; + end S; + +end Boolean_Expr1; diff --git a/gcc/testsuite/gnat.dg/boolean_expr1.ads b/gcc/testsuite/gnat.dg/boolean_expr1.ads new file mode 100644 index 000000000..526551135 --- /dev/null +++ b/gcc/testsuite/gnat.dg/boolean_expr1.ads @@ -0,0 +1,5 @@ +package Boolean_Expr1 is + + function S (V : in Long_Float) return String; + +end Boolean_Expr1; diff --git a/gcc/testsuite/gnat.dg/boolean_expr2.adb b/gcc/testsuite/gnat.dg/boolean_expr2.adb new file mode 100644 index 000000000..8bdcb84e9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/boolean_expr2.adb @@ -0,0 +1,18 @@ +-- { dg-do run } + +procedure Boolean_Expr2 is + + function Ident_Bool (B : Boolean) return Boolean is + begin + return B; + end; + +begin + if Boolean'Succ (Ident_Bool(False)) /= True then + raise Program_Error; + end if; + + if Boolean'Pred (Ident_Bool(True)) /= False then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/boolean_subtype.adb b/gcc/testsuite/gnat.dg/boolean_subtype.adb new file mode 100644 index 000000000..3976d7992 --- /dev/null +++ b/gcc/testsuite/gnat.dg/boolean_subtype.adb @@ -0,0 +1,42 @@ +-- { dg-do compile } +-- { dg-options "-O2" } + +procedure boolean_subtype is + + subtype Component_T is Boolean; + + function Condition return Boolean is + begin + return True; + end; + + V : Integer := 0; + + function Component_Value return Integer is + begin + V := V + 1; + return V; + end; + + Most_Significant : Component_T := False; + Least_Significant : Component_T := True; + +begin + + if Condition then + Most_Significant := True; + end if; + + if Condition then + Least_Significant := Component_T'Val (Component_Value); + end if; + + if Least_Significant < Most_Significant then + Least_Significant := Most_Significant; + end if; + + if Least_Significant /= True then + raise Program_Error; + end if; + +end; diff --git a/gcc/testsuite/gnat.dg/bug_elaboration_code.adb b/gcc/testsuite/gnat.dg/bug_elaboration_code.adb new file mode 100644 index 000000000..0aa7abe80 --- /dev/null +++ b/gcc/testsuite/gnat.dg/bug_elaboration_code.adb @@ -0,0 +1,12 @@ +package body Bug_Elaboration_Code is + + procedure Increment_I is + begin + I := I + 1; + end Increment_I; + +begin + I := 5; + Increment_I; + J := I; +end Bug_Elaboration_Code; diff --git a/gcc/testsuite/gnat.dg/bug_elaboration_code.ads b/gcc/testsuite/gnat.dg/bug_elaboration_code.ads new file mode 100644 index 000000000..7354dcb24 --- /dev/null +++ b/gcc/testsuite/gnat.dg/bug_elaboration_code.ads @@ -0,0 +1,8 @@ +package Bug_Elaboration_Code is + + pragma Elaborate_Body; + + I : Integer; + J : Integer; + +end Bug_Elaboration_Code; diff --git a/gcc/testsuite/gnat.dg/c_words.adb b/gcc/testsuite/gnat.dg/c_words.adb new file mode 100644 index 000000000..dff871640 --- /dev/null +++ b/gcc/testsuite/gnat.dg/c_words.adb @@ -0,0 +1,14 @@ +-- { dg-do compile } + +package body C_Words is + + function New_Word (Str : String) return Word is + begin + return (Str'Length, Str); + end New_Word; + + function New_Word (Str : String) return C_Word is + begin + return (Str'Length, Str); + end New_Word; +end C_Words; diff --git a/gcc/testsuite/gnat.dg/c_words.ads b/gcc/testsuite/gnat.dg/c_words.ads new file mode 100644 index 000000000..b87a19bb1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/c_words.ads @@ -0,0 +1,16 @@ +package C_Words is + type Comparable is limited interface; + + type Word (<>) is tagged private; + function New_Word (Str : String) return Word; + + type C_Word (<>) is new Word and Comparable with private; + function New_Word (Str : String) return C_Word; + +private + type Word (Length : Natural) is tagged record + Str : String (1 .. Length) := (others => ' '); + end record; + + type C_Word is new Word and Comparable with null record; +end C_Words; diff --git a/gcc/testsuite/gnat.dg/capture_value.adb b/gcc/testsuite/gnat.dg/capture_value.adb new file mode 100644 index 000000000..10272a49a --- /dev/null +++ b/gcc/testsuite/gnat.dg/capture_value.adb @@ -0,0 +1,16 @@ +-- { dg-do run } + +procedure capture_value is + x : integer := 0; +begin + declare + z : integer renames x; + begin + z := 3; + x := 5; + z := z + 1; + if z /= 6 then + raise Program_Error; + end if; + end; +end; diff --git a/gcc/testsuite/gnat.dg/case_null.adb b/gcc/testsuite/gnat.dg/case_null.adb new file mode 100644 index 000000000..eba89dc5f --- /dev/null +++ b/gcc/testsuite/gnat.dg/case_null.adb @@ -0,0 +1,16 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +package body Case_Null is + procedure P1 (X : T) is + begin + case X is + when S1 => + null; + when e => + null; + when others => + null; + end case; + end P1; +end Case_Null; diff --git a/gcc/testsuite/gnat.dg/case_null.ads b/gcc/testsuite/gnat.dg/case_null.ads new file mode 100644 index 000000000..0e47d4200 --- /dev/null +++ b/gcc/testsuite/gnat.dg/case_null.ads @@ -0,0 +1,11 @@ +package Case_Null is + type T is (a, b, c, d, e); + + subtype S is T range b .. d; + + subtype S1 is S range a .. d; + -- Low bound out of range of base subtype. + + procedure P1 (X : T); + +end Case_Null; diff --git a/gcc/testsuite/gnat.dg/case_optimization1.adb b/gcc/testsuite/gnat.dg/case_optimization1.adb new file mode 100644 index 000000000..3273b16fe --- /dev/null +++ b/gcc/testsuite/gnat.dg/case_optimization1.adb @@ -0,0 +1,21 @@ +-- { dg-do compile } +-- { dg-options "-O2" } + +package body Case_Optimization1 is + + function F (Op_Kind : Internal_Operator_Symbol_Kinds) return Integer is + begin + case Op_Kind is + when A_Not_Operator => return 3; + when An_Exponentiate_Operator => return 2; + when others => return 1; + end case; + end; + + function Len (E : Element) return Integer is + Op_Kind : Internal_Element_Kinds := Int_Kind (E); + begin + return F (Int_Kind (E)); + end; + +end Case_Optimization1; diff --git a/gcc/testsuite/gnat.dg/case_optimization1.ads b/gcc/testsuite/gnat.dg/case_optimization1.ads new file mode 100644 index 000000000..737c9b70a --- /dev/null +++ b/gcc/testsuite/gnat.dg/case_optimization1.ads @@ -0,0 +1,7 @@ +with Case_Optimization_Pkg1; use Case_Optimization_Pkg1; + +package Case_Optimization1 is + + function Len (E : Element) return Integer; + +end Case_Optimization1; diff --git a/gcc/testsuite/gnat.dg/case_optimization2.adb b/gcc/testsuite/gnat.dg/case_optimization2.adb new file mode 100644 index 000000000..f548a8488 --- /dev/null +++ b/gcc/testsuite/gnat.dg/case_optimization2.adb @@ -0,0 +1,14 @@ +-- PR ada/43106 +-- Testcase by Bill Neven <neven@hitt.nl> + +-- { dg-do run } +-- { dg-options "-O" } + +with Case_Optimization_Pkg2; use Case_Optimization_Pkg2; + +procedure Case_Optimization2 is + Radar : Radar_T; +begin + Radar.Sensor_Type := radcmb; + Initialize (Radar); +end; diff --git a/gcc/testsuite/gnat.dg/case_optimization_pkg1.ads b/gcc/testsuite/gnat.dg/case_optimization_pkg1.ads new file mode 100644 index 000000000..da458645e --- /dev/null +++ b/gcc/testsuite/gnat.dg/case_optimization_pkg1.ads @@ -0,0 +1,432 @@ +package Case_Optimization_Pkg1 is + + type Element is null record; + + type Internal_Element_Kinds is + (Not_An_Element, + An_All_Calls_Remote_Pragma, + An_Asynchronous_Pragma, + An_Atomic_Pragma, + An_Atomic_Components_Pragma, + An_Attach_Handler_Pragma, + A_Controlled_Pragma, + A_Convention_Pragma, + A_Discard_Names_Pragma, + An_Elaborate_Pragma, + An_Elaborate_All_Pragma, + An_Elaborate_Body_Pragma, + An_Export_Pragma, + An_Import_Pragma, + An_Inline_Pragma, + An_Inspection_Point_Pragma, + An_Interrupt_Handler_Pragma, + An_Interrupt_Priority_Pragma, + A_Linker_Options_Pragma, + A_List_Pragma, + A_Locking_Policy_Pragma, + A_Normalize_Scalars_Pragma, + An_Optimize_Pragma, + A_Pack_Pragma, + A_Page_Pragma, + A_Preelaborate_Pragma, + A_Priority_Pragma, + A_Pure_Pragma, + A_Queuing_Policy_Pragma, + A_Remote_Call_Interface_Pragma, + A_Remote_Types_Pragma, + A_Restrictions_Pragma, + A_Reviewable_Pragma, + A_Shared_Passive_Pragma, + A_Storage_Size_Pragma, + A_Suppress_Pragma, + A_Task_Dispatching_Policy_Pragma, + A_Volatile_Pragma, + A_Volatile_Components_Pragma, + An_Assert_Pragma, + An_Assertion_Policy_Pragma, + A_Detect_Blocking_Pragma, + A_No_Return_Pragma, + A_Partition_Elaboration_Policy_Pragma, + A_Preelaborable_Initialization_Pragma, + A_Priority_Specific_Dispatching_Pragma, + A_Profile_Pragma, + A_Relative_Deadline_Pragma, + An_Unchecked_Union_Pragma, + An_Unsuppress_Pragma, + An_Implementation_Defined_Pragma, + An_Unknown_Pragma, + A_Defining_Identifier, + A_Defining_Character_Literal, + A_Defining_Enumeration_Literal, + A_Defining_And_Operator, + A_Defining_Or_Operator, + A_Defining_Xor_Operator, + A_Defining_Equal_Operator, + A_Defining_Not_Equal_Operator, + A_Defining_Less_Than_Operator, + A_Defining_Less_Than_Or_Equal_Operator, + A_Defining_Greater_Than_Operator, + A_Defining_Greater_Than_Or_Equal_Operator, + A_Defining_Plus_Operator, + A_Defining_Minus_Operator, + A_Defining_Concatenate_Operator, + A_Defining_Unary_Plus_Operator, + A_Defining_Unary_Minus_Operator, + A_Defining_Multiply_Operator, + A_Defining_Divide_Operator, + A_Defining_Mod_Operator, + A_Defining_Rem_Operator, + A_Defining_Exponentiate_Operator, + A_Defining_Abs_Operator, + A_Defining_Not_Operator, + A_Defining_Expanded_Name, + An_Ordinary_Type_Declaration, + A_Task_Type_Declaration, + A_Protected_Type_Declaration, + An_Incomplete_Type_Declaration, + A_Tagged_Incomplete_Type_Declaration, + A_Private_Type_Declaration, + A_Private_Extension_Declaration, + A_Subtype_Declaration, + A_Variable_Declaration, + A_Constant_Declaration, + A_Deferred_Constant_Declaration, + A_Single_Task_Declaration, + A_Single_Protected_Declaration, + An_Integer_Number_Declaration, + A_Real_Number_Declaration, + An_Enumeration_Literal_Specification, + A_Discriminant_Specification, + A_Component_Declaration, + A_Loop_Parameter_Specification, + A_Procedure_Declaration, + A_Function_Declaration, + A_Parameter_Specification, + A_Procedure_Body_Declaration, + A_Function_Body_Declaration, + A_Return_Object_Declaration, + A_Null_Procedure_Declaration, + A_Package_Declaration, + A_Package_Body_Declaration, + An_Object_Renaming_Declaration, + An_Exception_Renaming_Declaration, + A_Package_Renaming_Declaration, + A_Procedure_Renaming_Declaration, + A_Function_Renaming_Declaration, + A_Generic_Package_Renaming_Declaration, + A_Generic_Procedure_Renaming_Declaration, + A_Generic_Function_Renaming_Declaration, + A_Task_Body_Declaration, + A_Protected_Body_Declaration, + An_Entry_Declaration, + An_Entry_Body_Declaration, + An_Entry_Index_Specification, + A_Procedure_Body_Stub, + A_Function_Body_Stub, + A_Package_Body_Stub, + A_Task_Body_Stub, + A_Protected_Body_Stub, + An_Exception_Declaration, + A_Choice_Parameter_Specification, + A_Generic_Procedure_Declaration, + A_Generic_Function_Declaration, + A_Generic_Package_Declaration, + A_Package_Instantiation, + A_Procedure_Instantiation, + A_Function_Instantiation, + A_Formal_Object_Declaration, + A_Formal_Type_Declaration, + A_Formal_Procedure_Declaration, + A_Formal_Function_Declaration, + A_Formal_Package_Declaration, + A_Formal_Package_Declaration_With_Box, + A_Derived_Type_Definition, + A_Derived_Record_Extension_Definition, + An_Enumeration_Type_Definition, + A_Signed_Integer_Type_Definition, + A_Modular_Type_Definition, + A_Root_Integer_Definition, + A_Root_Real_Definition, + A_Universal_Integer_Definition, + A_Universal_Real_Definition, + A_Universal_Fixed_Definition, + A_Floating_Point_Definition, + An_Ordinary_Fixed_Point_Definition, + A_Decimal_Fixed_Point_Definition, + An_Unconstrained_Array_Definition, + A_Constrained_Array_Definition, + A_Record_Type_Definition, + A_Tagged_Record_Type_Definition, + An_Ordinary_Interface, + A_Limited_Interface, + A_Task_Interface, + A_Protected_Interface, + A_Synchronized_Interface, + A_Pool_Specific_Access_To_Variable, + An_Access_To_Variable, + An_Access_To_Constant, + An_Access_To_Procedure, + An_Access_To_Protected_Procedure, + An_Access_To_Function, + An_Access_To_Protected_Function, + A_Subtype_Indication, + A_Range_Attribute_Reference, + A_Simple_Expression_Range, + A_Digits_Constraint, + A_Delta_Constraint, + An_Index_Constraint, + A_Discriminant_Constraint, + A_Component_Definition, + A_Discrete_Subtype_Indication_As_Subtype_Definition, + A_Discrete_Range_Attribute_Reference_As_Subtype_Definition, + A_Discrete_Simple_Expression_Range_As_Subtype_Definition, + A_Discrete_Subtype_Indication, + A_Discrete_Range_Attribute_Reference, + A_Discrete_Simple_Expression_Range, + An_Unknown_Discriminant_Part, + A_Known_Discriminant_Part, + A_Record_Definition, + A_Null_Record_Definition, + A_Null_Component, + A_Variant_Part, + A_Variant, + An_Others_Choice, + An_Anonymous_Access_To_Variable, + An_Anonymous_Access_To_Constant, + An_Anonymous_Access_To_Procedure, + An_Anonymous_Access_To_Protected_Procedure, + An_Anonymous_Access_To_Function, + An_Anonymous_Access_To_Protected_Function, + A_Private_Type_Definition, + A_Tagged_Private_Type_Definition, + A_Private_Extension_Definition, + A_Task_Definition, + A_Protected_Definition, + A_Formal_Private_Type_Definition, + A_Formal_Tagged_Private_Type_Definition, + A_Formal_Derived_Type_Definition, + A_Formal_Discrete_Type_Definition, + A_Formal_Signed_Integer_Type_Definition, + A_Formal_Modular_Type_Definition, + A_Formal_Floating_Point_Definition, + A_Formal_Ordinary_Fixed_Point_Definition, + A_Formal_Decimal_Fixed_Point_Definition, + A_Formal_Ordinary_Interface, + A_Formal_Limited_Interface, + A_Formal_Task_Interface, + A_Formal_Protected_Interface, + A_Formal_Synchronized_Interface, + A_Formal_Unconstrained_Array_Definition, + A_Formal_Constrained_Array_Definition, + A_Formal_Pool_Specific_Access_To_Variable, + A_Formal_Access_To_Variable, + A_Formal_Access_To_Constant, + A_Formal_Access_To_Procedure, + A_Formal_Access_To_Protected_Procedure, + A_Formal_Access_To_Function, + A_Formal_Access_To_Protected_Function, + An_Integer_Literal, + A_Real_Literal, + A_String_Literal, + An_Identifier, + An_And_Operator, + An_Or_Operator, + An_Xor_Operator, + An_Equal_Operator, + A_Not_Equal_Operator, + A_Less_Than_Operator, + A_Less_Than_Or_Equal_Operator, + A_Greater_Than_Operator, + A_Greater_Than_Or_Equal_Operator, + A_Plus_Operator, + A_Minus_Operator, + A_Concatenate_Operator, + A_Unary_Plus_Operator, + A_Unary_Minus_Operator, + A_Multiply_Operator, + A_Divide_Operator, + A_Mod_Operator, + A_Rem_Operator, + An_Exponentiate_Operator, + An_Abs_Operator, + A_Not_Operator, + A_Character_Literal, + An_Enumeration_Literal, + An_Explicit_Dereference, + A_Function_Call, + An_Indexed_Component, + A_Slice, + A_Selected_Component, + An_Access_Attribute, + An_Address_Attribute, + An_Adjacent_Attribute, + An_Aft_Attribute, + An_Alignment_Attribute, + A_Base_Attribute, + A_Bit_Order_Attribute, + A_Body_Version_Attribute, + A_Callable_Attribute, + A_Caller_Attribute, + A_Ceiling_Attribute, + A_Class_Attribute, + A_Component_Size_Attribute, + A_Compose_Attribute, + A_Constrained_Attribute, + A_Copy_Sign_Attribute, + A_Count_Attribute, + A_Definite_Attribute, + A_Delta_Attribute, + A_Denorm_Attribute, + A_Digits_Attribute, + An_Exponent_Attribute, + An_External_Tag_Attribute, + A_First_Attribute, + A_First_Bit_Attribute, + A_Floor_Attribute, + A_Fore_Attribute, + A_Fraction_Attribute, + An_Identity_Attribute, + An_Image_Attribute, + An_Input_Attribute, + A_Last_Attribute, + A_Last_Bit_Attribute, + A_Leading_Part_Attribute, + A_Length_Attribute, + A_Machine_Attribute, + A_Machine_Emax_Attribute, + A_Machine_Emin_Attribute, + A_Machine_Mantissa_Attribute, + A_Machine_Overflows_Attribute, + A_Machine_Radix_Attribute, + A_Machine_Rounds_Attribute, + A_Max_Attribute, + A_Max_Size_In_Storage_Elements_Attribute, + A_Min_Attribute, + A_Model_Attribute, + A_Model_Emin_Attribute, + A_Model_Epsilon_Attribute, + A_Model_Mantissa_Attribute, + A_Model_Small_Attribute, + A_Modulus_Attribute, + An_Output_Attribute, + A_Partition_ID_Attribute, + A_Pos_Attribute, + A_Position_Attribute, + A_Pred_Attribute, + A_Range_Attribute, + A_Read_Attribute, + A_Remainder_Attribute, + A_Round_Attribute, + A_Rounding_Attribute, + A_Safe_First_Attribute, + A_Safe_Last_Attribute, + A_Scale_Attribute, + A_Scaling_Attribute, + A_Signed_Zeros_Attribute, + A_Size_Attribute, + A_Small_Attribute, + A_Storage_Pool_Attribute, + A_Storage_Size_Attribute, + A_Succ_Attribute, + A_Tag_Attribute, + A_Terminated_Attribute, + A_Truncation_Attribute, + An_Unbiased_Rounding_Attribute, + An_Unchecked_Access_Attribute, + A_Val_Attribute, + A_Valid_Attribute, + A_Value_Attribute, + A_Version_Attribute, + A_Wide_Image_Attribute, + A_Wide_Value_Attribute, + A_Wide_Width_Attribute, + A_Width_Attribute, + A_Write_Attribute, + A_Machine_Rounding_Attribute, + A_Mod_Attribute, + A_Priority_Attribute, + A_Stream_Size_Attribute, + A_Wide_Wide_Image_Attribute, + A_Wide_Wide_Value_Attribute, + A_Wide_Wide_Width_Attribute, + An_Implementation_Defined_Attribute, + An_Unknown_Attribute, + A_Record_Aggregate, + An_Extension_Aggregate, + A_Positional_Array_Aggregate, + A_Named_Array_Aggregate, + An_And_Then_Short_Circuit, + An_Or_Else_Short_Circuit, + An_In_Range_Membership_Test, + A_Not_In_Range_Membership_Test, + An_In_Type_Membership_Test, + A_Not_In_Type_Membership_Test, + A_Null_Literal, + A_Parenthesized_Expression, + A_Type_Conversion, + A_Qualified_Expression, + An_Allocation_From_Subtype, + An_Allocation_From_Qualified_Expression, + A_Pragma_Argument_Association, + A_Discriminant_Association, + A_Record_Component_Association, + An_Array_Component_Association, + A_Parameter_Association, + A_Generic_Association, + A_Null_Statement, + An_Assignment_Statement, + An_If_Statement, + A_Case_Statement, + A_Loop_Statement, + A_While_Loop_Statement, + A_For_Loop_Statement, + A_Block_Statement, + An_Exit_Statement, + A_Goto_Statement, + A_Procedure_Call_Statement, + A_Return_Statement, + An_Extended_Return_Statement, + An_Accept_Statement, + An_Entry_Call_Statement, + A_Requeue_Statement, + A_Requeue_Statement_With_Abort, + A_Delay_Until_Statement, + A_Delay_Relative_Statement, + A_Terminate_Alternative_Statement, + A_Selective_Accept_Statement, + A_Timed_Entry_Call_Statement, + A_Conditional_Entry_Call_Statement, + An_Asynchronous_Select_Statement, + An_Abort_Statement, + A_Raise_Statement, + A_Code_Statement, + An_If_Path, + An_Elsif_Path, + An_Else_Path, + A_Case_Path, + A_Select_Path, + An_Or_Path, + A_Then_Abort_Path, + A_Use_Package_Clause, + A_Use_Type_Clause, + A_With_Clause, + An_Attribute_Definition_Clause, + An_Enumeration_Representation_Clause, + A_Record_Representation_Clause, + An_At_Clause, + A_Component_Clause, + An_Exception_Handler, + Non_Trivial_Mapping, + Not_Implemented_Mapping, + Trivial_Mapping, + No_Mapping); + + subtype Internal_Expression_Kinds is Internal_Element_Kinds + range An_Integer_Literal .. An_Allocation_From_Qualified_Expression; + + subtype Internal_Operator_Symbol_Kinds is Internal_Expression_Kinds + range An_And_Operator .. A_Not_Operator; + + function Int_Kind (E : Element) return Internal_Element_Kinds; + +end Case_Optimization_Pkg1; diff --git a/gcc/testsuite/gnat.dg/case_optimization_pkg2.adb b/gcc/testsuite/gnat.dg/case_optimization_pkg2.adb new file mode 100644 index 000000000..57f9224e5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/case_optimization_pkg2.adb @@ -0,0 +1,23 @@ +package body Case_Optimization_Pkg2 is + + procedure Initialize (Radar : in Radar_T) is + Antenna1 : Antenna_Type_T; + Antenna2 : Antenna_Type_T; + begin + case Radar.Sensor_Type is + when radpr | radssr => + Antenna1 := Radar.Sensor_Type; + Antenna2 := Radar.Sensor_Type; + when radcmb => + Antenna1 := radpr; + Antenna2 := radssr; + when others => + Antenna1 := radpr; + Antenna2 := radssr; + end case; + if Antenna1 /= radpr or Antenna2 /= radssr then + raise Program_Error; + end if; + end Initialize; + +end Case_Optimization_Pkg2; diff --git a/gcc/testsuite/gnat.dg/case_optimization_pkg2.ads b/gcc/testsuite/gnat.dg/case_optimization_pkg2.ads new file mode 100644 index 000000000..c41a05c26 --- /dev/null +++ b/gcc/testsuite/gnat.dg/case_optimization_pkg2.ads @@ -0,0 +1,23 @@ +package Case_Optimization_Pkg2 is + + type Unsigned_64 is mod 2 ** 64; + + type Associated_Report_T is (miss, radpr, radssr, radcmb); + + -- sensor type : primary, secondary, co-rotating (combined) + subtype Sensor_Type_T is Associated_Report_T; -- range radpr .. radcmb; + subtype Antenna_Type_T is Sensor_Type_T range radpr .. radssr; + + type Filtering_Level_T is (none, pr_in_clutter, ssr_plots, pr_plots); + type Filtering_Levels_T is array (Filtering_Level_T) of boolean; + + type Radar_T is record + External_Sensor_ID : Unsigned_64; + Dual_Radar_Index : Integer; + Compatible_Filtering_Levels : Filtering_Levels_T; + Sensor_Type : Sensor_Type_T; + end record; + + procedure Initialize (Radar : in Radar_T); + +end Case_Optimization_Pkg2; diff --git a/gcc/testsuite/gnat.dg/check1.adb b/gcc/testsuite/gnat.dg/check1.adb new file mode 100644 index 000000000..f3d32333c --- /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 000000000..baeeda007 --- /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/check_displace_generation.adb b/gcc/testsuite/gnat.dg/check_displace_generation.adb new file mode 100644 index 000000000..2ae2ed0be --- /dev/null +++ b/gcc/testsuite/gnat.dg/check_displace_generation.adb @@ -0,0 +1,50 @@ +-- { dg-do run } +procedure Check_Displace_Generation is + + package Stuff is + + type Base_1 is interface; + function F_1 (X : Base_1) return Integer is abstract; + + type Base_2 is interface; + function F_2 (X : Base_2) return Integer is abstract; + + type Concrete is new Base_1 and Base_2 with null record; + function F_1 (X : Concrete) return Integer; + function F_2 (X : Concrete) return Integer; + + end Stuff; + + package body Stuff is + + function F_1 (X : Concrete) return Integer is + begin + return 1; + end F_1; + + function F_2 (X : Concrete) return Integer is + begin + return 2; + end F_2; + + end Stuff; + + use Stuff; + + function Make_Concrete return Concrete is + C : Concrete; + begin + return C; + end Make_Concrete; + + B_1 : Base_1'Class := Make_Concrete; + B_2 : Base_2'Class := Make_Concrete; + +begin + if B_1.F_1 /= 1 then + raise Program_Error with "bad B_1.F_1 call"; + end if; + if B_2.F_2 /= 2 then + raise Program_Error with "bad B_2.F_2 call"; + end if; +end Check_Displace_Generation; diff --git a/gcc/testsuite/gnat.dg/check_elaboration_code.adb b/gcc/testsuite/gnat.dg/check_elaboration_code.adb new file mode 100644 index 000000000..63dde56f2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/check_elaboration_code.adb @@ -0,0 +1,9 @@ +-- { dg-do run } +with Bug_Elaboration_Code; use Bug_Elaboration_Code; + +procedure Check_Elaboration_Code is +begin + if I /= J then + raise Program_Error; + end if; +end Check_Elaboration_Code; diff --git a/gcc/testsuite/gnat.dg/class_wide1.adb b/gcc/testsuite/gnat.dg/class_wide1.adb new file mode 100644 index 000000000..ba6fea032 --- /dev/null +++ b/gcc/testsuite/gnat.dg/class_wide1.adb @@ -0,0 +1,26 @@ +-- { dg-do compile } + +procedure Class_Wide1 is + package P is + type T is tagged null record; + procedure P1 (x : T'Class); + procedure P2 (x : access T'Class); + end P; + package body P is + procedure P1 (x : T'Class) is + begin + null; + end; + procedure P2 (x : access T'Class) is + begin + null; + end; + end P; + use P; + a : T; + type Ptr is access T; + b : Ptr := new T; +begin + A.P1; + B.P2; +end; diff --git a/gcc/testsuite/gnat.dg/class_wide2.adb b/gcc/testsuite/gnat.dg/class_wide2.adb new file mode 100644 index 000000000..9df54bf90 --- /dev/null +++ b/gcc/testsuite/gnat.dg/class_wide2.adb @@ -0,0 +1,13 @@ +-- { dg-do compile } + +package body Class_Wide2 is + + procedure Initialize is + Var_Acc : Class_Acc := new Grand_Child; + Var : Grand_Child'Class := Grand_Child'Class (Var_Acc.all); + + begin + Var := Grand_Child'Class (Var_Acc.all); + end Initialize; + +end Class_Wide2; diff --git a/gcc/testsuite/gnat.dg/class_wide2.ads b/gcc/testsuite/gnat.dg/class_wide2.ads new file mode 100644 index 000000000..a1acc223e --- /dev/null +++ b/gcc/testsuite/gnat.dg/class_wide2.ads @@ -0,0 +1,17 @@ +package Class_Wide2 is + + type Root_1 (V : Integer) is tagged record + null; + end record; + + type Child is new Root_1 (1) with null record; + + type Class_Acc is access all Child'Class; + + type Grand_Child is new Child with record + null; + end record; + + procedure Initialize; + +end Class_Wide2; diff --git a/gcc/testsuite/gnat.dg/compose.adb b/gcc/testsuite/gnat.dg/compose.adb new file mode 100644 index 000000000..4ee3c57f6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/compose.adb @@ -0,0 +1,11 @@ +-- { dg-do run } +with Ada.Directories; +with Ada.Text_IO; + +procedure Compose is + Result : constant String := Ada.Directories.Compose (Name => "foo", + Extension => "txt"); + pragma Unreferenced (Result); +begin + null; +end Compose; diff --git a/gcc/testsuite/gnat.dg/concat1.adb b/gcc/testsuite/gnat.dg/concat1.adb new file mode 100644 index 000000000..16b85433e --- /dev/null +++ b/gcc/testsuite/gnat.dg/concat1.adb @@ -0,0 +1,21 @@ +-- { dg-do run } +-- { dg-options "-O2" } + +with Concat1_Pkg; use Concat1_Pkg; + +procedure Concat1 is + + Ident_1 : Integer := Ident (1); + Ident_2 : Integer := Ident (2); + Ident_5 : Integer := Ident (5); + + type Arr is array (Integer range <>) of Integer; + A : Arr (1..10); + +begin + A := (1, 2, 3, 4, 5, 6, 7, 8, 9, 10); + A := 0 & A(Ident_1..Ident_2) & A(Ident_1..Ident_2) & A(Ident_1..Ident_5); + if A /= (0, 1, 2, 1, 2, 1, 2, 3, 4, 5) then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/concat1_pkg.adb b/gcc/testsuite/gnat.dg/concat1_pkg.adb new file mode 100644 index 000000000..4e50e6119 --- /dev/null +++ b/gcc/testsuite/gnat.dg/concat1_pkg.adb @@ -0,0 +1,5 @@ +package body Concat1_Pkg is + + function Ident (I : Integer) return Integer is begin return I; end; + +end Concat1_Pkg; diff --git a/gcc/testsuite/gnat.dg/concat1_pkg.ads b/gcc/testsuite/gnat.dg/concat1_pkg.ads new file mode 100644 index 000000000..8690ba22f --- /dev/null +++ b/gcc/testsuite/gnat.dg/concat1_pkg.ads @@ -0,0 +1,5 @@ +package Concat1_Pkg is + + function Ident (I : Integer) return Integer; + +end Concat1_Pkg; diff --git a/gcc/testsuite/gnat.dg/concat_length.adb b/gcc/testsuite/gnat.dg/concat_length.adb new file mode 100644 index 000000000..fe482d98d --- /dev/null +++ b/gcc/testsuite/gnat.dg/concat_length.adb @@ -0,0 +1,15 @@ +-- { dg-do run } + +procedure Concat_Length is + type Byte is mod 256; + for Byte'Size use 8; + type Block is array(Byte range <>) of Integer; + + C0: Block(1..7) := (others => 0); + C1: Block(8..255) := (others => 0); + C2: Block := C0 & C1; +begin + if C2'Length /= 255 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/cond_expr1.adb b/gcc/testsuite/gnat.dg/cond_expr1.adb new file mode 100644 index 000000000..e1a87a36a --- /dev/null +++ b/gcc/testsuite/gnat.dg/cond_expr1.adb @@ -0,0 +1,7 @@ +-- { dg-do compile } +-- { dg-options "-gnat12" } + +function Cond_Expr1 (Dir : in String) return String is +begin + return (if Dir (Dir'Last) = '\' then Dir else Dir & '\'); +end; diff --git a/gcc/testsuite/gnat.dg/constant1.adb b/gcc/testsuite/gnat.dg/constant1.adb new file mode 100644 index 000000000..6cd1bcfd2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/constant1.adb @@ -0,0 +1,8 @@ +-- { dg-do compile } + +procedure Constant1 is + Def_Const : constant Integer; + pragma Import (Ada, Def_Const); +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/constant2.adb b/gcc/testsuite/gnat.dg/constant2.adb new file mode 100644 index 000000000..41c7e9140 --- /dev/null +++ b/gcc/testsuite/gnat.dg/constant2.adb @@ -0,0 +1,11 @@ +-- { dg-do run } +-- { dg-options "-gnatVa" } + +with Constant2_Pkg1; use Constant2_Pkg1; + +procedure Constant2 is +begin + if Val then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/constant2_pkg1.ads b/gcc/testsuite/gnat.dg/constant2_pkg1.ads new file mode 100644 index 000000000..8905d3064 --- /dev/null +++ b/gcc/testsuite/gnat.dg/constant2_pkg1.ads @@ -0,0 +1,7 @@ +with Constant2_Pkg2; use Constant2_Pkg2; + +package Constant2_Pkg1 is + + Val : constant Boolean := F1 and then F2; + +end Constant2_Pkg1; diff --git a/gcc/testsuite/gnat.dg/constant2_pkg2.adb b/gcc/testsuite/gnat.dg/constant2_pkg2.adb new file mode 100644 index 000000000..e9ccadea2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/constant2_pkg2.adb @@ -0,0 +1,13 @@ +package body Constant2_Pkg2 is + + function F1 return Boolean is + begin + return False; + end; + + function F2 return Boolean is + begin + return False; + end; + +end Constant2_Pkg2; diff --git a/gcc/testsuite/gnat.dg/constant2_pkg2.ads b/gcc/testsuite/gnat.dg/constant2_pkg2.ads new file mode 100644 index 000000000..60b283c87 --- /dev/null +++ b/gcc/testsuite/gnat.dg/constant2_pkg2.ads @@ -0,0 +1,6 @@ +package Constant2_Pkg2 is + + function F1 return Boolean; + function F2 return Boolean; + +end Constant2_Pkg2; diff --git a/gcc/testsuite/gnat.dg/controlled1.ads b/gcc/testsuite/gnat.dg/controlled1.ads new file mode 100644 index 000000000..cca8aa76e --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled1.ads @@ -0,0 +1,13 @@ + +with Ada.Finalization; use Ada.Finalization; +package controlled1 is + type Test is new Controlled with null record; + procedure Add_Test (T : access Test'Class); + + type Test_Case1 is new Test with null record; + type Test_Suite is new Test with null record; + + type Test_Case is new Test_Case1 with record + Link_Under_Test : Natural; + end record; +end; diff --git a/gcc/testsuite/gnat.dg/controlled2.adb b/gcc/testsuite/gnat.dg/controlled2.adb new file mode 100644 index 000000000..4fa61aff8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled2.adb @@ -0,0 +1,10 @@ +-- { dg-do compile } + +with controlled1; use controlled1; +package body controlled2 is + procedure Test_Suite is + begin + Add_Test + (new Test_Case'(Test_Case1 with Link_Under_Test => 300)); + end Test_Suite; +end controlled2; diff --git a/gcc/testsuite/gnat.dg/controlled2.ads b/gcc/testsuite/gnat.dg/controlled2.ads new file mode 100644 index 000000000..a9736235f --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled2.ads @@ -0,0 +1,5 @@ + +with controlled1; use controlled1; +package controlled2 is + procedure Test_Suite; +end controlled2; diff --git a/gcc/testsuite/gnat.dg/controlled3.ads b/gcc/testsuite/gnat.dg/controlled3.ads new file mode 100644 index 000000000..4dee28a3c --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled3.ads @@ -0,0 +1,12 @@ +with Ada.Finalization; use Ada.Finalization; +package controlled3 is + type Test is new Controlled with null record; + procedure Add_Test (T : access Test'Class); + + type Test_Case1 is new Test with null record; + type Test_Suite is new Test with null record; + + type Test_Case is new Test_Case1 with record + Link_Under_Test : Natural; + end record; +end; diff --git a/gcc/testsuite/gnat.dg/controlled4.adb b/gcc/testsuite/gnat.dg/controlled4.adb new file mode 100644 index 000000000..b823cc9f4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled4.adb @@ -0,0 +1,9 @@ +-- { dg-do compile } + +package body controlled4 is + procedure Test_Suite is + begin + Add_Test + (new Test_Case'(Test_Case1 with Link_Under_Test => 300)); + end Test_Suite; +end; diff --git a/gcc/testsuite/gnat.dg/controlled4.ads b/gcc/testsuite/gnat.dg/controlled4.ads new file mode 100644 index 000000000..5ea458a5d --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled4.ads @@ -0,0 +1,5 @@ + +with controlled3; use controlled3; +package controlled4 is + procedure Test_Suite; +end; diff --git a/gcc/testsuite/gnat.dg/controlled5.adb b/gcc/testsuite/gnat.dg/controlled5.adb new file mode 100644 index 000000000..4c54249d4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled5.adb @@ -0,0 +1,9 @@ +-- { dg-do run } + +with Controlled5_Pkg; use Controlled5_Pkg; + +procedure Controlled5 is + V : Root'Class := Dummy (300); +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/controlled5_pkg.adb b/gcc/testsuite/gnat.dg/controlled5_pkg.adb new file mode 100644 index 000000000..828f9efec --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled5_pkg.adb @@ -0,0 +1,18 @@ +with Ada.Tags; + +package body Controlled5_Pkg is + + type Child is new Root with null record; + + function Dummy (I : Integer) return Root'Class is + A1 : T_Root_Class := new Child; + My_Var : Root'Class := A1.all; + begin + if I = 0 then + return My_Var; + else + return Dummy (I - 1); + end if; + end Dummy; + +end Controlled5_Pkg; diff --git a/gcc/testsuite/gnat.dg/controlled5_pkg.ads b/gcc/testsuite/gnat.dg/controlled5_pkg.ads new file mode 100644 index 000000000..537203987 --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled5_pkg.ads @@ -0,0 +1,19 @@ +with Ada.Finalization; use Ada.Finalization; + +package Controlled5_Pkg is + + type Root is tagged private; + + type Inner is new Ada.Finalization.Controlled with null record; + + type T_Root_Class is access all Root'Class; + + function Dummy (I : Integer) return Root'Class; + +private + + type Root is tagged record + F2 : Inner; + end record; + +end Controlled5_Pkg; diff --git a/gcc/testsuite/gnat.dg/controlled_record.adb b/gcc/testsuite/gnat.dg/controlled_record.adb new file mode 100644 index 000000000..89a9380b9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled_record.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } +-- { dg-options "-O2" } + +with Ada.Text_IO; use Ada.Text_IO; +with Assert; + +package body Controlled_Record is + + procedure Assert_Invariants (PA : Point_T) is + PB : Point_T; + begin + Assert.Assert (PB.Pos = PA.Pos); + end; + +end Controlled_Record; diff --git a/gcc/testsuite/gnat.dg/controlled_record.ads b/gcc/testsuite/gnat.dg/controlled_record.ads new file mode 100644 index 000000000..71a57372c --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled_record.ads @@ -0,0 +1,16 @@ +with Ada.Finalization; + +package Controlled_Record is + + type Point_T is limited private; + procedure Assert_Invariants (PA : Point_T); + +private + + type Coords_T is array (1 .. 2) of Natural; + + type Point_T is new Ada.Finalization.Controlled with record + Pos : Coords_T := (0, 0); + end record; + +end Controlled_Record; diff --git a/gcc/testsuite/gnat.dg/conv_bug.adb b/gcc/testsuite/gnat.dg/conv_bug.adb new file mode 100644 index 000000000..f5aaef363 --- /dev/null +++ b/gcc/testsuite/gnat.dg/conv_bug.adb @@ -0,0 +1,30 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +with discr3; use discr3; +with Text_IO; use Text_IO; +procedure Conv_Bug is +begin + begin + V2 := S2 (V1); + exception + when Constraint_Error => null; + when others => Put_Line ("Wrong Exception raised"); + end; + + begin + V2 := S2(V1(V1'Range)); + Put_Line ("No exception raised - 2"); + exception + when Constraint_Error => null; + when others => Put_Line ("Wrong Exception raised"); + end; + + begin + V2 := S2 (V3); + Put_Line ("No exception raised - 3"); + exception + when Constraint_Error => null; + when others => Put_Line ("Wrong Exception raised"); + end; +end Conv_Bug; diff --git a/gcc/testsuite/gnat.dg/conv_decimal.adb b/gcc/testsuite/gnat.dg/conv_decimal.adb new file mode 100644 index 000000000..d5199c1b4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/conv_decimal.adb @@ -0,0 +1,34 @@ +-- PR middle-end/36575 +-- reporter: Laurent Guerby <laurent@guerby.net> +-- { dg-do run } + +procedure Conv_Decimal is + + type Unsigned_Over_8 is mod 2**8+2; + type Signed_Over_8 is range -200 .. 200; + + procedure Assert(Truth: Boolean) is + begin + if not Truth then + raise Program_Error; + end if; + end; + + type Decim is delta 0.1 digits 5; + + Halfway : Decim := 2.5; + Neg_Half : Decim := -2.5; + + Big : Unsigned_Over_8; + Also_Big : Signed_Over_8; + +begin + Big := Unsigned_Over_8 (Halfway); -- Rounds up by 4.6(33). + Assert(Big = 3); + + Also_Big := Signed_Over_8 (Halfway); -- Rounds up by 4.6(33). + Assert(Also_Big = 3); + + Also_Big := Signed_Over_8 (Neg_Half); -- Rounds down by 4.6(33). + Assert(Also_Big = -3); +end; diff --git a/gcc/testsuite/gnat.dg/conv_integer.adb b/gcc/testsuite/gnat.dg/conv_integer.adb new file mode 100644 index 000000000..7693da077 --- /dev/null +++ b/gcc/testsuite/gnat.dg/conv_integer.adb @@ -0,0 +1,12 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +procedure Conv_Integer is + S : constant := Integer'Size; + type Regoff_T is range -1 .. 2 ** (S-1); + for Regoff_T'Size use S; + B : Integer; + C : Regoff_T; +begin + B := Integer (C); +end; diff --git a/gcc/testsuite/gnat.dg/conv_real.adb b/gcc/testsuite/gnat.dg/conv_real.adb new file mode 100644 index 000000000..99808e7ad --- /dev/null +++ b/gcc/testsuite/gnat.dg/conv_real.adb @@ -0,0 +1,18 @@ +-- { dg-do run } + +with Interfaces; use Interfaces; +procedure Conv_Real is + Small : constant := 10.0**(-9); + type Time_Type is delta Small range -2**63 * Small .. (2**63-1) * Small; + for Time_Type'Small use Small; + for Time_Type'Size use 64; + procedure Cache (Seconds_Per_GDS_Cycle : in Time_Type) is + Cycles_Per_Second : constant Time_Type := (1.0 / Seconds_Per_GDS_Cycle); + begin + if Integer_32 (Seconds_Per_GDS_Cycle * Cycles_Per_Second) /= 1 then + raise Program_Error; + end if; + end Cache; +begin + Cache (0.035); +end; diff --git a/gcc/testsuite/gnat.dg/curr_task.adb b/gcc/testsuite/gnat.dg/curr_task.adb new file mode 100644 index 000000000..628be1759 --- /dev/null +++ b/gcc/testsuite/gnat.dg/curr_task.adb @@ -0,0 +1,134 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +with Ada.Exceptions; +with Ada.Text_IO; +with Ada.Task_Identification; + +procedure Curr_Task is + + use Ada.Task_Identification; + + -- Simple semaphore + + protected Semaphore is + entry Lock; + procedure Unlock; + private + TID : Task_Id := Null_Task_Id; + Lock_Count : Natural := 0; + end Semaphore; + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + Semaphore.Lock; + end Lock; + + --------------- + -- Semaphore -- + --------------- + + protected body Semaphore is + + ---------- + -- Lock -- + ---------- + + entry Lock when Lock_Count = 0 + or else TID = Current_Task + is + begin + if not + (Lock_Count = 0 + or else TID = Lock'Caller) + then + Ada.Text_IO.Put_Line + ("Barrier leaks " & Lock_Count'Img + & ' ' & Image (TID) + & ' ' & Image (Lock'Caller)); + end if; + + Lock_Count := Lock_Count + 1; + TID := Lock'Caller; + end Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock is + begin + if TID = Current_Task then + Lock_Count := Lock_Count - 1; + else + raise Tasking_Error; + end if; + end Unlock; + + end Semaphore; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock is + begin + Semaphore.Unlock; + end Unlock; + + task type Secondary is + entry Start; + end Secondary; + + procedure Parse (P1 : Positive); + + ----------- + -- Parse -- + ----------- + + procedure Parse (P1 : Positive) is + begin + Lock; + delay 0.01; + + if P1 mod 2 = 0 then + Lock; + delay 0.01; + Unlock; + end if; + + Unlock; + end Parse; + + --------------- + -- Secondary -- + --------------- + + task body Secondary is + begin + accept Start; + + for K in 1 .. 20 loop + Parse (K); + end loop; + + raise Constraint_Error; + + exception + when Program_Error => + null; + end Secondary; + + TS : array (1 .. 2) of Secondary; + +begin + Parse (1); + + for J in TS'Range loop + TS (J).Start; + end loop; +end Curr_Task; diff --git a/gcc/testsuite/gnat.dg/debug1.ads b/gcc/testsuite/gnat.dg/debug1.ads new file mode 100644 index 000000000..3ce148cf7 --- /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/decl_ctx_def.ads b/gcc/testsuite/gnat.dg/decl_ctx_def.ads new file mode 100644 index 000000000..dd004dfe0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/decl_ctx_def.ads @@ -0,0 +1,4 @@ + +package DECL_CTX_Def is + X : exception; +end; diff --git a/gcc/testsuite/gnat.dg/decl_ctx_use.adb b/gcc/testsuite/gnat.dg/decl_ctx_use.adb new file mode 100644 index 000000000..c4fde2b3e --- /dev/null +++ b/gcc/testsuite/gnat.dg/decl_ctx_use.adb @@ -0,0 +1,14 @@ +-- { dg-do compile } +-- { dg-options "-O1" } +with DECL_CTX_Def; use DECL_CTX_Def; +package body DECL_CTX_Use is + procedure Check_1 is + begin + raise X; + end; + + procedure Check_2 is + begin + raise X; + end; +end; diff --git a/gcc/testsuite/gnat.dg/decl_ctx_use.ads b/gcc/testsuite/gnat.dg/decl_ctx_use.ads new file mode 100644 index 000000000..2f38f8917 --- /dev/null +++ b/gcc/testsuite/gnat.dg/decl_ctx_use.ads @@ -0,0 +1,5 @@ + +package DECL_CTX_Use is + procedure Check_1; + procedure Check_2; +end; diff --git a/gcc/testsuite/gnat.dg/deep_old.adb b/gcc/testsuite/gnat.dg/deep_old.adb new file mode 100644 index 000000000..d7818ff96 --- /dev/null +++ b/gcc/testsuite/gnat.dg/deep_old.adb @@ -0,0 +1,10 @@ +-- { dg-options "-gnatws" } + +procedure Deep_Old (X : Integer) is +begin + begin + if X = X'Old then + null; + end if; + end; +end Deep_Old; diff --git a/gcc/testsuite/gnat.dg/deferred_const1.adb b/gcc/testsuite/gnat.dg/deferred_const1.adb new file mode 100644 index 000000000..79b9f4a03 --- /dev/null +++ b/gcc/testsuite/gnat.dg/deferred_const1.adb @@ -0,0 +1,12 @@ +-- { dg-do compile } + +with Text_IO; use Text_IO; + +procedure Deferred_Const1 is + I : Integer := 16#20_3A_2D_28#; + S : constant string(1..4); + for S'address use I'address; -- { dg-warning "constant overlays a variable" } + pragma Import (Ada, S); +begin + Put_Line (S); +end; diff --git a/gcc/testsuite/gnat.dg/deferred_const2.adb b/gcc/testsuite/gnat.dg/deferred_const2.adb new file mode 100644 index 000000000..ee06db79c --- /dev/null +++ b/gcc/testsuite/gnat.dg/deferred_const2.adb @@ -0,0 +1,11 @@ +-- { dg-do run } + +with System; use System; +with Deferred_Const2_Pkg; use Deferred_Const2_Pkg; + +procedure Deferred_Const2 is +begin + if I'Address /= S'Address then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/deferred_const2_pkg.adb b/gcc/testsuite/gnat.dg/deferred_const2_pkg.adb new file mode 100644 index 000000000..b81d44886 --- /dev/null +++ b/gcc/testsuite/gnat.dg/deferred_const2_pkg.adb @@ -0,0 +1,11 @@ +with System; use System; + +package body Deferred_Const2_Pkg is + + procedure Dummy is begin null; end; + +begin + if S'Address /= I'Address then + raise Program_Error; + end if; +end Deferred_Const2_Pkg; diff --git a/gcc/testsuite/gnat.dg/deferred_const2_pkg.ads b/gcc/testsuite/gnat.dg/deferred_const2_pkg.ads new file mode 100644 index 000000000..c76e5fdb8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/deferred_const2_pkg.ads @@ -0,0 +1,12 @@ +package Deferred_Const2_Pkg is + + I : Integer := 16#20_3A_2D_28#; + + pragma Warnings (Off); + S : constant string(1..4); + for S'address use I'address; + pragma Import (Ada, S); + + procedure Dummy; + +end Deferred_Const2_Pkg; diff --git a/gcc/testsuite/gnat.dg/deferred_const3.adb b/gcc/testsuite/gnat.dg/deferred_const3.adb new file mode 100644 index 000000000..84554d306 --- /dev/null +++ b/gcc/testsuite/gnat.dg/deferred_const3.adb @@ -0,0 +1,19 @@ +-- { dg-do run } + +with System; use System; +with Deferred_Const3_Pkg; use Deferred_Const3_Pkg; + +procedure Deferred_Const3 is +begin + if C1'Address /= C'Address then + raise Program_Error; + end if; + + if C2'Address /= C'Address then + raise Program_Error; + end if; + + if C3'Address /= C'Address then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/deferred_const3_pkg.adb b/gcc/testsuite/gnat.dg/deferred_const3_pkg.adb new file mode 100644 index 000000000..e86549445 --- /dev/null +++ b/gcc/testsuite/gnat.dg/deferred_const3_pkg.adb @@ -0,0 +1,19 @@ +with System; use System; + +package body Deferred_Const3_Pkg is + + procedure Dummy is begin null; end; + +begin + if C1'Address /= C'Address then + raise Program_Error; + end if; + + if C2'Address /= C'Address then + raise Program_Error; + end if; + + if C3'Address /= C'Address then + raise Program_Error; + end if; +end Deferred_Const3_Pkg; diff --git a/gcc/testsuite/gnat.dg/deferred_const3_pkg.ads b/gcc/testsuite/gnat.dg/deferred_const3_pkg.ads new file mode 100644 index 000000000..de6af3d52 --- /dev/null +++ b/gcc/testsuite/gnat.dg/deferred_const3_pkg.ads @@ -0,0 +1,21 @@ +package Deferred_Const3_Pkg is + + C : constant Natural := 1; + + C1 : constant Natural := 1; + for C1'Address use C'Address; + + C2 : constant Natural; + for C2'Address use C'Address; + + C3 : constant Natural; + + procedure Dummy; + +private + C2 : constant Natural := 1; + + C3 : constant Natural := 1; + for C3'Address use C'Address; + +end Deferred_Const3_Pkg; diff --git a/gcc/testsuite/gnat.dg/deques.ads b/gcc/testsuite/gnat.dg/deques.ads new file mode 100644 index 000000000..9e7489768 --- /dev/null +++ b/gcc/testsuite/gnat.dg/deques.ads @@ -0,0 +1,14 @@ +package Deques is + + type Deque (<>) is tagged limited private; + function Create return Deque; + procedure Pop (D : access Deque); + + type Sequence is limited interface; + type P_Deque is new Deque and Sequence with private; + function Create return P_Deque; + +private + type Deque is tagged limited null record; + type P_Deque is new Deque and Sequence with null record; +end Deques; diff --git a/gcc/testsuite/gnat.dg/deref1.ads b/gcc/testsuite/gnat.dg/deref1.ads new file mode 100644 index 000000000..3da99ab0a --- /dev/null +++ b/gcc/testsuite/gnat.dg/deref1.ads @@ -0,0 +1,4 @@ +package deref1 is + type T is tagged limited null record; + procedure Op (Obj : in out T); +end deref1; diff --git a/gcc/testsuite/gnat.dg/deref2.ads b/gcc/testsuite/gnat.dg/deref2.ads new file mode 100644 index 000000000..84d509f91 --- /dev/null +++ b/gcc/testsuite/gnat.dg/deref2.ads @@ -0,0 +1,13 @@ +with deref1; +package deref2 is + type NT is tagged limited private; + + function PT_View (Obj : not null access NT) + return not null access deref1.T'Class; +private + type PT (Obj : not null access NT) is new deref1.T with null record; + + type NT is tagged limited record + PT_View : aliased PT (NT'Access); + end record; +end; diff --git a/gcc/testsuite/gnat.dg/deref3.adb b/gcc/testsuite/gnat.dg/deref3.adb new file mode 100644 index 000000000..b0edb18fb --- /dev/null +++ b/gcc/testsuite/gnat.dg/deref3.adb @@ -0,0 +1,10 @@ +-- { dg-do compile } + +with deref2; +procedure deref3 is + Obj : aliased deref2.NT; +begin + deref2.PT_View (Obj'Access).Op; + Obj.PT_View.all.Op; + Obj.PT_View.Op; +end; diff --git a/gcc/testsuite/gnat.dg/derived_aggregate.adb b/gcc/testsuite/gnat.dg/derived_aggregate.adb new file mode 100644 index 000000000..29dad7874 --- /dev/null +++ b/gcc/testsuite/gnat.dg/derived_aggregate.adb @@ -0,0 +1,32 @@ +-- { dg-do run } +-- { dg-options "-O2" } + +procedure Derived_Aggregate is + type Int is range 1 .. 10; + type Str is array (Int range <>) of Character; + + type Parent (D1, D2 : Int; B : Boolean) is + record + S : Str (D1 .. D2); + case B is + when False => C1 : Integer; + when True => C2 : Float; + end case; + end record; + + for Parent'Alignment use 8; + + type Derived (D : Int) is new Parent (D1 => D, D2 => D, B => False); + + function Ident (I : Integer) return integer is + begin + return I; + end; + + Y : Derived := (D => 7, S => "b", C1 => Ident (32)); + +begin + if Parent(Y).D1 /= 7 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/derived_type1.adb b/gcc/testsuite/gnat.dg/derived_type1.adb new file mode 100644 index 000000000..c50d5ef46 --- /dev/null +++ b/gcc/testsuite/gnat.dg/derived_type1.adb @@ -0,0 +1,28 @@ +-- { dg-do compile } +-- { dg-options "-gnatws -fdump-tree-original" } + +procedure Derived_Type1 is + + type Root is tagged null record; + + type Derived1 is new Root with record + I1 : Integer; + end record; + + type Derived2 is new Derived1 with record + I2: Integer; + end record; + + R : Root; + D1 : Derived1; + D2 : Derived2; + +begin + R := Root(D1); + R := Root(D2); + D1 := Derived1(D2); +end; + +-- { dg-final { scan-tree-dump-not "VIEW_CONVERT_EXPR<struct derived_type1__root>" "original" } } +-- { dg-final { scan-tree-dump-not "VIEW_CONVERT_EXPR<struct derived_type1__derived1>" "original" } } +-- { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gnat.dg/dg.exp b/gcc/testsuite/gnat.dg/dg.exp new file mode 100644 index 000000000..a764c0b00 --- /dev/null +++ b/gcc/testsuite/gnat.dg/dg.exp @@ -0,0 +1,36 @@ +# Copyright (C) 2006, 2007 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# <http://www.gnu.org/licenses/>. + +# GCC testsuite that uses the `dg.exp' driver. + +# Load support procs. +load_lib gnat-dg.exp + +# If a testcase doesn't have special options, use these. +global DEFAULT_CFLAGS +if ![info exists DEFAULT_CFLAGS] then { + set DEFAULT_CFLAGS "" +} + +# Initialize `dg'. +dg-init + +# Main loop. +dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.adb]] \ + "" $DEFAULT_CFLAGS + +# All done. +dg-finish diff --git a/gcc/testsuite/gnat.dg/discr1.ads b/gcc/testsuite/gnat.dg/discr1.ads new file mode 100644 index 000000000..e2adab441 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr1.ads @@ -0,0 +1,25 @@ +package discr1 is + + type R is (One, Two); + + type C_Type (Kind : R) is + record + case Kind is + when One => + Name : Integer; + when Two => + Designator : String (1 .. 40); + end case; + end record; + + for C_Type use record + Name at 0 range 0.. 31; + Designator at 0 range 0..319; + Kind at 40 range 0.. 7; + end record; + + for C_Type'Size use 44 * 8; + + procedure Assign (Id : String); + +end discr1; diff --git a/gcc/testsuite/gnat.dg/discr10.adb b/gcc/testsuite/gnat.dg/discr10.adb new file mode 100644 index 000000000..4ad834fd1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr10.adb @@ -0,0 +1,8 @@ +package body Discr10 is + + function Get (X : R) return R is + begin + return R'(D1 => False, D2 => False, D3 => X.D3); + end; + +end Discr10; diff --git a/gcc/testsuite/gnat.dg/discr10.ads b/gcc/testsuite/gnat.dg/discr10.ads new file mode 100644 index 000000000..8df7ef146 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr10.ads @@ -0,0 +1,23 @@ +package Discr10 is + + subtype Index is Natural range 0 .. 150; + + type List is array (Index range <>) of Integer; + + type R (D1 : Boolean := True; D2 : Boolean := False; D3 : Index := 0) is + record + case D2 is + when True => + L : List (1 .. D3); + case D1 is + when True => I : Integer; + when False => null; + end case; + when False => + null; + end case; + end record; + + function Get (X : R) return R; + +end Discr10; diff --git a/gcc/testsuite/gnat.dg/discr11.adb b/gcc/testsuite/gnat.dg/discr11.adb new file mode 100644 index 000000000..ceec4cefb --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr11.adb @@ -0,0 +1,9 @@ +-- { dg-do compile } + +package body Discr11 is + function Create return DT_2 is + begin + return DT_2'(DT_1'(Create) with More => 1234); + end; +end Discr11; + diff --git a/gcc/testsuite/gnat.dg/discr11.ads b/gcc/testsuite/gnat.dg/discr11.ads new file mode 100644 index 000000000..b3911999d --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr11.ads @@ -0,0 +1,9 @@ +with Discr11_Pkg; use Discr11_Pkg; + +package Discr11 is + type DT_2 is new DT_1 with record + More : Integer; + end record; + + function Create return DT_2; +end Discr11; diff --git a/gcc/testsuite/gnat.dg/discr11_pkg.ads b/gcc/testsuite/gnat.dg/discr11_pkg.ads new file mode 100644 index 000000000..1b0a979bb --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr11_pkg.ads @@ -0,0 +1,8 @@ +package Discr11_Pkg is + type DT_1 (<>) is tagged private; + function Create return DT_1; +private + type DT_1 (Size : Positive) is tagged record + Data : String (1 .. Size); + end record; +end Discr11_Pkg; diff --git a/gcc/testsuite/gnat.dg/discr12.adb b/gcc/testsuite/gnat.dg/discr12.adb new file mode 100644 index 000000000..ae72850dd --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr12.adb @@ -0,0 +1,35 @@ +-- { dg-do compile } + +with Discr12_Pkg; use Discr12_Pkg; + +procedure Discr12 is + + subtype Small_Int is Integer range 1..10; + + package P is + + type PT_W_Disc (D : Small_Int) is private; + + type Rec_W_Private (D1 : Integer) is + record + C : PT_W_Disc (D1); + end record; + + type Rec_01 (D3 : Integer) is + record + C1 : Rec_W_Private (D3); + end record; + + type Arr is array (1 .. 5) of Rec_01(Dummy(0)); + + private + type PT_W_Disc (D : Small_Int) is + record + Str : String (1 .. D); + end record; + + end P; + +begin + Null; +end; diff --git a/gcc/testsuite/gnat.dg/discr12_pkg.ads b/gcc/testsuite/gnat.dg/discr12_pkg.ads new file mode 100644 index 000000000..785146310 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr12_pkg.ads @@ -0,0 +1,5 @@ +package Discr12_Pkg is + + function Dummy (I : Integer) return Integer; + +end Discr12_Pkg; diff --git a/gcc/testsuite/gnat.dg/discr13.adb b/gcc/testsuite/gnat.dg/discr13.adb new file mode 100644 index 000000000..3dcf2150c --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr13.adb @@ -0,0 +1,30 @@ +-- { dg-do compile } + +with Discr12_Pkg; use Discr12_Pkg; + +procedure Discr13 is + + function F1 return Integer is + begin + return Dummy (1); + end F1; + + protected type Poe (D3 : Integer := F1) is + entry E (D3 .. F1); -- F1 evaluated + function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer) 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 (D3 : Integer; E_First : Integer; E_Last : Integer) return Boolean is + begin + return False; + end Is_Ok; + end Poe; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/discr14.adb b/gcc/testsuite/gnat.dg/discr14.adb new file mode 100644 index 000000000..490ec4358 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr14.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } + +package body Discr14 is + + procedure ASSIGN( TARGET : in out SW_TYPE_INFO ; + SOURCE : in SW_TYPE_INFO ) is + begin + TARGET := new T_SW_TYPE_DESCRIPTOR( SOURCE.SW_TYPE, SOURCE.DIMENSION ); + end ASSIGN; + +end Discr14; diff --git a/gcc/testsuite/gnat.dg/discr14.ads b/gcc/testsuite/gnat.dg/discr14.ads new file mode 100644 index 000000000..a6b5a0a87 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr14.ads @@ -0,0 +1,42 @@ +package Discr14 is + + type COMPLETION_CODE is (SUCCESS, FAILURE, NONE); + + type T_SW_TYPE is (NONE, COMPLETION_CODE_TYPE); + + type T_COMPLETION_CODE_RANGE (CONSTRAINED: BOOLEAN := FALSE) is + record + case CONSTRAINED is + when TRUE => + FIRST : COMPLETION_CODE := SUCCESS; + LAST : COMPLETION_CODE := FAILURE; + when FALSE => + null; + end case; + end record; + + type T_SW_DIMENSIONS is range 0 .. 3; + + type T_SW_INDEX_LIST is array (T_SW_DIMENSIONS range <>) of POSITIVE; + + type T_SW_TYPE_DESCRIPTOR (SW_TYPE : T_SW_TYPE := NONE; + DIMENSION : T_SW_DIMENSIONS := 0) is + record + BOUNDS : T_SW_INDEX_LIST (1 .. DIMENSION); + + case SW_TYPE is + + when COMPLETION_CODE_TYPE => + COMPLETION_CODE_RANGE : T_COMPLETION_CODE_RANGE; + + when OTHERS => + null; + + end case; + end record; + + type SW_TYPE_INFO is access T_SW_TYPE_DESCRIPTOR; + + procedure ASSIGN(TARGET : in out SW_TYPE_INFO; SOURCE : in SW_TYPE_INFO) ; + +end Discr14; diff --git a/gcc/testsuite/gnat.dg/discr15.adb b/gcc/testsuite/gnat.dg/discr15.adb new file mode 100644 index 000000000..0030ac7d9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr15.adb @@ -0,0 +1,14 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +with Discr15_Pkg; use Discr15_Pkg; + +procedure Discr15 (History : in Rec_Multi_Moment_History) is + + Sub: constant Rec_Multi_Moment_History := Sub_History_Of (History); + subtype Vec is String(0..Sub.Last); + Mmts : array(1..Sub.Size) of Vec; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/discr15_pkg.ads b/gcc/testsuite/gnat.dg/discr15_pkg.ads new file mode 100644 index 000000000..1f3bf286b --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr15_pkg.ads @@ -0,0 +1,16 @@ +package Discr15_Pkg is + + type Moment is new Positive; + + type Multi_Moment_History is array (Natural range <>, Moment range <>) of Float; + + type Rec_Multi_Moment_History (Len : Natural; Size : Moment) is + record + Moments : Multi_Moment_History(0..Len, 1..Size); + Last : Natural; + end record; + + function Sub_History_Of (History : Rec_Multi_Moment_History) + return Rec_Multi_Moment_History; + +end Discr15_Pkg; diff --git a/gcc/testsuite/gnat.dg/discr16.adb b/gcc/testsuite/gnat.dg/discr16.adb new file mode 100644 index 000000000..c4c24fd4d --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr16.adb @@ -0,0 +1,23 @@ +-- { dg-do compile } + +with Discr16_G; +with Discr16_Cont; use Discr16_Cont; + +procedure Discr16 is + + generic + type T is (<>); + function MAX_ADD_G(X : T; I : INTEGER) return T; + + function MAX_ADD_G(X : T; I : INTEGER) return T is + begin + return T'val(T'pos(X) + LONG_INTEGER(I)); + end; + + function MAX_ADD is new MAX_ADD_G(ES6A); + + package P is new Discr16_G(ES6A, MAX_ADD); + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/discr16_cont.ads b/gcc/testsuite/gnat.dg/discr16_cont.ads new file mode 100644 index 000000000..ea041cadf --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr16_cont.ads @@ -0,0 +1,7 @@ +with Discr16_Pkg; use Discr16_Pkg; + +package Discr16_Cont is + + type ES6a is new ET3a range E2..E4; + +end; diff --git a/gcc/testsuite/gnat.dg/discr16_g.ads b/gcc/testsuite/gnat.dg/discr16_g.ads new file mode 100644 index 000000000..f163f75d9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr16_g.ads @@ -0,0 +1,18 @@ +generic + + type T is (<>); + with function MAX_ADD(X : T; I : INTEGER) return T; + +package Discr16_G is + + LO : T := T'val(T'pos(T'first)); + HI : T := T'val(T'pos(MAX_ADD(LO, 15))); + + type A2 is array(T range <>) of T; + + type R2(D : T) is + record + C : A2(LO..D); + end record; + +end; diff --git a/gcc/testsuite/gnat.dg/discr16_pkg.ads b/gcc/testsuite/gnat.dg/discr16_pkg.ads new file mode 100644 index 000000000..985785f66 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr16_pkg.ads @@ -0,0 +1,7 @@ +package Discr16_Pkg is + + type ET3a is (E1, E2, E3, E4, E5); + for ET3a use (E1=> 32_001, E2=> 32_002, E3=> 32_003, + E4=> 32_004, E5=> 32_005); + +end; diff --git a/gcc/testsuite/gnat.dg/discr17.adb b/gcc/testsuite/gnat.dg/discr17.adb new file mode 100644 index 000000000..d7b480c07 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr17.adb @@ -0,0 +1,66 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +procedure Discr17 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/discr18.adb b/gcc/testsuite/gnat.dg/discr18.adb new file mode 100644 index 000000000..bd3fd7944 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr18.adb @@ -0,0 +1,19 @@ +-- { dg-do compile } + +with Discr18_Pkg; use Discr18_Pkg; + +procedure Discr18 is + + String_10 : String (1..10) := "1234567890"; + + MD : Multiple_Discriminants (A => 10, B => 10) := + Multiple_Discriminants'(A => 10, + B => 10, + S1 => String_10, + S2 => String_10); + MDE : Multiple_Discriminant_Extension (C => 10) := + (MD with C => 10, S3 => String_10); + +begin + Do_Something(MDE); +end; diff --git a/gcc/testsuite/gnat.dg/discr18_pkg.ads b/gcc/testsuite/gnat.dg/discr18_pkg.ads new file mode 100644 index 000000000..72f7fec95 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr18_pkg.ads @@ -0,0 +1,19 @@ +package Discr18_Pkg is + + subtype Length is Natural range 0..256; + + type Multiple_Discriminants (A, B : Length) is tagged + record + S1 : String (1..A); + S2 : String (1..B); + end record; + + procedure Do_Something (Rec : in out Multiple_Discriminants); + + type Multiple_Discriminant_Extension (C : Length) is + new Multiple_Discriminants (A => C, B => C) + with record + S3 : String (1..C); + end record; + +end Discr18_Pkg; diff --git a/gcc/testsuite/gnat.dg/discr19.adb b/gcc/testsuite/gnat.dg/discr19.adb new file mode 100644 index 000000000..8f5c56b3f --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr19.adb @@ -0,0 +1,16 @@ +-- { dg-do compile } + +procedure Discr19 is + + type Arr_Int_T is array (Integer range <>) of Integer; + + type Abs_Tag_Rec_T (N : Integer; M : Integer) is abstract tagged record + Arr_Int : Arr_Int_T (1..M); + end record; + + type Tag_Rec_T (M : Integer) + is new Abs_Tag_Rec_T (N => 1, M => M) with null record; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/discr2.adb b/gcc/testsuite/gnat.dg/discr2.adb new file mode 100644 index 000000000..0f03a0fd9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr2.adb @@ -0,0 +1,22 @@ +-- { dg-do compile } + +with discr1; use discr1; + +package body discr2 is + + procedure Copy (Dataset : in out C_Type) is + Last_Char : Positive := 300; + begin + while (Last_Char > 40) loop + Last_Char := Last_Char - 1; + end loop; + + Assign (Dataset.Designator (1 .. Last_Char)); + end; + + procedure Dummy is + begin + null; + end Dummy; + +end discr2; diff --git a/gcc/testsuite/gnat.dg/discr2.ads b/gcc/testsuite/gnat.dg/discr2.ads new file mode 100644 index 000000000..f534ba20c --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr2.ads @@ -0,0 +1,5 @@ +package discr2 is + + procedure Dummy; + +end discr2; diff --git a/gcc/testsuite/gnat.dg/discr20.adb b/gcc/testsuite/gnat.dg/discr20.adb new file mode 100644 index 000000000..358d56540 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr20.adb @@ -0,0 +1,10 @@ +-- { dg-do compile } + +package body Discr20 is + + function Get (X : Wrapper) return Def is + begin + return X.It; + end Get; + +end Discr20; diff --git a/gcc/testsuite/gnat.dg/discr20.ads b/gcc/testsuite/gnat.dg/discr20.ads new file mode 100644 index 000000000..a447b3309 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr20.ads @@ -0,0 +1,31 @@ +package Discr20 is + + Size : Integer; + + type Name is new String (1..Size); + + type Rec is record + It : Name; + end record; + + type Danger is (This, That); + type def (X : Danger := This) is record + case X is + when This => It : Rec; + when That => null; + end case; + end record; + + type Switch is (On, Off); + type Wrapper (Disc : Switch := On) is private; + function Get (X : Wrapper) return Def; + +private + type Wrapper (Disc : Switch := On) is record + Case Disc is + when On => It : Def; + when Off => null; + end case; + end record; + +end Discr20; diff --git a/gcc/testsuite/gnat.dg/discr21.adb b/gcc/testsuite/gnat.dg/discr21.adb new file mode 100644 index 000000000..5c105cdb2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr21.adb @@ -0,0 +1,34 @@ +-- { dg-do compile } +-- { dg-options "-gnatws -O3" } + +with Discr21_Pkg; use Discr21_Pkg; + +package body Discr21 is + + type Index is new Natural range 0 .. 100; + + type Arr is array (Index range <> ) of Position; + + type Rec(Size : Index := 1) is record + A : Arr(1 .. Size); + end record; + + Data : Rec; + + function To_V(pos : Position) return VPosition is + begin + return To_Position(pos.x, pos.y, pos.z); + end; + + procedure Read(Data : Rec) is + pos : VPosition := To_V (Data.A(1)); + begin + null; + end; + + procedure Test is + begin + Read (Data); + end; + +end Discr21; diff --git a/gcc/testsuite/gnat.dg/discr21.ads b/gcc/testsuite/gnat.dg/discr21.ads new file mode 100644 index 000000000..8de8ed08b --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr21.ads @@ -0,0 +1,5 @@ +package Discr21 is + + procedure Test; + +end Discr21; diff --git a/gcc/testsuite/gnat.dg/discr21_pkg.ads b/gcc/testsuite/gnat.dg/discr21_pkg.ads new file mode 100644 index 000000000..d156df625 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr21_pkg.ads @@ -0,0 +1,19 @@ +package Discr21_Pkg is + + type Position is record + x,y,z : Float; + end record; + + type Dim is (Two, Three); + + type VPosition (D: Dim := Three) is record + x, y : Float; + case D is + when Two => null; + when Three => z : Float; + end case; + end record; + + function To_Position (x, y, z : Float) return VPosition; + +end Discr21_Pkg; diff --git a/gcc/testsuite/gnat.dg/discr22.adb b/gcc/testsuite/gnat.dg/discr22.adb new file mode 100644 index 000000000..af4f9ab78 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr22.adb @@ -0,0 +1,23 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +procedure Discr22 is + + subtype Precision is Integer range 1 .. 5; + + type Rec(D1 : Precision; D2 : Integer) is record + case D1 is + when 1 => I : Integer; + when others => null; + end case; + end record; + for Rec use record + D1 at 0 range 0 .. 7; + end record; + + P : Precision; + X : Rec(P, 0); + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/discr23.adb b/gcc/testsuite/gnat.dg/discr23.adb new file mode 100644 index 000000000..1d1e695e9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr23.adb @@ -0,0 +1,18 @@ +-- { dg-do compile } + +with Discr23_Pkg; use Discr23_Pkg; + +package body Discr23 is + + N : constant Text := Get; + + function Try (A : in Text) return Text is + begin + return A; + exception + when others => return N; + end; + + procedure Dummy is begin null; end; + +end Discr23; diff --git a/gcc/testsuite/gnat.dg/discr23.ads b/gcc/testsuite/gnat.dg/discr23.ads new file mode 100644 index 000000000..960dcdaf8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr23.ads @@ -0,0 +1,5 @@ +package Discr23 is + + procedure Dummy; + +end Discr23; diff --git a/gcc/testsuite/gnat.dg/discr23_pkg.ads b/gcc/testsuite/gnat.dg/discr23_pkg.ads new file mode 100644 index 000000000..339734be8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr23_pkg.ads @@ -0,0 +1,12 @@ +package Discr23_Pkg is + + subtype Size_Range is Positive range 1 .. 256; + + type Text (Size : Size_Range) is + record + Characters : String( 1.. Size); + end record; + + function Get return Text; + +end Discr23_Pkg; diff --git a/gcc/testsuite/gnat.dg/discr24.adb b/gcc/testsuite/gnat.dg/discr24.adb new file mode 100644 index 000000000..dcd67c4b2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr24.adb @@ -0,0 +1,46 @@ +-- { dg-do run } +-- { dg-options "-gnatp" } + +procedure Discr24 is + + type Family_Type is (Family_Inet, Family_Inet6); + type Port_Type is new Natural; + + subtype Inet_Addr_Comp_Type is Natural range 0 .. 255; + + type Inet_Addr_VN_Type is array (Natural range <>) of Inet_Addr_Comp_Type; + + subtype Inet_Addr_V4_Type is Inet_Addr_VN_Type (1 .. 4); + subtype Inet_Addr_V6_Type is Inet_Addr_VN_Type (1 .. 16); + + type Inet_Addr_Type (Family : Family_Type := Family_Inet) is record + case Family is + when Family_Inet => + Sin_V4 : Inet_Addr_V4_Type := (others => 0); + + when Family_Inet6 => + Sin_V6 : Inet_Addr_V6_Type := (others => 0); + end case; + end record; + + type Sock_Addr_Type (Family : Family_Type := Family_Inet) is record + Addr : Inet_Addr_Type (Family); + Port : Port_Type; + end record; + + function F return Inet_Addr_Type is + begin + return Inet_Addr_Type' + (Family => Family_Inet, Sin_V4 => (192, 168, 169, 170)); + end F; + + SA : Sock_Addr_Type; + +begin + SA.Addr.Sin_V4 := (172, 16, 17, 18); + SA.Port := 1111; + SA.Addr := F; + if SA.Port /= 1111 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/discr25.adb b/gcc/testsuite/gnat.dg/discr25.adb new file mode 100644 index 000000000..a1effea3e --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr25.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } + +with Discr25_Pkg; + +procedure Discr25 (N : Natural) is + + package Test_Set is new Discr25_Pkg (N); + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/discr25_pkg.adb b/gcc/testsuite/gnat.dg/discr25_pkg.adb new file mode 100644 index 000000000..59792fdcb --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr25_pkg.adb @@ -0,0 +1,24 @@ +package body Discr25_Pkg is + + type Arr1 is array (Natural range <>) of Integer; + + B : constant Boolean := N > 0; + + type Arr2 is array (True .. B) of Integer; + + type Obj_T (Size_Max : Natural) is record + A2 : Arr2; + A1 : Arr1 (0 .. Size_Max); + end record; + + procedure Proc1 (Set : in out T) is + begin + Set := new Obj_T'(Set.all); + end; + + procedure Proc2 (Obj : in out T; L : Natural) is + begin + Obj := new Obj_T (L); + end; + +end Discr25_Pkg; diff --git a/gcc/testsuite/gnat.dg/discr25_pkg.ads b/gcc/testsuite/gnat.dg/discr25_pkg.ads new file mode 100644 index 000000000..c09634d8c --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr25_pkg.ads @@ -0,0 +1,15 @@ +generic + + N : Natural; + +package Discr25_Pkg is + + type T is private; + + procedure Proc1 (Set : in out T); + +private + type Obj_T (Size_Max : Natural); + type T is access Obj_T; + +end Discr25_Pkg; diff --git a/gcc/testsuite/gnat.dg/discr29.adb b/gcc/testsuite/gnat.dg/discr29.adb new file mode 100644 index 000000000..834437f6f --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr29.adb @@ -0,0 +1,10 @@ +-- { dg-do compile } + +package body Discr29 is + + procedure Proc (R : out Rec3) is + begin + R := (False, Tmp); + end; + +end Discr29; diff --git a/gcc/testsuite/gnat.dg/discr29.ads b/gcc/testsuite/gnat.dg/discr29.ads new file mode 100644 index 000000000..6bbf16725 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr29.ads @@ -0,0 +1,25 @@ +package Discr29 is + + type Rec1 is record + I1 : Integer; + I2 : Integer; + I3 : Integer; + end record; + + type Rec2 is tagged record + I1 : Integer; + I2 : Integer; + end record; + + type Rec3 (D : Boolean) is record + case D is + when True => A : Rec1; + when False => B : Rec2; + end case; + end record; + + procedure Proc (R : out Rec3); + + Tmp : Rec2; + +end Discr29; diff --git a/gcc/testsuite/gnat.dg/discr3.ads b/gcc/testsuite/gnat.dg/discr3.ads new file mode 100644 index 000000000..37ba91734 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr3.ads @@ -0,0 +1,11 @@ +package discr3 is + type E is range 0..255; + type R1 is range 1..5; + type R2 is range 11..15; + type S1 is array(R1 range <>) of E; + type S2 is array(R2 range <>) of E; + V1 : S1( 2..3) := (0,0); + V2 : S2(12..13) := (1,1); + subtype R3 is R1 range 2..3; + V3 : S1 (R3); +end discr3; diff --git a/gcc/testsuite/gnat.dg/discr30.adb b/gcc/testsuite/gnat.dg/discr30.adb new file mode 100644 index 000000000..b3bf10013 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr30.adb @@ -0,0 +1,50 @@ +-- PR ada/48844 +-- Reported by Georg Bauhaus <bauhaus@futureapps.de> */ + +-- { dg-do compile } + +procedure Discr30 is + + generic + type Source is private; + type Target is private; + function Conversion (S : Source) return Target; + + function Conversion (S : Source) return Target is + type Source_Wrapper is tagged record + S : Source; + end record; + type Target_Wrapper is tagged record + T : Target; + end record; + + type Selector is (Source_Field, Target_Field); + type Magic (Sel : Selector := Target_Field) is record + case Sel is + when Source_Field => S : Source_Wrapper; + when Target_Field => T : Target_Wrapper; + end case; + end record; + + M : Magic; + + function Convert (T : Target_Wrapper) return Target is + begin + M := (Sel => Source_Field, S => (S => S)); + return T.T; + end Convert; + + begin + return Convert (M.T); + end Conversion; + + type Integer_Access is access all Integer; + + I : aliased Integer; + I_Access : Integer_Access := I'Access; + + function Convert is new Conversion (Integer_Access, Integer); + +begin + I := Convert (I_Access); +end; diff --git a/gcc/testsuite/gnat.dg/discr4.adb b/gcc/testsuite/gnat.dg/discr4.adb new file mode 100644 index 000000000..859daaf7f --- /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/discr5.adb b/gcc/testsuite/gnat.dg/discr5.adb new file mode 100644 index 000000000..631db55db --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr5.adb @@ -0,0 +1,17 @@ +-- { dg-do compile } + +procedure Discr5 is + + type Enum is (Ten, Twenty); + for Enum use (10, 20); + type Arr is array (Enum range <>) of Integer; + type Rec (Discr: Enum := Ten) is record + case Discr is + when others => + A: Arr (Ten .. Discr); + end case; + end record; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/discr6.adb b/gcc/testsuite/gnat.dg/discr6.adb new file mode 100644 index 000000000..441b19bdf --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr6.adb @@ -0,0 +1,33 @@ +-- { dg-do compile }
+-- { dg-options "-gnatdm -gnatws" }
+
+with Discr6_Pkg;
+
+procedure Discr6 is
+
+ type T_Bit is range 0..1;
+ type T_Entier_16 is range -2**15 .. 2**15-1;
+
+ package My_Q is new Discr6_Pkg(T_Entier_16);
+
+ type T_Valeur is (BIT, Entier_16);
+
+ type R(D : T_Valeur) is record
+ case D is
+ when BIT => V_BIT : T_Bit;
+ when Entier_16 => V_E16 : T_Entier_16;
+ end case;
+ end record;
+ for R use record
+ V_BIT at 0 range 0..7;
+ V_E16 at 0 range 0..15;
+ D at 8 range 0..7;
+ end record;
+ for R'size use 128;
+
+ A : R(Entier_16);
+ I : Integer;
+
+begin
+ I := My_Q.X(A.V_E16);
+end;
diff --git a/gcc/testsuite/gnat.dg/discr6_pkg.ads b/gcc/testsuite/gnat.dg/discr6_pkg.ads new file mode 100644 index 000000000..11d713c24 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr6_pkg.ads @@ -0,0 +1,16 @@ +generic
+
+ type T(<>) is private;
+
+package Discr6_Pkg is
+
+ function X (A : T) return Integer;
+
+ pragma Interface(C, X);
+ pragma IMPORT_FUNCTION (
+ INTERNAL => X,
+ EXTERNAL => X,
+ PARAMETER_TYPES => (T),
+ MECHANISM => (Descriptor(S)));
+
+end Discr6_Pkg;
diff --git a/gcc/testsuite/gnat.dg/discr7.adb b/gcc/testsuite/gnat.dg/discr7.adb new file mode 100644 index 000000000..3bb61cb12 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr7.adb @@ -0,0 +1,27 @@ +-- { dg-do compile } + +procedure Discr7 is + + subtype Index is Natural range 0..5; + type BitString is array(Index range <>) of Boolean; + pragma Pack(BitString); + + function Id (I : Integer) return Integer is + begin + return I; + end; + + type E(D : Index) is record + C : BitString(1..D); + end record; + + subtype E0 is E(Id(0)); + + function F return E0 is + begin + return E'(D=>0, C=>(1..0=>FALSE)); + end; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/discr8.adb b/gcc/testsuite/gnat.dg/discr8.adb new file mode 100644 index 000000000..cfb3d48e9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr8.adb @@ -0,0 +1,38 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +package body Discr8 is + + procedure Make (C : out Local_T) is + Tmp : Local_T (Tag_One); + begin + C := Tmp; + end; + + package Iteration is + + type Message_T is + record + S : Local_T; + end record; + + type Iterator_T is + record + S : Local_T; + end record; + + type Access_Iterator_T is access Iterator_T; + + end Iteration; + + package body Iteration is + + procedure Construct (Iterator : in out Access_Iterator_T; + Message : Message_T) is + begin + Iterator.S := Message.S; + end; + + end Iteration; + +end Discr8; diff --git a/gcc/testsuite/gnat.dg/discr8.ads b/gcc/testsuite/gnat.dg/discr8.ads new file mode 100644 index 000000000..80dd2f652 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr8.ads @@ -0,0 +1,20 @@ +with Discr8_Pkg1; use Discr8_Pkg1; + +package Discr8 is + + type Tag_T is (Tag_One, Tag_Two); + + type Local_T (Tag : Tag_T := Tag_One) is + record + case Tag is + when Tag_One => + A : T; + B : Integer; + when Tag_Two => + null; + end case; + end record; + + procedure Make (C : out Local_T); + +end Discr8; diff --git a/gcc/testsuite/gnat.dg/discr8_pkg1.ads b/gcc/testsuite/gnat.dg/discr8_pkg1.ads new file mode 100644 index 000000000..ae93dc4d4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr8_pkg1.ads @@ -0,0 +1,11 @@ +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Discr8_Pkg2; use Discr8_Pkg2; + +package Discr8_Pkg1 is + + type T is record + A : Unbounded_String; + B : L; + end record; + +end Discr8_Pkg1; diff --git a/gcc/testsuite/gnat.dg/discr8_pkg2.ads b/gcc/testsuite/gnat.dg/discr8_pkg2.ads new file mode 100644 index 000000000..f98318a5a --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr8_pkg2.ads @@ -0,0 +1,13 @@ +with Discr8_Pkg3; use Discr8_Pkg3; + +package Discr8_Pkg2 is + + Max : constant Natural := Value; + + type List_T is array (Natural range <>) of Integer; + + type L is record + List : List_T (1 .. Max); + end record; + +end Discr8_Pkg2; diff --git a/gcc/testsuite/gnat.dg/discr8_pkg3.ads b/gcc/testsuite/gnat.dg/discr8_pkg3.ads new file mode 100644 index 000000000..576b40fab --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr8_pkg3.ads @@ -0,0 +1,3 @@ +package Discr8_Pkg3 is + function Value return Natural; +end Discr8_Pkg3; diff --git a/gcc/testsuite/gnat.dg/discr9.adb b/gcc/testsuite/gnat.dg/discr9.adb new file mode 100644 index 000000000..199855f57 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr9.adb @@ -0,0 +1,10 @@ +-- { dg-do compile } + +package body Discr9 is + + procedure Proc (From : in R; To : out R) is + begin + To := R'(D1 => False, D2 => From.D2, Field => From.Field); + end; + +end Discr9; diff --git a/gcc/testsuite/gnat.dg/discr9.ads b/gcc/testsuite/gnat.dg/discr9.ads new file mode 100644 index 000000000..5edde81bf --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr9.ads @@ -0,0 +1,22 @@ +package Discr9 is + + type IArr is Array (Natural range <>) of Integer; + type CArr is Array (Natural range <>) of Character; + + type Var_R (D1 : Boolean; D2 : Boolean) is record + case D1 is + when True => + L : IArr (1..4); + M1, M2 : CArr (1..16); + when False => + null; + end case; + end record; + + type R (D1 : Boolean; D2 : Boolean) is record + Field : Var_R (D1, D2); + end record; + + procedure Proc (From : in R; To : out R); + +end Discr9; diff --git a/gcc/testsuite/gnat.dg/discr_range_check.adb b/gcc/testsuite/gnat.dg/discr_range_check.adb new file mode 100644 index 000000000..4a4ae6886 --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr_range_check.adb @@ -0,0 +1,18 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +procedure discr_range_check is + Default_First_Entry : constant := 1; + + task type Server_T (First_Entry : Positive := Default_First_Entry) is + entry E (First_Entry .. First_Entry); + end Server_T; + + task body Server_T is begin null; end; + + type Server_Access is access Server_T; + Server : Server_Access; + +begin + Server := new Server_T; +end; diff --git a/gcc/testsuite/gnat.dg/discr_test.adb b/gcc/testsuite/gnat.dg/discr_test.adb new file mode 100644 index 000000000..1a6a4d21d --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr_test.adb @@ -0,0 +1,31 @@ +-- { dg-do compile } + +procedure Discr_Test is + procedure P is begin null; end P; + + task type Tsk1 is + entry rvT; + end Tsk1; + + task body Tsk1 is + begin + accept rvT; + end Tsk1; + + task type Tsk2 (pS : not null access procedure) is + entry rvT; + end Tsk2; + + task body Tsk2 is + tskT : Tsk1; + begin + accept rvT do + requeue tskT.rvT; + end rvT; + pS.all; + end; + + Obj : Tsk2 (P'access); +begin + Obj.rvT; +end; diff --git a/gcc/testsuite/gnat.dg/discr_test2.adb b/gcc/testsuite/gnat.dg/discr_test2.adb new file mode 100644 index 000000000..89f46782a --- /dev/null +++ b/gcc/testsuite/gnat.dg/discr_test2.adb @@ -0,0 +1,18 @@ +-- { dg-do compile } + +procedure Discr_Test2 is + type Ptr is access all integer; + type Ar is array (Integer range <>) of Ptr; + + type Inner (Discr : Integer) is record + Comp : Ar (1..Discr); + end record; + + type Wrapper (Discr : Integer) is record + Comp : Inner (Discr); + end record; + + Val : constant Wrapper := (0, Comp => <>); +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/dispatch1.adb b/gcc/testsuite/gnat.dg/dispatch1.adb new file mode 100644 index 000000000..28e97e6e7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/dispatch1.adb @@ -0,0 +1,9 @@ +-- { dg-do run } + +with dispatch1_p; use dispatch1_p; +procedure dispatch1 is + O : DT_I1; + Ptr : access I1'Class; +begin + Ptr := new I1'Class'(I1'Class (O)); +end; diff --git a/gcc/testsuite/gnat.dg/dispatch1_p.ads b/gcc/testsuite/gnat.dg/dispatch1_p.ads new file mode 100644 index 000000000..73de62751 --- /dev/null +++ b/gcc/testsuite/gnat.dg/dispatch1_p.ads @@ -0,0 +1,4 @@ +package dispatch1_p is + type I1 is interface; + type DT_I1 is new I1 with null record; +end; diff --git a/gcc/testsuite/gnat.dg/dispatch2.adb b/gcc/testsuite/gnat.dg/dispatch2.adb new file mode 100644 index 000000000..ed57b1335 --- /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 000000000..243c3ca97 --- /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 000000000..e7852b446 --- /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/div_no_warning.adb b/gcc/testsuite/gnat.dg/div_no_warning.adb new file mode 100644 index 000000000..5b652638c --- /dev/null +++ b/gcc/testsuite/gnat.dg/div_no_warning.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } + +procedure div_no_warning is + Flag : constant Boolean := False; + Var : Boolean := True; + function F return Boolean is + begin + return Var; + end F; + Int : Integer := 0; +begin + if Flag and then F then + Int := Int / 0; + end if; +end div_no_warning; diff --git a/gcc/testsuite/gnat.dg/dse_step.adb b/gcc/testsuite/gnat.dg/dse_step.adb new file mode 100644 index 000000000..040bcb7d2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/dse_step.adb @@ -0,0 +1,18 @@ +package body Dse_Step is + + procedure Do_Step (This : in out Counter) is + begin + This.Value := This.Value + This.Step; + end; + + procedure Step_From (Start : in My_Counter) is + Lc : My_Counter := Start; + begin + while Nsteps > 0 loop + Do_Step (Lc); + Nsteps := Nsteps - 1; + end loop; + Mv := Lc.Value; + end; + +end; diff --git a/gcc/testsuite/gnat.dg/dse_step.ads b/gcc/testsuite/gnat.dg/dse_step.ads new file mode 100644 index 000000000..8cf0c74ea --- /dev/null +++ b/gcc/testsuite/gnat.dg/dse_step.ads @@ -0,0 +1,19 @@ +package Dse_Step is + + type Counter is record + Value : Natural; + Step : Natural; + end record; + pragma Suppress_Initialization (Counter); + + procedure Do_Step (This : in out Counter); + pragma Inline (Do_Step); + + type My_Counter is new Counter; + pragma Suppress_Initialization (My_Counter); + + procedure Step_From (Start : in My_Counter); + + Nsteps : Natural := 12; + Mv : Natural; +end; diff --git a/gcc/testsuite/gnat.dg/dynamic_bound.adb b/gcc/testsuite/gnat.dg/dynamic_bound.adb new file mode 100644 index 000000000..99720cdfa --- /dev/null +++ b/gcc/testsuite/gnat.dg/dynamic_bound.adb @@ -0,0 +1,34 @@ +-- { dg-do compile } +-- { dg-options "-gnato" } + +procedure Dynamic_Bound is + + procedure Define (Count : Integer) is + + type Count_T is new Integer range 0 .. Count * 1000; + + type Obj_T is record + Count : Count_T; + end record; + + type T is access Obj_T ; + + procedure Create (S : in out T) is + begin + S := new Obj_T'(Count => 0); + end; + + procedure Add (To : in out T) is + begin + To.Count := To.Count + 1; + end; + + My_T : T; + + begin + Create (My_T); + end; + +begin + Define (1); +end; diff --git a/gcc/testsuite/gnat.dg/dynamic_elab1.adb b/gcc/testsuite/gnat.dg/dynamic_elab1.adb new file mode 100644 index 000000000..88f76688c --- /dev/null +++ b/gcc/testsuite/gnat.dg/dynamic_elab1.adb @@ -0,0 +1,20 @@ +-- { dg-do compile } +-- { dg-options "-gnatE" } + +package body Dynamic_Elab1 is + + function Get_Plot return Plot is + + procedure Fill (X : out Plot) is + begin + X.Data := Get_R; + end; + + X : Plot; + + begin + Fill(X); + return X; + end; + +end Dynamic_Elab1; diff --git a/gcc/testsuite/gnat.dg/dynamic_elab1.ads b/gcc/testsuite/gnat.dg/dynamic_elab1.ads new file mode 100644 index 000000000..c241e54cc --- /dev/null +++ b/gcc/testsuite/gnat.dg/dynamic_elab1.ads @@ -0,0 +1,12 @@ +with Dynamic_Elab_Pkg; use Dynamic_Elab_Pkg; + +package Dynamic_Elab1 is + + type Plot is record + Data : R; + end record; + pragma Pack (Plot); + + function Get_Plot return Plot; + +end Dynamic_Elab1; diff --git a/gcc/testsuite/gnat.dg/dynamic_elab2.adb b/gcc/testsuite/gnat.dg/dynamic_elab2.adb new file mode 100644 index 000000000..138d130c7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/dynamic_elab2.adb @@ -0,0 +1,20 @@ +-- { dg-do compile } +-- { dg-options "-gnatE" } + +package body Dynamic_Elab2 is + + function Get_Plot return Plot is + + procedure Fill (X : out Plot) is + begin + X.Data := Get_R; + end; + + X : Plot; + + begin + Fill(X); + return X; + end; + +end Dynamic_Elab2; diff --git a/gcc/testsuite/gnat.dg/dynamic_elab2.ads b/gcc/testsuite/gnat.dg/dynamic_elab2.ads new file mode 100644 index 000000000..9191dabd5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/dynamic_elab2.ads @@ -0,0 +1,13 @@ +with Dynamic_Elab_Pkg; use Dynamic_Elab_Pkg; + +package Dynamic_Elab2 is + + type Plot is record + B : Boolean; + Data : R; + end record; + pragma Pack (Plot); + + function Get_Plot return Plot; + +end Dynamic_Elab2; diff --git a/gcc/testsuite/gnat.dg/dynamic_elab_pkg.ads b/gcc/testsuite/gnat.dg/dynamic_elab_pkg.ads new file mode 100644 index 000000000..2e2574f34 --- /dev/null +++ b/gcc/testsuite/gnat.dg/dynamic_elab_pkg.ads @@ -0,0 +1,10 @@ +package Dynamic_Elab_Pkg is + + type R is record + Code : Integer; + Val : Boolean; + end record; + + function Get_R return R; + +end Dynamic_Elab_Pkg; diff --git a/gcc/testsuite/gnat.dg/elab1.ads b/gcc/testsuite/gnat.dg/elab1.ads new file mode 100644 index 000000000..2d656ea7f --- /dev/null +++ b/gcc/testsuite/gnat.dg/elab1.ads @@ -0,0 +1,23 @@ +package elab1 is + + -- the forward declaration is the trigger + type Stream; + + type Stream_Ptr is access Stream; + + type Stream is array (Positive range <>) of Character; + + function Get_Size (S : Stream_Ptr) return Natural; + + type Rec (Size : Natural) is + record + B : Boolean; + end record; + + My_Desc : constant Stream_Ptr := new Stream'(1 => ' '); + + My_Size : constant Natural := Get_Size (My_Desc); + + subtype My_Rec is Rec (My_Size); + +end; diff --git a/gcc/testsuite/gnat.dg/elab2.adb b/gcc/testsuite/gnat.dg/elab2.adb new file mode 100644 index 000000000..3379a4172 --- /dev/null +++ b/gcc/testsuite/gnat.dg/elab2.adb @@ -0,0 +1,10 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +with elab1; + +procedure elab2 is + A : elab1.My_Rec; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/elim1.adb b/gcc/testsuite/gnat.dg/elim1.adb new file mode 100644 index 000000000..7d2ddd193 --- /dev/null +++ b/gcc/testsuite/gnat.dg/elim1.adb @@ -0,0 +1,6 @@ +package body elim1 is + procedure d (a : t) is + begin + null; + end; +end; diff --git a/gcc/testsuite/gnat.dg/elim1.ads b/gcc/testsuite/gnat.dg/elim1.ads new file mode 100644 index 000000000..7a7bd3588 --- /dev/null +++ b/gcc/testsuite/gnat.dg/elim1.ads @@ -0,0 +1,5 @@ +pragma Eliminate (p, d); +package elim1 is + type t is tagged null record; + procedure d (a : t); +end; diff --git a/gcc/testsuite/gnat.dg/elim2.adb b/gcc/testsuite/gnat.dg/elim2.adb new file mode 100644 index 000000000..a816f0890 --- /dev/null +++ b/gcc/testsuite/gnat.dg/elim2.adb @@ -0,0 +1,7 @@ +-- { dg-do run } + +with elim1; +procedure elim2 is +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/empty_vector_length.adb b/gcc/testsuite/gnat.dg/empty_vector_length.adb new file mode 100644 index 000000000..256a254e2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/empty_vector_length.adb @@ -0,0 +1,19 @@ +-- { dg-do run } +-- { dg-options "-gnatp" } + +procedure Empty_Vector_Length is + + type Vector is array (Integer range <>) of Integer; + + function Empty_Vector return Vector is + begin + return (2 .. Integer'First => 0); + end; + + My_Vector : Vector := Empty_Vector; + My_Length : Integer := My_Vector'Length; +begin + if My_Length /= 0 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/enclosing_record_reference.adb b/gcc/testsuite/gnat.dg/enclosing_record_reference.adb new file mode 100644 index 000000000..69c85bcc6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/enclosing_record_reference.adb @@ -0,0 +1,24 @@ +-- { dg-do compile } +package body Enclosing_Record_Reference is + + R: aliased T; + + function F1 (x: integer) return T is begin return R; end; + function F2 (x: T) return integer is begin return 0; end; + function F3 (x: T) return T is begin return R; end; + function F4 (x: integer) return access T is begin return R'access; end; + function F5 (x: access T) return integer is begin return 0; end; + function F6 (x: access T) return access T is begin return R'access; end; + function F7 (x: T) return access T is begin return R'access; end; + function F8 (x: access T) return T is begin return R; end; + +begin + R.F1 := F1'Access; + R.F2 := F2'Access; + R.F3 := F3'Access; + R.F4 := F4'Access; + R.F5 := F5'Access; + R.F6 := F6'Access; + R.F7 := F7'Access; + R.F8 := F8'Access; +end Enclosing_Record_Reference; diff --git a/gcc/testsuite/gnat.dg/enclosing_record_reference.ads b/gcc/testsuite/gnat.dg/enclosing_record_reference.ads new file mode 100644 index 000000000..6573b1d54 --- /dev/null +++ b/gcc/testsuite/gnat.dg/enclosing_record_reference.ads @@ -0,0 +1,15 @@ +package Enclosing_Record_Reference is + pragma elaborate_body; + + type T is record + F1: access function(x: integer) return T; + F2: access function(x: T) return integer; --?? + F3: access function(x: T) return T; --?? + F4: access function(x: integer) return access T; --?? + F5: access function(x: access T) return integer; + F6: access function(x: access T) return access T; + F7: access function(x: T) return access T; --?? + F8: access function(x: access T) return T; + end record; + +end Enclosing_Record_Reference; diff --git a/gcc/testsuite/gnat.dg/entry_queues.adb b/gcc/testsuite/gnat.dg/entry_queues.adb new file mode 100644 index 000000000..5740cebb5 --- /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/enum1.adb b/gcc/testsuite/gnat.dg/enum1.adb new file mode 100644 index 000000000..f751d24a7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/enum1.adb @@ -0,0 +1,17 @@ +-- { dg-do run } +-- { dg-options "-O2" } + +with Enum1_Pkg; use Enum1_Pkg; + +procedure Enum1 is + + function Cond return Boolean is + begin + return My_N = Two or My_N = Three; + end; + +begin + if Cond then + raise Constraint_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/enum1_pkg.ads b/gcc/testsuite/gnat.dg/enum1_pkg.ads new file mode 100644 index 000000000..ff090869c --- /dev/null +++ b/gcc/testsuite/gnat.dg/enum1_pkg.ads @@ -0,0 +1,9 @@ +package Enum1_Pkg is + + type Enum is (One, Two, Three); + + subtype Sub_Enum is Enum; + + My_N : Sub_Enum := One; + +end Enum1_Pkg; diff --git a/gcc/testsuite/gnat.dg/enum2.adb b/gcc/testsuite/gnat.dg/enum2.adb new file mode 100644 index 000000000..e98252a19 --- /dev/null +++ b/gcc/testsuite/gnat.dg/enum2.adb @@ -0,0 +1,11 @@ +-- { dg-do run } +-- { dg-options "-gnat05 -O2" } + +with Enum2_Pkg; use Enum2_Pkg; + +procedure Enum2 is + type Enum is (A, B, C, D); + Table : array (B .. C, 1 .. 1) of F_String := (others => (others => Null_String)); +begin + Table := (others => (others => Null_String)); +end; diff --git a/gcc/testsuite/gnat.dg/enum2_pkg.ads b/gcc/testsuite/gnat.dg/enum2_pkg.ads new file mode 100644 index 000000000..20112d23c --- /dev/null +++ b/gcc/testsuite/gnat.dg/enum2_pkg.ads @@ -0,0 +1,8 @@ +with Ada.Finalization; use Ada.Finalization; + +package Enum2_Pkg is + type F_String is new Controlled with record + Data : access String; + end record; + Null_String : constant F_String := (Controlled with Data => null); +end Enum2_Pkg; diff --git a/gcc/testsuite/gnat.dg/env_compile_capacity.adb b/gcc/testsuite/gnat.dg/env_compile_capacity.adb new file mode 100644 index 000000000..03d208633 --- /dev/null +++ b/gcc/testsuite/gnat.dg/env_compile_capacity.adb @@ -0,0 +1,24 @@ +-- { dg-do compile } + +with My_Env_Versioned_Value_Set_G; +package body Env_Compile_Capacity is + generic + with package Env_Obj_Set_Instance is + new My_Env_Versioned_Value_Set_G(<>); + with function Updated_Entity (Value : Env_Obj_Set_Instance.Value_T) + return Boolean is <>; + with package Entity_Upd_Iteration is + new Env_Obj_Set_Instance.Update_G (Updated_Entity); + procedure Compile_G; + procedure Compile_G is begin null; end; + package My_Env_Aerodrome is + new My_Env_Versioned_Value_Set_G (Value_T => String); + function Updated_Entity (Id : in String) return Boolean is + begin return True; end; + package Iteration_Aerodrome_Arrival is + new My_Env_Aerodrome.Update_G (Updated_Entity); + procedure Aerodrome_Arrival is new Compile_G + (Env_Obj_Set_Instance => My_Env_Aerodrome, + Updated_Entity => Updated_Entity, + Entity_Upd_Iteration => Iteration_Aerodrome_Arrival); +end Env_Compile_Capacity; diff --git a/gcc/testsuite/gnat.dg/env_compile_capacity.ads b/gcc/testsuite/gnat.dg/env_compile_capacity.ads new file mode 100644 index 000000000..da6103426 --- /dev/null +++ b/gcc/testsuite/gnat.dg/env_compile_capacity.ads @@ -0,0 +1 @@ +package Env_Compile_Capacity is pragma Elaborate_Body; end; diff --git a/gcc/testsuite/gnat.dg/equal1.ads b/gcc/testsuite/gnat.dg/equal1.ads new file mode 100644 index 000000000..0b6ed7261 --- /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/equal_access.adb b/gcc/testsuite/gnat.dg/equal_access.adb new file mode 100644 index 000000000..699c4daf3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/equal_access.adb @@ -0,0 +1,9 @@ +-- { dg-do compile } + +procedure equal_access is + PA, PB : access procedure := null; +begin + if PA /= PB then + null; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/exp0_eval.adb b/gcc/testsuite/gnat.dg/exp0_eval.adb new file mode 100644 index 000000000..11edd7d09 --- /dev/null +++ b/gcc/testsuite/gnat.dg/exp0_eval.adb @@ -0,0 +1,31 @@ +-- { dg-do run } +with Interfaces; use Interfaces; +procedure Exp0_Eval is + + F_Count : Natural := 0; + + function F return Integer is + begin + F_Count := F_Count + 1; + return 1; + end F; + + function F return Unsigned_32 is + begin + F_Count := F_Count + 1; + return 1; + end F; + + R : constant Integer := + F ** 0 + + F * 0 + + 0 * F + + Integer (Unsigned_32'(F) mod 1) + + Integer (Unsigned_32'(F) rem 1); + pragma Warnings (Off, R); +begin + if F_Count /= 5 then + raise Program_Error + with "incorrect numbers of calls to F:" & F_Count'Img; + end if; +end Exp0_Eval; diff --git a/gcc/testsuite/gnat.dg/expect1.adb b/gcc/testsuite/gnat.dg/expect1.adb new file mode 100644 index 000000000..058fe42c9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/expect1.adb @@ -0,0 +1,15 @@ +-- { dg-do run } + +with GNAT.Expect; use GNAT.Expect; +with Ada.Text_IO; use Ada.Text_IO; +procedure expect1 is + Process : Process_Descriptor; +begin + begin + Close (Process); + raise Program_Error; + exception + when Invalid_Process => + null; -- expected + end; +end expect1; diff --git a/gcc/testsuite/gnat.dg/ext1.ads b/gcc/testsuite/gnat.dg/ext1.ads new file mode 100644 index 000000000..db58e284a --- /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/fatp_sra.adb b/gcc/testsuite/gnat.dg/fatp_sra.adb new file mode 100644 index 000000000..a964737d1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/fatp_sra.adb @@ -0,0 +1,17 @@ +-- { dg-do compile } +-- { dg-options "-gnatp -O1" } + +procedure Fatp_Sra is + + function X return String is + begin + return "X"; + end; + + function Letter return String is + begin + return X; + end; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/finalized.adb b/gcc/testsuite/gnat.dg/finalized.adb new file mode 100644 index 000000000..36400d53e --- /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/fixce.adb b/gcc/testsuite/gnat.dg/fixce.adb new file mode 100644 index 000000000..91e02e793 --- /dev/null +++ b/gcc/testsuite/gnat.dg/fixce.adb @@ -0,0 +1,13 @@ +-- { dg-do run } + +procedure fixce is + type D is delta 128.0 / (2 ** 15) range 0.0 .. 256.0; + type R is range 0 .. 200; + dd : D; + RA : constant array (1 .. 3) of R := (127, 128, 200); +begin + dd := D (RA (2)); + for i in RA'range loop + dd := D (RA (i)); + end loop; +end fixce; diff --git a/gcc/testsuite/gnat.dg/fixedpnt.adb b/gcc/testsuite/gnat.dg/fixedpnt.adb new file mode 100644 index 000000000..2e9988c33 --- /dev/null +++ b/gcc/testsuite/gnat.dg/fixedpnt.adb @@ -0,0 +1,10 @@ +-- { dg-do run } + +procedure Fixedpnt is + A : Duration := 1.0; + B : Duration := Duration ((-1.0) * A); +begin + if B > 0.0 then + raise Constraint_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/forward_anon.adb b/gcc/testsuite/gnat.dg/forward_anon.adb new file mode 100644 index 000000000..bce495e22 --- /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 000000000..ff68ff400 --- /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/forward_vla.adb b/gcc/testsuite/gnat.dg/forward_vla.adb new file mode 100644 index 000000000..515112b83 --- /dev/null +++ b/gcc/testsuite/gnat.dg/forward_vla.adb @@ -0,0 +1,20 @@ +-- { dg-do compile } +-- { dg-options "-O2 -gnatp -Wuninitialized" } + +procedure Forward_Vla is + + function N return Natural is begin return 1; end; + + type Sequence; + type Sequence_Access is access all Sequence; + + Ptr : Sequence_Access := null; -- freeze access type + + Sequence_Length : Natural := N; + type Sequence is array (1 .. Sequence_Length) of Natural; + + Seq : Sequence; +begin + Seq (1) := 0; +end; + diff --git a/gcc/testsuite/gnat.dg/frame_overflow.adb b/gcc/testsuite/gnat.dg/frame_overflow.adb new file mode 100644 index 000000000..1e7405fa5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/frame_overflow.adb @@ -0,0 +1,25 @@ +-- { dg-do compile } + +package body Frame_Overflow is + + function -- { dg-error "too large" } + Set_In (Bitmap : Bitmap_T; Bitpos : Bitpos_Range_T) return Bitmap_T + is + Result: Bitmap_T := Bitmap; + begin + Result.Bits (Bitpos) := True; + return Result; + end; + + function -- { dg-error "too large" } + Negate (Bitmap : Bitmap_T) return Bitmap_T + is + Result: Bitmap_T; + begin + for E in Bitpos_Range_T loop + Result.Bits (E) := not Bitmap.Bits (E); + end loop; + return Result; + end; + +end Frame_Overflow; diff --git a/gcc/testsuite/gnat.dg/frame_overflow.ads b/gcc/testsuite/gnat.dg/frame_overflow.ads new file mode 100644 index 000000000..898e37a67 --- /dev/null +++ b/gcc/testsuite/gnat.dg/frame_overflow.ads @@ -0,0 +1,17 @@ +with System; + +package Frame_Overflow is + + type Bitpos_Range_T is range 1..2**(System.Word_Size-1)-1; + type Bitmap_Array_T is array (Bitpos_Range_T) of Boolean; + + type Bitmap_T is record + Bits : Bitmap_Array_T := (others => False); + end record; + + function + Set_In (Bitmap : Bitmap_T; Bitpos : Bitpos_Range_T) return Bitmap_T; + + function Negate (Bitmap : Bitmap_T) return Bitmap_T; + +end Frame_Overflow; diff --git a/gcc/testsuite/gnat.dg/frunaligned.adb b/gcc/testsuite/gnat.dg/frunaligned.adb new file mode 100644 index 000000000..a57e87227 --- /dev/null +++ b/gcc/testsuite/gnat.dg/frunaligned.adb @@ -0,0 +1,8 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } +with FRUnaligned1; use FRUnaligned1; +function FRUnaligned return r is + ss : s; +begin + return ss.y; +end; diff --git a/gcc/testsuite/gnat.dg/frunaligned1.ads b/gcc/testsuite/gnat.dg/frunaligned1.ads new file mode 100644 index 000000000..4a8db361b --- /dev/null +++ b/gcc/testsuite/gnat.dg/frunaligned1.ads @@ -0,0 +1,12 @@ +package FRUnaligned1 is + type r is array (1 .. 72) of Boolean; + pragma Pack (r); + type s is record + x : Boolean; + y : r; + end record; + for s use record + x at 0 range 0 .. 0; + y at 0 range 1 .. 72; + end record; +end FRUnaligned1; diff --git a/gcc/testsuite/gnat.dg/g_tables.adb b/gcc/testsuite/gnat.dg/g_tables.adb new file mode 100644 index 000000000..bdad37850 --- /dev/null +++ b/gcc/testsuite/gnat.dg/g_tables.adb @@ -0,0 +1,8 @@ +-- { dg-options "-gnatws" } + +package body G_Tables is + function Create (L : Natural) return Table is + begin + return T : Table (1 .. L); + end Create; +end G_Tables; diff --git a/gcc/testsuite/gnat.dg/g_tables.ads b/gcc/testsuite/gnat.dg/g_tables.ads new file mode 100644 index 000000000..34126882a --- /dev/null +++ b/gcc/testsuite/gnat.dg/g_tables.ads @@ -0,0 +1,9 @@ +generic + type Component is private; +package G_Tables is + type Table (<>) is limited private; + + function Create (L : Natural) return Table; +private + type Table is array (Positive range <>) of Component; +end G_Tables; diff --git a/gcc/testsuite/gnat.dg/gen_disp.adb b/gcc/testsuite/gnat.dg/gen_disp.adb new file mode 100644 index 000000000..736b9cdc0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/gen_disp.adb @@ -0,0 +1,45 @@ +-- { dg-do compile } +with Ada.Containers.Ordered_Maps; +with Ada.Tags.Generic_Dispatching_Constructor; +package body gen_disp is + + use type Ada.Tags.Tag; + + function "<" (L, R : in Ada.Tags.Tag) return Boolean is + begin + return Ada.Tags.External_Tag (L) < Ada.Tags.External_Tag (R); + end "<"; + + package Char_To_Tag_Map is new Ada.Containers.Ordered_Maps ( + Key_Type => Character, + Element_Type => Ada.Tags.Tag, + "<" => "<", + "=" => Ada.Tags. "="); + + package Tag_To_Char_Map is new Ada.Containers.Ordered_Maps ( + Key_Type => Ada.Tags.Tag, + Element_Type => Character, + "<" => "<", + "=" => "="); + + use type Char_To_Tag_Map.Cursor; + use type Tag_To_Char_Map.Cursor; + + Char_To_Tag : Char_To_Tag_Map.Map; + Tag_To_Char : Tag_To_Char_Map.Map; + + function Get_Object is new + Ada.Tags.Generic_Dispatching_Constructor + (Root_Type, Ada.Streams.Root_Stream_Type'Class, Root_Type'Input); + + function Root_Type_Class_Input + (S : not null access Ada.Streams.Root_Stream_Type'Class) + return Root_Type'Class + is + External_Tag : constant Character := Character'Input (S); + C : constant Char_To_Tag_Map.Cursor := Char_To_Tag.Find (External_Tag); + begin + + return Get_Object (Char_To_Tag_Map.Element (C), S); + end Root_Type_Class_Input; +end gen_disp; diff --git a/gcc/testsuite/gnat.dg/gen_disp.ads b/gcc/testsuite/gnat.dg/gen_disp.ads new file mode 100644 index 000000000..722c0c1b1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/gen_disp.ads @@ -0,0 +1,10 @@ +with Ada.Streams, Ada.Tags; +package gen_disp is + type Root_Type is tagged null record; + + function Root_Type_Class_Input + (S : not null access Ada.Streams.Root_Stream_Type'Class) + return Root_Type'Class; + + for Root_Type'Class'Input use Root_Type_Class_Input; +end gen_disp; diff --git a/gcc/testsuite/gnat.dg/generic_dispatch.adb b/gcc/testsuite/gnat.dg/generic_dispatch.adb new file mode 100644 index 000000000..a22e495f4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/generic_dispatch.adb @@ -0,0 +1,9 @@ +-- { dg-do run } + +with generic_dispatch_p; use generic_dispatch_p; +procedure generic_dispatch is + I : aliased Integer := 0; + D : Iface'Class := Dispatching_Constructor (DT'Tag, I'access); +begin + null; +end generic_dispatch; diff --git a/gcc/testsuite/gnat.dg/generic_dispatch_p.adb b/gcc/testsuite/gnat.dg/generic_dispatch_p.adb new file mode 100644 index 000000000..7a4bbbd8a --- /dev/null +++ b/gcc/testsuite/gnat.dg/generic_dispatch_p.adb @@ -0,0 +1,7 @@ +package body generic_dispatch_p is + function Constructor (I : not null access Integer) return DT is + R : DT; + begin + return R; + end Constructor; +end; diff --git a/gcc/testsuite/gnat.dg/generic_dispatch_p.ads b/gcc/testsuite/gnat.dg/generic_dispatch_p.ads new file mode 100644 index 000000000..fe6115dd9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/generic_dispatch_p.ads @@ -0,0 +1,13 @@ +with Ada.Tags.Generic_Dispatching_Constructor; +package generic_dispatch_p is + type Iface is interface; + function Constructor (I : not null access Integer) return Iface is abstract; + function Dispatching_Constructor + is new Ada.Tags.Generic_Dispatching_Constructor + (T => Iface, + Parameters => Integer, + Constructor => Constructor); + type DT is new Iface with null record; + overriding + function Constructor (I : not null access Integer) return DT; +end; diff --git a/gcc/testsuite/gnat.dg/gnat_malloc.adb b/gcc/testsuite/gnat.dg/gnat_malloc.adb new file mode 100644 index 000000000..7e8d6140b --- /dev/null +++ b/gcc/testsuite/gnat.dg/gnat_malloc.adb @@ -0,0 +1,25 @@ +-- { dg-do run } +-- { dg-options "-O2" } + +with Unchecked_Conversion; + +procedure gnat_malloc is + + type int1 is new integer; + type int2 is new integer; + type a1 is access int1; + type a2 is access int2; + + function to_a2 is new Unchecked_Conversion (a1, a2); + + v1 : a1 := new int1; + v2 : a2 := to_a2 (v1); + +begin + v1.all := 1; + v2.all := 0; + + if v1.all /= 0 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/gnatg.adb b/gcc/testsuite/gnat.dg/gnatg.adb new file mode 100644 index 000000000..4f09cb654 --- /dev/null +++ b/gcc/testsuite/gnat.dg/gnatg.adb @@ -0,0 +1,13 @@ +-- { dg-do compile } +-- { dg-options "-gnatD" } + +with System; +with Ada.Unchecked_Conversion; +procedure gnatg is + subtype Address is System.Address; + type T is access procedure; + function Cvt is new Ada.Unchecked_Conversion (Address, T); + X : T; +begin + X := Cvt (Gnatg'Address); +end gnatg; diff --git a/gcc/testsuite/gnat.dg/graphic.adb b/gcc/testsuite/gnat.dg/graphic.adb new file mode 100644 index 000000000..282f46ddd --- /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 000000000..a1153de64 --- /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/handle_and_return.adb b/gcc/testsuite/gnat.dg/handle_and_return.adb new file mode 100644 index 000000000..b40dbafb3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/handle_and_return.adb @@ -0,0 +1,21 @@ +-- { dg-do run } +-- { dg-options "-gnatp -O2" } + +with Raise_Ce; + +procedure Handle_And_Return is +begin + begin + Raise_CE; + return; + exception + when others => null; + end; + + begin + Raise_CE; + return; + exception + when others => null; + end; +end; diff --git a/gcc/testsuite/gnat.dg/handle_raise_from_pure.adb b/gcc/testsuite/gnat.dg/handle_raise_from_pure.adb new file mode 100644 index 000000000..0248d350d --- /dev/null +++ b/gcc/testsuite/gnat.dg/handle_raise_from_pure.adb @@ -0,0 +1,11 @@ +-- { dg-do run } +-- { dg-options "-O2" } +with Ada.Text_Io; use Ada.Text_IO; +with Raise_From_Pure; use Raise_From_Pure; +procedure handle_raise_from_pure is + K : Integer; +begin + K := Raise_CE_If_0 (0); +exception + when others => Put_Line ("exception caught"); +end; diff --git a/gcc/testsuite/gnat.dg/hyper_flat.adb b/gcc/testsuite/gnat.dg/hyper_flat.adb new file mode 100644 index 000000000..6842edbf5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/hyper_flat.adb @@ -0,0 +1,17 @@ +-- { dg-do run } +-- { dg-options "-gnatp" } + +procedure Hyper_Flat is + + type Unsigned is mod 2 ** 32; + x : Integer := 0; + pragma Volatile (X); + + S : constant String := (1 .. X - 3 => 'A'); + -- Hyper-flat null string + +begin + if Unsigned'(S'Length) /= 0 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/ice_type.adb b/gcc/testsuite/gnat.dg/ice_type.adb new file mode 100644 index 000000000..cac09fc30 --- /dev/null +++ b/gcc/testsuite/gnat.dg/ice_type.adb @@ -0,0 +1,9 @@ +-- { dg-do compile } + +with ICE_Types; use ICE_Types; +procedure ICE_Type is + type Local_Float_T is new Float_View_T; + LF : Local_Float_T; +begin + Initialize (Float_View_T (LF)); +end; diff --git a/gcc/testsuite/gnat.dg/ice_types.ads b/gcc/testsuite/gnat.dg/ice_types.ads new file mode 100644 index 000000000..522bd55a2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/ice_types.ads @@ -0,0 +1,6 @@ +package ICE_Types is + type Float_View_T is private; + procedure Initialize (X : out Float_View_T); +private + type Float_View_T is new Float; +end; diff --git a/gcc/testsuite/gnat.dg/iface1.ads b/gcc/testsuite/gnat.dg/iface1.ads new file mode 100644 index 000000000..bfe90a303 --- /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 000000000..c56559952 --- /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 000000000..d25bc4246 --- /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/iface_test.adb b/gcc/testsuite/gnat.dg/iface_test.adb new file mode 100644 index 000000000..b47814f85 --- /dev/null +++ b/gcc/testsuite/gnat.dg/iface_test.adb @@ -0,0 +1,28 @@ +-- { dg-do compile } +package body Iface_Test is + protected SQLite_Safe is + function Prepare_Select + (DB : DT_1; + Iter : Standard.Iface_Test.Iface_2'Class) + return Standard.Iface_Test.Iface_2'Class; + end; + + overriding procedure Prepare_Select + (DB : DT_1; + Iter : in out Standard.Iface_Test.Iface_2'Class) + is + begin + Iter := SQLite_Safe.Prepare_Select (DB, Iter); -- test + end; + + protected body SQLite_Safe is + function Prepare_Select + (DB : DT_1; + Iter : Standard.Iface_Test.Iface_2'Class) + return Standard.Iface_Test.Iface_2'Class + is + begin + return Iter; + end; + end; +end; diff --git a/gcc/testsuite/gnat.dg/iface_test.ads b/gcc/testsuite/gnat.dg/iface_test.ads new file mode 100644 index 000000000..d093c2822 --- /dev/null +++ b/gcc/testsuite/gnat.dg/iface_test.ads @@ -0,0 +1,18 @@ +package Iface_Test is + type Iface_1 is interface; + type Iface_2 is interface; + + procedure Prepare_Select + (DB : Iface_1; + Iter : in out Iface_2'Class) is abstract; + + type DT_1 is new Iface_1 with null record; + + type Iterator is new Iface_2 with record + More : Boolean; + end record; + + overriding procedure Prepare_Select + (DB : DT_1; + Iter : in out Standard.Iface_Test.Iface_2'Class); +end; diff --git a/gcc/testsuite/gnat.dg/ifaces.adb b/gcc/testsuite/gnat.dg/ifaces.adb new file mode 100644 index 000000000..225137997 --- /dev/null +++ b/gcc/testsuite/gnat.dg/ifaces.adb @@ -0,0 +1,5 @@ +with Text_IO; use Text_IO; +package body Ifaces is + procedure op1 (this : Root) is begin null; end; + procedure op2 (this : DT) is begin null; end; +end; diff --git a/gcc/testsuite/gnat.dg/ifaces.ads b/gcc/testsuite/gnat.dg/ifaces.ads new file mode 100644 index 000000000..598c0a931 --- /dev/null +++ b/gcc/testsuite/gnat.dg/ifaces.ads @@ -0,0 +1,17 @@ + +package Ifaces is + type Iface_1 is interface; + procedure op1(this : Iface_1) is abstract; +-- + type Iface_2 is interface; + procedure op2 (this : Iface_2) is abstract; +-- + type Root is new Iface_1 with record + m_name : String(1..4); + end record; +-- + procedure op1 (this : Root); +-- + type DT is new Root and Iface_2 with null record; + procedure op2 (this : DT); +end; diff --git a/gcc/testsuite/gnat.dg/import1.adb b/gcc/testsuite/gnat.dg/import1.adb new file mode 100644 index 000000000..4e4056098 --- /dev/null +++ b/gcc/testsuite/gnat.dg/import1.adb @@ -0,0 +1,17 @@ +-- { dg-do compile }
+-- { dg-options "-g" }
+
+package body Import1 is
+
+ procedure Create (Bounds : Arr) is
+ type Bound_Array is array (Bounds'Range) of Integer;
+
+ procedure Proc (Ptr : access Bound_Array);
+ pragma Import (C, Proc);
+
+ Temp : aliased Bound_Array;
+ begin
+ Proc (Temp'Access);
+ end;
+
+end Import1;
diff --git a/gcc/testsuite/gnat.dg/import1.ads b/gcc/testsuite/gnat.dg/import1.ads new file mode 100644 index 000000000..cb00a0caf --- /dev/null +++ b/gcc/testsuite/gnat.dg/import1.ads @@ -0,0 +1,7 @@ +package Import1 is
+
+ type Arr is array (Positive range <>) of Integer;
+
+ procedure Create (Bounds : Arr);
+
+end Import1;
diff --git a/gcc/testsuite/gnat.dg/in_mod_conv.adb b/gcc/testsuite/gnat.dg/in_mod_conv.adb new file mode 100644 index 000000000..5ff080825 --- /dev/null +++ b/gcc/testsuite/gnat.dg/in_mod_conv.adb @@ -0,0 +1,24 @@ +-- { dg-do compile } + +procedure in_mod_conv is + package Test is + type T is new Natural range 1..6; + subtype T_SubType is T range 3..5; + type A1 is array (T range <>) of boolean; + type A2 is new A1 (T_SubType); + PRAGMA pack (A2); + type New_A2 is new A2; + end Test; + package body Test is + procedure P1 (Obj : in New_A2) is + begin + null; + end P1; + procedure P2 (Data : in out A2) is + begin + P1 (New_A2 (Data (T_SubType))); -- test + end P2; + end Test; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/in_out_parameter.adb b/gcc/testsuite/gnat.dg/in_out_parameter.adb new file mode 100644 index 000000000..c936ec1e7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/in_out_parameter.adb @@ -0,0 +1,38 @@ +-- { dg-do run } + +with Ada.Streams.Stream_IO; + +procedure In_Out_Parameter is + + use Ada.Streams; use Stream_IO; + + File : Stream_IO.File_Type; + + type Bitmap is array (Natural range <>) of Boolean; + for Bitmap'Component_Size use 1; + + type Message is record + B : Bitmap (0 .. 14); + end record; + for Message use record + B at 0 range 2 .. 16; + end record; + + TX, RX : Message; + +begin + + TX.B := (others => False); + Stream_IO.Create (File => File, Mode => Out_File, Name => "data"); + Message'Output (Stream (File), TX); + Stream_IO.Close (File); + -- + Stream_IO.Open (File => File, Mode => In_File, Name => "data"); + RX := Message'Input (Stream (File)); + Stream_IO.Close (File); + + if RX /= TX then + raise Program_Error; + end if; + +end In_Out_Parameter; diff --git a/gcc/testsuite/gnat.dg/in_out_parameter2.adb b/gcc/testsuite/gnat.dg/in_out_parameter2.adb new file mode 100644 index 000000000..1b5cc7e6a --- /dev/null +++ b/gcc/testsuite/gnat.dg/in_out_parameter2.adb @@ -0,0 +1,24 @@ +-- { dg-do run } +-- { dg-options "-gnat12" } + +procedure In_Out_Parameter2 is + + function F (I : In Out Integer) return Boolean is + A : Integer := I; + begin + I := I + 1; + return (A > 0); + end; + + I : Integer := 0; + B : Boolean; + +begin + B := F (I); + if B then + raise Program_Error; + end if; + if I /= 1 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/in_out_parameter3.adb b/gcc/testsuite/gnat.dg/in_out_parameter3.adb new file mode 100644 index 000000000..dab3f8d52 --- /dev/null +++ b/gcc/testsuite/gnat.dg/in_out_parameter3.adb @@ -0,0 +1,42 @@ +-- { dg-do run } +-- { dg-options "-gnat12" } + +procedure In_Out_Parameter3 is + + type Arr is array (1..16) of Integer; + + type Rec1 is record + A : Arr; + B : Boolean; + end record; + + type Rec2 is record + R : Rec1; + end record; + pragma Pack (Rec2); + + function F (I : In Out Rec1) return Boolean is + A : Integer := I.A (1); + begin + I.A (1) := I.A (1) + 1; + return (A > 0); + end; + + I : Rec2 := (R => (A => (others => 0), B => True)); + B : Boolean; + +begin + B := F (I.R); + if B then + raise Program_Error; + end if; + if I.R.A (1) /= 1 then + raise Program_Error; + end if; + if F (I.R) = False then + raise Program_Error; + end if; + if I.R.A (1) /= 2 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/include.adb b/gcc/testsuite/gnat.dg/include.adb new file mode 100644 index 000000000..ec183c723 --- /dev/null +++ b/gcc/testsuite/gnat.dg/include.adb @@ -0,0 +1,4 @@ +-- { dg-do compile } */ +-- { dg-options "-cargs -I -gnatws" } + +-- { dg-error "search directory missing" "" { target *-*-* } 0 } diff --git a/gcc/testsuite/gnat.dg/incomplete1.ads b/gcc/testsuite/gnat.dg/incomplete1.ads new file mode 100644 index 000000000..34900335d --- /dev/null +++ b/gcc/testsuite/gnat.dg/incomplete1.ads @@ -0,0 +1,3 @@ +package Incomplete1 is + type T is null record; +end Incomplete1; diff --git a/gcc/testsuite/gnat.dg/incomplete2.adb b/gcc/testsuite/gnat.dg/incomplete2.adb new file mode 100644 index 000000000..19c83609b --- /dev/null +++ b/gcc/testsuite/gnat.dg/incomplete2.adb @@ -0,0 +1,4 @@ +-- { dg-do compile } +-- { dg-excess-errors "instantiation abandoned" } +with Incomplete1; +package body Incomplete2 is end Incomplete2; diff --git a/gcc/testsuite/gnat.dg/incomplete2.ads b/gcc/testsuite/gnat.dg/incomplete2.ads new file mode 100644 index 000000000..21f2d2bb1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/incomplete2.ads @@ -0,0 +1,8 @@ +limited with Incomplete1; +package Incomplete2 is + pragma Elaborate_Body; + generic + type T is private; + package G is end G; + package I1 is new G (Incomplete1.T); -- { dg-error "premature use" } +end Incomplete2; diff --git a/gcc/testsuite/gnat.dg/init_scalar1.adb b/gcc/testsuite/gnat.dg/init_scalar1.adb new file mode 100644 index 000000000..2688e9298 --- /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/inline_scope.adb b/gcc/testsuite/gnat.dg/inline_scope.adb new file mode 100644 index 000000000..d83ce184f --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline_scope.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } +-- { dg-options "-gnatN" } + +with inline_scope_p; +procedure inline_scope (X : Integer) is + type A is array (Integer range 1 .. 2) of Boolean; + S : A; + pragma Warnings (Off, S); + procedure Report_List is + begin + inline_scope_p.Assert (S (1), Natural'Image (Natural (1))); + end Report_List; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/inline_scope_p.adb b/gcc/testsuite/gnat.dg/inline_scope_p.adb new file mode 100644 index 000000000..bbe47249c --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline_scope_p.adb @@ -0,0 +1,8 @@ +package body inline_scope_p is + procedure Assert (Expr : Boolean; Str : String) is + begin + if Expr then + null; + end if; + end Assert; +end; diff --git a/gcc/testsuite/gnat.dg/inline_scope_p.ads b/gcc/testsuite/gnat.dg/inline_scope_p.ads new file mode 100644 index 000000000..d05e3434e --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline_scope_p.ads @@ -0,0 +1,4 @@ +package inline_scope_p is + procedure Assert (Expr : Boolean; Str : String); + pragma Inline (Assert); +end; diff --git a/gcc/testsuite/gnat.dg/inline_tagged.adb b/gcc/testsuite/gnat.dg/inline_tagged.adb new file mode 100644 index 000000000..e0692884f --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline_tagged.adb @@ -0,0 +1,35 @@ +-- { dg-do run } +-- { dg-options "-gnatN" } + +with Text_IO; use Text_IO; +with system; use system; +procedure inline_tagged is + package Pkg is + type T_Inner is tagged record + Value : Integer; + end record; + type T_Inner_access is access all T_Inner; + procedure P2 (This : in T_Inner; Ptr : address); + pragma inline (P2); + type T_Outer is record + Inner : T_Inner_Access; + end record; + procedure P1 (This : access T_Outer); + end Pkg; + package body Pkg is + procedure P2 (This : in T_Inner; Ptr : address) is + begin + if this'address /= Ptr then + raise Program_Error; + end if; + end; + procedure P1 (This : access T_Outer) is + begin + P2 (This.Inner.all, This.Inner.all'Address); + end P1; + end Pkg; + use Pkg; + Thing : aliased T_Outer := (inner => new T_Inner); +begin + P1 (Thing'access); +end; diff --git a/gcc/testsuite/gnat.dg/interface1.adb b/gcc/testsuite/gnat.dg/interface1.adb new file mode 100644 index 000000000..b22b94959 --- /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 000000000..903d3308f --- /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/interface3.adb b/gcc/testsuite/gnat.dg/interface3.adb new file mode 100644 index 000000000..da38a1fb7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/interface3.adb @@ -0,0 +1,31 @@ +-- { dg-do run } + +procedure interface3 is +-- + package Pkg is + type Foo is interface; + subtype Element_Type is Foo'Class; +-- + type Element_Access is access Element_Type; + type Elements_Type is array (1 .. 1) of Element_Access; + type Elements_Access is access Elements_Type; +-- + type Vector is tagged record + Elements : Elements_Access; + end record; +-- + procedure Test (Obj : Vector); + end; +-- + package body Pkg is + procedure Test (Obj : Vector) is + Elements : Elements_Access := new Elements_Type; +-- + begin + Elements (1) := new Element_Type'(Obj.Elements (1).all); + end; + end; +-- +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/interface4.adb b/gcc/testsuite/gnat.dg/interface4.adb new file mode 100644 index 000000000..8dde602c3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/interface4.adb @@ -0,0 +1,13 @@ +-- { dg-do compile } + +procedure interface4 is + generic + type I1 is interface; + type I2 is limited interface; + type I3 is interface and I1; + type I4 is limited interface and I2; + package Pack_I is + end Pack_I; +begin + null; +end interface4; diff --git a/gcc/testsuite/gnat.dg/interface5.adb b/gcc/testsuite/gnat.dg/interface5.adb new file mode 100644 index 000000000..65d19a6cb --- /dev/null +++ b/gcc/testsuite/gnat.dg/interface5.adb @@ -0,0 +1,8 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } +package body interface5 is + function F (Object : Child) return access Child is + begin + return null; + end F; +end interface5; diff --git a/gcc/testsuite/gnat.dg/interface5.ads b/gcc/testsuite/gnat.dg/interface5.ads new file mode 100644 index 000000000..e1bd0bac2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/interface5.ads @@ -0,0 +1,9 @@ +package interface5 is + type B is tagged null record; + + type I is interface; + function F (Object : I) return access I is abstract; + + type Child is new B and I with null record; + function F (Object : Child) return access Child; +end interface5; diff --git a/gcc/testsuite/gnat.dg/interface_conv.adb b/gcc/testsuite/gnat.dg/interface_conv.adb new file mode 100644 index 000000000..503fb7eaa --- /dev/null +++ b/gcc/testsuite/gnat.dg/interface_conv.adb @@ -0,0 +1,17 @@ +-- { dg-do run } + +procedure Interface_Conv is + package Pkg is + type I1 is interface; + procedure Prim (X : I1) is null; + type I2 is interface; + procedure Prim (X : I2) is null; + type DT is new I1 and I2 with null record; + end Pkg; + use Pkg; + Obj : DT; + CW_3 : I2'Class := Obj; + CW_5 : I1'Class := I1'Class (CW_3); -- test +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/invariant_index.adb b/gcc/testsuite/gnat.dg/invariant_index.adb new file mode 100644 index 000000000..69ad47ac1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/invariant_index.adb @@ -0,0 +1,14 @@ +-- { dg-do compile } +-- { dg-options "-O -gnatp" } + +package body Invariant_Index is + + procedure Proc (S : String) is + N : constant Integer := S'Length; + begin + Name_Buffer (1 + N .. Name_Len + N) := Name_Buffer (1 .. Name_Len); + Name_Buffer (1 .. N) := S; + Name_Len := Name_Len + N; + end; + +end Invariant_Index; diff --git a/gcc/testsuite/gnat.dg/invariant_index.ads b/gcc/testsuite/gnat.dg/invariant_index.ads new file mode 100644 index 000000000..77c46fc39 --- /dev/null +++ b/gcc/testsuite/gnat.dg/invariant_index.ads @@ -0,0 +1,8 @@ +package Invariant_Index is + + Name_Buffer : String (1 .. 100); + Name_Len : Natural; + + procedure Proc (S : String); + +end Invariant_Index; diff --git a/gcc/testsuite/gnat.dg/iprot_test.adb b/gcc/testsuite/gnat.dg/iprot_test.adb new file mode 100644 index 000000000..17c202155 --- /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/itype.adb b/gcc/testsuite/gnat.dg/itype.adb new file mode 100644 index 000000000..848bda4b6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/itype.adb @@ -0,0 +1,8 @@ +package body itype is + function G return not null access constant T is + X : aliased T; + + begin + return X'Unchecked_Access; + end G; +end itype; diff --git a/gcc/testsuite/gnat.dg/itype.ads b/gcc/testsuite/gnat.dg/itype.ads new file mode 100644 index 000000000..3ffb7c695 --- /dev/null +++ b/gcc/testsuite/gnat.dg/itype.ads @@ -0,0 +1,5 @@ +package itype is + generic + type T is private; + function G return not null access constant T; +end itype; diff --git a/gcc/testsuite/gnat.dg/itypes.adb b/gcc/testsuite/gnat.dg/itypes.adb new file mode 100644 index 000000000..fc9f10dcb --- /dev/null +++ b/gcc/testsuite/gnat.dg/itypes.adb @@ -0,0 +1,22 @@ +-- { dg-do compile } + +package body itypes is + Size : constant := 10; + type Arr is array (1 .. size) of Integer; + + type Rec is record + Field1 : Arr := (others => 0); + Field2 : Arr := (others => 0); + Field3 : Arr := (others => 0); + Field4 : Arr := (others => 0); + Field5 : Arr := (others => 0); + Field6 : Arr := (others => 0); + Field7 : Arr := (others => 0); + end record; + + procedure Proc is + Temp1 : Rec; + begin + null; + end; +end; diff --git a/gcc/testsuite/gnat.dg/itypes.ads b/gcc/testsuite/gnat.dg/itypes.ads new file mode 100644 index 000000000..f6137e26e --- /dev/null +++ b/gcc/testsuite/gnat.dg/itypes.ads @@ -0,0 +1,4 @@ + +package itypes is + procedure Proc; +end; diff --git a/gcc/testsuite/gnat.dg/kill_value.adb b/gcc/testsuite/gnat.dg/kill_value.adb new file mode 100644 index 000000000..d83842166 --- /dev/null +++ b/gcc/testsuite/gnat.dg/kill_value.adb @@ -0,0 +1,20 @@ +-- { dg-do run } + +procedure kill_value is + type Struct; + type Pstruct is access all Struct; + + type Struct is record Next : Pstruct; end record; + + Vap : Pstruct := new Struct; + +begin + for J in 1 .. 10 loop + if Vap /= null then + while Vap /= null + loop + Vap := Vap.Next; + end loop; + end if; + end loop; +end; diff --git a/gcc/testsuite/gnat.dg/late_overriding.adb b/gcc/testsuite/gnat.dg/late_overriding.adb new file mode 100644 index 000000000..9fe5fc139 --- /dev/null +++ b/gcc/testsuite/gnat.dg/late_overriding.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } + +procedure late_overriding is + package Pkg is + type I is interface; + procedure Meth (O : in I) is abstract; + type Root is abstract tagged null record; + type DT1 is abstract new Root and I with null record; + end Pkg; + use Pkg; + type DT2 is new DT1 with null record; + procedure Meth (X : DT2) is begin null; end; -- Test +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/layered_abstraction.adb b/gcc/testsuite/gnat.dg/layered_abstraction.adb new file mode 100644 index 000000000..bdb9552e1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/layered_abstraction.adb @@ -0,0 +1,9 @@ +package body Layered_Abstraction is + Z : P1.T := P2.Obj; -- Both P1.T and P2.Obj are visible because + -- they were not specified in the formal package. + -- Note that P2.T is not visible since it + -- is required to match P1.T + + use P1; -- to make equality immediately visible + Yes_Again : Boolean := P1.Obj2 = P2.Obj2; +end Layered_Abstraction; diff --git a/gcc/testsuite/gnat.dg/layered_abstraction.ads b/gcc/testsuite/gnat.dg/layered_abstraction.ads new file mode 100644 index 000000000..219fbebc3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/layered_abstraction.ads @@ -0,0 +1,13 @@ +with Layered_Abstraction_P; +generic + with package P1 is new Layered_Abstraction_P(<>); + with package P2 is new Layered_Abstraction_P(T => P1.T, Obj => <>); +package Layered_Abstraction is + pragma Elaborate_Body; + X : P1.T := P2.Obj; -- Both P1.T and P2.Obj are visible because + -- they were not specified in the formal package. -- Note that P2.T is not visible since it + -- is required to match P1.T + + use P1; -- to make equality immediately visible + Yes : Boolean := P1.Obj2 = P2.Obj2; +end Layered_Abstraction; diff --git a/gcc/testsuite/gnat.dg/layered_abstraction_p.ads b/gcc/testsuite/gnat.dg/layered_abstraction_p.ads new file mode 100644 index 000000000..d06f60d96 --- /dev/null +++ b/gcc/testsuite/gnat.dg/layered_abstraction_p.ads @@ -0,0 +1,6 @@ +generic + type T is private; + Obj : T; +package Layered_Abstraction_P is + Obj2 : T := Obj; +end; diff --git a/gcc/testsuite/gnat.dg/layered_instance.adb b/gcc/testsuite/gnat.dg/layered_instance.adb new file mode 100644 index 000000000..f1326be8a --- /dev/null +++ b/gcc/testsuite/gnat.dg/layered_instance.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } + +with Layered_Abstraction_P; +with layered_abstraction; +procedure layered_instance is + package s1 is new Layered_Abstraction_P (Integer, 15); + package S2 is new Layered_Abstraction_P (Integer, 20); + package Inst is new layered_abstraction (S1, S2); +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/lhs_view_convert.adb b/gcc/testsuite/gnat.dg/lhs_view_convert.adb new file mode 100644 index 000000000..e7947f033 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lhs_view_convert.adb @@ -0,0 +1,29 @@ +-- { dg-do run } +-- { dg-options "-gnatp" } + +procedure Lhs_View_Convert is + + type Root is tagged record + RV : Natural; + end record; + + type Derived is new Root with null record; + + Root_Instance : Root := (RV => 1); + + Derived_Instance : Derived; + + procedure Process is + X : Natural := Derived_Instance.RV; + begin + null; + end; +begin + Derived_Instance.RV := 2; + + Root (Derived_Instance) := Root (Root_Instance); + + if Derived_Instance.RV /= Root_Instance.RV then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/limited_with.adb b/gcc/testsuite/gnat.dg/limited_with.adb new file mode 100644 index 000000000..f2211f193 --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited_with.adb @@ -0,0 +1,9 @@ +-- { dg-do compile } + +with Pack1; +package body limited_with is + procedure Print_2 (Obj : access Pack1.Nested.Rec_Typ) is + begin + null; + end; +end limited_with; diff --git a/gcc/testsuite/gnat.dg/limited_with.ads b/gcc/testsuite/gnat.dg/limited_with.ads new file mode 100644 index 000000000..add7b9e28 --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited_with.ads @@ -0,0 +1,4 @@ +limited with Pack1; +package limited_with is + procedure Print_2 (Obj : access Pack1.Nested.Rec_Typ); +end limited_with; diff --git a/gcc/testsuite/gnat.dg/loop_address.adb b/gcc/testsuite/gnat.dg/loop_address.adb new file mode 100644 index 000000000..e8e93d440 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_address.adb @@ -0,0 +1,30 @@ +-- { dg-do compile } +-- { dg-options "-O -gnatws" } + +-- PR middle-end/35136 + +pragma Extend_System(AUX_DEC); +with System; + +procedure Loop_Address is + + function Y(E : Integer) return String is + begin + return ""; + end Y; + + function X(C : in System.Address) return String is + D : Integer; + for D use at C; + begin + return Y(D); + end X; + + A : System.Address; + B : String := ""; + +begin + for I in 0..1 loop + B := X(System."+"(A, I)); + end loop; +end; diff --git a/gcc/testsuite/gnat.dg/loop_address2.adb b/gcc/testsuite/gnat.dg/loop_address2.adb new file mode 100644 index 000000000..aa955d771 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_address2.adb @@ -0,0 +1,26 @@ +-- { dg-do compile }
+-- { dg-options "-O" }
+
+with System, Ada.Unchecked_Conversion;
+with System.Storage_Elements; use System.Storage_Elements;
+
+procedure Loop_Address2 is
+
+ type Ptr is access all Integer;
+
+ function To_Ptr is new Ada.Unchecked_Conversion (System.Address, Ptr);
+
+ function F (BM : System.Address; I : Integer) return System.Address is
+ begin
+ return BM + Storage_Offset (4*I);
+ end;
+
+ B : Integer;
+ P : Ptr;
+
+begin
+ for I in 0 .. 2 loop
+ P := To_Ptr (F (B'Address, I));
+ P.all := 0;
+ end loop;
+end ;
diff --git a/gcc/testsuite/gnat.dg/loop_boolean.adb b/gcc/testsuite/gnat.dg/loop_boolean.adb new file mode 100644 index 000000000..f2836c393 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_boolean.adb @@ -0,0 +1,20 @@ +-- { dg-do run } +-- { dg-options "-gnatVaM" } + +procedure Loop_Boolean is + + type R is record + B : Boolean; + end record; + + procedure proc (X : R) is + B : Boolean; + begin + B := X.B; + end; + +begin + for I in reverse Boolean loop + Proc ((B => I)); + end loop; +end; diff --git a/gcc/testsuite/gnat.dg/loop_bound.adb b/gcc/testsuite/gnat.dg/loop_bound.adb new file mode 100644 index 000000000..c08a21585 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_bound.adb @@ -0,0 +1,26 @@ +-- { dg-do compile } + +procedure loop_bound is + package P is + type Base is new Integer; + Limit : constant Base := 10; + type Index is private; + generic package Gen is end; + private + type Index is new Base range 0 .. Limit; + end P; + package body P is + package body Gen is + type Table is array (Index) of Integer; + procedure Init (X : in out Table) is + begin + for I in 1..Index'last -1 loop + X (I) := -1; + end loop; + end Init; + end Gen; + end P; + package Inst is new P.Gen; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/loop_optimization1.adb b/gcc/testsuite/gnat.dg/loop_optimization1.adb new file mode 100644 index 000000000..8875c1f8d --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization1.adb @@ -0,0 +1,27 @@ +-- { dg-do compile } +-- { dg-options "-O3" } + +package body Loop_Optimization1 is + + procedure Create (A : in out D; Val : Integer) is + + M : constant Group_Chain_List := Group_Chains(Val); + G : constant Group_List := Groups(Val); + + function Is_Visible (Group : Number) return Boolean is + begin + for I in M'Range loop + if Group = M(I).Groups(M(I).Length) then + return True; + end if; + end loop; + return False; + end; + + begin + for I in A.L'Range loop + A.L(I) := new R(Is_Visible(G(I))); + end loop; + end; + +end Loop_Optimization1; diff --git a/gcc/testsuite/gnat.dg/loop_optimization1.ads b/gcc/testsuite/gnat.dg/loop_optimization1.ads new file mode 100644 index 000000000..2c3f419b5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization1.ads @@ -0,0 +1,35 @@ +package Loop_Optimization1 is + + type Number is range 0 .. 127; + + type Group_List is array (Positive range <>) of Number; + + subtype Index is Natural range 1 .. 5; + + function Groups (T : Integer) return Group_List; + pragma Import (Ada, Groups); + + type Group_Chain (Length : Index := 1) is record + Groups : Group_List(1 .. Length); + end record; + + type Group_Chain_List is array (Positive range <>) of Group_Chain; + + function Group_Chains (T : Integer) return Group_Chain_List; + pragma Import (Ada, Group_Chains); + + type R (I : Boolean) is null record; + + type R_Access is access R; + + type R_List is array (Positive range <>) of R_Access; + + type R_List_Access is access R_List; + + type D is record + L : R_List_Access; + end record; + + procedure Create (A : in out D; Val : Integer); + +end Loop_Optimization1; diff --git a/gcc/testsuite/gnat.dg/loop_optimization2.adb b/gcc/testsuite/gnat.dg/loop_optimization2.adb new file mode 100644 index 000000000..f78cd989a --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization2.adb @@ -0,0 +1,41 @@ +-- { dg-do compile } +-- { dg-options "-gnata -O2 -fno-inline" } + +with Ada.Unchecked_Conversion; + +package body Loop_Optimization2 is + + function To_Addr_Ptr is + new Ada.Unchecked_Conversion (System.Address, Addr_Ptr); + + function To_Address is + new Ada.Unchecked_Conversion (Tag, System.Address); + + function To_Type_Specific_Data_Ptr is + new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); + + function Interface_Ancestor_Tags (T : Tag) return Tag_Array is + TSD_Ptr : constant Addr_Ptr := To_Addr_Ptr (To_Address (T)); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table; + begin + if Iface_Table = null then + declare + Table : Tag_Array (1 .. 0); + begin + return Table; + end; + else + declare + Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces); + begin + for J in 1 .. Iface_Table.Nb_Ifaces loop + Table (J) := Iface_Table.Ifaces_Table (J).Iface_Tag; + end loop; + return Table; + end; + end if; + end Interface_Ancestor_Tags; + +end Loop_Optimization2; diff --git a/gcc/testsuite/gnat.dg/loop_optimization2.ads b/gcc/testsuite/gnat.dg/loop_optimization2.ads new file mode 100644 index 000000000..39d83236b --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization2.ads @@ -0,0 +1,41 @@ +with System; + +package Loop_Optimization2 is + + type Prim_Ptr is access procedure; + type Address_Array is array (Positive range <>) of Prim_Ptr; + + subtype Dispatch_Table is Address_Array (1 .. 1); + + type Tag is access all Dispatch_Table; + + type Tag_Array is array (Positive range <>) of Tag; + + function Interface_Ancestor_Tags (T : Tag) return Tag_Array; + + type Interface_Data_Element is record + Iface_Tag : Tag; + end record; + + type Interfaces_Array is array (Natural range <>) of Interface_Data_Element; + + type Interface_Data (Nb_Ifaces : Positive) is record + Ifaces_Table : Interfaces_Array (1 .. Nb_Ifaces); + end record; + + type Interface_Data_Ptr is access all Interface_Data; + + type Type_Specific_Data (Idepth : Natural) is record + Interfaces_Table : Interface_Data_Ptr; + end record; + + type Type_Specific_Data_Ptr is access all Type_Specific_Data; + pragma No_Strict_Aliasing (Type_Specific_Data_Ptr); + + subtype Predef_Prims_Table is Address_Array (1 .. 16); + type Predef_Prims_Table_Ptr is access Predef_Prims_Table; + + type Addr_Ptr is access System.Address; + pragma No_Strict_Aliasing (Addr_Ptr); + +end Loop_Optimization2; diff --git a/gcc/testsuite/gnat.dg/loop_optimization3.adb b/gcc/testsuite/gnat.dg/loop_optimization3.adb new file mode 100644 index 000000000..e69f535fb --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization3.adb @@ -0,0 +1,15 @@ +-- { dg-do run } +-- { dg-options "-O" } + +with Loop_Optimization3_Pkg; use Loop_Optimization3_Pkg; + +procedure Loop_Optimization3 is + + type Arr is array (Integer range -3 .. 3) of Integer; + C : constant Arr := (1, others => F(2)); + +begin + if C /= (1, 2, 2, 2, 2, 2, 2) then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/loop_optimization3_pkg.adb b/gcc/testsuite/gnat.dg/loop_optimization3_pkg.adb new file mode 100644 index 000000000..7a6481503 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization3_pkg.adb @@ -0,0 +1,8 @@ +package body Loop_Optimization3_Pkg is + + function F (n : Integer) return Integer is + begin + return n; + end; + +end Loop_Optimization3_Pkg; diff --git a/gcc/testsuite/gnat.dg/loop_optimization3_pkg.ads b/gcc/testsuite/gnat.dg/loop_optimization3_pkg.ads new file mode 100644 index 000000000..90f4fc32b --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization3_pkg.ads @@ -0,0 +1,5 @@ +package Loop_Optimization3_Pkg is + + function F (n : Integer) return Integer; + +end Loop_Optimization3_Pkg; diff --git a/gcc/testsuite/gnat.dg/loop_optimization4.adb b/gcc/testsuite/gnat.dg/loop_optimization4.adb new file mode 100644 index 000000000..a6799f393 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization4.adb @@ -0,0 +1,9 @@ +-- { dg-do run } +-- { dg-options "-O2" } + +with Loop_Optimization4_Pkg; use Loop_Optimization4_Pkg; + +procedure Loop_Optimization4 is +begin + Add ("Nothing"); +end; diff --git a/gcc/testsuite/gnat.dg/loop_optimization4_pkg.adb b/gcc/testsuite/gnat.dg/loop_optimization4_pkg.adb new file mode 100644 index 000000000..ba372f6bd --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization4_pkg.adb @@ -0,0 +1,17 @@ +package body Loop_Optimization4_Pkg is + + procedure Add (Phrase : String) is + begin + if Debug_Buffer_Len = Max_Debug_Buffer_Len then + return; + end if; + for I in Phrase'Range loop + Debug_Buffer_Len := Debug_Buffer_Len + 1; + Debug_Buffer (Debug_Buffer_Len) := Phrase (I); + if Debug_Buffer_Len = Max_Debug_Buffer_Len then + exit; + end if; + end loop; + end Add; + +end Loop_Optimization4_Pkg; diff --git a/gcc/testsuite/gnat.dg/loop_optimization4_pkg.ads b/gcc/testsuite/gnat.dg/loop_optimization4_pkg.ads new file mode 100644 index 000000000..a07c4e568 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization4_pkg.ads @@ -0,0 +1,9 @@ +package Loop_Optimization4_Pkg is + + Max_Debug_Buffer_Len : Natural := 8 * 1024; + Debug_Buffer : String (1 .. Max_Debug_Buffer_Len); + Debug_Buffer_Len : Natural range 0 .. Max_Debug_Buffer_Len; + + procedure Add (Phrase : String); + +end Loop_Optimization4_Pkg; diff --git a/gcc/testsuite/gnat.dg/loop_optimization5.adb b/gcc/testsuite/gnat.dg/loop_optimization5.adb new file mode 100644 index 000000000..09bf3e216 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization5.adb @@ -0,0 +1,21 @@ +-- { dg-do compile } +-- { dg-options "-O -gnatp" } + +with Loop_Optimization5_Pkg; use Loop_Optimization5_Pkg; + +procedure Loop_Optimization5 is + Str : constant String := "12345678"; + Cmd : constant String := Init; + StartP : Positive := Cmd'First; + StartS : Positive := Cmd'Last + 1; + EndP : Natural := StartP - 1; + Full_Cmd : String_Access; +begin + for J in StartP .. Cmd'Last - Str'Length + 1 loop + if Cmd (J .. J + Str'Length - 1) = Str then + EndP := J - 1; + exit; + end if; + end loop; + Full_Cmd := Locate (Cmd (StartP .. EndP)); +end; diff --git a/gcc/testsuite/gnat.dg/loop_optimization5_pkg.ads b/gcc/testsuite/gnat.dg/loop_optimization5_pkg.ads new file mode 100644 index 000000000..4af6c1ce6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization5_pkg.ads @@ -0,0 +1,7 @@ +package Loop_Optimization5_Pkg is + + type String_Access is access all String; + function Init return String; + function Locate (S : String) return String_Access; + +end Loop_Optimization5_Pkg; diff --git a/gcc/testsuite/gnat.dg/loop_optimization6.adb b/gcc/testsuite/gnat.dg/loop_optimization6.adb new file mode 100644 index 000000000..30f35f6ba --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization6.adb @@ -0,0 +1,26 @@ +-- { dg-do compile } +-- { dg-options "-O2 -gnatp -fdump-tree-optimized" } + +package body Loop_Optimization6 is + procedure Foo is + begin + for I in 1 .. 1_000_000 loop + A := A + 1; + end loop; + end Foo; + + procedure Bar is + begin + for J in 1 .. 1_000 loop + Foo; + end loop; + end Bar; + + procedure Main is + begin + Bar; + end; +end Loop_Optimization6; + +-- { dg-final { scan-tree-dump-not "goto" "optimized"} } +-- { dg-final { cleanup-tree-dump "optimized" } } diff --git a/gcc/testsuite/gnat.dg/loop_optimization6.ads b/gcc/testsuite/gnat.dg/loop_optimization6.ads new file mode 100644 index 000000000..9b8a26703 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization6.ads @@ -0,0 +1,4 @@ +package Loop_Optimization6 is + A : Integer := 0; + procedure Main; +end Loop_Optimization6; diff --git a/gcc/testsuite/gnat.dg/loop_optimization7.adb b/gcc/testsuite/gnat.dg/loop_optimization7.adb new file mode 100644 index 000000000..166839494 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization7.adb @@ -0,0 +1,16 @@ +-- { dg-do compile } +-- { dg-options "-O3" } +-- { dg-options "-O3 -msse" { target i?86-*-* x86_64-*-* } } + +package body Loop_Optimization7 is + + function Conv (A : Arr) return Arr is + Result : Arr; + begin + for I in A'Range loop + Result (I) := Conv (A (I)); + end loop; + return Result; + end; + +end Loop_Optimization7; diff --git a/gcc/testsuite/gnat.dg/loop_optimization7.ads b/gcc/testsuite/gnat.dg/loop_optimization7.ads new file mode 100644 index 000000000..ab0a165ea --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization7.ads @@ -0,0 +1,9 @@ +with Loop_Optimization7_Pkg; use Loop_Optimization7_Pkg; + +package Loop_Optimization7 is + + type Arr is array (1..8) of Rec; + + function Conv (A : Arr) return Arr; + +end Loop_Optimization7; diff --git a/gcc/testsuite/gnat.dg/loop_optimization7_pkg.ads b/gcc/testsuite/gnat.dg/loop_optimization7_pkg.ads new file mode 100644 index 000000000..0eaefa1b0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization7_pkg.ads @@ -0,0 +1,10 @@ +package Loop_Optimization7_Pkg is + pragma Pure; + + type Rec is record + F : Float; + end record; + + function Conv (Trig : Rec) return Rec; + +end Loop_Optimization7_Pkg; diff --git a/gcc/testsuite/gnat.dg/loop_optimization8.adb b/gcc/testsuite/gnat.dg/loop_optimization8.adb new file mode 100644 index 000000000..6be28f113 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization8.adb @@ -0,0 +1,30 @@ +-- { dg-do run } +-- { dg-options "-O -gnatn" } + +with Loop_Optimization8_Pkg1; + +procedure Loop_Optimization8 is + + Data : Loop_Optimization8_Pkg1.T; + + procedure Check_1 (N : in Natural) is + begin + if N /= 0 then + for I in 1 .. Data.Last loop + declare + F : constant Natural := Data.Elements (I); + begin + if F = N then + raise Program_Error; + end if; + end; + end loop; + end if; + end; + + procedure Check is new Loop_Optimization8_Pkg1.Iter (Check_1); + +begin + Data := Loop_Optimization8_Pkg1.Empty; + Check; +end; diff --git a/gcc/testsuite/gnat.dg/loop_optimization8_pkg1.adb b/gcc/testsuite/gnat.dg/loop_optimization8_pkg1.adb new file mode 100644 index 000000000..3c3368dd4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization8_pkg1.adb @@ -0,0 +1,15 @@ +with Loop_Optimization8_Pkg2; + +package body Loop_Optimization8_Pkg1 is + + Data : Loop_Optimization8_Pkg2.T + := new Loop_Optimization8_Pkg2.Obj_T'(Length =>1, Elements => (1 => 1)); + + procedure Iter is + begin + for I in 1 .. Loop_Optimization8_Pkg2.Length (Data) loop + Action (Loop_Optimization8_Pkg2.Index (Data, I)); + end loop; + end; + +end Loop_Optimization8_Pkg1; diff --git a/gcc/testsuite/gnat.dg/loop_optimization8_pkg1.ads b/gcc/testsuite/gnat.dg/loop_optimization8_pkg1.ads new file mode 100644 index 000000000..e6f3c7021 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization8_pkg1.ads @@ -0,0 +1,20 @@ +with Ada.Finalization; + +package Loop_Optimization8_Pkg1 is + + type Array_T is array (Positive range <>) of Natural; + + type Array_Access_T is access Array_T; + + type T is new Ada.Finalization.Controlled with record + Last : Natural := 0; + Elements : Array_Access_T; + end record; + + Empty : T := (Ada.Finalization.Controlled with Last => 0, Elements => null); + + generic + with procedure Action (Info : Natural); + procedure Iter; + +end Loop_Optimization8_Pkg1; diff --git a/gcc/testsuite/gnat.dg/loop_optimization8_pkg2.adb b/gcc/testsuite/gnat.dg/loop_optimization8_pkg2.adb new file mode 100644 index 000000000..9b9a3dea1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization8_pkg2.adb @@ -0,0 +1,13 @@ +package body Loop_Optimization8_Pkg2 is + + function Length (Set : T) return Natural is + begin + return Set.Length; + end Length; + + function Index (Set : T; Position : Natural) return Integer is + begin + return Set.Elements (Position); + end Index; + +end Loop_Optimization8_Pkg2; diff --git a/gcc/testsuite/gnat.dg/loop_optimization8_pkg2.ads b/gcc/testsuite/gnat.dg/loop_optimization8_pkg2.ads new file mode 100644 index 000000000..b92cb588b --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_optimization8_pkg2.ads @@ -0,0 +1,16 @@ +package Loop_Optimization8_Pkg2 is + + type Array_T is array (Natural range <>) of Integer; + + type Obj_T (Length : Natural) is + record + Elements : Array_T (1 .. Length); + end record; + + type T is access Obj_T; + + function Length (Set : T) return Natural; + function Index (Set : T; Position : Natural) return Integer; + pragma Inline (Length, Index); + +end Loop_Optimization8_Pkg2; diff --git a/gcc/testsuite/gnat.dg/loop_unchecked_conversion.adb b/gcc/testsuite/gnat.dg/loop_unchecked_conversion.adb new file mode 100644 index 000000000..e87c415c5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_unchecked_conversion.adb @@ -0,0 +1,33 @@ +-- { dg-do compile } +-- { dg-options "-gnatws -O" } + +with Unchecked_Conversion; + +package body loop_unchecked_conversion is + + type Byte is mod 2**8; + + type List is array (Natural range <>) of Byte; + + subtype Integer_List is List (1 .. 4); + + function Integer_Down is new + Unchecked_Conversion (Source => Integer, Target => Integer_List); + + type Storage (Size : Integer) is + record + Data : List (1 .. Size); + end record; + + type Storage_Pointer is access Storage; + + The_Data_Storage : Storage_Pointer; + + procedure slice is + begin + for I in 0 .. 1 loop + The_Data_Storage.Data (I+1 .. I+4) := Integer_Down (I); + end loop; + end; + +end loop_unchecked_conversion; diff --git a/gcc/testsuite/gnat.dg/loop_unchecked_conversion.ads b/gcc/testsuite/gnat.dg/loop_unchecked_conversion.ads new file mode 100644 index 000000000..5ce43e552 --- /dev/null +++ b/gcc/testsuite/gnat.dg/loop_unchecked_conversion.ads @@ -0,0 +1,5 @@ +package loop_unchecked_conversion is + + procedure slice; + +end loop_unchecked_conversion; diff --git a/gcc/testsuite/gnat.dg/lto1.adb b/gcc/testsuite/gnat.dg/lto1.adb new file mode 100644 index 000000000..d777097ad --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto1.adb @@ -0,0 +1,14 @@ +-- PR ada/43106 +-- Testcase by Bill Neven <neven@hitt.nl> + +-- { dg-do run } +-- { dg-options "-O2 -flto" { target lto } } + +with Lto1_Pkg; use Lto1_Pkg; + +procedure Lto1 is + Radar : Radar_T; +begin + Radar.Sensor_Type := radcmb; + Initialize (Radar); +end; diff --git a/gcc/testsuite/gnat.dg/lto10.adb b/gcc/testsuite/gnat.dg/lto10.adb new file mode 100644 index 000000000..647ed0063 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto10.adb @@ -0,0 +1,14 @@ +-- { dg-do run } +-- { dg-options "-flto" { target lto } } + +with Lto10_Pkg; use Lto10_Pkg; + +procedure Lto10 is + A : Integer := Minus_One; + Pos : Position; +begin + Pos := Pix.Pos; + if A /= Minus_One then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/lto10_pkg.ads b/gcc/testsuite/gnat.dg/lto10_pkg.ads new file mode 100644 index 000000000..9be6a78c9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto10_pkg.ads @@ -0,0 +1,18 @@ +package Lto10_Pkg is + + type U16 is mod 2 ** 16; + + type Position is record + X, Y, Z : U16; + end record; + for Position'Size use 48; + + type Pixel is record + Pos : Position; + end record; + pragma Pack (Pixel); + + Minus_One : Integer := -1; + Pix : Pixel := (Pos => (X => 0, Y => 0, Z => 0)); + +end Lto10_Pkg; diff --git a/gcc/testsuite/gnat.dg/lto1_pkg.adb b/gcc/testsuite/gnat.dg/lto1_pkg.adb new file mode 100644 index 000000000..99955a874 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto1_pkg.adb @@ -0,0 +1,23 @@ +package body Lto1_Pkg is + + procedure Initialize (Radar : in Radar_T) is + Antenna1 : Antenna_Type_T; + Antenna2 : Antenna_Type_T; + begin + case Radar.Sensor_Type is + when radpr | radssr => + Antenna1 := Radar.Sensor_Type; + Antenna2 := Radar.Sensor_Type; + when radcmb => + Antenna1 := radpr; + Antenna2 := radssr; + when others => + Antenna1 := radpr; + Antenna2 := radssr; + end case; + if Antenna1 /= radpr or Antenna2 /= radssr then + raise Program_Error; + end if; + end Initialize; + +end Lto1_Pkg; diff --git a/gcc/testsuite/gnat.dg/lto1_pkg.ads b/gcc/testsuite/gnat.dg/lto1_pkg.ads new file mode 100644 index 000000000..33c9bc9b5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto1_pkg.ads @@ -0,0 +1,23 @@ +package Lto1_Pkg is + + type Unsigned_64 is mod 2 ** 64; + + type Associated_Report_T is (miss, radpr, radssr, radcmb); + + -- sensor type : primary, secondary, co-rotating (combined) + subtype Sensor_Type_T is Associated_Report_T; -- range radpr .. radcmb; + subtype Antenna_Type_T is Sensor_Type_T range radpr .. radssr; + + type Filtering_Level_T is (none, pr_in_clutter, ssr_plots, pr_plots); + type Filtering_Levels_T is array (Filtering_Level_T) of boolean; + + type Radar_T is record + External_Sensor_ID : Unsigned_64; + Dual_Radar_Index : Integer; + Compatible_Filtering_Levels : Filtering_Levels_T; + Sensor_Type : Sensor_Type_T; + end record; + + procedure Initialize (Radar : in Radar_T); + +end Lto1_Pkg; diff --git a/gcc/testsuite/gnat.dg/lto2.adb b/gcc/testsuite/gnat.dg/lto2.adb new file mode 100644 index 000000000..7981097f8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto2.adb @@ -0,0 +1,28 @@ +-- { dg-do compile } +-- { dg-options "-flto" { target lto } } + +procedure Lto2 (Nbytes : Natural) is + + type Message_T (Length : Natural) is record + case Length is + when 0 => null; + when others => Id : Natural; + end case; + end record; + + type Local_Message_T is new Message_T (Nbytes); + + function One_message return Local_Message_T is + M : Local_Message_T; + begin + if M.Length > 0 then + M.Id := 1; + end if; + return M; + end; + + procedure Process (X : Local_Message_T) is begin null; end; + +begin + Process (One_Message); +end; diff --git a/gcc/testsuite/gnat.dg/lto4.adb b/gcc/testsuite/gnat.dg/lto4.adb new file mode 100644 index 000000000..8bb57b49d --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto4.adb @@ -0,0 +1,12 @@ +-- { dg-do compile } +-- { dg-options "-flto" { target lto } } + +package body Lto4 is + + procedure SS_Allocate (Stack : Stack_Ptr) is + Chunk : Chunk_Ptr := Stack.Current_Chunk; + begin + Chunk := new Chunk_Id (First => Chunk.Last, Last => Chunk.Last); + end; + +end Lto4; diff --git a/gcc/testsuite/gnat.dg/lto4.ads b/gcc/testsuite/gnat.dg/lto4.ads new file mode 100644 index 000000000..36c9f9464 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto4.ads @@ -0,0 +1,26 @@ +with System.Storage_Elements; + +package Lto4 is + + package SSE renames System.Storage_Elements; + + type SS_Ptr is new SSE.Integer_Address; + + type Memory is array (SS_Ptr range <>) of SSE.Storage_Element; + for Memory'Alignment use Standard'Maximum_Alignment; + + type Chunk_Id (First, Last : SS_Ptr) is record + Mem : Memory (First .. Last); + end record; + + type Chunk_Ptr is access all Chunk_Id; + + type Stack_Id is record + Current_Chunk : Chunk_Ptr; + end record; + + type Stack_Ptr is access Stack_Id; + + procedure SS_Allocate (Stack : Stack_Ptr); + +end Lto4; diff --git a/gcc/testsuite/gnat.dg/lto5.adb b/gcc/testsuite/gnat.dg/lto5.adb new file mode 100644 index 000000000..506b41f55 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto5.adb @@ -0,0 +1,9 @@ +-- { dg-do run } +-- { dg-options "-flto" { target lto } } + +with Lto5_Pkg; + +procedure Lto5 is +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/lto5_pkg.adb b/gcc/testsuite/gnat.dg/lto5_pkg.adb new file mode 100644 index 000000000..b5bf68ab9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto5_pkg.adb @@ -0,0 +1,6 @@ +package body Lto5_Pkg is + procedure d (a : t) is + begin + null; + end; +end; diff --git a/gcc/testsuite/gnat.dg/lto5_pkg.ads b/gcc/testsuite/gnat.dg/lto5_pkg.ads new file mode 100644 index 000000000..34d34926e --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto5_pkg.ads @@ -0,0 +1,6 @@ +pragma Eliminate (p, d); + +package Lto5_Pkg is + type t is tagged null record; + procedure d (a : t); +end; diff --git a/gcc/testsuite/gnat.dg/lto6.adb b/gcc/testsuite/gnat.dg/lto6.adb new file mode 100644 index 000000000..f8cbf4dd0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto6.adb @@ -0,0 +1,11 @@ +-- { dg-do run } +-- { dg-options "-O2 -flto" { target lto } } + +with Lto6_Pkg; use Lto6_Pkg; + +procedure Lto6 is + type Enum is (A, B, C, D); + Table : array (B .. C, 1 .. 1) of F_String := (others => (others => Null_String)); +begin + Table := (others => (others => Null_String)); +end; diff --git a/gcc/testsuite/gnat.dg/lto6_pkg.ads b/gcc/testsuite/gnat.dg/lto6_pkg.ads new file mode 100644 index 000000000..81b7ddc5a --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto6_pkg.ads @@ -0,0 +1,8 @@ +with Ada.Finalization; use Ada.Finalization; + +package Lto6_Pkg is + type F_String is new Controlled with record + Data : access String; + end record; + Null_String : constant F_String := (Controlled with Data => null); +end Lto6_Pkg; diff --git a/gcc/testsuite/gnat.dg/lto7.adb b/gcc/testsuite/gnat.dg/lto7.adb new file mode 100644 index 000000000..cb81495a9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto7.adb @@ -0,0 +1,12 @@ +-- { dg-do run } +-- { dg-options "-flto" { target lto } } + +with Lto7_Pkg; use Lto7_Pkg; + +procedure Lto7 is + view2 : access Iface_2'Class; + obj : aliased DT := (m_name => "Abdu"); +begin + view2 := Iface_2'Class(obj)'Access; + view2.all.op2; +end; diff --git a/gcc/testsuite/gnat.dg/lto7_pkg.adb b/gcc/testsuite/gnat.dg/lto7_pkg.adb new file mode 100644 index 000000000..dd973dad3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto7_pkg.adb @@ -0,0 +1,6 @@ +package body Lto7_Pkg is + + procedure op1 (this : Root) is begin null; end; + procedure op2 (this : DT) is begin null; end; + +end Lto7_Pkg; diff --git a/gcc/testsuite/gnat.dg/lto7_pkg.ads b/gcc/testsuite/gnat.dg/lto7_pkg.ads new file mode 100644 index 000000000..284745fad --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto7_pkg.ads @@ -0,0 +1,16 @@ +package Lto7_Pkg is + type Iface_1 is interface; + procedure op1(this : Iface_1) is abstract; + + type Iface_2 is interface; + procedure op2 (this : Iface_2) is abstract; + + type Root is new Iface_1 with record + m_name : String(1..4); + end record; + + procedure op1 (this : Root); + + type DT is new Root and Iface_2 with null record; + procedure op2 (this : DT); +end Lto7_Pkg; diff --git a/gcc/testsuite/gnat.dg/lto8.adb b/gcc/testsuite/gnat.dg/lto8.adb new file mode 100644 index 000000000..68f9ea119 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto8.adb @@ -0,0 +1,22 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } +-- { dg-options "-gnatws -flto" { target lto } } + +pragma Locking_Policy (Ceiling_Locking); + +with Lto8_Pkg; use Lto8_Pkg; + +procedure Lto8 is + task Tsk is + pragma Priority (10); + end Tsk; + task body Tsk is + begin + Sema2.Seize; + Sema1.Seize; + exception + when Program_Error => null; + end; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/lto8_pkg.adb b/gcc/testsuite/gnat.dg/lto8_pkg.adb new file mode 100644 index 000000000..de4c2a757 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto8_pkg.adb @@ -0,0 +1,9 @@ +-- { dg-options "-gnatws" } + +package body Lto8_Pkg is + + protected body Protected_Queue_T is + entry Seize when True is begin null; end; + end Protected_Queue_T; + +end Lto8_Pkg; diff --git a/gcc/testsuite/gnat.dg/lto8_pkg.ads b/gcc/testsuite/gnat.dg/lto8_pkg.ads new file mode 100644 index 000000000..d9ea584df --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto8_pkg.ads @@ -0,0 +1,18 @@ +with System; +with Unchecked_Conversion; + +package Lto8_Pkg is + + type Task_Priority_T is new Natural; + function Convert_To_System_Priority is + new Unchecked_Conversion (Task_Priority_T, System.Priority); + + protected type Protected_Queue_T( PO_Priority : Task_Priority_T ) is + pragma Priority (Convert_To_System_Priority (PO_Priority )); + entry Seize; + end Protected_Queue_T; + + Sema1 : protected_Queue_T (5); + Sema2 : protected_Queue_T (10); + +end Lto8_Pkg; diff --git a/gcc/testsuite/gnat.dg/lto9.adb b/gcc/testsuite/gnat.dg/lto9.adb new file mode 100644 index 000000000..f4ec040d0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto9.adb @@ -0,0 +1,15 @@ +-- { dg-do run } +-- { dg-options "-flto" { target lto } } + +with Lto9_Pkg1; use Lto9_Pkg1; + +procedure Lto9 is + +begin + + District_Subscription_Lists.Put + (List => District_01_Subscribers, + Elem_Ptr => New_Subscriber_01'Access, + Location => 1); + +end; diff --git a/gcc/testsuite/gnat.dg/lto9_pkg1.ads b/gcc/testsuite/gnat.dg/lto9_pkg1.ads new file mode 100644 index 000000000..a09439262 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto9_pkg1.ads @@ -0,0 +1,24 @@ +with Lto9_Pkg2; + +package Lto9_Pkg1 is + + subtype Lengths is Natural range 0 .. 50; + + type Subscriber (NLen, ALen: Lengths := 50) is record + Name : String(1 .. NLen); + Address : String(1 .. ALen); + end record; + + type Subscriber_Ptr is access all Subscriber; + + package District_Subscription_Lists is new Lto9_Pkg2 + (Element_Type => Subscriber, + Element_Ptr => Subscriber_Ptr, + Size => 100); + + District_01_Subscribers : District_Subscription_Lists.List_Type; + + New_Subscriber_01 : aliased Subscriber := + (12, 23, "Brown, Silas", "King's Pyland, Dartmoor"); + +end Lto9_Pkg1; diff --git a/gcc/testsuite/gnat.dg/lto9_pkg2.adb b/gcc/testsuite/gnat.dg/lto9_pkg2.adb new file mode 100644 index 000000000..0291d608c --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto9_pkg2.adb @@ -0,0 +1,10 @@ +package body Lto9_Pkg2 is + + procedure Put (List : in out List_Type; + Elem_Ptr : in Element_Ptr; + Location : in Index) is + begin + List.Elements(Location) := Elem_Ptr; + end Put; + +end Lto9_Pkg2; diff --git a/gcc/testsuite/gnat.dg/lto9_pkg2.ads b/gcc/testsuite/gnat.dg/lto9_pkg2.ads new file mode 100644 index 000000000..881d02b54 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto9_pkg2.ads @@ -0,0 +1,21 @@ +generic + + Size : in Positive; + type Element_Type (<>) is private; + type Element_Ptr is access all Element_Type; + +package Lto9_Pkg2 is + + subtype Index is Positive range 1 .. (Size + 1); + + type List_Array is array (Index) of Element_Ptr; + + type List_Type is record + Elements : List_Array; + end record; + + procedure Put (List : in out List_Type; + Elem_Ptr : in Element_Ptr; + Location : in Index); + +end Lto9_Pkg2; diff --git a/gcc/testsuite/gnat.dg/machine_code1.adb b/gcc/testsuite/gnat.dg/machine_code1.adb new file mode 100644 index 000000000..2e03a9189 --- /dev/null +++ b/gcc/testsuite/gnat.dg/machine_code1.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +with System.Machine_Code; use System.Machine_Code; +procedure machine_code1 is + A_Float : Float; + An_Other_Float : Float := -99999.0; +begin + An_Other_Float := An_Other_Float - A_Float; + Asm("", Inputs => (Float'Asm_Input ("m", A_Float))); +end; diff --git a/gcc/testsuite/gnat.dg/max_align.adb b/gcc/testsuite/gnat.dg/max_align.adb new file mode 100644 index 000000000..702bbaca4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/max_align.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } + +procedure Max_Align is + type Block is record + X : Integer; + end record; + for Block'Alignment use Standard'Maximum_Alignment; + + type Block_Access is access Block; + Ptr : Block_Access := new Block; +begin + null; +end; + + diff --git a/gcc/testsuite/gnat.dg/md5_test.adb b/gcc/testsuite/gnat.dg/md5_test.adb new file mode 100644 index 000000000..e687bdf4a --- /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/memtrap.adb b/gcc/testsuite/gnat.dg/memtrap.adb new file mode 100644 index 000000000..ae87e8528 --- /dev/null +++ b/gcc/testsuite/gnat.dg/memtrap.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } +-- { dg-options "-O2" } + +with System; + +procedure Memtrap is + X : integer; + for X'address use System.Null_Address; +begin + X := 12; +exception + when others => null; +end; + +-- { dg-final { scan-assembler "__gnat_begin_handler|__gnat_raise_nodefer" } } diff --git a/gcc/testsuite/gnat.dg/misaligned_nest.adb b/gcc/testsuite/gnat.dg/misaligned_nest.adb new file mode 100644 index 000000000..3b6fd845d --- /dev/null +++ b/gcc/testsuite/gnat.dg/misaligned_nest.adb @@ -0,0 +1,26 @@ +-- { dg-do run } +-- { dg-options "-gnatp" } + +procedure Misaligned_Nest is + + type Int is record + V : Integer; + end record; + + type Block is record + B : Boolean; + I : Int; + end record; + pragma Pack (Block); + for Block'Alignment use 1; + + type Pair is array (1 .. 2) of Block; + + P : Pair; +begin + for K in P'Range loop + P(K).I.V := 1; + end loop; +end; + + diff --git a/gcc/testsuite/gnat.dg/misaligned_param.adb b/gcc/testsuite/gnat.dg/misaligned_param.adb new file mode 100644 index 000000000..dd591d06a --- /dev/null +++ b/gcc/testsuite/gnat.dg/misaligned_param.adb @@ -0,0 +1,30 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +with Misaligned_Param_Pkg; + +procedure Misaligned_Param is + + procedure Channel_Eth (Status : out Integer; Kind : out Integer); + + pragma Import (External, Channel_Eth); + pragma Import_Valued_Procedure + (Channel_Eth, "channel_eth", (Integer, Integer), (VALUE, REFERENCE)); + + type Channel is record + B : Boolean; + Kind : Integer; + end record; + pragma Pack (Channel); + + MyChan : Channel; + Status : Integer; + +begin + MyChan.Kind := 0; + Channel_Eth (Status => Status, Kind => MyChan.Kind); + + if Mychan.Kind = 0 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/misaligned_param_pkg.adb b/gcc/testsuite/gnat.dg/misaligned_param_pkg.adb new file mode 100644 index 000000000..888ed18c3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/misaligned_param_pkg.adb @@ -0,0 +1,14 @@ +package body Misaligned_Param_Pkg is + + type IP is access all Integer; + + function Channel_Eth (Kind : IP) return Integer; + pragma Export (Ada, Channel_Eth, "channel_eth"); + + function Channel_Eth (Kind : IP) return Integer is + begin + Kind.all := 111; + return 0; + end; + +end Misaligned_Param_Pkg; diff --git a/gcc/testsuite/gnat.dg/misaligned_param_pkg.ads b/gcc/testsuite/gnat.dg/misaligned_param_pkg.ads new file mode 100644 index 000000000..7934c3f34 --- /dev/null +++ b/gcc/testsuite/gnat.dg/misaligned_param_pkg.ads @@ -0,0 +1,5 @@ +package Misaligned_Param_Pkg is + + pragma Elaborate_Body (Misaligned_Param_Pkg); + +end Misaligned_Param_Pkg; diff --git a/gcc/testsuite/gnat.dg/missing_acc_check.adb b/gcc/testsuite/gnat.dg/missing_acc_check.adb new file mode 100644 index 000000000..1c2d9cf50 --- /dev/null +++ b/gcc/testsuite/gnat.dg/missing_acc_check.adb @@ -0,0 +1,39 @@ +-- { dg-do run } + +procedure Missing_Acc_Check is + + Test_Failed : Exception; + + type Int_Access is access all Integer; + + Save : Int_Access := null; + + type Int_Rec is record + Int : aliased Integer; + end record; + + type Ltd_Rec (IR_Acc : access Int_Rec) is limited null record; + + function Pass_Rec (IR_Acc : access Int_Rec) return Int_Access is + begin + return IR_Acc.Int'Access; -- Accessibility check here + end Pass_Rec; + + procedure Proc is + IR : aliased Int_Rec; + LR : Ltd_Rec (IR'Access); + begin + Save := Pass_Rec (LR.IR_Acc); -- Must raise Program_Error; + + if Save /= null then + raise Test_Failed; + end if; + + exception + when Program_Error => + null; + end Proc; + +begin + Proc; +end Missing_Acc_Check; diff --git a/gcc/testsuite/gnat.dg/modify_a_constant.adb b/gcc/testsuite/gnat.dg/modify_a_constant.adb new file mode 100644 index 000000000..576378b0b --- /dev/null +++ b/gcc/testsuite/gnat.dg/modify_a_constant.adb @@ -0,0 +1,19 @@ +-- { dg-do compile } + +with text_io; use text_io; +procedure modify_a_constant is + type Outer; + type Inner (Outer_Ref : access Outer) is limited null record; + + type Outer is limited record + Inner_Field : Inner (Outer_Ref => Outer'Access); + Integer_Field : Integer; + end record; + + X : constant Outer := (Inner_Field => <>, Integer_Field => 123); + +begin + Put_Line (Integer'image (X.Integer_Field)); + X.Inner_Field.Outer_Ref.Integer_Field := 0; + Put_Line (Integer'image (X.Integer_Field)); +end Modify_A_Constant; diff --git a/gcc/testsuite/gnat.dg/modular1.adb b/gcc/testsuite/gnat.dg/modular1.adb new file mode 100644 index 000000000..b9fcde95f --- /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/modular2.adb b/gcc/testsuite/gnat.dg/modular2.adb new file mode 100644 index 000000000..4e01bd609 --- /dev/null +++ b/gcc/testsuite/gnat.dg/modular2.adb @@ -0,0 +1,8 @@ +-- { dg-do run } + +procedure modular2 is + type x is mod 2 ** 64; + r : x := x'last; +begin + r := r + 1; +end; diff --git a/gcc/testsuite/gnat.dg/modular3.adb b/gcc/testsuite/gnat.dg/modular3.adb new file mode 100644 index 000000000..539edcaf4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/modular3.adb @@ -0,0 +1,32 @@ +-- { dg-do run } + +with Modular3_Pkg; use Modular3_Pkg; + +procedure Modular3 is + + function F1 (A : Int16_T) return Int16_T is + begin + return A + 128; + end; + + function F2 (B : Mod16_T) return Mod16_T is + begin + return B + 128; + end; + + A : Int16_T := 16384; + B : Mod16_T := 65504; + +begin + + A := F1 (A); + if A /= 16512 then + raise Program_Error; + end if; + + B := F2 (B); + if B /= 96 then + raise Program_Error; + end if; + +end Modular3; diff --git a/gcc/testsuite/gnat.dg/modular3_pkg.ads b/gcc/testsuite/gnat.dg/modular3_pkg.ads new file mode 100644 index 000000000..85cf6a8bf --- /dev/null +++ b/gcc/testsuite/gnat.dg/modular3_pkg.ads @@ -0,0 +1,11 @@ +package Modular3_Pkg is + + type Int16_T is range -32768 .. 32767; + for Int16_T'Size use 16; + for Int16_T'Alignment use 1; + + type Mod16_T is mod 2 ** 16; + for Mod16_T'Size use 16; + for Mod16_T'Alignment use 1; + +end Modular3_Pkg; diff --git a/gcc/testsuite/gnat.dg/mutable1.adb b/gcc/testsuite/gnat.dg/mutable1.adb new file mode 100644 index 000000000..274b52375 --- /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/my_env_versioned_value_set_g.ads b/gcc/testsuite/gnat.dg/my_env_versioned_value_set_g.ads new file mode 100644 index 000000000..11e47b3ff --- /dev/null +++ b/gcc/testsuite/gnat.dg/my_env_versioned_value_set_g.ads @@ -0,0 +1,7 @@ +generic + type Value_T(<>) is private; +package My_Env_Versioned_Value_Set_G is + generic + with function Updated_Entity (Value : Value_T) return Boolean is <>; + package Update_G is end; +end; diff --git a/gcc/testsuite/gnat.dg/named_test.adb b/gcc/testsuite/gnat.dg/named_test.adb new file mode 100644 index 000000000..1d271ba5c --- /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/namet.ads b/gcc/testsuite/gnat.dg/namet.ads new file mode 100644 index 000000000..01e4002fb --- /dev/null +++ b/gcc/testsuite/gnat.dg/namet.ads @@ -0,0 +1,11 @@ +package Namet is + + Hash_Num : constant Integer := 2**12; + + subtype Hash_Index_Type is Integer range 0 .. Hash_Num - 1; + + Name_Buffer : String (1 .. 16*1024); + + Name_Len : Natural; + +end Namet; diff --git a/gcc/testsuite/gnat.dg/nat1.ads b/gcc/testsuite/gnat.dg/nat1.ads new file mode 100644 index 000000000..9504c163b --- /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 000000000..91a17ba3a --- /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/nested_agg_bitfield_constructor.adb b/gcc/testsuite/gnat.dg/nested_agg_bitfield_constructor.adb new file mode 100644 index 000000000..6015900c5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/nested_agg_bitfield_constructor.adb @@ -0,0 +1,34 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } +-- (bits of "Header" unused) + +procedure Nested_Agg_Bitfield_Constructor is + + type Uint64 is mod 2 ** 64; + type Uint16 is mod 2 ** 16; + + type Time_Stamp is record + Sec : Uint64; + Year : Uint16; + end record; + + type Msg_Header is record + Stamp : Time_Stamp; + end record; + for Msg_Header use record + Stamp at 0 range 0 .. 64+16-1; + end record; + for Msg_Header'Size use 80; + + type Msg is record + Header : Msg_Header; + end record; + + for Msg use record + Header at 0 range 0 .. 191; + end record; + + M : Msg := (Header => (Stamp => (2, 4))); +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/nested_controlled_alloc.adb b/gcc/testsuite/gnat.dg/nested_controlled_alloc.adb new file mode 100644 index 000000000..963ba76be --- /dev/null +++ b/gcc/testsuite/gnat.dg/nested_controlled_alloc.adb @@ -0,0 +1,49 @@ +-- { dg-do run } + +with Text_IO; use Text_IO; +with Ada.Finalization; use Ada.Finalization; + +procedure Nested_Controlled_Alloc is + + package Controlled_Alloc is + + type Fin is new Limited_Controlled with null record; + procedure Finalize (X : in out Fin); + + F : Fin; + + type T is limited private; + type Ref is access all T; + + private + + type T is new Limited_Controlled with null record; + procedure Finalize (X : in out T); + + end Controlled_Alloc; + + package body Controlled_Alloc is + + procedure Finalize (X : in out T) is + begin + Put_Line ("Finalize (T)"); + end Finalize; + + procedure Finalize (X : in out Fin) is + R : Ref; + begin + begin + R := new T; + raise Constraint_Error; + + exception + when Program_Error => + null; -- OK + end; + end Finalize; + + end Controlled_Alloc; + +begin + null; +end Nested_Controlled_Alloc; diff --git a/gcc/testsuite/gnat.dg/nested_float_packed.ads b/gcc/testsuite/gnat.dg/nested_float_packed.ads new file mode 100644 index 000000000..46b9e803f --- /dev/null +++ b/gcc/testsuite/gnat.dg/nested_float_packed.ads @@ -0,0 +1,20 @@ +package Nested_Float_Packed is + + type Float_Type is record + Value : Float; + Valid : Boolean; + end record; + + type Data_Type is record + Data : Float_Type; + end record; + + Default_Data : constant Data_Type := + (Data => (Value => 1.0, Valid => False)); + + type Range_Type is (RV1, RV2, RV3); + for Range_Type use (1, 2, 3); + + Data_Block : array (Range_Type) + of Data_Type := (others => Default_Data); +end; diff --git a/gcc/testsuite/gnat.dg/nested_proc1.adb b/gcc/testsuite/gnat.dg/nested_proc1.adb new file mode 100644 index 000000000..b3abf2625 --- /dev/null +++ b/gcc/testsuite/gnat.dg/nested_proc1.adb @@ -0,0 +1,33 @@ +-- { dg-do run } +-- Test that a static link is correctly passed to a subprogram which is +-- indirectly called through an aggregate. + +procedure Nested_Proc1 is + + I : Integer := 0; + + procedure P1 (X : Integer) is + begin + I := X; + end; + + type Func_Ptr is access procedure (X : Integer); + + type Arr is array (1..64) of Integer; + + type Rec is record + F : Func_Ptr; + A : Arr; + end record; + + procedure P2 (R : Rec) is + begin + R.F (1); + end; + +begin + P2 ((F => P1'Access, A => (others => 0))); + if I /= 1 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/nested_proc2.adb b/gcc/testsuite/gnat.dg/nested_proc2.adb new file mode 100644 index 000000000..b5349563a --- /dev/null +++ b/gcc/testsuite/gnat.dg/nested_proc2.adb @@ -0,0 +1,30 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +procedure Nested_Proc2 is + + type Arr is array(1..2) of Integer; + + type Rec is record + Data : Arr; + end record; + + From : Rec; + Index : Integer; + + function F (X : Arr) return Integer is + begin + return 0; + end; + + procedure Test is + begin + Index := F (From.Data); + If Index /= 0 then + raise Program_Error; + end if; + end; + +begin + Test; +end; diff --git a/gcc/testsuite/gnat.dg/nested_return_test.adb b/gcc/testsuite/gnat.dg/nested_return_test.adb new file mode 100644 index 000000000..bc9f043cf --- /dev/null +++ b/gcc/testsuite/gnat.dg/nested_return_test.adb @@ -0,0 +1,33 @@ +-- { dg-do run } +-- { dg-options "-gnata" } + +procedure Nested_Return_Test is + function H (X: integer) return access integer is + Local : aliased integer := (X+1); + begin + case X is + when 3 => + begin + return Result : access integer do + Result := new integer '(27); + begin + for I in 1 .. 10 loop + result.all := result.all + 10; + end loop; + return; + end; + end return; + end; + when 5 => + return Result: Access integer do + Result := New Integer'(X*X*X); + end return; + when others => + return null; + end case; + end; +begin + pragma Assert (H (3).all = 127); + pragma Assert (H (5).all = 125); + null; +end Nested_Return_Test; diff --git a/gcc/testsuite/gnat.dg/nested_subtype_byref.adb b/gcc/testsuite/gnat.dg/nested_subtype_byref.adb new file mode 100644 index 000000000..b232aa36d --- /dev/null +++ b/gcc/testsuite/gnat.dg/nested_subtype_byref.adb @@ -0,0 +1,23 @@ + +package body Nested_Subtype_Byref is + + type Data (Stamped : Boolean) is record + case Stamped is + when True => Valid : Boolean; + when others => null; + end case; + end record; + + type Message is record + F : Integer := 1; + D : Data (Stamped => True); + end record; + + procedure Check is + M : Message; + begin + M.D.Valid := True; + end; + +end; + diff --git a/gcc/testsuite/gnat.dg/nested_subtype_byref.ads b/gcc/testsuite/gnat.dg/nested_subtype_byref.ads new file mode 100644 index 000000000..24e3f1eaa --- /dev/null +++ b/gcc/testsuite/gnat.dg/nested_subtype_byref.ads @@ -0,0 +1,4 @@ + +package Nested_Subtype_Byref is + procedure Check; +end; diff --git a/gcc/testsuite/gnat.dg/no_exc_prop.adb b/gcc/testsuite/gnat.dg/no_exc_prop.adb new file mode 100644 index 000000000..68e2b1d21 --- /dev/null +++ b/gcc/testsuite/gnat.dg/no_exc_prop.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } +-- { dg-options "-gnatwa" } + +package body no_exc_prop is + protected body Simple_Barrier is + entry Wait when Signaled is + begin + Signaled := False; + end Wait; + procedure Signal is + begin + Signaled := True; + end Signal; + end Simple_Barrier; +end no_exc_prop; diff --git a/gcc/testsuite/gnat.dg/no_exc_prop.ads b/gcc/testsuite/gnat.dg/no_exc_prop.ads new file mode 100644 index 000000000..ef3caa3d2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/no_exc_prop.ads @@ -0,0 +1,9 @@ +pragma Restrictions (No_Exception_Propagation); +package no_exc_prop is + protected Simple_Barrier is + entry Wait; + procedure Signal; + private + Signaled : Boolean := False; + end Simple_Barrier; +end no_exc_prop; diff --git a/gcc/testsuite/gnat.dg/no_final.adb b/gcc/testsuite/gnat.dg/no_final.adb new file mode 100644 index 000000000..b1a63cdf0 --- /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/noreturn1.adb b/gcc/testsuite/gnat.dg/noreturn1.adb new file mode 100644 index 000000000..f854e662b --- /dev/null +++ b/gcc/testsuite/gnat.dg/noreturn1.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } + +package body Noreturn1 is + + procedure Error (E : in Exception_Occurrence) is + Occurrence_Message : constant String := Exception_Message (E); + begin + if Occurrence_Message = "$" then + raise Program_Error; + else + raise Constraint_Error; + end if; + end; + +end Noreturn1; diff --git a/gcc/testsuite/gnat.dg/noreturn1.ads b/gcc/testsuite/gnat.dg/noreturn1.ads new file mode 100644 index 000000000..c63e43999 --- /dev/null +++ b/gcc/testsuite/gnat.dg/noreturn1.ads @@ -0,0 +1,8 @@ +with Ada.Exceptions; use Ada.Exceptions; + +package Noreturn1 is + + procedure Error (E : in Exception_Occurrence); + pragma No_Return (Error); + +end Noreturn1; diff --git a/gcc/testsuite/gnat.dg/noreturn2.adb b/gcc/testsuite/gnat.dg/noreturn2.adb new file mode 100644 index 000000000..5caf222f2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/noreturn2.adb @@ -0,0 +1,23 @@ +-- { dg-do compile } + +package body Noreturn2 is + + procedure Raise_Exception_No_Defer (Message : String); + pragma No_Return (Raise_Exception_No_Defer); + + procedure Raise_From (X : Exception_Occurrence) is + Occurrence_Message : constant String := Exception_Message (X); + begin + if Occurrence_Message = "$" then + Raise_Exception_No_Defer (Occurrence_Message); + else + Raise_Exception_No_Defer ("::" & Occurrence_Message); + end if; + end; + + procedure Raise_Exception_No_Defer (Message : String) is + begin + raise Program_Error; + end; + +end Noreturn2; diff --git a/gcc/testsuite/gnat.dg/noreturn2.ads b/gcc/testsuite/gnat.dg/noreturn2.ads new file mode 100644 index 000000000..1aaf4e974 --- /dev/null +++ b/gcc/testsuite/gnat.dg/noreturn2.ads @@ -0,0 +1,8 @@ +with Ada.Exceptions; use Ada.Exceptions; + +package Noreturn2 is + + procedure Raise_From (X : Exception_Occurrence); + pragma No_Return (Raise_From); + +end Noreturn2; diff --git a/gcc/testsuite/gnat.dg/noreturn3.adb b/gcc/testsuite/gnat.dg/noreturn3.adb new file mode 100644 index 000000000..4457373c3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/noreturn3.adb @@ -0,0 +1,27 @@ +-- { dg-do compile } + +with Ada.Exceptions; + +package body Noreturn3 is + + procedure Raise_Error (E : Enum; ErrorMessage : String) is + + function Msg return String is + begin + return "Error :" & ErrorMessage; + end; + + begin + case E is + when One => + Ada.Exceptions.Raise_Exception (Exc1'Identity, Msg); + + when Two => + Ada.Exceptions.Raise_Exception (Exc2'Identity, Msg); + + when others => + Ada.Exceptions.Raise_Exception (Exc3'Identity, Msg); + end case; + end; + +end Noreturn3; diff --git a/gcc/testsuite/gnat.dg/noreturn3.ads b/gcc/testsuite/gnat.dg/noreturn3.ads new file mode 100644 index 000000000..d830a1491 --- /dev/null +++ b/gcc/testsuite/gnat.dg/noreturn3.ads @@ -0,0 +1,12 @@ +package Noreturn3 is + + Exc1 : Exception; + Exc2 : Exception; + Exc3 : Exception; + + type Enum is (One, Two, Three); + + procedure Raise_Error (E : Enum; ErrorMessage : String); + pragma No_Return (Raise_Error); + +end Noreturn3; diff --git a/gcc/testsuite/gnat.dg/not_null.adb b/gcc/testsuite/gnat.dg/not_null.adb new file mode 100644 index 000000000..3cbd86c16 --- /dev/null +++ b/gcc/testsuite/gnat.dg/not_null.adb @@ -0,0 +1,22 @@ +-- { dg-do run } + +procedure not_null is + type Not_Null_Int_Ptr is not null access all Integer; + + generic + F : Not_Null_Int_Ptr := null; + package GPack is + end GPack; + +begin + declare + pragma Warnings (Off, "*null not allowed in null-excluding objects"); + package Inst_2 is new GPack (null); + pragma Warnings (On, "*null not allowed in null-excluding objects"); + begin + null; + end; +exception + when Constraint_Error => + null; +end not_null; diff --git a/gcc/testsuite/gnat.dg/notnot.adb b/gcc/testsuite/gnat.dg/notnot.adb new file mode 100644 index 000000000..3d4181aaa --- /dev/null +++ b/gcc/testsuite/gnat.dg/notnot.adb @@ -0,0 +1,9 @@ +-- { dg-do compile } +-- { dg-options "-gnatwr" } + +procedure notnot (x, y : integer) is +begin + if not (not (x = y)) then -- { dg-warning "redundant double negation" } + return; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/null_pointer_deref1.adb b/gcc/testsuite/gnat.dg/null_pointer_deref1.adb new file mode 100644 index 000000000..6e7bf14e5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/null_pointer_deref1.adb @@ -0,0 +1,21 @@ +-- { dg-do run } +-- { dg-options "-gnatp" } + +-- This test requires architecture- and OS-specific support code for unwinding +-- through signal frames (typically located in *-unwind.h) to pass. Feel free +-- to disable it if this code hasn't been implemented yet. + +procedure Null_Pointer_Deref1 is + type Int_Ptr is access all Integer; + + function Ident return Int_Ptr is + begin + return null; + end; + + Data : Int_Ptr := Ident; +begin + Data.all := 1; +exception + when Constraint_Error | Storage_Error => null; +end; diff --git a/gcc/testsuite/gnat.dg/null_pointer_deref2.adb b/gcc/testsuite/gnat.dg/null_pointer_deref2.adb new file mode 100644 index 000000000..63e2dd11f --- /dev/null +++ b/gcc/testsuite/gnat.dg/null_pointer_deref2.adb @@ -0,0 +1,28 @@ +-- { dg-do run } +-- { dg-options "-gnatp" } + +-- This test requires architecture- and OS-specific support code for unwinding +-- through signal frames (typically located in *-unwind.h) to pass. Feel free +-- to disable it if this code hasn't been implemented yet. + +procedure Null_Pointer_Deref2 is + + task T; + + task body T is + type Int_Ptr is access all Integer; + + function Ident return Int_Ptr is + begin + return null; + end; + Data : Int_Ptr := Ident; + begin + Data.all := 1; + exception + when Constraint_Error | Storage_Error => null; + end T; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/oalign1.ads b/gcc/testsuite/gnat.dg/oalign1.ads new file mode 100644 index 000000000..26fec130e --- /dev/null +++ b/gcc/testsuite/gnat.dg/oalign1.ads @@ -0,0 +1,5 @@ + +package Oalign1 is + Klunk1 : Integer := 12; + for Klunk1'Alignment use Standard'Maximum_Alignment; +end; diff --git a/gcc/testsuite/gnat.dg/oalign2.ads b/gcc/testsuite/gnat.dg/oalign2.ads new file mode 100644 index 000000000..abe4aca27 --- /dev/null +++ b/gcc/testsuite/gnat.dg/oalign2.ads @@ -0,0 +1,5 @@ + +package Oalign2 is + Klunk2 : Integer := 12; + for Klunk2'Alignment use Standard'Maximum_Alignment; +end; diff --git a/gcc/testsuite/gnat.dg/object_overflow.adb b/gcc/testsuite/gnat.dg/object_overflow.adb new file mode 100644 index 000000000..41b6184fe --- /dev/null +++ b/gcc/testsuite/gnat.dg/object_overflow.adb @@ -0,0 +1,13 @@ +-- { dg-do compile } + +procedure Object_Overflow is + + procedure Proc (x : Boolean) is begin null; end; + + type Arr is array(Long_Integer) of Boolean; + Obj : Arr; -- { dg-warning "Storage_Error" } + +begin + Obj(1) := True; + Proc (Obj(1)); +end; diff --git a/gcc/testsuite/gnat.dg/oconst1.adb b/gcc/testsuite/gnat.dg/oconst1.adb new file mode 100644 index 000000000..1e97ad8f2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/oconst1.adb @@ -0,0 +1,18 @@ +-- { dg-do compile } +-- { dg-final { scan-assembler-not "elabs" } } + +package body OCONST1 is + + procedure check (arg : R) is + begin + if arg.u /= 1 + or else arg.b.i1 /= 2 + or else arg.b.i2 /= 3 + or else arg.b.i3 /= 4 + then + raise Program_Error; + end if; + end; + +end; + diff --git a/gcc/testsuite/gnat.dg/oconst1.ads b/gcc/testsuite/gnat.dg/oconst1.ads new file mode 100644 index 000000000..93b35f79b --- /dev/null +++ b/gcc/testsuite/gnat.dg/oconst1.ads @@ -0,0 +1,25 @@ +package OCONST1 is + + type u8 is mod 2**8; + + type Base is record + i1 : Integer; + i2 : Integer; + i3 : Integer; + end Record; + + type R is record + u : u8; + b : Base; + end record; + + for R use record + u at 0 range 0 .. 7; + b at 1 range 0 .. 95; -- BLKmode bitfield + end record; + + My_R : constant R := (u=>1, b=>(2, 3, 4)); + + procedure check (arg : R); + +end; diff --git a/gcc/testsuite/gnat.dg/oconst2.adb b/gcc/testsuite/gnat.dg/oconst2.adb new file mode 100644 index 000000000..d4f45ad5d --- /dev/null +++ b/gcc/testsuite/gnat.dg/oconst2.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } +-- { dg-final { scan-assembler-not "elabs" } } + +package body OCONST2 is + + procedure check (arg : R) is + begin + if arg.u /= 1 + or else arg.b.i1 /= 2 + then + raise Program_Error; + end if; + end; + +end; diff --git a/gcc/testsuite/gnat.dg/oconst2.ads b/gcc/testsuite/gnat.dg/oconst2.ads new file mode 100644 index 000000000..23e57a74c --- /dev/null +++ b/gcc/testsuite/gnat.dg/oconst2.ads @@ -0,0 +1,23 @@ +package OCONST2 is + + type u8 is mod 2**8; + + type Base is record + i1 : Integer; + end Record; + + type R is record + u : u8; + b : Base; + end record; + + for R use record + u at 0 range 0 .. 7; + b at 1 range 0 .. 31; -- aligned SImode bitfield + end record; + + My_R : constant R := (u=>1, b=>(i1=>2)); + + procedure check (arg : R); + +end; diff --git a/gcc/testsuite/gnat.dg/oconst3.adb b/gcc/testsuite/gnat.dg/oconst3.adb new file mode 100644 index 000000000..c9a94d4f4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/oconst3.adb @@ -0,0 +1,16 @@ +-- { dg-do compile } +-- { dg-final { scan-assembler-not "elabs" } } + +package body OCONST3 is + + procedure check (arg : R) is + begin + if arg.u /= 1 + or else arg.f /= one + or else arg.b.i1 /= 3 + then + raise Program_Error; + end if; + end; + +end; diff --git a/gcc/testsuite/gnat.dg/oconst3.ads b/gcc/testsuite/gnat.dg/oconst3.ads new file mode 100644 index 000000000..6a0094b57 --- /dev/null +++ b/gcc/testsuite/gnat.dg/oconst3.ads @@ -0,0 +1,26 @@ +package OCONST3 is + + type bit is (zero, one); + type u8 is mod 2**8; + + type Base is record + i1 : Integer; + end Record; + + type R is record + u : u8; + f : bit; + b : Base; + end record; + + for R use record + u at 0 range 0 .. 7; + f at 1 range 0 .. 0; + b at 1 range 1 .. 32; -- unaligned SImode bitfield + end record; + + My_R : constant R := (u=>1, f=>one, b=>(i1=>3)); + + procedure check (arg : R); + +end; diff --git a/gcc/testsuite/gnat.dg/oconst4.adb b/gcc/testsuite/gnat.dg/oconst4.adb new file mode 100644 index 000000000..f97f217b3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/oconst4.adb @@ -0,0 +1,24 @@ +-- { dg-do compile } +-- { dg-final { scan-assembler-not "elabs" } } + +package body OCONST4 is + + procedure check (arg : R) is + begin + if arg.u /= 1 + or else arg.d.f1 /= 17 + or else arg.d.b.f1 /= one + or else arg.d.b.f2 /= 2 + or else arg.d.b.f3 /= 17 + or else arg.d.b.f4 /= 42 + or else arg.d.f2 /= one + or else arg.d.f3 /= 1 + or else arg.d.f4 /= 111 + or else arg.d.i1 /= 2 + or else arg.d.i2 /= 3 + then + raise Program_Error; + end if; + end; + +end; diff --git a/gcc/testsuite/gnat.dg/oconst4.ads b/gcc/testsuite/gnat.dg/oconst4.ads new file mode 100644 index 000000000..cde0935fe --- /dev/null +++ b/gcc/testsuite/gnat.dg/oconst4.ads @@ -0,0 +1,66 @@ +package OCONST4 is + + type bit is (zero, one); + type u2 is mod 2**2; + type u5 is mod 2**5; + type u8 is mod 2**8; + + type Base is record + f1 : bit; + f2 : u2; + f3 : u5; + f4 : u8; + end record; + + for Base use record + f1 at 0 range 0 .. 0; + f2 at 0 range 1 .. 2; + f3 at 0 range 3 .. 7; + f4 at 1 range 0 .. 7; + end record; + + type Derived is record + f1 : u5; + b : Base; + f2 : bit; + f3 : u2; + f4 : u8; + i1 : Integer; + i2 : Integer; + end record; + + for Derived use record + f1 at 0 range 0 .. 4; + b at 0 range 5 .. 20; -- unaligned HImode bitfield + f2 at 0 range 21 .. 21; + f3 at 0 range 22 .. 23; + f4 at 0 range 24 .. 31; + i1 at 4 range 0 .. 31; + i2 at 8 range 0 .. 31; + end record; + + type R is record + u : u8; + d : Derived; + end record; + + for R use record + u at 0 range 0 .. 7; + d at 1 range 0 .. 95; -- BLKmode bitfield + end record; + + My_R : constant R := (u=>1, + d=>(f1=>17, + b=>(f1=>one, + f2=>2, + f3=>17, + f4=>42), + f2=>one, + f3=>1, + f4=>111, + i1=>2, + i2=>3)); + + procedure check (arg : R); + +end; diff --git a/gcc/testsuite/gnat.dg/oconst5.adb b/gcc/testsuite/gnat.dg/oconst5.adb new file mode 100644 index 000000000..4d4896aea --- /dev/null +++ b/gcc/testsuite/gnat.dg/oconst5.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } +-- { dg-final { scan-assembler-not "elabs" } } + +package body OCONST5 is + + procedure Check (Arg : R; Bit : U1) is + begin + if Arg.Bit /= Bit + or else Arg.Agg.A /= 3 + or else Arg.Agg.B /= 7 + then + raise Program_Error; + end if; + end; +end; diff --git a/gcc/testsuite/gnat.dg/oconst5.ads b/gcc/testsuite/gnat.dg/oconst5.ads new file mode 100644 index 000000000..f12a265d0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/oconst5.ads @@ -0,0 +1,27 @@ +package OCONST5 is + + type u1 is mod 2**1; + type u8 is mod 2**8; + + type HI_Record is record + A, B : U8; + end record; + pragma Suppress_Initialization (HI_Record); + + type R is record + Bit : U1; + Agg : HI_Record; + end record; + pragma Suppress_Initialization (R); + + for R use record + Bit at 0 range 0 .. 0; + Agg at 0 range 1 .. 16; + end record; + + My_R0 : R := (Bit => 0, Agg => (A => 3, B => 7)); + My_R1 : R := (Bit => 1, Agg => (A => 3, B => 7)); + + procedure Check (Arg : R; Bit : U1); + +end; diff --git a/gcc/testsuite/gnat.dg/old_errors.adb b/gcc/testsuite/gnat.dg/old_errors.adb new file mode 100644 index 000000000..a5e4d4217 --- /dev/null +++ b/gcc/testsuite/gnat.dg/old_errors.adb @@ -0,0 +1,47 @@ +-- { dg-do compile } +package body Old_Errors is + + A : Integer; + + function F + (X : Integer := A'Old) -- { dg-error "can only appear within subprogram" } + return Integer is + begin + return X; + end F; + + procedure P (I : in Integer; O : out Integer; IO : in out Integer) is + Y : Integer := 0; + function G + (X : Integer := Y'Old) -- { dg-error "cannot refer to local variable" } + return Integer is + begin + return X; + end G; + + function H (X : Integer := A'Old) return Integer is -- OK + begin + return X; + end H; + + begin + Y := Y'Old; -- { dg-error "cannot refer to local variable" } + declare + Z : Integer := 0; + procedure Inner is + IL : Integer := 0; + begin + IL := IL'Old; -- { dg-error "cannot refer to local variable" } + Z := Z'Old; -- OK + end Inner; + begin + Y := Z'Old; -- { dg-error "cannot refer to local variable" } + end; + Y := I'Old; -- { dg-warning "Old applied to constant has no effect" } + Y := O'Old; -- OK + Y := IO'Old; -- OK + Y := G; -- OK, error has been signalled at G declaration + pragma Assert (G (3)'Old = Y); -- { dg-error "cannot refer to local variable" } + end P; + +end Old_Errors; diff --git a/gcc/testsuite/gnat.dg/old_errors.ads b/gcc/testsuite/gnat.dg/old_errors.ads new file mode 100644 index 000000000..84717ff06 --- /dev/null +++ b/gcc/testsuite/gnat.dg/old_errors.ads @@ -0,0 +1,5 @@ +package Old_Errors is + + pragma Elaborate_Body; + +end Old_Errors; diff --git a/gcc/testsuite/gnat.dg/opt1.adb b/gcc/testsuite/gnat.dg/opt1.adb new file mode 100644 index 000000000..69bb8136d --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt1.adb @@ -0,0 +1,29 @@ +-- { dg-do compile } +-- { dg-options "-O -gnatws" } + +package body Opt1 is + + function De_Linear_Index + (Index : Natural; + D : Natural; + Ind_Lengths : Dimention_Length) + return Dimension_Indexes + is + Len : Natural := 1; + Tmp_Ind : Natural := Index; + Tmp_Res : Natural; + Result : Dimension_Indexes (1 .. D); + begin + for J in 1 .. D loop + Len := Len * Ind_Lengths (J); + end loop; + + for J in Result'Range loop + Result (J) := Tmp_Res; + Tmp_Ind := Tmp_Ind - Len * (Result (J) - 1); + end loop; + + return Result; + end; + +end Opt1; diff --git a/gcc/testsuite/gnat.dg/opt1.ads b/gcc/testsuite/gnat.dg/opt1.ads new file mode 100644 index 000000000..247e7dc63 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt1.ads @@ -0,0 +1,13 @@ +package Opt1 is + + type Dimention_Length is array (1 .. 16) of Natural; + + type Dimension_Indexes is array (Positive range <>) of Positive; + + function De_Linear_Index + (Index : Natural; + D : Natural; + Ind_Lengths : Dimention_Length) + return Dimension_Indexes; + +end Opt1; diff --git a/gcc/testsuite/gnat.dg/opt10.adb b/gcc/testsuite/gnat.dg/opt10.adb new file mode 100644 index 000000000..5a256a04e --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt10.adb @@ -0,0 +1,26 @@ +-- { dg-do compile } +-- { dg-options "-O2" } + +with Opt10_Pkg; use Opt10_Pkg; + +procedure Opt10 is + + procedure Compare_Rep_Data (MA, MB : Rep_Message) is + begin + if MA.Data /= MB.Data then + raise Program_Error; + end if; + end; + + procedure Check_Rep_For (Bit : Boolean) is + MA, MB : Rep_Message; + begin + Safe_Assign (MA, Bit); + Safe_Assign (MB, Bit); + Compare_Rep_Data (MA, MB); + end; + +begin + Check_Rep_For (Bit => False); +end; + diff --git a/gcc/testsuite/gnat.dg/opt10_pkg.ads b/gcc/testsuite/gnat.dg/opt10_pkg.ads new file mode 100644 index 000000000..8df6dca17 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt10_pkg.ads @@ -0,0 +1,14 @@ +package Opt10_Pkg is + + type Rep_Message is record + Bit : Boolean; + Data : String (1 .. 4); + end record; + for Rep_Message use record + Bit at 0 range 0 .. 0; + Data at 0 range 1 .. 32; + end record; + + procedure Safe_Assign (M : in out Rep_Message; Bit : Boolean); + +end; diff --git a/gcc/testsuite/gnat.dg/opt11.adb b/gcc/testsuite/gnat.dg/opt11.adb new file mode 100644 index 000000000..918981410 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt11.adb @@ -0,0 +1,12 @@ +-- { dg-do compile } +-- { dg-options "-O" } + +package body Opt11 is + + procedure Proc is + R : Rec; + begin + R := (others => <>); + end; + +end Opt11; diff --git a/gcc/testsuite/gnat.dg/opt11.ads b/gcc/testsuite/gnat.dg/opt11.ads new file mode 100644 index 000000000..983bf2643 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt11.ads @@ -0,0 +1,17 @@ +package Opt11 is + + type String_Ptr is access constant String; + + type Form_Type is (Qualified, Unqualified); + + type Rec is record + N1, N2, N3 : Natural; + Fixed : String_Ptr; + Form : Form_Type; + Is_Local : Boolean := True; + end record; + pragma Pack (Rec); + + procedure Proc; + +end Opt11; diff --git a/gcc/testsuite/gnat.dg/opt12.adb b/gcc/testsuite/gnat.dg/opt12.adb new file mode 100644 index 000000000..e8b5c4787 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt12.adb @@ -0,0 +1,18 @@ +-- { dg-do run } +-- { dg-options "-O2" } + +with Opt12_Pkg; use Opt12_Pkg; + +procedure Opt12 is + + Static_Target : Static_Integer_Subtype; + +begin + + Static_Target := Static_Integer_Subtype(Fix_Half); + + if not Equal(Static_Target, 1) then + raise Program_Error; + end if; + +end Opt12; diff --git a/gcc/testsuite/gnat.dg/opt12_pkg.adb b/gcc/testsuite/gnat.dg/opt12_pkg.adb new file mode 100644 index 000000000..646c8734c --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt12_pkg.adb @@ -0,0 +1,8 @@ +package body Opt12_Pkg is + + function Equal (L, R: Static_Integer_Subtype) return Boolean is + begin + return (L = R); + end; + +end Opt12_Pkg; diff --git a/gcc/testsuite/gnat.dg/opt12_pkg.ads b/gcc/testsuite/gnat.dg/opt12_pkg.ads new file mode 100644 index 000000000..4defe2b77 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt12_pkg.ads @@ -0,0 +1,11 @@ +package Opt12_Pkg is + + type Static_Integer_Subtype is range -32_000 .. 32_000; + + function Equal (L, R: Static_Integer_Subtype) return Boolean; + + type My_Fixed is delta 0.1 range -5.0 .. 5.0; + + Fix_Half : My_Fixed := 0.5; + +end Opt12_Pkg; diff --git a/gcc/testsuite/gnat.dg/opt13.adb b/gcc/testsuite/gnat.dg/opt13.adb new file mode 100644 index 000000000..9e47957e9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt13.adb @@ -0,0 +1,13 @@ +-- { dg-do run } +-- { dg-options "-O" } + +with Opt13_Pkg; use Opt13_Pkg; + +procedure Opt13 is + T : My_Type; +begin + Allocate (T); + if N /= 1 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/opt13_pkg.adb b/gcc/testsuite/gnat.dg/opt13_pkg.adb new file mode 100644 index 000000000..850022766 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt13_pkg.adb @@ -0,0 +1,31 @@ +package body Opt13_Pkg is + + subtype Index_Type is Natural range 0 .. 16; + + type Arr is array (Index_Type range <>) of Integer; + + type Rec is record + F1, F2, F3 : Float; + N : Natural; + B1, B2 : Boolean; + F4 : Float; + end record; + + type Data (D : Index_Type) is record + A : Arr (1 .. D); + R : Rec; + end record; + + Zero : constant Rec := (0.0, 0.0, 0.0, 0, False, False, 0.0); + + procedure Allocate (T : out My_Type) is + begin + T := new Data (Index_Type'last); + T.R := Zero; + + for I in 1 .. T.A'last loop + N := 1; + end loop; + end; + +end Opt13_Pkg; diff --git a/gcc/testsuite/gnat.dg/opt13_pkg.ads b/gcc/testsuite/gnat.dg/opt13_pkg.ads new file mode 100644 index 000000000..f52f782f4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt13_pkg.ads @@ -0,0 +1,15 @@ +package Opt13_Pkg is + + N : Natural := 0; + + type My_Type is private; + + procedure Allocate (T : out My_Type); + +private + + type Data; + + type My_Type is access Data; + +end Opt13_Pkg; diff --git a/gcc/testsuite/gnat.dg/opt14.adb b/gcc/testsuite/gnat.dg/opt14.adb new file mode 100644 index 000000000..61bc7313b --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt14.adb @@ -0,0 +1,25 @@ +-- { dg-do run } +-- { dg-options "-O2" } + +procedure Opt14 is + + type Rec is record + I1, I2, I3 : Integer; + end record; + + type Ptr is access Rec; + + P : Ptr := new Rec'(0,0,0); + + procedure Sub (R : In Out Rec) is + begin + R.I3 := R.I3 - 1; + end; + +begin + P.all := (1,2,3); + Sub (P.all); + if P.all /= (1,2,2) then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/opt17.adb b/gcc/testsuite/gnat.dg/opt17.adb new file mode 100644 index 000000000..361f7607b --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt17.adb @@ -0,0 +1,13 @@ +-- { dg-do compile } +-- { dg-options "-O" } + +package body Opt17 is + + function Func return S is + V : String (1 .. 6); + begin + V (1 .. 3) := "ABC"; + return V (1 .. 5); + end; + +end Opt17; diff --git a/gcc/testsuite/gnat.dg/opt17.ads b/gcc/testsuite/gnat.dg/opt17.ads new file mode 100644 index 000000000..601c2f201 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt17.ads @@ -0,0 +1,7 @@ +package Opt17 is + + subtype S is String (1 .. 5); + + function Func return S; + +end Opt17; diff --git a/gcc/testsuite/gnat.dg/opt2.adb b/gcc/testsuite/gnat.dg/opt2.adb new file mode 100644 index 000000000..a6c247fdb --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt2.adb @@ -0,0 +1,31 @@ +-- { dg-do run } +-- { dg-options "-O2 -fno-inline" } + +procedure Opt2 is + function Get return String is + begin + return "[]"; + end Get; + + Message : String := Get; + + F, L : Integer; +begin + for J in Message'Range loop + if Message (J) = '[' then + F := J; + elsif Message (J) = ']' then + L := J; + exit; + end if; + end loop; + + declare + M : String := + Message (Message'First .. F) & Message (L .. Message'Last); + begin + if M /= "[]" then + raise Program_Error; + end if; + end; +end; diff --git a/gcc/testsuite/gnat.dg/opt26.adb b/gcc/testsuite/gnat.dg/opt26.adb new file mode 100644 index 000000000..61f8b5b1e --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt26.adb @@ -0,0 +1,37 @@ +-- { dg-do run } +-- { dg-options "-gnato -O" } + +with Interfaces; use Interfaces; + +procedure Opt26 is + + procedure Shift_Left_Bool + (Bool : in Boolean; + U8 : out Interfaces.Unsigned_8) + is + begin + U8 := Shift_Left (Boolean'Pos (Bool), 6); + end Shift_Left_Bool; + + procedure Shift_Left_Not_Bool + (Bool : in Boolean; + U8 : out Interfaces.Unsigned_8) + is + begin + U8 := Shift_Left (Boolean'Pos (not Bool), 6); + end Shift_Left_Not_Bool; + + Bool : constant Boolean := True; + Byte1, Byte2 : Interfaces.Unsigned_8; + +begin + + Shift_Left_Bool (Bool, Byte1); + + Shift_Left_Not_Bool (Bool, Byte2); + + if Byte1 + Byte2 /= 64 then + raise Program_Error; + end if; + +end; diff --git a/gcc/testsuite/gnat.dg/opt3.adb b/gcc/testsuite/gnat.dg/opt3.adb new file mode 100644 index 000000000..b8ca2c7fb --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt3.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } +-- { dg-options "-O3" } + +with Opt3_Pkg; use Opt3_Pkg; + +procedure Opt3 is + type Buffer_Type is array (Integer range <> ) of Short_Integer; + B : Buffer_Type (1 .. 256) := (others => 0); +begin + F (B(1)); +end; diff --git a/gcc/testsuite/gnat.dg/opt3_pkg.ads b/gcc/testsuite/gnat.dg/opt3_pkg.ads new file mode 100644 index 000000000..458a98be2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt3_pkg.ads @@ -0,0 +1,5 @@ +package Opt3_Pkg is + + procedure F (I : Short_Integer); + +end Opt3_Pkg; diff --git a/gcc/testsuite/gnat.dg/opt4.adb b/gcc/testsuite/gnat.dg/opt4.adb new file mode 100644 index 000000000..caa5ab3a6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt4.adb @@ -0,0 +1,22 @@ +-- { dg-do run } +-- { dg-options "-O2" } + +procedure Opt4 is + + type Rec (D : Natural) is record + S : String (1..D); + end record; + + procedure Test (R : Rec) is + begin + if R.D /= 9 then + raise Program_Error; + end if; + end; + + R : Rec(9); + +begin + R := (9, "123456789"); + Test (R); +end; diff --git a/gcc/testsuite/gnat.dg/opt5.adb b/gcc/testsuite/gnat.dg/opt5.adb new file mode 100644 index 000000000..73a21bde0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt5.adb @@ -0,0 +1,21 @@ +-- { dg-do run } +-- { dg-options "-O2" } + +procedure Opt5 is + + type Varray is array (1 .. 4) of Natural; + + procedure Check_All_Ones (A : Varray) is + begin + for J in A'Range loop + if (A (J)) /= 1 then + raise Program_Error; + end if; + end loop; + end; + + X : constant Varray := (1, 1, 1, 1); + +begin + Check_All_Ones (X); +end; diff --git a/gcc/testsuite/gnat.dg/opt6.adb b/gcc/testsuite/gnat.dg/opt6.adb new file mode 100644 index 000000000..44dc047b5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt6.adb @@ -0,0 +1,28 @@ +-- PR rtl-optimization/45394 + +-- { dg-do compile } +-- { dg-options "-O2 -g" } + +package body Opt6 is + + function Current_Parameter (Iter : Command_Line_Iterator) return String is + begin + if Iter.Params = null + or else Iter.Current > Iter.Params'Last + or else Iter.Params (Iter.Current) = null + then + return ""; + + else + declare + P : constant String := Iter.Params (Iter.Current).all; + + begin + -- Skip separator + + return P (P'First + 1 .. P'Last); + end; + end if; + end Current_Parameter; + +end Opt6; diff --git a/gcc/testsuite/gnat.dg/opt6.ads b/gcc/testsuite/gnat.dg/opt6.ads new file mode 100644 index 000000000..f04985316 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt6.ads @@ -0,0 +1,14 @@ +package Opt6 is + + type String_Access is access all String; + type String_List is array (Positive range <>) of String_Access; + type String_List_Access is access all String_List; + + type Command_Line_Iterator is record + Params : String_List_Access; + Current : Natural; + end record; + + function Current_Parameter (Iter : Command_Line_Iterator) return String; + +end Opt6; diff --git a/gcc/testsuite/gnat.dg/opt7.adb b/gcc/testsuite/gnat.dg/opt7.adb new file mode 100644 index 000000000..da3b0e6df --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt7.adb @@ -0,0 +1,44 @@ +-- { dg-do compile }
+-- { dg-options "-Os -g" }
+
+with Opt7_Pkg;
+
+package body Opt7 is
+
+ procedure Parse (Str : String;
+ Time_Type : out time_t;
+ Abs_Time : out Time;
+ Delt_Time : out Duration) is
+ Year : Year_Number;
+ Month : Month_Number;
+ Day : Day_Number;
+ Minute : Integer := 0;
+ Idx : Integer := Str'First;
+ Ch : Character := Str (Idx);
+ Current_Time : Time;
+
+ begin
+ if Ch = '-' then
+ Time_Type := Absolute_Time;
+ Current_Time := Clock;
+ Day := Ada.Calendar.Day (Current_Time);
+ Month := Ada.Calendar.Month (Current_Time);
+ Year := Ada.Calendar.Year (Current_Time);
+ else
+ Time_Type := Delta_Time;
+ end if;
+ while Ch in '0' .. '9' loop
+ Minute := Minute + Character'Pos (Ch);
+ Idx := Idx + 1;
+ Ch := Str (Idx);
+ end loop;
+ if Time_Type = Absolute_Time then
+ Abs_Time := Time_Of (Year, Month, Day, Day_Duration (1));
+ else
+ Delt_Time := Duration (Float (Minute));
+ end if;
+ exception
+ when others => Opt7_Pkg.My_Raise_Exception;
+ end;
+
+end Opt7;
diff --git a/gcc/testsuite/gnat.dg/opt7.ads b/gcc/testsuite/gnat.dg/opt7.ads new file mode 100644 index 000000000..c98035326 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt7.ads @@ -0,0 +1,12 @@ +with Ada.Calendar; use Ada.Calendar;
+
+package Opt7 is
+
+ type time_t is (Absolute_Time, Delta_Time);
+
+ procedure Parse (Str : String;
+ Time_Type : out time_t;
+ Abs_Time : out Time;
+ Delt_Time : out Duration);
+
+end Opt7;
diff --git a/gcc/testsuite/gnat.dg/opt7_pkg.ads b/gcc/testsuite/gnat.dg/opt7_pkg.ads new file mode 100644 index 000000000..db24f5dac --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt7_pkg.ads @@ -0,0 +1,5 @@ +package Opt7_Pkg is + + procedure My_Raise_Exception; + +end Opt7_Pkg; diff --git a/gcc/testsuite/gnat.dg/opt8.adb b/gcc/testsuite/gnat.dg/opt8.adb new file mode 100644 index 000000000..72145fd6b --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt8.adb @@ -0,0 +1,48 @@ +-- { dg-do compile } +-- { dg-options "-O2" } + +with Opt8_Pkg; + +package body Opt8 is + + function Content_Value (Rec : Kappa_Component_Rec) + return Value_Number is + begin + return Opt8_Pkg.Id_To_VN (Rec.Content_VN); + end; + + function Possible_Values_Count (V: Kappa_Component_Ptr) return Natural is + Result : Natural := 0; + List : Kappa_Component_Ptr := V; + begin + while List /= null loop + Result := Result +1; + List := List.Next; + end loop; + return Result; + end; + + function VN_Complexity (Val : Value_Number; N : Natural) + return Natural is + Result : Natural := 0; + begin + case Val.Kind is + when Membership_VN => + Result := VN_Complexity(Val, N); + when Selected_Address_VN => + Result := VN_Complexity(Val, N) + 1; + when Kappa_VN => + Result := Possible_Values_Count(Val.Possible_New_Values)*3; + if Val.Use_Default then + if Result < N then + Result := Result + + VN_Complexity(Content_Value (Val.old_Value), N); + end if; + end if; + when others => + Result := 0; + end case; + return Result; + end; + +end Opt8; diff --git a/gcc/testsuite/gnat.dg/opt8.ads b/gcc/testsuite/gnat.dg/opt8.ads new file mode 100644 index 000000000..57d84a293 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt8.ads @@ -0,0 +1,46 @@ +package Opt8 is + + type Value_Number_Kind is + (Int_Literal_VN, + Selected_Address_VN, + Membership_VN, + Initial_External_Kappa_VN, + Aliased_Kappa_VN, + Phi_As_Kappa_VN, + Multi_Target_Call_Kappa_VN, + Final_Value_Of_Seq_Kappa_VN, + Block_Kappa_VN); + + subtype Kappa_VN is Value_Number_Kind + range Initial_External_Kappa_VN .. Block_Kappa_VN; + + type Value_Number_Id is new Positive; + + type Kappa_Component_Rec; + + type Kappa_Component_Ptr is access Kappa_Component_Rec; + + type Kappa_Component_Rec is record + Content_VN : Value_Number_Id; + Next : Kappa_Component_Ptr; + end record; + + type Value_Number_Rec(Kind : Value_Number_Kind) is record + Id: Value_Number_Id; + case Kind is + when Int_Literal_VN => + Int_Val : Integer; + when Kappa_VN => + Old_Value : Kappa_Component_Rec; + Possible_New_Values : Kappa_Component_Ptr; + Use_Default : Boolean; + when Others => + null; + end case; + end record; + + type Value_Number is access all Value_Number_Rec; + + function VN_Complexity (Val : Value_Number; N : Natural) return Natural; + +end Opt8; diff --git a/gcc/testsuite/gnat.dg/opt8_pkg.ads b/gcc/testsuite/gnat.dg/opt8_pkg.ads new file mode 100644 index 000000000..3e39f1177 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt8_pkg.ads @@ -0,0 +1,7 @@ +with Opt8; use Opt8; + +package Opt8_Pkg is + + function Id_To_VN (Id: Value_Number_Id) return Value_Number; + +end Opt8_Pkg; diff --git a/gcc/testsuite/gnat.dg/opt9.adb b/gcc/testsuite/gnat.dg/opt9.adb new file mode 100644 index 000000000..a0f1ac5c6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt9.adb @@ -0,0 +1,26 @@ +-- { dg-do compile } +-- { dg-options "-gnatws -O" } + +with Opt9_Pkg; use Opt9_Pkg; + +procedure Opt9 is + + type Array_T is array (1 .. N) of Integer; + + type Clock_T is record + N_Ticks : Integer := 0; + end record; + + type Rec is record + Values : Array_T; + Valid : Boolean; + Tstamp : Clock_T; + end record; + + pragma Pack (Rec); + + Data : Rec; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/opt9_pkg.ads b/gcc/testsuite/gnat.dg/opt9_pkg.ads new file mode 100644 index 000000000..beffac26f --- /dev/null +++ b/gcc/testsuite/gnat.dg/opt9_pkg.ads @@ -0,0 +1,5 @@ +package Opt9_Pkg is + + N : integer := 15; + +end Opt9_Pkg; diff --git a/gcc/testsuite/gnat.dg/outer_agg_bitfield_constructor.adb b/gcc/testsuite/gnat.dg/outer_agg_bitfield_constructor.adb new file mode 100644 index 000000000..6658042e9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/outer_agg_bitfield_constructor.adb @@ -0,0 +1,44 @@ +-- { dg-do run } + +procedure Outer_Agg_Bitfield_Constructor is + + type Mod_64 is mod 2 ** 64; + for Mod_64'Size use 64; + + type Uint_16 is range 0 .. 2 ** 16 - 1; + for Uint_16'Size use 16; + + type Values_Type is record + M64 : Mod_64; + U16 : Uint_16; + end record; + + for Values_Type use record + M64 at 0 range 0 .. 63; + U16 at 8 range 0 .. 15; + end record; + + type Wrapper_Type is record + Values : Values_Type; + end record; + + for Wrapper_Type use record + Values at 0 range 0 .. 79; + end record; + + M : constant := 2; + U : constant := 4; + + W : Wrapper_Type := (Values => (M, U)); + + procedure Check (O : Wrapper_Type) is + begin + if O.Values.M64 /= M or else O.Values.U16 /= U then + raise Program_Error; + end if; + end; +begin + Check (W); +end; + + diff --git a/gcc/testsuite/gnat.dg/overflow_sum.adb b/gcc/testsuite/gnat.dg/overflow_sum.adb new file mode 100644 index 000000000..56d8fe99e --- /dev/null +++ b/gcc/testsuite/gnat.dg/overflow_sum.adb @@ -0,0 +1,45 @@ +-- { dg-do run } +-- { dg-options "-gnato" } + +procedure Overflow_Sum is + + function sum (a, b, c, d, e, f, g, h, i, j, k, l, m, + n, o, p, q, r, s, t, u, v, w, x, y, z : Integer) + return Integer + is + begin + return a + b + c + d + e + f + g + h + i + j + k + l + m + + n + o + p + q + r + s + t + u + v + w + x + y + z; + end; + + f : integer; +begin + f := sum (a => -2**31, b => 1, c => 2**31 - 1, -- 0 + d => 1, e => -2**31, f => 2**31 - 1, -- 0 + g => 2**0, h => 2, i => 4, -- 2**3 - 1 + j => 2**3, k => 2**4, l => 2**5, -- 2**6 - 1 + m => 2**6, n => 2**7, o => 2**8, -- 2**9 - 1 + p => 2**9, q => 2**10, r => 2**11, -- 2**12 - 1 + s => 2**12, t => 2**13, u => 2**14, -- 2**15 - 1 + v => 2**15, w => 2**16, x => 2**17, -- 2**18 - 1 + y => 2**31 - 2**18, z => 0); -- 2**31 - 1 + + if f /= 2**31 - 1 then + raise Program_Error; + end if; + + begin + f := sum (a => f, b => -2**31, c => 1, -- 0 + d => -2**31, e => 1, f => f, -- 0 + g => 2**0, h => 2, i => 4, -- 2**3 - 1 + j => 2**3, k => 2**4, l => 2**5, -- 2**6 - 1 + m => 2**6, n => 2**7, o => 2**8, -- 2**9 - 1 + p => 2**9, q => 2**10, r => 2**11, -- 2**12 - 1 + s => 2**12, t => 2**13, u => 2**14, -- 2**15 - 1 + v => 2**15, w => 2**16, x => 2**17, -- 2**18 - 1 + y => 2**31 - 2**18, z => 1); -- 2**31 (overflow) + raise Program_Error; + exception + when Constraint_Error => null; + end; +end; diff --git a/gcc/testsuite/gnat.dg/overflow_sum2.adb b/gcc/testsuite/gnat.dg/overflow_sum2.adb new file mode 100644 index 000000000..8374eee13 --- /dev/null +++ b/gcc/testsuite/gnat.dg/overflow_sum2.adb @@ -0,0 +1,32 @@ +-- { dg-do compile } +-- { dg-options "-gnato" } + +with Namet; use Namet; + +function Overflow_Sum2 return Hash_Index_Type is + + Even_Name_Len : Integer; + +begin + + if Name_Len > 12 then + Even_Name_Len := (Name_Len) / 2 * 2; + + return (((((((((((( + Character'Pos (Name_Buffer (01))) * 2 + + Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 + + Character'Pos (Name_Buffer (03))) * 2 + + Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 + + Character'Pos (Name_Buffer (05))) * 2 + + Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 + + Character'Pos (Name_Buffer (07))) * 2 + + Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 + + Character'Pos (Name_Buffer (09))) * 2 + + Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 + + Character'Pos (Name_Buffer (11))) * 2 + + Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num; + end if; + + return 0; + +end; diff --git a/gcc/testsuite/gnat.dg/overriding_ops.adb b/gcc/testsuite/gnat.dg/overriding_ops.adb new file mode 100644 index 000000000..5ffa8a9ae --- /dev/null +++ b/gcc/testsuite/gnat.dg/overriding_ops.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } + +package body overriding_ops is + task body Light_Programmer is + begin + accept Set_Name (Name : Name_Type); + end Light_Programmer; + + protected body Light is + procedure Set_Name (Name : Name_Type) is + begin + L_Name := Name; + end Set_Name; + end Light; +end overriding_ops; diff --git a/gcc/testsuite/gnat.dg/overriding_ops.ads b/gcc/testsuite/gnat.dg/overriding_ops.ads new file mode 100644 index 000000000..5b228821b --- /dev/null +++ b/gcc/testsuite/gnat.dg/overriding_ops.ads @@ -0,0 +1,12 @@ +with overriding_ops_p; use overriding_ops_p; +package overriding_ops is + task type Light_Programmer is new Device with + overriding entry Set_Name (Name : Name_Type); + end Light_Programmer; + -- Object that represents a light + protected type Light is new Device with + overriding procedure Set_Name (Name : Name_Type); + private + L_Name : Name_Type; + end Light; +end overriding_ops; diff --git a/gcc/testsuite/gnat.dg/overriding_ops_p.ads b/gcc/testsuite/gnat.dg/overriding_ops_p.ads new file mode 100644 index 000000000..cd6e32fe0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/overriding_ops_p.ads @@ -0,0 +1,8 @@ +package overriding_ops_p is + subtype Name_Type is String (1 .. 30); + type Device is synchronized interface; + -- Base type of devices + procedure Set_Name (Object : in out Device; Name : Name_Type) + is abstract; + -- Set the name of the Device +end overriding_ops_p; diff --git a/gcc/testsuite/gnat.dg/pack1.ads b/gcc/testsuite/gnat.dg/pack1.ads new file mode 100644 index 000000000..de42d4c78 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack1.ads @@ -0,0 +1,7 @@ +package Pack1 is + package Nested is + type Rec_Typ is record + null; + end record; + end Nested; +end Pack1; diff --git a/gcc/testsuite/gnat.dg/pack10.adb b/gcc/testsuite/gnat.dg/pack10.adb new file mode 100644 index 000000000..945e404d2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack10.adb @@ -0,0 +1,34 @@ +-- { dg-do run } + +procedure Pack10 is + + type U16 is mod 2**16; + type U8 is mod 2**8; + + type R is record + A : U16; + B : U8; + end record; + + type M is array (1..2) of R; + pragma Pack (M); + -- This size clause can actually be omitted + for M'Size use 48; + + type R2 is record + C : M; + D : U8; + end record; + for R2 use record + C at 0 range 0 .. 24*2-1; + end record; + + My_R2 : R2; + +begin + My_R2.D := 1; + My_R2.C(2).B := 0; + if My_R2.D /=1 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/pack11.adb b/gcc/testsuite/gnat.dg/pack11.adb new file mode 100644 index 000000000..479062b5f --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack11.adb @@ -0,0 +1,29 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +with System; + +procedure Pack11 is + + type R1 is record + A1, A2, A3 : System.Address; + end record; + + type R2 is record + C : Character; + R : R1; + end record; + pragma Pack (R2); + + procedure Dummy (R : R1) is begin null; end; + + procedure Init (X : R2) is + begin + Dummy (X.R); + end; + + My_R2 : R2; + +begin + Init (My_R2); +end; diff --git a/gcc/testsuite/gnat.dg/pack12.adb b/gcc/testsuite/gnat.dg/pack12.adb new file mode 100644 index 000000000..640ace325 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack12.adb @@ -0,0 +1,31 @@ +-- { dg-do run } + +procedure Pack12 is + + type U16 is mod 2 ** 16; + + type Key is record + Value : U16; + Valid : Boolean; + end record; + + type Key_Buffer is record + Current, Latch : Key; + end record; + + type Block is record + Keys : Key_Buffer; + Stamp : U16; + end record; + pragma Pack (Block); + + My_Block : Block; + My_Stamp : constant := 16#1234#; + +begin + My_Block.Stamp := My_Stamp; + My_Block.Keys.Latch := My_Block.Keys.Current; + if My_Block.Stamp /= My_Stamp then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/pack13.adb b/gcc/testsuite/gnat.dg/pack13.adb new file mode 100644 index 000000000..dd9cb09cf --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack13.adb @@ -0,0 +1,10 @@ +-- [ dg-do compile } + +package body Pack13 is + + procedure Set (Myself : Object_Ptr; The_Data : Thirty_Two_Bits.Object) is + begin + Myself.Something.Data_1 := The_Data; + end; + +end Pack13; diff --git a/gcc/testsuite/gnat.dg/pack13.ads b/gcc/testsuite/gnat.dg/pack13.ads new file mode 100644 index 000000000..1836311e7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack13.ads @@ -0,0 +1,33 @@ +with Pack13_Pkg; + +package Pack13 is + + package Four_Bits is new Pack13_Pkg (4); + package Thirty_Two_Bits is new Pack13_Pkg (32); + + type Object is private; + type Object_Ptr is access all Object; + + procedure Set (Myself : Object_Ptr; The_Data : Thirty_Two_Bits.Object); + +private + + type Some_Record is record + Data_1 : Thirty_Two_Bits.Object; + Data_2 : Thirty_Two_Bits.Object; + Small_Data : Four_Bits.Object; + end record; + for Some_Record use record + Data_1 at 0 range 0 .. 31; + Data_2 at 4 range 0 .. 31; + Small_Data at 8 range 0 .. 3; + end record; + + type Object is record + Something : Some_Record; + end record; + for Object use record + Something at 0 range 0 .. 67; + end record; + +end Pack13; diff --git a/gcc/testsuite/gnat.dg/pack13_pkg.ads b/gcc/testsuite/gnat.dg/pack13_pkg.ads new file mode 100644 index 000000000..afe8bec8f --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack13_pkg.ads @@ -0,0 +1,17 @@ +generic + + Size : Positive; + +package Pack13_Pkg is + + type Object is private; + +private + + type Bit is range 0 .. 1; + for Bit'size use 1; + + type Object is array (1 .. Size) of Bit; + pragma Pack (Object); + +end Pack13_Pkg; diff --git a/gcc/testsuite/gnat.dg/pack14.adb b/gcc/testsuite/gnat.dg/pack14.adb new file mode 100644 index 000000000..b3764316b --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack14.adb @@ -0,0 +1,16 @@ +-- { dg-do compile } + +procedure Pack14 is + + subtype False_T is Boolean range False .. False; + + type Rec is record + F : False_T; + end record; + pragma Pack (Rec); + + A : Rec := (F => False); + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/pack15.adb b/gcc/testsuite/gnat.dg/pack15.adb new file mode 100644 index 000000000..019b2da0f --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack15.adb @@ -0,0 +1,10 @@ +-- { dg-do compile } + +package body Pack15 is + + procedure Transfer is + begin + O.Status_Flags := Status_Flags; + end; + +end Pack15; diff --git a/gcc/testsuite/gnat.dg/pack15.ads b/gcc/testsuite/gnat.dg/pack15.ads new file mode 100644 index 000000000..94be462c0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack15.ads @@ -0,0 +1,22 @@ +package Pack15 is + + type Flags is array (1..2) of Boolean; + for Flags'Component_Size use 1; + + type Messages is record + Status_Flags : Flags; + end record; + + for Messages use record + Status_Flags at 0 range 1 .. 2; + end record; + + O : Messages; + + Buffer : Integer; + Status_Flags : Flags; + for Status_Flags'Address use Buffer'Address; + + procedure Transfer; + +end Pack15; diff --git a/gcc/testsuite/gnat.dg/pack2.adb b/gcc/testsuite/gnat.dg/pack2.adb new file mode 100644 index 000000000..7837c8ad8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack2.adb @@ -0,0 +1,22 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +procedure Pack2 is + + type Bits_T is record + B0, B1, B2: Boolean; + end record; + + type State_T is record + Valid : Boolean; + Value : Bits_T; + end record; + pragma Pack (State_T); + + procedure Process (Bits : Bits_T) is begin null; end; + + State : State_T; + +begin + Process (State.Value); +end; diff --git a/gcc/testsuite/gnat.dg/pack3.adb b/gcc/testsuite/gnat.dg/pack3.adb new file mode 100644 index 000000000..06f71cbe9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack3.adb @@ -0,0 +1,31 @@ +-- { dg-do run } + +procedure Pack3 is + + type U32 is mod 2 ** 32; + + type Key is record + Value : U32; + Valid : Boolean; + end record; + + type Key_Buffer is record + Current, Latch : Key; + end record; + + type Block is record + Keys : Key_Buffer; + Stamp : U32; + end record; + pragma Pack (Block); + + My_Block : Block; + My_Stamp : constant := 16#01234567#; + +begin + My_Block.Stamp := My_Stamp; + My_Block.Keys.Latch := My_Block.Keys.Current; + if My_Block.Stamp /= My_Stamp then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/pack4.adb b/gcc/testsuite/gnat.dg/pack4.adb new file mode 100644 index 000000000..2c73e1dd4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack4.adb @@ -0,0 +1,38 @@ +-- { dg-do run } + +procedure Pack4 is + + type Time_T is record + Hour : Integer; + end record; + + type Date_And_Time_T is record + Date : Integer; + Time : Time_T; + end record; + + pragma Pack(Date_And_Time_T); + + procedure + Assign_Hour_Of (T : out Time_T) + is + begin + T.Hour := 44; + end; + + procedure + Clobber_Hour_Of (DT: out Date_And_Time_T) + is + begin + Assign_Hour_Of (Dt.Time); + end; + + DT : Date_And_Time_T; + +begin + DT.Time.Hour := 22; + Clobber_Hour_Of (DT); + if DT.Time.Hour /= 44 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/pack5.adb b/gcc/testsuite/gnat.dg/pack5.adb new file mode 100644 index 000000000..12bea11a3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack5.adb @@ -0,0 +1,32 @@ +-- { dg-do compile } + +procedure Pack5 is + + type Kind is (v1, v2, v3); + + type Error (k : Kind := Kind'First) is record + case k is + when v1 => + null; + when v2 => + null; + when Others => + B : Boolean; + end case; + end record; + pragma Pack (Error); + for Error'Size use 16; + + No_Error: constant Error := (k => v2); + + type R (B : Boolean) is record + E : Error; + end record; + pragma Pack(R); + type Ptr is access R; + + C : Ptr := new R (True); + +begin + C.E := No_Error; +end; diff --git a/gcc/testsuite/gnat.dg/pack6.adb b/gcc/testsuite/gnat.dg/pack6.adb new file mode 100644 index 000000000..d846ed12c --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack6.adb @@ -0,0 +1,27 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +procedure Pack6 is + + type R is record + I : Integer; + a, b, c, d, e : Character; + end record; + + type Ar1 is array (1..4) of R; + type Ar2 is array (1..4) of R; + pragma Pack (Ar2); + + type R2 is record + A : Ar2; + end record; + for R2 use record + A at 0 range 0 .. 72*4-1; + end record; + + X : Ar1; + Y : Ar2; + +begin + Y (1) := X (1); +end; diff --git a/gcc/testsuite/gnat.dg/pack7.adb b/gcc/testsuite/gnat.dg/pack7.adb new file mode 100644 index 000000000..000e7fa81 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack7.adb @@ -0,0 +1,27 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +procedure Pack7 is + + type R is record + I : Integer; + a, b : Character; + end record; + + type Ar1 is array (1..4) of R; + type Ar2 is array (1..4) of R; + pragma Pack (Ar2); + + type R2 is record + A : Ar2; + end record; + for R2 use record + A at 0 range 0 .. 48*4-1; + end record; + + X : Ar1; + Y : Ar2; + +begin + Y (1) := X (1); +end; diff --git a/gcc/testsuite/gnat.dg/pack8.adb b/gcc/testsuite/gnat.dg/pack8.adb new file mode 100644 index 000000000..a3a83bab0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack8.adb @@ -0,0 +1,27 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +procedure Pack8 is + + type R is record + I : Integer; + a, b : Character; + end record; + + type Ar1 is array (1..4) of R; + type Ar2 is array (1..4) of R; + pragma Pack (Ar2); + + type R2 is record + A : Ar2; + end record; + for R2 use record + A at 0 range 0 .. 48*4-1-1; -- { dg-error "too small" } + end record; + + X : Ar1; + Y : Ar2; + +begin + Y (1) := X (1); +end; diff --git a/gcc/testsuite/gnat.dg/pack9.adb b/gcc/testsuite/gnat.dg/pack9.adb new file mode 100644 index 000000000..7e74050d3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack9.adb @@ -0,0 +1,19 @@ +-- { dg-do compile } +-- { dg-options "-O2 -gnatp -fdump-tree-optimized" } +-- See PR tree-optimization/46801 for the expected failure + +package body Pack9 is + + procedure Copy (X, Y : R2_Ptr) is + T : R2 := Y.all; + begin + if T.I2 /= Y.I2 then + raise Program_Error; + end if; + X.all := T; + end; + +end Pack9; + +-- { dg-final { scan-tree-dump-not "gnat_rcheck" "optimized" } } +-- { dg-final { cleanup-tree-dump "optimized" } } diff --git a/gcc/testsuite/gnat.dg/pack9.ads b/gcc/testsuite/gnat.dg/pack9.ads new file mode 100644 index 000000000..00202a97f --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack9.ads @@ -0,0 +1,18 @@ +package Pack9 is + + type R1 is record + I : Integer; + C : Character; + end record; + + type R2 is record + I1, I2 : Integer; + A : R1; + end record; + pragma Pack(R2); + + type R2_Ptr is access all R2; + + procedure Copy (X, Y : R2_Ptr); + +end Pack9; diff --git a/gcc/testsuite/gnat.dg/packed_subtype.adb b/gcc/testsuite/gnat.dg/packed_subtype.adb new file mode 100644 index 000000000..925440a41 --- /dev/null +++ b/gcc/testsuite/gnat.dg/packed_subtype.adb @@ -0,0 +1,24 @@ +-- { dg-do run } + +procedure Packed_Subtype is + + subtype Ubyte is Integer range 0 .. 255; + type Packet (Id : Ubyte) is record + A, B : Ubyte; + end record; + pragma Pack (Packet); + + subtype My_Packet is Packet (Id => 1); + + MP : My_Packet; +begin + MP.A := 1; + MP.B := 2; + + if MP.A /= 1 or else MP.B /= 2 then + raise Program_Error; + end if; +end; + + + diff --git a/gcc/testsuite/gnat.dg/pak.adb b/gcc/testsuite/gnat.dg/pak.adb new file mode 100644 index 000000000..0430482f3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pak.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } +package body Pak is + pragma Suppress (Discriminant_Check); + -- Suppress discriminant check to prevent the assignment from using + -- the predefined primitive _assign. + + procedure Initialize (X : in out T) is begin null; end Initialize; + procedure Finalize (X : in out T) is begin null; end Finalize; + + procedure Assign (X : out T'Class) is + Y : T; + begin + T (X) := Y; + end Assign; +end Pak; diff --git a/gcc/testsuite/gnat.dg/pak.ads b/gcc/testsuite/gnat.dg/pak.ads new file mode 100644 index 000000000..e1e2d0d4d --- /dev/null +++ b/gcc/testsuite/gnat.dg/pak.ads @@ -0,0 +1,7 @@ +with Ada.Finalization; +package Pak is + type T is new Ada.Finalization.Controlled with null record; + procedure Initialize (X : in out T); + procedure Finalize (X : in out T); + procedure Assign (X : out T'Class); +end Pak; diff --git a/gcc/testsuite/gnat.dg/parameterlessfunc.adb b/gcc/testsuite/gnat.dg/parameterlessfunc.adb new file mode 100644 index 000000000..d63bc9add --- /dev/null +++ b/gcc/testsuite/gnat.dg/parameterlessfunc.adb @@ -0,0 +1,17 @@ +-- { dg-do compile } + +procedure parameterlessfunc is + type Byte is mod 256; + type Byte_Array is array(Byte range <>) of Byte; + subtype Index is Byte range 0..7; + subtype Small_Array is Byte_Array(Index); + + function F return Byte_Array is + begin + return (0..255=>0); + end F; + + B5: Small_Array := F(Index); +begin + null; +end parameterlessfunc; diff --git a/gcc/testsuite/gnat.dg/parent_ltd_with-child_full_view.adb b/gcc/testsuite/gnat.dg/parent_ltd_with-child_full_view.adb new file mode 100644 index 000000000..cd8cf4240 --- /dev/null +++ b/gcc/testsuite/gnat.dg/parent_ltd_with-child_full_view.adb @@ -0,0 +1,12 @@ +-- { dg-do compile } + +package body Parent_Ltd_With.Child_Full_View is + + function New_Child_Symbol return Child_Symbol_Access is + Sym : constant Child_Symbol_Access := new Child_Symbol'(Comp => 10); + + begin + return Sym; + end New_Child_Symbol; + +end Parent_Ltd_With.Child_Full_View; diff --git a/gcc/testsuite/gnat.dg/parent_ltd_with-child_full_view.ads b/gcc/testsuite/gnat.dg/parent_ltd_with-child_full_view.ads new file mode 100644 index 000000000..3f7aa2e99 --- /dev/null +++ b/gcc/testsuite/gnat.dg/parent_ltd_with-child_full_view.ads @@ -0,0 +1,12 @@ +package Parent_Ltd_With.Child_Full_View is + + type Child_Symbol is new Parent_Ltd_With.Symbol with private; + type Child_Symbol_Access is access all Child_Symbol; + + function New_Child_Symbol return Child_Symbol_Access; + +private + + type Child_Symbol is new Parent_Ltd_With.Symbol with null record; + +end Parent_Ltd_With.Child_Full_View; diff --git a/gcc/testsuite/gnat.dg/parent_ltd_with.ads b/gcc/testsuite/gnat.dg/parent_ltd_with.ads new file mode 100644 index 000000000..637aa7c3b --- /dev/null +++ b/gcc/testsuite/gnat.dg/parent_ltd_with.ads @@ -0,0 +1,15 @@ +limited with Parent_Ltd_With.Child_Full_View; + +package Parent_Ltd_With is + + type Symbol is abstract tagged limited private; + + type Symbol_Access is access all Symbol'Class; + +private + + type Symbol is abstract tagged limited record + Comp : Integer; + end record; + +end Parent_Ltd_With; diff --git a/gcc/testsuite/gnat.dg/pointer_array.adb b/gcc/testsuite/gnat.dg/pointer_array.adb new file mode 100644 index 000000000..a1c72daae --- /dev/null +++ b/gcc/testsuite/gnat.dg/pointer_array.adb @@ -0,0 +1,16 @@ +-- { dg-do compile } + +procedure pointer_array is + + type Node; + type Node_Ptr is access Node; + type Node is array (1..10) of Node_Ptr; + + procedure Process (N : Node_Ptr) is + begin + null; + end; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/pointer_controlled.adb b/gcc/testsuite/gnat.dg/pointer_controlled.adb new file mode 100644 index 000000000..1d85b53fe --- /dev/null +++ b/gcc/testsuite/gnat.dg/pointer_controlled.adb @@ -0,0 +1,31 @@ +-- PR ada/49732 +-- Testcase by Vorfeed Canal + +-- { dg-do compile } +-- { dg-options "-gnato" } + +with Interfaces.C; use Interfaces.C; +with Interfaces.C.Strings; use Interfaces.C.Strings; +with Interfaces.C.Pointers; + +procedure Pointer_Controlled is + + function Create (Name : String) return size_t is + + type Name_String is new char_array (0 .. Name'Length); + type Name_String_Ptr is access Name_String; + pragma Controlled (Name_String_Ptr); + + Name_Str : constant Name_String_Ptr := new Name_String; + Name_Len : size_t; + + begin + To_C (Name, Name_Str.all, Name_Len); + return 1; + end; + + Test : size_t; + +begin + Test := Create("ABC"); +end; diff --git a/gcc/testsuite/gnat.dg/pointer_conversion.adb b/gcc/testsuite/gnat.dg/pointer_conversion.adb new file mode 100644 index 000000000..8ed2e0d54 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pointer_conversion.adb @@ -0,0 +1,25 @@ +-- { dg-do run } +-- { dg-options "-O2" } + +with Unchecked_Conversion; + +procedure pointer_conversion is + + type int1 is new integer; + type int2 is new integer; + type a1 is access int1; + type a2 is access int2; + + function to_a2 is new Unchecked_Conversion (a1, a2); + + v1 : a1 := new int1; + v2 : a2 := to_a2 (v1); + +begin + v1.all := 1; + v2.all := 0; + + if v1.all /= 0 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/pointer_discr1.adb b/gcc/testsuite/gnat.dg/pointer_discr1.adb new file mode 100644 index 000000000..e3c171e16 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pointer_discr1.adb @@ -0,0 +1,9 @@ +-- { dg-do compile } + +with Pointer_Discr1_Pkg1; +with Pointer_Discr1_Pkg3; + +procedure Pointer_Discr1 is +begin + Pointer_Discr1_Pkg3.Map(Pointer_Discr1_Pkg1.Window(1)); +end; diff --git a/gcc/testsuite/gnat.dg/pointer_discr1_pkg1.ads b/gcc/testsuite/gnat.dg/pointer_discr1_pkg1.ads new file mode 100644 index 000000000..a930af2fd --- /dev/null +++ b/gcc/testsuite/gnat.dg/pointer_discr1_pkg1.ads @@ -0,0 +1,9 @@ +with Pointer_Discr1_Pkg2; + +package Pointer_Discr1_Pkg1 is + + type Arr is array (1..4) of Pointer_Discr1_Pkg2.T_WINDOW; + + Window : Arr; + +end Pointer_Discr1_Pkg1; diff --git a/gcc/testsuite/gnat.dg/pointer_discr1_pkg2.ads b/gcc/testsuite/gnat.dg/pointer_discr1_pkg2.ads new file mode 100644 index 000000000..c51069073 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pointer_discr1_pkg2.ads @@ -0,0 +1,10 @@ +with Unchecked_Conversion; +with Pointer_Discr1_Pkg3; + +package Pointer_Discr1_Pkg2 is + + subtype T_WINDOW is Pointer_Discr1_Pkg3.T_WINDOW(Pointer_Discr1_Pkg3.One); + + function TO_WINDOW is new Unchecked_Conversion(Integer, T_WINDOW); + +end Pointer_Discr1_Pkg2; diff --git a/gcc/testsuite/gnat.dg/pointer_discr1_pkg3.ads b/gcc/testsuite/gnat.dg/pointer_discr1_pkg3.ads new file mode 100644 index 000000000..b27b5149a --- /dev/null +++ b/gcc/testsuite/gnat.dg/pointer_discr1_pkg3.ads @@ -0,0 +1,13 @@ +package Pointer_Discr1_Pkg3 is + + type T_TYPE is (One, Two, Three); + + type T_DATA (D : T_TYPE); + + type T_DATA (D : T_TYPE) is null record; + + type T_WINDOW is access T_DATA; + + procedure Map (Window : in T_WINDOW); + +end Pointer_Discr1_Pkg3; diff --git a/gcc/testsuite/gnat.dg/pointer_protected.adb b/gcc/testsuite/gnat.dg/pointer_protected.adb new file mode 100644 index 000000000..070dbef94 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pointer_protected.adb @@ -0,0 +1,10 @@ +-- { dg-do compile } + +with pointer_protected_p; + +procedure pointer_protected is + Pointer : pointer_protected_p.Ptr := null; + Data : pointer_protected_p.T; +begin + Pointer.all (Data); +end pointer_protected; diff --git a/gcc/testsuite/gnat.dg/pointer_protected_p.ads b/gcc/testsuite/gnat.dg/pointer_protected_p.ads new file mode 100644 index 000000000..65e4e72ab --- /dev/null +++ b/gcc/testsuite/gnat.dg/pointer_protected_p.ads @@ -0,0 +1,9 @@ +package pointer_protected_p is + type T; + + type Ptr is access protected procedure (Data : T); + + type T is record + Data : Ptr; + end record; +end pointer_protected_p; diff --git a/gcc/testsuite/gnat.dg/pointer_variable_bounds.adb b/gcc/testsuite/gnat.dg/pointer_variable_bounds.adb new file mode 100644 index 000000000..5cc838a38 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pointer_variable_bounds.adb @@ -0,0 +1,26 @@ +-- { dg-do compile }
+-- { dg-options "-gnatws" }
+
+package body pointer_variable_bounds is
+
+ function COMPONENT_DAT(BP : in BUNDLE_POINTER_TYPE; CP : in COMP_POINTER_TYPE) return HALF_INTEGER is
+ type CP_TYPE is access COMP_POINTER_TYPE;
+ type CD_TYPE is access HALF_INTEGER;
+ CD : CD_TYPE;
+ begin
+ return CD.all;
+ end;
+
+ procedure BUNDLE_DAT(BP : in BUNDLE_POINTER_TYPE) is
+ N0 : C_POINTER_TYPE := COMPONENT_DAT(BP, 4);
+ begin
+ null;
+ end;
+
+ procedure SEQUENCE_DAT(BP : in BUNDLE_POINTER_TYPE) is
+ N0 : C_POINTER_TYPE := COMPONENT_DAT(BP, 4);
+ begin
+ null;
+ end;
+
+end pointer_variable_bounds;
diff --git a/gcc/testsuite/gnat.dg/pointer_variable_bounds.ads b/gcc/testsuite/gnat.dg/pointer_variable_bounds.ads new file mode 100644 index 000000000..b18c35407 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pointer_variable_bounds.ads @@ -0,0 +1,16 @@ +with pointer_variable_bounds_q; use pointer_variable_bounds_q;
+
+package pointer_variable_bounds is
+
+ type HALF_INTEGER is range -32768 .. 32767;
+ subtype HALF_NATURAL is HALF_INTEGER range 0 .. 32767;
+
+ MAX_COMPS : constant HALF_NATURAL := HALF_NATURAL(A_MAX_COMPS);
+ subtype COMP_POINTER_TYPE is HALF_NATURAL range 0 .. MAX_COMPS;
+ subtype BUNDLE_POINTER_TYPE is HALF_NATURAL range 0 .. 1;
+ subtype C_POINTER_TYPE is HALF_NATURAL range 0 .. 1;
+
+ procedure BUNDLE_DAT(BP : in BUNDLE_POINTER_TYPE);
+ procedure SEQUENCE_DAT(BP : in BUNDLE_POINTER_TYPE);
+
+end pointer_variable_bounds;
diff --git a/gcc/testsuite/gnat.dg/pointer_variable_bounds_q.ads b/gcc/testsuite/gnat.dg/pointer_variable_bounds_q.ads new file mode 100644 index 000000000..03997f77e --- /dev/null +++ b/gcc/testsuite/gnat.dg/pointer_variable_bounds_q.ads @@ -0,0 +1,6 @@ +package pointer_variable_bounds_q is + + type A_SIZE_TYPE is new INTEGER range 0 .. 65536; + function A_MAX_COMPS return A_SIZE_TYPE; + +end pointer_variable_bounds_q; diff --git a/gcc/testsuite/gnat.dg/prefix1.adb b/gcc/testsuite/gnat.dg/prefix1.adb new file mode 100644 index 000000000..70e11368e --- /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 000000000..3dbaa63e9 --- /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/prefix2.adb b/gcc/testsuite/gnat.dg/prefix2.adb new file mode 100644 index 000000000..562bdf495 --- /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 000000000..5e7b2b27b --- /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/profile_warning.adb b/gcc/testsuite/gnat.dg/profile_warning.adb new file mode 100644 index 000000000..3bdc58ea5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/profile_warning.adb @@ -0,0 +1,4 @@ +-- { dg-do compile } + +package body profile_warning is +end; diff --git a/gcc/testsuite/gnat.dg/profile_warning.ads b/gcc/testsuite/gnat.dg/profile_warning.ads new file mode 100644 index 000000000..475d83713 --- /dev/null +++ b/gcc/testsuite/gnat.dg/profile_warning.ads @@ -0,0 +1,6 @@ +pragma Profile_Warnings (Ravenscar); +with profile_warning_p; +package profile_warning is + pragma Elaborate_Body; + procedure I is new profile_warning_p.Proc; +end; diff --git a/gcc/testsuite/gnat.dg/profile_warning_p.adb b/gcc/testsuite/gnat.dg/profile_warning_p.adb new file mode 100644 index 000000000..455237a77 --- /dev/null +++ b/gcc/testsuite/gnat.dg/profile_warning_p.adb @@ -0,0 +1,20 @@ +package body profile_warning_p is + procedure Proc is begin null; end Proc; + + task type T is + end T; + + task body T is + begin + null; + end; + + type A_T is access T; + + procedure Do_Stuff is + P : A_T; + begin + P := new T; + end Do_Stuff; + +end; diff --git a/gcc/testsuite/gnat.dg/profile_warning_p.ads b/gcc/testsuite/gnat.dg/profile_warning_p.ads new file mode 100644 index 000000000..6c78d453f --- /dev/null +++ b/gcc/testsuite/gnat.dg/profile_warning_p.ads @@ -0,0 +1,4 @@ +package profile_warning_p is + generic + procedure Proc; +end; diff --git a/gcc/testsuite/gnat.dg/prot1.adb b/gcc/testsuite/gnat.dg/prot1.adb new file mode 100644 index 000000000..7a98f9dcc --- /dev/null +++ b/gcc/testsuite/gnat.dg/prot1.adb @@ -0,0 +1,22 @@ +-- { dg-do compile } + +procedure Prot1 is + protected type Prot is + procedure Change (x : integer); + private + Flag : Boolean; + end Prot; + type Handle is access protected procedure (X : Integer); + procedure Manage (Ptr : Handle) is + begin + null; + end; + + protected body prot is + procedure Change (x : integer) is begin null; end; + end; + + Sema : Prot; +begin + Manage (Sema.Change'Unrestricted_Access); +end; diff --git a/gcc/testsuite/gnat.dg/prot2.adb b/gcc/testsuite/gnat.dg/prot2.adb new file mode 100644 index 000000000..cc6fcab8f --- /dev/null +++ b/gcc/testsuite/gnat.dg/prot2.adb @@ -0,0 +1,23 @@ +-- { dg-do compile } + +with Prot2_Pkg1; +with Prot2_Pkg2; + +package body Prot2 is + + type A is array (1 .. Prot2_Pkg1.Num) of Integer; + + type E is (One, Two); + + type Rec (D : E := One) is record + case D is + when One => L : A; + when Two => null; + end case; + end record; + + package My_Pkg2 is new Prot2_Pkg2 (Rec); + + procedure Dummy is begin null; end; + +end Prot2; diff --git a/gcc/testsuite/gnat.dg/prot2.ads b/gcc/testsuite/gnat.dg/prot2.ads new file mode 100644 index 000000000..d388fc7d0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/prot2.ads @@ -0,0 +1,5 @@ +package Prot2 is + + procedure Dummy; + +end Prot2; diff --git a/gcc/testsuite/gnat.dg/prot2_pkg1.ads b/gcc/testsuite/gnat.dg/prot2_pkg1.ads new file mode 100644 index 000000000..2e71aacfc --- /dev/null +++ b/gcc/testsuite/gnat.dg/prot2_pkg1.ads @@ -0,0 +1,5 @@ +package Prot2_Pkg1 is + + function Num return Natural; + +end Prot2_Pkg1; diff --git a/gcc/testsuite/gnat.dg/prot2_pkg2.adb b/gcc/testsuite/gnat.dg/prot2_pkg2.adb new file mode 100644 index 000000000..503cce73d --- /dev/null +++ b/gcc/testsuite/gnat.dg/prot2_pkg2.adb @@ -0,0 +1,23 @@ +with Unchecked_Deallocation; + +package body Prot2_Pkg2 is + + protected type Rec is + private + M : T; + end Rec; + + protected body Rec is end; + + procedure Create (B : out Id) is + begin + B := new Rec; + end; + + procedure Delete (B : in out Id) is + procedure Free is new Unchecked_Deallocation(Object => Rec, Name => Id); + begin + Free (B); + end; + +end Prot2_Pkg2; diff --git a/gcc/testsuite/gnat.dg/prot2_pkg2.ads b/gcc/testsuite/gnat.dg/prot2_pkg2.ads new file mode 100644 index 000000000..cdd436b8a --- /dev/null +++ b/gcc/testsuite/gnat.dg/prot2_pkg2.ads @@ -0,0 +1,17 @@ +generic + + type T is private; + +package Prot2_Pkg2 is + + type Id is private; + + procedure Create (B : out Id); + procedure Delete (B : in out Id); + +private + + type Rec; + type Id is access Rec; + +end Prot2_Pkg2; diff --git a/gcc/testsuite/gnat.dg/prot_def.adb b/gcc/testsuite/gnat.dg/prot_def.adb new file mode 100644 index 000000000..d56195ea4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/prot_def.adb @@ -0,0 +1,44 @@ +-- { dg-do run } +procedure Prot_Def is + + protected Prot is + procedure Inc; + function Get return Integer; + private + Data : Integer := 0; + end Prot; + + protected body Prot is + procedure Inc is + begin + Data := Data + 1; + end Inc; + function Get return Integer is + begin + return Data; + end Get; + end Prot; + + generic + with procedure Inc is Prot.Inc; + with function Get return Integer is Prot.Get; + package Gen is + function Add2_Get return Integer; + end Gen; + + package body Gen is + function Add2_Get return Integer is + begin + Inc; + Inc; + return Get; + end Add2_Get; + end Gen; + + package Inst is new Gen; + +begin + if Inst.Add2_Get /= 2 then + raise Constraint_Error; + end if; +end Prot_Def; diff --git a/gcc/testsuite/gnat.dg/protected_self_ref1.adb b/gcc/testsuite/gnat.dg/protected_self_ref1.adb new file mode 100644 index 000000000..b6c2aef68 --- /dev/null +++ b/gcc/testsuite/gnat.dg/protected_self_ref1.adb @@ -0,0 +1,25 @@ +-- { dg-do run } +with System; + +procedure Protected_Self_Ref1 is + + protected type P is + procedure Foo; + end P; + + protected body P is + procedure Foo is + Ptr : access P; -- here P denotes the type P + T : Integer; + A : System.Address; + begin + Ptr := P'Access; -- here P denotes the "this" instance of P + T := P'Size; + A := P'Address; + end; + end P; + + O : P; +begin + O.Foo; +end Protected_Self_Ref1; diff --git a/gcc/testsuite/gnat.dg/protected_self_ref2.adb b/gcc/testsuite/gnat.dg/protected_self_ref2.adb new file mode 100644 index 000000000..825c0cc40 --- /dev/null +++ b/gcc/testsuite/gnat.dg/protected_self_ref2.adb @@ -0,0 +1,18 @@ +-- { dg-do compile } +procedure Protected_Self_Ref2 is + + protected type P is + procedure Foo; + end P; + + protected body P is + procedure Foo is + D : Integer; + begin + D := P'Digits; -- { dg-error "denotes current instance" } + end; + end P; + +begin + null; +end Protected_Self_Ref2; diff --git a/gcc/testsuite/gnat.dg/quote.adb b/gcc/testsuite/gnat.dg/quote.adb new file mode 100644 index 000000000..4b12c9fb9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/quote.adb @@ -0,0 +1,9 @@ +-- { dg-do run } + +with GNAT.Regpat; use GNAT.Regpat; +procedure Quote is +begin + if Quote (".+") /= "\.\+" then + raise Program_Error; + end if; +end Quote; diff --git a/gcc/testsuite/gnat.dg/raise_ce.adb b/gcc/testsuite/gnat.dg/raise_ce.adb new file mode 100644 index 000000000..f526beef5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/raise_ce.adb @@ -0,0 +1,4 @@ +procedure Raise_CE is +begin + raise Constraint_Error; +end; diff --git a/gcc/testsuite/gnat.dg/raise_from_pure.adb b/gcc/testsuite/gnat.dg/raise_from_pure.adb new file mode 100644 index 000000000..62e543e94 --- /dev/null +++ b/gcc/testsuite/gnat.dg/raise_from_pure.adb @@ -0,0 +1,11 @@ +package body raise_from_pure is + function Raise_CE_If_0 (P : Integer) return Integer is + begin + if P = 0 then + raise Constraint_error; + end if; + return 1; + end; +end; + + diff --git a/gcc/testsuite/gnat.dg/raise_from_pure.ads b/gcc/testsuite/gnat.dg/raise_from_pure.ads new file mode 100644 index 000000000..9c363a5be --- /dev/null +++ b/gcc/testsuite/gnat.dg/raise_from_pure.ads @@ -0,0 +1,5 @@ + +package raise_from_pure is + pragma Pure; + function Raise_CE_If_0 (P : Integer) return Integer; +end; diff --git a/gcc/testsuite/gnat.dg/range_check.adb b/gcc/testsuite/gnat.dg/range_check.adb new file mode 100644 index 000000000..18839a1aa --- /dev/null +++ b/gcc/testsuite/gnat.dg/range_check.adb @@ -0,0 +1,20 @@ +-- { dg-do run } + +procedure range_check is + function ident (x : integer) return integer is + begin + return x; + end ident; + + guard1 : Integer; + + r : array (1 .. ident (10)) of integer; + pragma Suppress (Index_Check, r); + + guard2 : Integer; + +begin + guard1 := 0; + guard2 := 0; + r (11) := 3; +end; diff --git a/gcc/testsuite/gnat.dg/range_check2.adb b/gcc/testsuite/gnat.dg/range_check2.adb new file mode 100644 index 000000000..33172f155 --- /dev/null +++ b/gcc/testsuite/gnat.dg/range_check2.adb @@ -0,0 +1,13 @@ +-- { dg-do compile } +-- { dg-options "-O2" } + +procedure Range_Check2 is + + subtype Block_Subtype is String(1 .. 6); + type Color is (Black, Red, Green, Yellow, Blue, Magenta, Cyan, White); + Foregrnd_Color : Color := White; + Block : Block_Subtype := "123456"; + +begin + Foregrnd_Color := Color'Val(Integer'Value(Block(5 .. 6))); +end; diff --git a/gcc/testsuite/gnat.dg/rational_arithmetic.ads b/gcc/testsuite/gnat.dg/rational_arithmetic.ads new file mode 100644 index 000000000..f4398c514 --- /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/ref_type.adb b/gcc/testsuite/gnat.dg/ref_type.adb new file mode 100644 index 000000000..3d36b96ff --- /dev/null +++ b/gcc/testsuite/gnat.dg/ref_type.adb @@ -0,0 +1,9 @@ + +-- { dg-do compile } + +package body ref_type is + procedure Print (X : T) is + begin + null; + end; +end ref_type; diff --git a/gcc/testsuite/gnat.dg/ref_type.ads b/gcc/testsuite/gnat.dg/ref_type.ads new file mode 100644 index 000000000..550d5892f --- /dev/null +++ b/gcc/testsuite/gnat.dg/ref_type.ads @@ -0,0 +1,5 @@ +package ref_type is +private + type T is tagged null record; + procedure Print (X : T); +end ref_type; diff --git a/gcc/testsuite/gnat.dg/regpat1.adb b/gcc/testsuite/gnat.dg/regpat1.adb new file mode 100644 index 000000000..fdd258942 --- /dev/null +++ b/gcc/testsuite/gnat.dg/regpat1.adb @@ -0,0 +1,13 @@ +-- { dg-do run } + +with GNAT.Regpat; use GNAT.Regpat; +procedure regpat1 is +begin + declare + Re : Pattern_Matcher := Compile ("a[]b"); + begin + raise Program_Error; + end; +exception + when Expression_Error => null; +end regpat1; diff --git a/gcc/testsuite/gnat.dg/release_unc_maxalign.adb b/gcc/testsuite/gnat.dg/release_unc_maxalign.adb new file mode 100644 index 000000000..245ce2190 --- /dev/null +++ b/gcc/testsuite/gnat.dg/release_unc_maxalign.adb @@ -0,0 +1,19 @@ +-- { dg-do run } + +with Ada.Unchecked_Deallocation; + +procedure Release_UNC_Maxalign is + + type List is array (Natural range <>) of Integer; + for List'Alignment use Standard'Maximum_Alignment; + + type List_Access is access all List; + + procedure Release is new Ada.Unchecked_Deallocation + (Object => List, Name => List_Access); + + My_List : List_Access; +begin + My_List := new List (1 .. 3); + Release (My_List); +end; diff --git a/gcc/testsuite/gnat.dg/remote_type.adb b/gcc/testsuite/gnat.dg/remote_type.adb new file mode 100644 index 000000000..788f79588 --- /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 000000000..79c27106b --- /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/renaming1.adb b/gcc/testsuite/gnat.dg/renaming1.adb new file mode 100644 index 000000000..d033c9abc --- /dev/null +++ b/gcc/testsuite/gnat.dg/renaming1.adb @@ -0,0 +1,13 @@ +-- { dg-do compile} +-- { dg-options "-gnatwa" } + +with Text_IO; +use Text_IO; +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 000000000..893f423d5 --- /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/renaming2.adb b/gcc/testsuite/gnat.dg/renaming2.adb new file mode 100644 index 000000000..0ec89c2f3 --- /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/renaming3.adb b/gcc/testsuite/gnat.dg/renaming3.adb new file mode 100644 index 000000000..335a21221 --- /dev/null +++ b/gcc/testsuite/gnat.dg/renaming3.adb @@ -0,0 +1,12 @@ +-- { dg-do run } + +with Renaming4; use Renaming4; + +procedure Renaming3 is + type A is array(1..16) of Integer; + Filler : A := (others => 0); +begin + if B(1) /= 1 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/renaming4.ads b/gcc/testsuite/gnat.dg/renaming4.ads new file mode 100644 index 000000000..4fdc9c108 --- /dev/null +++ b/gcc/testsuite/gnat.dg/renaming4.ads @@ -0,0 +1,15 @@ +package Renaming4 is + + type Big_Array is array (Natural range <>) of Integer; + + subtype Index is Natural range 1..4; + subtype My_Array is Big_Array(Index); + + A : constant My_Array := (1, 2, 3, 4); + + subtype Small is Index range 1..2; + subtype Small_Array is Big_Array(Small); + + B : Small_Array renames A(Index); + +end Renaming4; diff --git a/gcc/testsuite/gnat.dg/renaming5.adb b/gcc/testsuite/gnat.dg/renaming5.adb new file mode 100644 index 000000000..25374fe89 --- /dev/null +++ b/gcc/testsuite/gnat.dg/renaming5.adb @@ -0,0 +1,30 @@ +-- PR ada/46192 +-- Testcase by Rolf Ebert <rolf.ebert.gcc@gmx.de> + +-- { dg-do compile } +-- { dg-options "-O2 -fdump-tree-optimized" } + +with System; use System; + +package body Renaming5 is + + type Bits_In_Byte is array (0 .. 7) of Boolean; + pragma Pack (Bits_In_Byte); + + A : Bits_In_Byte; + for A'Address use System'To_Address(16#c0#); + pragma Volatile (A); + + B : Bits_In_Byte renames A; + + procedure Proc is + begin + while B (0) = False loop + null; + end loop; + end; + +end Renaming5; + +-- { dg-final { scan-tree-dump-times "goto" 2 "optimized" } } +-- { dg-final { cleanup-tree-dump "optimized" } } diff --git a/gcc/testsuite/gnat.dg/renaming5.ads b/gcc/testsuite/gnat.dg/renaming5.ads new file mode 100644 index 000000000..2b39663ad --- /dev/null +++ b/gcc/testsuite/gnat.dg/renaming5.ads @@ -0,0 +1,5 @@ +package Renaming5 is + + procedure Proc; + +end Renaming5; diff --git a/gcc/testsuite/gnat.dg/rep_clause1.adb b/gcc/testsuite/gnat.dg/rep_clause1.adb new file mode 100644 index 000000000..b7f5c7dd4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/rep_clause1.adb @@ -0,0 +1,101 @@ +-- { dg-do compile } + +with Ada.Text_IO; use Ada.Text_IO; + +procedure Rep_Clause1 is + + type Int_16 is range 0 .. 65535; + for Int_16'Size use 16; + + ---------------------------------------------- + + type Rec_A is + record + Int_1 : Int_16; + Int_2 : Int_16; + Int_3 : Int_16; + Int_4 : Int_16; + end record; + + + for Rec_A use record + Int_1 at 0 range 0 .. 15; + Int_2 at 2 range 0 .. 15; + Int_3 at 4 range 0 .. 15; + Int_4 at 6 range 0 .. 15; + end record; + + Rec_A_Size : constant := 4 * 16; + + for Rec_A'Size use Rec_A_Size; + + ---------------------------------------------- + + type Rec_B_Version_1 is + record + Rec_1 : Rec_A; + Rec_2 : Rec_A; + Int_1 : Int_16; + end record; + + for Rec_B_Version_1 use record + Rec_1 at 0 range 0 .. 63; + Rec_2 at 8 range 0 .. 63; + Int_1 at 16 range 0 .. 15; + end record; + + Rec_B_Size : constant := 2 * Rec_A_Size + 16; + + for Rec_B_Version_1'Size use Rec_B_Size; + for Rec_B_Version_1'Alignment use 2; + + ---------------------------------------------- + + type Rec_B_Version_2 is + record + Int_1 : Int_16; + Rec_1 : Rec_A; + Rec_2 : Rec_A; + end record; + + for Rec_B_Version_2 use record + Int_1 at 0 range 0 .. 15; + Rec_1 at 2 range 0 .. 63; + Rec_2 at 10 range 0 .. 63; + end record; + + for Rec_B_Version_2'Size use Rec_B_Size; + + ---------------------------------------------- + + Arr_A_Length : constant := 2; + Arr_A_Size : constant := Arr_A_Length * Rec_B_Size; + + type Arr_A_Version_1 is array (1 .. Arr_A_Length) of Rec_B_Version_1; + type Arr_A_Version_2 is array (1 .. Arr_A_Length) of Rec_B_Version_2; + + pragma Pack (Arr_A_Version_1); + pragma Pack (Arr_A_Version_2); + + for Arr_A_Version_1'Size use Arr_A_Size; + for Arr_A_Version_2'Size use Arr_A_Size; + + ---------------------------------------------- + +begin + -- Put_Line ("Arr_A_Size =" & Arr_A_Size'Img); + + if Arr_A_Version_1'Size /= Arr_A_Size then + Ada.Text_IO.Put_Line + ("Version 1 Size mismatch! " & + "Arr_A_Version_1'Size =" & Arr_A_Version_1'Size'Img); + end if; + + if Arr_A_Version_2'Size /= Arr_A_Size then + Ada.Text_IO.Put_Line + ("Version 2 Size mismatch! " & + "Arr_A_Version_2'Size =" & Arr_A_Version_2'Size'Img); + + end if; + +end; diff --git a/gcc/testsuite/gnat.dg/rep_clause2.adb b/gcc/testsuite/gnat.dg/rep_clause2.adb new file mode 100644 index 000000000..b6cd49f9f --- /dev/null +++ b/gcc/testsuite/gnat.dg/rep_clause2.adb @@ -0,0 +1,10 @@ +-- { dg-do compile }
+
+package body Rep_Clause2 is
+
+ procedure Assign (From : Data; Offset : Positive; I : Index; To : out Bit_Array) is
+ begin
+ To (Offset .. Offset + 7) := Bit_Array (Conv (From.D(I).S.N));
+ end;
+
+end Rep_Clause2;
diff --git a/gcc/testsuite/gnat.dg/rep_clause2.ads b/gcc/testsuite/gnat.dg/rep_clause2.ads new file mode 100644 index 000000000..cc8b33e8b --- /dev/null +++ b/gcc/testsuite/gnat.dg/rep_clause2.ads @@ -0,0 +1,53 @@ +with Unchecked_Conversion;
+
+package Rep_Clause2 is
+
+ type Tiny is range 0 .. 3;
+ for Tiny'Size use 2;
+
+ type Small is range 0 .. 255;
+ for Small'Size use 8;
+
+ type Small_Data is record
+ D : Tiny;
+ N : Small;
+ end record;
+ pragma Pack (Small_Data);
+
+ type Chunk is
+ record
+ S : Small_Data;
+ C : Character;
+ end record;
+
+ for Chunk use record
+ S at 0 range 0 .. 15;
+ C at 2 range 0 .. 7;
+ end record;
+
+ type Index is range 1 .. 10;
+
+ type Data_Array is array (Index) of Chunk;
+ for Data_Array'Alignment use 2;
+ pragma Pack (Data_Array);
+
+ type Data is record
+ D : Data_Array;
+ end record;
+
+ type Bit is range 0 .. 1;
+ for Bit'Size use 1;
+
+ type Bit_Array is array (Positive range <>) of Bit;
+ pragma Pack (Bit_Array);
+
+ type Byte is new Bit_Array (1 .. 8);
+ for Byte'Size use 8;
+ for Byte'Alignment use 1;
+
+ function Conv
+ is new Unchecked_Conversion(Source => Small, Target => Byte);
+
+ procedure Assign (From : Data; Offset : Positive; I : Index; To : out Bit_Array);
+
+end Rep_Clause2;
diff --git a/gcc/testsuite/gnat.dg/rep_clause3.adb b/gcc/testsuite/gnat.dg/rep_clause3.adb new file mode 100644 index 000000000..f4adcc37b --- /dev/null +++ b/gcc/testsuite/gnat.dg/rep_clause3.adb @@ -0,0 +1,47 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +procedure Rep_Clause3 is + + subtype U_16 is integer range 0..2**16-1; + + type TYPE1 is range 0 .. 135; + for TYPE1'size use 14; + + type TYPE2 is range 0 .. 262_143; + for TYPE2'size use 18; + + subtype TYPE3 is integer range 1 .. 21*6; + + type ARR is array (TYPE3 range <>) of boolean; + pragma Pack(ARR); + + subtype SUB_ARR is ARR(1 .. 5*6); + + OBJ : SUB_ARR; + + type R is + record + N : TYPE1; + L : TYPE2; + I : SUB_ARR; + CRC : U_16; + end record; + for R use + record at mod 4; + N at 0 range 0 .. 13; + L at 0 range 14 .. 31; + I at 4 range 2 .. 37; + CRC at 8 range 16 .. 31; + end record; + for R'size use 12*8; + + type SUB_R is array (1..4) of R; + + T : SUB_R; + +begin + if OBJ = T(1).I then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/rep_clause4.adb b/gcc/testsuite/gnat.dg/rep_clause4.adb new file mode 100644 index 000000000..76bb15284 --- /dev/null +++ b/gcc/testsuite/gnat.dg/rep_clause4.adb @@ -0,0 +1,34 @@ +-- { dg-do run } + +procedure Rep_Clause4 is + + type U32 is mod 2 ** 32; + + type Key is record + Value : U32; + Valid : Boolean; + end record; + + type Key_Buffer is record + Current, Latch : Key; + end record; + + type Block is record + Keys : Key_Buffer; + Stamp : U32; + end record; + for Block use record + Keys at 0 range 0 .. 103; + Stamp at 13 range 0 .. 31; + end record; + + My_Block : Block; + My_Stamp : constant := 16#01234567#; + +begin + My_Block.Stamp := My_Stamp; + My_Block.Keys.Latch := My_Block.Keys.Current; + if My_Block.Stamp /= My_Stamp then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/rep_clause5.adb b/gcc/testsuite/gnat.dg/rep_clause5.adb new file mode 100644 index 000000000..7fdf26409 --- /dev/null +++ b/gcc/testsuite/gnat.dg/rep_clause5.adb @@ -0,0 +1,39 @@ +-- { dg-do compile } +-- { dg-options "-O" } + +package body Rep_Clause5 is + + function To_LNumber(S : String) return LNumber_Type is + V : VString; + LV : Long_Type; + LN : LNumber_Type; + begin + LV := To_Long(V, 10); + LN := LNumber_Type(LV); + return LN; + end; + + procedure Merge_Numbered(LNodes : in out LNodes_Ptr) is + T1 : Token_Type; + LNO : LNumber_Type; + begin + for X in LNodes.all'Range loop + T1 := LNodes(X).Line(0); + if T1.Token /= LEX_LF then + declare + S : String := Element(T1.SID); + begin + begin + LNO := To_LNumber(S); + exception + when Bad_Number => + LNO := 0; + when Too_Large => + LNO := 0; + end; + end; + end if; + end loop; + end; + +end Rep_Clause5; diff --git a/gcc/testsuite/gnat.dg/rep_clause5.ads b/gcc/testsuite/gnat.dg/rep_clause5.ads new file mode 100644 index 000000000..986f893ec --- /dev/null +++ b/gcc/testsuite/gnat.dg/rep_clause5.ads @@ -0,0 +1,12 @@ +with Rep_Clause5_Pkg; use Rep_Clause5_Pkg; + +package Rep_Clause5 is + + Bad_Number : exception; + Too_Large : exception; + + type LNumber_Type is range 0..99999; + + procedure Merge_Numbered(LNodes : in out LNodes_Ptr); + +end Rep_Clause5; diff --git a/gcc/testsuite/gnat.dg/rep_clause5_pkg.ads b/gcc/testsuite/gnat.dg/rep_clause5_pkg.ads new file mode 100644 index 000000000..e3496c4a2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/rep_clause5_pkg.ads @@ -0,0 +1,383 @@ +package Rep_Clause5_Pkg is + + type ID_Type is mod 65536; + type String_ID is new ID_Type; + type LNumber_Type is range 0..99999; + subtype Long_Type is Integer; + + type Func_ID is (No_Func, FUN_SGN, FUN_EXP, FUN_LOG, FUN_LOG10); + + type Token_Kind is ( + No_Token, + LEX_BINARY, + LEX_SECTION, + LEX_003, + LEX_004, + LEX_005, + LEX_006, + LEX_007, + LEX_008, + LEX_009, + LEX_LF, + LEX_011, + LEX_012, + LEX_013, + LEX_014, + LEX_015, + LEX_016, + LEX_017, + LEX_018, + LEX_019, + LEX_020, + LEX_021, + LEX_022, + LEX_023, + LEX_024, + LEX_025, + LEX_026, + LEX_027, + LEX_028, + LEX_029, + LEX_030, + LEX_031, + LEX_032, + '!', + '"', + '#', + '$', + '%', + '&', + ''', + '(', + ')', + '*', + '+', + ',', + '-', + '.', + '/', + '0', + '1', + '2', + '3', + '4', + '5', + '6', + '7', + '8', + '9', + ':', + ';', + '<', + '=', + '>', + '?', + '@', + 'A', + 'B', + 'C', + 'D', + 'E', + 'F', + 'G', + 'H', + 'I', + 'J', + 'K', + 'L', + 'M', + 'N', + 'O', + 'P', + 'Q', + 'R', + 'S', + 'T', + 'U', + 'V', + 'W', + 'X', + 'Y', + 'Z', + '[', + '\', + ']', + '^', + '_', + '`', + 'a', + 'b', + 'c', + 'd', + 'e', + 'f', + 'g', + 'h', + 'i', + 'j', + 'k', + 'l', + 'm', + 'n', + 'o', + LEX_SFUN3, + LEX_SFUN2, + LEX_SFUN1, + LEX_SFUNN, + LEX_FUN3, + LEX_FUN2, + LEX_FUN1, + LEX_FUNN, + 'x', + 'y', + 'z', + '{', + '|', + '}', + '~', + LEX_CRTA, + LEX_ISNULL, + LEX_USING, + LEX_HANDLE, + LEX_CALLX, + LEX_COMPLEX, + LEX_FIXED, + LEX_ENV, + LEX_SPARSE, + LEX_SUBROUTINE, + LEX_CALL, + LEX_BOX, + LEX_VLINE, + LEX_HLINE, + LEX_MAXLENGTH, + LEX_DLENGTH, + LEX_INPUT, + LEX_INITIALIZE, + LEX_OUTPUT, + LEX_UNLINK, + LEX_SEEK, + LEX_EXIT, + LEX_NOT, + LEX_COMMON, + LEX_CHAIN, + LEX_DEF, + LEX_ARITY, + LEX_RESUME, + LEX_PIC_S, + LEX_BG, + LEX_FG, + LEX_PC, + LEX_CRT, + LEX_ENUM, + LEX_DECLARE, + LEX_CURSOR, + LEX_DROP, + LEX_CURRENT, + LEX_ISOLATION, + LEX_SET, + LEX_TRANSACTION, + LEX_COMMIT, + LEX_ABORT, + LEX_BEGIN, + LEX_PREVIOUS, + LEX_LAST, + LEX_FIRST, + LEX_KEY, + LEX_START, + LEX_REWRITE, + LEX_INDEX, + LEX_SECONDARY, + LEX_PRIMARY, + LEX_COLUMN, + LEX_TEMP, + LEX_TABLE, + LEX_CREATE, + LEX_HASH, + LEX_BTREE, + LEX_UPDATE, + LEX_ERROR, + LEX_ACCEPT, + LEX_AVG, + LEX_MAX, + LEX_MIN, + LEX_FIELD, + LEX_RESTORE, + LEX_END, + LEX_STEP, + LEX_NEXT, + LEX_FOR, + LEX_RETURN, + LEX_GOSUB, + LEX_RANGE, + LEX_EXPON, + LEX_XOR, + LEX_OR, + LEX_AND, + LEX_SHIFTR, + LEX_GE, + LEX_NE, + LEX_SHIFTL, + LEX_LE, + LEX_VARYING, + LEX_LENGTH, + LEX_PRINT, + LEX_IF, + LEX_GOTO, + LEX_ON, + LEX_THEN, + LEX_DELETE, + LEX_TO, + LEX_SEQUENCE, + LEX_NONUNIQUE, + LEX_UNIQUE, + LEX_FILE, + LEX_CLOSE, + LEX_OPEN, + LEX_DATABASE, + LEX_RECORD, + LEX_DATA, + LEX_WRITE, + LEX_READ, + LEX_STOP, + LEX_LET, + LEX_MOD, + LEX_LONG, + LEX_DIM, + LEX_SHORT, + LEX_REM, + LEX_SHELL, + LEX_TOKEN, + LEX_FLOAT, + LEX_SIDENT, + LEX_INLREM, + LEX_ENDLIT, + LEX_STRLIT, + LEX_IDENT, + LEX_LNUMBER, + LEX_HEX, + LEX_NUMBER, + LEX_EOF, + LEX_QUIT, + LEX_LIST, + LEX_REMOVE, + LEX_RENUMBER, + LEX_CONTINUE, + LEX_RUN, + LEX_MERGE, + LEX_ENTER, + LEX_NEW, + LEX_RESET, + LEX_SYMTAB, + LEX_CLS, + LEX_EDIT, + LEX_SAVE, + LEX_RESAVE, + LEX_LOAD, + LEX_NAME, + LEX_LISTP, + LEX_SHOW, + LEX_STACK, + LEX_STATUS, + LEX_CACHE, + LEX_INSPECT, + LEX_STOW, + LEX_PKGRUN, + LEX_POP, + LEX_CHECK, + LEX_INSERT, + LEX_INTO, + LEX_VALUES, + LEX_NULL, + LEX_WHERE, + LEX_FROM, + LEX_EXEC, + LEX_SELECT, + LEX_AS, + LEX_ALL, + LEX_BY, + LEX_CROSS, + LEX_DESC, + LEX_FULL, + LEX_GROUP, + LEX_INNER, + LEX_JOIN, + LEX_LEFT, + LEX_LIMIT, + LEX_NATURAL, + LEX_OFFSET, + LEX_ORDER, + LEX_OUTER, + LEX_RIGHT, + LEX_FETCH, + LEX_DISTINCT, + LEX_DEFAULT, + LEX_RETURNING, + LEX_LEVEL, + LEX_COMMITTED, + LEX_SERIALIZABLE, + LEX_ONLY, + LEX_HOLD, + LEX_FORWARD, + LEX_WITH, + LEX_PRIOR, + LEX_RELATIVE, + LEX_BACKWARD, + LEX_OF, + LEX_SCROLL, + LEX_NOWAIT, + LEX_HAVING, + LEX_END_TOKENS + ); + + type Aux_Kind is (No_Aux, SID_Aux, FID_Aux, LNO_Aux); + + type Token_Type(Aux : Aux_Kind := No_Aux) is + record + Token : Token_Kind := No_Token; + case Aux is + when SID_Aux => + SID : String_ID; + when FID_Aux => + FID : Func_ID; + when LNO_Aux => + LNO : LNumber_Type; + when No_Aux => + null; + end case; + end record; + + for Token_Type use + record + Aux at 0 range 0..2; + Token at 0 range 3..12; + SID at 0 range 16..31; + FID at 0 range 16..31; + LNO at 0 range 13..31; + end record; + + type Tokens_Index is range 0..999999; + type Token_Array is array(Tokens_Index range <>) of Token_Type; + type Token_Line is access all Token_Array; + + type Line_Node is + record + Line : Token_Line; + LNO : LNumber_Type := 0; + Numbered : Boolean := False; + end record; + + type Nodes_Index is range 0..999999; + type LNodes_Array is array(Nodes_Index range <>) of Line_Node; + type LNodes_Ptr is access all LNodes_Array; + + type VString is + record + Max_Length : Natural := 0; + Fixed : Boolean := False; + end record; + + function To_Long(Object : VString; Radix : Natural) return Long_Type; + + function Element (V : String_ID) return String; + +end Rep_Clause5_Pkg; diff --git a/gcc/testsuite/gnat.dg/requeue1.adb b/gcc/testsuite/gnat.dg/requeue1.adb new file mode 100644 index 000000000..f7902966b --- /dev/null +++ b/gcc/testsuite/gnat.dg/requeue1.adb @@ -0,0 +1,51 @@ +-- { dg-do run } + +with Ada.Text_Io; use Ada.Text_Io; + +procedure requeue1 is + + protected P is + entry Requeue_Without_Abort; + entry Queue_Without; + procedure Open; + private + Opened: Boolean := False; + end P; + + protected body P is + entry Requeue_Without_Abort when True is + begin + -- BUG: after this requeue no time out of the call should be possible + requeue Queue_Without; + end Requeue_Without_Abort; + + entry Queue_Without when Opened is + begin + Opened := False; + end Queue_Without; + + procedure Open is + begin + Opened := True; + end Open; + end P; + + -- Test of timed entry call to an entry with requeue without abort + task T_Without; + task body T_Without is + begin + select + P.Requeue_Without_Abort; + or + delay 1.0; + Put_Line("failed"); + end select; + + exception + when others => Put_Line ("failed"); + end T_Without; + +begin + delay 3.0; + P.Open; +end; diff --git a/gcc/testsuite/gnat.dg/return1.adb b/gcc/testsuite/gnat.dg/return1.adb new file mode 100644 index 000000000..f632211f5 --- /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 Base'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 000000000..6948fdabc --- /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/return2.adb b/gcc/testsuite/gnat.dg/return2.adb new file mode 100644 index 000000000..65b7bf045 --- /dev/null +++ b/gcc/testsuite/gnat.dg/return2.adb @@ -0,0 +1,33 @@ +-- { dg-do compile } +-- { dg-options "-O" } + +with Return2_Pkg; use Return2_Pkg; + +package body Return2 is + + function Value_Internal (Image : String) return Result_Internal_T is + begin + return (Member => False); + end; + + type Result_T is array (1 .. 2) of Result_Internal_T; + + function Value (Img : String) return T is + My_F : constant String := F; + Result : Result_T; + Value : T; + begin + for I in Result'Range loop + if G (My_F, I) /= "" then + Result (I) := Value_Internal (G (My_F, I)); + if Result (I).Member then + Value (Result (I).Data) := True; + else + raise Program_Error; + end if; + end if; + end loop; + return Value; + end; + +end Return2; diff --git a/gcc/testsuite/gnat.dg/return2.ads b/gcc/testsuite/gnat.dg/return2.ads new file mode 100644 index 000000000..3e29910d2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/return2.ads @@ -0,0 +1,18 @@ +package Return2 is + + type Kind_T is (One, Two); + + type T is array (Kind_T) of Boolean; + + type Result_Internal_T (Member : Boolean := False) is record + case Member is + when True => + Data : Kind_T := Kind_T'First; + when False => + null; + end case; + end record; + + function Value (Img : String) return T; + +end Return2; diff --git a/gcc/testsuite/gnat.dg/return2_pkg.ads b/gcc/testsuite/gnat.dg/return2_pkg.ads new file mode 100644 index 000000000..f5738654a --- /dev/null +++ b/gcc/testsuite/gnat.dg/return2_pkg.ads @@ -0,0 +1,7 @@ +package Return2_Pkg is + + function F return String; + + function G (Line : String; Index : Positive) return String; + +end Return2_Pkg; diff --git a/gcc/testsuite/gnat.dg/rt1.adb b/gcc/testsuite/gnat.dg/rt1.adb new file mode 100644 index 000000000..ce94928ca --- /dev/null +++ b/gcc/testsuite/gnat.dg/rt1.adb @@ -0,0 +1,9 @@ +-- { dg-do compile } + +package body RT1 is + procedure P (S : access Root_Stream_Type'Class) is + Val : constant Ptr := Ptr'Input (S); + begin + null; + end P; +end RT1; diff --git a/gcc/testsuite/gnat.dg/rt1.ads b/gcc/testsuite/gnat.dg/rt1.ads new file mode 100644 index 000000000..50cbbf0ff --- /dev/null +++ b/gcc/testsuite/gnat.dg/rt1.ads @@ -0,0 +1,14 @@ +with Ada.Streams; use Ada.Streams; +package RT1 is + pragma Remote_Types; + + type Ptr is private; + procedure Read (X : access Root_Stream_Type'Class; V : out Ptr) is null; + procedure Write (X : access Root_Stream_Type'Class; V : Ptr) is null; + for Ptr'Read use Read; + for Ptr'Write use Write; + + procedure P (S : access Root_Stream_Type'Class); +private + type Ptr is not null access all Integer; +end RT1; diff --git a/gcc/testsuite/gnat.dg/scalar_mode_agg_compare.adb b/gcc/testsuite/gnat.dg/scalar_mode_agg_compare.adb new file mode 100644 index 000000000..ff3734642 --- /dev/null +++ b/gcc/testsuite/gnat.dg/scalar_mode_agg_compare.adb @@ -0,0 +1,25 @@ +-- { dg-do run } + +procedure Scalar_Mode_Agg_Compare is + + type Point is record + Mapped : Boolean; + Tag : String (1 .. 2); -- HImode + end record; + pragma Pack (Point); -- Tag possibly at bitpos 1 + + function My_Point return Point is + begin + return (Mapped => True, Tag => "XX"); + end; + + A, B : Point := My_Point; +begin + -- The comparison below should find the two Tag fields equal and not + -- attempt to take their address, which might not be byte aligned. + + if A.Tag /= B.Tag then + raise Program_Error; + end if; +end; + diff --git a/gcc/testsuite/gnat.dg/scalar_mode_agg_compare_loop.adb b/gcc/testsuite/gnat.dg/scalar_mode_agg_compare_loop.adb new file mode 100644 index 000000000..9bafb4d29 --- /dev/null +++ b/gcc/testsuite/gnat.dg/scalar_mode_agg_compare_loop.adb @@ -0,0 +1,18 @@ + +-- { dg-do compile } +-- { dg-options "-O2 -gnatp" } + +function Scalar_Mode_Agg_Compare_Loop return Boolean is + S : constant String (1 .. 4) := "ABCD"; + F : constant Natural := S'First; + L : constant Natural := S'Last; +begin + for J in F .. L - 1 loop + if S (F .. F) = "X" or (J <= L - 2 and S (J .. J + 1) = "YY") then + return True; + end if; + end loop; + + return False; +end; + diff --git a/gcc/testsuite/gnat.dg/self.adb b/gcc/testsuite/gnat.dg/self.adb new file mode 100644 index 000000000..c95c3ef2b --- /dev/null +++ b/gcc/testsuite/gnat.dg/self.adb @@ -0,0 +1,18 @@ +package body Self is + function G (X : Integer) return Lim is + begin + return R : Lim := (Comp => X, others => <>); + end G; + + procedure Change (X : in out Lim; Incr : Integer) is + begin + X.Comp := X.Comp + Incr; + X.Self_Default.Comp := X.Comp + Incr; + X.Self_Anon_Default.Comp := X.Comp + Incr; + end Change; + + function Get (X : Lim) return Integer is + begin + return X.Comp; + end; +end Self; diff --git a/gcc/testsuite/gnat.dg/self.ads b/gcc/testsuite/gnat.dg/self.ads new file mode 100644 index 000000000..1837188ab --- /dev/null +++ b/gcc/testsuite/gnat.dg/self.ads @@ -0,0 +1,17 @@ +with System; +package Self is + type Lim is limited private; + type Lim_Ref is access all Lim; + function G (X : Integer) return lim; + + procedure Change (X : in out Lim; Incr : Integer); + function Get (X : Lim) return Integer; +private + type Lim is limited record + Comp : Integer; + Self_Default : Lim_Ref := Lim'Unchecked_Access; + Self_Unrestricted_Default : Lim_Ref := Lim'Unrestricted_Access; + Self_Anon_Default : access Lim := Lim'Unchecked_Access; + Self_Anon_Unrestricted_Default : access Lim := Lim'Unrestricted_Access; + end record; +end Self; diff --git a/gcc/testsuite/gnat.dg/self1.adb b/gcc/testsuite/gnat.dg/self1.adb new file mode 100644 index 000000000..dc6f485b8 --- /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/self_aggregate_with_array.adb b/gcc/testsuite/gnat.dg/self_aggregate_with_array.adb new file mode 100644 index 000000000..850e5deff --- /dev/null +++ b/gcc/testsuite/gnat.dg/self_aggregate_with_array.adb @@ -0,0 +1,21 @@ +-- { dg-do run } + +procedure self_aggregate_with_array is + + type Value_Bounds is array (1 .. 2) of Natural; + + type Sensor is record + Value : Natural; + Bounds : Value_Bounds; + end record; + + Pressure : Sensor; + +begin + Pressure.Value := 256; + Pressure := (Value => Pressure.Value, Bounds => (1, 2)); + + if Pressure.Value /= 256 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/self_aggregate_with_call.adb b/gcc/testsuite/gnat.dg/self_aggregate_with_call.adb new file mode 100644 index 000000000..4979bd4fc --- /dev/null +++ b/gcc/testsuite/gnat.dg/self_aggregate_with_call.adb @@ -0,0 +1,30 @@ +-- { dg-do run } +-- { dg-options "-O2" } + +procedure self_aggregate_with_call is + + type Values is array (1 .. 8) of Natural; + + type Vector is record + Components : Values; + end record; + + function Clone (Components: Values) return Values is + begin + return Components; + end; + + procedure Process (V : in out Vector) is + begin + V.Components (Values'First) := 1; + V := (Components => Clone (V.Components)); + + if V.Components (Values'First) /= 1 then + raise Program_Error; + end if; + end; + + V : Vector; +begin + Process (V); +end; diff --git a/gcc/testsuite/gnat.dg/self_aggregate_with_pointer.adb b/gcc/testsuite/gnat.dg/self_aggregate_with_pointer.adb new file mode 100644 index 000000000..179fe4e97 --- /dev/null +++ b/gcc/testsuite/gnat.dg/self_aggregate_with_pointer.adb @@ -0,0 +1,26 @@ +-- { dg-do run } + +procedure self_aggregate_with_pointer is + + type Arr is array (Natural range <>) of Integer; + + type Rec (N : Natural) is record + A : Arr (1..N); + end record; + + type Acc_Rec is access all Rec; + + type SRec is record + A : Acc_Rec; + I1, I2, I3, I4, I5, I6, I7: Integer; + end record; + + R : aliased Rec (1); + S : Srec := (A => R'Access, others => 0); + +begin + S := (A => S.A, others => 0); + if S.A /= R'Access then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/self_aggregate_with_zeros.adb b/gcc/testsuite/gnat.dg/self_aggregate_with_zeros.adb new file mode 100644 index 000000000..f774fcdf6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/self_aggregate_with_zeros.adb @@ -0,0 +1,19 @@ +-- { dg-do run } + +procedure self_aggregate_with_zeros is + + type Sensor is record + Value : Natural; + A, B, C, D, E, F, G, H, I, J, K, L, M : Natural; + end record; + + Pressure : Sensor; + +begin + Pressure.Value := 256; + Pressure := (Pressure.Value, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0); + + if Pressure.Value /= 256 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/set_in_pproc.adb b/gcc/testsuite/gnat.dg/set_in_pproc.adb new file mode 100644 index 000000000..8e9ae1c8b --- /dev/null +++ b/gcc/testsuite/gnat.dg/set_in_pproc.adb @@ -0,0 +1,20 @@ +-- { dg-do compile } + +with Ada.Containers.Ordered_Sets; +procedure Set_In_Pproc is + + protected type Ptype is + procedure Pproc; + end; + + protected body Ptype is + procedure Pproc is + package Sets is + new Ada.Containers.Ordered_Sets (Element_Type => Integer); + begin + null; + end; + end; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/show_deques_priority.adb b/gcc/testsuite/gnat.dg/show_deques_priority.adb new file mode 100644 index 000000000..614e825a9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/show_deques_priority.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } + +with Deques; +procedure Show_Deques_Priority is + use Deques; + + PD : aliased P_Deque := Create; + +begin + PD.Pop; +end Show_Deques_Priority; diff --git a/gcc/testsuite/gnat.dg/size_attribute.adb b/gcc/testsuite/gnat.dg/size_attribute.adb new file mode 100644 index 000000000..25642e0b0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/size_attribute.adb @@ -0,0 +1,8 @@ +-- PR middle-end/35823 +-- { dg-do compile ] + +procedure Size_Attribute (Arg : in String) is + Size : constant Natural := Arg'Size; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/sizetype1.adb b/gcc/testsuite/gnat.dg/sizetype1.adb new file mode 100644 index 000000000..e5d12c61e --- /dev/null +++ b/gcc/testsuite/gnat.dg/sizetype1.adb @@ -0,0 +1,14 @@ +-- { dg-do run } + +with Interfaces.C; use Interfaces.C; + +procedure Sizetype1 is + + TC_String : String(1..8) := "abcdefgh"; + TC_No_nul : constant char_array := To_C(TC_String, False); + +begin + if TC_No_nul(0) /= To_C('a') then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/sizetype2.adb b/gcc/testsuite/gnat.dg/sizetype2.adb new file mode 100644 index 000000000..4593936c8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/sizetype2.adb @@ -0,0 +1,27 @@ +-- { dg-do run } + +procedure Sizetype2 is + + function Ident_Int (X : Integer) return Integer is + begin + return X; + end; + + type A is array (Integer range <>) of Boolean; + subtype T1 is A (Ident_Int (- 6) .. Ident_Int (Integer'Last - 4)); + subtype T2 is A (- 6 .. Ident_Int (Integer'Last - 4)); + subtype T3 is A (Ident_Int (- 6) .. Integer'Last - 4); + +begin + if T1'Size /= 17179869200 then + raise Program_Error; + end if; + + if T2'Size /= 17179869200 then + raise Program_Error; + end if; + + if T3'Size /= 17179869200 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/sizetype3.adb b/gcc/testsuite/gnat.dg/sizetype3.adb new file mode 100644 index 000000000..31bab1116 --- /dev/null +++ b/gcc/testsuite/gnat.dg/sizetype3.adb @@ -0,0 +1,20 @@ +-- { dg-do compile } +-- { dg-options "-O" } + +with Sizetype3_Pkg; use Sizetype3_Pkg; + +package body Sizetype3 is + + procedure Handle_Enum_Values is + Values : constant List := F; + L : Values_Array_Access; + begin + L := new Values_Array (1 .. Values'Length); + end Handle_Enum_Values; + + procedure Simplify_Type_Of is + begin + Handle_Enum_Values; + end Simplify_Type_Of; + +end Sizetype3; diff --git a/gcc/testsuite/gnat.dg/sizetype3.ads b/gcc/testsuite/gnat.dg/sizetype3.ads new file mode 100644 index 000000000..f57e6ab97 --- /dev/null +++ b/gcc/testsuite/gnat.dg/sizetype3.ads @@ -0,0 +1,8 @@ +package Sizetype3 is + + type Values_Array is array (Positive range <>) of Integer; + type Values_Array_Access is access all Values_Array; + + procedure Simplify_Type_Of; + +end Sizetype3; diff --git a/gcc/testsuite/gnat.dg/sizetype3_pkg.ads b/gcc/testsuite/gnat.dg/sizetype3_pkg.ads new file mode 100644 index 000000000..ee03262e2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/sizetype3_pkg.ads @@ -0,0 +1,7 @@ +package Sizetype3_Pkg is + + type List is array (Integer range <>) of Integer; + + function F return List; + +end Sizetype3_Pkg; diff --git a/gcc/testsuite/gnat.dg/sizetype4.adb b/gcc/testsuite/gnat.dg/sizetype4.adb new file mode 100644 index 000000000..b3ff64319 --- /dev/null +++ b/gcc/testsuite/gnat.dg/sizetype4.adb @@ -0,0 +1,25 @@ +-- { dg-do run } + +procedure Sizetype4 is + + type Float_Array is array (Integer range <>) of Float; + NoFloats : Float_Array (1 .. 0); + + procedure Q (Results : Float_Array := NoFloats) is + + type Reply_Msg is + record + Request_Id : Integer; + Status : Integer; + Data : Float_Array (Results'Range); + end record; + + begin + if Reply_Msg'Size /= 64 then + raise Program_Error; + end if; + end; + +begin + Q; +end; diff --git a/gcc/testsuite/gnat.dg/slice1.adb b/gcc/testsuite/gnat.dg/slice1.adb new file mode 100644 index 000000000..4c24975f7 --- /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/slice2.adb b/gcc/testsuite/gnat.dg/slice2.adb new file mode 100644 index 000000000..ab7307431 --- /dev/null +++ b/gcc/testsuite/gnat.dg/slice2.adb @@ -0,0 +1,13 @@ +-- { dg-do compile }
+-- { dg-options "-O" }
+
+package body Slice2 is
+
+ function F (I : R1) return R2 is
+ Val : R2;
+ begin
+ Val.Text (1 .. 8) := I.Text (1 .. 8);
+ return Val;
+ end F;
+
+end Slice2;
diff --git a/gcc/testsuite/gnat.dg/slice2.ads b/gcc/testsuite/gnat.dg/slice2.ads new file mode 100644 index 000000000..f1b8674fb --- /dev/null +++ b/gcc/testsuite/gnat.dg/slice2.ads @@ -0,0 +1,14 @@ +package Slice2 is
+
+ type R1 is record
+ Text : String (1 .. 30);
+ end record;
+
+ type R2 is record
+ Text : String (1 .. 8);
+ B : Boolean := True;
+ end record;
+
+ function F (I : R1) return R2;
+
+end Slice2;
diff --git a/gcc/testsuite/gnat.dg/slice3.adb b/gcc/testsuite/gnat.dg/slice3.adb new file mode 100644 index 000000000..db568f997 --- /dev/null +++ b/gcc/testsuite/gnat.dg/slice3.adb @@ -0,0 +1,24 @@ +-- { dg-do run } + +procedure Slice3 is + + type Varray is array (1 .. 1) of Natural; -- SImode + + type Sample is record + Maybe : Boolean; + Values : Varray; + end record; + pragma Pack (Sample); + + function Match (X, Y: Sample; Length : Positive) return Boolean is + begin + return X.Values (1 .. Length) = Y.Values (1 .. Length); + end; + + X, Y : Sample := (Maybe => True, Values => (1 => 1)); +begin + X.Maybe := False; + if not Match (X, Y, 1) then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/slice4.adb b/gcc/testsuite/gnat.dg/slice4.adb new file mode 100644 index 000000000..a7890a210 --- /dev/null +++ b/gcc/testsuite/gnat.dg/slice4.adb @@ -0,0 +1,28 @@ +-- { dg-do run } + +procedure Slice4 is + + type Varray is array (1 .. 1) of Natural; -- SImode + + type Rec is record + Values : Varray; + end record; + + type Sample is record + Maybe : Boolean; + R : Rec; + end record; + pragma Pack (Sample); + + function Match (X, Y: Sample; Length : Positive) return Boolean is + begin + return X.R.Values (1 .. Length) = Y.R.Values (1 .. Length); + end; + + X, Y : Sample := (Maybe => True, R => (Values => (1 => 1))); +begin + X.Maybe := False; + if not Match (X, Y, 1) then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/slice5.adb b/gcc/testsuite/gnat.dg/slice5.adb new file mode 100644 index 000000000..c619b2f60 --- /dev/null +++ b/gcc/testsuite/gnat.dg/slice5.adb @@ -0,0 +1,24 @@ +-- { dg-do compile } +-- { dg-options "-gnatwr" } + +procedure Slice5 is + + type Item_Type is record + I : Integer; + end record; + + type Index_Type is (A, B); + + type table is array (integer range <>) of integer; + subtype Small is Integer range 1 .. 10; + T1 : constant Table (Small) := (Small => 0); + T2 : constant Table (Small) := T1 (Small); -- { dg-warning "redundant slice denotes whole array" } + + Item_Array : constant array (Index_Type) of Item_Type + := (A => (I => 10), B => (I => 22)); + + Item : Item_Type; + for Item'Address use Item_Array(Index_Type)'Address; -- { dg-warning "redundant slice denotes whole array" } +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/slice6.adb b/gcc/testsuite/gnat.dg/slice6.adb new file mode 100644 index 000000000..8d96bbf8c --- /dev/null +++ b/gcc/testsuite/gnat.dg/slice6.adb @@ -0,0 +1,23 @@ +-- { dg-do compile }
+-- { dg-options "-gnatws" }
+
+with Slice6_Pkg; use Slice6_Pkg;
+
+procedure Slice6 is
+
+ procedure Send (V_LENGTH : SHORT_INTEGER) is
+
+ V : Integer;
+
+ V_BLOCK : T_BLOCK (1 .. 4096);
+ for V_BLOCK use at V'Address;
+
+ V_MSG : T_MSG ;
+
+ begin
+ V_MSG := (V_LENGTH, 1, V_BLOCK (1 .. V_LENGTH));
+ end;
+
+begin
+ null;
+end;
diff --git a/gcc/testsuite/gnat.dg/slice6_pkg.ads b/gcc/testsuite/gnat.dg/slice6_pkg.ads new file mode 100644 index 000000000..3154c2959 --- /dev/null +++ b/gcc/testsuite/gnat.dg/slice6_pkg.ads @@ -0,0 +1,15 @@ +package Slice6_Pkg is
+
+ subtype LENGTH_RANGE is SHORT_INTEGER range 0 .. 8184;
+
+ type T_BLOCK is array (SHORT_INTEGER range <>) of SHORT_SHORT_INTEGER;
+ for T_BLOCK'alignment use 4;
+
+ type T_MSG (V_LENGTH : LENGTH_RANGE := 0) is
+ record
+ HEADER : Integer;
+ DATAS : T_BLOCK (1 .. V_LENGTH) := (others => 0);
+ end record;
+ for T_MSG'alignment use 4;
+
+end Slice6_Pkg;
diff --git a/gcc/testsuite/gnat.dg/slice7.adb b/gcc/testsuite/gnat.dg/slice7.adb new file mode 100644 index 000000000..bb68c1f0f --- /dev/null +++ b/gcc/testsuite/gnat.dg/slice7.adb @@ -0,0 +1,38 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +with System.Storage_Elements; use System.Storage_Elements; +with Unchecked_Conversion; +with Slice7_Pkg; use Slice7_Pkg; + +procedure Slice7 is + + type Discrete_Type is range 1 .. 32; + + Max_Byte_Count : constant := 4; + subtype Byte_Count_Type is Storage_Offset range 1..Max_Byte_Count; + + subtype Buffer_Type is Storage_Array (Byte_Count_Type); + function Convert_Put is new Unchecked_Conversion (Integer, Buffer_Type); + + function Set_Buffer_Size return Byte_Count_Type is + begin + return 4; + end; + + Buffer_Size : constant Byte_Count_Type := Set_Buffer_Size; + Buffer_End : constant Byte_Count_Type := Max_Byte_Count; + Buffer_Start : constant Byte_Count_Type := Buffer_End - Buffer_Size + 1; + + Obj : Discrete_Type; + +begin + Put (Convert_Put(Discrete_Type'Pos (Obj))); + + Put (Convert_Put(Discrete_Type'Pos (Obj)) + (Buffer_Start..Buffer_End)); + + Put (Convert_Put(Discrete_Type'Pos (Obj) - + Discrete_Type'Pos (Discrete_Type'First)) + (Buffer_Start..Buffer_End)); +end; diff --git a/gcc/testsuite/gnat.dg/slice7_pkg.ads b/gcc/testsuite/gnat.dg/slice7_pkg.ads new file mode 100644 index 000000000..3c2f4a177 --- /dev/null +++ b/gcc/testsuite/gnat.dg/slice7_pkg.ads @@ -0,0 +1,7 @@ +with System.Storage_Elements; use System.Storage_Elements; + +package Slice7_Pkg is + + procedure Put (The_Object : in Storage_Array); + +end Slice7_Pkg; diff --git a/gcc/testsuite/gnat.dg/slice8.adb b/gcc/testsuite/gnat.dg/slice8.adb new file mode 100644 index 000000000..b05829d0f --- /dev/null +++ b/gcc/testsuite/gnat.dg/slice8.adb @@ -0,0 +1,13 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +with Slice8_Pkg1; +with Slice8_Pkg3; + +procedure Slice8 is + + package Bp is new Slice8_Pkg3 (Slice8_Pkg1); + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/slice8_pkg1.ads b/gcc/testsuite/gnat.dg/slice8_pkg1.ads new file mode 100644 index 000000000..3f433fdfb --- /dev/null +++ b/gcc/testsuite/gnat.dg/slice8_pkg1.ads @@ -0,0 +1,3 @@ +with Slice8_Pkg2; + +package Slice8_Pkg1 is new Slice8_Pkg2 (Line_Length => 132, Max_Lines => 1000); diff --git a/gcc/testsuite/gnat.dg/slice8_pkg2.ads b/gcc/testsuite/gnat.dg/slice8_pkg2.ads new file mode 100644 index 000000000..a6eafc6aa --- /dev/null +++ b/gcc/testsuite/gnat.dg/slice8_pkg2.ads @@ -0,0 +1,23 @@ +generic + + Line_Length : Natural; + Max_Lines : Natural; + +package Slice8_Pkg2 is + + Subtype Index is Natural Range 0..Line_length; + Subtype Line_Count is Natural Range 0..Max_Lines; + + Type Line (Size : Index := 0) is + Record + Data : String (1..Size); + End Record; + + Type Lines is Array (Line_Count Range <>) of Line; + + Type Paragraph (Size : Line_Count) is + Record + Data : Lines (1..Size); + End Record; + +end Slice8_Pkg2; diff --git a/gcc/testsuite/gnat.dg/slice8_pkg3.adb b/gcc/testsuite/gnat.dg/slice8_pkg3.adb new file mode 100644 index 000000000..3524de1f0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/slice8_pkg3.adb @@ -0,0 +1,17 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +package body Slice8_Pkg3 is + + Current : Str.Lines (Str.Line_Count); + Last : Natural := 0; + + function Get return Str.Paragraph is + Result : constant Str.Paragraph := (Size => Last, + Data => Current (1..Last)); + begin + Last := 0; + return Result; + end Get; + +end Slice8_Pkg3; diff --git a/gcc/testsuite/gnat.dg/slice8_pkg3.ads b/gcc/testsuite/gnat.dg/slice8_pkg3.ads new file mode 100644 index 000000000..a802cb72d --- /dev/null +++ b/gcc/testsuite/gnat.dg/slice8_pkg3.ads @@ -0,0 +1,11 @@ +with Slice8_Pkg2; + +generic + + with package Str is new Slice8_Pkg2 (<>); + +package Slice8_Pkg3 is + + function Get return Str.Paragraph; + +end Slice8_Pkg3; diff --git a/gcc/testsuite/gnat.dg/slice_enum.adb b/gcc/testsuite/gnat.dg/slice_enum.adb new file mode 100644 index 000000000..cdaea47d6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/slice_enum.adb @@ -0,0 +1,8 @@ +-- { dg-do compile } + +procedure Slice_Enum is + Pos : array (Boolean) of Integer; +begin + Pos (Boolean) := (others => 0); +end; + diff --git a/gcc/testsuite/gnat.dg/small_alignment.adb b/gcc/testsuite/gnat.dg/small_alignment.adb new file mode 100644 index 000000000..fbe1c2145 --- /dev/null +++ b/gcc/testsuite/gnat.dg/small_alignment.adb @@ -0,0 +1,28 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +procedure Small_Alignment is + + type My_Integer is new Integer; + for My_Integer'Alignment use 1; + + function Set_A return My_Integer is + begin + return 12; + end; + + function Set_B return My_Integer is + begin + return 6; + end; + + C : Character; + A : My_Integer := Set_A; + B : My_Integer := Set_B; + +begin + A := A * B / 2; + if A /= 36 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/socket1.adb b/gcc/testsuite/gnat.dg/socket1.adb new file mode 100644 index 000000000..a6bdade30 --- /dev/null +++ b/gcc/testsuite/gnat.dg/socket1.adb @@ -0,0 +1,14 @@ +-- { dg-do run { target { ! "*-*-solaris2*" } } } + +with GNAT.Sockets; use GNAT.Sockets; +procedure socket1 is + X : Character; +begin + X := 'x'; + GNAT.Sockets.Initialize; + declare + H : Host_Entry_Type := Get_Host_By_Address (Inet_Addr ("127.0.0.1")); + begin + null; + end; +end socket1; diff --git a/gcc/testsuite/gnat.dg/sort1.adb b/gcc/testsuite/gnat.dg/sort1.adb new file mode 100644 index 000000000..cf0fb5d5f --- /dev/null +++ b/gcc/testsuite/gnat.dg/sort1.adb @@ -0,0 +1,27 @@ +with GNAT.Heap_Sort_G; +function sort1 (S : String) return String is + Result : String (1 .. S'Length) := S; + Temp : Character; + + procedure Move (From : Natural; To : Natural) is + begin + if From = 0 then Result (To) := Temp; + elsif To = 0 then Temp := Result (From); + else Result (To) := Result (From); + end if; + end Move; + + function Lt (Op1, Op2 : Natural) return Boolean is + begin + if Op1 = 0 then return Temp < Result (Op2); + elsif Op2 = 0 then return Result (Op1) < Temp; + else return Result (Op1) < Result (Op2); + end if; + end Lt; + + package SP is new GNAT.Heap_Sort_G (Move, Lt); + +begin + SP.Sort (S'Length); + return Result; +end; diff --git a/gcc/testsuite/gnat.dg/sort1.ads b/gcc/testsuite/gnat.dg/sort1.ads new file mode 100644 index 000000000..6c972a489 --- /dev/null +++ b/gcc/testsuite/gnat.dg/sort1.ads @@ -0,0 +1,2 @@ +function sort1 (S : String) return String; +pragma Pure (sort1); diff --git a/gcc/testsuite/gnat.dg/sort2.adb b/gcc/testsuite/gnat.dg/sort2.adb new file mode 100644 index 000000000..084ad38bf --- /dev/null +++ b/gcc/testsuite/gnat.dg/sort2.adb @@ -0,0 +1,9 @@ +-- { dg-do run } + +with sort1; +procedure sort2 is +begin + if Sort1 ("hello world") /= " dehllloorw" then + raise Program_Error; + end if; +end sort2; diff --git a/gcc/testsuite/gnat.dg/specs/abstract_limited.ads b/gcc/testsuite/gnat.dg/specs/abstract_limited.ads new file mode 100644 index 000000000..adcd35249 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/abstract_limited.ads @@ -0,0 +1,6 @@ +-- { dg-do compile } + +package abstract_limited is + type I is limited interface; + type T is abstract limited new I with null record; +end; diff --git a/gcc/testsuite/gnat.dg/specs/abstract_private.ads b/gcc/testsuite/gnat.dg/specs/abstract_private.ads new file mode 100644 index 000000000..7420a9842 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/abstract_private.ads @@ -0,0 +1,17 @@ +generic +package Abstract_Private is + + type T1 is abstract tagged private; + procedure P1 (X : T1) is abstract; + + type T2 is abstract tagged private; + +private + + type T1 is abstract tagged null record; + procedure P2 (X : T1) is abstract; -- { dg-error "must be visible" } + + type T2 is abstract new T1 with null record; + procedure P1 (X : T2) is abstract; + +end Abstract_Private; diff --git a/gcc/testsuite/gnat.dg/specs/access3.ads b/gcc/testsuite/gnat.dg/specs/access3.ads new file mode 100644 index 000000000..f7fbf7e1e --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/access3.ads @@ -0,0 +1,25 @@ +-- { dg-do compile } + +package access3 is + type TF is access function return access procedure (P1 : Integer); + + type TAF is access protected function return access procedure (P1 : Integer); + + type TAF2 is access + function return access protected procedure (P1 : Integer); + + type TAF3 is access + protected function return access protected procedure (P1 : Integer); + + type TAF_Inf is + access protected function return + access function return + access function return + access function return + access function return + access function return + access function return + access function return + access function return + Integer; +end access3; diff --git a/gcc/testsuite/gnat.dg/specs/access_constant.ads b/gcc/testsuite/gnat.dg/specs/access_constant.ads new file mode 100644 index 000000000..fa9829e83 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/access_constant.ads @@ -0,0 +1,13 @@ +-- { dg-do compile } +package Access_Constant is + + c: aliased constant integer := 3; + + type const_ptr is access constant integer; + cp : const_ptr := c'access; + + procedure inc (var_ptr: access integer := + cp) -- { dg-error "access-to-constant" } + is abstract; + +end Access_Constant; diff --git a/gcc/testsuite/gnat.dg/specs/access_constant_decl.ads b/gcc/testsuite/gnat.dg/specs/access_constant_decl.ads new file mode 100644 index 000000000..aec40e6db --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/access_constant_decl.ads @@ -0,0 +1,11 @@ +-- { dg-do compile } +package Access_Constant_Decl is + + c: aliased constant integer := 3; + + type const_ptr is access constant integer; + cp : const_ptr := c'access; + + x : access integer := cp; -- { dg-error "access-to-constant" } + +end Access_Constant_Decl; diff --git a/gcc/testsuite/gnat.dg/specs/addr1.ads b/gcc/testsuite/gnat.dg/specs/addr1.ads new file mode 100644 index 000000000..ed048f68e --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/addr1.ads @@ -0,0 +1,35 @@ +-- { dg-do compile } + +with Interfaces; use Interfaces; + +package Addr1 is + + type Arr is array (Integer range <>) of Unsigned_16; + + type Rec1 is record + I1, I2: Integer; + end record; + + type Rec2 is record + I1, I2: Integer; + end record; + for Rec2'Size use 64; + + A: Arr (1 .. 4); + + Obj1: Rec1; + for Obj1'Address use A'Address; -- { dg-bogus "alignment" } + + Obj2: Rec2; + for Obj2'Address use A'Address; -- { dg-bogus "alignment" } + + Obj3: Rec1; + for Obj3'Address use A(1)'Address; -- { dg-bogus "alignment" } + + Obj4: Rec1; + for Obj4'Address use A(2)'Address; -- { dg-warning "(alignment|erroneous)" } + + Obj5: Rec1; + for Obj5'Address use A(3)'Address; -- { dg-bogus "alignment" } + +end Addr1; diff --git a/gcc/testsuite/gnat.dg/specs/aggr1.ads b/gcc/testsuite/gnat.dg/specs/aggr1.ads new file mode 100644 index 000000000..6c7663513 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/aggr1.ads @@ -0,0 +1,8 @@ +-- { dg-do compile } + +package aggr1 is + type Buffer_Array is array (1 .. 2 ** 23) of Integer; + type Message is record + Data : Buffer_Array := (others => 0); + end record; +end; 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 000000000..88d7e9876 --- /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/alignment1.ads b/gcc/testsuite/gnat.dg/specs/alignment1.ads new file mode 100644 index 000000000..cffcba138 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/alignment1.ads @@ -0,0 +1,11 @@ +-- { dg-do compile } + +package Alignment1 is + S : Natural := 20; + pragma Volatile (S); + + type Block is array (1 .. S) of Integer; + for Block'Alignment use 128; + + B : Block; +end; diff --git a/gcc/testsuite/gnat.dg/specs/alignment2.ads b/gcc/testsuite/gnat.dg/specs/alignment2.ads new file mode 100644 index 000000000..8dce1a8c3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/alignment2.ads @@ -0,0 +1,47 @@ +-- { dg-do compile } + +with Interfaces; use Interfaces; + +package Alignment2 is + + -- warning + type R1 is record + A, B, C, D : Integer_8; + end record; + for R1'Size use 32; + for R1'Alignment use 32; -- { dg-warning "suspiciously large alignment" } + + -- warning + type R2 is record + A, B, C, D : Integer_8; + end record; + for R2'Alignment use 32; -- { dg-warning "suspiciously large alignment" } + + -- OK, big size + type R3 is record + A, B, C, D : Integer_8; + end record; + for R3'Size use 32 * 8; + for R3'Alignment use 32; + + -- OK, big size + type R4 is record + A, B, C, D, E, F, G, H : Integer_32; + end record; + for R4'Alignment use 32; + + -- warning + type I1 is new Integer_32; + for I1'Size use 32; + for I1'Alignment use 32; -- { dg-warning "suspiciously large alignment" } + + -- warning + type I2 is new Integer_32; + for I2'Alignment use 32; -- { dg-warning "suspiciously large alignment" } + + -- OK, big size + type I3 is new Integer_32; + for I3'Size use 32 * 8; + for I3'Alignment use 32; + +end Alignment2; diff --git a/gcc/testsuite/gnat.dg/specs/array_no_def_init.ads b/gcc/testsuite/gnat.dg/specs/array_no_def_init.ads new file mode 100644 index 000000000..b7a024d6f --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/array_no_def_init.ads @@ -0,0 +1,9 @@ +-- { dg-do compile } + +pragma Restrictions (No_Default_Initialization); +package Array_No_Def_Init is + + type Int_Array is array (Natural range <>) of Integer; + IA : Int_Array (1 .. 10); + +end Array_No_Def_Init; diff --git a/gcc/testsuite/gnat.dg/specs/attribute_parsing.ads b/gcc/testsuite/gnat.dg/specs/attribute_parsing.ads new file mode 100644 index 000000000..7722a9ae1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/attribute_parsing.ads @@ -0,0 +1,5 @@ +-- { dg-do compile } +package Attribute_Parsing is + I : constant Integer := 12345; + S : constant String := I'Img (1 .. 2); +end Attribute_Parsing; diff --git a/gcc/testsuite/gnat.dg/specs/box1.ads b/gcc/testsuite/gnat.dg/specs/box1.ads new file mode 100644 index 000000000..dad13f332 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/box1.ads @@ -0,0 +1,13 @@ +-- { dg-do compile } + +package box1 is + type Root is tagged null record; + type Der1 is new Root with record + B : Boolean; + end record; + + type Der2 is new Der1 with null record; + type Der3 is new Der2 with null record; + + Obj : Der3 := (Der2 with others => <>); +end; diff --git a/gcc/testsuite/gnat.dg/specs/constant1.ads b/gcc/testsuite/gnat.dg/specs/constant1.ads new file mode 100644 index 000000000..1c00c33f7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/constant1.ads @@ -0,0 +1,22 @@ +-- { dg-do compile } + +with Constant1_Pkg; + +package Constant1 is + + type Timer_Id_T is new Constant1_Pkg.Timer_Id_T with null record; + + type Timer_Op_T (Pending : Boolean := False) is + record + case Pending is + when True => + Timer_Id : Timer_Id_T; + when False => + null; + end case; + end record; + + Timer : Timer_Op_T + := (True, Timer_Id_T'(Constant1_Pkg.Null_Timer_Id with null record)); + +end Constant1; diff --git a/gcc/testsuite/gnat.dg/specs/constant1_pkg.ads b/gcc/testsuite/gnat.dg/specs/constant1_pkg.ads new file mode 100644 index 000000000..13300b1ad --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/constant1_pkg.ads @@ -0,0 +1,11 @@ +package Constant1_Pkg is + + type Id_T is mod Natural'Last + 1; + + type Timer_Id_T is tagged record + Id : Id_T := Id_T'Last; + end record; + + Null_Timer_Id : constant Timer_Id_T := (Id => Id_T'Last - 1); + +end Constant1_Pkg; diff --git a/gcc/testsuite/gnat.dg/specs/constructor.ads b/gcc/testsuite/gnat.dg/specs/constructor.ads new file mode 100644 index 000000000..aaabc41ed --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/constructor.ads @@ -0,0 +1,13 @@ +-- { dg-do compile } + +package constructor is + type R (Name_Length : Natural) is record + Name : Wide_String (1..Name_Length); + Multiple : Boolean; + end record; + + Null_Params : constant R := + (Name_Length => 0, + Name => "", + Multiple => False); +end; diff --git a/gcc/testsuite/gnat.dg/specs/controlled1.ads b/gcc/testsuite/gnat.dg/specs/controlled1.ads new file mode 100644 index 000000000..1ceedaf37 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/controlled1.ads @@ -0,0 +1,35 @@ +-- { dg-do compile } + +with Ada.Finalization; +with Controlled1_Pkg; use Controlled1_Pkg; + +package Controlled1 is + + type Collection is new Ada.Finalization.Controlled with null record; + + type Object_Kind_Type is (One, Two); + + type Byte_Array is array (Natural range <>) of Integer; + + type Bounded_Byte_Array_Type is record + A : Byte_Array (1 .. Value); + end record; + + type Object_Type is tagged record + A : Bounded_Byte_Array_Type; + end record; + + type R_Object_Type is new Object_Type with record + L : Collection; + end record; + + type Obj_Type (Kind : Object_Kind_Type := One) is record + case Kind is + when One => R : R_Object_Type; + when others => null; + end case; + end record; + + type Obj_Array_Type is array (Positive range <>) of Obj_Type; + +end Controlled1; diff --git a/gcc/testsuite/gnat.dg/specs/controlled1_pkg.ads b/gcc/testsuite/gnat.dg/specs/controlled1_pkg.ads new file mode 100644 index 000000000..3d08c1ee9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/controlled1_pkg.ads @@ -0,0 +1,7 @@ +-- { dg-excess-errors "no code generated" } + +package Controlled1_Pkg is + + function Value return Natural; + +end Controlled1_Pkg; diff --git a/gcc/testsuite/gnat.dg/specs/controller.ads b/gcc/testsuite/gnat.dg/specs/controller.ads new file mode 100644 index 000000000..eff9e0536 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/controller.ads @@ -0,0 +1,15 @@ +-- { dg-do compile } + +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +package Controller is + type Iface is interface; + type Thing is tagged record + Name : Unbounded_String; + end record; + type Object is abstract new Thing and Iface with private; +private + type Object is abstract new Thing and Iface + with record + Surname : Unbounded_String; + end record; +end Controller; diff --git a/gcc/testsuite/gnat.dg/specs/corr_discr.ads b/gcc/testsuite/gnat.dg/specs/corr_discr.ads new file mode 100644 index 000000000..70ea86056 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/corr_discr.ads @@ -0,0 +1,13 @@ +package Corr_Discr is + + type Base (T1 : Boolean := True; T2 : Boolean := False) + is null record; + for Base use record + T1 at 0 range 0 .. 0; + T2 at 0 range 1 .. 1; + end record; + + type Deriv (D : Boolean := False) is new Base (T1 => True, T2 => D); + +end Corr_Discr; + diff --git a/gcc/testsuite/gnat.dg/specs/cpp1.ads b/gcc/testsuite/gnat.dg/specs/cpp1.ads new file mode 100644 index 000000000..1f759b7a9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/cpp1.ads @@ -0,0 +1,10 @@ +-- { dg-do compile } + +package cpp1 is + type Root_Interface is interface; + + type Typ is new Root_Interface with record + TOTO : Integer; + pragma CPP_Vtable (TOTO); + end record; +end cpp1; diff --git a/gcc/testsuite/gnat.dg/specs/cpp_assignment.ads b/gcc/testsuite/gnat.dg/specs/cpp_assignment.ads new file mode 100644 index 000000000..3247b671b --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/cpp_assignment.ads @@ -0,0 +1,10 @@ +-- { dg-do compile } + +package CPP_Assignment is + type T is tagged record + Data : Integer := 0; + end record; + pragma Convention (CPP, T); + + Obj1 : T := (Data => 1); Obj2 : T'Class := Obj1; +end; diff --git a/gcc/testsuite/gnat.dg/specs/delta_small.ads b/gcc/testsuite/gnat.dg/specs/delta_small.ads new file mode 100644 index 000000000..3ff742631 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/delta_small.ads @@ -0,0 +1,9 @@ +-- { dg-do compile } + +package Delta_Small is + type T is delta 0.1 range -0.8 .. 0.8; + for T'Small use 0.1; + for T'Size use 4; + type T2 is new T range -0.4 .. 0.4; + for T2'Small use 0.0625; +end Delta_Small; diff --git a/gcc/testsuite/gnat.dg/specs/discr_private.ads b/gcc/testsuite/gnat.dg/specs/discr_private.ads new file mode 100644 index 000000000..0ddfbd137 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/discr_private.ads @@ -0,0 +1,50 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +package Discr_Private is + + package Dec is + type T_DECIMAL (Prec : Integer := 1) is private; + private + type T_DECIMAL (Prec : Integer := 1) is record + case Prec is + when 1 .. 2 => Value : Integer; + when others => null; + end case; + end record; + end; + + type Value_T is record + Bits : Dec.T_DECIMAL(1); + end record; + for Value_T'size use 88; + + type Value_Entry_T is record + Index : Integer; + Value : Value_T; + end record; + + type Value_Mode is (QI, HI, SI, DI, XI); + for Value_Mode'size use 8; + + type Valid_Modes_T is array (Value_Mode) of Boolean; + + type Register_T is record + Ventry : Value_Entry_T; + Vmodes : Valid_Modes_T; + end record; + + type Regid_T is (Latch, Acc); + for Regid_T use (Latch => 0, Acc => 2); + for Regid_T'Size use 8; + + type Regarray_T is array (Regid_T) of Register_T; + + type Machine_T (Up : Boolean := True) is record + case Up is + when True => Regs : Regarray_T; + when False => null; + end case; + end record; + +end Discr_Private; diff --git a/gcc/testsuite/gnat.dg/specs/discr_record_constant.ads b/gcc/testsuite/gnat.dg/specs/discr_record_constant.ads new file mode 100644 index 000000000..f43b13869 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/discr_record_constant.ads @@ -0,0 +1,22 @@ +-- { dg-do compile } + +pragma Restrictions (No_Implicit_Heap_Allocations); + +package Discr_Record_Constant is + + type T (Big : Boolean := False) is record + case Big is + when True => + Content : Integer; + when False => + null; + end case; + end record; + + D : constant T := (True, 0); + + Var : T := D; -- OK, maximum size + Con : constant T := D; -- Violation of restriction + Ter : constant T := Con; -- Violation of restriction + +end Discr_Record_Constant; diff --git a/gcc/testsuite/gnat.dg/specs/double_record_extension1.ads b/gcc/testsuite/gnat.dg/specs/double_record_extension1.ads new file mode 100644 index 000000000..c1c436f3e --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/double_record_extension1.ads @@ -0,0 +1,13 @@ +-- { dg-do compile } + +package double_record_extension1 is + + type T1(n: natural) is tagged record + s1: string (1..n); + end record; + type T2(j,k: natural) is new T1(j) with record + s2: string (1..k); + end record; + type T3 is new T2 (10, 10) with null record; + +end double_record_extension1; diff --git a/gcc/testsuite/gnat.dg/specs/double_record_extension2.ads b/gcc/testsuite/gnat.dg/specs/double_record_extension2.ads new file mode 100644 index 000000000..8fa83dbce --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/double_record_extension2.ads @@ -0,0 +1,17 @@ +-- { dg-do compile } + +package double_record_extension2 is + + type Base_Message_Type (Num_Bytes : Positive) is tagged record + Data_Block : String (1..Num_Bytes); + end record; + + type Extended_Message_Type (Num_Bytes1 : Positive; Num_Bytes2 : Positive) is new Base_Message_Type (Num_Bytes1) with record + A: String (1..Num_Bytes2); + end record; + + type Final_Message_Type is new Extended_Message_Type with record + B : Integer; + end record; + +end double_record_extension2; diff --git a/gcc/testsuite/gnat.dg/specs/elab1.ads b/gcc/testsuite/gnat.dg/specs/elab1.ads new file mode 100644 index 000000000..ac435d76a --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/elab1.ads @@ -0,0 +1,21 @@ +-- { dg-do compile } + +pragma Restrictions(No_Elaboration_Code); + +with System; + +package Elab1 is + + type Ptrs_Type is array (Integer range 1 .. 2) of System.Address; + type Vars_Array is array (Integer range 1 .. 2) of Integer; + + Vars : Vars_Array; + + Val1 : constant Integer := 1; + Val2 : constant Integer := 2; + + Ptrs : constant Ptrs_Type := + (1 => Vars (Val1)'Address, + 2 => Vars (Val2)'Address); + +end Elab1; diff --git a/gcc/testsuite/gnat.dg/specs/empty_variants.ads b/gcc/testsuite/gnat.dg/specs/empty_variants.ads new file mode 100644 index 000000000..079b64ac8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/empty_variants.ads @@ -0,0 +1,32 @@ +-- { dg-do compile } +-- { dg-options "-gnatdF" } + +package Empty_Variants is + + type Rec (D : Integer := 1) is record + case D is + when 1 => + I : Integer; + when 2 .. 5 => + J : Integer; + K : Integer; + when 6 => + null; + when 7 .. 8 => + null; + when others => + L : Integer; + M : Integer; + N : Integer; + end case; + end record; + + R : Rec; + + I : Integer := R.I; + J : Integer := R.J; + K : Integer := R.K; + L : Integer := R.L; + M : Integer := R.L; + +end Empty_Variants; diff --git a/gcc/testsuite/gnat.dg/specs/fe_inlining.ads b/gcc/testsuite/gnat.dg/specs/fe_inlining.ads new file mode 100644 index 000000000..ef5f46942 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/fe_inlining.ads @@ -0,0 +1,4 @@ +-- { dg-do compile } +-- { dg-options "-O -gnatN" } +with FE_Inlining_Helper; +procedure FE_Inlining is new FE_Inlining_Helper; diff --git a/gcc/testsuite/gnat.dg/specs/fe_inlining_helper.adb b/gcc/testsuite/gnat.dg/specs/fe_inlining_helper.adb new file mode 100644 index 000000000..c149ea3c7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/fe_inlining_helper.adb @@ -0,0 +1,4 @@ +procedure FE_Inlining_Helper is +begin + null; +end FE_Inlining_Helper; diff --git a/gcc/testsuite/gnat.dg/specs/fe_inlining_helper.ads b/gcc/testsuite/gnat.dg/specs/fe_inlining_helper.ads new file mode 100644 index 000000000..733268c65 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/fe_inlining_helper.ads @@ -0,0 +1,3 @@ +-- { dg-excess-errors "no code generated" } +generic +procedure FE_Inlining_Helper; diff --git a/gcc/testsuite/gnat.dg/specs/formal_type.ads b/gcc/testsuite/gnat.dg/specs/formal_type.ads new file mode 100644 index 000000000..4f12b82d3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/formal_type.ads @@ -0,0 +1,15 @@ +-- { dg-do compile } + +with Ada.Strings.Bounded; +package formal_type is + generic + with package BI is + new Ada.Strings.Bounded.Generic_Bounded_Length (<>); + type NB is new BI.Bounded_String; + package G is end; + package BI is new Ada.Strings.Bounded.Generic_Bounded_Length (30); + type NB is new BI.Bounded_String; + Thing : NB; + Size : Integer := THing.Max_Length; + package GI is new G (BI, NB); +end; diff --git a/gcc/testsuite/gnat.dg/specs/gen_interface.ads b/gcc/testsuite/gnat.dg/specs/gen_interface.ads new file mode 100644 index 000000000..9ec902d42 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/gen_interface.ads @@ -0,0 +1,8 @@ +-- { dg-do compile } + +with gen_interface_p; +package gen_interface is + type T is interface; + procedure P (Thing: T) is abstract; + package NG is new gen_interface_p (T, P); +end; diff --git a/gcc/testsuite/gnat.dg/specs/gen_interface_p.ads b/gcc/testsuite/gnat.dg/specs/gen_interface_p.ads new file mode 100644 index 000000000..5ebceb253 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/gen_interface_p.ads @@ -0,0 +1,5 @@ +generic + type I is interface; + with procedure P (X : I) is abstract; +package gen_interface_p is +end; diff --git a/gcc/testsuite/gnat.dg/specs/genericppc.ads b/gcc/testsuite/gnat.dg/specs/genericppc.ads new file mode 100644 index 000000000..494a8890b --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/genericppc.ads @@ -0,0 +1,7 @@ +-- { dg-do compile } +-- { dg-options "-gnatc" } + +generic + type T_Item is private; +function genericppc (T : in t_Item; I : integer) return integer; +pragma Precondition (I > 0); diff --git a/gcc/testsuite/gnat.dg/specs/gnati.ads b/gcc/testsuite/gnat.dg/specs/gnati.ads new file mode 100644 index 000000000..72eff6e2e --- /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/specs/iface_eq_test-child.ads b/gcc/testsuite/gnat.dg/specs/iface_eq_test-child.ads new file mode 100644 index 000000000..028bb1be0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/iface_eq_test-child.ads @@ -0,0 +1,9 @@ +-- { dg-do compile } +-- { dg-options "-gnatc" } +generic +package Iface_Eq_Test.Child is + protected type PO is new Iface with + procedure Dummy; + end; + overriding function "=" (L, R : access PO) return Boolean; +end; diff --git a/gcc/testsuite/gnat.dg/specs/iface_eq_test.ads b/gcc/testsuite/gnat.dg/specs/iface_eq_test.ads new file mode 100644 index 000000000..36f9031ad --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/iface_eq_test.ads @@ -0,0 +1,6 @@ +-- { dg-do compile } +generic +package Iface_Eq_Test is + type Iface is limited interface; + function "=" (L, R : access Iface) return Boolean is abstract; +end; diff --git a/gcc/testsuite/gnat.dg/specs/import_abstract.ads b/gcc/testsuite/gnat.dg/specs/import_abstract.ads new file mode 100644 index 000000000..9d05f0c1c --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/import_abstract.ads @@ -0,0 +1,6 @@ +-- { dg-do compile } +package Import_Abstract is + type T1 is abstract tagged null record; + procedure p1(X : T1) is abstract; + pragma Import (Ada, p1); -- { dg-error "cannot import abstract subprogram" } +end Import_Abstract; diff --git a/gcc/testsuite/gnat.dg/specs/integer_value.ads b/gcc/testsuite/gnat.dg/specs/integer_value.ads new file mode 100644 index 000000000..6e9c1b51f --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/integer_value.ads @@ -0,0 +1,5 @@ +-- { dg-do compile } +package Integer_Value is + X : constant Integer := + Integer'Integer_Value (12.8); -- { dg-error "fixed-point type" "" } +end Integer_Value; diff --git a/gcc/testsuite/gnat.dg/specs/interface5.ads b/gcc/testsuite/gnat.dg/specs/interface5.ads new file mode 100644 index 000000000..842b5e3fe --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/interface5.ads @@ -0,0 +1,9 @@ +-- { dg-do compile } +-- { dg-options "-gnatc" } + +package interface5 is + type Lim_Iface is limited interface; + protected type Prot_Typ is new Lim_Iface with + private + end Prot_Typ; +end interface5; diff --git a/gcc/testsuite/gnat.dg/specs/limited1.ads b/gcc/testsuite/gnat.dg/specs/limited1.ads new file mode 100644 index 000000000..375cf66f5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/limited1.ads @@ -0,0 +1,10 @@ +-- { dg-do compile } + +package limited1 is + pragma Pure; + + type Buffer is limited interface; + type Synchronous_Buffer_Type is synchronized interface and Buffer; + +private +end limited1; diff --git a/gcc/testsuite/gnat.dg/specs/linker_section.ads b/gcc/testsuite/gnat.dg/specs/linker_section.ads new file mode 100644 index 000000000..73e89aa48 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/linker_section.ads @@ -0,0 +1,13 @@ +package Linker_Section is + Data1 : constant String := "12345678901234567"; + pragma Linker_Section (Entity => Data1, + Section => ".eeprom"); + type EEPROM_String is new String; + pragma Linker_Section (Entity => EEPROM_String, -- { dg-error "objects" } + Section => ".eeprom"); + Data2 : constant EEPROM_String := "12345678901234567"; + package Inner is end; + pragma Linker_Section (Entity => Inner, -- { dg-error "objects" } + Section => ".eeprom"); +end Linker_Section; + diff --git a/gcc/testsuite/gnat.dg/specs/lto3.ads b/gcc/testsuite/gnat.dg/specs/lto3.ads new file mode 100644 index 000000000..9576376f2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/lto3.ads @@ -0,0 +1,11 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } +-- { dg-options "-gnatws -flto" { target lto } } + +with Lto3_Pkg1; + +package Lto3 is + + package P is new Lto3_Pkg1 (Id_T => Natural); + +end Lto3; diff --git a/gcc/testsuite/gnat.dg/specs/lto3_pkg1.adb b/gcc/testsuite/gnat.dg/specs/lto3_pkg1.adb new file mode 100644 index 000000000..34caa3c6c --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/lto3_pkg1.adb @@ -0,0 +1,24 @@ +package body Lto3_Pkg1 is + + function Is_Fixed return Boolean is + begin + return True; + end Is_Fixed; + + function Do_Item (I : Natural) return Variable_Data_Fixed_T is + It : Variable_Data_Fixed_T; + begin + return It; + end Do_Item; + + My_Db : Db.T; + + procedure Run is + Kitem : Variable_Data_Fixed_T; + I : Natural; + begin + Kitem := Db.Get (My_Db); + Kitem := Do_Item (I); + end Run; + +end Lto3_Pkg1; diff --git a/gcc/testsuite/gnat.dg/specs/lto3_pkg1.ads b/gcc/testsuite/gnat.dg/specs/lto3_pkg1.ads new file mode 100644 index 000000000..5619b60c7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/lto3_pkg1.ads @@ -0,0 +1,26 @@ +-- { dg-excess-errors "no code generated" } + +with Lto3_Pkg2; + +generic + type Id_T is range <>; +package Lto3_Pkg1 is + + type Variable_Data_T (Fixed : Boolean := False) is + record + case Fixed is + when True => + Length : Natural; + when False => + null; + end case; + end record; + + function Is_Fixed return Boolean; + + type Variable_Data_Fixed_T is new Variable_Data_T (Is_Fixed); + + package Db is new Lto3_Pkg2 (Id_T => Id_T, + Data_T => Variable_Data_Fixed_T); + +end Lto3_Pkg1; diff --git a/gcc/testsuite/gnat.dg/specs/lto3_pkg2.adb b/gcc/testsuite/gnat.dg/specs/lto3_pkg2.adb new file mode 100644 index 000000000..d95fe60dd --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/lto3_pkg2.adb @@ -0,0 +1,7 @@ +package body Lto3_Pkg2 is + function Get (X : T) return Data_T is + Result : Data_T; + begin + return Result; + end; +end Lto3_Pkg2; diff --git a/gcc/testsuite/gnat.dg/specs/lto3_pkg2.ads b/gcc/testsuite/gnat.dg/specs/lto3_pkg2.ads new file mode 100644 index 000000000..52fdccb90 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/lto3_pkg2.ads @@ -0,0 +1,11 @@ +-- { dg-excess-errors "no code generated" } + +generic + type Id_T is private; + type Data_T is private; +package Lto3_Pkg2 is + type T is private; + function Get (X : T) return Data_T; +private + type T is null record; +end Lto3_Pkg2; diff --git a/gcc/testsuite/gnat.dg/specs/null_aggr_bug.ads b/gcc/testsuite/gnat.dg/specs/null_aggr_bug.ads new file mode 100644 index 000000000..95467f428 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/null_aggr_bug.ads @@ -0,0 +1,20 @@ +-- { dg-do compile } +package Null_Aggr_Bug is + + type Rec1 is null record; + + type Rec2 is tagged null record; + + type Rec3 is new Rec2 with null record; + + X1 : Rec1 := (null record); + Y1 : Rec1 := (others => <>); + + X2 : Rec2 := (null record); + Y2 : Rec2 := (others => <>); + + X3 : Rec3 := (null record); + Y3 : Rec3 := (others => <>); + Z3 : Rec3 := (Rec2 with others => <>); + +end Null_Aggr_Bug; diff --git a/gcc/testsuite/gnat.dg/specs/oconst6.ads b/gcc/testsuite/gnat.dg/specs/oconst6.ads new file mode 100644 index 000000000..e4c3c50eb --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/oconst6.ads @@ -0,0 +1,18 @@ +-- { dg-do compile } +-- { dg-final { scan-assembler-not "elabs" } } + +package OCONST6 is + + type Sequence is array (1 .. 1) of Natural; + + type Message is record + Data : Sequence; + end record; + + for Message'Alignment use 1; + pragma PACK (Message); + + ACK : Message := (Data => (others => 1)); + +end; + diff --git a/gcc/testsuite/gnat.dg/specs/oversize.ads b/gcc/testsuite/gnat.dg/specs/oversize.ads new file mode 100644 index 000000000..e98c8bd77 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/oversize.ads @@ -0,0 +1,56 @@ +with Ada.Numerics.Discrete_Random; + +package Oversize is + + subtype M1 is Integer range 1 .. 200; -- Won't trigger + type R1 (D : M1 := 100) is record + Name : String (1 .. D); + end record; + + type M2 is new Integer range 1 .. 200; -- Won't trigger + for M2'Size use 64; + type M2S is array (M2 range <>) of Character; + type R2 (D : M2 := 100) is record + Name : M2S (1 .. D); + end record; + + subtype M3 is Integer; -- Will trigger + type R3 (D : M3 := 100) -- { dg-error "may raise Storage_Error" } + is record + Name : String (1 .. D); + end record; + + type M4 is new Positive; -- Will trigger + type M4S is array (M4 range <>) of Character; + type R4 (D : M4 := 100) -- { dg-error "may raise Storage_Error" } + is record + Name : M4S (1 .. D); + end record; + + type M5 is new Positive; -- Will trigger + for M5'Size use Integer'Size - 1; + type M5S is array (M5 range <>) of Character; + type R5 (D : M5 := 100) -- { dg-error "may raise Storage_Error" } + is record + Name : M5S (1 .. D); + end record; + + subtype M6 is Integer range 1 .. (Integer'Last + 1)/2; -- Won't trigger + type R6 (D : M6 := 100) is record + Name : String (1 .. D); + end record; + + subtype M7 is Integer range 1 .. (Integer'Last + 1)/2+1; -- Will trigger + type R7 (D : M7 := 100) -- { dg-error "may raise Storage_Error" } + is record + Name : String (1 .. D); + end record; + + package P8 is new Ada.Numerics.Discrete_Random (Natural); + G8 : P8.Generator; + subtype M8 is Integer range 1 .. P8.Random (G8); -- Won't trigger + type R8 (D : M8 := 100) is record + Name : String (1 .. D); + end record; + +end Oversize; diff --git a/gcc/testsuite/gnat.dg/specs/pack2.ads b/gcc/testsuite/gnat.dg/specs/pack2.ads new file mode 100644 index 000000000..7272048a1 --- /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/specs/pack3.ads b/gcc/testsuite/gnat.dg/specs/pack3.ads new file mode 100644 index 000000000..ba2b34683 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/pack3.ads @@ -0,0 +1,45 @@ +-- { dg-do compile } + +with Pack3_Pkg; + +package Pack3 is + + subtype N_TYPE is INTEGER range 0..5; + + type LIST_ARRAY is array (N_TYPE range <>) of INTEGER; + + type LIST (N : N_TYPE := 0) is record + LIST : LIST_ARRAY(1..N); + end record; + pragma PACK(LIST); + + subtype CS is STRING(1..Pack3_Pkg.F); + + type CSA is array (NATURAL range <>) of CS; + + type REC is record + I1, I2 : INTEGER; + end record ; + + type CMD is (CO, AS); + + type CMD_BLOCK_TYPE (D : CMD := CO) is record + N : CSA (1..4); + case D is + when CO => L : LIST; + when AS => R : REC; + end case ; + end record; + pragma PACK(CMD_BLOCK_TYPE); + + type CMD_TYPE is (RIGHT, WRONG); + + type CMD_RESULT (D : CMD_TYPE) is record + case D is + when RIGHT => C : CMD_BLOCK_TYPE; + when WRONG => null; + end case; + end record ; + pragma PACK(CMD_RESULT); + +end Pack3; diff --git a/gcc/testsuite/gnat.dg/specs/pack33.ads b/gcc/testsuite/gnat.dg/specs/pack33.ads new file mode 100644 index 000000000..d5255aa44 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/pack33.ads @@ -0,0 +1,27 @@ +-- { dg-do compile } + +package Pack33 is + + Bits : constant := 33; + + type Bits_33 is mod 2 ** Bits; + for Bits_33'Size use Bits; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_33; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + +end Pack33; diff --git a/gcc/testsuite/gnat.dg/specs/pack3_pkg.ads b/gcc/testsuite/gnat.dg/specs/pack3_pkg.ads new file mode 100644 index 000000000..200333188 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/pack3_pkg.ads @@ -0,0 +1,7 @@ +-- { dg-excess-errors "no code generated" } + +package Pack3_Pkg is + + function F return Integer; + +end Pack3_Pkg; diff --git a/gcc/testsuite/gnat.dg/specs/pack4.ads b/gcc/testsuite/gnat.dg/specs/pack4.ads new file mode 100644 index 000000000..82b76d2f4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/pack4.ads @@ -0,0 +1,12 @@ +package Pack4 is + + type Buffer is array (Natural range <>) of Boolean; + + type Root (Size : Natural) is tagged record + Data : Buffer (1..Size); + end record; + pragma Pack (Root); + + type Derived is new Root with null record; + +end Pack4; diff --git a/gcc/testsuite/gnat.dg/specs/pack5.ads b/gcc/testsuite/gnat.dg/specs/pack5.ads new file mode 100644 index 000000000..65c8fc744 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/pack5.ads @@ -0,0 +1,13 @@ +package Pack5 is + + type Small is range -32 .. 31; + + type Arr is array (Integer range <>) of Small; + pragma Pack (Arr); + + type Rec is record + Y: Arr (1 .. 10); + end record; + pragma Pack (Rec); + +end Pack5; diff --git a/gcc/testsuite/gnat.dg/specs/pack6.ads b/gcc/testsuite/gnat.dg/specs/pack6.ads new file mode 100644 index 000000000..cf1813d14 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/pack6.ads @@ -0,0 +1,24 @@ +-- { dg-do compile } + +with Ada.Finalization; +with Pack6_Pkg; + +package Pack6 is + + package Eight_Bits is new Pack6_Pkg (8); + + type Some_Data is record + Byte_1 : Eight_Bits.Object; + Byte_2 : Eight_Bits.Object; + end record; + + for Some_Data use record + Byte_1 at 0 range 0 .. 7; + Byte_2 at 1 range 0 .. 7; + end record; + + type Top_Object is new Ada.Finalization.Controlled with record + Data : Some_Data; + end record; + +end Pack6; diff --git a/gcc/testsuite/gnat.dg/specs/pack6_pkg.ads b/gcc/testsuite/gnat.dg/specs/pack6_pkg.ads new file mode 100644 index 000000000..52ded342d --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/pack6_pkg.ads @@ -0,0 +1,17 @@ +generic + + Size : Positive; + +package Pack6_Pkg is + + type Object is private; + +private + + type Bit is range 0 .. 1; + for Bit'Size use 1; + + type Object is array (1 .. Size) of Bit; + pragma Pack (Object); + +end Pack6_Pkg; diff --git a/gcc/testsuite/gnat.dg/specs/preelab.ads b/gcc/testsuite/gnat.dg/specs/preelab.ads new file mode 100644 index 000000000..4336c754f --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/preelab.ads @@ -0,0 +1,9 @@ +-- { dg-do compile } + +with Ada.Finalization; +package preelab is + type T is limited private; + pragma Preelaborable_Initialization (T); +private + type T is new Ada.Finalization.Limited_Controlled with null record; +end preelab; 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 000000000..f339e5a43 --- /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/renamings.ads b/gcc/testsuite/gnat.dg/specs/renamings.ads new file mode 100644 index 000000000..745795299 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/renamings.ads @@ -0,0 +1,14 @@ +package Renamings is + + package Inner is + procedure PI (X : Integer); + end Inner; + + procedure P (X : Integer) renames Inner.PI; + procedure P (X : Float); + pragma Convention (C, P); -- { dg-error "non-local entity" } + + procedure Q (X : Float); + procedure Q (X : Integer) renames Inner.PI; + pragma Convention (C, Q); -- { dg-error "non-local entity" } +end Renamings; diff --git a/gcc/testsuite/gnat.dg/specs/rep_clause1.ads b/gcc/testsuite/gnat.dg/specs/rep_clause1.ads new file mode 100644 index 000000000..57f63ad3b --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/rep_clause1.ads @@ -0,0 +1,19 @@ +-- { dg-do compile } +-- { dg-options "-gnatwa" } + +package Rep_Clause1 is + generic + type Custom_T is private; + package Handler is + type Storage_T is record + A : Boolean; + B : Boolean; + C : Custom_T; + end record; + + for Storage_T use record + A at 0 range 0..0; + B at 1 range 0..0; + end record; + end Handler; +end Rep_Clause1; diff --git a/gcc/testsuite/gnat.dg/specs/rep_clause2.ads b/gcc/testsuite/gnat.dg/specs/rep_clause2.ads new file mode 100644 index 000000000..361c141ec --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/rep_clause2.ads @@ -0,0 +1,11 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +package Rep_Clause2 is + + type S is new String; + for S'Component_Size use 256; + + type T is new S(1..8); + +end Rep_Clause2; diff --git a/gcc/testsuite/gnat.dg/specs/rep_clause3.ads b/gcc/testsuite/gnat.dg/specs/rep_clause3.ads new file mode 100644 index 000000000..438c60468 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/rep_clause3.ads @@ -0,0 +1,36 @@ +package Rep_Clause3 is + + type Record1 is + record + Page_Handle : Integer range 0 .. 255; + Page_Owner : Integer range 0 .. 15; + end record; + for Record1 use + record + Page_Handle at 0 range 0 .. 15; + Page_Owner at 0 range 16 .. 19; + end record; + for Record1'Size use 20; + + type Range_A is range 1 .. 7; + for Range_A'Size use 16; + + type Array_Type is array (Range_A) of Record1; + pragma Pack (Array_Type); + for Array_Type'Size use 7 * 20; +-- for array_Type'alignment use 1; + + type Record2 is + record + Page_Tree_Index : Range_A; + Page_Tree : Array_Type; + end record; + + for Record2 use + record + Page_Tree_Index at 0 range 0 .. 15; + Page_Tree at 0 range 16 .. 15 + (7 * 20); + end record; + for Record2'Size use 16 + (7 * 20); + +end Rep_Clause3; diff --git a/gcc/testsuite/gnat.dg/specs/rep_clause4.ads b/gcc/testsuite/gnat.dg/specs/rep_clause4.ads new file mode 100644 index 000000000..8009f876c --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/rep_clause4.ads @@ -0,0 +1,42 @@ +-- { dg-do compile } +-- { dg-options "-O" } + +package Rep_Clause4 is + + type Uns16 is mod 2**16; + + type Rec32 is + record + W1 : Uns16 := 1; + W2 : Uns16 := 2; + end record; + for Rec32 use + record + W1 at 0 range 0..15; + W2 at 2 range 0..15; + end record; + for Rec32'size use 32; + + type Rec48 is + record + W1andW2 : Rec32; + W3 : Uns16; + end record; + for Rec48 use + record + W1andW2 at 0 range 0..31; + W3 at 4 range 0..15; + end record; + for Rec48'size use 48; + + type Rec_Type is + record + Field1 : Rec48; + end record; + for Rec_Type use + record + Field1 at 0 range 0 .. 47; + end record; + for Rec_Type'size use 48; + +end Rep_Clause4; 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 000000000..cfd846994 --- /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/specs/root-level_1-level_2.ads b/gcc/testsuite/gnat.dg/specs/root-level_1-level_2.ads new file mode 100644 index 000000000..9687208e0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/root-level_1-level_2.ads @@ -0,0 +1,7 @@ +package Root.Level_1.Level_2 is + + type Level_2_Type (First : Natural; + Second : Natural) is new + Level_1.Level_1_Type (First => First, Second => Second) with null record; + +end Root.Level_1.Level_2; diff --git a/gcc/testsuite/gnat.dg/specs/root-level_1.ads b/gcc/testsuite/gnat.dg/specs/root-level_1.ads new file mode 100644 index 000000000..6bcb1251f --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/root-level_1.ads @@ -0,0 +1,14 @@ +package Root.Level_1 is + + type Level_1_Type (First : Natural; + Second : Natural) is new Root_Type with private; + +private + + type Level_1_Type (First : Natural; + Second : Natural) is new Root_Type (First => First) + with record + Buffer_1 : Buffer_Type (1 .. Second); + end record; + +end Root.Level_1; diff --git a/gcc/testsuite/gnat.dg/specs/root-level_2.ads b/gcc/testsuite/gnat.dg/specs/root-level_2.ads new file mode 100644 index 000000000..c4f812ecf --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/root-level_2.ads @@ -0,0 +1,9 @@ +with Root.Level_1; + +package Root.Level_2 is + + type Level_2_Type (First : Natural; + Second : Natural) is new + Level_1.Level_1_Type (First => First, Second => Second) with null record; + +end Root.Level_2; diff --git a/gcc/testsuite/gnat.dg/specs/root.ads b/gcc/testsuite/gnat.dg/specs/root.ads new file mode 100644 index 000000000..e80ab8804 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/root.ads @@ -0,0 +1,9 @@ +package Root is + + type Buffer_Type is array (Positive range <>) of Natural; + + type Root_Type (First : Natural) is abstract tagged record + Buffer_Root : Buffer_Type (1 .. First); + end record; + +end Root; diff --git a/gcc/testsuite/gnat.dg/specs/self_class.ads b/gcc/testsuite/gnat.dg/specs/self_class.ads new file mode 100644 index 000000000..56c7ab476 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/self_class.ads @@ -0,0 +1,9 @@ +-- { dg-do compile } + +package Self_Class is + type P6 is private; +private + type P6 is tagged record + Self : access P6'Class; + end record; +end Self_Class; diff --git a/gcc/testsuite/gnat.dg/specs/size_attribute1.ads b/gcc/testsuite/gnat.dg/specs/size_attribute1.ads new file mode 100644 index 000000000..ece680728 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/size_attribute1.ads @@ -0,0 +1,20 @@ +-- { dg-do compile } + +with Size_Attribute1_Pkg1; + +package Size_Attribute1 is + + function Num return Natural; + pragma Import (Ada, Num); + + type A is array (Natural range <>) of Integer; + + type T is + record + F1 : Long_Float; + F2 : A (1 .. Num); + end record; + + package My_Q is new Size_Attribute1_Pkg1 (T); + +end Size_Attribute1; diff --git a/gcc/testsuite/gnat.dg/specs/size_attribute1_pkg1.adb b/gcc/testsuite/gnat.dg/specs/size_attribute1_pkg1.adb new file mode 100644 index 000000000..a0a45a9e4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/size_attribute1_pkg1.adb @@ -0,0 +1,13 @@ +package body Size_Attribute1_Pkg1 is + + type Rec is + record + F : T; + end record; + + procedure Dummy is + begin + null; + end; + +end Size_Attribute1_Pkg1; diff --git a/gcc/testsuite/gnat.dg/specs/size_attribute1_pkg1.ads b/gcc/testsuite/gnat.dg/specs/size_attribute1_pkg1.ads new file mode 100644 index 000000000..2cd2dc4d1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/size_attribute1_pkg1.ads @@ -0,0 +1,15 @@ +-- { dg-excess-errors "no code generated" } + +with Size_Attribute1_Pkg2; + +generic + + type T is private; + +package Size_Attribute1_Pkg1 is + + package My_R is new Size_Attribute1_Pkg2 (T); + + procedure Dummy; + +end Size_Attribute1_Pkg1; diff --git a/gcc/testsuite/gnat.dg/specs/size_attribute1_pkg2.adb b/gcc/testsuite/gnat.dg/specs/size_attribute1_pkg2.adb new file mode 100644 index 000000000..ded1c8c65 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/size_attribute1_pkg2.adb @@ -0,0 +1,9 @@ +package body Size_Attribute1_Pkg2 is + + procedure Proc is + I : Integer := T'Size; + begin + null; + end; + +end Size_Attribute1_Pkg2; diff --git a/gcc/testsuite/gnat.dg/specs/size_attribute1_pkg2.ads b/gcc/testsuite/gnat.dg/specs/size_attribute1_pkg2.ads new file mode 100644 index 000000000..156150803 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/size_attribute1_pkg2.ads @@ -0,0 +1,11 @@ +-- { dg-excess-errors "no code generated" } + +generic + + type T is private; + +package Size_Attribute1_Pkg2 is + + procedure Proc; + +end Size_Attribute1_Pkg2; diff --git a/gcc/testsuite/gnat.dg/specs/size_clause1.ads b/gcc/testsuite/gnat.dg/specs/size_clause1.ads new file mode 100644 index 000000000..5b8417ea7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/size_clause1.ads @@ -0,0 +1,48 @@ +-- { dg-do compile } + +package Size_Clause1 is + + -- The record inherits the alignment of Integer, which is 4, so + -- the real size is 64 instead of 40. That's OK, as long as the + -- size of a component of type R1 in a packed record is 40. + type R1 is record + I : Integer; + B : Boolean; + end record; + for R1'Size use 40; + + type S1 is record + rr : R1; -- size must be 40 + end record; + pragma Pack(S1); + + -- The record is explicitly given alignment 1 so its real type is 40 too. + -- The size of a component of type R2 in a packed record is naturally 40. + type R2 is record + I : Integer; + B : Boolean; + end record; + for R2'Size use 40; + for R2'Alignment use 1; + + type S2 is record + rr : R2; -- size must be 40 + end record; + pragma Pack(S2); + + -- The record is explicitly given alignment 4 so its real type is 64. + -- That's OK, as long as the size of a component of type R3 in a packed + -- record is 40. + type R3 is record + I : Integer; + B : Boolean; + end record; + for R3'Size use 40; + for R3'Alignment use 4; + + type S3 is record + rr : R3; -- size must be 40 + end record; + pragma Pack(S3); + +end Size_Clause1; diff --git a/gcc/testsuite/gnat.dg/specs/size_clause2.ads b/gcc/testsuite/gnat.dg/specs/size_clause2.ads new file mode 100644 index 000000000..957d3920f --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/size_clause2.ads @@ -0,0 +1,48 @@ +-- { dg-do compile } + +package Size_Clause2 is + + -- The alignment of the record is capped to the greatest power of 2 + -- factor of the size, so that the real size is 40 too and the size + -- of a component of type R1 in a packed record can be 40. + type R1 is record + I : Integer; + B : aliased Boolean; + end record; + for R1'Size use 40; + + type S1 is record + rr : R1; -- size must be 40 + end record; + pragma Pack(S1); + + -- The record is explicitly given alignment 1 so its real type is 40 too. + -- The size of a component of type R2 in a packed record is naturally 40. + type R2 is record + I : Integer; + B : aliased Boolean; + end record; + for R2'Size use 40; + for R2'Alignment use 1; + + type S2 is record + rr : R2; -- size must be 40 + end record; + pragma Pack(S2); + + -- The record is explicitly given alignment 4 so its real type is 64. + -- That's not OK, because the size of a component of type R3 in a packed + -- record cannot be 40 so the size clause is violated. + type R3 is record + I : Integer; + B : aliased Boolean; + end record; + for R3'Size use 40; -- { dg-error "size for .R3. too small" } + for R3'Alignment use 4; + + type S3 is record + rr : R3; -- size must be 40 + end record; + pragma Pack(S3); + +end Size_Clause2; diff --git a/gcc/testsuite/gnat.dg/specs/size_clause3.ads b/gcc/testsuite/gnat.dg/specs/size_clause3.ads new file mode 100644 index 000000000..6a89114e4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/size_clause3.ads @@ -0,0 +1,50 @@ +-- { dg-do compile } + +package Size_Clause3 is + + -- The record inherits the alignment of Integer, which is 4, so + -- the real size is 64 instead of 40. + type R1 is record + I : Integer; + B : aliased Boolean; + end record; + + -- That's not OK, the size of a component of type R1 cannot be 40. + type S1 is record + rr : R1; -- size must be 40 + end record; + for S1 use record + rr at 0 range 0 .. 39; -- { dg-error "size of .rr. with aliased or tagged component" } + end record; + + -- The record is explicitly given alignment 1 so its real type is 40. + type R2 is record + I : Integer; + B : aliased Boolean; + end record; + for R2'Alignment use 1; + + -- That's OK, the size of a component of type R2 can be 40. + type S2 is record + rr : R2; -- size must be 40 + end record; + for S2 use record + rr at 0 range 0 .. 39; + end record; + + -- The record is explicitly given alignment 4 so its real type is 64. + type R3 is record + I : Integer; + B : aliased Boolean; + end record; + for R3'Alignment use 4; + + -- That's not OK, the size of a component of type R3 cannot be 40. + type S3 is record + rr : R3; -- size must be 40 + end record; + for S3 use record + rr at 0 range 0 .. 39; -- { dg-error "size of .rr. with aliased or tagged component" } + end record; + +end Size_Clause3; diff --git a/gcc/testsuite/gnat.dg/specs/small_alignment.ads b/gcc/testsuite/gnat.dg/specs/small_alignment.ads new file mode 100644 index 000000000..fbedf47d1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/small_alignment.ads @@ -0,0 +1,13 @@ +-- { dg-do compile } + +package Small_Alignment is + + type Int is range -512 .. 511; + for Int'Alignment use 1; + + type R is record + I: Int; + end record; + Pragma Pack (R); + +end Small_Alignment; diff --git a/gcc/testsuite/gnat.dg/specs/specs.exp b/gcc/testsuite/gnat.dg/specs/specs.exp new file mode 100644 index 000000000..91c5f6c4c --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/specs.exp @@ -0,0 +1,36 @@ +# Copyright (C) 2006, 2007 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# <http://www.gnu.org/licenses/>. + +# GCC testsuite that uses the `dg.exp' driver. + +# Load support procs. +load_lib gnat-dg.exp + +# If a testcase doesn't have special options, use these. +global DEFAULT_CFLAGS +if ![info exists DEFAULT_CFLAGS] then { + set DEFAULT_CFLAGS "" +} + +# Initialize `dg'. +dg-init + +# Main loop. +dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.ads]] \ + "" $DEFAULT_CFLAGS + +# All done. +dg-finish diff --git a/gcc/testsuite/gnat.dg/specs/static_initializer.ads b/gcc/testsuite/gnat.dg/specs/static_initializer.ads new file mode 100644 index 000000000..8755c30d1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/static_initializer.ads @@ -0,0 +1,14 @@ +-- { dg-do compile } + +package static_initializer is + + type Vector is array (1 .. 3) of Float; + type Arr is array (Integer range 1 .. 3) of Vector; + + Pos : constant Arr := ((0.0, 1.0, 2.0), + (0.5, 1.5, 2.5), + (1.0, 2.0, 4.0)); + +end; + +-- { dg-final { scan-assembler-not "elabs" } } diff --git a/gcc/testsuite/gnat.dg/specs/static_initializer2.ads b/gcc/testsuite/gnat.dg/specs/static_initializer2.ads new file mode 100644 index 000000000..3b27f26bd --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/static_initializer2.ads @@ -0,0 +1,22 @@ +-- { dg-do compile } + +package Static_Initializer2 is + + type A is array (1..5) of Integer; + f : constant A := (1, 2, 3, 4, 5); + + i1 : integer renames f(1); + i2 : integer renames f(2); + i3 : integer renames f(3); + i4 : integer renames f(4); + i5 : integer renames f(5); + + b1 : boolean := i1 = 1; + b2 : boolean := i2 = 2; + b3 : boolean := i3 = 3; + b4 : boolean := i4 = 4; + b5 : boolean := i5 = 5; + +end Static_Initializer2; + +-- { dg-final { scan-assembler-not "elabs" } } diff --git a/gcc/testsuite/gnat.dg/specs/static_initializer3.ads b/gcc/testsuite/gnat.dg/specs/static_initializer3.ads new file mode 100644 index 000000000..2dc8be1e5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/static_initializer3.ads @@ -0,0 +1,29 @@ +-- { dg-do compile } + +with Unchecked_Conversion; + +package Static_Initializer3 is + + type Byte is range 0 .. 16#FF#; + for Byte'Size use 8; + + type Word is range 0 .. 16#FFFF# ; + for Word'Size use 16; + + type R is record + b1 : Boolean; + b2 : Boolean; + end record; + for R use record + b1 at 0 range 0..3; + b2 at 0 range 4..7; + end record; + for R'Size use 8; + + function Conv is new Unchecked_Conversion (R, Byte); + + C1 : constant Byte := Conv ((true, false)); + + C2 : constant Word := Word(C1); + +end Static_Initializer3; diff --git a/gcc/testsuite/gnat.dg/specs/static_initializer4.ads b/gcc/testsuite/gnat.dg/specs/static_initializer4.ads new file mode 100644 index 000000000..a1a5e846e --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/static_initializer4.ads @@ -0,0 +1,13 @@ +-- { dg-do compile } + +package Static_Initializer4 is + + type R is tagged record + b : Boolean; + end record; + + type NR is new R with null record; + + C : NR := (b => True); + +end Static_Initializer4; diff --git a/gcc/testsuite/gnat.dg/specs/static_initializer5.ads b/gcc/testsuite/gnat.dg/specs/static_initializer5.ads new file mode 100644 index 000000000..29845ceeb --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/static_initializer5.ads @@ -0,0 +1,13 @@ +-- { dg-do compile } + +with Static_Initializer5_Pkg; use Static_Initializer5_Pkg; + +package Static_Initializer5 is + + type Derived is new Rec with record + Target : Boolean; + end record; + + Null_Derived : constant Derived := (Null_Rec with Target => False); + +end Static_Initializer5; diff --git a/gcc/testsuite/gnat.dg/specs/static_initializer5_pkg.ads b/gcc/testsuite/gnat.dg/specs/static_initializer5_pkg.ads new file mode 100644 index 000000000..16a8f7277 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/static_initializer5_pkg.ads @@ -0,0 +1,17 @@ +package Static_Initializer5_Pkg is + + type Arr is array (Positive range <>) of Character; + + type Buffer_Type (Length : Positive) is record + Content : Arr (1 .. Length); + end record; + + type Buffer_Access is access Buffer_Type; + + type Rec is tagged record + Buffer : Buffer_Access; + end record; + + Null_Rec : constant Rec := (Buffer => null); + +end Static_Initializer5_Pkg; diff --git a/gcc/testsuite/gnat.dg/specs/storage.ads b/gcc/testsuite/gnat.dg/specs/storage.ads new file mode 100644 index 000000000..e54445793 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/storage.ads @@ -0,0 +1,10 @@ +-- { dg-do compile } +with System.Pool_Global; +package Storage is + x1: System.Pool_Global.Unbounded_No_Reclaim_Pool; + type T1 is access integer; + for T1'Storage_Pool use (x1); -- { dg-error "must be a variable" } + type T2 is access Integer; + for T2'Storage_Pool use x1; +end Storage; + diff --git a/gcc/testsuite/gnat.dg/specs/sync_iface_test.ads b/gcc/testsuite/gnat.dg/specs/sync_iface_test.ads new file mode 100644 index 000000000..4bccd255d --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/sync_iface_test.ads @@ -0,0 +1,14 @@ +-- { dg-do compile } +-- { dg-options "-gnatc" } + +package Sync_Iface_Test is + type Iface is limited interface; + procedure Do_Test + (Container : in out Iface; + Process : access procedure (E : Natural)) is abstract; + + protected type Buffer is new Iface with + overriding procedure Do_Test + (Process : access procedure (E : Natural)); + end; +end; diff --git a/gcc/testsuite/gnat.dg/specs/tag1.ads b/gcc/testsuite/gnat.dg/specs/tag1.ads new file mode 100644 index 000000000..7cf7c99dd --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/tag1.ads @@ -0,0 +1,8 @@ +-- { dg-do compile } + +package tag1 is + type T is tagged limited record + Y : access T'Class; -- OK + X : access Tag1.T'Class; -- Problem + end record; +end tag1; diff --git a/gcc/testsuite/gnat.dg/specs/tag2.ads b/gcc/testsuite/gnat.dg/specs/tag2.ads new file mode 100644 index 000000000..67b44978d --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/tag2.ads @@ -0,0 +1,17 @@ +-- { dg-do compile } + +package tag2 is + type I is synchronized interface; + type T1 is tagged; + type T2 is tagged; + type T3 is tagged; + type T4 is tagged; + type T5 is tagged; + 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 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; +end tag2; diff --git a/gcc/testsuite/gnat.dg/specs/uc1.ads b/gcc/testsuite/gnat.dg/specs/uc1.ads new file mode 100644 index 000000000..299782035 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/uc1.ads @@ -0,0 +1,22 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +with System; +with System.Storage_Elements; +with Unchecked_Conversion; + +package UC1 is + + function Conv is + new Unchecked_Conversion (Source => System.Address, Target => Integer); + function Conv is + new Unchecked_Conversion (Source => Integer, Target => System.Address); + + M : constant System.Address := System.Storage_Elements.To_Address(0); + N : constant System.Address := Conv (Conv (M) + 1); + A : constant System.Address := Conv (Conv (N) + 1); + + I : Integer; + for I use at A; + +end UC1; diff --git a/gcc/testsuite/gnat.dg/specs/unchecked_union.ads b/gcc/testsuite/gnat.dg/specs/unchecked_union.ads new file mode 100644 index 000000000..260f781d8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/unchecked_union.ads @@ -0,0 +1,20 @@ +-- PR ada/28591 +-- Reported by Martin Michlmayr <tbm@cyrius.com> + +-- { dg-do compile } +-- { dg-options "-g" } + +with Interfaces; use Interfaces; + +package Unchecked_Union is + type Mode_Type is (Mode_B2); + + type Value_Union (Mode : Mode_Type := Mode_B2) is record + case Mode is + when Mode_B2 => + B2 : Integer_32; + end case; + end record; + pragma Unchecked_Union (Value_Union); + +end Unchecked_Union; diff --git a/gcc/testsuite/gnat.dg/specs/universal_fixed.ads b/gcc/testsuite/gnat.dg/specs/universal_fixed.ads new file mode 100644 index 000000000..e54ce278c --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/universal_fixed.ads @@ -0,0 +1,8 @@ +-- { dg-do compile } + +package Universal_Fixed is + Nm2Metres : constant := 1852.0; + type Metres is delta 1.0 range 0.0 .. 1_000_000.0; + type Nautical_Miles is + delta 0.001 range 0.0 .. (Metres'Last + (Nm2Metres / 2)) / Nm2Metres; +end Universal_Fixed; diff --git a/gcc/testsuite/gnat.dg/specs/variant_part.ads b/gcc/testsuite/gnat.dg/specs/variant_part.ads new file mode 100644 index 000000000..afc92cde5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/variant_part.ads @@ -0,0 +1,8 @@ +-- { dg-do compile } +package Variant_Part is + type T1(b: boolean) is record + case (b) is -- { dg-error "discriminant name may not be parenthesized" } + when others => null; + end case; + end record; +end Variant_Part; diff --git a/gcc/testsuite/gnat.dg/specs/varsize_return.ads b/gcc/testsuite/gnat.dg/specs/varsize_return.ads new file mode 100644 index 000000000..b6c55ed63 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/varsize_return.ads @@ -0,0 +1,10 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +with Varsize_Return_Pkg1; + +package Varsize_Return is + + package P is new Varsize_Return_Pkg1 (Id_T => Natural); + +end Varsize_Return; diff --git a/gcc/testsuite/gnat.dg/specs/varsize_return_pkg1.adb b/gcc/testsuite/gnat.dg/specs/varsize_return_pkg1.adb new file mode 100644 index 000000000..59b283c2b --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/varsize_return_pkg1.adb @@ -0,0 +1,24 @@ +package body Varsize_Return_Pkg1 is + + function Is_Fixed return Boolean is + begin + return True; + end Is_Fixed; + + function Do_Item (I : Natural) return Variable_Data_Fixed_T is + It : Variable_Data_Fixed_T; + begin + return It; + end Do_Item; + + My_Db : Db.T; + + procedure Run is + Kitem : Variable_Data_Fixed_T; + I : Natural; + begin + Kitem := Db.Get (My_Db); + Kitem := Do_Item (I); + end Run; + +end Varsize_Return_Pkg1; diff --git a/gcc/testsuite/gnat.dg/specs/varsize_return_pkg1.ads b/gcc/testsuite/gnat.dg/specs/varsize_return_pkg1.ads new file mode 100644 index 000000000..792b7a5ce --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/varsize_return_pkg1.ads @@ -0,0 +1,26 @@ +-- { dg-excess-errors "no code generated" } + +with Varsize_Return_Pkg2; + +generic + type Id_T is range <>; +package Varsize_Return_Pkg1 is + + type Variable_Data_T (Fixed : Boolean := False) is + record + case Fixed is + when True => + Length : Natural; + when False => + null; + end case; + end record; + + function Is_Fixed return Boolean; + + type Variable_Data_Fixed_T is new Variable_Data_T (Is_Fixed); + + package Db is new Varsize_Return_Pkg2 (Id_T => Id_T, + Data_T => Variable_Data_Fixed_T); + +end Varsize_Return_Pkg1; diff --git a/gcc/testsuite/gnat.dg/specs/varsize_return_pkg2.adb b/gcc/testsuite/gnat.dg/specs/varsize_return_pkg2.adb new file mode 100644 index 000000000..d89255285 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/varsize_return_pkg2.adb @@ -0,0 +1,7 @@ +package body Varsize_Return_Pkg2 is + function Get (X : T) return Data_T is + Result : Data_T; + begin + return Result; + end; +end Varsize_Return_Pkg2; diff --git a/gcc/testsuite/gnat.dg/specs/varsize_return_pkg2.ads b/gcc/testsuite/gnat.dg/specs/varsize_return_pkg2.ads new file mode 100644 index 000000000..9d1abb96c --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/varsize_return_pkg2.ads @@ -0,0 +1,11 @@ +-- { dg-excess-errors "no code generated" } + +generic + type Id_T is private; + type Data_T is private; +package Varsize_Return_Pkg2 is + type T is private; + function Get (X : T) return Data_T; +private + type T is null record; +end Varsize_Return_Pkg2; diff --git a/gcc/testsuite/gnat.dg/specs/warnstar.ads b/gcc/testsuite/gnat.dg/specs/warnstar.ads new file mode 100644 index 000000000..325cbb6f3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/warnstar.ads @@ -0,0 +1,12 @@ +-- { dg-do compile } + +pragma Warnings (Off, "*bits of*unused"); +package warnstar is + type r is record + a : integer; + end record; + + for r use record + a at 0 range 0 .. 1023; + end record; +end warnstar; diff --git a/gcc/testsuite/gnat.dg/specs/weak1.ads b/gcc/testsuite/gnat.dg/specs/weak1.ads new file mode 100644 index 000000000..82cddc09a --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/weak1.ads @@ -0,0 +1,7 @@ +package Weak1 is + + Myconst : constant Integer := 1234; + pragma Export (C, Myconst, "myconst"); + pragma Weak_External (Myconst); + +end Weak1; 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 000000000..f2329cf88 --- /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/spipaterr.adb b/gcc/testsuite/gnat.dg/spipaterr.adb new file mode 100644 index 000000000..b68dc2e10 --- /dev/null +++ b/gcc/testsuite/gnat.dg/spipaterr.adb @@ -0,0 +1,14 @@ +-- { dg-do run } + +with Text_IO; use Text_IO; +with GNAT.SPITBOL.Patterns; use GNAT.SPITBOL.Patterns; +procedure Spipaterr is + X : String := "ABCDE"; + Y : Pattern := Len (1) & X (2 .. 2); +begin + if Match ("XB", Y) then + null; + else + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/sse_nolib.adb b/gcc/testsuite/gnat.dg/sse_nolib.adb new file mode 100644 index 000000000..a0aa720f0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/sse_nolib.adb @@ -0,0 +1,50 @@ +-- { dg-do run { target i?86-*-* x86_64-*-* } } +-- { dg-options "-O1 -msse" } +-- { dg-require-effective-target sse_runtime } + +with Ada.Unchecked_Conversion; + +procedure SSE_Nolib is + + -- Base vector type definitions + + package SSE_Types is + VECTOR_ALIGN : constant := 16; + VECTOR_BYTES : constant := 16; + + type m128 is private; + private + type m128 is array (1 .. 4) of Float; + for m128'Alignment use VECTOR_ALIGN; + pragma Machine_Attribute (m128, "vector_type"); + pragma Machine_Attribute (m128, "may_alias"); + end SSE_Types; + + use SSE_Types; + + -- Core operations + + function mm_add_ss (A, B : m128) return m128; + pragma Import (Intrinsic, mm_add_ss, "__builtin_ia32_addss"); + + -- User views / conversions or overlays + + type Vf32_View is array (1 .. 4) of Float; + for Vf32_View'Alignment use VECTOR_ALIGN; + + function To_m128 is new Ada.Unchecked_Conversion (Vf32_View, m128); + function To_m128 is new Ada.Unchecked_Conversion (m128, Vf32_View); + + X, Y, Z : M128; + + Vz : Vf32_View; + for Vz'Address use Z'Address; +begin + X := To_m128 ((1.0, 1.0, 2.0, 2.0)); + Y := To_m128 ((2.0, 2.0, 1.0, 1.0)); + Z := mm_add_ss (X, Y); + + if Vz /= (3.0, 1.0, 2.0, 2.0) then + raise Program_Error; + end if; +end SSE_Nolib; diff --git a/gcc/testsuite/gnat.dg/stack_check1.adb b/gcc/testsuite/gnat.dg/stack_check1.adb new file mode 100644 index 000000000..51ee1a633 --- /dev/null +++ b/gcc/testsuite/gnat.dg/stack_check1.adb @@ -0,0 +1,38 @@ +-- { dg-do run } +-- { dg-options "-fstack-check" } + +-- This test requires architecture- and OS-specific support code for unwinding +-- through signal frames (typically located in *-unwind.h) to pass. Feel free +-- to disable it if this code hasn't been implemented yet. + +procedure Stack_Check1 is + + type A is Array (1..2048) of Integer; + + procedure Consume_Stack (N : Integer) is + My_A : A; -- 8 KB static + begin + My_A (1) := 0; + if N <= 0 then + return; + end if; + Consume_Stack (N-1); + end; + + Task T; + + Task body T is + begin + begin + Consume_Stack (Integer'Last); + raise Program_Error; + exception + when Storage_Error => null; + end; + + Consume_Stack (128); + end; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/stack_check2.adb b/gcc/testsuite/gnat.dg/stack_check2.adb new file mode 100644 index 000000000..4a3008ba0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/stack_check2.adb @@ -0,0 +1,43 @@ +-- { dg-do run } +-- { dg-options "-fstack-check" } + +-- This test requires architecture- and OS-specific support code for unwinding +-- through signal frames (typically located in *-unwind.h) to pass. Feel free +-- to disable it if this code hasn't been implemented yet. + +procedure Stack_Check2 is + + function UB return Integer is + begin + return 2048; + end; + + type A is Array (Positive range <>) of Integer; + + procedure Consume_Stack (N : Integer) is + My_A : A (1..UB); -- 8 KB dynamic + begin + My_A (1) := 0; + if N <= 0 then + return; + end if; + Consume_Stack (N-1); + end; + + Task T; + + Task body T is + begin + begin + Consume_Stack (Integer'Last); + raise Program_Error; + exception + when Storage_Error => null; + end; + + Consume_Stack (128); + end; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/statically_matching.ads b/gcc/testsuite/gnat.dg/statically_matching.ads new file mode 100644 index 000000000..de2ba1b0b --- /dev/null +++ b/gcc/testsuite/gnat.dg/statically_matching.ads @@ -0,0 +1,7 @@ +package Statically_Matching is + type T1(b: boolean) is tagged null record; + type T2 is new T1(b => false) with private; +private + F: constant boolean := false; + type T2 is new T1(b => F) with null record; -- OK +end Statically_Matching; diff --git a/gcc/testsuite/gnat.dg/str1.adb b/gcc/testsuite/gnat.dg/str1.adb new file mode 100644 index 000000000..833d0f1d1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/str1.adb @@ -0,0 +1,20 @@ +-- { dg-do compile } + +procedure str1 is + Str : constant string := "--"; + generic + package Gen is + procedure P; + end Gen; + package body Gen is + procedure P is + inner : String := Str; + begin + null; + end; + end Gen; + + package Inst is new Gen; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/string_comparison.adb b/gcc/testsuite/gnat.dg/string_comparison.adb new file mode 100644 index 000000000..22e6c9e01 --- /dev/null +++ b/gcc/testsuite/gnat.dg/string_comparison.adb @@ -0,0 +1,10 @@ +-- { dg-do compile } + +with Ada.Text_IO; use Ada.Text_IO; + +procedure String_Comparison is + package Bool_IO is new Enumeration_IO (Boolean); + use Bool_IO; +begin + Put (Boolean'Image (True) = "True"); +end; diff --git a/gcc/testsuite/gnat.dg/string_slice.adb b/gcc/testsuite/gnat.dg/string_slice.adb new file mode 100644 index 000000000..c14ae49b7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/string_slice.adb @@ -0,0 +1,21 @@ +-- { dg-do run } +-- { dg-options "-O" } + +procedure string_slice is + + subtype Key_T is String (1 .. 3); + + function One_Xkey return Key_T is + Key : Key_T := "XXX"; + begin + Key (1 .. 2) := "__"; + return Key; + end; + + Key : Key_T := One_Xkey; + +begin + if Key (3) /= 'X' then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/string_slice2.adb b/gcc/testsuite/gnat.dg/string_slice2.adb new file mode 100644 index 000000000..e9a9efaa1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/string_slice2.adb @@ -0,0 +1,24 @@ +-- { dg-do compile } +-- { dg-options "-O" } + +with Ada.Strings; +with Ada.Strings.Fixed; + +procedure String_Slice2 is + + package ASF renames Ada.Strings.Fixed; + + Delete_String : String(1..10); + Source_String2 : String(1..12) := "abcdefghijkl"; + +begin + + Delete_String := Source_String2(1..10); + + ASF.Delete(Source => Delete_String, + From => 6, + Through => Delete_String'Last, + Justify => Ada.Strings.Left, + Pad => 'x'); + +end; diff --git a/gcc/testsuite/gnat.dg/style/style.exp b/gcc/testsuite/gnat.dg/style/style.exp new file mode 100644 index 000000000..a764c0b00 --- /dev/null +++ b/gcc/testsuite/gnat.dg/style/style.exp @@ -0,0 +1,36 @@ +# Copyright (C) 2006, 2007 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# <http://www.gnu.org/licenses/>. + +# GCC testsuite that uses the `dg.exp' driver. + +# Load support procs. +load_lib gnat-dg.exp + +# If a testcase doesn't have special options, use these. +global DEFAULT_CFLAGS +if ![info exists DEFAULT_CFLAGS] then { + set DEFAULT_CFLAGS "" +} + +# Initialize `dg'. +dg-init + +# Main loop. +dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.adb]] \ + "" $DEFAULT_CFLAGS + +# All done. +dg-finish diff --git a/gcc/testsuite/gnat.dg/subp_elim_errors.adb b/gcc/testsuite/gnat.dg/subp_elim_errors.adb new file mode 100644 index 000000000..669e87721 --- /dev/null +++ b/gcc/testsuite/gnat.dg/subp_elim_errors.adb @@ -0,0 +1,32 @@ +-- [ dg-do compile } + +with System; + +package body Subp_Elim_Errors is + + type Acc_Proc is access procedure; + + procedure Proc is + begin + null; + end Proc; + + procedure Pass_Proc (P : Acc_Proc) is + begin + P.all; + end Pass_Proc; + + procedure Pass_Proc (P : System.Address) is + begin + null; + end Pass_Proc; + +begin + Proc; -- { dg-error "eliminated" } + + Pass_Proc (Proc'Access); -- { dg-error "eliminated" } + + Pass_Proc (Proc'Address); -- { dg-error "eliminated" } + + Pass_Proc (Proc'Code_Address); -- { dg-error "eliminated" } +end Subp_Elim_Errors; diff --git a/gcc/testsuite/gnat.dg/subp_elim_errors.ads b/gcc/testsuite/gnat.dg/subp_elim_errors.ads new file mode 100644 index 000000000..d42f1b204 --- /dev/null +++ b/gcc/testsuite/gnat.dg/subp_elim_errors.ads @@ -0,0 +1,7 @@ +pragma Eliminate (Subp_Elim_Errors, Proc); + +package Subp_Elim_Errors is + + procedure Proc; + +end Subp_Elim_Errors; diff --git a/gcc/testsuite/gnat.dg/sync1.adb b/gcc/testsuite/gnat.dg/sync1.adb new file mode 100644 index 000000000..08be6395d --- /dev/null +++ b/gcc/testsuite/gnat.dg/sync1.adb @@ -0,0 +1,15 @@ +-- { dg-do compile } +package body sync1 is + protected body Chopstick is + + entry Pick_Up when not Busy is + begin + Busy := True; + end Pick_Up; + + procedure Put_Down is + begin + Busy := False; + end Put_Down; + end Chopstick; +end sync1; diff --git a/gcc/testsuite/gnat.dg/sync1.ads b/gcc/testsuite/gnat.dg/sync1.ads new file mode 100644 index 000000000..35349773f --- /dev/null +++ b/gcc/testsuite/gnat.dg/sync1.ads @@ -0,0 +1,12 @@ +package sync1 is + type Chopstick_Type is synchronized interface; + + type Chopstick is synchronized new Chopstick_Type with private; +private + protected type Chopstick is new Chopstick_Type with + entry Pick_Up; + procedure Put_Down; + private + Busy : Boolean := False; + end Chopstick; +end sync1; diff --git a/gcc/testsuite/gnat.dg/sync_iface_test.adb b/gcc/testsuite/gnat.dg/sync_iface_test.adb new file mode 100644 index 000000000..f431adfe2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/sync_iface_test.adb @@ -0,0 +1,19 @@ +-- { dg-do compile } +package body Sync_Iface_Test is + protected body Buffer is + procedure Dummy is begin null; end; + end; + + function First (Obj : Buffer) return Natural is + begin + return 0; + end; + + procedure Do_Test (Dummy : Natural; Item : Buffer) + is + Position1 : Natural := First (Item); + Position2 : Natural := Item.First; -- Problem here + begin + null; + end; +end; diff --git a/gcc/testsuite/gnat.dg/sync_iface_test.ads b/gcc/testsuite/gnat.dg/sync_iface_test.ads new file mode 100644 index 000000000..c172d7fa2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/sync_iface_test.ads @@ -0,0 +1,11 @@ +package Sync_Iface_Test is + type Iface is limited interface; + function First (Obj : Iface) return Natural is abstract; + + protected type Buffer is new Iface with + procedure Dummy; + end; + overriding function First (Obj : Buffer) return Natural; + + procedure Do_Test (Dummy : Natural; Item : Buffer); +end; diff --git a/gcc/testsuite/gnat.dg/tag1.adb b/gcc/testsuite/gnat.dg/tag1.adb new file mode 100644 index 000000000..f973cb291 --- /dev/null +++ b/gcc/testsuite/gnat.dg/tag1.adb @@ -0,0 +1,20 @@ +-- { dg-do run } + +with Ada.Tags; +procedure tag1 is + type T is tagged null record; + X : Ada.Tags.Tag; +begin + begin + X := Ada.Tags.Descendant_Tag ("Internal tag at 16#0#", T'Tag); + raise Program_Error; + exception + when Ada.Tags.Tag_Error => null; + end; + begin + X := Ada.Tags.Descendant_Tag ("Internal tag at 16#XXXX#", T'Tag); + raise Program_Error; + exception + when Ada.Tags.Tag_Error => null; + end; +end; diff --git a/gcc/testsuite/gnat.dg/tagged_alloc_free.adb b/gcc/testsuite/gnat.dg/tagged_alloc_free.adb new file mode 100644 index 000000000..d26916dcb --- /dev/null +++ b/gcc/testsuite/gnat.dg/tagged_alloc_free.adb @@ -0,0 +1,22 @@ +-- { dg-do run } + +with Ada.Unchecked_Deallocation; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; + +procedure Tagged_Alloc_Free is + + type Test_Base is tagged null record; + type Test_Class_Access is access all Test_Base'Class; + type Test_Extension is new Test_Base with record + Last_Name : Unbounded_String := Null_Unbounded_String; + end record; + + procedure Free is new Ada.Unchecked_Deallocation + (Object => Test_Base'Class, + Name => Test_Class_Access); + + Handle : Test_Class_Access := new Test_Extension; + +begin + Free (Handle); +end; diff --git a/gcc/testsuite/gnat.dg/tagged_type_pkg.adb b/gcc/testsuite/gnat.dg/tagged_type_pkg.adb new file mode 100644 index 000000000..dea1b5461 --- /dev/null +++ b/gcc/testsuite/gnat.dg/tagged_type_pkg.adb @@ -0,0 +1,18 @@ +package body Tagged_Type_Pkg is + + function Pass_TT_Access (Obj : access TT'Class) return access TT'Class is + begin + if Obj = null then + return null; + + else + -- The implicit conversion in the assignment to the return object + -- must fail if Obj's actual is not a library-level object. + + return TT_Acc : access TT'Class := Obj do + TT_Acc := TT_Acc.Self; + end return; + end if; + end Pass_TT_Access; + +end Tagged_Type_Pkg; diff --git a/gcc/testsuite/gnat.dg/tagged_type_pkg.ads b/gcc/testsuite/gnat.dg/tagged_type_pkg.ads new file mode 100644 index 000000000..809261032 --- /dev/null +++ b/gcc/testsuite/gnat.dg/tagged_type_pkg.ads @@ -0,0 +1,9 @@ +package Tagged_Type_Pkg is + + type TT is tagged limited record + Self : access TT'Class := TT'Unchecked_Access; + end record; + + function Pass_TT_Access (Obj : access TT'Class) return access TT'Class; + +end Tagged_Type_Pkg; diff --git a/gcc/testsuite/gnat.dg/tail_call.adb b/gcc/testsuite/gnat.dg/tail_call.adb new file mode 100644 index 000000000..4f109adff --- /dev/null +++ b/gcc/testsuite/gnat.dg/tail_call.adb @@ -0,0 +1,9 @@ +-- { dg-do run } +-- { dg-options "-O2 -fno-unit-at-a-time" } + +with Tail_Call_P; use Tail_Call_P; + +procedure Tail_Call is +begin + Insert (My_Array, 0, 0); +end; diff --git a/gcc/testsuite/gnat.dg/tail_call_p.adb b/gcc/testsuite/gnat.dg/tail_call_p.adb new file mode 100644 index 000000000..56add5f6b --- /dev/null +++ b/gcc/testsuite/gnat.dg/tail_call_p.adb @@ -0,0 +1,35 @@ +package body Tail_Call_P is + + function Start_Side (Element : T) return Index is + begin + if Element = 1 then + raise Program_Error; + end if; + if Element = 0 then + return Second; + else + return First; + end if; + end; + + function Segment (Element : T) return T is + begin + if Element /= 0 then + raise Program_Error; + end if; + return 1; + end; + + procedure Really_Insert (Into : T; Element : T; Value : T) is + begin + if Into /= 0 then + raise Program_Error; + end if; + end; + + procedure Insert (Into : A; Element : T; Value : T) is + begin + Really_Insert (Into (Start_Side (Element)), Segment (Element), Value); + end Insert; + +end Tail_Call_P; diff --git a/gcc/testsuite/gnat.dg/tail_call_p.ads b/gcc/testsuite/gnat.dg/tail_call_p.ads new file mode 100644 index 000000000..1665bc30c --- /dev/null +++ b/gcc/testsuite/gnat.dg/tail_call_p.ads @@ -0,0 +1,13 @@ +package Tail_Call_P is + + type T is new Natural; + + type Index is (First, Second); + + type A is array (Index) of T; + + My_Array : A := (0, 0); + + procedure Insert (Into : A; Element : T; Value : T); + +end Tail_Call_P; diff --git a/gcc/testsuite/gnat.dg/tamdt.adb b/gcc/testsuite/gnat.dg/tamdt.adb new file mode 100644 index 000000000..81af6ade2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/tamdt.adb @@ -0,0 +1,19 @@ + +with Tamdt_Aux; + +package body TAMDT is + type TAMT1 is new Tamdt_Aux.Priv (X => 1); + type TAMT2 is new Tamdt_Aux.Priv; + + procedure Check is + Ptr1 : TAMT1_Access := new TAMT1; + Ptr2 : TAMT2_Access := new TAMT2 (X => 2); + begin + if Ptr1.all.X /= 1 then + raise Program_Error; + end if; + if Ptr2.all.X /= 2 then + raise Program_Error; + end if; + end; +end; diff --git a/gcc/testsuite/gnat.dg/tamdt.ads b/gcc/testsuite/gnat.dg/tamdt.ads new file mode 100644 index 000000000..09d9388ee --- /dev/null +++ b/gcc/testsuite/gnat.dg/tamdt.ads @@ -0,0 +1,10 @@ + +package TAMDT is + procedure Check; +private + type TAMT1; + type TAMT1_Access is access TAMT1; + + type TAMT2; + type TAMT2_Access is access TAMT2; +end; diff --git a/gcc/testsuite/gnat.dg/tamdt_aux.ads b/gcc/testsuite/gnat.dg/tamdt_aux.ads new file mode 100644 index 000000000..d5cca103f --- /dev/null +++ b/gcc/testsuite/gnat.dg/tamdt_aux.ads @@ -0,0 +1,9 @@ + +package Tamdt_Aux is + type Priv (X : Integer) is private; +private + type Priv (X : Integer) is null record; +end; + + + diff --git a/gcc/testsuite/gnat.dg/task_name.adb b/gcc/testsuite/gnat.dg/task_name.adb new file mode 100644 index 000000000..86c9c7d81 --- /dev/null +++ b/gcc/testsuite/gnat.dg/task_name.adb @@ -0,0 +1,8 @@ +-- { dg-do compile } + +package body task_name is + task body Task_Object is + begin + null; + end Task_Object; +end; diff --git a/gcc/testsuite/gnat.dg/task_name.ads b/gcc/testsuite/gnat.dg/task_name.ads new file mode 100644 index 000000000..2d9d3ab15 --- /dev/null +++ b/gcc/testsuite/gnat.dg/task_name.ads @@ -0,0 +1,22 @@ +with Ada.Finalization; +package task_name is + type Base_Controller is + abstract new Ada.Finalization.Limited_Controlled with null record; + + type Extended_Controller is + abstract new Base_Controller with private; + + type Task_Object (Controller : access Extended_Controller'Class) is + limited private; +private + type String_Access is access string; + + type Extended_Controller is + abstract new Base_Controller with record + Thread : aliased Task_Object (Extended_Controller'Access); + Name : String_Access := new string'("the_name_of_the_task"); + end record; + + task type Task_Object (Controller : access Extended_Controller'Class) is pragma Task_Name (Controller.Name.all); + end Task_Object; +end; diff --git a/gcc/testsuite/gnat.dg/task_stack_align.adb b/gcc/testsuite/gnat.dg/task_stack_align.adb new file mode 100644 index 000000000..1151a913b --- /dev/null +++ b/gcc/testsuite/gnat.dg/task_stack_align.adb @@ -0,0 +1,31 @@ +-- { dg-do run } + +with Ada.Text_IO; use Ada.Text_IO; +with System.Storage_Elements; use System.Storage_Elements; + +procedure Task_Stack_Align is + + type Align_Me is record + Value : Integer; + end record; + for Align_Me'Alignment use Standard'Maximum_Alignment; + + procedure Check_Local_Alignment_From (Context : String) is + Object : Align_Me; + begin + if To_Integer (Object'Address) mod Object'Alignment /= 0 then + Put_Line ("alignment check failed in " & Context); + end if; + end; + + task type T; + + task body T is + begin + Check_Local_Alignment_From ("task T"); + end; + + Tasks : array (1 .. 50) of T; +begin + Check_Local_Alignment_From ("environment"); +end; diff --git a/gcc/testsuite/gnat.dg/test_8bitlong_overflow.adb b/gcc/testsuite/gnat.dg/test_8bitlong_overflow.adb new file mode 100644 index 000000000..b22c87170 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_8bitlong_overflow.adb @@ -0,0 +1,28 @@ +-- { dg-do run } +-- { dg-options "-gnato" } + +procedure Test_8bitlong_Overflow is + + pragma Unsuppress (Overflow_Check); + generic + type T is range <>; + package G is + LO : T := T'first; + ONE : T := T(1); + + type A2 is array(T range <>) of T; + subtype SA2 is A2(LO..4*ONE); + + ARRAY_AGGR : SA2 := SA2'(others=>LO + 1); + + POS_1 : T := T'pos(LO*ONE); + end; + + type T is new LONG_INTEGER range -1..10; + for T'size use 8; + + package P is new G (T); + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/test_address_null_init.adb b/gcc/testsuite/gnat.dg/test_address_null_init.adb new file mode 100644 index 000000000..18824d666 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_address_null_init.adb @@ -0,0 +1,16 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +with Address_Null_Init; use Address_Null_Init; +with Ada.Text_IO; use Ada.Text_IO; + +procedure Test_Address_Null_Init is +begin + if B /= null then + Put_Line ("ERROR: B was not default initialized to null!"); + end if; + + if A /= null then + Put_Line ("ERROR: A was not reinitialized to null!"); + end if; +end Test_Address_Null_Init; diff --git a/gcc/testsuite/gnat.dg/test_ai254.adb b/gcc/testsuite/gnat.dg/test_ai254.adb new file mode 100644 index 000000000..18f658372 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_ai254.adb @@ -0,0 +1,12 @@ +-- { dg-do compile } + +procedure test_ai254 is + function Func + (Obj : not null access protected function (X : Float) return Float) + return not null access protected function (X : Float) return Float is + begin + return null; + end; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/test_allocator_maxalign2.adb b/gcc/testsuite/gnat.dg/test_allocator_maxalign2.adb new file mode 100644 index 000000000..144914d2d --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_allocator_maxalign2.adb @@ -0,0 +1,8 @@ +-- { dg-do run } + +with Allocator_Maxalign2; + +procedure Test_Allocator_Maxalign2 is +begin + Allocator_Maxalign2.Check; +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 000000000..82973147e --- /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/test_bounded.adb b/gcc/testsuite/gnat.dg/test_bounded.adb new file mode 100644 index 000000000..29d94f48e --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_bounded.adb @@ -0,0 +1,13 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +procedure Test_Bounded is + type Bounded (Length : Natural := 0) is + record + S : String (1..Length); + end record; + type Ref is access all Bounded; + X : Ref := new Bounded; +begin + null; +end Test_Bounded; diff --git a/gcc/testsuite/gnat.dg/test_call.adb b/gcc/testsuite/gnat.dg/test_call.adb new file mode 100644 index 000000000..f1ea10f73 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_call.adb @@ -0,0 +1,24 @@ +-- { dg-do compile } + +with System; with Ada.Unchecked_Conversion; +procedure Test_Call is + type F_ACC is access function (Str : String) return String; + + function Do_Something (V : F_Acc) return System.Address is + begin + return System.Null_Address; + end Do_Something; + + function BUG_1 (This : access Integer) return F_Acc is + begin + return null; + end BUG_1; + + function Unch is new Ada.Unchecked_Conversion (F_Acc, System.Address); + Func : System.Address := Unch (BUG_1 (null)); + + V : System.Address := Do_Something (BUG_1 (null)); + +begin + null; +end Test_Call; diff --git a/gcc/testsuite/gnat.dg/test_debug1.adb b/gcc/testsuite/gnat.dg/test_debug1.adb new file mode 100644 index 000000000..f4d362f30 --- /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 000000000..aaedf7f40 --- /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_direct_io.adb b/gcc/testsuite/gnat.dg/test_direct_io.adb new file mode 100644 index 000000000..0eb8aa208 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_direct_io.adb @@ -0,0 +1,15 @@ +-- { dg-do run } +with Ada.Direct_IO; + +procedure Test_Direct_IO is + + package BDIO is new Ada.Direct_IO (Boolean); + use BDIO; + + FD : File_Type; + +begin + Create (FD, Form => "shared=yes"); + Reset (FD); + Close (FD); +end Test_Direct_IO; diff --git a/gcc/testsuite/gnat.dg/test_dse_step.adb b/gcc/testsuite/gnat.dg/test_dse_step.adb new file mode 100644 index 000000000..77652b4c3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_dse_step.adb @@ -0,0 +1,14 @@ +-- { dg-do compile } +-- { dg-options "-O1 -gnatp -gnatn" } + +with Dse_Step; use Dse_Step; + +procedure Test_Dse_Step is + Start : My_Counter := (Value => 0, Step => 1); + Steps : Natural := Nsteps; +begin + Step_From (Start); + if Mv /= Steps then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/test_enum_io.adb b/gcc/testsuite/gnat.dg/test_enum_io.adb new file mode 100644 index 000000000..10771c99f --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_enum_io.adb @@ -0,0 +1,33 @@ +-- { dg-do run } + +with Ada.Text_IO; +use Ada.Text_IO; + +procedure Test_Enum_IO is + + type Enum is (Literal); + package Enum_IO is new Enumeration_IO (Enum); + use Enum_IO; + + File : File_Type; + Value: Enum; + Rest : String (1 ..30); + Last : Natural; + +begin + + Create (File, Mode => Out_File); + Put_Line (File, "Literax0000000l note the 'l' at the end"); + + Reset (File, Mode => In_File); + Get (File, Value); + Get_Line (File, Rest, Last); + + Close (File); + + Put_Line (Enum'Image (Value) & Rest (1 .. Last)); + raise Program_Error; + +exception + when Data_Error => null; +end Test_Enum_IO; diff --git a/gcc/testsuite/gnat.dg/test_equal1.adb b/gcc/testsuite/gnat.dg/test_equal1.adb new file mode 100644 index 000000000..7731f0c51 --- /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 000000000..8accc70d0 --- /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_fixed_io.adb b/gcc/testsuite/gnat.dg/test_fixed_io.adb new file mode 100644 index 000000000..823e172d5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_fixed_io.adb @@ -0,0 +1,34 @@ +-- { dg-do run } + +with Ada.Text_IO; use Ada.Text_IO; + +procedure test_fixed_io is + type FX is delta 0.0001 range -3.0 .. 250.0; + for FX'Small use 0.0001; + package FXIO is new Fixed_IO (FX); + use FXIO; + ST : String (1 .. 11) := (others => ' '); + ST2 : String (1 .. 12) := (others => ' '); + + N : constant FX := -2.345; +begin + begin + Put (ST, N, 6, 2); + Put_Line ("*ERROR* Test1: Exception Layout_Error was not raised"); + Put_Line ("ST = """ & ST & '"'); + exception + when Layout_Error => + null; + when others => + Put_Line ("Test1: Unexpected exception"); + end; + + begin + Put (ST2, N, 6, 2); + exception + when Layout_Error => + Put_Line ("*ERROR* Test2: Exception Layout_Error was raised"); + when others => + Put_Line ("Test2: Unexpected exception"); + end; +end; 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 000000000..85c1ceb0f --- /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/test_ifaces.adb b/gcc/testsuite/gnat.dg/test_ifaces.adb new file mode 100644 index 000000000..5fca1371e --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_ifaces.adb @@ -0,0 +1,10 @@ +-- { dg-do run } + +with Ifaces; use Ifaces; +procedure test_ifaces is + view2 : access Iface_2'Class; + obj : aliased DT := (m_name => "Abdu"); +begin + view2 := Iface_2'Class(obj)'Access; + view2.all.op2; +end; diff --git a/gcc/testsuite/gnat.dg/test_image.adb b/gcc/testsuite/gnat.dg/test_image.adb new file mode 100644 index 000000000..8f9430143 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_image.adb @@ -0,0 +1,8 @@ +-- { dg-do run } + +with test_image_p; +procedure test_image is + my_at5c : test_image_p.a_type5_class; +begin + my_at5c := new test_image_p.type5; +end; diff --git a/gcc/testsuite/gnat.dg/test_image_p.adb b/gcc/testsuite/gnat.dg/test_image_p.adb new file mode 100644 index 000000000..499a113ad --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_image_p.adb @@ -0,0 +1,24 @@ +with ada.task_identification; +with ada.text_io; use ada.text_io; +package body test_image_p is + function to_type1 (arg1 : in Integer) return type1 is + begin + return (f2 => (others => Standard.False)); + end to_type1; + task body task_t is + Name : String := + ada.task_identification.image (arg.the_task'identity); + begin + arg.the_array := (others => to_type1 (-1)); + if Name (1 .. 19) /= "my_at5c.f3.the_task" then + Put_Line ("error"); + raise Program_Error; + end if; + + select + accept entry1; + or + terminate; + end select; + end task_t; +end; diff --git a/gcc/testsuite/gnat.dg/test_image_p.ads b/gcc/testsuite/gnat.dg/test_image_p.ads new file mode 100644 index 000000000..95715b8b5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_image_p.ads @@ -0,0 +1,23 @@ +package test_image_p is + type type1 is tagged private; + type type3 is limited private; + type type5 is tagged limited private; + type a_type5_class is access all type5'Class; + task type task_t (arg : access type3) is + entry entry1; + end task_t; + function to_type1 (arg1 : in Integer) return type1; +private + type array_t is array (Positive range <>) of type1; + type array_t2 is array (1 .. 3) of Boolean; + type type1 is tagged record + f2 : array_t2; + end record; + type type3 is limited record + the_task : aliased task_t (type3'Access); + the_array : array_t (1 .. 10) := (others => to_type1 (-1)); + end record; + type type5 is tagged limited record + f3 : type3; + end record; +end; diff --git a/gcc/testsuite/gnat.dg/test_nested_subtype_byref.adb b/gcc/testsuite/gnat.dg/test_nested_subtype_byref.adb new file mode 100644 index 000000000..282aefd1a --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_nested_subtype_byref.adb @@ -0,0 +1,8 @@ +-- { dg-do run } +-- { dg-options "-O2" } + +with Nested_Subtype_Byref; +procedure Test_Nested_Subtype_Byref is +begin + Nested_Subtype_Byref.Check; +end; diff --git a/gcc/testsuite/gnat.dg/test_oalign.adb b/gcc/testsuite/gnat.dg/test_oalign.adb new file mode 100644 index 000000000..5ad0111c9 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_oalign.adb @@ -0,0 +1,14 @@ +-- { dg-do run } + +with System.Storage_Elements; use System.Storage_Elements; +with Oalign1, Oalign2; use Oalign1, Oalign2; + +procedure Test_Oalign is +begin + if Klunk1'Address mod Klunk1'Alignment /= 0 then + raise Program_Error; + end if; + if Klunk2'Address mod Klunk2'Alignment /= 0 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/test_oconst.adb b/gcc/testsuite/gnat.dg/test_oconst.adb new file mode 100644 index 000000000..23e5a97d5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_oconst.adb @@ -0,0 +1,13 @@ +-- { dg-do run } + +with OCONST1, OCONST2, OCONST3, OCONST4, OCONST5; + +procedure Test_Oconst is +begin + OCONST1.check (OCONST1.My_R); + OCONST2.check (OCONST2.My_R); + OCONST3.check (OCONST3.My_R); + OCONST4.check (OCONST4.My_R); + OCONST5.check (OCONST5.My_R0, 0); + OCONST5.check (OCONST5.My_R1, 1); +end; diff --git a/gcc/testsuite/gnat.dg/test_prefix1.adb b/gcc/testsuite/gnat.dg/test_prefix1.adb new file mode 100644 index 000000000..8ed1ed5e5 --- /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_prio.adb b/gcc/testsuite/gnat.dg/test_prio.adb new file mode 100644 index 000000000..30d07a81e --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_prio.adb @@ -0,0 +1,21 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +pragma Locking_Policy (Ceiling_Locking); +with test_prio_p;use test_prio_p; +with text_io; use text_io; +procedure Test_Prio is + task Tsk is + pragma Priority (10); + end Tsk; + task body Tsk is + begin + Sema2.Seize; + Sema1.Seize; + Put_Line ("error"); + exception + when Program_Error => null; -- OK + end; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/test_prio_p.adb b/gcc/testsuite/gnat.dg/test_prio_p.adb new file mode 100644 index 000000000..333ab9286 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_prio_p.adb @@ -0,0 +1,7 @@ +-- { dg-options "-gnatws" } + +package body test_prio_p is + protected body Protected_Queue_T is + entry Seize when True is begin null; end; + end Protected_Queue_T; +end test_prio_p; diff --git a/gcc/testsuite/gnat.dg/test_prio_p.ads b/gcc/testsuite/gnat.dg/test_prio_p.ads new file mode 100644 index 000000000..f6dcaa8eb --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_prio_p.ads @@ -0,0 +1,12 @@ +with System; with Unchecked_Conversion; +package test_prio_p is + type Task_Priority_T is new Natural; + function Convert_To_System_Priority is + new Unchecked_Conversion (Task_Priority_T, System.Priority); + protected type Protected_Queue_T( PO_Priority : Task_Priority_T ) is + pragma Priority (Convert_To_System_Priority (PO_Priority )); + entry Seize; + end Protected_Queue_T; + Sema1 : protected_Queue_T (5); + Sema2 : protected_Queue_T (10); +end test_prio_p; diff --git a/gcc/testsuite/gnat.dg/test_raise_from_pure.adb b/gcc/testsuite/gnat.dg/test_raise_from_pure.adb new file mode 100644 index 000000000..66db2232e --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_raise_from_pure.adb @@ -0,0 +1,13 @@ +-- { dg-do run { xfail arm*-*-* } } +-- { dg-options "-O2" } + +-- This is an optimization test and its failure is only a missed optimization. +-- For technical reasons it cannot pass with SJLJ exceptions. + +with Raise_From_Pure; use Raise_From_Pure; + +procedure test_raise_from_pure is + K : Integer; +begin + K := Raise_CE_If_0 (0); +end; 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 000000000..d33ea393a --- /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/test_self.adb b/gcc/testsuite/gnat.dg/test_self.adb new file mode 100644 index 000000000..6348c02a0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_self.adb @@ -0,0 +1,12 @@ +-- { dg-do run } + +with Text_IO; use Text_IO; +with Self; use Self; +procedure Test_Self is + It : Lim := G (5); +begin + Change (It, 10); + if Get (It) /= 35 then + Put_Line ("self-referential aggregate incorrectly built"); + end if; +end Test_Self; diff --git a/gcc/testsuite/gnat.dg/test_self_ref.adb b/gcc/testsuite/gnat.dg/test_self_ref.adb new file mode 100644 index 000000000..0fe630212 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_self_ref.adb @@ -0,0 +1,36 @@ +-- { dg-do run } + +procedure Test_Self_Ref is + type T2; + type T2_Ref is access all T2; + + function F (X: T2_Ref) return Integer; + + type T2 is limited record + Int1 : Integer := F (T2'Unchecked_Access); + Int2 : Integer := F (T2'Unrestricted_Access); + end record; + + Counter : Integer := 2; + + function F (X: T2_Ref) return Integer is + begin + Counter := Counter * 5; + return Counter; + end F; + + Obj1 : T2_Ref := new T2'(10,20); + Obj2 : T2_Ref := new T2; + Obj3 : T2_Ref := new T2'(others => <>); + +begin + if Obj1.Int1 /= 10 or else Obj1.Int2 /= 20 then + raise Program_Error; + end if; + if Obj2.Int1 /= 10 or else Obj2.Int2 /= 50 then + raise Program_Error; + end if; + if Obj3.Int1 /= 250 or else Obj3.Int2 /= 1250 then + raise Program_Error; + end if; +end Test_Self_Ref; diff --git a/gcc/testsuite/gnat.dg/test_table1.adb b/gcc/testsuite/gnat.dg/test_table1.adb new file mode 100644 index 000000000..64155bfd8 --- /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; diff --git a/gcc/testsuite/gnat.dg/test_tables.adb b/gcc/testsuite/gnat.dg/test_tables.adb new file mode 100644 index 000000000..d0abbfa57 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_tables.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +with G_tables; +procedure test_tables is + package Inst is new G_Tables (Integer); + use Inst; + It : Inst.Table := Create (15); +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/test_tamdt.adb b/gcc/testsuite/gnat.dg/test_tamdt.adb new file mode 100644 index 000000000..d0658ecc4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_tamdt.adb @@ -0,0 +1,8 @@ +-- { dg-do run } + +with Tamdt; + +procedure Test_Tamdt is +begin + Tamdt.Check; +end; diff --git a/gcc/testsuite/gnat.dg/test_time_stamp.adb b/gcc/testsuite/gnat.dg/test_time_stamp.adb new file mode 100644 index 000000000..1e25f8780 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_time_stamp.adb @@ -0,0 +1,37 @@ +-- { dg-do run } + +with GNAT.Time_Stamp; +use GNAT.Time_Stamp; + +procedure test_time_stamp is + S : constant String := Current_Time; + + function NN (S : String) return Boolean is + begin + for J in S'Range loop + if S (J) not in '0' .. '9' then + return True; + end if; + end loop; + return False; + end NN; + +begin + if S'Length /= 22 + or else S (5) /= '-' + or else S (8) /= '-' + or else S (11) /= ' ' + or else S (14) /= ':' + or else S (17) /= ':' + or else S (20) /= '.' + or else NN (S (1 .. 4)) + or else NN (S (6 .. 7)) + or else NN (S (9 .. 10)) + or else NN (S (12 .. 13)) + or else NN (S (15 .. 16)) + or else NN (S (18 .. 19)) + or else NN (S (21 .. 22)) + then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/test_unknown_discrs.adb b/gcc/testsuite/gnat.dg/test_unknown_discrs.adb new file mode 100644 index 000000000..6af52dfd6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_unknown_discrs.adb @@ -0,0 +1,31 @@ +-- { dg-do compile } + +procedure Test_Unknown_Discrs is + + package Display is + + type Component_Id (<>) is limited private; + + Deferred_Const : constant Component_Id; + + private + + type Component_Id is (Clock); + + type Rec1 is record + C : Component_Id := Deferred_Const; + end record; + + Priv_Cid_Object : Component_Id := Component_Id'First; + + type Rec2 is record + C : Component_Id := Priv_Cid_Object; + end record; + + Deferred_Const : constant Component_Id := Priv_Cid_Object; + + end Display; + +begin + null; +end Test_Unknown_Discrs; diff --git a/gcc/testsuite/gnat.dg/test_version.adb b/gcc/testsuite/gnat.dg/test_version.adb new file mode 100644 index 000000000..2b88a147a --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_version.adb @@ -0,0 +1,13 @@ +-- { dg-do run } +with GNAT.Compiler_Version; +procedure Test_Version is + package Vsn is new GNAT.Compiler_Version; + use Vsn; + X : constant String := Version; +begin + if X'Length = 78 then + -- 78 = Ver_Len_Max + Ver_Prefix'Length + -- actual version should be shorter than this + raise Program_Error; + end if; +end Test_Version; diff --git a/gcc/testsuite/gnat.dg/testint.adb b/gcc/testsuite/gnat.dg/testint.adb new file mode 100644 index 000000000..a5faf4a57 --- /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; diff --git a/gcc/testsuite/gnat.dg/tf_interface_1.adb b/gcc/testsuite/gnat.dg/tf_interface_1.adb new file mode 100644 index 000000000..352e7e4a8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/tf_interface_1.adb @@ -0,0 +1,8 @@ +-- { dg-do compile } +package body TF_Interface_1 is + procedure Get_It (Handle : Stream_Access; It : out CF_Interface_1'class) + is + begin + CF_Interface_1'Class'Read (Handle, It); + end; +end; diff --git a/gcc/testsuite/gnat.dg/tf_interface_1.ads b/gcc/testsuite/gnat.dg/tf_interface_1.ads new file mode 100644 index 000000000..15c5a64cb --- /dev/null +++ b/gcc/testsuite/gnat.dg/tf_interface_1.ads @@ -0,0 +1,19 @@ +with Ada.Streams; +with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; +package TF_INTERFACE_1 is + + type CF_INTERFACE_1 is interface; + + procedure P_PROCEDURE_1 (This : in out CF_INTERFACE_1) + is abstract; + + procedure Read (Stream : not null access ada.Streams.Root_stream_Type'Class; + Item : out CF_INTERFACE_1) is null; + for CF_INTERFACE_1'Read use Read; + + procedure Write (Stream : not null access ada.Streams.Root_stream_Type'Class; + Item : CF_INTERFACE_1) is null; + for CF_INTERFACE_1'Write use Write; + + procedure Get_It (Handle : Stream_Access; It : out CF_Interface_1'class); +end TF_INTERFACE_1; diff --git a/gcc/testsuite/gnat.dg/tfren.adb b/gcc/testsuite/gnat.dg/tfren.adb new file mode 100644 index 000000000..3b6829a96 --- /dev/null +++ b/gcc/testsuite/gnat.dg/tfren.adb @@ -0,0 +1,35 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +procedure Tfren is + type R; + type Ar is access all R; + type R is record F1: Integer; F2: Ar; end record; + + for R use record + F1 at 1 range 0..31; + F2 at 5 range 0..63; + end record; + + procedure Foo (RR1, RR2: Ar); + + procedure Foo (RR1, RR2 : Ar) is + begin + if RR2.all.F1 /= 55 then raise program_error; end if; + end; + + R3: aliased R := (55, Null); + R2: aliased R := (44, R3'Access); + R1: aliased R := (22, R2'Access); + P: Ar := R1'Access; + + X: Ar renames P.all.F2; + Y: Ar renames X.all.F2; + +begin + P := R2'Access; + R1.F2 := R1'Access; + Foo (X, Y); + Y.F1 := -111; + if Y.F1 /= -111 then raise Constraint_Error; end if; +end Tfren; diff --git a/gcc/testsuite/gnat.dg/thin_pointer1.adb b/gcc/testsuite/gnat.dg/thin_pointer1.adb new file mode 100644 index 000000000..8bc586ee4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/thin_pointer1.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } +-- { dg-options "-O" } + +package body Thin_Pointer1 is + + procedure Set_Buffer (AD : Buf_Ptr; Buffer : Stream_ptr) is + begin + AD.B.A := Buffer (Buffer'First)'Address; + end Set_Buffer; + +end Thin_Pointer1; diff --git a/gcc/testsuite/gnat.dg/thin_pointer1.ads b/gcc/testsuite/gnat.dg/thin_pointer1.ads new file mode 100644 index 000000000..7332e84b7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/thin_pointer1.ads @@ -0,0 +1,22 @@ +with System; + +package Thin_Pointer1 is + + type Stream is array (Integer range <>) of Character; + + type Stream_Ptr is access Stream; + for Stream_Ptr'Size use Standard'Address_Size; + + type Buf is record + A : System.Address; + end record; + + type Buf_Wrapper is record + B : Buf; + end record; + + type Buf_Ptr is access Buf_Wrapper; + + procedure Set_Buffer (AD : Buf_Ptr; Buffer : Stream_ptr); + +end Thin_Pointer1; diff --git a/gcc/testsuite/gnat.dg/thin_pointer2.adb b/gcc/testsuite/gnat.dg/thin_pointer2.adb new file mode 100644 index 000000000..52c4dd6de --- /dev/null +++ b/gcc/testsuite/gnat.dg/thin_pointer2.adb @@ -0,0 +1,13 @@ +-- PR ada/42253 +-- Testcase by Duncan Sands <baldrick@gcc.gnu.org> + +-- { dg-do run } + +with Thin_Pointer2_Pkg; use Thin_Pointer2_Pkg; + +procedure Thin_Pointer2 is +begin + if F /= '*' then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/thin_pointer2_pkg.adb b/gcc/testsuite/gnat.dg/thin_pointer2_pkg.adb new file mode 100644 index 000000000..22500773c --- /dev/null +++ b/gcc/testsuite/gnat.dg/thin_pointer2_pkg.adb @@ -0,0 +1,18 @@ +package body Thin_Pointer2_Pkg is + + type SB is access constant String; + + function Inner (S : SB) return Character is + begin + if S /= null and then S'Length > 0 then + return S (S'First); + end if; + return '*'; + end; + + function F return Character is + begin + return Inner (SB (S)); + end; + +end Thin_Pointer2_Pkg; diff --git a/gcc/testsuite/gnat.dg/thin_pointer2_pkg.ads b/gcc/testsuite/gnat.dg/thin_pointer2_pkg.ads new file mode 100644 index 000000000..f6752b0d7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/thin_pointer2_pkg.ads @@ -0,0 +1,9 @@ +package Thin_Pointer2_Pkg is + + type SA is access String; + for SA'Size use Standard'Address_Size; + S : SA; + + function F return Character; + +end Thin_Pointer2_Pkg; diff --git a/gcc/testsuite/gnat.dg/timer_cancel.adb b/gcc/testsuite/gnat.dg/timer_cancel.adb new file mode 100644 index 000000000..c300b47a8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/timer_cancel.adb @@ -0,0 +1,38 @@ +-- { dg-do run } + +with Ada.Real_Time.Timing_Events; +use Ada.Real_Time, Ada.Real_Time.Timing_Events; + +procedure Timer_Cancel is + + E : Timing_Event; + C : Boolean; + + protected Dummy is + procedure Trigger (Event : in out Timing_Event); + end Dummy; + + protected body Dummy is + procedure Trigger (Event : in out Timing_Event) is + begin + null; + end Trigger; + end Dummy; + +begin + Set_Handler (E, Time_Last, Dummy.Trigger'Unrestricted_Access); + + if Time_Of_Event (E) /= Time_Last then + raise Program_Error with "Event time not set correctly"; + end if; + + Cancel_Handler (E, C); + + if not C then + raise Program_Error with "Event triggered already"; + end if; + + if Time_Of_Event (E) /= Time_First then + raise Program_Error with "Event time not reset correctly"; + end if; +end Timer_Cancel; diff --git a/gcc/testsuite/gnat.dg/timing_events.adb b/gcc/testsuite/gnat.dg/timing_events.adb new file mode 100644 index 000000000..589c14209 --- /dev/null +++ b/gcc/testsuite/gnat.dg/timing_events.adb @@ -0,0 +1,29 @@ +-- { dg-do run } + +procedure Timing_Events is + type Timing_Event_Handler is access protected procedure; + + protected PO is + entry Test; + procedure Proc; + private + Data : Integer := 99; + end PO; + + protected body PO is + entry Test when True is + Handler : Timing_Event_Handler := Proc'Access; + begin + Handler.all; + end Test; + + procedure Proc is + begin + if Data /= 99 then + raise Program_Error; + end if; + end Proc; + end PO; +begin + PO.Test; +end; diff --git a/gcc/testsuite/gnat.dg/trampoline1.adb b/gcc/testsuite/gnat.dg/trampoline1.adb new file mode 100644 index 000000000..065b373f0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/trampoline1.adb @@ -0,0 +1,23 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +with System; use System; + +procedure Trampoline1 is + + A : Integer; + + function F (I : Integer) return Integer is + begin + return A + I; + end F; + + CA : System.Address := F'Code_Address; + +begin + if CA = System.Null_Address then + raise Program_Error; + end if; +end; + +-- { dg-final { scan-assembler-not "GNU-stack.*x" } } diff --git a/gcc/testsuite/gnat.dg/trampoline2.adb b/gcc/testsuite/gnat.dg/trampoline2.adb new file mode 100644 index 000000000..26b42722a --- /dev/null +++ b/gcc/testsuite/gnat.dg/trampoline2.adb @@ -0,0 +1,27 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +with System; use System; + +procedure Trampoline2 is + + A : Integer; + + type FuncPtr is access function (I : Integer) return Integer; + + function F (I : Integer) return Integer is + begin + return A + I; + end F; + + P : FuncPtr := F'Access; + CA : System.Address := F'Code_Address; + I : Integer; + +begin + if CA = System.Null_Address then + raise Program_Error; + end if; + + I := P(0); +end; diff --git a/gcc/testsuite/gnat.dg/tree_static_def.adb b/gcc/testsuite/gnat.dg/tree_static_def.adb new file mode 100644 index 000000000..ed86747a8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/tree_static_def.adb @@ -0,0 +1,11 @@ + +package body TREE_STATIC_Def is + + procedure check (i : int; v : integer) is + begin + if i.value /= v then + raise program_error; + end if; + end; +end; + diff --git a/gcc/testsuite/gnat.dg/tree_static_def.ads b/gcc/testsuite/gnat.dg/tree_static_def.ads new file mode 100644 index 000000000..1ea58ee03 --- /dev/null +++ b/gcc/testsuite/gnat.dg/tree_static_def.ads @@ -0,0 +1,10 @@ +package TREE_STATIC_Def is + + type Int is record + Value : Integer; + end record; + + procedure check (I : Int; v : integer); + + One : constant Int := (Value => 1); +end; diff --git a/gcc/testsuite/gnat.dg/tree_static_use.adb b/gcc/testsuite/gnat.dg/tree_static_use.adb new file mode 100644 index 000000000..ff02b5456 --- /dev/null +++ b/gcc/testsuite/gnat.dg/tree_static_use.adb @@ -0,0 +1,12 @@ +-- { dg-do run } +-- { dg-options "-O1" } + +with TREE_STATIC_Def; use TREE_STATIC_Def; + +procedure TREE_STATIC_Use is + I : Int := One; +begin + check (I, 1); +end; + + diff --git a/gcc/testsuite/gnat.dg/type_conv.adb b/gcc/testsuite/gnat.dg/type_conv.adb new file mode 100644 index 000000000..82a01495e --- /dev/null +++ b/gcc/testsuite/gnat.dg/type_conv.adb @@ -0,0 +1,14 @@ +-- { dg-do compile } + +procedure type_conv is + type Str is new String; + generic + package G is private end; + package body G is + Name : constant String := "it"; + Full_Name : Str := Str (Name & " works"); + end G; + package Inst is new G; +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/unaligned_rep_clause.adb b/gcc/testsuite/gnat.dg/unaligned_rep_clause.adb new file mode 100644 index 000000000..ffaa076ee --- /dev/null +++ b/gcc/testsuite/gnat.dg/unaligned_rep_clause.adb @@ -0,0 +1,37 @@ +-- { dg-do compile } + +procedure Unaligned_Rep_Clause is + + type One_Bit_Record is + record + B : Boolean; + end record; + Pragma Pack(One_Bit_Record); + + subtype Version_Number_Type is String (1 .. 3); + + type Inter is + record + Version : Version_Number_Type; + end record; + + type Msg_Type is + record + Status : One_Bit_Record; + Version : Inter; + end record; + + for Msg_Type use + record + Status at 0 range 0 .. 0; + Version at 0 range 1 .. 24; + end record; + for Msg_Type'Size use 25; + + Data : Msg_Type; + Pragma Warnings (Off, Data); + Version : Inter; + +begin + Version := Data.Version; +end; diff --git a/gcc/testsuite/gnat.dg/unc.adb b/gcc/testsuite/gnat.dg/unc.adb new file mode 100644 index 000000000..c75dfbe66 --- /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/unc_memfree.adb b/gcc/testsuite/gnat.dg/unc_memfree.adb new file mode 100644 index 000000000..d6a07f07f --- /dev/null +++ b/gcc/testsuite/gnat.dg/unc_memfree.adb @@ -0,0 +1,34 @@ +-- { dg-do run } + +with Ada.Unchecked_Deallocation; +with Unc_Memops; + +procedure Unc_Memfree is + + type List is array (Natural range <>) of Integer; + for List'Alignment use Standard'Maximum_Alignment; + + type Fat_List_Access is access all List; + + type Thin_List_Access is access all List; + for Thin_List_Access'Size use Standard'Address_Size; + + procedure Release_Fat is new Ada.Unchecked_Deallocation + (Object => List, Name => Fat_List_Access); + + procedure Release_Thin is new Ada.Unchecked_Deallocation + (Object => List, Name => Thin_List_Access); + + My_Fat_List : Fat_List_Access; + My_Thin_List : Thin_List_Access; +begin + Unc_Memops.Expect_Symetry (True); + + My_Fat_List := new List (1 .. 3); + Release_Fat (My_Fat_List); + + My_Thin_List := new List (1 .. 3); + Release_Thin (My_Thin_List); + + Unc_Memops.Expect_Symetry (False); +end; diff --git a/gcc/testsuite/gnat.dg/unc_memops.adb b/gcc/testsuite/gnat.dg/unc_memops.adb new file mode 100644 index 000000000..356fc0100 --- /dev/null +++ b/gcc/testsuite/gnat.dg/unc_memops.adb @@ -0,0 +1,63 @@ + +package body Unc_Memops is + + use type System.Address; + + type Addr_Array_T is array (1 .. 20) of Addr_T; + + type Addr_Stack_T is record + Store : Addr_Array_T; + Size : Integer := 0; + end record; + + procedure Push (Addr : Addr_T; As : access addr_stack_t) is + begin + As.Size := As.Size + 1; + As.Store (As.Size) := Addr; + end; + + function Pop (As : access Addr_Stack_T) return Addr_T is + Addr : Addr_T := As.Store (As.Size); + begin + As.Size := As.Size - 1; + return Addr; + end; + + -- + + Addr_Stack : aliased Addr_Stack_T; + Symetry_Expected : Boolean := False; + + procedure Expect_Symetry (Status : Boolean) is + begin + Symetry_Expected := Status; + end; + + function Alloc (Size : size_t) return Addr_T is + function malloc (Size : Size_T) return Addr_T; + pragma Import (C, Malloc, "malloc"); + + Ptr : Addr_T := malloc (Size); + begin + if Symetry_Expected then + Push (Ptr, Addr_Stack'Access); + end if; + return Ptr; + end; + + procedure Free (Ptr : addr_t) is + begin + if Symetry_Expected + and then Ptr /= Pop (Addr_Stack'Access) + then + raise Program_Error; + end if; + end; + + function Realloc (Ptr : addr_t; Size : size_t) return Addr_T is + begin + raise Program_Error; + return System.Null_Address; + end; + +end; diff --git a/gcc/testsuite/gnat.dg/unc_memops.ads b/gcc/testsuite/gnat.dg/unc_memops.ads new file mode 100644 index 000000000..e64b3a62c --- /dev/null +++ b/gcc/testsuite/gnat.dg/unc_memops.ads @@ -0,0 +1,30 @@ +with System; + +package Unc_Memops is + pragma Elaborate_Body; + + type size_t is mod 2 ** Standard'Address_Size; + subtype addr_t is System.Address; + + function Alloc (Size : size_t) return addr_t; + procedure Free (Ptr : addr_t); + function Realloc (Ptr : addr_t; Size : size_t) return addr_t; + + procedure Expect_Symetry (Status : Boolean); + -- Whether we expect "free"s to match "alloc" return values in + -- reverse order, like alloc->X, alloc->Y should be followed by + -- free Y, free X. + +private + + -- Uncomment the exports below to really exercise the alternate versions. + + -- This only works when using an installed version of the tools which + -- grabs the runtime library objects from an archive, hence doesn't force + -- the inclusion of s-memory.o. + + -- pragma Export (C, Alloc, "__gnat_malloc"); + -- pragma Export (C, Free, "__gnat_free"); + -- pragma Export (C, Realloc, "__gnat_realloc"); + +end; diff --git a/gcc/testsuite/gnat.dg/unchecked_convert1.adb b/gcc/testsuite/gnat.dg/unchecked_convert1.adb new file mode 100644 index 000000000..eb63d59a8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/unchecked_convert1.adb @@ -0,0 +1,32 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +with Ada.Unchecked_Conversion; + +procedure Unchecked_Convert1 is + type Byte is mod 2**8; + + type Stream is array (Natural range <>) of Byte; + + type Rec is record + I1, I2 : Integer; + end record; + + function Do_Sum (R : Rec) return Integer is + begin + return R.I1 + R.I2; + end; + + function Sum (S : Stream) return Integer is + subtype Chunk is Stream (1 .. Rec'Size / 8); + function To_Chunk is new Ada.Unchecked_Conversion (Chunk, Rec); + begin + return Do_Sum (To_Chunk (S(S'First .. S'First + Rec'Size / 8 - 1))); + end; + + A : Stream (1..9); + I : Integer; + +begin + I := Sum (A(1..8)); +end; diff --git a/gcc/testsuite/gnat.dg/unchecked_convert2.adb b/gcc/testsuite/gnat.dg/unchecked_convert2.adb new file mode 100644 index 000000000..f542af7c3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/unchecked_convert2.adb @@ -0,0 +1,34 @@ +-- { dg-do run } + +with Ada.Unchecked_Conversion; +with Ada.Streams; use Ada.Streams; +with Ada.Text_IO; use Ada.Text_IO; + +procedure Unchecked_Convert2 is + + subtype Day_Number is Integer range 0 .. 31; + + subtype Byte_Array_Of_Integer is Stream_Element_Array + (1 .. Integer'Size / Stream_Element_Array'Component_Size); + + function To_Byte_Array is + new Ada.Unchecked_Conversion (Integer, Byte_Array_Of_Integer); + + Day_Now : Day_Number; + Pragma Volatile (Day_Now); + + Arr : Stream_Element_Array (1 .. 12) := (others => 16#ff#); + + procedure Test (Arr : Stream_Element_Array) is + begin + if Arr(5) /= 0 or Arr(6) /= 0 or Arr(7) /= 0 or Arr(8) /= 0 then + raise Program_Error; + end if; + end; + +begin + Day_Now := 0; + Arr (5 .. 8) := To_Byte_Array (Day_Now); + Test (Arr); + Arr (1) := 16#ff#; +end Unchecked_Convert2; diff --git a/gcc/testsuite/gnat.dg/unchecked_convert3.adb b/gcc/testsuite/gnat.dg/unchecked_convert3.adb new file mode 100644 index 000000000..135475216 --- /dev/null +++ b/gcc/testsuite/gnat.dg/unchecked_convert3.adb @@ -0,0 +1,22 @@ +-- { dg-do run } +-- { dg-options "-gnatVa" } + +with Unchecked_Conversion; + +procedure Unchecked_Convert3 is + + type Word is range -(2**15) .. (2**15) - 1; + type UWord is mod (2**16); + + function To_Word is new unchecked_conversion (UWord, Word); + + function F return UWord is + begin + return 65036; + end; + + W : Word := To_Word(F); + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/unchecked_convert4.adb b/gcc/testsuite/gnat.dg/unchecked_convert4.adb new file mode 100644 index 000000000..8f3a1aa4e --- /dev/null +++ b/gcc/testsuite/gnat.dg/unchecked_convert4.adb @@ -0,0 +1,24 @@ +-- { dg-do compile } + +with Unchecked_Conversion; + +procedure Unchecked_Convert4 is + + type Uint32 is mod 2**32; + + type Rec is record + I : Uint32; + end record; + for Rec'Size use 32; + pragma Atomic (Rec); + + function Conv is new Unchecked_Conversion (Uint32, Rec); + + function F return Uint32; + pragma Import (Ada, F); + + procedure Proc (R : Rec) is begin null; end; + +begin + Proc (Conv (F or 1)); +end; diff --git a/gcc/testsuite/gnat.dg/unchecked_convert5.adb b/gcc/testsuite/gnat.dg/unchecked_convert5.adb new file mode 100644 index 000000000..e3e4312d7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/unchecked_convert5.adb @@ -0,0 +1,22 @@ +-- { dg-do run { target hppa*-*-* sparc*-*-* powerpc*-*-* } } + +with Unchecked_Conversion; + +procedure Unchecked_Convert5 is + + subtype c_1 is string(1..1); + + function int2c1 is -- { dg-warning "different sizes" } + new unchecked_conversion (source => integer, target => c_1); + + c1 : c_1; + +begin + + c1 := int2c1(16#12#); + + if c1 (1) /= ASCII.Nul then + raise Program_Error; + end if; + +end; diff --git a/gcc/testsuite/gnat.dg/unchecked_convert5b.adb b/gcc/testsuite/gnat.dg/unchecked_convert5b.adb new file mode 100644 index 000000000..5232041c0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/unchecked_convert5b.adb @@ -0,0 +1,22 @@ +-- { dg-do run { target i?86-*-* x86_64-*-* alpha*-*-* ia64-*-* } } + +with Unchecked_Conversion; + +procedure Unchecked_Convert5b is + + subtype c_1 is string(1..1); + + function int2c1 is -- { dg-warning "different sizes" } + new unchecked_conversion (source => integer, target => c_1); + + c1 : c_1; + +begin + + c1 := int2c1(16#12#); + + if c1 (1) /= ASCII.DC2 then + raise Program_Error; + end if; + +end; diff --git a/gcc/testsuite/gnat.dg/unchecked_convert6.adb b/gcc/testsuite/gnat.dg/unchecked_convert6.adb new file mode 100644 index 000000000..a26a6a9b7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/unchecked_convert6.adb @@ -0,0 +1,22 @@ +-- { dg-do run { target hppa*-*-* sparc*-*-* powerpc*-*-* } } + +with Unchecked_Conversion; + +procedure Unchecked_Convert6 is + + subtype c_5 is string(1..5); + + function int2c5 is -- { dg-warning "different sizes" } + new unchecked_conversion (source => integer, target => c_5); + + c5 : c_5; + +begin + + c5 := int2c5(16#12#); + + if c5 (4) /= ASCII.DC2 then + raise Program_Error; + end if; + +end; diff --git a/gcc/testsuite/gnat.dg/unchecked_convert6b.adb b/gcc/testsuite/gnat.dg/unchecked_convert6b.adb new file mode 100644 index 000000000..d696f7d5f --- /dev/null +++ b/gcc/testsuite/gnat.dg/unchecked_convert6b.adb @@ -0,0 +1,22 @@ +-- { dg-do run { target i?86-*-* x86_64-*-* alpha*-*-* ia64-*-* } } + +with Unchecked_Conversion; + +procedure Unchecked_Convert6b is + + subtype c_5 is string(1..5); + + function int2c5 is -- { dg-warning "different sizes" } + new unchecked_conversion (source => integer, target => c_5); + + c5 : c_5; + +begin + + c5 := int2c5(16#12#); + + if c5 (1) /= ASCII.DC2 then + raise Program_Error; + end if; + +end; diff --git a/gcc/testsuite/gnat.dg/unchecked_convert7.adb b/gcc/testsuite/gnat.dg/unchecked_convert7.adb new file mode 100644 index 000000000..502459bba --- /dev/null +++ b/gcc/testsuite/gnat.dg/unchecked_convert7.adb @@ -0,0 +1,36 @@ +-- { dg-do compile } +-- { dg-options "-g -gnatVa" } + +with Unchecked_Conversion; + +procedure Unchecked_Convert7 is + + type BPA is array (1 .. 23) of Boolean; + pragma Pack (BPA); + for BPA'Size use 23; + + subtype Byte is Natural range 0 .. 255; + + type R is + record + S : Boolean; + E : Byte; + F : BPA; + end record; + + for R use + record + S at 0 range 0 .. 0; + E at 0 range 1 .. 8; + F at 0 range 9 .. 31; + end record; + for R'Size use 32; + + function Conversion + is new Unchecked_Conversion (Source => R, Target => Float); + + F : Float := Conversion (R'(False, Byte'Last, (others => False))); + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/unchecked_convert8.adb b/gcc/testsuite/gnat.dg/unchecked_convert8.adb new file mode 100644 index 000000000..0b8f8d12d --- /dev/null +++ b/gcc/testsuite/gnat.dg/unchecked_convert8.adb @@ -0,0 +1,34 @@ +-- { dg-do compile } +-- { dg-options "-g -O" } + +with Ada.Unchecked_Conversion; + +package body Unchecked_Convert8 is + + type T1 is range 0 .. 255; + + type T2 is + record + A : T1; + B : T1; + end record; + + for T2 use + record + A at 0 range 0 .. 7; + B at 1 range 0 .. 7; + end record; + + for T2'Size use 16; + + type T3 is range 0 .. (2**16 - 1); + for T3'Size use 16; + + function T2_TO_T3 is + new Ada.Unchecked_Conversion (Source => T2, Target => T3); + + C : constant T3 := T2_TO_T3 (S => (A => 0, B => 0)); + + procedure Dummy is begin null; end; + +end Unchecked_Convert8; diff --git a/gcc/testsuite/gnat.dg/unchecked_convert8.ads b/gcc/testsuite/gnat.dg/unchecked_convert8.ads new file mode 100644 index 000000000..3a2857ccb --- /dev/null +++ b/gcc/testsuite/gnat.dg/unchecked_convert8.ads @@ -0,0 +1,5 @@ +package Unchecked_Convert8 is + + procedure Dummy; + +end Unchecked_Convert8; diff --git a/gcc/testsuite/gnat.dg/unchecked_union1.adb b/gcc/testsuite/gnat.dg/unchecked_union1.adb new file mode 100644 index 000000000..671d0b0c7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/unchecked_union1.adb @@ -0,0 +1,23 @@ +-- { dg-do run } + +procedure Unchecked_Union1 is + + type Bit is (Zero, One); + + type U (X : Bit := Zero) is record + case X is + when Zero => I: Integer; + when One => F : Float; + end case; + end record; + for U use record + I at 0 range 0 .. 31; + F at 0 range 0 .. 31; + end record; + pragma Unchecked_Union(U); + +begin + if U'Object_Size /= 32 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/uninit_func.adb b/gcc/testsuite/gnat.dg/uninit_func.adb new file mode 100644 index 000000000..ff5427ad7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/uninit_func.adb @@ -0,0 +1,13 @@ +-- { dg-do compile } +-- { dg-options "-O -Wall" } + +function uninit_func (A, B : Boolean) return Boolean is + C : Boolean; +begin + if A then + C := False; + elsif B then + C := True; + end if; + return C; -- { dg-warning "may be used uninitialized" } +end; diff --git a/gcc/testsuite/gnat.dg/valid1.adb b/gcc/testsuite/gnat.dg/valid1.adb new file mode 100644 index 000000000..a24376733 --- /dev/null +++ b/gcc/testsuite/gnat.dg/valid1.adb @@ -0,0 +1,24 @@ +-- { dg-do run } +-- { dg-options "-gnatVi" } + +procedure valid1 is + type m is range 0 .. 10; + for m'size use 8; + + type r is record + a, b : m; + c, d, e, f : boolean; + end record; + pragma Pack (r); + for R'size use 20; + + type G is array (1 .. 3, 1 .. 3) of R; + pragma Pack (G); + + procedure h (c : m) is begin null; end; + + GG : G := (others => (others => (2, 3, true, true, true, true))); + +begin + h (GG (3, 2).a); +end; diff --git a/gcc/testsuite/gnat.dg/varsize_copy.adb b/gcc/testsuite/gnat.dg/varsize_copy.adb new file mode 100644 index 000000000..4fa0ff862 --- /dev/null +++ b/gcc/testsuite/gnat.dg/varsize_copy.adb @@ -0,0 +1,24 @@ +-- { dg-do compile } +-- { dg-options "-O -gnatws" } + +package body Varsize_Copy is + + type Key_Mapping_Type is record + Page : Page_Type; + B : Boolean; + end record; + + type Key_Mapping_Array is array (Key_Type) of Key_Mapping_Type; + + type Set is record + Key_Mappings : Key_Mapping_Array; + end record; + + S : Set; + + function F (Key : Key_Type) return Page_Type is + begin + return S.Key_Mappings (Key).Page; + end; + +end Varsize_Copy; diff --git a/gcc/testsuite/gnat.dg/varsize_copy.ads b/gcc/testsuite/gnat.dg/varsize_copy.ads new file mode 100644 index 000000000..9a088a9ff --- /dev/null +++ b/gcc/testsuite/gnat.dg/varsize_copy.ads @@ -0,0 +1,30 @@ +package Varsize_Copy is + + type Key_Type is + (Nul, Cntrl, Stx, Etx, Eot, Enq, Ack, Spad, Clr, Dc_1, Dc_2, Dc_3, Dc_4); + + for Key_Type use + (Nul => 0, + Cntrl => 1, + Stx => 2, + Etx => 3, + Eot => 4, + Enq => 5, + Ack => 6, + Spad => 7, + Clr => 8, + Dc_1 => 17, + Dc_2 => 18, + Dc_3 => 19, + Dc_4 => 20); + + type Page_Type(D : Boolean := False) is record + case D is + when True => I : Integer; + when False => null; + end case; + end record; + + function F (Key : Key_Type) return Page_Type; + +end Varsize_Copy; diff --git a/gcc/testsuite/gnat.dg/varsize_temp.adb b/gcc/testsuite/gnat.dg/varsize_temp.adb new file mode 100644 index 000000000..b7c3a0b60 --- /dev/null +++ b/gcc/testsuite/gnat.dg/varsize_temp.adb @@ -0,0 +1,29 @@ +-- { dg-do compile } + +procedure Varsize_Temp (Nbytes : Natural) is + + type Message_T (Length : Natural) is record + case Length is + when 0 => null; + when others => Id : Natural; + end case; + end record; + + type Local_Message_T is new Message_T (Nbytes); + + function One_message return Local_Message_T is + M : Local_Message_T; + begin + if M.Length > 0 then + M.Id := 1; + end if; + return M; + end; + + procedure Process (X : Local_Message_T) is begin null; end; + +begin + Process (One_Message); +end; + + diff --git a/gcc/testsuite/gnat.dg/volatile1.ads b/gcc/testsuite/gnat.dg/volatile1.ads new file mode 100644 index 000000000..62bf17a59 --- /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 000000000..57df26e7a --- /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 000000000..0f7ed071c --- /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; diff --git a/gcc/testsuite/gnat.dg/volatile3.adb b/gcc/testsuite/gnat.dg/volatile3.adb new file mode 100644 index 000000000..bd0e96a27 --- /dev/null +++ b/gcc/testsuite/gnat.dg/volatile3.adb @@ -0,0 +1,16 @@ +-- { dg-do compile } +-- { dg-options "-O2" } + +procedure volatile3 is + + v1 : Integer := 0; + v2 : Integer := 0; + pragma Volatile (v1); + pragma Volatile (v2); +begin + if v1 /= v2 then + raise Program_Error; + end if; +end; + +-- { dg-final { scan-assembler "__gnat_rcheck" } } diff --git a/gcc/testsuite/gnat.dg/volatile4.adb b/gcc/testsuite/gnat.dg/volatile4.adb new file mode 100644 index 000000000..fe2b30760 --- /dev/null +++ b/gcc/testsuite/gnat.dg/volatile4.adb @@ -0,0 +1,24 @@ +-- { dg-do run } + +procedure Volatile4 is + + type My_Int is new Integer; + pragma Volatile (My_Int); + + type Rec is record + I : My_Int; + end record; + + function F (R : Rec) return Rec is + begin + return R; + end; + + R : Rec := (I => 0); + +begin + R := F (R); + if R.I /= 0 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/volatile5.adb b/gcc/testsuite/gnat.dg/volatile5.adb new file mode 100644 index 000000000..24527a500 --- /dev/null +++ b/gcc/testsuite/gnat.dg/volatile5.adb @@ -0,0 +1,16 @@ +-- { dg-do compile } + +with Volatile5_Pkg; use Volatile5_Pkg; + +procedure Volatile5 is + + A : Rec; + + procedure Proc is + begin + A := F; + end; + +begin + Proc; +end; diff --git a/gcc/testsuite/gnat.dg/volatile5_pkg.ads b/gcc/testsuite/gnat.dg/volatile5_pkg.ads new file mode 100644 index 000000000..71a0c8046 --- /dev/null +++ b/gcc/testsuite/gnat.dg/volatile5_pkg.ads @@ -0,0 +1,11 @@ +package Volatile5_Pkg is + + type Rec is record + I : Integer; + end record; + pragma Volatile(Rec); + + function F return Rec; + +end Volatile5_Pkg; +--
\ No newline at end of file diff --git a/gcc/testsuite/gnat.dg/volatile_aggregate.adb b/gcc/testsuite/gnat.dg/volatile_aggregate.adb new file mode 100644 index 000000000..e30e28b09 --- /dev/null +++ b/gcc/testsuite/gnat.dg/volatile_aggregate.adb @@ -0,0 +1,33 @@ +-- { dg-do compile } + +with System; + +procedure Volatile_Aggregate is + + function GetArrayUpperBound return Integer is + begin + return 2; + end GetArrayUpperBound; + + some_value : Integer := GetArrayUpperBound; + + type Gp_Element_Type is record + Element : Integer; + end record; + + type some_type is array (1 .. some_value) of Gp_Element_Type; + + type Aligned_Some_Type is record + Value : aliased some_type; + end record; + + for Aligned_Some_Type'Alignment use 8; + + an_aligned_type : aligned_Some_Type; + my_address : system.address; + + pragma Volatile (an_aligned_type); + +begin + my_address := an_aligned_type.value(1)'address; +end; diff --git a/gcc/testsuite/gnat.dg/warn1.adb b/gcc/testsuite/gnat.dg/warn1.adb new file mode 100644 index 000000000..6dbdfa2e7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/warn1.adb @@ -0,0 +1,12 @@ +-- { dg-do run } +-- { dg-options "-gnatwae" } + +procedure warn1 is + pragma Warnings + (Off, "variable ""Unused"" is never read and never assigned"); + Unused : Integer; + pragma Warnings + (On, "variable ""Unused"" is never read and never assigned"); +begin + null; +end warn1; diff --git a/gcc/testsuite/gnat.dg/warn2.adb b/gcc/testsuite/gnat.dg/warn2.adb new file mode 100644 index 000000000..8675a524f --- /dev/null +++ b/gcc/testsuite/gnat.dg/warn2.adb @@ -0,0 +1,14 @@ +-- { dg-do compile } + +with Unchecked_Conversion; +procedure warn2 is + type R1 is record X : Integer; end record; + type R2 is record X, Y : Integer; end record; + pragma Warnings + (Off, "types for unchecked conversion have different sizes"); + function F is new Unchecked_Conversion (R1, R2); + pragma Warnings + (On, "types for unchecked conversion have different sizes"); +begin + null; +end warn2; diff --git a/gcc/testsuite/gnat.dg/warn3.adb b/gcc/testsuite/gnat.dg/warn3.adb new file mode 100644 index 000000000..66cc79bdb --- /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; diff --git a/gcc/testsuite/gnat.dg/warn4.adb b/gcc/testsuite/gnat.dg/warn4.adb new file mode 100644 index 000000000..94147c1e6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/warn4.adb @@ -0,0 +1,30 @@ +-- { dg-do compile } +-- { dg-options "-O2" } + +with Unchecked_Conversion; + +procedure Warn4 is + + type POSIX_Character is new Standard.Character; + type POSIX_String is array (Positive range <>) of aliased POSIX_Character; + + type String_Ptr is access all String; + type POSIX_String_Ptr is access all POSIX_String; + + function sptr_to_psptr is new Unchecked_Conversion -- { dg-warning "aliasing problem" } + (String_Ptr, POSIX_String_Ptr); -- { dg-warning "" "" { target *-*-* } 14 } + + function To_POSIX_String (Str : String) return POSIX_String; + function To_POSIX_String (Str : String) + return POSIX_String is + begin + return sptr_to_psptr (Str'Unrestricted_Access).all; + end To_POSIX_String; + + A : Boolean; + S : String := "ABCD/abcd"; + P : Posix_String := "ABCD/abcd"; + +begin + A := To_POSIX_String (S) = P; +end; diff --git a/gcc/testsuite/gnat.dg/warn5.adb b/gcc/testsuite/gnat.dg/warn5.adb new file mode 100644 index 000000000..77e4a66f7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/warn5.adb @@ -0,0 +1,34 @@ +-- { dg-do compile } + +with System; +with Unchecked_Conversion; + +procedure Warn5 is + + type Digit_Type is range 0..15; + + type Frequency_Type is array( 1..12) of Digit_Type; + pragma Pack(Frequency_Type); + + type Element_Type is record + F : Frequency_Type; + end record; + + type Array_Type is array (Natural range <>) of Element_Type; + + type List_Type is record + A : Array_Type (0..1); + end record; + for List_Type'Alignment use 4; + + type Pointer_Type is access Element_Type; + function To_Ptr is new Unchecked_Conversion(System.Address, Pointer_Type); + + function Pointer (Pos : Natural; List : List_Type) return Pointer_Type is + begin + return To_Ptr(List.A(Pos)'Address); -- { dg-warning "source alignment" "" { target alpha*-*-* arm*-*-* hppa*-*-* ia64-*-* mips*-*-* sparc*-*-* } } + end; + +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/wide_boolean.adb b/gcc/testsuite/gnat.dg/wide_boolean.adb new file mode 100644 index 000000000..6cbbcf14c --- /dev/null +++ b/gcc/testsuite/gnat.dg/wide_boolean.adb @@ -0,0 +1,26 @@ +-- { dg-do run } + +with Wide_Boolean_Pkg; use Wide_Boolean_Pkg; + +procedure Wide_Boolean is + + R : TREC; + LB_TEST_BOOL : TBOOL; + +begin + + R.B := FALSE; + LB_TEST_BOOL := FALSE; + + Modify (R.H, R.B); + if (R.B /= TRUE) then + raise Program_Error; + end if; + + Modify (R.H, LB_TEST_BOOL); + R.B := LB_TEST_BOOL; + if (R.B /= TRUE) then + raise Program_Error; + end if; + +end; diff --git a/gcc/testsuite/gnat.dg/wide_boolean_pkg.adb b/gcc/testsuite/gnat.dg/wide_boolean_pkg.adb new file mode 100644 index 000000000..c61efca57 --- /dev/null +++ b/gcc/testsuite/gnat.dg/wide_boolean_pkg.adb @@ -0,0 +1,9 @@ +package body Wide_Boolean_Pkg is + + procedure Modify (LH : in out TUINT32; LB : in out TBOOL) is + begin + LH := 16#12345678#; + LB := TRUE; + end; + +end Wide_Boolean_Pkg; diff --git a/gcc/testsuite/gnat.dg/wide_boolean_pkg.ads b/gcc/testsuite/gnat.dg/wide_boolean_pkg.ads new file mode 100644 index 000000000..2dda1abb7 --- /dev/null +++ b/gcc/testsuite/gnat.dg/wide_boolean_pkg.ads @@ -0,0 +1,24 @@ +package Wide_Boolean_Pkg is + + type TBOOL is new BOOLEAN; + for TBOOL use (FALSE => 0, TRUE => 1); + for TBOOL'SIZE use 8; + + type TUINT32 is mod (2 ** 32); + for TUINT32'SIZE use 32; + + type TREC is + record + H : TUINT32; + B : TBOOL; + end record; + for TREC use + record + H at 0 range 0..31; + B at 4 range 0..31; + end record; + + procedure Modify (LH : in out TUINT32; LB : in out TBOOL); + pragma export(C, Modify, "Modify"); + +end Wide_Boolean_Pkg; diff --git a/gcc/testsuite/gnat.dg/wide_pi.adb b/gcc/testsuite/gnat.dg/wide_pi.adb new file mode 100644 index 000000000..dcb5a65ad --- /dev/null +++ b/gcc/testsuite/gnat.dg/wide_pi.adb @@ -0,0 +1,9 @@ +-- { dg-do compile } +-- { dg-options "-gnatW8" } + +with Ada.Numerics; + +procedure wide_pi is +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/wide_test.adb b/gcc/testsuite/gnat.dg/wide_test.adb new file mode 100644 index 000000000..f5d990b08 --- /dev/null +++ b/gcc/testsuite/gnat.dg/wide_test.adb @@ -0,0 +1,18 @@ +-- { dg-do run } +-- { dg-options "-gnatW8" } + +procedure wide_test is + X : constant Wide_Character := 'Я'; + +begin + declare + S3 : constant Wide_String := (''', X, '''); + X3 : Wide_Character; + begin + X3 := Wide_Character'Wide_Value (S3); + + if X /= X3 then + raise Program_Error; + end if; + end; +end; |