--- /dev/null
+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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+
+package aggr5 is
+ type Event is limited interface;
+ type Event_Access is access all Event'Class;
+ type Q_Action_Event is limited interface and Event;
+ function Build (X : integer) return Event_Access;
+end aggr5;
--- /dev/null
+-- { dg-do compile }
+
+with aggr5;
+procedure aggr6 is
+ procedure Block is
+ Wrapper : aliased aggr5.Q_Action_Event'Class
+ := aggr5.Q_Action_Event'Class (aggr5.Build (0));
+ begin
+ null;
+ end;
+begin
+ null;
+end;
--- /dev/null
+
+package anon1 is
+ function F return access Integer;
+end anon1;
--- /dev/null
+-- { dg-do compile }
+
+with anon1;
+procedure anon2 is
+begin
+ if anon1.F /= null then
+ null;
+ end if;
+end anon2;
--- /dev/null
+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;
--- /dev/null
+-- { dg-do compile }
+
+procedure equal_access is
+ PA, PB : access procedure := null;
+begin
+ if PA /= PB then
+ null;
+ end if;
+end;
--- /dev/null
+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;
--- /dev/null
+
+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;
--- /dev/null
+
+-- { dg-do compile }
+
+package body ref_type is
+ type T is tagged null record;
+ procedure Print (X : T) is
+ begin
+ null;
+ end;
+end ref_type;
--- /dev/null
+package ref_type is
+private
+ type T is tagged;
+ procedure Print (X : T);
+end ref_type;
--- /dev/null
+-- { dg-do compile }
+
+with Ada.Text_IO; use Ada.Text_IO;
+
+procedure Rep_Problem2 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 Rep_Problem2;
--- /dev/null
+-- { dg-do compile }
+
+with Deques;
+procedure Show_Deques_Priority is
+ use Deques;
+
+ PD : aliased P_Deque := Create;
+
+begin
+ PD.Pop;
+end Show_Deques_Priority;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
OSDN Git Service
