3 -- Grant of Unlimited Rights
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
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.
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
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
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.
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.
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.
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.
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.
77 -- 06 Dec 94 SAIC ACVC 2.0
78 -- 19 Dec 94 SAIC Removed RM references from objective text.
85 type DB_Record
is tagged record
86 Key
: Natural range 1 .. 9999;
87 Data
: String (1..10);
90 function "=" (L
, R
: in DB_Record
) return Boolean;
92 type Dated_Record
is new DB_Record
with record
93 Retrieval_Time
: Ada
.Calendar
.Time
;
98 package body C340001_0
is
100 function "=" (L
, R
: in DB_Record
) return Boolean is
101 -- Key is ignored in determining equality of records
103 return L
.Data
= R
.Data
;
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);
116 procedure Add_To
(L
: in out List
; New_Value
: in Integer);
117 procedure Remove_From
(L
: in out List
);
119 function "=" (L
, R
: in List
) return Boolean;
121 subtype Revision_Mark
is Character range 'A' .. 'Z';
122 type Revisable_List
is new List
with record
123 Revision
: Revision_Mark
:= 'A';
126 procedure Revise
(L
: in out Revisable_List
);
130 package body C340001_1
is
132 -- Note: This is not a complete abstraction of a list. Exceptions
133 -- are not defined and boundary checks are not made.
135 procedure Add_To
(L
: in out List
; New_Value
: in Integer) is
137 L
.Length
:= L
.Length
+ 1;
138 L
.Contents
(L
.Length
) := New_Value
;
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.
145 L
.Length
:= L
.Length
- 1;
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.
153 return L
.Length
= R
.Length
154 and then L
.Contents
(1..L
.Length
) = R
.Contents
(1..R
.Length
);
157 procedure Revise
(L
: in out Revisable_List
) is
159 L
.Revision
:= Character'Succ (L
.Revision
);
166 type Media
is (Paper
, Electronic
);
168 type Transaction
(Medium
: Media
) is tagged record
169 ID
: Natural range 1000 .. 9999;
172 function "=" (L
, R
: in Transaction
) return Boolean;
174 type Authorization
(Kind
: Media
) is new Transaction
(Medium
=> Kind
)
178 Signature_On_File
: Boolean;
180 Paper_Backup
: Boolean; -- to retain opposing value
186 package body C340001_2
is
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.
199 with C340001_0
; -- nonlimited tagged record declarations
200 with C340001_1
; -- limited tagged record declarations
201 with C340001_2
; -- tagged variant declarations
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
213 Some_Time
: Ada
.Calendar
.Time
:=
214 Ada
.Calendar
.Time_Of
(Month
=> 9, Day
=> 16, Year
=> 1993);
216 Another_Time
: Ada
.Calendar
.Time
:=
217 Ada
.Calendar
.Time_Of
(Month
=> 9, Day
=> 19, Year
=> 1993);
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."="
232 List1
: C340001_1
.List
;
233 List2
: C340001_1
.List
;
235 RList1
: C340001_1
.Revisable_List
;
236 RList2
: C340001_1
.Revisable_List
;
237 RList3
: C340001_1
.Revisable_List
;
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
246 Approval1
: C340001_2
.Authorization
(C340001_2
.Paper
)
247 := (Kind
=> C340001_2
.Paper
,
249 Signature_On_File
=> True);
250 Approval2
: C340001_2
.Authorization
(C340001_2
.Paper
)
251 := (Kind
=> C340001_2
.Paper
,
253 Signature_On_File
=> False);
254 Approval3
: C340001_2
.Authorization
(C340001_2
.Electronic
)
255 := (Kind
=> C340001_2
.Electronic
,
257 Paper_Backup
=> False);
258 -- Approval1 /= Approval2 if user-defined equality extended with
259 -- component equality.
260 -- Approval2 /= Approval3 if differing variant parts checked
262 -- Direct visibility to operator symbols
263 use type C340001_0
.DB_Record
;
264 use type C340001_0
.Dated_Record
;
266 use type C340001_1
.List
;
267 use type C340001_1
.Revisable_List
;
269 use type C340001_2
.Transaction
;
270 use type C340001_2
.Authorization
;
274 Report
.Test
("C340001", "Inheritance of user-defined ""=""");
276 -- Approval1 /= Approval2 if user-defined equality extended with
277 -- component equality.
278 -- Approval2 /= Approval3 if differing variant parts checked
280 ---------------------------------------------------------------------
281 -- Check that "=" and "/=" for the parent type call the user-defined
283 ---------------------------------------------------------------------
285 if not (DB_Rec1
= DB_Rec2
) then
286 Report
.Failed
("Nonlimited tagged record: " &
287 "User-defined equality did not override predefined " &
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");
297 ---------------------------------------------------------------------
298 -- Check that "=" and "/=" for the type extension use the user-defined
299 -- equality operations from the parent to compare the inherited
301 ---------------------------------------------------------------------
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");
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");
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 " &
325 if not (Dated_Rec2
/= Dated_Rec3
) then
326 Report
.Failed
("Nonlimited tagged record: " &
327 "Record inequality was not extended with component " &
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
);
337 C340001_1
.Add_To
(List2
, 1);
338 C340001_1
.Add_To
(List2
, 2);
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))
343 -- List1 = List2 using user-defined equality
344 -- List1 /= List2 using predefined equality
346 ---------------------------------------------------------------------
347 -- Check that "=" and "/=" for the parent type call the user-defined
349 ---------------------------------------------------------------------
350 if not (List1
= List2
) then
351 Report
.Failed
("Limited tagged record : " &
352 "User-defined equality incorrectly implemented " );
355 if List1
/= List2
then
356 Report
.Failed
("Limited tagged record : " &
357 "User-defined equality incorrectly implemented " );
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.
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
);
372 C340001_1
.Add_To
(RList2
, 1);
373 C340001_1
.Add_To
(RList2
, 2);
375 C340001_1
.Add_To
(RList3
, 1);
376 C340001_1
.Add_To
(RList3
, 2);
378 C340001_1
.Revise
(RList3
);
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')
384 -- RList1 = RList2 if List."=" inherited
385 -- RList2 /= RList3 if List."=" inherited and extended with Character "="
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");
396 if RList1
/= RList2
then
397 Report
.Failed
("Limited tagged record : " &
398 "User-defined inequality was not inherited");
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
405 ---------------------------------------------------------------------
406 if not (RList2
= RList3
) then
407 Report
.Failed
("Limited tagged record : " &
408 "Inherited equality operation was extended with " &
409 "component equality");
412 if RList2
/= RList3
then
413 Report
.Failed
("Limited tagged record : " &
414 "Inherited inequality operation was extended with " &
415 "component equality");
418 ---------------------------------------------------------------------
419 -- Check that "=" and "/=" for the parent type call the user-defined
421 ---------------------------------------------------------------------
422 if not (Current
= Last
) then
423 Report
.Failed
("Variant record : " &
424 "User-defined equality did not override predefined " &
428 if Current
/= Last
then
429 Report
.Failed
("Variant record : " &
430 "User-defined inequality did not override predefined " &
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 " &
444 if Approval1
= Approval2
then
445 Report
.Failed
("Variant record : " &
446 "Equality was not extended with component " &
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");
460 if not (Approval2
/= Approval3
) then
461 Report
.Failed
("Variant record : " &
462 "Inequality failed even though variant parts " &
463 "in type extension differ");
466 ---------------------------------------------------------------------
468 ---------------------------------------------------------------------