OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

Compare Revisions

  • This comparison shows the changes necessary to convert path 
    /openrisc/trunk/gnu-dev/or1k-gcc/gcc
    from Rev 695 to Rev 696
    ↔ Reverse comparison
  •

Rev 695 → Rev 696

/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;
/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;
/testsuite/gnat.dg/discr26_pkg.ads
0,0 → 1,5
package Discr26_Pkg is
 
function N return Integer;
 
end Discr26_Pkg;
/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;
/testsuite/gnat.dg/cond_expr2.adb
0,0 → 1,11
-- { dg-do compile }
-- { dg-options "-gnat12" }
 
package body Cond_Expr2 is
 
function F (X : integer) return String is
begin
return (if X > 0 then "positive" else "negative");
end;
 
end Cond_Expr2;
/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;
/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;
/testsuite/gnat.dg/elim1.adb
0,0 → 1,6
package body elim1 is
procedure d (a : t) is
begin
null;
end;
end;
/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;
 
 
/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;
/testsuite/gnat.dg/controlled4.ads
0,0 → 1,5
 
with controlled3; use controlled3;
package controlled4 is
procedure Test_Suite;
end;
/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;
/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;
/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;
/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;
/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;
 
/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;
/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;
 
 
/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;
/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;
/testsuite/gnat.dg/cond_expr2.ads
0,0 → 1,5
package Cond_Expr2 is
 
function F (X : integer) return String;
 
end Cond_Expr2;
/testsuite/gnat.dg/taft_type1_pkg2.ads
0,0 → 1,5
package Taft_Type1_Pkg2 is
type Priv (X : Integer) is private;
private
type Priv (X : Integer) is null record;
end Taft_Type1_Pkg2;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/array19.adb
0,0 → 1,34
-- { dg-do compile }
 
package body Array19 is
 
function N return Integer is
begin
return 1;
end;
 
type Array_Type is array (1 .. N) of Float;
 
type Enum is (One, Two);
 
type Rec (D : Enum := Enum'First) is record
case D is
when One => null;
when Two => A : Array_Type;
end case;
end record;
 
procedure Proc is
 
R : Rec;
 
function F return Array_Type is
begin
return (others => 0.0);
end F;
 
begin
R.A := F;
end;
 
end Array19;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/volatile7.adb
0,0 → 1,24
-- { dg-do compile }
-- { dg-options "-O2 -fdump-tree-optimized" }
 
function Volatile7 return Integer is
 
type Vol is new Integer;
pragma Volatile (Vol);
 
type R is record
X : Vol := 0;
end record;
 
V : R;
 
begin
for J in 1 .. 10 loop
V.X := V.X + 1;
end loop;
 
return Integer (V.X);
end;
 
-- { dg-final { scan-tree-dump "goto" "optimized" } }
-- { dg-final { cleanup-tree-dump "optimized" } }
/testsuite/gnat.dg/loop_unchecked_conversion.ads
0,0 → 1,5
package loop_unchecked_conversion is
 
procedure slice;
 
end loop_unchecked_conversion;
/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;
/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;
/testsuite/gnat.dg/array19.ads
0,0 → 1,5
package Array19 is
 
procedure Proc;
 
end Array19;
/testsuite/gnat.dg/prot2_pkg1.ads
0,0 → 1,5
package Prot2_Pkg1 is
 
function Num return Natural;
 
end Prot2_Pkg1;
/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;
/testsuite/gnat.dg/opt19.adb
0,0 → 1,27
-- { dg-do compile }
-- { dg-options "-O" }
 
procedure Opt19 is
 
type Enum is (One, Two);
 
type Vector_T is array (Enum) of Integer;
 
Zero_Vector : constant Vector_T := (Enum => 0);
 
type T is record
Vector : Vector_T;
end record;
 
procedure Nested (Value : in out T; E : Enum; B : out Boolean) is
I : Integer renames Value.Vector(E);
begin
B := I /= 0;
end;
 
Obj : T := (Vector => Zero_Vector);
B : Boolean;
 
begin
Nested (Obj, One, B);
end;
/testsuite/gnat.dg/opt9_pkg.ads
0,0 → 1,5
package Opt9_Pkg is
 
N : integer := 15;
 
end Opt9_Pkg;
/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;
/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;
/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;
/testsuite/gnat.dg/array20.adb
0,0 → 1,13
-- { dg-do assemble }
 
package body Array20 is
 
type Arr is array (Positive range <>) of Integer;
 
type P_Arr is access Arr;
 
N : constant P_Arr := null;
 
Table : P_Arr := N;
 
end Array20;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/aggr19.adb
0,0 → 1,14
-- { dg-do run }
 
with Aggr19_Pkg; use Aggr19_Pkg;
 
procedure Aggr19 is
C : Rec5
:= (Ent => (Kind => Two, Node => (L => (D => True, Pos => 1 )), I => 0));
A : Rec5 := C;
begin
Proc (A);
if A /= C then
raise Program_Error;
end if;
end;
/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;
/testsuite/gnat.dg/array20.ads
0,0 → 1,5
package Array20 is
 
pragma Elaborate_Body;
 
end array20;
/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;
/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;
/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;
/testsuite/gnat.dg/opt20.adb
0,0 → 1,15
with Ada.Characters.Handling; use Ada.Characters.Handling;
 
package body Opt20 is
 
type Build_Mode_State is (None, Static, Dynamic, Relocatable);
 
procedure Build_Library (For_Project : Integer) is
Project_Name : constant String := Get_Name_String (For_Project);
The_Build_Mode : Build_Mode_State := None;
begin
Fail (Project_Name);
Write_Str (To_Lower (Build_Mode_State'Image (The_Build_Mode)));
end;
 
end Opt20;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/oalign1.ads
0,0 → 1,5
 
package Oalign1 is
Klunk1 : Integer := 12;
for Klunk1'Alignment use Standard'Maximum_Alignment;
end;
/testsuite/gnat.dg/constant3.adb
0,0 → 1,21
-- { dg-do compile }
-- { dg-options "-O" }
 
with System.Machine_code; use System.Machine_code;
 
procedure Constant3 is
 
c : Integer := -1;
r : Integer;
 
procedure Conv (res : out Integer; v : Integer) is
v1 : constant Integer := v;
begin
Asm ("", Integer'Asm_output ("=m", res), Integer'Asm_input("m", v1));
end;
 
pragma Inline_Always (Conv);
 
begin
Conv (r, c);
end;
/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;
/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;
/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;
/testsuite/gnat.dg/opt20.ads
0,0 → 1,10
-- { dg-do compile }
-- { dg-options "-O2 -gnatpn" }
 
with Opt20_Pkg; use Opt20_Pkg;
 
package Opt20 is
 
procedure Build_Library (For_Project : Integer);
 
end Opt20;
/testsuite/gnat.dg/vect4.adb
0,0 → 1,128
-- { dg-do compile { target i?86-*-* x86_64-*-* } }
-- { dg-options "-O3 -msse2 -fdump-tree-vect-details" }
 
package body Vect4 is
 
function "+" (X : Varray; Y : Long_Float) return Varray is
R : Varray (X'Range);
begin
for I in X'Range loop
R(I) := X(I) + Y;
end loop;
return R;
end;
 
procedure Add (X : Varray; Y : Long_Float; R : out Varray) is
begin
for I in X'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
procedure Add (X : not null access Varray; Y : Long_Float; R : not null access Varray) is
begin
for I in X'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
 
function "+" (X : Sarray; Y : Long_Float) return Sarray is
R : Sarray;
begin
for I in Sarray'Range loop
R(I) := X(I) + Y;
end loop;
return R;
end;
 
procedure Add (X : Sarray; Y : Long_Float; R : out Sarray) is
begin
for I in Sarray'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
procedure Add (X : not null access Sarray; Y : Long_Float; R : not null access Sarray) is
begin
for I in Sarray'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
 
function "+" (X : Darray1; Y : Long_Float) return Darray1 is
R : Darray1;
begin
for I in Darray1'Range loop
R(I) := X(I) + Y;
end loop;
return R;
end;
 
procedure Add (X : Darray1; Y : Long_Float; R : out Darray1) is
begin
for I in Darray1'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
procedure Add (X : not null access Darray1; Y : Long_Float; R : not null access Darray1) is
begin
for I in Darray1'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
 
function "+" (X : Darray2; Y : Long_Float) return Darray2 is
R : Darray2;
begin
for I in Darray2'Range loop
R(I) := X(I) + Y;
end loop;
return R;
end;
 
procedure Add (X : Darray2; Y : Long_Float; R : out Darray2) is
begin
for I in Darray2'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
procedure Add (X : not null access Darray2; Y : Long_Float; R : not null access Darray2) is
begin
for I in Darray2'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
 
function "+" (X : Darray3; Y : Long_Float) return Darray3 is
R : Darray3;
begin
for I in Darray3'Range loop
R(I) := X(I) + Y;
end loop;
return R;
end;
 
procedure Add (X : Darray3; Y : Long_Float; R : out Darray3) is
begin
for I in Darray3'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
procedure Add (X : not null access Darray3; Y : Long_Float; R : not null access Darray3) is
begin
for I in Darray3'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
end Vect4;
 
-- { dg-final { scan-tree-dump-times "vectorized 1 loops" 15 "vect" } }
-- { dg-final { cleanup-tree-dump "vect" } }
/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;
/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;
/testsuite/gnat.dg/addr1.adb
0,0 → 1,17
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;
/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;
/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;
/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;
/testsuite/gnat.dg/return3.adb
0,0 → 1,9
-- { dg-do compile { target *-*-linux* } }
-- { dg-options "-gdwarf-2" }
 
procedure Return3 is
begin
return;
end;
 
-- { dg-final { scan-assembler "loc 1 6" } }
/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;
/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;
/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;
/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" } }
/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;
/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;
/testsuite/gnat.dg/vect4.ads
0,0 → 1,47
with Vect4_Pkg;
 
package Vect4 is
 
-- Unconstrained array types are vectorizable, possibly with special
-- help for the programmer
type Varray is array (Integer range <>) of Long_Float;
for Varray'Alignment use 16;
 
function "+" (X : Varray; Y : Long_Float) return Varray;
procedure Add (X : Varray; Y : Long_Float; R : out Varray);
procedure Add (X : not null access Varray; Y : Long_Float; R : not null access Varray);
 
 
-- Constrained array types are vectorizable
type Sarray is array (1 .. 4) of Long_Float;
for Sarray'Alignment use 16;
 
function "+" (X : Sarray; Y : Long_Float) return Sarray;
procedure Add (X : Sarray; Y : Long_Float; R : out Sarray);
procedure Add (X : not null access Sarray; Y : Long_Float; R : not null access Sarray);
 
 
type Darray1 is array (1 .. Vect4_Pkg.N) of Long_Float;
for Darray1'Alignment use 16;
 
function "+" (X : Darray1; Y : Long_Float) return Darray1;
procedure Add (X : Darray1; Y : Long_Float; R : out Darray1);
procedure Add (X : not null access Darray1; Y : Long_Float; R : not null access Darray1);
 
 
type Darray2 is array (Vect4_Pkg.K .. 4) of Long_Float;
for Darray2'Alignment use 16;
 
function "+" (X : Darray2; Y : Long_Float) return Darray2;
procedure Add (X : Darray2; Y : Long_Float; R : out Darray2);
procedure Add (X : not null access Darray2; Y : Long_Float; R : not null access Darray2);
 
 
type Darray3 is array (Vect4_Pkg.K .. Vect4_Pkg.N) of Long_Float;
for Darray3'Alignment use 16;
 
function "+" (X : Darray3; Y : Long_Float) return Darray3;
procedure Add (X : Darray3; Y : Long_Float; R : out Darray3);
procedure Add (X : not null access Darray3; Y : Long_Float; R : not null access Darray3);
 
end Vect4;
/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;
/testsuite/gnat.dg/discr31.adb
0,0 → 1,12
-- { dg-do compile }
-- { dg-options "-O" }
 
package body Discr31 is
 
function Log_Item(Packet : in Packet_Data_Type) return Log_Item_Type is
None : Log_Item_Type(0);
begin
return None;
end;
 
end Discr31;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/addr1.ads
0,0 → 1,5
-- { dg-do compile }
 
package addr1 is
pragma Elaborate_Body;
end;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/atomic6_pkg.ads
0,0 → 1,34
package Atomic6_Pkg is
 
type Int is new Integer;
pragma Atomic (Int);
 
Counter1 : Int;
Counter2 : Int;
 
Timer1 : Integer;
pragma Atomic (Timer1);
 
Timer2 : Integer;
pragma Atomic (Timer2);
 
type Arr1 is array (1..8) of Int;
Counter : Arr1;
 
type Arr2 is array (1..8) of Integer;
pragma Atomic_Components (Arr2);
Timer : Arr2;
 
type R is record
Counter1 : Int;
Timer1 : Integer;
pragma Atomic (Timer1);
Counter2 : Int;
Timer2 : Integer;
pragma Atomic (Timer2);
Dummy : Integer;
end record;
 
type Int_Ptr is access all Int;
 
end Atomic6_Pkg;
/testsuite/gnat.dg/decl_ctx_def.ads
0,0 → 1,4
 
package DECL_CTX_Def is
X : exception;
end;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/discr31.ads
0,0 → 1,14
package Discr31 is
 
type Byte_List_Type is array(Positive range <>) of Integer;
 
type Log_Item_Type(Last : Natural) is record
Data : Byte_List_Type(1 .. Last) := (others => 0);
Link : Natural := 0;
end record;
 
type Packet_Data_Type is access Log_Item_Type;
 
function Log_Item(Packet : in Packet_Data_Type) return Log_Item_Type;
 
end Discr31;
/testsuite/gnat.dg/atomic6_8.adb
0,0 → 1,37
-- { dg-do compile }
-- { dg-options "-fdump-tree-gimple" }
 
with Atomic6_Pkg; use Atomic6_Pkg;
 
procedure Atomic6_8 is
Ptr : Int_Ptr := new Int;
Temp : Integer;
begin
 
Ptr.all := Counter1;
 
Counter1 := Ptr.all;
 
Ptr.all := Int(Timer1);
Timer1 := Integer(Ptr.all);
 
Temp := Integer(Ptr.all);
Ptr.all := Int(Temp);
 
end;
 
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__counter1" 1 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__counter2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__timer1" 1 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__timer2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&temp" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*ptr" 3 "gimple"} }
 
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__counter1" 1 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__counter2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__timer1" 1 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__timer2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&temp" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*ptr" 3 "gimple"} }
 
