URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c392013.a] - Rev 294
Go to most recent revision | Compare with Previous | Blame | View Log
-- C392013.A
--
-- Grant of Unlimited Rights
--
-- The Ada Conformity Assessment Authority (ACAA) holds unlimited
-- rights in the software and documentation contained herein. Unlimited
-- rights are the same as those granted by the U.S. Government for older
-- parts of the Ada Conformity Assessment Test Suite, and are defined
-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
-- intends to confer upon all recipients unlimited rights equal to those
-- held by the ACAA. These rights include rights to use, duplicate,
-- release or disclose the released technical data and computer software
-- in whole or in part, in any manner and for any purpose whatsoever, and
-- to have or permit others to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that the "/=" implicitly declared with the declaration of "=" for
-- a tagged type is legal and can be used in a dispatching call.
-- (Defect Report 8652/0010, as reflected in Technical Corrigendum 1).
--
-- CHANGE HISTORY:
-- 23 JAN 2001 PHL Initial version.
-- 16 MAR 2001 RLB Readied for release; added identity and negative
-- result cases.
-- 24 MAY 2001 RLB Corrected the result for the 9 vs. 9 case.
--!
with Report;
use Report;
procedure C392013 is
package P1 is
type T is tagged
record
C1 : Integer;
end record;
function "=" (L, R : T) return Boolean;
end P1;
package P2 is
type T is new P1.T with private;
function Make (Ancestor : P1.T; X : Float) return T;
private
type T is new P1.T with
record
C2 : Float;
end record;
function "=" (L, R : T) return Boolean;
end P2;
package P3 is
type T is new P2.T with
record
C3 : Character;
end record;
private
function "=" (L, R : T) return Boolean;
function Make (Ancestor : P1.T; X : Float) return T;
end P3;
package body P1 is separate;
package body P2 is separate;
package body P3 is separate;
type Cwat is access P1.T'Class;
type Cwat_Array is array (Positive range <>) of Cwat;
A : constant Cwat_Array :=
(1 => new P1.T'(C1 => Ident_Int (3)),
2 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (5)), X => 4.0)),
3 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (-5)), X => 4.2)),
4 => new P1.T'(C1 => Ident_Int (-3)),
5 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (5)), X => 3.6)),
6 => new P1.T'(C1 => Ident_Int (4)),
7 => new P3.T'(P2.Make
(Ancestor => (C1 => Ident_Int (4)), X => 1.2) with
Ident_Char ('a')),
8 => new P3.T'(P2.Make
(Ancestor => (C1 => Ident_Int (-4)), X => 1.3) with
Ident_Char ('A')),
9 => new P3.T'(P2.Make
(Ancestor => (C1 => Ident_Int (4)), X => 1.0) with
Ident_Char ('B')));
type Truth is ('F', 'T');
type Truth_Table is array (Positive range <>, Positive range <>) of Truth;
Equality : constant Truth_Table (A'Range, A'Range) := ("TFFTFFFFF",
"FTTFTFFFF",
"FTTFFFFFF",
"TFFTFFFFF",
"FTFFTFFFF",
"FFFFFTFFF",
"FFFFFFTTF",
"FFFFFFTTF",
"FFFFFFFFT");
begin
Test ("C392013", "Check that the ""/="" implicitly declared " &
"with the declaration of ""="" for a tagged " &
"type is legal and can be used in a dispatching call");
for I in A'Range loop
for J in A'Range loop
-- Test identity:
if P1."=" (A (I).all, A (J).all) /=
(not P1."/=" (A (I).all, A (J).all)) then
Failed ("Incorrect identity comparing objects" &
Positive'Image (I) & " and" & Positive'Image (J));
end if;
-- Test the result of "/=":
if Equality (I, J) = 'T' then
if P1."/=" (A (I).all, A (J).all) then
Failed ("Incorrect result comparing objects" &
Positive'Image (I) & " and" & Positive'Image (J) & " - T");
end if;
else
if not P1."/=" (A (I).all, A (J).all) then
Failed ("Incorrect result comparing objects" &
Positive'Image (I) & " and" & Positive'Image (J) & " - F");
end if;
end if;
end loop;
end loop;
Result;
end C392013;
separate (C392013)
package body P1 is
function "=" (L, R : T) return Boolean is
begin
return abs L.C1 = abs R.C1;
end "=";
end P1;
separate (C392013)
package body P2 is
function "=" (L, R : T) return Boolean is
begin
return P1."=" (P1.T (L), P1.T (R)) and then abs (L.C2 - R.C2) <= 0.5;
end "=";
function Make (Ancestor : P1.T; X : Float) return T is
begin
return (Ancestor with X);
end Make;
end P2;
with Ada.Characters.Handling;
separate (C392013)
package body P3 is
function "=" (L, R : T) return Boolean is
begin
return P2."=" (P2.T (L), P2.T (R)) and then
Ada.Characters.Handling.To_Upper (L.C3) =
Ada.Characters.Handling.To_Upper (R.C3);
end "=";
function Make (Ancestor : P1.T; X : Float) return T is
begin
return (P2.Make (Ancestor, X) with ' ');
end Make;
end P3;
Go to most recent revision | Compare with Previous | Blame | View Log