1 |
294 |
jeremybenn |
-- 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 |
|
|
--!
|
37 |
|
|
with Report;
|
38 |
|
|
use Report;
|
39 |
|
|
procedure 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 |
|
|
|
109 |
|
|
begin
|
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;
|
138 |
|
|
end C392013;
|
139 |
|
|
separate (C392013)
|
140 |
|
|
package 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 |
|
|
|
147 |
|
|
end P1;
|
148 |
|
|
separate (C392013)
|
149 |
|
|
package 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 |
|
|
|
162 |
|
|
end P2;
|
163 |
|
|
with Ada.Characters.Handling;
|
164 |
|
|
separate (C392013)
|
165 |
|
|
package 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 |
|
|
|
179 |
|
|
end P3;
|