-- { dg-final { cleanup-tree-dump "gimple" } }
/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;
/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;
/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;
/testsuite/gnat.dg/vect2_pkg.ads
0,0 → 1,6
package Vect2_Pkg is
 
function K return Positive;
function N return Positive;
 
end Vect2_Pkg;
/testsuite/gnat.dg/limited_with2_pkg1.ads
0,0 → 1,9
limited with Limited_With2_Pkg2;
 
package Limited_With2_Pkg1 is
 
type Rec2 is record
F : access Limited_With2_Pkg2.Rec3;
end record;
 
end Limited_With2_Pkg1;
/testsuite/gnat.dg/elim2.adb
0,0 → 1,7
-- { dg-do run }
 
with elim1;
procedure elim2 is
begin
null;
end;
/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;
/testsuite/gnat.dg/vect6_pkg.ads
0,0 → 1,10
with System;
 
package Vect6_Pkg is
 
type Index_Type is mod System.Memory_Size;
 
function K return Index_Type;
function N return Index_Type;
 
end Vect6_Pkg;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/incomplete1.ads
0,0 → 1,3
package Incomplete1 is
type T is null record;
end Incomplete1;
/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;
/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;
/testsuite/gnat.dg/taft_type3_pkg.ads
0,0 → 1,10
package Taft_Type3_Pkg is
 
type T is private;
 
private
 
type Buffer_T;
type T is access Buffer_T;
 
end Taft_Type3_Pkg;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/volatile8.adb
0,0 → 1,22
-- { dg-do compile }
-- { dg-options "-O2 -fdump-tree-optimized" }
 
function Volatile8 return Integer is
 
type Vol is new Integer;
pragma Volatile (Vol);
 
type A is array (1..4) of Vol;
 
V : A := (others => 0);
 
begin
for J in 1 .. 10 loop
V(1) := V(1) + 1;
end loop;
 
return Integer (V(1));
end;
 
-- { dg-final { scan-tree-dump "goto" "optimized" } }
-- { dg-final { cleanup-tree-dump "optimized" } }
/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;
/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;
/testsuite/gnat.dg/concat1_pkg.ads
0,0 → 1,5
package Concat1_Pkg is
 
function Ident (I : Integer) return Integer;
 
end Concat1_Pkg;
/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;
/testsuite/gnat.dg/boolean_subtype1.adb
0,0 → 1,42
-- { dg-do compile }
-- { dg-options "-O2" }
 
procedure Boolean_Subtype1 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;
/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;
/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;
/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;
/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;
/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;
/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" } }
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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" } }
/testsuite/gnat.dg/opt21.adb
0,0 → 1,11
-- { dg-do run }
-- { dg-options "-O2" }
 
with System;
with Opt21_Pkg; use Opt21_Pkg;
 
procedure Opt21 is
V : System.Address := Convert (null);
begin
null;
end;
/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;
/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;
/testsuite/gnat.dg/array16_pkg.ads
0,0 → 1,5
package Array16_Pkg is
 
function N return Integer;
 
end Array16_Pkg;
/testsuite/gnat.dg/loop_optimization9.adb
0,0 → 1,124
-- { dg-do compile }
-- { dg-options "-gnatws -O3" }
-- { dg-options "-gnatws -O3 -msse" { target i?86-*-* x86_64-*-* } }
 
with System.Soft_Links;
 
package body Loop_Optimization9 is
 
package SSL renames System.Soft_Links;
 
First_Temp_File_Name : constant String := "GNAT-TEMP-000000.TMP";
 
Current_Temp_File_Name : String := First_Temp_File_Name;
 
Temp_File_Name_Last_Digit : constant Positive :=
First_Temp_File_Name'Last - 4;
 
function Argument_String_To_List
(Arg_String : String) return Argument_List_Access
is
Max_Args : constant Integer := Arg_String'Length;
New_Argv : Argument_List (1 .. Max_Args);
New_Argc : Natural := 0;
Idx : Integer;
 
begin
Idx := Arg_String'First;
 
loop
exit when Idx > Arg_String'Last;
 
declare
Quoted : Boolean := False;
Backqd : Boolean := False;
Old_Idx : Integer;
 
begin
Old_Idx := Idx;
 
loop
-- An unquoted space is the end of an argument
 
if not (Backqd or Quoted)
and then Arg_String (Idx) = ' '
then
exit;
 
-- Start of a quoted string
 
elsif not (Backqd or Quoted)
and then Arg_String (Idx) = '"'
then
Quoted := True;
 
-- End of a quoted string and end of an argument
 
elsif (Quoted and not Backqd)
and then Arg_String (Idx) = '"'
then
Idx := Idx + 1;
exit;
 
-- Following character is backquoted
 
elsif Arg_String (Idx) = '\' then
Backqd := True;
 
-- Turn off backquoting after advancing one character
 
elsif Backqd then
Backqd := False;
 
end if;
 
Idx := Idx + 1;
exit when Idx > Arg_String'Last;
end loop;
 
-- Found an argument
 
New_Argc := New_Argc + 1;
New_Argv (New_Argc) :=
new String'(Arg_String (Old_Idx .. Idx - 1));
end;
end loop;
 
return new Argument_List'(New_Argv (1 .. New_Argc));
end Argument_String_To_List;
 
procedure Create_Temp_File_Internal
(FD : out File_Descriptor;
Name : out String_Access)
is
Pos : Positive;
begin
File_Loop : loop
Locked : begin
Pos := Temp_File_Name_Last_Digit;
 
Digit_Loop :
loop
case Current_Temp_File_Name (Pos) is
when '0' .. '8' =>
Current_Temp_File_Name (Pos) :=
Character'Succ (Current_Temp_File_Name (Pos));
exit Digit_Loop;
 
when '9' =>
Current_Temp_File_Name (Pos) := '0';
Pos := Pos - 1;
 
when others =>
 
SSL.Unlock_Task.all;
FD := 0;
Name := null;
exit File_Loop;
end case;
end loop Digit_Loop;
end Locked;
end loop File_Loop;
end Create_Temp_File_Internal;
 
end Loop_Optimization9;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/oalign2.ads
0,0 → 1,5
 
package Oalign2 is
Klunk2 : Integer := 12;
for Klunk2'Alignment use Standard'Maximum_Alignment;
end;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/vect5.adb
0,0 → 1,128
-- { dg-do compile { target i?86-*-* x86_64-*-* } }
-- { dg-options "-O3 -msse2 -fdump-tree-vect-details" }
 
package body Vect5 is
 
function "+" (X : Varray; Y : Long_Float) return Varray is
R : Varray (X'Range);
begin
for I in X'Range loop
R(I) := X(I) + Y;
end loop;
return R;
end;
 
procedure Add (X : Varray; Y : Long_Float; R : out Varray) is
begin
for I in X'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
procedure Add (X : not null access Varray; Y : Long_Float; R : not null access Varray) is
begin
for I in X'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
 
function "+" (X : Sarray; Y : Long_Float) return Sarray is
R : Sarray;
begin
for I in Sarray'Range loop
R(I) := X(I) + Y;
end loop;
return R;
end;
 
procedure Add (X : Sarray; Y : Long_Float; R : out Sarray) is
begin
for I in Sarray'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
procedure Add (X : not null access Sarray; Y : Long_Float; R : not null access Sarray) is
begin
for I in Sarray'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
 
function "+" (X : Darray1; Y : Long_Float) return Darray1 is
R : Darray1;
begin
for I in Darray1'Range loop
R(I) := X(I) + Y;
end loop;
return R;
end;
 
procedure Add (X : Darray1; Y : Long_Float; R : out Darray1) is
begin
for I in Darray1'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
procedure Add (X : not null access Darray1; Y : Long_Float; R : not null access Darray1) is
begin
for I in Darray1'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
 
function "+" (X : Darray2; Y : Long_Float) return Darray2 is
R : Darray2;
begin
for I in Darray2'Range loop
R(I) := X(I) + Y;
end loop;
return R;
end;
 
procedure Add (X : Darray2; Y : Long_Float; R : out Darray2) is
begin
for I in Darray2'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
procedure Add (X : not null access Darray2; Y : Long_Float; R : not null access Darray2) is
begin
for I in Darray2'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
 
function "+" (X : Darray3; Y : Long_Float) return Darray3 is
R : Darray3;
begin
for I in Darray3'Range loop
R(I) := X(I) + Y;
end loop;
return R;
end;
 
procedure Add (X : Darray3; Y : Long_Float; R : out Darray3) is
begin
for I in Darray3'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
procedure Add (X : not null access Darray3; Y : Long_Float; R : not null access Darray3) is
begin
for I in Darray3'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
end Vect5;
 
-- { dg-final { scan-tree-dump-times "vectorized 1 loops" 15 "vect" } }
-- { dg-final { cleanup-tree-dump "vect" } }
/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;
--
/testsuite/gnat.dg/loop_optimization9.ads
0,0 → 1,18
with GNAT.Strings; use GNAT.Strings;
 
package Loop_Optimization9 is
 
type File_Descriptor is new Integer;
 
procedure Create_Temp_File_Internal
(FD : out File_Descriptor;
Name : out String_Access);
 
subtype Argument_List is String_List;
 
subtype Argument_List_Access is String_List_Access;
 
function Argument_String_To_List
(Arg_String : String) return Argument_List_Access;
 
end Loop_Optimization9;
/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;
/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;
/testsuite/gnat.dg/discr23.ads
0,0 → 1,7
-- { dg-do compile }
 
package Discr23 is
 
procedure Dummy;
 
end Discr23;
/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;
/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;
/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;
/testsuite/gnat.dg/aggr19_pkg.adb
0,0 → 1,8
package body Aggr19_Pkg is
 
procedure Proc (Pool : in out Rec5) is
begin
Pool.Ent := (Kind => Two, Node => Pool.Ent.Node, I => 0);
end;
 
end ;
/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;
/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;
/testsuite/gnat.dg/opt18_pkg.ads
0,0 → 1,26
package Opt18_Pkg is
 
pragma Pure;
 
type Limit_Type is record
Low : Float;
High : Float;
end record;
 
function First_Order_Trig return Float;
 
type Trig_Pair_Type is
record
Sin : Float;
Cos : Float;
end record;
 
function Atan2 (Trig : in Trig_Pair_Type) return Float;
 
function Unchecked_Trig_Pair (Sin, Cos : in Float) return Trig_Pair_Type;
 
function Double_Trig (Trig : in Trig_Pair_Type) return Trig_Pair_Type;
 
function Sqrt (X : Float) return Float;
 
end Opt18_Pkg;
/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;
/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;
/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;
 
 
 
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/vect5.ads
0,0 → 1,47
with Vect5_Pkg;
 
package Vect5 is
 
-- Unconstrained array types are vectorizable, possibly with special
-- help for the programmer
type Varray is array (Positive range <>) of Long_Float;
for Varray'Alignment use 16;
 
function "+" (X : Varray; Y : Long_Float) return Varray;
procedure Add (X : Varray; Y : Long_Float; R : out Varray);
procedure Add (X : not null access Varray; Y : Long_Float; R : not null access Varray);
 
 
-- Constrained array types are vectorizable
type Sarray is array (Positive (1) .. Positive (4)) of Long_Float;
for Sarray'Alignment use 16;
 
function "+" (X : Sarray; Y : Long_Float) return Sarray;
procedure Add (X : Sarray; Y : Long_Float; R : out Sarray);
procedure Add (X : not null access Sarray; Y : Long_Float; R : not null access Sarray);
 
 
type Darray1 is array (Positive(1) .. Vect5_Pkg.N) of Long_Float;
for Darray1'Alignment use 16;
 
function "+" (X : Darray1; Y : Long_Float) return Darray1;
procedure Add (X : Darray1; Y : Long_Float; R : out Darray1);
procedure Add (X : not null access Darray1; Y : Long_Float; R : not null access Darray1);
 
 
type Darray2 is array (Vect5_Pkg.K .. Positive(4)) of Long_Float;
for Darray2'Alignment use 16;
 
function "+" (X : Darray2; Y : Long_Float) return Darray2;
procedure Add (X : Darray2; Y : Long_Float; R : out Darray2);
procedure Add (X : not null access Darray2; Y : Long_Float; R : not null access Darray2);
 
 
type Darray3 is array (Vect5_Pkg.K .. Vect5_Pkg.N) of Long_Float;
for Darray3'Alignment use 16;
 
function "+" (X : Darray3; Y : Long_Float) return Darray3;
procedure Add (X : Darray3; Y : Long_Float; R : out Darray3);
procedure Add (X : not null access Darray3; Y : Long_Float; R : not null access Darray3);
 
end Vect5;
/testsuite/gnat.dg/opt23_pkg.adb
0,0 → 1,8
package body Opt23_Pkg is
 
function Get (R : Rec; I : Positive; M : Natural) return Path is
begin
return R.Val (I) (M);
end;
 
end Opt23_Pkg;
/testsuite/gnat.dg/discr32.adb
0,0 → 1,21
-- { dg-do run }
-- { dg-options "-gnatws" }
 
with Discr32_Pkg; use Discr32_Pkg;
 
procedure Discr32 is
begin
 
if R1'Object_Size /= 32 then
raise Program_Error;
end if;
 
if R2'Object_Size /= R'Object_Size then
raise Program_Error;
end if;
 
if R3'Object_Size /= 64 then
raise Program_Error;
end if;
 
end;
/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;
/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;
/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;
/testsuite/gnat.dg/aggr19_pkg.ads
0,0 → 1,32
package Aggr19_Pkg is
 
type Rec1 (D : Boolean := False) is record
case D is
when False => null;
when True => Pos : Integer;
end case;
end record;
 
type Rec2 is record
L : Rec1;
end record;
 
type Rec3 is tagged null record;
 
type Enum is (One, Two, Three);
 
type Rec4 (Kind : Enum := One) is record
Node : Rec2;
case Kind is
when One => R : Rec3;
when Others => I : Integer;
end case;
end record;
 
type Rec5 is record
Ent : Rec4;
end record;
 
procedure Proc (Pool : in out Rec5);
 
end Aggr19_Pkg;
/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;
/testsuite/gnat.dg/atomic6_1.adb
0,0 → 1,39
-- { dg-do compile }
-- { dg-options "-fdump-tree-gimple" }
 
with Atomic6_Pkg; use Atomic6_Pkg;
 
procedure Atomic6_1 is
Temp : Integer;
begin
 
Counter1 := Counter2;
 
Timer1 := Timer2;
 
Counter1 := Int(Timer1);
Timer1 := Integer(Counter1);
 
Temp := Integer(Counter1);
Counter1 := Int(Temp);
 
Temp := Timer1;
Timer1 := Temp;
 
end;
 
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__counter1" 2 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__counter2" 1 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__timer1" 2 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__timer2" 1 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&temp" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*ptr" 0 "gimple"} }
 
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__counter1" 3 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__counter2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__timer1" 3 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__timer2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&temp" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*ptr" 0 "gimple"} }
 
