1-- C392013.A
2--
3--                             Grant of Unlimited Rights
4--
5--     The Ada Conformity Assessment Authority (ACAA) holds unlimited
6--     rights in the software and documentation contained herein. Unlimited
7--     rights are the same as those granted by the U.S. Government for older
8--     parts of the Ada Conformity Assessment Test Suite, and are defined
9--     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
10--     intends to confer upon all recipients unlimited rights equal to those
11--     held by the ACAA. These rights include rights to use, duplicate,
12--     release or disclose the released technical data and computer software
13--     in whole or in part, in any manner and for any purpose whatsoever, and
14--     to have or permit others to do so.
15--
16--                                    DISCLAIMER
17--
18--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
20--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
21--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
22--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
23--     PARTICULAR PURPOSE OF SAID MATERIAL.
24--*
25--
26-- OBJECTIVE:
27--    Check that the "/=" implicitly declared with the declaration of "=" for
28--    a tagged type is legal and can be used in a dispatching call.
29--    (Defect Report 8652/0010, as reflected in Technical Corrigendum 1).
30--
31-- CHANGE HISTORY:
32--    23 JAN 2001   PHL   Initial version.
33--    16 MAR 2001   RLB   Readied for release; added identity and negative
34--                        result cases.
35--    24 MAY 2001   RLB   Corrected the result for the 9 vs. 9 case.
36--!
37with Report;
38use Report;
39procedure C392013 is
40
41    package P1 is
42        type T is tagged
43            record
44                C1 : Integer;
45            end record;
46        function "=" (L, R : T) return Boolean;
47    end P1;
48
49    package P2 is
50        type T is new P1.T with private;
51        function Make (Ancestor : P1.T; X : Float) return T;
52    private
53        type T is new P1.T with
54            record
55                C2 : Float;
56            end record;
57        function "=" (L, R : T) return Boolean;
58    end P2;
59
60    package P3 is
61        type T is new P2.T with
62            record
63                C3 : Character;
64            end record;
65    private
66        function "=" (L, R : T) return Boolean;
67        function Make (Ancestor : P1.T; X : Float) return T;
68    end P3;
69
70
71    package body P1 is separate;
72    package body P2 is separate;
73    package body P3 is separate;
74
75
76    type Cwat is access P1.T'Class;
77    type Cwat_Array is array (Positive range <>) of Cwat;
78
79    A : constant Cwat_Array :=
80       (1 => new P1.T'(C1 => Ident_Int (3)),
81        2 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (5)), X => 4.0)),
82        3 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (-5)), X => 4.2)),
83        4 => new P1.T'(C1 => Ident_Int (-3)),
84        5 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (5)), X => 3.6)),
85        6 => new P1.T'(C1 => Ident_Int (4)),
86        7 => new P3.T'(P2.Make
87                          (Ancestor => (C1 => Ident_Int (4)), X => 1.2) with
88                       Ident_Char ('a')),
89        8 => new P3.T'(P2.Make
90                          (Ancestor => (C1 => Ident_Int (-4)), X => 1.3) with
91                       Ident_Char ('A')),
92        9 => new P3.T'(P2.Make
93                          (Ancestor => (C1 => Ident_Int (4)), X => 1.0) with
94                       Ident_Char ('B')));
95
96    type Truth is ('F', 'T');
97    type Truth_Table is array (Positive range <>, Positive range <>) of Truth;
98
99    Equality : constant Truth_Table (A'Range, A'Range) := ("TFFTFFFFF",
100                                                           "FTTFTFFFF",
101                                                           "FTTFFFFFF",
102                                                           "TFFTFFFFF",
103                                                           "FTFFTFFFF",
104                                                           "FFFFFTFFF",
105                                                           "FFFFFFTTF",
106                                                           "FFFFFFTTF",
107                                                           "FFFFFFFFT");
108
109begin
110    Test ("C392013", "Check that the ""/="" implicitly declared " &
111                        "with the declaration of ""="" for a tagged " &
112                        "type is legal and can be used in a dispatching call");
113
114    for I in A'Range loop
115        for J in A'Range loop
116	    -- Test identity:
117            if P1."=" (A (I).all, A (J).all) /=
118                  (not P1."/=" (A (I).all, A (J).all)) then
119                Failed ("Incorrect identity comparing objects" &
120                        Positive'Image (I) & " and" & Positive'Image (J));
121            end if;
122            -- Test the result of "/=":
123            if Equality (I, J) = 'T' then
124                if P1."/=" (A (I).all, A (J).all) then
125                    Failed ("Incorrect result comparing objects" &
126                           Positive'Image (I) & " and" & Positive'Image (J) & " - T");
127                end if;
128            else
129                if not P1."/=" (A (I).all, A (J).all) then
130                    Failed ("Incorrect result comparing objects" &
131                           Positive'Image (I) & " and" & Positive'Image (J) & " - F");
132                end if;
133            end if;
134        end loop;
135    end loop;
136
137    Result;
138end C392013;
139separate (C392013)
140package body P1 is
141
142    function "=" (L, R : T) return Boolean is
143    begin
144        return abs L.C1 = abs R.C1;
145    end "=";
146
147end P1;
148separate (C392013)
149package body P2 is
150
151    function "=" (L, R : T) return Boolean is
152    begin
153        return P1."=" (P1.T (L), P1.T (R)) and then abs (L.C2 - R.C2) <= 0.5;
154    end "=";
155
156
157    function Make (Ancestor : P1.T; X : Float) return T is
158    begin
159        return (Ancestor with X);
160    end Make;
161
162end P2;
163with Ada.Characters.Handling;
164separate (C392013)
165package body P3 is
166
167    function "=" (L, R : T) return Boolean is
168    begin
169        return P2."=" (P2.T (L), P2.T (R)) and then
170                  Ada.Characters.Handling.To_Upper (L.C3) =
171                     Ada.Characters.Handling.To_Upper (R.C3);
172    end "=";
173
174    function Make (Ancestor : P1.T; X : Float) return T is
175    begin
176        return (P2.Make (Ancestor, X) with ' ');
177    end Make;
178
179end P3;
180