--- /dev/null
+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;
--- /dev/null
+-- { dg-do compile }
+
+package addr1 is
+ pragma Elaborate_Body;
+end;
--- /dev/null
+-- { 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;
--- /dev/null
+with SYSTEM;
+WITH array2; use array2;
+
+package array1 is
+
+ procedure Foo (R : RIC_TYPE);
+ procedure Start_Timer (Q : SYSTEM.ADDRESS);
+
+end array1;
--- /dev/null
+package array2 is
+
+ type RIC_TYPE is (RIC1, RIC2);
+ for RIC_TYPE'SIZE use 32;
+
+ function MAX return Integer;
+
+end array2;
--- /dev/null
+-- { 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;
--- /dev/null
+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;
--- /dev/null
+-- { 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;
--- /dev/null
+package discr2 is
+
+ procedure Dummy;
+
+end discr2;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+-- { dg-do compile }
+-- { dg-options "-gnatws" }
+
+with elab1;
+
+procedure elab2 is
+ A : elab1.My_Rec;
+begin
+ null;
+end;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { dg-do run }
+
+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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { dg-do compile }
+
+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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
--- /dev/null
+-- { 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;
projects / thirdparty / gcc.git / commitdiff
