Subversion Repositories openrisc_2011-10-31

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