OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

Compare Revisions

  • This comparison shows the changes necessary to convert path 
    /openrisc/trunk/gnu-old/gcc-4.2.2/gcc/testsuite/gnat.dg
    from Rev 154 to Rev 816
    ↔ Reverse comparison
  •

Rev 154 → Rev 816

/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;
/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;
/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;
/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;
 
/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;
/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
/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;
/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;
/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;
 
/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;
/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;
 
 
/loop_unchecked_conversion.ads
0,0 → 1,5
package loop_unchecked_conversion is
 
procedure slice;
 
end loop_unchecked_conversion;
/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
/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;
/frame_overflow.adb
0,0 → 1,33
-- { dg-do compile }
 
procedure frame_overflow is
 
type Bitpos_Range_T is new Positive;
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;
begin
Result.Bits (Bitpos) := True;
return Result;
end;
 
function -- { dg-error "too large" "" }
Negate (Bitmap : Bitmap_T) return Bitmap_T is
Result: Bitmap_T;
begin
for E in Bitpos_Range_T loop
Result.Bits (E) := not Bitmap.Bits (E);
end loop;
return Result;
end;
 
begin
null;
end;
/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;
/assert.ads
0,0 → 1,5
package Assert is
 
procedure Assert (Condition : Boolean);
 
end Assert;
/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;
 
 
/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;
/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;
/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;
/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;
/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;
/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;
/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;
/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;
 
/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;
/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;
/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;
/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/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/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/double_record_extension1.ads
0,0 → 1,11
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,15
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;

powered by: WebSVN 2.1.0

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