summaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c3/c340001.a
blob: dce98bdb05b2572bd078b6fb6fbec4e635000eb3 (plain)
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
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
-- C340001.A
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     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 GOVERNMENT 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.
--*
--
-- OBJECTIVE:
--      Check that user-defined equality operators are inherited by a
--      derived type except when the derived type is a nonlimited record
--      extension. In the latter case, ensure that the primitive
--      equality operation of the record extension compares any extended
--      components according to the predefined equality operators of the
--      component types.  Also check that the parent portion of the extended
--      type is compared using the user-defined equality operation of the
--      parent type.
--
-- TEST DESCRIPTION:
--      Declares a nonlimited tagged record and a limited tagged record
--      type, each in a separate package. A user-defined "=" operation is
--      defined for each type. Each type is extended with one new record
--      component added.
--
--      Objects are declared for each parent and extended types and are
--      assigned values. For the limited type, modifier operations defined
--      in the package are used to assign values.
--
--      To verify the use of the user-defined "=", values are assigned so
--      that predefined equality will return the opposite result if called.
--      Similarly, values are assigned to the extended type objects so that
--      one comparison will verify that the inherited components from the
--      parent are compared using the user-defined equality operation.
--
--      A second comparison sets the values of the inherited components to
--      be the same so that equality based on the extended component may be
--      verified. For the nonlimited type, the test for equality should
--      fail, as the "=" defined for this type should include testing
--      equality of the extended component. For the limited type, "=" of the
--      parent should be inherited as-is, so the test for equality should
--      succeed even though the records differ in the extended component.
--
--      A third package declares a discriminated tagged record. Equality
--      is user-defined and ignores the discriminant value. A type
--      extension is declared which also contains a discriminant. Since
--      an inherited discriminant may not be referenced other than in a
--      "new" discriminant, the type extension is also discriminated. The
--      discriminant is used as the constraint for the parent type.
--
--      A variant part is declared in the type extension based on the new
--      discriminant. Comparisons are made to confirm that the user-defined
--      equality operator is used to compare values of the type extension.
--      Two record objects are given values so that user-defined equality
--      for the parent portion of the record succeeds, but the variant
--      parts in the type extended object differ. These objects are checked
--      to ensure that they are not equal.
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      19 Dec 94   SAIC    Removed RM references from objective text.
--
--! 

with Ada.Calendar;
package C340001_0 is

   type DB_Record is tagged record
      Key : Natural range 1 .. 9999;
      Data : String (1..10);
   end record;

   function "=" (L, R : in DB_Record) return Boolean;

   type Dated_Record is new DB_Record with record
      Retrieval_Time : Ada.Calendar.Time;
   end record;

end C340001_0;

package body C340001_0 is

   function "=" (L, R : in DB_Record) return Boolean is
   -- Key is ignored in determining equality of records
   begin
      return L.Data = R.Data;
   end "=";
   
end C340001_0;

package C340001_1 is

   type List_Contents is array (1..10) of Integer;
   type List is tagged limited record
      Length   : Natural range 0..10 := 0;
      Contents : List_Contents := (others => 0);
   end record;

   procedure Add_To (L : in out List; New_Value : in Integer);
   procedure Remove_From (L : in out List);

   function "=" (L, R : in List) return Boolean;

   subtype Revision_Mark is Character range 'A' .. 'Z';
   type Revisable_List is new List with record
      Revision : Revision_Mark := 'A';
   end record;

   procedure Revise (L : in out Revisable_List);

end C340001_1;

package body C340001_1 is

   -- Note: This is not a complete abstraction of a list. Exceptions
   -- are not defined and boundary checks are not made.

   procedure Add_To (L : in out List; New_Value : in Integer) is
   begin
      L.Length := L.Length + 1;
      L.Contents (L.Length) := New_Value;
   end Add_To;

   procedure Remove_From (L : in out List) is
   -- The list length is decremented. "Old" values are left in the
   -- array. They are overwritten when a new value is added.
   begin
      L.Length := L.Length - 1;
   end Remove_From;

   function "=" (L, R : in List) return Boolean is
   -- Two lists are equal if they are the same length and
   -- the component values within that length are the same.
   -- Values stored past the end of the list are ignored.
   begin
      return L.Length = R.Length
	 and then L.Contents (1..L.Length) = R.Contents (1..R.Length);
   end "=";

   procedure Revise (L : in out Revisable_List) is
   begin
      L.Revision := Character'Succ (L.Revision);
   end Revise;
   
end C340001_1;

package C340001_2 is

   type Media is (Paper, Electronic);

   type Transaction (Medium : Media) is tagged record
      ID : Natural range 1000 .. 9999;
   end record;

   function "=" (L, R : in Transaction) return Boolean;

   type Authorization (Kind : Media) is new Transaction (Medium => Kind)
   with record
      case Kind is
      when Paper =>
	 Signature_On_File : Boolean;
      when Electronic =>
        Paper_Backup   : Boolean; -- to retain opposing value
      end case;
   end record;

end C340001_2;

