OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

Compare Revisions

  • This comparison shows the changes necessary to convert path 
    /openrisc/tags/gnu-src/gcc-4.5.1/gcc-4.5.1-or32-1.0rc1/gcc/testsuite/gnat.dg
    from Rev 304 to Rev 338
    ↔ Reverse comparison
  •

Rev 304 → Rev 338

/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;
/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;
/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;
/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;
/elim1.adb
0,0 → 1,6
package body elim1 is
procedure d (a : t) is
begin
null;
end;
end;
/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;
 
 
/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;
/controlled4.ads
0,0 → 1,5
 
with controlled3; use controlled3;
package controlled4 is
procedure Test_Suite;
end;
/frame_overflow.adb
0,0 → 1,34
-- { dg-do compile }
 
with System;
 
procedure 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 -- { dg-error "too large" }
Set_In (Bitmap : Bitmap_T; Bitpos : Bitpos_Range_T) return Bitmap_T
is
Result: Bitmap_T := Bitmap; -- { dg-error "Storage_Error" }
begin
Result.Bits (Bitpos) := True;
return Result;
end;
 
function Negate (Bitmap : Bitmap_T) return Bitmap_T is
Result: Bitmap_T; -- { dg-error "Storage_Error" }
begin
for E in Bitpos_Range_T loop
Result.Bits (E) := not Bitmap.Bits (E);
end loop;
return Result;
end;
 
begin
null;
end;
/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;
/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 will be raised" }
 
begin
null;
end;
/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;
/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;
 
/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;
/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;
 
 
/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;
/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;
/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;
/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;
/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;
/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;
/elim1.ads
0,0 → 1,5
pragma Eliminate (p, d);
package elim1 is
type t is tagged null record;
procedure d (a : t);
end;
/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 will be raised" }
 
begin
Obj(1) := True;
Proc (Obj(1));
end;
/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;
/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;
/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;
/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;
/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;
/loop_unchecked_conversion.ads
0,0 → 1,5
package loop_unchecked_conversion is
 
procedure slice;
 
end loop_unchecked_conversion;
/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;
/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;
/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;
/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;
/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;
/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; -- { dg-warning "may be used uninitialized" }
begin
if A then
C := False;
elsif B then
C := True;
end if;
return C;
end;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/tamdt_aux.ads
0,0 → 1,9
 
package Tamdt_Aux is
type Priv (X : Integer) is private;
private
type Priv (X : Integer) is null record;
end;
 
 
 
/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;
/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;
/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;
/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;
/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;
/oalign1.ads
0,0 → 1,5
 
