1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
-- F452A00.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 ACAA 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.
--
-- Notice
--
-- The ACAA has created and maintains the Ada Conformity Assessment Test
-- Suite for the purpose of conformity assessments conducted in accordance
-- with the International Standard ISO/IEC 18009 - Ada: Conformity
-- assessment of a language processor. This test suite should not be used
-- to make claims of conformance unless used in accordance with
-- ISO/IEC 18009 and any applicable ACAA procedures.
--*
--
-- FOUNDATION DESCRIPTION:
-- This foundation provides basic operations to test whether equality of
-- a type is the same inside and outside of this foundation.
--
-- The language requires that the equality operations of
-- language-defined types act as if they are predefined, that is, the
-- operation remain the same inside of a generic (where some predefined
-- operation code reemerge) and that they participate in the predefined
-- equality of all composite types containing it as a part (including
-- arrays). This is only true for record types; for other kinds of types,
-- any user-defined "=" is ignored inside of a generic and in composition
-- of of equality.
--
-- Note that the three formal objects always be independent objects and
-- must have the relationship
-- Obj1 = Obj2 /= Obj3
-- If not, the test may fail incorrectly or miss errors.
-- CHANGE HISTORY:
-- 25 JAN 2001 PHL Initial version.
-- 19 Dec 2018 RLB Created foundation from part of submitted test.
generic
Subtest : String;
type T is private;
-- Obj1 = Obj2 /= Obj3, and they are all created independently.
Obj1 : in T;
Obj2 : in out T;
Obj3 : in out T;
package F452A00 is
type A is array (Boolean range <>) of T;
type R (D : Boolean) is
record
C1 : Character;
case D is
when False =>
C2 : A (False .. D);
C3 : Float;
when True =>
C4 : Boolean;
C5 : T;
end case;
end record;
procedure Check;
end F452A00;
with Report;
use Report;
package body F452A00 is
Cnt : Natural := 0;
procedure Fill_False (X : out R; Obj : T) is
begin
X.C1 := Ident_Char ('a');
X.C2 := (Ident_Bool (False) .. Ident_Bool (False) => Obj);
X.C3 := 5.0;
end Fill_False;
procedure Fill_True (X : out R; Obj : T) is
begin
X.C1 := Ident_Char ('b');
X.C4 := Ident_Bool (True);
X.C5 := Obj;
end Fill_True;
procedure Fill (X : out T) is
begin
Cnt := Cnt + 1;
case Cnt mod 3 is
when 0 =>
X := Obj3;
when 1 =>
X := Obj1;
when 2 =>
X := Obj2;
when others =>
Failed (Subtest & " - Something went wrong in case statement");
end case;
end Fill;
procedure Check is
begin
Comment (Subtest & " - Checking reemergence of equality");
if Obj1 /= Obj2 or Obj1 = Obj3 or Obj2 = Obj3 then
Failed
(Subtest &
" - predefined equality reemerged in generic instantiation");
end if;
Comment (Subtest & " - Checking composability of equality");
Rec:
declare
X1 : R := (D => False,
C1 => Ident_Char ('a'),
C2 => (others => Obj1),
C3 => 5.0);
X2 : R (Ident_Bool (False));
X3 : R (False);
Y1 : R (Ident_Bool (True));
Y2 : constant R := (D => True,
C1 => Ident_Char ('b'),
C4 => Ident_Bool (True),
C5 => Obj2);
Y3 : R (True);
begin
Fill_False (X2, Obj2);
Fill_False (X3, Obj3);
Fill_True (Y1, Obj1);
Fill_True (Y3, Obj3);
if X1 /= X2 or X1 = X3 or X2 = X3 or
Y1 /= Y2 or Y1 = Y3 or Y2 = Y3 then
Failed
(Subtest &
" - Equality does not compose properly for records");
end if;
end Rec;
Arr:
declare
type A is array (Positive range <>) of T;
X1 : A (Ident_Int (10) .. Ident_Int (12)) :=
(Obj1, Obj2, Obj3);
X2 : A (Ident_Int (7) .. Ident_Int (9));
X3 : constant A (1 .. 3) := (Obj2, Obj2, Obj2);
begin
Fill (X2 (X2'First));
Fill (X2 (X2'First + 1));
Fill (X2 (X2'First + 2));
if X1 /= X2 or X1 = X3 or X2 = X3 then
Failed (Subtest &
" - Equality does not compose properly for arrays");
end if;
end Arr;
end Check;
end F452A00;
|
