llvm-gcc-4.0/gcc/testsuite/ada/acats/tests/c3/c392013.a

-- 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;