-- { dg-final { cleanup-tree-dump "gimple" } }
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/opt23_pkg.ads
0,0 → 1,23
package Opt23_Pkg is
 
function N return Positive;
pragma Import (Ada, N);
 
type Path is array(1 .. N) of Long_Float;
type Path_Vector is array (Positive range <>) of Path;
type Path_Vector_P is access all Path_Vector;
type Path_Vector_PV is array(Positive range <>) of Path_Vector_P;
type Path_Vector_P2 is access all Path_Vector_PV;
 
type Vector is array (Positive range <>) of Natural;
type Vector_Access is access Vector;
 
type Rec is record
Val : Path_Vector_P2;
Step : Vector_Access;
end record;
 
function Get (R : Rec; I : Positive; M : Natural) return Path;
pragma Inline (Get);
 
end Opt23_Pkg;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/limited_with2_pkg2.ads
0,0 → 1,9
with Limited_With2;
 
package Limited_With2_Pkg2 is
 
type Rec3 is record
F : Limited_With2.Rec1;
end record;
 
end Limited_With2_Pkg2;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/array13.adb
0,0 → 1,14
-- PR ada/38394
 
 
-- { dg-do assemble }
 
package body Array13 is
 
procedure Foo is
X, Y : T;
begin
null;
end;
 
end Array13;
/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;
/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;
/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;
/testsuite/gnat.dg/discr32_pkg.ads
0,0 → 1,24
package Discr32_Pkg is
 
type Enum is (One, Two, Three);
 
type R (D : Enum) is record
case D is
when One => B : Boolean;
when Two => I : Integer;
when Three => F : Float;
end case;
end record;
 
for R use record
D at 0 range 0 .. 1;
B at 1 range 0 .. 0;
I at 4 range 0 .. 31 + 128;
-- F at 4 range 0 .. 31;
end record;
 
subtype R1 is R (One);
subtype R2 is R (Two);
subtype R3 is R (Three);
 
end Discr32_Pkg;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/volatile9.adb
0,0 → 1,20
-- { dg-do compile }
-- { dg-options "-O2 -fdump-tree-optimized" }
 
function Volatile9 return Integer is
 
type A is array (1..4) of Integer;
pragma Volatile_Components (A);
 
V : A := (others => 0);
 
begin
for J in 1 .. 10 loop
V(1) := V(1) + 1;
end loop;
 
return V(1);
end;
 
-- { dg-final { scan-tree-dump "goto" "optimized" } }
-- { dg-final { cleanup-tree-dump "optimized" } }
/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;
/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;
/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;
/testsuite/gnat.dg/boolean_subtype2.adb
0,0 → 1,40
-- { dg-do compile }
-- { dg-options "-O3 -gnata" }
 
package body Boolean_Subtype2 is
 
function Component_Type (Id : Entity_Id) return Entity_Id is
begin
pragma Assert (Is_String_Type (Id));
return Node20 (Id);
end;
 
function First_Index (Id : Entity_Id) return Node_Id is
begin
pragma Assert (Is_String_Type (Id));
return Node20 (Id);
end ;
 
function Is_Character_Type (Id : Entity_Id) return B is
begin
return Flag63 (Id);
end;
 
function Number_Dimensions (Id : Entity_Id) return Positive is
N : Integer := 0;
T : Node_Id := First_Index (Id);
begin
if Present (T) then
N := N + 1;
end if;
return N;
end;
 
function Is_String_Type (Id : Entity_Id) return B is
begin
return (Id /= 0
and then Number_Dimensions (Id) = 1
and then Is_Character_Type (Component_Type (Id)));
end;
 
end Boolean_Subtype2;
/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;
/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;
/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;
/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;
/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;
/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;
/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" } }
/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;
/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;
/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;
/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);
/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;
/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" } }
/testsuite/gnat.dg/boolean_subtype2.ads
0,0 → 1,9
with Boolean_Subtype2_Pkg; use Boolean_Subtype2_Pkg;
 
package Boolean_Subtype2 is
 
subtype B is Boolean;
 
function Is_String_Type (Id : Entity_Id) return B;
 
end Boolean_Subtype2;
/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;
/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;
/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;
/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;
/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" } }
/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;
/testsuite/gnat.dg/opt22.adb
0,0 → 1,20
-- { dg-do run }
-- { dg-options "-O" }
 
with Opt22_Pkg; use Opt22_Pkg;
 
procedure Opt22 is
 
procedure Go (S : String) is
begin
begin
Fail;
exception
when Constraint_Error => Put ("the " & S);
end;
Put ("the " & S);
end;
 
begin
Go ("message");
end;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/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;
 
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/vect6.adb
0,0 → 1,128
-- { dg-do compile { target i?86-*-* x86_64-*-* } }
-- { dg-options "-O3 -msse2 -fdump-tree-vect-details" }
 
package body Vect6 is
 
function "+" (X : Varray; Y : Long_Float) return Varray is
R : Varray (X'Range);
begin
for I in X'Range loop
R(I) := X(I) + Y;
end loop;
return R;
end;
 
procedure Add (X : Varray; Y : Long_Float; R : out Varray) is
begin
for I in X'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
procedure Add (X : not null access Varray; Y : Long_Float; R : not null access Varray) is
begin
for I in X'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
 
function "+" (X : Sarray; Y : Long_Float) return Sarray is
R : Sarray;
begin
for I in Sarray'Range loop
R(I) := X(I) + Y;
end loop;
return R;
end;
 
procedure Add (X : Sarray; Y : Long_Float; R : out Sarray) is
begin
for I in Sarray'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
procedure Add (X : not null access Sarray; Y : Long_Float; R : not null access Sarray) is
begin
for I in Sarray'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
 
function "+" (X : Darray1; Y : Long_Float) return Darray1 is
R : Darray1;
begin
for I in Darray1'Range loop
R(I) := X(I) + Y;
end loop;
return R;
end;
 
procedure Add (X : Darray1; Y : Long_Float; R : out Darray1) is
begin
for I in Darray1'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
procedure Add (X : not null access Darray1; Y : Long_Float; R : not null access Darray1) is
begin
for I in Darray1'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
 
function "+" (X : Darray2; Y : Long_Float) return Darray2 is
R : Darray2;
begin
for I in Darray2'Range loop
R(I) := X(I) + Y;
end loop;
return R;
end;
 
procedure Add (X : Darray2; Y : Long_Float; R : out Darray2) is
begin
for I in Darray2'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
procedure Add (X : not null access Darray2; Y : Long_Float; R : not null access Darray2) is
begin
for I in Darray2'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
 
function "+" (X : Darray3; Y : Long_Float) return Darray3 is
R : Darray3;
begin
for I in Darray3'Range loop
R(I) := X(I) + Y;
end loop;
return R;
end;
 
procedure Add (X : Darray3; Y : Long_Float; R : out Darray3) is
begin
for I in Darray3'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
procedure Add (X : not null access Darray3; Y : Long_Float; R : not null access Darray3) is
begin
for I in Darray3'Range loop
R(I) := X(I) + Y;
end loop;
end;
 
end Vect6;
 
-- { dg-final { scan-tree-dump-times "vectorized 1 loops" 15 "vect" } }
-- { dg-final { cleanup-tree-dump "vect" } }
/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;
/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;
/testsuite/gnat.dg/aggr9.ads
0,0 → 1,7
with Aggr9_Pkg; use Aggr9_Pkg;
 
package Aggr9 is
 
procedure Proc (X : R1);
 
end Aggr9;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/vect6.ads
0,0 → 1,48
with Vect6_Pkg;
 
package Vect6 is
 
-- Unconstrained array types are vectorizable, possibly with special
-- help for the programmer
type Varray is array (Vect6_Pkg.Index_Type range <>) of Long_Float;
for Varray'Alignment use 16;
 
function "+" (X : Varray; Y : Long_Float) return Varray;
procedure Add (X : Varray; Y : Long_Float; R : out Varray);
procedure Add (X : not null access Varray; Y : Long_Float; R : not null access Varray);
 
 
-- Constrained array types are vectorizable
type Sarray is array (Vect6_Pkg.Index_Type(1) .. Vect6_Pkg.Index_Type(4))
of Long_Float;
for Sarray'Alignment use 16;
 
function "+" (X : Sarray; Y : Long_Float) return Sarray;
procedure Add (X : Sarray; Y : Long_Float; R : out Sarray);
procedure Add (X : not null access Sarray; Y : Long_Float; R : not null access Sarray);
 
 
type Darray1 is array (Vect6_Pkg.Index_Type(1) .. Vect6_Pkg.N) of Long_Float;
for Darray1'Alignment use 16;
 
function "+" (X : Darray1; Y : Long_Float) return Darray1;
procedure Add (X : Darray1; Y : Long_Float; R : out Darray1);
procedure Add (X : not null access Darray1; Y : Long_Float; R : not null access Darray1);
 
 
type Darray2 is array (Vect6_Pkg.K .. Vect6_Pkg.Index_Type(4)) of Long_Float;
for Darray2'Alignment use 16;
 
function "+" (X : Darray2; Y : Long_Float) return Darray2;
procedure Add (X : Darray2; Y : Long_Float; R : out Darray2);
procedure Add (X : not null access Darray2; Y : Long_Float; R : not null access Darray2);
 
 
type Darray3 is array (Vect6_Pkg.K .. Vect6_Pkg.N) of Long_Float;
for Darray3'Alignment use 16;
 
function "+" (X : Darray3; Y : Long_Float) return Darray3;
procedure Add (X : Darray3; Y : Long_Float; R : out Darray3);
procedure Add (X : not null access Darray3; Y : Long_Float; R : not null access Darray3);
 
end Vect6;
/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;
/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;
/testsuite/gnat.dg/discr33.adb
0,0 → 1,31
-- { dg-do run }
 
procedure Discr33 is
 
subtype Int is Integer range 1..100;
 
type T (D : Int := 1) is
record
A : Integer;
B : String (1..D);
C : aliased Integer;
end record;
 
Var : T := (D => 1, A => 1234, B => "x", C => 4567);
 
type Int_Ref is access all Integer;
Pointer_To_C : Int_Ref := Var.C'Access;
 
begin
 
if Pointer_To_C.all /= 4567 then
raise Program_Error;
end if;
 
Var := (D => 26, A => 1234, B => "abcdefghijklmnopqrstuvwxyz", C => 2345);
 
if Pointer_To_C.all /= 2345 then
raise Program_Error;
end if;
 
end Discr33;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/atomic6_2.adb
0,0 → 1,45
-- { dg-do compile }
-- { dg-options "-fdump-tree-gimple" }
 
with Atomic6_Pkg; use Atomic6_Pkg;
 
procedure Atomic6_2 is
Temp : Integer;
begin
 
Counter1 := Counter1 + Counter2;
 
Timer1 := Timer1 + Timer2;
 
Counter1 := Counter1 + Int(Timer1);
Timer1 := Timer1 + Integer(Counter1);
 
Temp := Integer(Counter1) + Timer1;
Counter1 := Int(Timer1) + Int(Temp);
Timer1 := Integer(Counter1) + Temp;
 
if Counter1 /= Counter2 then
raise Program_Error;
end if;
 
if Timer1 /= Timer2 then
raise Program_Error;
end if;
 
end;
 
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__counter1" 6 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__counter2" 2 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__timer1" 6 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__timer2" 2 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&temp" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*ptr" 0 "gimple"} }
 
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__counter1" 3 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__counter2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__timer1" 3 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__timer2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&temp" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*ptr" 0 "gimple"} }
 
-- { dg-final { cleanup-tree-dump "gimple" } }
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/vect3_pkg.ads
0,0 → 1,10
with System;
 
package Vect3_Pkg is
 
type Index_Type is mod System.Memory_Size;
 
function K return Index_Type;
function N return Index_Type;
 
end Vect3_Pkg;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/decl_ctx_use.ads
0,0 → 1,5
 
package DECL_CTX_Use is
procedure Check_1;
procedure Check_2;
end;
/testsuite/gnat.dg/array14.adb
0,0 → 1,35
-- { dg-do compile }
-- { dg-options "-gnatws" }
 
with Array14_Pkg; use Array14_Pkg;
 
package body Array14 is
 
package Nested is
 
Length : constant SSE.Storage_Count := Length2;
 
