|
111
|
1 -- C340001.A
|
|
|
2 --
|
|
|
3 -- Grant of Unlimited Rights
|
|
|
4 --
|
|
|
5 -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
|
|
|
6 -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
|
|
|
7 -- unlimited rights in the software and documentation contained herein.
|
|
|
8 -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
|
|
9 -- this public release, the Government intends to confer upon all
|
|
|
10 -- recipients unlimited rights equal to those held by the Government.
|
|
|
11 -- These rights include rights to use, duplicate, release or disclose the
|
|
|
12 -- released technical data and computer software in whole or in part, in
|
|
|
13 -- any manner and for any purpose whatsoever, and to have or permit others
|
|
|
14 -- 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 user-defined equality operators are inherited by a
|
|
|
28 -- derived type except when the derived type is a nonlimited record
|
|
|
29 -- extension. In the latter case, ensure that the primitive
|
|
|
30 -- equality operation of the record extension compares any extended
|
|
|
31 -- components according to the predefined equality operators of the
|
|
|
32 -- component types. Also check that the parent portion of the extended
|
|
|
33 -- type is compared using the user-defined equality operation of the
|
|
|
34 -- parent type.
|
|
|
35 --
|
|
|
36 -- TEST DESCRIPTION:
|
|
|
37 -- Declares a nonlimited tagged record and a limited tagged record
|
|
|
38 -- type, each in a separate package. A user-defined "=" operation is
|
|
|
39 -- defined for each type. Each type is extended with one new record
|
|
|
40 -- component added.
|
|
|
41 --
|
|
|
42 -- Objects are declared for each parent and extended types and are
|
|
|
43 -- assigned values. For the limited type, modifier operations defined
|
|
|
44 -- in the package are used to assign values.
|
|
|
45 --
|
|
|
46 -- To verify the use of the user-defined "=", values are assigned so
|
|
|
47 -- that predefined equality will return the opposite result if called.
|
|
|
48 -- Similarly, values are assigned to the extended type objects so that
|
|
|
49 -- one comparison will verify that the inherited components from the
|
|
|
50 -- parent are compared using the user-defined equality operation.
|
|
|
51 --
|
|
|
52 -- A second comparison sets the values of the inherited components to
|
|
|
53 -- be the same so that equality based on the extended component may be
|
|
|
54 -- verified. For the nonlimited type, the test for equality should
|
|
|
55 -- fail, as the "=" defined for this type should include testing
|
|
|
56 -- equality of the extended component. For the limited type, "=" of the
|
|
|
57 -- parent should be inherited as-is, so the test for equality should
|
|
|
58 -- succeed even though the records differ in the extended component.
|
|
|
59 --
|
|
|
60 -- A third package declares a discriminated tagged record. Equality
|
|
|
61 -- is user-defined and ignores the discriminant value. A type
|
|
|
62 -- extension is declared which also contains a discriminant. Since
|
|
|
63 -- an inherited discriminant may not be referenced other than in a
|
|
|
64 -- "new" discriminant, the type extension is also discriminated. The
|
|
|
65 -- discriminant is used as the constraint for the parent type.
|
|
|
66 --
|
|
|
67 -- A variant part is declared in the type extension based on the new
|
|
|
68 -- discriminant. Comparisons are made to confirm that the user-defined
|
|
|
69 -- equality operator is used to compare values of the type extension.
|
|
|
70 -- Two record objects are given values so that user-defined equality
|
|
|
71 -- for the parent portion of the record succeeds, but the variant
|
|
|
72 -- parts in the type extended object differ. These objects are checked
|
|
|
73 -- to ensure that they are not equal.
|
|
|
74 --
|
|
|
75 --
|
|
|
76 -- CHANGE HISTORY:
|
|
|
77 -- 06 Dec 94 SAIC ACVC 2.0
|
|
|
78 -- 19 Dec 94 SAIC Removed RM references from objective text.
|
|
|
79 --
|
|
|
80 --!
|
|
|
81
|
|
|
82 with Ada.Calendar;
|
|
|
83 package C340001_0 is
|
|
|
84
|
|
|
85 type DB_Record is tagged record
|
|
|
86 Key : Natural range 1 .. 9999;
|
|
|
87 Data : String (1..10);
|
|
|
88 end record;
|
|
|
89
|
|
|
90 function "=" (L, R : in DB_Record) return Boolean;
|
|
|
91
|
|
|
92 type Dated_Record is new DB_Record with record
|
|
|
93 Retrieval_Time : Ada.Calendar.Time;
|
|
|
94 end record;
|
|
|
95
|
|
|
96 end C340001_0;
|
|
|
97
|
|
|
98 package body C340001_0 is
|
|
|
99
|
|
|
100 function "=" (L, R : in DB_Record) return Boolean is
|
|
|
101 -- Key is ignored in determining equality of records
|
|
|
102 begin
|
|
|
103 return L.Data = R.Data;
|
|
|
104 end "=";
|
|
|
105
|
|
|
106 end C340001_0;
|
|
|
107
|
|
|
108 package C340001_1 is
|
|
|
109
|
|
|
110 type List_Contents is array (1..10) of Integer;
|
|
|
111 type List is tagged limited record
|
|
|
112 Length : Natural range 0..10 := 0;
|
|
|
113 Contents : List_Contents := (others => 0);
|
|
|
114 end record;
|
|
|
115
|
|
|
116 procedure Add_To (L : in out List; New_Value : in Integer);
|
|
|
117 procedure Remove_From (L : in out List);
|
|
|
118
|
|
|
119 function "=" (L, R : in List) return Boolean;
|
|
|
120
|
|
|
121 subtype Revision_Mark is Character range 'A' .. 'Z';
|
|
|
122 type Revisable_List is new List with record
|
|
|
123 Revision : Revision_Mark := 'A';
|
|
|
124 end record;
|
|
|
125
|
|
|
126 procedure Revise (L : in out Revisable_List);
|
|
|
127
|
|
|
128 end C340001_1;
|
|
|
129
|
|
|
130 package body C340001_1 is
|
|
|
131
|
|
|
132 -- Note: This is not a complete abstraction of a list. Exceptions
|
|
|
133 -- are not defined and boundary checks are not made.
|
|
|
134
|
|
|
135 procedure Add_To (L : in out List; New_Value : in Integer) is
|
|
|
136 begin
|
|
|
137 L.Length := L.Length + 1;
|
|
|
138 L.Contents (L.Length) := New_Value;
|
|
|
139 end Add_To;
|
|
|
140
|
|
|
141 procedure Remove_From (L : in out List) is
|
|
|
142 -- The list length is decremented. "Old" values are left in the
|
|
|
143 -- array. They are overwritten when a new value is added.
|
|
|
144 begin
|
|
|
145 L.Length := L.Length - 1;
|
|
|
146 end Remove_From;
|
|
|
147
|
|
|
148 function "=" (L, R : in List) return Boolean is
|
|
|
149 -- Two lists are equal if they are the same length and
|
|
|
150 -- the component values within that length are the same.
|
|
|
151 -- Values stored past the end of the list are ignored.
|
|
|
152 begin
|
|
|
153 return L.Length = R.Length
|
|
|
154 and then L.Contents (1..L.Length) = R.Contents (1..R.Length);
|
|
|
155 end "=";
|
|
|
156
|
|
|
157 procedure Revise (L : in out Revisable_List) is
|
|
|
158 begin
|
|
|
159 L.Revision := Character'Succ (L.Revision);
|
|
|
160 end Revise;
|
|
|
161
|
|
|
162 end C340001_1;
|
|
|
163
|
|
|
164 package C340001_2 is
|
|
|
165
|
|
|
166 type Media is (Paper, Electronic);
|
|
|
167
|
|
|
168 type Transaction (Medium : Media) is tagged record
|
|
|
169 ID : Natural range 1000 .. 9999;
|
|
|
170 end record;
|
|
|
171
|
|
|
172 function "=" (L, R : in Transaction) return Boolean;
|
|
|
173
|
|
|
174 type Authorization (Kind : Media) is new Transaction (Medium => Kind)
|
|
|
175 with record
|
|
|
176 case Kind is
|
|
|
177 when Paper =>
|
|
|
178 Signature_On_File : Boolean;
|
|
|
179 when Electronic =>
|
|
|
180 Paper_Backup : Boolean; -- to retain opposing value
|
|
|
181 end case;
|
|
|
182 end record;
|
|
|
183
|
|
|
184 end C340001_2;
|
|
|
185
|
|
|
186 package body C340001_2 is
|
|
|
187
|
|
|
188 function "=" (L, R : in Transaction) return Boolean is
|
|
|
189 -- There may be electronic and paper copies of the same transaction.
|
|
|
190 -- The ID uniquely identifies a transaction. The medium (stored in
|
|
|
191 -- the discriminant) is ignored.
|
|
|
192 begin
|
|
|
193 return L.ID = R.ID;
|
|
|
194 end "=";
|
|
|
195
|
|
|
196 end C340001_2;
|
|
|
197
|
|
|
198
|
|
|
199 with C340001_0; -- nonlimited tagged record declarations
|
|
|
200 with C340001_1; -- limited tagged record declarations
|
|
|
201 with C340001_2; -- tagged variant declarations
|
|
|
202 with Ada.Calendar;
|
|
|
203 with Report;
|
|
|
204 procedure C340001 is
|
|
|
205
|
|
|
206 DB_Rec1 : C340001_0.DB_Record := (Key => 1,
|
|
|
207 Data => "aaaaaaaaaa");
|
|
|
208 DB_Rec2 : C340001_0.DB_Record := (Key => 55,
|
|
|
209 Data => "aaaaaaaaaa");
|
|
|
210 -- DB_Rec1 = DB_Rec2 using user-defined equality
|
|
|
211 -- DB_Rec1 /= DB_Rec2 using predefined equality
|
|
|
212
|
|
|
213 Some_Time : Ada.Calendar.Time :=
|
|
|
214 Ada.Calendar.Time_Of (Month => 9, Day => 16, Year => 1993);
|
|
|
215
|
|
|
216 Another_Time : Ada.Calendar.Time :=
|
|
|
217 Ada.Calendar.Time_Of (Month => 9, Day => 19, Year => 1993);
|
|
|
218
|
|
|
219 Dated_Rec1 : C340001_0.Dated_Record := (Key => 2,
|
|
|
220 Data => "aaaaaaaaaa",
|
|
|
221 Retrieval_Time => Some_Time);
|
|
|
222 Dated_Rec2 : C340001_0.Dated_Record := (Key => 77,
|
|
|
223 Data => "aaaaaaaaaa",
|
|
|
224 Retrieval_Time => Some_Time);
|
|
|
225 Dated_Rec3 : C340001_0.Dated_Record := (Key => 77,
|
|
|
226 Data => "aaaaaaaaaa",
|
|
|
227 Retrieval_Time => Another_Time);
|
|
|
228 -- Dated_Rec1 = Dated_Rec2 if DB_Record."=" used for parent portion
|
|
|
229 -- Dated_Rec2 /= Dated_Rec3 if extended component is compared
|
|
|
230 -- using Ada.Calendar.Time."="
|
|
|
231
|
|
|
232 List1 : C340001_1.List;
|
|
|
233 List2 : C340001_1.List;
|
|
|
234
|
|
|
235 RList1 : C340001_1.Revisable_List;
|
|
|
236 RList2 : C340001_1.Revisable_List;
|
|
|
237 RList3 : C340001_1.Revisable_List;
|
|
|
238
|
|
|
239 Current : C340001_2.Transaction (C340001_2.Paper) :=
|
|
|
240 (C340001_2.Paper, 2001);
|
|
|
241 Last : C340001_2.Transaction (C340001_2.Electronic) :=
|
|
|
242 (C340001_2.Electronic, 2001);
|
|
|
243 -- Current = Last using user-defined equality
|
|
|
244 -- Current /= Last using predefined equality
|
|
|
245
|
|
|
246 Approval1 : C340001_2.Authorization (C340001_2.Paper)
|
|
|
247 := (Kind => C340001_2.Paper,
|
|
|
248 ID => 1040,
|
|
|
249 Signature_On_File => True);
|
|
|
250 Approval2 : C340001_2.Authorization (C340001_2.Paper)
|
|
|
251 := (Kind => C340001_2.Paper,
|
|
|
252 ID => 2167,
|
|
|
253 Signature_On_File => False);
|
|
|
254 Approval3 : C340001_2.Authorization (C340001_2.Electronic)
|
|
|
255 := (Kind => C340001_2.Electronic,
|
|
|
256 ID => 2167,
|
|
|
257 Paper_Backup => False);
|
|
|
258 -- Approval1 /= Approval2 if user-defined equality extended with
|
|
|
259 -- component equality.
|
|
|
260 -- Approval2 /= Approval3 if differing variant parts checked
|
|
|
261
|
|
|
262 -- Direct visibility to operator symbols
|
|
|
263 use type C340001_0.DB_Record;
|
|
|
264 use type C340001_0.Dated_Record;
|
|
|
265
|
|
|
266 use type C340001_1.List;
|
|
|
267 use type C340001_1.Revisable_List;
|
|
|
268
|
|
|
269 use type C340001_2.Transaction;
|
|
|
270 use type C340001_2.Authorization;
|
|
|
271
|
|
|
272 begin
|
|
|
273
|
|
|
274 Report.Test ("C340001", "Inheritance of user-defined ""=""");
|
|
|
275
|
|
|
276 -- Approval1 /= Approval2 if user-defined equality extended with
|
|
|
277 -- component equality.
|
|
|
278 -- Approval2 /= Approval3 if differing variant parts checked
|
|
|
279
|
|
|
280 ---------------------------------------------------------------------
|
|
|
281 -- Check that "=" and "/=" for the parent type call the user-defined
|
|
|
282 -- operation
|
|
|
283 ---------------------------------------------------------------------
|
|
|
284
|
|
|
285 if not (DB_Rec1 = DB_Rec2) then
|
|
|
286 Report.Failed ("Nonlimited tagged record: " &
|
|
|
287 "User-defined equality did not override predefined " &
|
|
|
288 "equality");
|
|
|
289 end if;
|
|
|
290
|
|
|
291 if DB_Rec1 /= DB_Rec2 then
|
|
|
292 Report.Failed ("Nonlimited tagged record: " &
|
|
|
293 "User-defined equality did not override predefined " &
|
|
|
294 "inequality as well");
|
|
|
295 end if;
|
|
|
296
|
|
|
297 ---------------------------------------------------------------------
|
|
|
298 -- Check that "=" and "/=" for the type extension use the user-defined
|
|
|
299 -- equality operations from the parent to compare the inherited
|
|
|
300 -- components
|
|
|
301 ---------------------------------------------------------------------
|
|
|
302
|
|
|
303 if not (Dated_Rec1 = Dated_Rec2) then
|
|
|
304 Report.Failed ("Nonlimited tagged record: " &
|
|
|
305 "User-defined equality was not used to compare " &
|
|
|
306 "components inherited from parent");
|
|
|
307 end if;
|
|
|
308
|
|
|
309 if Dated_Rec1 /= Dated_Rec2 then
|
|
|
310 Report.Failed ("Nonlimited tagged record: " &
|
|
|
311 "User-defined inequality was not used to compare " &
|
|
|
312 "components inherited from parent");
|
|
|
313 end if;
|
|
|
314
|
|
|
315 ---------------------------------------------------------------------
|
|
|
316 -- Check that equality and inequality for the type extension incorporate
|
|
|
317 -- the predefined equality operators for the extended component type
|
|
|
318 ---------------------------------------------------------------------
|
|
|
319 if Dated_Rec2 = Dated_Rec3 then
|
|
|
320 Report.Failed ("Nonlimited tagged record: " &
|
|
|
321 "Record equality was not extended with component " &
|
|
|
322 "equality");
|
|
|
323 end if;
|
|
|
324
|
|
|
325 if not (Dated_Rec2 /= Dated_Rec3) then
|
|
|
326 Report.Failed ("Nonlimited tagged record: " &
|
|
|
327 "Record inequality was not extended with component " &
|
|
|
328 "equality");
|
|
|
329 end if;
|
|
|
330
|
|
|
331 ---------------------------------------------------------------------
|
|
|
332 C340001_1.Add_To (List1, 1);
|
|
|
333 C340001_1.Add_To (List1, 2);
|
|
|
334 C340001_1.Add_To (List1, 3);
|
|
|
335 C340001_1.Remove_From (List1);
|
|
|
336
|
|
|
337 C340001_1.Add_To (List2, 1);
|
|
|
338 C340001_1.Add_To (List2, 2);
|
|
|
339
|
|
|
340 -- List1 contents are (2, (1, 2, 3, 0, 0, 0, 0, 0, 0, 0))
|
|
|
341 -- List2 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0))
|
|
|
342
|
|
|
343 -- List1 = List2 using user-defined equality
|
|
|
344 -- List1 /= List2 using predefined equality
|
|
|
345
|
|
|
346 ---------------------------------------------------------------------
|
|
|
347 -- Check that "=" and "/=" for the parent type call the user-defined
|
|
|
348 -- operation
|
|
|
349 ---------------------------------------------------------------------
|
|
|
350 if not (List1 = List2) then
|
|
|
351 Report.Failed ("Limited tagged record : " &
|
|
|
352 "User-defined equality incorrectly implemented " );
|
|
|
353 end if;
|
|
|
354
|
|
|
355 if List1 /= List2 then
|
|
|
356 Report.Failed ("Limited tagged record : " &
|
|
|
357 "User-defined equality incorrectly implemented " );
|
|
|
358 end if;
|
|
|
359
|
|
|
360 ---------------------------------------------------------------------
|
|
|
361 -- RList1 and RList2 are made equal but "different" by adding
|
|
|
362 -- a nonzero value to RList1 then removing it. Removal updates
|
|
|
363 -- the list Length only, not its contents. The two lists will be
|
|
|
364 -- equal according to the defined list abstraction, but the records
|
|
|
365 -- will contain differing component values.
|
|
|
366
|
|
|
367 C340001_1.Add_To (RList1, 1);
|
|
|
368 C340001_1.Add_To (RList1, 2);
|
|
|
369 C340001_1.Add_To (RList1, 3);
|
|
|
370 C340001_1.Remove_From (RList1);
|
|
|
371
|
|
|
372 C340001_1.Add_To (RList2, 1);
|
|
|
373 C340001_1.Add_To (RList2, 2);
|
|
|
374
|
|
|
375 C340001_1.Add_To (RList3, 1);
|
|
|
376 C340001_1.Add_To (RList3, 2);
|
|
|
377
|
|
|
378 C340001_1.Revise (RList3);
|
|
|
379
|
|
|
380 -- RList1 contents are (2, (1, 2, 3, 0, 0, 0, 0, 0, 0, 0), 'A')
|
|
|
381 -- RList2 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0), 'A')
|
|
|
382 -- RList3 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0), 'B')
|
|
|
383
|
|
|
384 -- RList1 = RList2 if List."=" inherited
|
|
|
385 -- RList2 /= RList3 if List."=" inherited and extended with Character "="
|
|
|
386
|
|
|
387 ---------------------------------------------------------------------
|
|
|
388 -- Check that "=" and "/=" are the user-defined operations inherited
|
|
|
389 -- from the parent type.
|
|
|
390 ---------------------------------------------------------------------
|
|
|
391 if not (RList1 = RList2) then
|
|
|
392 Report.Failed ("Limited tagged record : " &
|
|
|
393 "User-defined equality was not inherited");
|
|
|
394 end if;
|
|
|
395
|
|
|
396 if RList1 /= RList2 then
|
|
|
397 Report.Failed ("Limited tagged record : " &
|
|
|
398 "User-defined inequality was not inherited");
|
|
|
399 end if;
|
|
|
400 ---------------------------------------------------------------------
|
|
|
401 -- Check that "=" and "/=" for the type extension are NOT extended
|
|
|
402 -- with the predefined equality operators for the extended component.
|
|
|
403 -- A limited type extension should inherit the parent equality operation
|
|
|
404 -- as is.
|
|
|
405 ---------------------------------------------------------------------
|
|
|
406 if not (RList2 = RList3) then
|
|
|
407 Report.Failed ("Limited tagged record : " &
|
|
|
408 "Inherited equality operation was extended with " &
|
|
|
409 "component equality");
|
|
|
410 end if;
|
|
|
411
|
|
|
412 if RList2 /= RList3 then
|
|
|
413 Report.Failed ("Limited tagged record : " &
|
|
|
414 "Inherited inequality operation was extended with " &
|
|
|
415 "component equality");
|
|
|
416 end if;
|
|
|
417
|
|
|
418 ---------------------------------------------------------------------
|
|
|
419 -- Check that "=" and "/=" for the parent type call the user-defined
|
|
|
420 -- operation
|
|
|
421 ---------------------------------------------------------------------
|
|
|
422 if not (Current = Last) then
|
|
|
423 Report.Failed ("Variant record : " &
|
|
|
424 "User-defined equality did not override predefined " &
|
|
|
425 "equality");
|
|
|
426 end if;
|
|
|
427
|
|
|
428 if Current /= Last then
|
|
|
429 Report.Failed ("Variant record : " &
|
|
|
430 "User-defined inequality did not override predefined " &
|
|
|
431 "inequality");
|
|
|
432 end if;
|
|
|
433
|
|
|
434 ---------------------------------------------------------------------
|
|
|
435 -- Check that user-defined equality was incorporated and extended
|
|
|
436 -- with equality of extended components.
|
|
|
437 ---------------------------------------------------------------------
|
|
|
438 if not (Approval1 /= Approval2) then
|
|
|
439 Report.Failed ("Variant record : " &
|
|
|
440 "Inequality was not extended with component " &
|
|
|
441 "inequality");
|
|
|
442 end if;
|
|
|
443
|
|
|
444 if Approval1 = Approval2 then
|
|
|
445 Report.Failed ("Variant record : " &
|
|
|
446 "Equality was not extended with component " &
|
|
|
447 "equality");
|
|
|
448 end if;
|
|
|
449
|
|
|
450 ---------------------------------------------------------------------
|
|
|
451 -- Check that equality and inequality for the type extension
|
|
|
452 -- succeed despite the presence of differing variant parts.
|
|
|
453 ---------------------------------------------------------------------
|
|
|
454 if Approval2 = Approval3 then
|
|
|
455 Report.Failed ("Variant record : " &
|
|
|
456 "Equality succeeded even though variant parts " &
|
|
|
457 "in type extension differ");
|
|
|
458 end if;
|
|
|
459
|
|
|
460 if not (Approval2 /= Approval3) then
|
|
|
461 Report.Failed ("Variant record : " &
|
|
|
462 "Inequality failed even though variant parts " &
|
|
|
463 "in type extension differ");
|
|
|
464 end if;
|
|
|
465
|
|
|
466 ---------------------------------------------------------------------
|
|
|
467 Report.Result;
|
|
|
468 ---------------------------------------------------------------------
|
|
|
469
|
|
|
470 end C340001;
|
