--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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 record
+ TA : Two_Alone (One'Access);
+ TI : Two_Iface (One'Access); -- OFFENDING LINE
+ TB : Two_Base (One'Access);
+ end record;
+
+begin
+ null;
+end;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { do-do run }
+-- { do-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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+package dispatch1_p is
+ type I1 is interface;
+ type DT_I1 is new I1 with null record;
+end;
--- /dev/null
+-- { do-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;
--- /dev/null
+package Env_Compile_Capacity is pragma Elaborate_Body; end;
--- /dev/null
+-- { 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;
--- /dev/null
+package body generic_dispatch_p is
+ function Constructor (I : not null access Integer) return DT is
+ R : DT;
+ begin
+ return R;
+ end Constructor;
+end;
--- /dev/null
+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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+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;
--- /dev/null
+-- { do-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;
--- /dev/null
+-- { do-do compile }
+-- { do-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;
--- /dev/null
+package body inline_scope_p is
+ procedure Assert (Expr : Boolean; Str : String) is
+ begin
+ if Expr then
+ null;
+ end if;
+ end Assert;
+end;
--- /dev/null
+package inline_scope_p is
+ procedure Assert (Expr : Boolean; Str : String);
+ pragma Inline (Assert);
+end;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+generic
+ type T is private;
+ Obj : T;
+package Layered_Abstraction_P is
+ Obj2 : T := Obj;
+end;
--- /dev/null
+-- { do-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;
--- /dev/null
+-- { 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;
--- /dev/null
+limited with Pack1;
+package limited_with is
+ procedure Print_2 (Obj : access Pack1.Nested.Rec_Typ);
+end limited_with;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+package Pack1 is
+ package Nested is
+ type Rec_Typ is record
+ null;
+ end record;
+ end Nested;
+end Pack1;
--- /dev/null
+-- { 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;
--- /dev/null
+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;
--- /dev/null
+-- { 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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+-- { dg-do compile }
+
+package abstract_limited is
+ type I is limited interface;
+ type T is abstract limited new I with null record;
+end;
--- /dev/null
+-- { 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;
+-- { dg-do compile }
+
package double_record_extension1 is
type T1(n: natural) is tagged record
+-- { dg-do compile }
+
package double_record_extension2 is
type Base_Message_Type (Num_Bytes : Positive) is tagged record
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+generic
+ type I is interface;
+ with procedure P (X : I) is abstract;
+package gen_interface_p is
+end;
-- { dg-do compile }
+-- { dg-options "-cargs -S -margs" }
package static_initializer is
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { dg-do compile }
+
+package body task_name is
+ task body Task_Object is
+ begin
+ null;
+ end Task_Object;
+end;
--- /dev/null
+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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+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;
--- /dev/null
+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 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;
--- /dev/null
+-- { do-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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { dg-do compile }
+-- { dg-options "-gnatW8" }
+
+with Ada.Numerics;
+
+procedure wide_pi is
+begin
+ null;
+end;
--- /dev/null
+-- { 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;
projects / thirdparty / gcc.git / commitdiff