package body C340001_2 is

   function "=" (L, R : in Transaction) return Boolean is
   -- There may be electronic and paper copies of the same transaction.
   -- The ID uniquely identifies a transaction. The medium (stored in
   -- the discriminant) is ignored.
   begin
      return L.ID = R.ID;
   end "=";

end C340001_2;


with C340001_0; -- nonlimited tagged record declarations
with C340001_1; -- limited tagged record declarations
with C340001_2; -- tagged variant declarations
with Ada.Calendar;
with Report;
procedure C340001 is

   DB_Rec1 : C340001_0.DB_Record := (Key  => 1,
				     Data => "aaaaaaaaaa");
   DB_Rec2 : C340001_0.DB_Record := (Key  => 55,
				     Data => "aaaaaaaaaa");
   -- DB_Rec1  = DB_Rec2 using user-defined equality
   -- DB_Rec1 /= DB_Rec2 using predefined equality

   Some_Time : Ada.Calendar.Time :=
      Ada.Calendar.Time_Of (Month => 9, Day => 16, Year => 1993);

   Another_Time : Ada.Calendar.Time :=
      Ada.Calendar.Time_Of (Month => 9, Day => 19, Year => 1993);

   Dated_Rec1 : C340001_0.Dated_Record := (Key  => 2,
					   Data => "aaaaaaaaaa",
					   Retrieval_Time => Some_Time);
   Dated_Rec2 : C340001_0.Dated_Record := (Key  => 77,
					   Data => "aaaaaaaaaa",
					   Retrieval_Time => Some_Time);
   Dated_Rec3 : C340001_0.Dated_Record := (Key  => 77,
					   Data => "aaaaaaaaaa",
					   Retrieval_Time => Another_Time);
   -- Dated_Rec1  = Dated_Rec2 if DB_Record."=" used for parent portion
   -- Dated_Rec2 /= Dated_Rec3 if extended component is compared
   --    using Ada.Calendar.Time."="

   List1 : C340001_1.List;
   List2 : C340001_1.List;

   RList1 : C340001_1.Revisable_List;
   RList2 : C340001_1.Revisable_List;
   RList3 : C340001_1.Revisable_List;

   Current : C340001_2.Transaction (C340001_2.Paper) :=
      (C340001_2.Paper, 2001);
   Last    : C340001_2.Transaction (C340001_2.Electronic) :=
      (C340001_2.Electronic, 2001);
   -- Current  = Last using user-defined equality
   -- Current /= Last using predefined equality

   Approval1 : C340001_2.Authorization (C340001_2.Paper)
    := (Kind => C340001_2.Paper,
        ID => 1040,
        Signature_On_File => True);
   Approval2 : C340001_2.Authorization (C340001_2.Paper)
    := (Kind => C340001_2.Paper,
        ID => 2167,
        Signature_On_File => False);
   Approval3 : C340001_2.Authorization (C340001_2.Electronic)
    := (Kind => C340001_2.Electronic,
        ID => 2167,
        Paper_Backup => False);
   -- Approval1 /= Approval2 if user-defined equality extended with
   --    component equality.
   -- Approval2 /= Approval3 if differing variant parts checked

   -- Direct visibility to operator symbols
   use type C340001_0.DB_Record;
   use type C340001_0.Dated_Record;

   use type C340001_1.List;
   use type C340001_1.Revisable_List;

   use type C340001_2.Transaction;
   use type C340001_2.Authorization;

