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.
28 -- Check that extension aggregates may be used to specify values
29 -- for types that are record extensions. Check that the
30 -- type of the ancestor expression may be any nonlimited type that
31 -- is a record extension, including private types and private
32 -- extensions. Check that the type for the aggregate is
33 -- derived from the type of the ancestor expression.
37 -- Two progenitor nonlimited record types are declared, one
38 -- nonprivate and one private. Using these as parent types,
39 -- all possible combinations of record extensions are declared
40 -- (Nonprivate record extension of nonprivate type, private
41 -- extension of nonprivate type, nonprivate record extension of
42 -- private type, and private extension of private type). Finally,
43 -- each of these types is extended using nonprivate record
46 -- Extension of private types is done in packages other than
47 -- the ones containing the parent declaration. This is done
48 -- to eliminate errors with extension of the partial view of
49 -- a type, which is not an objective of this test.
51 -- All components of private types and private extensions are given
52 -- default values. This eliminates the need for separate subprograms
53 -- whose sole purpose is to place a value into a private record type.
55 -- Types that have been extended are checked using an object of their
56 -- parent type as the ancestor expression. For those types that
57 -- have been extended twice, using only nonprivate record extensions,
58 -- a check is made using an object of their grandparent type as
59 -- the ancestor expression.
61 -- For each type, a subprogram is defined which checks the contents
62 -- of the parameter, which is a value of the record extension.
63 -- Components of nonprivate record extensions are checked against
64 -- passed-in parameters of the component type. Components of private
65 -- extensions are checked to ensure that they maintain their initial
68 -- To check that the aggregate's type is derived from its ancestor,
69 -- each Check subprogram in turn calls the Check subprogram for
70 -- its parent type. Explicit conversion is used to convert the
71 -- record extension to the parent type.
75 -- 06 Dec 94 SAIC ACVC 2.0
82 type Eras
is (Precambrian
, Paleozoic
, Mesozoic
, Cenozoic
);
84 type N
is tagged record
85 How_Long_Ago
: Natural := Report
.Ident_Int
(1);
86 Era
: Eras
:= Cenozoic
;
89 function Check
(Rec
: in N
;
91 E
: in Eras
) return Boolean;
93 type P
is tagged private;
95 function Check
(Rec
: in P
) return Boolean;
99 type P
is tagged record
100 How_Long_Ago
: Natural := Report
.Ident_Int
(150);
101 Era
: Eras
:= Mesozoic
;
106 package body C432001_0
is
108 function Check
(Rec
: in P
) return Boolean is
110 return Rec
.How_Long_Ago
= 150 and Rec
.Era
= Mesozoic
;
113 function Check
(Rec
: in N
;
115 E
: in Eras
) return Boolean is
117 return Rec
.How_Long_Ago
= N
and Rec
.Era
= E
;
126 (Aphebian
, Helikian
, Hadrynian
,
127 Cambrian
, Ordovician
, Silurian
, Devonian
, Carboniferous
, Permian
,
128 Triassic
, Jurassic
, Cretaceous
,
129 Tertiary
, Quaternary
);
131 type N_N
is new C432001_0
.N
with record
132 Period
: Periods
:= C432001_1
.Quaternary
;
135 function Check
(Rec
: in N_N
;
137 E
: in C432001_0
.Eras
;
138 P
: in Periods
) return Boolean;
140 type N_P
is new C432001_0
.N
with private;
142 function Check
(Rec
: in N_P
) return Boolean;
144 type P_N
is new C432001_0
.P
with record
145 Period
: Periods
:= C432001_1
.Jurassic
;
148 function Check
(Rec
: in P_N
;
149 P
: in Periods
) return Boolean;
151 type P_P
is new C432001_0
.P
with private;
153 function Check
(Rec
: in P_P
) return Boolean;
155 type P_P_Null
is new C432001_0
.P
with null record;
159 type N_P
is new C432001_0
.N
with record
160 Period
: Periods
:= C432001_1
.Quaternary
;
163 type P_P
is new C432001_0
.P
with record
164 Period
: Periods
:= C432001_1
.Jurassic
;
170 package body C432001_1
is
172 function Check
(Rec
: in N_N
;
174 E
: in C432001_0
.Eras
;
175 P
: in Periods
) return Boolean is
177 if not C432001_0
.Check
(C432001_0
.N
(Rec
), N
, E
) then
178 Report
.Failed
("Conversion to parent type of " &
179 "nonprivate portion of " &
180 "nonprivate extension failed");
182 return Rec
.Period
= P
;
186 function Check
(Rec
: in N_P
) return Boolean is
188 if not C432001_0
.Check
(C432001_0
.N
(Rec
), 1, C432001_0
.Cenozoic
) then
189 Report
.Failed
("Conversion to parent type of " &
190 "nonprivate portion of " &
191 "private extension failed");
193 return Rec
.Period
= C432001_1
.Quaternary
;
196 function Check
(Rec
: in P_N
;
197 P
: in Periods
) return Boolean is
199 if not C432001_0
.Check
(C432001_0
.P
(Rec
)) then
200 Report
.Failed
("Conversion to parent type of " &
201 "private portion of " &
202 "nonprivate extension failed");
204 return Rec
.Period
= P
;
207 function Check
(Rec
: in P_P
) return Boolean is
209 if not C432001_0
.Check
(C432001_0
.P
(Rec
)) then
210 Report
.Failed
("Conversion to parent type of " &
211 "private portion of " &
212 "private extension failed");
214 return Rec
.Period
= C432001_1
.Jurassic
;
223 -- All types herein are nonprivate extensions, since aggregates
224 -- cannot be given for private extensions
226 type N_N_N
is new C432001_1
.N_N
with record
227 Sample_On_Loan
: Boolean;
230 function Check
(Rec
: in N_N_N
;
232 E
: in C432001_0
.Eras
;
233 P
: in C432001_1
.Periods
;
234 B
: in Boolean) return Boolean;
236 type N_P_N
is new C432001_1
.N_P
with record
237 Sample_On_Loan
: Boolean;
240 function Check
(Rec
: in N_P_N
;
241 B
: Boolean) return Boolean;
243 type P_N_N
is new C432001_1
.P_N
with record
244 Sample_On_Loan
: Boolean;
247 function Check
(Rec
: in P_N_N
;
248 P
: in C432001_1
.Periods
;
249 B
: Boolean) return Boolean;
251 type P_P_N
is new C432001_1
.P_P
with record
252 Sample_On_Loan
: Boolean;
255 function Check
(Rec
: in P_P_N
;
256 B
: Boolean) return Boolean;
261 package body C432001_2
is
263 -- direct access to operator
264 use type C432001_1
.Periods
;
267 function Check
(Rec
: in N_N_N
;
269 E
: in C432001_0
.Eras
;
270 P
: in C432001_1
.Periods
;
271 B
: in Boolean) return Boolean is
273 if not C432001_1
.Check
(C432001_1
.N_N
(Rec
), N
, E
, P
) then
274 Report
.Failed
("Conversion to parent " &
275 "nonprivate type extension " &
278 return Rec
.Sample_On_Loan
= B
;
282 function Check
(Rec
: in N_P_N
;
283 B
: Boolean) return Boolean is
285 if not C432001_1
.Check
(C432001_1
.N_P
(Rec
)) then
286 Report
.Failed
("Conversion to parent " &
287 "private type extension " &
290 return Rec
.Sample_On_Loan
= B
;
293 function Check
(Rec
: in P_N_N
;
294 P
: in C432001_1
.Periods
;
295 B
: Boolean) return Boolean is
297 if not C432001_1
.Check
(C432001_1
.P_N
(Rec
), P
) then
298 Report
.Failed
("Conversion to parent " &
299 "nonprivate type extension " &
302 return Rec
.Sample_On_Loan
= B
;
305 function Check
(Rec
: in P_P_N
;
306 B
: Boolean) return Boolean is
308 if not C432001_1
.Check
(C432001_1
.P_P
(Rec
)) then
309 Report
.Failed
("Conversion to parent " &
310 "private type extension " &
313 return Rec
.Sample_On_Loan
= B
;
325 N_Object
: C432001_0
.N
:= (How_Long_Ago
=> Report
.Ident_Int
(375),
326 Era
=> C432001_0
.Paleozoic
);
328 P_Object
: C432001_0
.P
; -- default value is (150,
329 -- C432001_0.Mesozoic)
331 N_N_Object
: C432001_1
.N_N
:=
332 (N_Object
with Period
=> C432001_1
.Devonian
);
334 P_N_Object
: C432001_1
.P_N
:=
335 (P_Object
with Period
=> C432001_1
.Jurassic
);
337 N_P_Object
: C432001_1
.N_P
; -- default is (1,
338 -- C432001_0.Cenozoic,
339 -- C432001_1.Quaternary)
341 P_P_Object
: C432001_1
.P_P
; -- default is (150,
342 -- C432001_0.Mesozoic,
343 -- C432001_1.Jurassic)
345 P_P_Null_Ob
:C432001_1
.P_P_Null
:= (P_Object
with null record);
347 N_N_N_Object
: C432001_2
.N_N_N
:=
348 (N_N_Object
with Sample_On_Loan
=> Report
.Ident_Bool
(True));
350 N_P_N_Object
: C432001_2
.N_P_N
:=
351 (N_P_Object
with Sample_On_Loan
=> Report
.Ident_Bool
(False));
353 P_N_N_Object
: C432001_2
.P_N_N
:=
354 (P_N_Object
with Sample_On_Loan
=> Report
.Ident_Bool
(True));
356 P_P_N_Object
: C432001_2
.P_P_N
:=
357 (P_P_Object
with Sample_On_Loan
=> Report
.Ident_Bool
(False));
359 P_N_Object_2
: C432001_1
.P_N
:= (C432001_0
.P
(P_N_N_Object
)
360 with C432001_1
.Carboniferous
);
362 N_N_Object_2
: C432001_1
.N_N
:= (C432001_0
.N
'(42,C432001_0.Precambrian)
363 with C432001_1.Carboniferous);
367 Report.Test ("C432001", "Extension aggregates");
369 -- check ultimate ancestor types
371 if not C432001_0.Check (N_Object,
373 C432001_0.Paleozoic) then
374 Report.Failed ("Object of " &
376 "failed content check");
379 if not C432001_0.Check (P_Object) then
380 Report.Failed ("Object of " &
382 "failed content check");
385 -- check direct type extensions
387 if not C432001_1.Check (N_N_Object,
390 C432001_1.Devonian) then
391 Report.Failed ("Object of " &
392 "nonprivate extension of nonprivate type " &
393 "failed content check");
396 if not C432001_1.Check (N_P_Object) then
397 Report.Failed ("Object of " &
398 "private extension of nonprivate type " &
399 "failed content check");
402 if not C432001_1.Check (P_N_Object,
403 C432001_1.Jurassic) then
404 Report.Failed ("Object of " &
405 "nonprivate extension of private type " &
406 "failed content check");
409 if not C432001_1.Check (P_P_Object) then
410 Report.Failed ("Object of " &
411 "private extension of private type " &
412 "failed content check");
415 if not C432001_1.Check (P_P_Null_Ob) then
416 Report.Failed ("Object of " &
418 "failed content check");
422 -- check direct extensions of extensions
424 if not C432001_2.Check (N_N_N_Object,
429 Report.Failed ("Object of " &
430 "nonprivate extension of nonprivate extension " &
431 "(of nonprivate parent) " &
432 "failed content check");
435 if not C432001_2.Check (N_P_N_Object, False) then
436 Report.Failed ("Object of " &
437 "nonprivate extension of private extension " &
438 "(of nonprivate parent) " &
439 "failed content check");
442 if not C432001_2.Check (P_N_N_Object,
445 Report.Failed ("Object of " &
446 "nonprivate extension of nonprivate extension " &
447 "(of private parent) " &
448 "failed content check");
451 if not C432001_2.Check (P_P_N_Object, False) then
452 Report.Failed ("Object of " &
453 "nonprivate extension of private extension " &
454 "(of private parent) " &
455 "failed content check");
458 -- check that the extension aggregate may specify an expression of
459 -- a "grandparent" ancestor type
461 -- types tested are derived through nonprivate extensions only
462 -- (extension aggregates are not allowed if the path from the
463 -- ancestor type wanders through a private extension)
466 (N_Object with Period => C432001_1.Devonian,
467 Sample_On_Loan => Report.Ident_Bool(True));
469 if not C432001_2.Check (N_N_N_Object,
474 Report.Failed ("Object of " &
475 "nonprivate extension " &
476 "of nonprivate ancestor " &
477 "failed content check");
481 (P_Object with Period => C432001_1.Jurassic,
482 Sample_On_Loan => Report.Ident_Bool(True));
484 if not C432001_2.Check (P_N_N_Object,
487 Report.Failed ("Object of " &
488 "nonprivate extension " &
489 "of private ancestor " &
490 "failed content check");
493 -- Check additional cases
494 if not C432001_1.Check (P_N_Object_2,
495 C432001_1.Carboniferous) then
496 Report.Failed ("Additional Object of " &
497 "nonprivate extension of private type " &
498 "failed content check");
501 if not C432001_1.Check (N_N_Object_2,
503 C432001_0.Precambrian,
504 C432001_1.Carboniferous) then
505 Report.Failed ("Additional Object of " &
506 "nonprivate extension of nonprivate type " &
507 "failed content check");