diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c392013.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c3/c392013.a | 179 |
1 files changed, 179 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392013.a b/gcc/testsuite/ada/acats/tests/c3/c392013.a new file mode 100644 index 000000000..3873d9e62 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c392013.a @@ -0,0 +1,179 @@ +-- 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; |