Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/c3/c340001.a @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
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; |