subtype Encoded_Index_Type is SSE.Storage_Count range 1 .. Length;
subtype Encoded_Type is SSE.Storage_Array (Encoded_Index_Type'Range);
 
procedure Encode (Input : in Integer; Output : out Encoded_Type);
 
end;
 
package body Nested is
 
procedure Encode (Input : in Integer; Output : out Encoded_Type) is
begin
Encode2 (Input, Output);
end;
 
end;
 
procedure Init is
O : Nested.Encoded_Type;
for O'Alignment use 4;
begin
null;
end;
 
end Array14;
/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;
/testsuite/gnat.dg/profile_warning.adb
0,0 → 1,4
-- { dg-do compile }
 
package body profile_warning is
end;
/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" } }
/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;
/testsuite/gnat.dg/limited_with3_pkg1.adb
0,0 → 1,20
with Ada.Strings.Fixed.Hash;
 
package body Limited_With3_Pkg1 is
 
function Equal ( Left, Right : Element_Access) return Boolean is
begin
return True;
end;
 
function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
begin
return True;
end;
 
function Hash (Key : Key_Type) return Ada.Containers.Hash_Type is
begin
return Ada.Strings.Fixed.Hash (Key.all);
end Hash;
 
end Limited_With3_Pkg1;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/debug2_pkg.ads
0,0 → 1,19
package Debug2_Pkg is
 
type String_Ptr is access all String;
 
function To_Heap return String_Ptr;
 
type String_List(Chars_Length: Positive) is private;
 
type String_List_Ptr is access constant String_List;
 
function Singleton return String_List;
 
private
 
type String_List(Chars_Length: Positive) is record
Chars: String(1..Chars_Length);
end record;
 
end Debug2_Pkg;
/testsuite/gnat.dg/old_errors.ads
0,0 → 1,5
package Old_Errors is
 
pragma Elaborate_Body;
 
end Old_Errors;
/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;
/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;
/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;
 
/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;
/testsuite/gnat.dg/array14.ads
0,0 → 1,5
package Array14 is
 
procedure Init;
 
end Array14;
/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;
/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;
/testsuite/gnat.dg/renaming5.ads
0,0 → 1,5
package Renaming5 is
 
procedure Proc;
 
end Renaming5;
/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;
/testsuite/gnat.dg/limited_with3_pkg1.ads
0,0 → 1,28
with Ada.Containers.Hashed_Maps;
 
generic
 
type Object_Type is tagged private;
 
package Limited_With3_Pkg1 is
 
type Key_Type is access all String;
 
type Element_Type is new Object_Type with null record;
 
type Element_Access is access all Element_Type;
 
function Equal (Left, Right : Element_Access) return Boolean;
 
function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
 
function Hash (Key : Key_Type) return Ada.Containers.Hash_Type;
 
package Table_Package is new Ada.Containers.Hashed_Maps (
Key_Type => Key_Type,
Element_Type => Element_Access,
Hash => Hash,
Equivalent_Keys => Equivalent_Keys,
"=" => Equal);
 
end Limited_With3_Pkg1;
/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;
/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;
/testsuite/gnat.dg/raise_ce.adb
0,0 → 1,4
procedure Raise_CE is
begin
raise Constraint_Error;
end;
/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;
/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;
/testsuite/gnat.dg/source_ref1.adb
0,0 → 1,6
pragma Source_Reference (3, "p1.adb");
 
procedure Source_Ref1 is
begin
null;
end;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/aggr14.adb
0,0 → 1,8
-- { dg-do run }
 
with Aggr14_Pkg; use Aggr14_Pkg;
 
procedure Aggr14 is
begin
Proc;
end;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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
/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;
/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;
/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;
/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;
 
/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;
/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;
/testsuite/gnat.dg/derived_type2.adb
0,0 → 1,40
-- { dg-do run }
-- { dg-options "-gnatws" }
 
procedure Derived_Type2 is
 
package Pkg is
 
type Parent (B : Boolean := True) is record
case B is
when True => S : String (1 .. 5);
when False => F : Float;
end case;
end record;
 
function Create (X : Parent) return Parent;
 
end Pkg;
 
package body Pkg is
 
function Create (X : Parent) return Parent is
begin
return (True, "12345");
end;
 
end Pkg;
 
use Pkg;
 
type T is new Parent (True);
 
X : T;
 
begin
 
if Create (X).B /= True then
raise Program_Error;
end if;
 
end;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/opt23.adb
0,0 → 1,16
-- { dg-do compile }
-- { dg-options "-O2 -gnatn" }
 
package body Opt23 is
 
procedure Proc (Driver : Rec) is
R : Path;
begin
for I in Driver.Step'Range loop
R := Get (Driver, 1, Driver.Step (I));
R := Get (Driver, 2, Driver.Step (I));
R := Get (Driver, 3, Driver.Step (I));
end loop;
end;
 
end Opt23;
/testsuite/gnat.dg/array17_pkg.ads
0,0 → 1,8
package Array17_Pkg is
 
type Varray is array (Integer range <>) of Long_Float;
for Varray'Alignment use 16;
 
function "+" (X, Y : Varray) return Varray;
 
end Array17_Pkg;
/testsuite/gnat.dg/bit_packed_array5.adb
0,0 → 1,23
-- { dg-do compile }
 
with System;
 
package body Bit_Packed_Array5 is
 
function Inv (Word : Word_Type) return Word_Type is
W : Word_Type := Word;
pragma Volatile (W);
 
A_W : constant System.Address := W'Address;
 
V : Short_Bit_Array_Type;
for V'Address use A_W;
pragma Volatile (V);
begin
for I in V'Range loop
V (I) := not V (I);
end loop;
return W;
end;
 
end Bit_Packed_Array5;
/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;
/testsuite/gnat.dg/opt15_pkg.adb
0,0 → 1,13
package body Opt15_Pkg is
 
procedure Trace_Non_Inlined is
begin
raise Program_Error;
end;
 
procedure Trace_Inlined is
begin
Trace_Non_Inlined;
end;
 
end Opt15_Pkg;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
 
/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;
/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;
/testsuite/gnat.dg/prot2.ads
0,0 → 1,5
package Prot2 is
 
procedure Dummy;
 
end Prot2;
/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;
/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;
/testsuite/gnat.dg/opt23.ads
0,0 → 1,7
with Opt23_Pkg; use Opt23_Pkg;
 
package Opt23 is
 
procedure Proc (Driver : Rec);
 
end Opt23;
/testsuite/gnat.dg/bit_packed_array5.ads
0,0 → 1,14
package Bit_Packed_Array5 is
 
type Bit_Array is array (Integer range <>) of Boolean;
pragma Pack (Bit_Array);
 
type Short_Bit_Array_Type is new Bit_Array (0 .. 15);
for Short_Bit_Array_Type'Size use 16;
 
type Word_Type is range 0 .. 65535;
for Word_Type'Size use 16;
 
function Inv (Word : Word_Type) return Word_Type;
 
end Bit_Packed_Array5;
/testsuite/gnat.dg/opt15_pkg.ads
0,0 → 1,6
package Opt15_Pkg is
 
procedure Trace_Inlined;
pragma Inline (Trace_Inlined);
 
end Opt15_Pkg;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/nested_subtype_byref.ads
0,0 → 1,4
 
package Nested_Subtype_Byref is
procedure Check;
end;
/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;
/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;
/testsuite/gnat.dg/debug2.adb
0,0 → 1,40
-- { dg-do compile }
-- { dg-options "-g" }
 
with Debug2_Pkg; use Debug2_Pkg;
 
package body Debug2 is
 
procedure Proc is
 
function F return String_List_Ptr is
begin
return new String_List'(Singleton);
end;
 
A : String_List_Ptr := F;
 
begin
null;
end;
 
function Get return Integer is
begin
return 0;
end;
 
Failed : exception;
 
A: String_Ptr;
 
begin
 
declare
Server_Args : Integer;
begin
Server_Args := Get;
exception
when X : Failed => A := To_Heap;
end;
 
end Debug2;
/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;
/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;
/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;
/testsuite/gnat.dg/discr34.adb
0,0 → 1,9
-- { dg-do compile }
 
with Discr34_Pkg; use Discr34_Pkg;
 
procedure Discr34 is
Object : Rec := F;
begin
null;
end;
/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;
/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;
/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;
/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;
 
 
/testsuite/gnat.dg/atomic6_3.adb
0,0 → 1,58
-- { dg-do compile }
-- { dg-options "-fdump-tree-gimple" }
 
with Atomic6_Pkg; use Atomic6_Pkg;
 
procedure Atomic6_3 is
 
function F (I : Integer) return Integer is
begin
return I;
end;
 
function F2 return Integer is
begin
return Integer(Counter1);
end;
 
function F3 return Integer is
begin
return Timer1;
end;
 
Temp : Integer;
begin
 
Counter1 := Int(F(Integer(Counter2)));
 
Timer1 := F(Timer2);
 
Counter1 := Int(F(Timer1));
Timer1 := F(Integer(Counter1));
 
Temp := F(Integer(Counter1));
Counter1 := Int(F(Temp));
 
Temp := F(Timer1);
Timer1 := F(Temp);
 
Temp := F2;
Temp := F3;
 
end;
 
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__counter1" 3 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__counter2" 1 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__timer1" 3 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__timer2" 1 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&temp" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*ptr" 0 "gimple"} }
 
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__counter1" 3 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__counter2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__timer1" 3 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__timer2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&temp" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*ptr" 0 "gimple"} }
 
-- { dg-final { cleanup-tree-dump "gimple" } }
/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;
/testsuite/gnat.dg/opt20_pkg.ads
0,0 → 1,13
package Opt20_Pkg is
 
procedure Write_Str (S : String);
 
type Fail_Proc is access procedure (S : String);
 
procedure My_Fail (S : String);
 
Fail : Fail_Proc := My_Fail'Access;
 
function Get_Name_String (Id : Integer) return String;
 
end Opt20_Pkg;
/testsuite/gnat.dg/debug2.ads
0,0 → 1,5
package Debug2 is
 
procedure Proc;
 
end Debug2;
/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;
/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;
/testsuite/gnat.dg/discr28_pkg.ads
0,0 → 1,5
package Discr28_Pkg is
 
function N return Natural;
 
end Discr28_Pkg;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/array15.adb
0,0 → 1,24
-- { dg-do compile }
-- { dg-options "-O -gnatws" }
 
package body Array15 is
 
type Arr is array (Natural range <>) of Integer;
 
Table : Arr (1 .. 4);
 
N : Natural := 1;
 
procedure Zero is
begin
N := 0;
end;
 
function F (I : Integer) return Integer is
A1 : Arr := (1 => I);
A2 : Arr := Table (1 .. N) & A1;
begin
return A2 (I);
end;
 
end Array15;
/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;
/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;
/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;
/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;
/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;
/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" } }
/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" } }
/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;
/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;
/testsuite/gnat.dg/array15.ads
0,0 → 1,5
package Array15 is
 
function F (I : Integer) return Integer;
 
end Array15;
/testsuite/gnat.dg/opt3_pkg.ads
0,0 → 1,5
package Opt3_Pkg is
 
procedure F (I : Short_Integer);
 
end Opt3_Pkg;
/testsuite/gnat.dg/opt15.adb
0,0 → 1,12
-- { dg-do compile }
-- { dg-options "-O -gnatn -fdump-tree-optimized" }
 
with Opt15_Pkg; use Opt15_Pkg;
 
procedure Opt15 is
begin
Trace_Inlined;
end;
 
-- { dg-final { scan-tree-dump-not "trace_inlined" "optimized" } }
-- { dg-final { cleanup-tree-dump "optimized" } }
/testsuite/gnat.dg/limited_with3_pkg2.ads
0,0 → 1,10
limited with Limited_With3_Pkg3;
 
package Limited_With3_Pkg2 is
 
type T is tagged null record;
 
procedure Proc (X : Limited_With3_Pkg3.TT; Y : T);
 
end Limited_With3_Pkg2;
 
/testsuite/gnat.dg/deferred_const4.adb
0,0 → 1,12
-- { dg-do compile }
 
package body Deferred_Const4 is
 
function F return My_Q.T is
R : My_Q.T;
begin
R := My_Q.Null_T;
return R;
end;
 
end Deferred_Const4;
/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;
/testsuite/gnat.dg/opt7_pkg.ads
0,0 → 1,5
package Opt7_Pkg is
 
procedure My_Raise_Exception;
 
end Opt7_Pkg;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/source_ref2.adb
0,0 → 1,7
pragma Source_Reference (1, "p2.adb");
 
procedure Source_Ref2 is
pragma Source_Reference (2, "p2.adb");
begin
null;
end;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/deferred_const4.ads
0,0 → 1,17
with Deferred_Const4_Pkg;
 
package Deferred_Const4 is
 
type R1 is tagged record
I1 : Integer;
end record;
 
type R2 is new R1 with record
I2 : Integer;
end record;
 
package My_Q is new Deferred_Const4_Pkg (R2);
 
function F return My_Q.T;
 
end Deferred_Const4;
/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" } }
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/invalid1.adb
0,0 → 1,49
-- { dg-do run }
-- { dg-options "-gnatws -gnatVa" }
 
pragma Initialize_Scalars;
 
procedure Invalid1 is
 
X : Boolean;
A : Boolean := False;
 
procedure Uninit (B : out Boolean) is
begin
if A then
B := True;
raise Program_Error;
end if;
end;
 
begin
 
-- first, check that initialize_scalars is enabled
begin
if X then
A := False;
end if;
raise Program_Error;
exception
when Constraint_Error => null;
end;
 