begin

   Report.Test ("C340001", "Inheritance of user-defined ""=""");

   -- Approval1 /= Approval2 if user-defined equality extended with
   --    component equality.
   -- Approval2 /= Approval3 if differing variant parts checked

   ---------------------------------------------------------------------
   -- Check that "=" and "/=" for the parent type call the user-defined
   -- operation
   ---------------------------------------------------------------------

   if not (DB_Rec1 = DB_Rec2) then
      Report.Failed ("Nonlimited tagged record: " &
		     "User-defined equality did not override predefined " &
		     "equality");
   end if;

   if DB_Rec1 /= DB_Rec2 then
      Report.Failed ("Nonlimited tagged record: " &
		     "User-defined equality did not override predefined " &
		     "inequality as well");
   end if;

   ---------------------------------------------------------------------
   -- Check that "=" and "/=" for the type extension use the user-defined 
   -- equality operations from the parent to compare the inherited
   -- components
   ---------------------------------------------------------------------
   
   if not (Dated_Rec1 = Dated_Rec2) then
      Report.Failed ("Nonlimited tagged record: " &
		     "User-defined equality was not used to compare " &
		     "components inherited from parent");
   end if;

   if Dated_Rec1 /= Dated_Rec2 then
      Report.Failed ("Nonlimited tagged record: " &
		     "User-defined inequality was not used to compare " &
		     "components inherited from parent");
   end if;

   ---------------------------------------------------------------------
   -- Check that equality and inequality for the type extension incorporate
   -- the predefined equality operators for the extended component type
   ---------------------------------------------------------------------
   if Dated_Rec2 = Dated_Rec3 then
      Report.Failed ("Nonlimited tagged record: " &
		     "Record equality was not extended with component " &
		     "equality");
   end if;

   if not (Dated_Rec2 /= Dated_Rec3) then
      Report.Failed ("Nonlimited tagged record: " &
		     "Record inequality was not extended with component " &
		     "equality");
   end if;

   ---------------------------------------------------------------------
   C340001_1.Add_To (List1, 1);
   C340001_1.Add_To (List1, 2);
   C340001_1.Add_To (List1, 3);
   C340001_1.Remove_From (List1);

   C340001_1.Add_To (List2, 1);
   C340001_1.Add_To (List2, 2);
   
   -- List1 contents are (2, (1, 2, 3, 0, 0, 0, 0, 0, 0, 0))
   -- List2 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0))
   
   -- List1 = List2 using user-defined equality
   -- List1 /= List2 using predefined equality

   ---------------------------------------------------------------------
   -- Check that "=" and "/=" for the parent type call the user-defined
   -- operation
   ---------------------------------------------------------------------
   if not (List1 = List2) then
      Report.Failed ("Limited tagged record   : " &
		     "User-defined equality incorrectly implemented " );
   end if;
   
   if List1 /= List2 then
      Report.Failed ("Limited tagged record   : " &
		     "User-defined equality incorrectly implemented " );
   end if;

   ---------------------------------------------------------------------
   -- RList1 and RList2 are made equal but "different" by adding
   -- a nonzero value to RList1 then removing it. Removal updates
   -- the list Length only, not its contents. The two lists will be
   -- equal according to the defined list abstraction, but the records
   -- will contain differing component values.

   C340001_1.Add_To (RList1, 1);
   C340001_1.Add_To (RList1, 2);
   C340001_1.Add_To (RList1, 3);
   C340001_1.Remove_From (RList1);

   C340001_1.Add_To (RList2, 1);
   C340001_1.Add_To (RList2, 2);

   C340001_1.Add_To (RList3, 1);
   C340001_1.Add_To (RList3, 2);

   C340001_1.Revise (RList3);

   -- RList1 contents are (2, (1, 2, 3, 0, 0, 0, 0, 0, 0, 0), 'A')
   -- RList2 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0), 'A')
   -- RList3 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0), 'B')
   
   -- RList1 = RList2 if List."=" inherited
   -- RList2 /= RList3 if List."=" inherited and extended with Character "="

   ---------------------------------------------------------------------
   -- Check that "=" and "/=" are the user-defined operations inherited
   -- from the parent type.
   ---------------------------------------------------------------------
   if not (RList1 = RList2) then
      Report.Failed ("Limited tagged record   : " &
		     "User-defined equality was not inherited");
   end if;

   if RList1 /= RList2 then
      Report.Failed ("Limited tagged record   : " &
		     "User-defined inequality was not inherited");
   end if;
   ---------------------------------------------------------------------
   -- Check that "=" and "/=" for the type extension are NOT extended
   -- with the predefined equality operators for the extended component.
   -- A limited type extension should inherit the parent equality operation
   -- as is.
   ---------------------------------------------------------------------
   if not (RList2 = RList3) then
      Report.Failed ("Limited tagged record   : " &
		     "Inherited equality operation was extended with " &
		     "component equality");
   end if;

   if RList2 /= RList3 then
      Report.Failed ("Limited tagged record   : " &
		     "Inherited inequality operation was extended with " &
		     "component equality");
   end if;

   ---------------------------------------------------------------------
   -- Check that "=" and "/=" for the parent type call the user-defined
   -- operation
   ---------------------------------------------------------------------
   if not (Current = Last) then
      Report.Failed ("Variant record          : " &
		     "User-defined equality did not override predefined " &
		     "equality");
   end if;
   
   if Current /= Last then
      Report.Failed ("Variant record          : " &
		     "User-defined inequality did not override predefined " &
		     "inequality");
   end if;

   ---------------------------------------------------------------------
   -- Check that user-defined equality was incorporated and extended
   -- with equality of extended components.
   ---------------------------------------------------------------------
   if not (Approval1 /= Approval2) then
      Report.Failed ("Variant record          : " &
		     "Inequality was not extended with component " &
		     "inequality");
   end if;

   if Approval1 = Approval2 then
      Report.Failed ("Variant record          : " &
		     "Equality was not extended with component " &
		     "equality");
   end if;
   
   ---------------------------------------------------------------------
   -- Check that equality and inequality for the type extension
   -- succeed despite the presence of differing variant parts.
   ---------------------------------------------------------------------
   if Approval2 = Approval3 then
      Report.Failed ("Variant record          : " &
		     "Equality succeeded even though variant parts " &
		     "in type extension differ");
   end if;

   if not (Approval2 /= Approval3) then
      Report.Failed ("Variant record          : " &
		     "Inequality failed even though variant parts " &
		     "in type extension differ");
   end if;
   
   ---------------------------------------------------------------------
   Report.Result;
   ---------------------------------------------------------------------

end C340001;