--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
+
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { dg-do compile }
+
+package body Check1 is
+ function FD (X : access R) return P2 is
+ begin
+ return P2 (X.Disc);
+ end FD;
+end Check1;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+-- { 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;
--- /dev/null
+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;
+
--- /dev/null
+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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
+
--- /dev/null
+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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+ with System;
+ package NAT1 is
+ Nat_One_Storage : constant Natural := 1;
+ One_Address : constant System.Address := Nat_One_Storage'Address;
+ end;
--- /dev/null
+-- { 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;
+
--- /dev/null
+-- { 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;
+
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+-- { dg-do compile}
+-- { dg-options "-gnatwa" }
+
+with Text_IO;
+use Text_IO;
+use type Text_IO.File_Access;
+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;
--- /dev/null
+with Text_IO;
+package renaming1 is
+ procedure Fo (A : Text_IO.File_Access);
+end;
--- /dev/null
+-- { 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 Child'Class do
+ X_Local := O;
+ end return;
+ end X_Func;
+end return1;
--- /dev/null
+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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { dg-do compile }
+-- { dg-options "-g" }
+
+with debug1; use debug1;
+procedure test_debug1 is
+ Blob : Meta_Data;
+begin
+ null;
+end;
--- /dev/null
+-- { dg-do run }
+
+with Ada.Real_Time;
+
+procedure Test_Delay is
+begin
+ delay until Ada.Real_Time.Clock;
+end Test_Delay;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { dg-do compile }
+
+with ext1; use ext1;
+procedure test_ext1 is
+ X : Regular_Smiley;
+begin
+ X.Set_Mood;
+end;
--- /dev/null
+-- {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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+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;
--- /dev/null
+-- { 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;
+
--- /dev/null
+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;
projects / gcc.git / commitdiff