-- second, check if copyback of an invalid value raises constraint error
begin
Uninit (A);
if A then
-- we expect constraint error in the 'if' above according to gnat ug:
-- ....
-- call. Note that there is no specific option to test `out'
-- parameters, but any reference within the subprogram will be tested
-- in the usual manner, and if an invalid value is copied back, any
-- reference to it will be subject to validity checking.
-- ...
raise Program_Error;
end if;
raise Program_Error;
exception
when Constraint_Error => null;
end;
 
end;
/testsuite/gnat.dg/discr2.ads
0,0 → 1,5
package discr2 is
procedure Dummy;
 
end discr2;
/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;
/testsuite/gnat.dg/opt24.adb
0,0 → 1,15
-- { dg-do compile }
-- { dg-options "-O2 -gnatn" }
 
package body Opt24 is
 
procedure Proc (Driver : Rec) is
R : Path;
begin
for I in Driver.Step'Range loop
R := Get (Driver, 1, Driver.Step (I));
R := Get (Driver, 2, Driver.Step (I));
end loop;
end;
 
end Opt24;
/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;
/testsuite/gnat.dg/discr26.adb
0,0 → 1,19
-- { dg-do compile }
-- { dg-options "-gnatws" }
 
package body Discr26 is
 
function F1 return My_T1 is
R: My_T1;
begin
return R;
end;
 
procedure Proc is
begin
if F1.D = 0 then
raise Program_Error;
end if;
end;
 
end Discr26;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/opt24.ads
0,0 → 1,7
with Opt23_Pkg; use Opt23_Pkg;
 
package Opt24 is
 
procedure Proc (Driver : Rec);
 
end Opt24;
/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;
/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;
/testsuite/gnat.dg/discr26.ads
0,0 → 1,16
with Discr26_Pkg;
 
package Discr26 is
 
type T1 (D : Integer) is record
case D is
when 1 => I : Integer;
when others => null;
end case;
end record;
 
type My_T1 is new T1 (Discr26_Pkg.N);
 
procedure Proc;
 
end Discr26;
/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;
 
/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;
/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;
 
 
/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;
/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;
/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;
/testsuite/gnat.dg/discr8_pkg3.ads
0,0 → 1,3
package Discr8_Pkg3 is
function Value return Natural;
end Discr8_Pkg3;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/debug3.adb
0,0 → 1,31
-- { dg-do compile }
-- { dg-options "-g" }
 
with Ada.Unchecked_Conversion;
with System;
 
package body Debug3 is
 
type Rec is record
I : Integer;
end record;
for Rec'Alignment use 1;
 
type Ptr is access Rec;
 
function To_Ptr is new Ada.Unchecked_Conversion(System.Address, Ptr);
 
procedure Proc is
 
function Get (S1 : String) return Ptr is
begin
return To_Ptr (S1'Address);
end;
 
M : Ptr;
 
begin
M := Get ("");
end;
 
end Debug3;
/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;
/testsuite/gnat.dg/discr35.adb
0,0 → 1,17
-- { dg-do compile }
 
package body Discr35 is
 
procedure Proc1 is
R : Rec2 := Null_Rec2;
begin
null;
end;
 
procedure Proc2 is
R : Rec2;
begin
R := Null_Rec2;
end;
 
end Discr35;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/atomic6_4.adb
0,0 → 1,45
-- { dg-do compile }
-- { dg-options "-fdump-tree-gimple" }
 
with Atomic6_Pkg; use Atomic6_Pkg;
 
procedure Atomic6_4 is
 
procedure P (I1 : out Integer; I2 : in Integer) is
begin
I1 := I2;
end;
 
Temp : Integer;
begin
 
P (Integer(Counter1), Integer(Counter2));
 
P (Timer1, Timer2);
 
P (Integer(Counter1), Timer1);
P (Timer1, Integer(Counter1));
 
P (Temp, Integer(Counter1));
P (Integer(Counter1), Temp);
 
P (Temp, Timer1);
P (Timer1, Temp);
 
end;
 
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__counter1" 2 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__counter2" 1 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__timer1" 2 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__timer2" 1 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&temp" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*ptr" 0 "gimple"} }
 
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__counter1" 3 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__counter2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__timer1" 3 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__timer2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&temp" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*ptr" 0 "gimple"} }
 
-- { dg-final { cleanup-tree-dump "gimple" } }
/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;
 
/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;
/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;
/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;
/testsuite/gnat.dg/debug3.ads
0,0 → 1,5
package Debug3 is
 
procedure Proc;
 
end Debug3;
/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;
/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;
/testsuite/gnat.dg/discr35.ads
0,0 → 1,25
package Discr35 is
 
type Rec1 is tagged null record;
 
type Enum is (One, Two);
 
type Rec2 (D : Enum := One) is
record
case D is
when One => null;
when Two => R : Rec1;
end case;
end record;
 
Null_Rec2 : Constant Rec2;
 
procedure Proc1;
 
procedure Proc2;
 
private
 
Null_Rec2 : Constant Rec2 := (D => One);
 
end Discr35;
/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;
/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;
/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;
/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;
/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;
 
/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;
/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;
/testsuite/gnat.dg/vect4_pkg.ads
0,0 → 1,6
package Vect4_Pkg is
 
function K return Integer;
function N return Integer;
 
end Vect4_Pkg;
/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;
/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;
/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;
/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;
/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;
 
 
/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;
/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;
/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;
/testsuite/gnat.dg/array16.adb
0,0 → 1,22
package body Array16 is
 
function F1 (A : access My_T1) return My_T1 is
begin
return A.all;
end;
 
function F2 (A : access My_T2) return My_T2 is
begin
return A.all;
end;
 
procedure Proc (A : access My_T1; B : access My_T2) is
L1 : My_T1 := F1(A);
L2 : My_T2 := F2(B);
begin
if L1.D = 0 and then L2(1) = 0 then
raise Program_Error;
end if;
end;
 
end Array16;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/itypes.ads
0,0 → 1,4
 
package itypes is
procedure Proc;
end;
/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;
/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;
/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" } }
/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;
/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;
/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;
/testsuite/gnat.dg/array16.ads
0,0 → 1,31
-- { dg-do compile }
-- { dg-options "-O -gnatn -fdump-tree-optimized" }
 
with Array16_Pkg;
 
package Array16 is
 
type T1 (D : Integer) is record
case D is
when 1 => I : Integer;
when others => null;
end case;
end record;
 
type Arr is array (Integer range <>) of Integer;
 
type My_T1 is new T1 (Array16_Pkg.N);
type My_T2 is new Arr (1 .. Integer'Min (2, Array16_Pkg.N));
 
function F1 (A : access My_T1) return My_T1;
pragma Inline (F1);
 
function F2 (A : access My_T2) return My_T2;
pragma Inline (F2);
 
procedure Proc (A : access My_T1; B : access My_T2);
 
end Array16;
 
-- { dg-final { scan-tree-dump-not "secondary_stack" "optimized" } }
-- { dg-final { cleanup-tree-dump "optimized" } }
/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;
/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;
/testsuite/gnat.dg/opt16.adb
0,0 → 1,33
-- { dg-do compile }
-- { dg-options "-O2 -gnatws" }
 
procedure Opt16 is
 
generic
type T (<>) is private;
V, V1 : T;
with function F1 (X : T) return T;
package GP is
R : Boolean := F1 (V) = V1;
end GP;
 
type AB is array (Boolean range <>) of Boolean;
 
begin
for I1 in Boolean loop
for I2 in Boolean loop
declare
B1 : Boolean := I1;
B2 : Boolean := I2;
AB1 : AB (Boolean) := (I1, I2);
T : AB (B1 .. B2) := (B1 .. B2 => True);
F : AB (B1 .. B2) := (B1 .. B2 => False);
 
package P is new GP (AB, AB1, NOT AB1, "NOT");
 
begin
null;
end;
end loop;
end loop;
end;
/testsuite/gnat.dg/limited_with3_pkg3.ads
0,0 → 1,12
with Limited_With3;
with Limited_With3_Pkg1;
 
package Limited_With3_Pkg3 is
 
package My_Q is new Limited_With3_Pkg1 (Limited_With3.T);
 
type TT is tagged record
State : My_Q.Element_Access;
end record;
 
end Limited_With3_Pkg3;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
 
/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;
/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;
 
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/loop_optimization10_pkg.ads
0,0 → 1,12
package Loop_Optimization10_Pkg is
 
pragma Pure (Loop_Optimization10_Pkg);
 
type Limit_Type is record
Low : Float;
High : Float;
end record;
 
function F (Low, High : in Float) return Limit_Type;
 
end Loop_Optimization10_Pkg;
/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;
/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;
/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;
/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;
 
 
/testsuite/gnat.dg/array14_pkg.ads
0,0 → 1,16
with System.Storage_Elements;
 
package Array14_Pkg is
 
package SSE renames System.Storage_Elements;
 
function Parity_Byte_Count return SSE.Storage_Count;
 
Length2 : constant SSE.Storage_Count := Parity_Byte_Count;
 
subtype Encoded_Index_Type2 is SSE.Storage_Count range 1 .. Length2;
subtype Encoded_Type2 is SSE.Storage_Array (Encoded_Index_Type2'Range);
 
procedure Encode2 (Input : in Integer; Output : out Encoded_Type2);
 
end Array14_Pkg;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/aggr16.ads
0,0 → 1,5
package Aggr16 is
 
procedure Proc;
 
end Aggr16;
/testsuite/gnat.dg/array18_pkg.ads
0,0 → 1,9
package Array18_Pkg is
 
function N return Positive;
 
subtype S is String (1 .. N);
 
function F return S;
 
end Array18_Pkg;
/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;
/testsuite/gnat.dg/discr27.adb
0,0 → 1,33
-- { dg-do compile }
 
package body Discr27 is
 
subtype Index is Positive range 1..4096;
 
function F return String is
S : String(1..1) := (others =>'w');
begin
return S;
end;
 
type Enum is (One, Two);
 
type Rec (D : Enum := One; Len : Index := 1) is record
case D is
when One => I : Integer;
when Two => A : String(1..Len);
end case;
end record;
 
procedure Nothing is
M : constant String := F;
C : constant Rec := (Two, M'Length, M);
begin
null;
end;
 
procedure Proc is begin
null;
end;
 
end Discr27;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/vect1.adb
0,0 → 1,128
-- { dg-do compile { target i?86-*-* x86_64-*-* } }
-- { dg-options "-O3 -msse2 -fdump-tree-vect-details" }
 
package body Vect1 is
 
function "+" (X, Y : Varray) return Varray is
R : Varray (X'Range);
begin
for I in X'Range loop
R(I) := X(I) + Y(I);
end loop;
return R;
end;
 
procedure Add (X, Y : Varray; R : out Varray) is
begin
for I in X'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
procedure Add (X, Y : not null access Varray; R : not null access Varray) is
begin
for I in X'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
 
function "+" (X, Y : Sarray) return Sarray is
R : Sarray;
begin
for I in Sarray'Range loop
R(I) := X(I) + Y(I);
end loop;
return R;
end;
 
procedure Add (X, Y : Sarray; R : out Sarray) is
begin
for I in Sarray'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
procedure Add (X, Y : not null access Sarray; R : not null access Sarray) is
begin
for I in Sarray'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
 
function "+" (X, Y : Darray1) return Darray1 is
R : Darray1;
begin
for I in Darray1'Range loop
R(I) := X(I) + Y(I);
end loop;
return R;
end;
 
procedure Add (X, Y : Darray1; R : out Darray1) is
begin
for I in Darray1'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
procedure Add (X, Y : not null access Darray1; R : not null access Darray1) is
begin
for I in Darray1'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
 
function "+" (X, Y : Darray2) return Darray2 is
R : Darray2;
begin
for I in Darray2'Range loop
R(I) := X(I) + Y(I);
end loop;
return R;
end;
 
procedure Add (X, Y : Darray2; R : out Darray2) is
begin
for I in Darray2'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
procedure Add (X, Y : not null access Darray2; R : not null access Darray2) is
begin
for I in Darray2'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
 
function "+" (X, Y : Darray3) return Darray3 is
R : Darray3;
begin
for I in Darray3'Range loop
R(I) := X(I) + Y(I);
end loop;
return R;
end;
 
procedure Add (X, Y : Darray3; R : out Darray3) is
begin
for I in Darray3'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
procedure Add (X, Y : not null access Darray3; R : not null access Darray3) is
begin
for I in Darray3'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
end Vect1;
 
-- { dg-final { scan-tree-dump-times "vectorized 1 loops" 15 "vect" } }
-- { dg-final { cleanup-tree-dump "vect" } }
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/discr12_pkg.ads
0,0 → 1,5
package Discr12_Pkg is
 
function Dummy (I : Integer) return Integer;
 
end Discr12_Pkg;
/testsuite/gnat.dg/deferred_const4_pkg.ads
0,0 → 1,22
generic
 
type User_T is private;
 
package Deferred_Const4_Pkg is
 
type T is private;
 
Null_T : constant T;
 
private
 
type T (Valid : Boolean := False) is record
case Valid is
when True => Value : User_T;
when False => null;
end case;
end record;
 
Null_T : constant T := (Valid => False);
 
end Deferred_Const4_Pkg;
/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;
/testsuite/gnat.dg/discr27.ads
0,0 → 1,5
package Discr27 is
 
procedure Proc;
 
end Discr27;
/testsuite/gnat.dg/boolean_subtype2_pkg.ads
0,0 → 1,10
package Boolean_Subtype2_Pkg is
 
type Node_Id is range 0 .. 099_999_999;
subtype Entity_Id is Node_Id;
 
function Node20 (N : Node_Id) return Node_Id;
function Flag63 (N : Node_Id) return Boolean;
function Present (N : Node_Id) return Boolean;
 
end Boolean_Subtype2_Pkg;
/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;
/testsuite/gnat.dg/nested_float_packed.ads
0,0 → 1,24
-- { dg-do compile }
 
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;
 
 
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/vect1.ads
0,0 → 1,47
with Vect1_Pkg;
 
package Vect1 is
 
-- Unconstrained array types are vectorizable, possibly with special
-- help for the programmer
type Varray is array (Integer range <>) of Long_Float;
for Varray'Alignment use 16;
 
function "+" (X, Y : Varray) return Varray;
procedure Add (X, Y : Varray; R : out Varray);
procedure Add (X, Y : not null access Varray; R : not null access Varray);
 
 
-- Constrained array types are vectorizable
type Sarray is array (1 .. 4) of Long_Float;
for Sarray'Alignment use 16;
 
function "+" (X, Y : Sarray) return Sarray;
procedure Add (X, Y : Sarray; R : out Sarray);
procedure Add (X, Y : not null access Sarray; R : not null access Sarray);
 
 
type Darray1 is array (1 .. Vect1_Pkg.N) of Long_Float;
for Darray1'Alignment use 16;
 
function "+" (X, Y : Darray1) return Darray1;
procedure Add (X, Y : Darray1; R : out Darray1);
procedure Add (X, Y : not null access Darray1; R : not null access Darray1);
 
 
type Darray2 is array (Vect1_Pkg.K .. 4) of Long_Float;
for Darray2'Alignment use 16;
 
function "+" (X, Y : Darray2) return Darray2;
procedure Add (X, Y : Darray2; R : out Darray2);
procedure Add (X, Y : not null access Darray2; R : not null access Darray2);
 
 
type Darray3 is array (Vect1_Pkg.K .. Vect1_Pkg.N) of Long_Float;
for Darray3'Alignment use 16;
 
function "+" (X, Y : Darray3) return Darray3;
procedure Add (X, Y : Darray3; R : out Darray3);
procedure Add (X, Y : not null access Darray3; R : not null access Darray3);
 
end Vect1;
/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;
/testsuite/gnat.dg/opt21_pkg.adb
0,0 → 1,17
package body Opt21_Pkg is
 
function Get_Object (Object : not null access R) return System.Address is
begin
return Object.Ptr;
end;
 
function Convert (W : Obj) return System.Address is
begin
if W = null then
return System.Null_Address;
else
return Get_Object (W);
end if;
end;
 
end Opt21_Pkg;
/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;
/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;
/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
/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;
/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;
/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;
/testsuite/gnat.dg/taft_type1.adb
0,0 → 1,8
-- { dg-do run }
 
with Taft_Type1_Pkg1;
 
procedure Taft_Type1 is
begin
Taft_Type1_Pkg1.Check;
end;
/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;
/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;
/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;
/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;
/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;
 
/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;
/testsuite/gnat.dg/atomic6_5.adb
0,0 → 1,38
-- { dg-do compile }
-- { dg-options "-fdump-tree-gimple" }
 
with Atomic6_Pkg; use Atomic6_Pkg;
 
procedure Atomic6_5 is
type Arr is array (Integer range 1 .. 4) of Boolean;
A : Arr;
B : Boolean;
begin
 
A (Integer(Counter1)) := True;
B := A (Timer1);
 
declare
pragma Suppress (Index_Check);
begin
A (Integer(Counter1)) := True;
B := A (Timer1);
end;
 
end;
 
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__counter1" 2 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__counter2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__timer1" 2 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__timer2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&temp" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*ptr" 0 "gimple"} }
 
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__counter1" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__counter2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__timer1" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__timer2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&temp" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*ptr" 0 "gimple"} }
 
-- { dg-final { cleanup-tree-dump "gimple" } }
/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;
/testsuite/gnat.dg/opt21_pkg.ads
0,0 → 1,15
with System;
 
package Opt21_Pkg is
 
type R is record
Ptr : System.Address := System.Null_Address;
end record;
 
type Obj is access all R;
 
function Get_Object (Object : not null access R) return System.Address;
 
function Convert (W : Obj) return System.Address;
 
end Opt21_Pkg;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/anon1.ads
0,0 → 1,4
 
package anon1 is
function F return access Integer;
end anon1;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/controlled2.ads
0,0 → 1,5
 
with controlled1; use controlled1;
package controlled2 is
procedure Test_Suite;
end controlled2;
/testsuite/gnat.dg/stack_usage1.adb
0,0 → 1,39
-- { dg-do compile }
-- { dg-options "-fstack-usage" }
 
with Stack_Usage1_Pkg; use Stack_Usage1_Pkg;
 
procedure Stack_Usage1 is
 
A : Integer := Ident_Int (123);
 
begin
case A is
when 0 =>
My_Proc (R'(Ident_Int(0), Ident_Int(1), Ident_Int(2), Ident_Int(3), Ident_Int(4), Ident_Int(5), Ident_Int(6), Ident_Int(7), Ident_Int(8), Ident_Int(9)));
when 1 =>
My_Proc (R'(Ident_Int(0), Ident_Int(1), Ident_Int(2), Ident_Int(3), Ident_Int(4), Ident_Int(5), Ident_Int(6), Ident_Int(7), Ident_Int(8), Ident_Int(9)));
when 2 =>
My_Proc (R'(Ident_Int(0), Ident_Int(1), Ident_Int(2), Ident_Int(3), Ident_Int(4), Ident_Int(5), Ident_Int(6), Ident_Int(7), Ident_Int(8), Ident_Int(9)));
when 3 =>
My_Proc (R'(Ident_Int(0), Ident_Int(1), Ident_Int(2), Ident_Int(3), Ident_Int(4), Ident_Int(5), Ident_Int(6), Ident_Int(7), Ident_Int(8), Ident_Int(9)));
when 4 =>
My_Proc (R'(Ident_Int(0), Ident_Int(1), Ident_Int(2), Ident_Int(3), Ident_Int(4), Ident_Int(5), Ident_Int(6), Ident_Int(7), Ident_Int(8), Ident_Int(9)));
when 5 =>
My_Proc (R'(Ident_Int(0), Ident_Int(1), Ident_Int(2), Ident_Int(3), Ident_Int(4), Ident_Int(5), Ident_Int(6), Ident_Int(7), Ident_Int(8), Ident_Int(9)));
when 6 =>
My_Proc (R'(Ident_Int(0), Ident_Int(1), Ident_Int(2), Ident_Int(3), Ident_Int(4), Ident_Int(5), Ident_Int(6), Ident_Int(7), Ident_Int(8), Ident_Int(9)));
when 7 =>
My_Proc (R'(Ident_Int(0), Ident_Int(1), Ident_Int(2), Ident_Int(3), Ident_Int(4), Ident_Int(5), Ident_Int(6), Ident_Int(7), Ident_Int(8), Ident_Int(9)));
when 8 =>
My_Proc (R'(Ident_Int(0), Ident_Int(1), Ident_Int(2), Ident_Int(3), Ident_Int(4), Ident_Int(5), Ident_Int(6), Ident_Int(7), Ident_Int(8), Ident_Int(9)));
when 9 =>
My_Proc (R'(Ident_Int(0), Ident_Int(1), Ident_Int(2), Ident_Int(3), Ident_Int(4), Ident_Int(5), Ident_Int(6), Ident_Int(7), Ident_Int(8), Ident_Int(9)));
when others =>
null;
end case;
 
end Stack_Usage1;
 
-- { dg-final { scan-stack-usage "\t\[0-9\]\[0-9\]\t" { target i?86-*-* x86_64-*-* } } }
-- { dg-final { cleanup-stack-usage } }
/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;
/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;
/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;
/testsuite/gnat.dg/loop_optimization10.adb
0,0 → 1,18
-- { dg-do compile }
-- { dg-options "-O3" }
-- { dg-options "-O3 -msse2" { target i?86-*-* x86_64-*-* } }
 
package body Loop_Optimization10 is
 
function F (Low, High : in Array_Real_Type) return Array_Limit_Type is
Result : Array_Limit_Type;
begin
for I in Result'Range
loop
Result (I) := F (Low (I), High (I));
end loop;
return Result;
end;
 
end Loop_Optimization10;
 
/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;
/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;
/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;
/testsuite/gnat.dg/array17.adb
0,0 → 1,11
-- { dg-do compile }
 
with Array17_Pkg; use Array17_Pkg;
 
procedure Array17 is
X : aliased Varray := (1 .. 8 => 1.0);
Y : Varray (1 .. 8) := (others => -1.0);
R : Varray (1 .. 8);
begin
R (1 .. 4) := Y (1 .. 4) + X (1 .. 4);
end;
/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;
/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;
/testsuite/gnat.dg/discr34_pkg.ads
0,0 → 1,16
package Discr34_Pkg is
 
function N return Natural;
 
type Enum is (One, Two);
 
type Rec (D : Enum := One) is record
case D is
when One => S : String (1 .. N);
when Two => null;
end case;
end record;
 
function F return Rec;
 
end Discr34_Pkg;
/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;
/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;
/testsuite/gnat.dg/loop_optimization10.ads
0,0 → 1,11
with Loop_Optimization10_Pkg; use Loop_Optimization10_Pkg;
package Loop_Optimization10 is
 
type Dual_Axis_Type is (One, Two);
 
type Array_Real_Type is array (Dual_Axis_Type) of Float;
type Array_Limit_Type is array (Dual_Axis_Type) of Limit_Type;
 
function F (Low, High : in Array_Real_Type) return Array_Limit_Type;
 
end Loop_Optimization10;
/testsuite/gnat.dg/volatile10_pkg.ads
0,0 → 1,29
package Volatile10_Pkg is
 
type Num is mod 2**9;
 
type Rec is record
B1 : Boolean;
N1 : Num;
B2 : Boolean;
N2 : Num;
B3 : Boolean;
B4 : Boolean;
B5 : Boolean;
B6 : Boolean;
B7 : Boolean;
B8 : Boolean;
B9 : Boolean;
B10 : Boolean;
B11 : Boolean;
B12 : Boolean;
B13 : Boolean;
B14 : Boolean;
end record;
pragma Pack (Rec);
for Rec'Size use 32;
pragma Volatile(Rec);
 
function F return Rec;
 
end Volatile10_Pkg;
/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" } }
/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;
/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;
/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;
 
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
 
/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;
/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;
/testsuite/gnat.dg/specs/fe_inlining_helper.adb
0,0 → 1,4
procedure FE_Inlining_Helper is
begin
null;
end FE_Inlining_Helper;
/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;
/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;
/testsuite/gnat.dg/specs/cond_expr1.ads
0,0 → 1,9
-- { dg-do compile }
-- { dg-options "-gnat12 -gnato" }
 
package Cond_Expr1 is
 
function Tail (S : String) return String is
(if S'Last <= S'First then "" else S (S'First + 1 .. S'Last));
 
end Cond_Expr1;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/specs/fe_inlining_helper.ads
0,0 → 1,3
-- { dg-excess-errors "no code generated" }
generic
procedure FE_Inlining_Helper;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/specs/elab2.ads
0,0 → 1,20
-- { dg-do compile }
 
with Elab2_Pkg; use Elab2_Pkg;
 
package Elab2 is
 
type Num is (One, Two);
 
type Rec2 (D : Index_Type := 0) is record
Data : Rec1(D);
end record;
 
type Rec3 (D : Num) is record
case D is
when One => R : Rec2;
when others => null;
end case;
end record;
 
end Elab2;
/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;
/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;
/testsuite/gnat.dg/specs/elab3.ads
0,0 → 1,16
-- { dg-do compile }
 
pragma Restrictions(No_Elaboration_Code);
 
package Elab3 is
 
type T_List is array (Positive range <>) of Integer;
type T_List_Access is access constant T_List;
 
type R is record
A : T_List_Access;
end record;
 
C : constant R := (A => null);
 
end Elab3;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/specs/private1.ads
0,0 → 1,5
package Private1 is
type T is private;
private
type T is new Boolean;
end Private1;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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);
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/specs/unchecked_union1.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_Union1 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_Union1;
/testsuite/gnat.dg/specs/unchecked_union2.ads
0,0 → 1,30
-- { dg-do compile }
 
package Unchecked_Union2 is
 
type Small_Int is range 0 .. 2**19 - 1;
 
type R1 (B : Boolean := True) is record
case B is
when True => Data1 : Small_Int;
when False => Data2 : Small_Int;
end case;
end record;
 
for R1 use record
Data1 at 0 range 0 .. 18;
Data2 at 0 range 0 .. 18;
end record;
for R1'Size use 24;
 
pragma Unchecked_Union (R1);
 
type R2 is record
Data : R1;
end record;
 
for R2 use record
Data at 0 range 3 .. 26;
end record;
 
end Unchecked_Union2;
/testsuite/gnat.dg/specs/discr1.ads
0,0 → 1,10
-- { dg-do compile }
-- { dg-options "-gnatct" }
 
with Discr1_Pkg; use Discr1_Pkg;
 
package Discr1 is
 
procedure Proc (V : Variable_String_Array);
 
end Discr1;
/testsuite/gnat.dg/specs/elab2_pkg.ads
0,0 → 1,18
-- { dg-excess-errors "no code generated" }
 
package Elab2_Pkg is
 
function Get_Value (S : String) return Integer;
 
Max_Limit : constant array(1..2) of Integer :=
(1 => Get_Value ("One"), 2 => Get_Value ("Two"));
 
type Index_Type is new Natural range 0 .. Max_Limit(1);
 
type Array_Type is array (Index_Type range <>) of Natural;
 
type Rec1(D : Index_Type) is record
A : Array_Type(1 .. D);
end record;
 
end Elab2_Pkg;
/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" } }
/testsuite/gnat.dg/specs/atomic1.ads
0,0 → 1,16
-- { dg-do compile }
 
package Atomic1 is
 
type Arr is array (Integer range <>) of Boolean;
type UA is access all Arr;
 
U : UA;
pragma Atomic (U); -- { dg-error "atomic access" }
 
type R is record
U : UA;
pragma Atomic (U); -- { dg-error "atomic access" }
end record;
 
end Atomic1;
/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;
/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;
/testsuite/gnat.dg/specs/loop_optimization1.ads
0,0 → 1,14
-- { dg-do compile }
-- { dg-options "-O3" }
 
with Loop_Optimization1_Pkg;
 
package Loop_Optimization1 is
 
type Kind_Type is (One, Two, Three, Four);
type Array_Type is array (Kind_Type) of Boolean;
pragma Pack (Array_Type);
 
package Q is new Loop_Optimization1_Pkg (Boolean, Kind_Type, Array_Type);
 
end Loop_Optimization1;
/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;
/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;
/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;
/testsuite/gnat.dg/specs/aggr2.ads
0,0 → 1,14
-- { dg-do compile }
 
package Aggr2 is
 
type Buffer is array (Positive range <>) of Boolean;
for Buffer'Alignment use 4;
 
type Buffer_Ptr is access Buffer;
 
subtype My_Buffer is Buffer (1 .. 2);
 
P : Buffer_Ptr := new My_Buffer'(Others => False);
 
end Aggr2;
/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;
/testsuite/gnat.dg/specs/aggr3.ads
0,0 → 1,18
-- { dg-do compile }
 
with Aggr3_Pkg; use Aggr3_Pkg;
 
package Aggr3 is
 
type Enum is (One);
 
type R (D : Enum := One) is
record
case D is
when One => The_T : T;
end case;
end record;
 
My_R : R := (D => One, The_T => My_T);
 
end Aggr3;
/testsuite/gnat.dg/specs/aggr4.ads
0,0 → 1,9
-- { dg-do compile }
 
with Aggr4_Pkg; use Aggr4_Pkg;
 
package Aggr4 is
 
C : constant Rec3 := (Data => (D => One, Value => Zero));
 
end Aggr4;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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" } }
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/specs/loop_optimization1_pkg.adb
0,0 → 1,16
package body Loop_Optimization1_Pkg is
 
type Unconstrained_Array_Type
is array (Index_Type range <>) of Element_Type;
 
procedure Local (UA : in out Unconstrained_Array_Type) is
begin
null;
end;
 
procedure Proc (CA : in out Constrained_Array_Type) is
begin
Local (Unconstrained_Array_Type (CA));
end;
 
end Loop_Optimization1_Pkg;
/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;
/testsuite/gnat.dg/specs/private1-sub.ads
0,0 → 1,13
-- { dg-do compile }
-- { dg-options "-gnatct" }
 
package Private1.Sub is
 
package Nested is
type T is limited private;
function "=" (X, Y : T) return Boolean;
private
type T is new Private1.T;
end Nested;
 
end Private1.Sub;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/specs/discr1_pkg.ads
0,0 → 1,14
package Discr1_Pkg is
 
Maximum_Length : Natural := 80 ;
 
subtype String_Length is Natural range 0 .. Maximum_Length;
 
type Variable_String (Length : String_Length := 0) is
record
S : String (1 .. Length);
end record;
 
type Variable_String_Array is array (Natural range <>) of Variable_String;
 
end Discr1_Pkg;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/specs/loop_optimization1_pkg.ads
0,0 → 1,13
-- { dg-excess-errors "no code generated" }
 
generic
 
type Element_Type is private;
type Index_Type is (<>);
type Constrained_Array_Type is array (Index_Type) of Element_Type;
 
package Loop_Optimization1_Pkg is
 
procedure Proc (CA : in out Constrained_Array_Type);
 
end Loop_Optimization1_Pkg;
/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;
/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;
/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;
/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;
/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;
 
/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;
/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;
/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;
/testsuite/gnat.dg/specs/aggr3_pkg.ads
0,0 → 1,9
package Aggr3_Pkg is
 
type Root is abstract tagged null record;
 
type T is new Root with null record;
 
My_T : T;
 
end Aggr3_Pkg;
/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;
/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;
/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;
/testsuite/gnat.dg/specs/aggr4_pkg.ads
0,0 → 1,26
-- { dg-excess-errors "cannot generate code" }
 
package Aggr4_Pkg is
 
function F return Integer;
 
type Rec1 is tagged record
I : Integer;
end record;
 
Zero : constant Rec1 := (I => F);
 
type Enum is (One, Two);
 
type Rec2 (D : Enum := One) is record
case D is
when One => Value : Rec1;
when others => null;
end case;
end record;
 
type Rec3 is record
Data : Rec2;
end record;
 
end Aggr4_Pkg;
/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;
/testsuite/gnat.dg/specs/debug1.ads
0,0 → 1,14
-- { dg-do compile { target *-*-linux* } }
-- { dg-options "-gdwarf-2 -cargs -dA -margs" }
 
package Debug1 is
 
function N return Integer;
pragma Import (Ada, N);
 
type Arr is array (-N .. N) of Boolean;
A : Arr;
 
end Debug1;
 
-- { dg-final { scan-assembler-times "DW_AT_artificial" 8 } }
/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;
 
/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;
/testsuite/gnat.dg/aggr17.adb
0,0 → 1,28
-- { dg-do compile }
-- { dg-options "-gnatws" }
 
procedure Aggr17 is
 
type Enum is (A, B);
 
type Rec (D : Enum := Enum'First) is record
case D is
when A => X : Integer;
when B => null;
end case;
end record;
for Rec'Size use 128;
pragma Volatile (Rec);
 
type Config_T (D : Enum := Enum'First) is record
N : Natural;
R : Rec (D);
end record;
 
C : constant Config_T := (D => A, N => 1, R => (D => A, X => 0));
 
type Arr is array (Natural range 1 .. C.N) of Boolean;
 
begin
null;
end;
/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;
/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;
/testsuite/gnat.dg/opt17.ads
0,0 → 1,7
package Opt17 is
 
subtype S is String (1 .. 5);
 
function Func return S;
 
end Opt17;
/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;
/testsuite/gnat.dg/atomic5.adb
0,0 → 1,20
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;
/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;
/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;
/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;
/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" } }
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
 
/testsuite/gnat.dg/discr28.adb
0,0 → 1,25
-- { dg-do compile }
 
package body Discr28 is
 
procedure Dummy (E : Rec) is
begin
null;
end;
 
function F return Rec is
begin
return Default_Rec;
end;
 
procedure Proc1 is
begin
Dummy (F);
end;
 
procedure Proc2 is
begin
Dummy (F);
end;
 
end Discr28;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/atomic5.ads
0,0 → 1,25
-- { dg-do compile }
 
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;
/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;
/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;
/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;
/testsuite/gnat.dg/vect2.adb
0,0 → 1,128
-- { dg-do compile { target i?86-*-* x86_64-*-* } }
-- { dg-options "-O3 -msse2 -fdump-tree-vect-details" }
 
package body Vect2 is
 
function "+" (X, Y : Varray) return Varray is
R : Varray (X'Range);
begin
for I in X'Range loop
R(I) := X(I) + Y(I);
end loop;
return R;
end;
 
procedure Add (X, Y : Varray; R : out Varray) is
begin
for I in X'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
procedure Add (X, Y : not null access Varray; R : not null access Varray) is
begin
for I in X'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
 
function "+" (X, Y : Sarray) return Sarray is
R : Sarray;
begin
for I in Sarray'Range loop
R(I) := X(I) + Y(I);
end loop;
return R;
end;
 
procedure Add (X, Y : Sarray; R : out Sarray) is
begin
for I in Sarray'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
procedure Add (X, Y : not null access Sarray; R : not null access Sarray) is
begin
for I in Sarray'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
 
function "+" (X, Y : Darray1) return Darray1 is
R : Darray1;
begin
for I in Darray1'Range loop
R(I) := X(I) + Y(I);
end loop;
return R;
end;
 
procedure Add (X, Y : Darray1; R : out Darray1) is
begin
for I in Darray1'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
procedure Add (X, Y : not null access Darray1; R : not null access Darray1) is
begin
for I in Darray1'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
 
function "+" (X, Y : Darray2) return Darray2 is
R : Darray2;
begin
for I in Darray2'Range loop
R(I) := X(I) + Y(I);
end loop;
return R;
end;
 
procedure Add (X, Y : Darray2; R : out Darray2) is
begin
for I in Darray2'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
procedure Add (X, Y : not null access Darray2; R : not null access Darray2) is
begin
for I in Darray2'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
 
function "+" (X, Y : Darray3) return Darray3 is
R : Darray3;
begin
for I in Darray3'Range loop
R(I) := X(I) + Y(I);
end loop;
return R;
end;
 
procedure Add (X, Y : Darray3; R : out Darray3) is
begin
for I in Darray3'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
procedure Add (X, Y : not null access Darray3; R : not null access Darray3) is
begin
for I in Darray3'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
end Vect2;
 
-- { dg-final { scan-tree-dump-times "vectorized 1 loops" 15 "vect" } }
-- { dg-final { cleanup-tree-dump "vect" } }
/testsuite/gnat.dg/lto5_pkg.adb
0,0 → 1,6
package body Lto5_Pkg is
procedure d (a : t) is
begin
null;
end;
end;
/testsuite/gnat.dg/profile_warning_p.ads
0,0 → 1,4
package profile_warning_p is
generic
procedure Proc;
end;
/testsuite/gnat.dg/loop_optimization6.ads
0,0 → 1,4
package Loop_Optimization6 is
A : Integer := 0;
procedure Main;
end Loop_Optimization6;
/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;
/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;
 
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/discr28.ads
0,0 → 1,19
with Discr28_Pkg;
 
package Discr28 is
 
type Enum is (One, Two);
 
type Rec (D : Enum := One) is record
case D is
when One => null;
when Two => S : String (1 .. Discr28_Pkg.N);
end case;
end record;
 
Default_Rec : constant Rec := (D => One);
 
procedure Proc1;
procedure Proc2;
 
end Discr28;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/limited_with2.adb
0,0 → 1,12
-- { dg-do compile }
 
with Limited_With2_Pkg2;
 
package body Limited_With2 is
 
function Func (Val : Rec1) return Limited_With2_Pkg1.Rec2 is
begin
return Val.F;
end;
 
end Limited_With2;
/testsuite/gnat.dg/vect2.ads
0,0 → 1,47
with Vect2_Pkg;
 
package Vect2 is
 
-- Unconstrained array types are vectorizable, possibly with special
-- help for the programmer
type Varray is array (Positive range <>) of Long_Float;
for Varray'Alignment use 16;
 
function "+" (X, Y : Varray) return Varray;
procedure Add (X, Y : Varray; R : out Varray);
procedure Add (X, Y : not null access Varray; R : not null access Varray);
 
 
-- Constrained array types are vectorizable
type Sarray is array (Positive(1) .. Positive(4)) of Long_Float;
for Sarray'Alignment use 16;
 
function "+" (X, Y : Sarray) return Sarray;
procedure Add (X, Y : Sarray; R : out Sarray);
procedure Add (X, Y : not null access Sarray; R : not null access Sarray);
 
 
type Darray1 is array (Positive(1) .. Vect2_Pkg.N) of Long_Float;
for Darray1'Alignment use 16;
 
function "+" (X, Y : Darray1) return Darray1;
procedure Add (X, Y : Darray1; R : out Darray1);
procedure Add (X, Y : not null access Darray1; R : not null access Darray1);
 
 
type Darray2 is array (Vect2_Pkg.K .. Positive(4)) of Long_Float;
for Darray2'Alignment use 16;
 
function "+" (X, Y : Darray2) return Darray2;
procedure Add (X, Y : Darray2; R : out Darray2);
procedure Add (X, Y : not null access Darray2; R : not null access Darray2);
 
 
type Darray3 is array (Vect2_Pkg.K .. Vect2_Pkg.N) of Long_Float;
for Darray3'Alignment use 16;
 
function "+" (X, Y : Darray3) return Darray3;
procedure Add (X, Y : Darray3; R : out Darray3);
procedure Add (X, Y : not null access Darray3; R : not null access Darray3);
 
end Vect2;
/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;
/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;
/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;
/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" } }
/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;
/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;
 
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/volatile10.adb
0,0 → 1,10
-- { dg-do compile }
 
with Volatile10_Pkg; use Volatile10_Pkg;
 
procedure Volatile10 is
N : Num;
begin
N := F.N1;
N := F.N2;
end;
/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;
/testsuite/gnat.dg/taft_type2.adb
0,0 → 1,22
-- { dg-do compile }
-- { dg-options "-g" }
 
with Taft_Type2_Pkg; use Taft_Type2_Pkg;
 
package body Taft_Type2 is
 
procedure Proc is
A : T;
 
function F return T is
My_T : T;
begin
My_T := Open;
return My_T;
end;
 
begin
A := F;
end;
 
end Taft_Type2;
/testsuite/gnat.dg/include.adb
0,0 → 1,4
-- { dg-do compile } */
-- { dg-options "-cargs -I -gnatws" }
 
-- { dg-error "search directory missing" "" { target *-*-* } 0 }
/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;
/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;
/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;
/testsuite/gnat.dg/limited_with2.ads
0,0 → 1,11
with Limited_With2_Pkg1;
 
package Limited_With2 is
 
type Rec1 is record
F : Limited_With2_Pkg1.Rec2;
end record;
 
function Func (Val : Rec1) return Limited_With2_Pkg1.Rec2;
 
end Limited_With2;
/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;
/testsuite/gnat.dg/atomic6_6.adb
0,0 → 1,39
-- { dg-do compile }
-- { dg-options "-fdump-tree-gimple" }
 
with Atomic6_Pkg; use Atomic6_Pkg;
 
procedure Atomic6_6 is
Temp : Integer;
begin
 
Counter(1) := Counter(2);
 
Timer(1) := Timer(2);
 
Counter(1) := Int(Timer(1));
Timer(1) := Integer(Counter(1));
 
Temp := Integer(Counter(1));
Counter(1) := Int(Temp);
 
Temp := Timer(1);
Timer(1) := Temp;
 
end;
 
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__counter\\\[1" 2 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__counter\\\[2" 1 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__timer\\\[1" 2 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__timer\\\[2" 1 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&temp" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*ptr" 0 "gimple"} }
 
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__counter\\\[1" 3 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__counter\\\[2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__timer\\\[1" 3 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__timer\\\[2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&temp" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*ptr" 0 "gimple"} }
 
-- { dg-final { cleanup-tree-dump "gimple" } }
/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;
/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;
/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;
/testsuite/gnat.dg/env_compile_capacity.ads
0,0 → 1,14
package Env_Compile_Capacity is pragma Elaborate_Body; end;
/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;
/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;
/testsuite/gnat.dg/taft_type1_pkg1.adb
0,0 → 1,18
with Taft_Type1_Pkg2;
 
package body Taft_Type1_Pkg1 is
type TAMT1 is new Taft_Type1_Pkg2.Priv (X => 1);
type TAMT2 is new Taft_Type1_Pkg2.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 Taft_Type1_Pkg1;
/testsuite/gnat.dg/taft_type2.ads
0,0 → 1,5
package Taft_Type2 is
 
procedure Proc;
 
end Taft_Type2;
/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;
/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;
/testsuite/gnat.dg/vect1_pkg.ads
0,0 → 1,6
package Vect1_Pkg is
 
function K return Integer;
function N return Integer;
 
end Vect1_Pkg;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/vect5_pkg.ads
0,0 → 1,6
package Vect5_Pkg is
 
function K return Positive;
function N return Positive;
 
end Vect5_Pkg;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
 
/testsuite/gnat.dg/taft_type1_pkg1.ads
0,0 → 1,9
package Taft_Type1_Pkg1 is
procedure Check;
private
type TAMT1;
type TAMT1_Access is access TAMT1;
 
type TAMT2;
type TAMT2_Access is access TAMT2;
end Taft_Type1_Pkg1;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/array18.adb
0,0 → 1,9
-- { dg-do compile }
 
with Array18_Pkg; use Array18_Pkg;
 
procedure Array18 is
A : String (1 .. 1);
begin
A := F;
end;
/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;
/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;
 
/testsuite/gnat.dg/renaming1.ads
0,0 → 1,4
with Text_IO;
package renaming1 is
procedure Fo (A : Text_IO.File_Access);
end;
/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;
/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;
 
/testsuite/gnat.dg/taft_type2_pkg.ads
0,0 → 1,12
package Taft_Type2_Pkg is
 
type T is private;
 
function Open return T;
 
private
 
type Buffer_T;
type T is access Buffer_T;
 
end Taft_Type2_Pkg;
/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;
/testsuite/gnat.dg/volatile6.adb
0,0 → 1,20
-- { dg-do compile }
-- { dg-options "-O2 -fdump-tree-optimized" }
 
function Volatile6 return Integer is
 
type Vol is new Integer;
pragma Volatile (Vol);
 
V : Vol := 0;
 
begin
for J in 1 .. 10 loop
V := V + 1;
end loop;
 
return Integer (V);
end;
 
-- { dg-final { scan-tree-dump "goto" "optimized" } }
-- { dg-final { cleanup-tree-dump "optimized" } }
/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;
/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;
/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;
/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" } }
/testsuite/gnat.dg/opt18.adb
0,0 → 1,31
-- { dg-do compile }
-- { dg-options "-O3" }
 
with Opt18_Pkg; use Opt18_Pkg;
 
package body Opt18 is
 
function Mag (Item : in Cart_Vector_Type) return Float is
begin
return Sqrt (Item (X) * Item (X) + Item (Y) * Item (Y)
+ Item (Z) * Item (Z));
end;
 
function Unit_Quaternion_To_Mag_Axis (Quaternion : in Unit_Quaternion_Type)
return Mag_Axis_Type is
Sin_Half : Float
:= Mag (Cart_Vector_Type'(Quaternion.X, Quaternion.Y, Quaternion.Z));
begin
if Sin_Half > 3.0 * First_Order_Trig then
return
(Mag => Atan2 (Double_Trig (Unchecked_Trig_Pair (Sin_Half,
Quaternion.S))),
Axis => Unit_Vector_Type'(Quaternion.X / Sin_Half,
Quaternion.Y / Sin_Half,
Quaternion.Z / Sin_Half));
else
return (0.0, X_Unit);
end if;
end;
 
end Opt18;
/testsuite/gnat.dg/stack_usage1_pkg.adb
0,0 → 1,13
package body Stack_Usage1_Pkg is
 
function Ident_Int (X : Integer) return Integer is
begin
return X;
end Ident_Int;
 
procedure My_Proc (X : R) is
begin
null;
end My_Proc;
 
end Stack_Usage1_Pkg;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/assert.ads
0,0 → 1,5
package Assert is
 
procedure Assert (Condition : Boolean);
 
end Assert;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/aggr18.adb
0,0 → 1,28
-- { dg-do compile }
-- { dg-options "-gnatws" }
 
procedure Aggr18 is
 
type Enum is (A, B);
 
type Rec (D : Enum := Enum'First) is record
case D is
when A => X : Integer;
when B => null;
end case;
end record;
for Rec'Size use 128;
pragma Volatile (Rec);
 
type Config_T (D : Enum := Enum'First) is record
N : Natural;
R : Rec (D);
end record;
 
C : Config_T := (D => A, N => 1, R => (D => A, X => 0));
 
type Arr is array (Natural range 1 .. C.N) of Boolean;
 
begin
null;
end;
/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;
/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;
/testsuite/gnat.dg/opt18.ads
0,0 → 1,29
package Opt18 is
 
type Cart_Axis_Type is (X, Y, Z);
 
type Cart_Vector_Type is array (Cart_Axis_Type) of Float;
 
function Mag (Item : in Cart_Vector_Type) return Float;
 
type Unit_Vector_Type is array (Cart_Axis_Type) of Float;
 
type Mag_Axis_Type is
record
Mag : Float;
Axis : Unit_Vector_Type;
end record;
 
type Unit_Quaternion_Type is record
X : Float;
Y : Float;
Z : Float;
S : Float;
end record;
 
function Unit_Quaternion_To_Mag_Axis (Quaternion : in Unit_Quaternion_Type)
return Mag_Axis_Type;
 
X_Unit : constant Unit_Vector_Type := (1.0, 0.0, 0.0);
 
end Opt18;
/testsuite/gnat.dg/stack_usage1_pkg.ads
0,0 → 1,12
package Stack_Usage1_Pkg is
 
function Ident_Int (X : Integer) return Integer;
 
type R is
record
C0, C1, C2, C3, C4, C5, C6, C7, C8, C9 : Integer;
end record;
 
procedure My_Proc (X : R);
 
end Stack_Usage1_Pkg;
/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;
/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 ;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/discr29.adb
0,0 → 1,8
package body Discr29 is
 
procedure Proc (R : out Rec3) is
begin
R := (False, Tmp);
end;
 
end Discr29;
/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;
/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;
/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;
/testsuite/gnat.dg/vect3.adb
0,0 → 1,128
-- { dg-do compile { target i?86-*-* x86_64-*-* } }
-- { dg-options "-O3 -msse2 -fdump-tree-vect-details" }
 
package body Vect3 is
 
function "+" (X, Y : Varray) return Varray is
R : Varray (X'Range);
begin
for I in X'Range loop
R(I) := X(I) + Y(I);
end loop;
return R;
end;
 
procedure Add (X, Y : Varray; R : out Varray) is
begin
for I in X'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
procedure Add (X, Y : not null access Varray; R : not null access Varray) is
begin
for I in X'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
 
function "+" (X, Y : Sarray) return Sarray is
R : Sarray;
begin
for I in Sarray'Range loop
R(I) := X(I) + Y(I);
end loop;
return R;
end;
 
procedure Add (X, Y : Sarray; R : out Sarray) is
begin
for I in Sarray'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
procedure Add (X, Y : not null access Sarray; R : not null access Sarray) is
begin
for I in Sarray'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
 
function "+" (X, Y : Darray1) return Darray1 is
R : Darray1;
begin
for I in Darray1'Range loop
R(I) := X(I) + Y(I);
end loop;
return R;
end;
 
procedure Add (X, Y : Darray1; R : out Darray1) is
begin
for I in Darray1'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
procedure Add (X, Y : not null access Darray1; R : not null access Darray1) is
begin
for I in Darray1'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
 
function "+" (X, Y : Darray2) return Darray2 is
R : Darray2;
begin
for I in Darray2'Range loop
R(I) := X(I) + Y(I);
end loop;
return R;
end;
 
procedure Add (X, Y : Darray2; R : out Darray2) is
begin
for I in Darray2'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
procedure Add (X, Y : not null access Darray2; R : not null access Darray2) is
begin
for I in Darray2'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
 
function "+" (X, Y : Darray3) return Darray3 is
R : Darray3;
begin
for I in Darray3'Range loop
R(I) := X(I) + Y(I);
end loop;
return R;
end;
 
procedure Add (X, Y : Darray3; R : out Darray3) is
begin
for I in Darray3'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
procedure Add (X, Y : not null access Darray3; R : not null access Darray3) is
begin
for I in Darray3'Range loop
R(I) := X(I) + Y(I);
end loop;
end;
 
end Vect3;
 
-- { dg-final { scan-tree-dump-times "vectorized 1 loops" 15 "vect" } }
-- { dg-final { cleanup-tree-dump "vect" } }
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/discr21.ads
0,0 → 1,5
package Discr21 is
 
procedure Test;
 
end Discr21;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/discr29.ads
0,0 → 1,27
-- { dg-do compile }
 
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;
/testsuite/gnat.dg/view_conversion1.adb
0,0 → 1,45
-- { dg-do run }
-- { dg-options "-gnatws" }
 
procedure View_Conversion1 is
 
type Matrix is array (Integer range <>, Integer range <>) of Float;
 
S1 : Matrix (-3 .. -2, 2 .. 3) := ((2.0, -1.0), (-1.0, 2.0));
S2 : Matrix (1 .. 2, 1 .. 2) := S1;
S3 : Matrix (2 .. 3, -3 .. -2);
S4 : Matrix (1 .. 2, 1 .. 2);
 
function Normal_Last (A : Matrix; N : Natural) return Boolean is
begin
if A'Last (1) = N and then A'Last (2) = N then
return True;
else
return False;
end if;
end;
 
procedure Transpose (A : Matrix; B : out Matrix) is
N : constant Natural := A'Length (1);
subtype Normal_Matrix is Matrix (1 .. N, 1 .. N);
begin
if not Normal_Last (A, N) or else not Normal_Last (B, N) then
Transpose (Normal_Matrix (A), Normal_Matrix (B));
return;
end if;
 
for J in 1 .. N loop
for K in 1 .. N loop
B (J, K) := A (K, J);
end loop;
end loop;
end;
 
begin
Transpose (S1, S3);
Transpose (S3, S4);
 
if S4 /= S2 then
raise Program_Error;
end if;
end;
/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;
/testsuite/gnat.dg/unchecked_convert8.ads
0,0 → 1,5
package Unchecked_Convert8 is
 
procedure Dummy;
 
end Unchecked_Convert8;
/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;
/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;
/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;
/testsuite/gnat.dg/limited_with3.adb
0,0 → 1,9
-- { dg-do compile }
 
with Limited_With3_Pkg3;
 
package body Limited_With3 is
 
procedure Dummy is begin null; end;
 
end Limited_With3;
/testsuite/gnat.dg/vect3.ads
0,0 → 1,48
with Vect3_Pkg;
 
package Vect3 is
 
-- Unconstrained array types are vectorizable, possibly with special
-- help for the programmer
type Varray is array (Vect3_Pkg.Index_Type range <>) of Long_Float;
for Varray'Alignment use 16;
 
function "+" (X, Y : Varray) return Varray;
procedure Add (X, Y : Varray; R : out Varray);
procedure Add (X, Y : not null access Varray; R : not null access Varray);
 
 
-- Constrained array types are vectorizable
type Sarray is array (Vect3_Pkg.Index_Type(1) .. Vect3_Pkg.Index_Type(4))
of Long_Float;
for Sarray'Alignment use 16;
 
function "+" (X, Y : Sarray) return Sarray;
procedure Add (X, Y : Sarray; R : out Sarray);
procedure Add (X, Y : not null access Sarray; R : not null access Sarray);
 
 
type Darray1 is array (Vect3_Pkg.Index_Type(1) .. Vect3_Pkg.N) of Long_Float;
for Darray1'Alignment use 16;
 
function "+" (X, Y : Darray1) return Darray1;
procedure Add (X, Y : Darray1; R : out Darray1);
procedure Add (X, Y : not null access Darray1; R : not null access Darray1);
 
 
type Darray2 is array (Vect3_Pkg.K .. Vect3_Pkg.Index_Type(4)) of Long_Float;
for Darray2'Alignment use 16;
 
function "+" (X, Y : Darray2) return Darray2;
procedure Add (X, Y : Darray2; R : out Darray2);
procedure Add (X, Y : not null access Darray2; R : not null access Darray2);
 
 
type Darray3 is array (Vect3_Pkg.K .. Vect3_Pkg.N) of Long_Float;
for Darray3'Alignment use 16;
 
function "+" (X, Y : Darray3) return Darray3;
procedure Add (X, Y : Darray3; R : out Darray3);
procedure Add (X, Y : not null access Darray3; R : not null access Darray3);
 
end Vect3;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/opt22_pkg.adb
0,0 → 1,15
package body Opt22_Pkg is
 
procedure Fail is
begin
raise Constraint_Error;
end;
 
procedure Put (S : String) is
begin
if S /= "the message" then
raise Program_Error;
end if;
end;
 
end Opt22_Pkg;
/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;
/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" } }
/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;
/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;
/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;
/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;
/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;
/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;
/testsuite/gnat.dg/taft_type3.adb
0,0 → 1,29
-- { dg-do compile }
-- { dg-options "-g" }
 
with Taft_Type3_Pkg; use Taft_Type3_Pkg;
 
procedure Taft_Type3 is
 
subtype S is String (1..32);
 
Empty : constant S := (others => ' ');
 
procedure Proc (Data : in out T) is begin null; end;
 
task type Task_T is
entry Send (Data : in out T);
end;
 
task body Task_T is
type List_T is array (1 .. 4) of S;
L : List_T := (others => Empty);
begin
accept Send (Data : in out T) do
Proc (Data);
end;
end;
 
begin
null;
end;
/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;
/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;
/testsuite/gnat.dg/limited_with3.ads
0,0 → 1,17
with Limited_With3_Pkg1;
with Limited_With3_Pkg2;
limited with Limited_With3_Pkg3;
 
package Limited_With3 is
 
procedure Dummy;
 
type T is tagged private;
 
private
 
package My_Q is new Limited_With3_Pkg1 (Limited_With3_Pkg2.T);
 
type T is tagged null record;
 
end Limited_With3;
/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;
/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;
/testsuite/gnat.dg/atomic6_7.adb
0,0 → 1,40
-- { dg-do compile }
-- { dg-options "-fdump-tree-gimple" }
 
with Atomic6_Pkg; use Atomic6_Pkg;
 
procedure Atomic6_7 is
My_Atomic : R;
Temp : Integer;
begin
 
My_Atomic.Counter1 := Counter2;
 
My_Atomic.Timer1 := Timer2;
 
My_Atomic.Counter1 := Int(My_Atomic.Timer1);
My_Atomic.Timer1 := Integer(My_Atomic.Counter1);
 
Temp := Integer(My_Atomic.Counter1);
My_Atomic.Counter1 := Int(Temp);
 
Temp := My_Atomic.Timer1;
My_Atomic.Timer1 := Temp;
 
end;
 
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&my_atomic.counter1" 2 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__counter2" 1 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&my_atomic.timer1" 2 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&atomic6_pkg__timer2" 1 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*&temp" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_load\[^\n\r\]*ptr" 0 "gimple"} }
 
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&my_atomic.counter1" 3 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__counter2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&my_atomic.timer1" 3 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&atomic6_pkg__timer2" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*&temp" 0 "gimple"} }
-- { dg-final { scan-tree-dump-times "atomic_store\[^\n\r\]*ptr" 0 "gimple"} }
 
-- { dg-final { cleanup-tree-dump "gimple" } }
/testsuite/gnat.dg/opt22_pkg.ads
0,0 → 1,7
package Opt22_Pkg is
 
procedure Fail;
 
procedure Put (S : String);
 
end Opt22_Pkg;
/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;
/testsuite/gnat.dg/sort1.ads
0,0 → 1,2
function sort1 (S : String) return String;
pragma Pure (sort1);

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.