package Oalign1 is
Klunk1 : Integer := 12;
for Klunk1'Alignment use Standard'Maximum_Alignment;
end;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/array7.adb
0,0 → 1,22
-- { 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" } }
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/addr1.ads
0,0 → 1,5
-- { dg-do compile }
 
package addr1 is
pragma Elaborate_Body;
end;
/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;
/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;
/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;
/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;
/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;
/decl_ctx_def.ads
0,0 → 1,4
 
package DECL_CTX_Def is
X : exception;
end;
/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;
/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;
/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;
/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;
/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;
/elim2.adb
0,0 → 1,7
-- { dg-do run }
 
with elim1;
procedure elim2 is
begin
null;
end;
/tamdt.adb
0,0 → 1,19
 
with Tamdt_Aux;
 
package body TAMDT is
type TAMT1 is new Tamdt_Aux.Priv (X => 1);
type TAMT2 is new Tamdt_Aux.Priv;
 
procedure Check is
Ptr1 : TAMT1_Access := new TAMT1;
Ptr2 : TAMT2_Access := new TAMT2 (X => 2);
begin
if Ptr1.all.X /= 1 then
raise Program_Error;
end if;
if Ptr2.all.X /= 2 then
raise Program_Error;
end if;
end;
end;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/tamdt.ads
0,0 → 1,10
 
package TAMDT is
procedure Check;
private
type TAMT1;
type TAMT1_Access is access TAMT1;
 
type TAMT2;
type TAMT2_Access is access TAMT2;
end;
/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;
/incomplete1.ads
0,0 → 1,3
package Incomplete1 is
type T is null record;
end Incomplete1;
/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;
/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;
/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;
/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;
/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;
/test_tamdt.adb
0,0 → 1,8
-- { dg-do run }
 
with Tamdt;
 
procedure Test_Tamdt is
begin
Tamdt.Check;
end;
/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;
/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;
/concat1_pkg.ads
0,0 → 1,5
package Concat1_Pkg is
 
function Ident (I : Integer) return Integer;
 
end Concat1_Pkg;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/oalign2.ads
0,0 → 1,5
 
package Oalign2 is
Klunk2 : Integer := 12;
for Klunk2'Alignment use Standard'Maximum_Alignment;
end;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
 
 
 
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/incomplete2.adb
0,0 → 1,4
-- { dg-do compile }
-- { dg-excess-errors "instantiation abandoned" }
with Incomplete1;
package body Incomplete2 is end Incomplete2;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/slice8_pkg1.ads
0,0 → 1,3
with Slice8_Pkg2;
 
package Slice8_Pkg1 is new Slice8_Pkg2 (Line_Length => 132, Max_Lines => 1000);
/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;
/atomic1.adb
0,0 → 1,17
-- { 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"} }
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
 
/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;
/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;
/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;
/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;
/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;
/aggr9.ads
0,0 → 1,7
with Aggr9_Pkg; use Aggr9_Pkg;
 
package Aggr9 is
 
procedure Proc (X : R1);
 
end Aggr9;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/boolean_expr1.ads
0,0 → 1,5
package Boolean_Expr1 is
 
function S (V : in Long_Float) return String;
 
end Boolean_Expr1;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/sse_nolib.adb
0,0 → 1,50
-- { dg-do run { target i?86-*-* x86_64-*-* } }
-- { dg-options "-O1 -msse" }
-- { dg-require-effective-target sse }
 
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;
/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;
/decl_ctx_use.ads
0,0 → 1,5
 
package DECL_CTX_Use is
procedure Check_1;
procedure Check_2;
end;
/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;
/profile_warning.adb
0,0 → 1,4
-- { dg-do compile }
 
package body profile_warning is
end;
/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;
/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;
/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;
/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;
/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;
/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;
/old_errors.ads
0,0 → 1,5
package Old_Errors is
 
pragma Elaborate_Body;
 
end Old_Errors;
/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;
/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;
/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;
 
/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;
/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;
/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;
/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;
/raise_ce.adb
0,0 → 1,4
procedure Raise_CE is
begin
raise Constraint_Error;
end;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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
/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;
/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;
/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;
/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;
 
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
 
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/noreturn1.adb
0,0 → 1,15
-- { dg-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;
/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;
/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;
/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;
/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;
/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;
/nested_subtype_byref.ads
0,0 → 1,4
 
package Nested_Subtype_Byref is
procedure Check;
end;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
 
 
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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" } }
/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" } }
/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;
/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;
/opt3_pkg.ads
0,0 → 1,5
package Opt3_Pkg is
 
procedure F (I : Short_Integer);
 
end Opt3_Pkg;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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" } }
/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;
/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;
/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;
/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;
/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;
/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;
/discr2.ads
0,0 → 1,5
package discr2 is
procedure Dummy;
 
end discr2;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
 
/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;
/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;
/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;
 
 
/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;
/discr8_pkg3.ads
0,0 → 1,3
package Discr8_Pkg3 is
function Value return Natural;
end Discr8_Pkg3;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/loop_optimization3_pkg.ads
0,0 → 1,5
package Loop_Optimization3_Pkg is
 
function F (n : Integer) return Integer;
 
end Loop_Optimization3_Pkg;
/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;
 
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
 
/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;
/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;
/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;
/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;
/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;
 
 
/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;
/bit_packed_array.adb
0,0 → 1,16
-- PR ada/33788
-- Origin: Oliver Kellogg <oliver.kellogg@eads.com>
 
-- { dg-do compile }
 
package body Bit_Packed_Array 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_Array;
/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;
/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;
/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;
/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;
/boolean_subtype.adb
0,0 → 1,42
-- { dg-do compile }
-- { dg-options "-O2" }
 
procedure boolean_subtype is
 
subtype Component_T is Boolean;
 
function Condition return Boolean is
begin
return True;
end;
 
V : Integer := 0;
 
function Component_Value return Integer is
begin
V := V + 1;
return V;
end;
 
Most_Significant : Component_T := False;
Least_Significant : Component_T := True;
 
begin
 
if Condition then
Most_Significant := True;
end if;
 
if Condition then
Least_Significant := Component_T'Val (Component_Value);
end if;
 
if Least_Significant < Most_Significant then
Least_Significant := Most_Significant;
end if;
 
if Least_Significant /= True then
raise Program_Error;
end if;
 
end;
/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;
/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;
/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;
/itypes.ads
0,0 → 1,4
 
package itypes is
procedure Proc;
end;
/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;
/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;
/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" } }
/bit_packed_array.ads
0,0 → 1,33
with Interfaces;
 
package Bit_Packed_Array 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_Array;
/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;
/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;
/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;
/inline_scope_p.ads
0,0 → 1,4
package inline_scope_p is
procedure Assert (Expr : Boolean; Str : String);
pragma Inline (Assert);
end;
/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;
/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;
/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;
/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;
/layered_abstraction_p.ads
0,0 → 1,6
generic
type T is private;
Obj : T;
package Layered_Abstraction_P is
Obj2 : T := Obj;
end;
/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;
/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;
/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;
/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;
 
/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;
/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;
 
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
 
 
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/deref1.ads
0,0 → 1,4
package deref1 is
type T is tagged limited null record;
procedure Op (Obj : in out T);
end deref1;
/discr12_pkg.ads
0,0 → 1,5
package Discr12_Pkg is
 
function Dummy (I : Integer) return Integer;
 
end Discr12_Pkg;
/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;
/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;
/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;
 
 
/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;
/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;
/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;
/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;
/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;
/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;
/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
/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;
/test_allocator_maxalign2.adb
0,0 → 1,8
-- { dg-do run }
 
with Allocator_Maxalign2;
 
procedure Test_Allocator_Maxalign2 is
begin
Allocator_Maxalign2.Check;
end;
/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;
/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;
 
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/anon1.ads
0,0 → 1,4
 
package anon1 is
function F return access Integer;
end anon1;
/null_pointer_deref1.adb
0,0 → 1,21
-- { dg-do run { target { ! "sparc*-sun-solaris2.11" } } }
-- { 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;
/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;
/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;
/controlled2.ads
0,0 → 1,5
 
with controlled1; use controlled1;
package controlled2 is
procedure Test_Suite;
end controlled2;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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" } }
/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;
/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;
 
/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;
/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;
/sizetype.adb
0,0 → 1,14
-- { dg-do run }
 
with Interfaces.C; use Interfaces.C;
 
procedure Sizetype 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;
/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;
/wide_pi.adb
0,0 → 1,9
-- { dg-do compile }
-- { dg-options "-gnatW8" }
 
with Ada.Numerics;
 
procedure wide_pi is
begin
null;
end;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
 
/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;
/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;
/specs/fe_inlining_helper.adb
0,0 → 1,4
procedure FE_Inlining_Helper is
begin
null;
end FE_Inlining_Helper;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/specs/fe_inlining_helper.ads
0,0 → 1,3
-- { dg-excess-errors "no code generated" }
generic
procedure FE_Inlining_Helper;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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);
/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;
/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;
/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;
/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" } }
/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;
/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;
/specs/unchecked_union.ads
0,0 → 1,20
-- PR ada/28591
-- Reported by Martin Michlmayr <tbm@cyrius.com>
 
-- { dg-do compile }
-- { dg-options "-g" }
 
with Interfaces; use Interfaces;
 
package Unchecked_Union is
type Mode_Type is (Mode_B2);
 
type Value_Union (Mode : Mode_Type := Mode_B2) is record
case Mode is
when Mode_B2 =>
B2 : Integer_32;
end case;
end record;
pragma Unchecked_Union (Value_Union);
 
end Unchecked_Union;
/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;
/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;
/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;
/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;
/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;
/specs/small_alignment.ads
0,0 → 1,13
-- { dg-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;
/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;
/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;
/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;
/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;
/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;
/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" } }
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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 .. 12);
 
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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
 
/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;
/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;
/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;
/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;
/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;
/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;
 
/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;
/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;
/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;
/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;
/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;
/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;
/loop_optimization6.adb
0,0 → 1,25
-- { 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"} }
/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;
/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;
/itype.ads
0,0 → 1,5
package itype is
generic
type T is private;
function G return not null access constant T;
end itype;
/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;
 
/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;
/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;
/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;
/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;
/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;
/profile_warning_p.ads
0,0 → 1,4
package profile_warning_p is
generic
procedure Proc;
end;
/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;
/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;
/loop_optimization6.ads
0,0 → 1,4
package Loop_Optimization6 is
A : Integer := 0;
procedure Main;
end Loop_Optimization6;
/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;
 
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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" } }
/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;
 
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/env_compile_capacity.ads
0,0 → 1,9
package Env_Compile_Capacity is pragma Elaborate_Body; end;
/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;
/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;
/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;
/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;
/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;
/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;
/const1.adb
0,0 → 1,8
-- { dg-do compile }
 
procedure const1 is
Def_Const : constant Integer;
pragma Import (Ada, Def_Const);
begin
null;
end const1;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
 
/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;
/interface5.adb
0,0 → 1,7
-- { dg-do compile }
package body interface5 is
function F (Object : Child) return access Child is
begin
return null;
end F;
end interface5;
/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;
/elab2.adb
0,0 → 1,10
-- { dg-do compile }
-- { dg-options "-gnatws" }
 
with elab1;
 
procedure elab2 is
A : elab1.My_Rec;
begin
null;
end;
/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;
/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;
/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;
 
/renaming1.ads
0,0 → 1,4
with Text_IO;
package renaming1 is
procedure Fo (A : Text_IO.File_Access);
end;
/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;
/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;
/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;
/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;
/pack9.adb
0,0 → 1,18
-- { dg-do compile }
-- { dg-options "-O2 -gnatp -cargs -fdump-tree-optimized" }
 
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" } }
/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;
/import1.ads
0,0 → 1,7
package Import1 is
 
type Arr is array (Positive range <>) of Integer;
 
procedure Create (Bounds : Arr);
 
end Import1;
/class_wide.adb
0,0 → 1,26
-- { dg-do compile }
 
procedure class_wide 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;
/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;
/pack1.ads
0,0 → 1,7
package Pack1 is
package Nested is
type Rec_Typ is record
null;
end record;
end Nested;
end Pack1;
/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;
/assert.ads
0,0 → 1,5
package Assert is
 
procedure Assert (Condition : Boolean);
 
end Assert;
/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;
/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;
/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;
/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;
/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;
/not_null.adb
0,0 → 1,24
-- { 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");
pragma Warnings (Off, """Constraint_Error"" will be raised at run time");
package Inst_2 is new GPack (null);
pragma Warnings (On, "*null not allowed in null-excluding objects");
pragma Warnings (On, """Constraint_Error"" will be raised at run time");
begin
null;
end;
exception
when Constraint_Error =>
null;
end not_null;
/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;
/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 ;
/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;
/loop_optimization7.adb
0,0 → 1,17
-- { dg-do compile }
-- { dg-options "-O3" }
-- { dg-options "-O3 -msse" { target i?86-*-* x86_64-*-* } }
-- { dg-require-effective-target sse }
 
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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/discr21.ads
0,0 → 1,5
package Discr21 is
 
procedure Test;
 
end Discr21;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/bug_elaboration_code.ads
0,0 → 1,8
package Bug_Elaboration_Code is
 
pragma Elaborate_Body;
 
I : Integer;
J : Integer;
 
end Bug_Elaboration_Code;
/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;
/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" } }
/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;
/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;
/misaligned_param_pkg.ads
0,0 → 1,5
package Misaligned_Param_Pkg is
 
pragma Elaborate_Body (Misaligned_Param_Pkg);
 
end Misaligned_Param_Pkg;
/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;
/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;
/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;
/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;
/sort1.ads
0,0 → 1,2
function sort1 (S : String) return String;
pragma Pure (sort1);
/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;

powered by: WebSVN 2.1.0

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