1-- C432001.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-- 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. 34-- 35-- TEST DESCRIPTION: 36-- 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 44-- extensions. 45-- 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. 50-- 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. 54-- 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. 60-- 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 66-- values. 67-- 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. 72-- 73-- 74-- CHANGE HISTORY: 75-- 06 Dec 94 SAIC ACVC 2.0 76-- 77--! 78 79with Report; 80package C432001_0 is 81 82 type Eras is (Precambrian, Paleozoic, Mesozoic, Cenozoic); 83 84 type N is tagged record 85 How_Long_Ago : Natural := Report.Ident_Int(1); 86 Era : Eras := Cenozoic; 87 end record; 88 89 function Check (Rec : in N; 90 N : in Natural; 91 E : in Eras) return Boolean; 92 93 type P is tagged private; 94 95 function Check (Rec : in P) return Boolean; 96 97private 98 99 type P is tagged record 100 How_Long_Ago : Natural := Report.Ident_Int(150); 101 Era : Eras := Mesozoic; 102 end record; 103 104end C432001_0; 105 106package body C432001_0 is 107 108 function Check (Rec : in P) return Boolean is 109 begin 110 return Rec.How_Long_Ago = 150 and Rec.Era = Mesozoic; 111 end Check; 112 113 function Check (Rec : in N; 114 N : in Natural; 115 E : in Eras) return Boolean is 116 begin 117 return Rec.How_Long_Ago = N and Rec.Era = E; 118 end Check; 119 120end C432001_0; 121 122with C432001_0; 123package C432001_1 is 124 125 type Periods is 126 (Aphebian, Helikian, Hadrynian, 127 Cambrian, Ordovician, Silurian, Devonian, Carboniferous, Permian, 128 Triassic, Jurassic, Cretaceous, 129 Tertiary, Quaternary); 130 131 type N_N is new C432001_0.N with record 132 Period : Periods := C432001_1.Quaternary; 133 end record; 134 135 function Check (Rec : in N_N; 136 N : in Natural; 137 E : in C432001_0.Eras; 138 P : in Periods) return Boolean; 139 140 type N_P is new C432001_0.N with private; 141 142 function Check (Rec : in N_P) return Boolean; 143 144 type P_N is new C432001_0.P with record 145 Period : Periods := C432001_1.Jurassic; 146 end record; 147 148 function Check (Rec : in P_N; 149 P : in Periods) return Boolean; 150 151 type P_P is new C432001_0.P with private; 152 153 function Check (Rec : in P_P) return Boolean; 154 155 type P_P_Null is new C432001_0.P with null record; 156 157private 158 159 type N_P is new C432001_0.N with record 160 Period : Periods := C432001_1.Quaternary; 161 end record; 162 163 type P_P is new C432001_0.P with record 164 Period : Periods := C432001_1.Jurassic; 165 end record; 166 167end C432001_1; 168 169with Report; 170package body C432001_1 is 171 172 function Check (Rec : in N_N; 173 N : in Natural; 174 E : in C432001_0.Eras; 175 P : in Periods) return Boolean is 176 begin 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"); 181 end if; 182 return Rec.Period = P; 183 end Check; 184 185 186 function Check (Rec : in N_P) return Boolean is 187 begin 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"); 192 end if; 193 return Rec.Period = C432001_1.Quaternary; 194 end Check; 195 196 function Check (Rec : in P_N; 197 P : in Periods) return Boolean is 198 begin 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"); 203 end if; 204 return Rec.Period = P; 205 end Check; 206 207 function Check (Rec : in P_P) return Boolean is 208 begin 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"); 213 end if; 214 return Rec.Period = C432001_1.Jurassic; 215 end Check; 216 217end C432001_1; 218 219with C432001_0; 220with C432001_1; 221package C432001_2 is 222 223 -- All types herein are nonprivate extensions, since aggregates 224 -- cannot be given for private extensions 225 226 type N_N_N is new C432001_1.N_N with record 227 Sample_On_Loan : Boolean; 228 end record; 229 230 function Check (Rec : in N_N_N; 231 N : in Natural; 232 E : in C432001_0.Eras; 233 P : in C432001_1.Periods; 234 B : in Boolean) return Boolean; 235 236 type N_P_N is new C432001_1.N_P with record 237 Sample_On_Loan : Boolean; 238 end record; 239 240 function Check (Rec : in N_P_N; 241 B : Boolean) return Boolean; 242 243 type P_N_N is new C432001_1.P_N with record 244 Sample_On_Loan : Boolean; 245 end record; 246 247 function Check (Rec : in P_N_N; 248 P : in C432001_1.Periods; 249 B : Boolean) return Boolean; 250 251 type P_P_N is new C432001_1.P_P with record 252 Sample_On_Loan : Boolean; 253 end record; 254 255 function Check (Rec : in P_P_N; 256 B : Boolean) return Boolean; 257 258end C432001_2; 259 260with Report; 261package body C432001_2 is 262 263 -- direct access to operator 264 use type C432001_1.Periods; 265 266 267 function Check (Rec : in N_N_N; 268 N : in Natural; 269 E : in C432001_0.Eras; 270 P : in C432001_1.Periods; 271 B : in Boolean) return Boolean is 272 begin 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 " & 276 "failed"); 277 end if; 278 return Rec.Sample_On_Loan = B; 279 end Check; 280 281 282 function Check (Rec : in N_P_N; 283 B : Boolean) return Boolean is 284 begin 285 if not C432001_1.Check (C432001_1.N_P (Rec)) then 286 Report.Failed ("Conversion to parent " & 287 "private type extension " & 288 "failed"); 289 end if; 290 return Rec.Sample_On_Loan = B; 291 end Check; 292 293 function Check (Rec : in P_N_N; 294 P : in C432001_1.Periods; 295 B : Boolean) return Boolean is 296 begin 297 if not C432001_1.Check (C432001_1.P_N (Rec), P) then 298 Report.Failed ("Conversion to parent " & 299 "nonprivate type extension " & 300 "failed"); 301 end if; 302 return Rec.Sample_On_Loan = B; 303 end Check; 304 305 function Check (Rec : in P_P_N; 306 B : Boolean) return Boolean is 307 begin 308 if not C432001_1.Check (C432001_1.P_P (Rec)) then 309 Report.Failed ("Conversion to parent " & 310 "private type extension " & 311 "failed"); 312 end if; 313 return Rec.Sample_On_Loan = B; 314 end Check; 315 316end C432001_2; 317 318 319with C432001_0; 320with C432001_1; 321with C432001_2; 322with Report; 323procedure C432001 is 324 325 N_Object : C432001_0.N := (How_Long_Ago => Report.Ident_Int(375), 326 Era => C432001_0.Paleozoic); 327 328 P_Object : C432001_0.P; -- default value is (150, 329 -- C432001_0.Mesozoic) 330 331 N_N_Object : C432001_1.N_N := 332 (N_Object with Period => C432001_1.Devonian); 333 334 P_N_Object : C432001_1.P_N := 335 (P_Object with Period => C432001_1.Jurassic); 336 337 N_P_Object : C432001_1.N_P; -- default is (1, 338 -- C432001_0.Cenozoic, 339 -- C432001_1.Quaternary) 340 341 P_P_Object : C432001_1.P_P; -- default is (150, 342 -- C432001_0.Mesozoic, 343 -- C432001_1.Jurassic) 344 345 P_P_Null_Ob:C432001_1.P_P_Null := (P_Object with null record); 346 347 N_N_N_Object : C432001_2.N_N_N := 348 (N_N_Object with Sample_On_Loan => Report.Ident_Bool(True)); 349 350 N_P_N_Object : C432001_2.N_P_N := 351 (N_P_Object with Sample_On_Loan => Report.Ident_Bool(False)); 352 353 P_N_N_Object : C432001_2.P_N_N := 354 (P_N_Object with Sample_On_Loan => Report.Ident_Bool(True)); 355 356 P_P_N_Object : C432001_2.P_P_N := 357 (P_P_Object with Sample_On_Loan => Report.Ident_Bool(False)); 358 359 P_N_Object_2 : C432001_1.P_N := (C432001_0.P(P_N_N_Object) 360 with C432001_1.Carboniferous); 361 362 N_N_Object_2 : C432001_1.N_N := (C432001_0.N'(42,C432001_0.Precambrian) 363 with C432001_1.Carboniferous); 364 365begin 366 367 Report.Test ("C432001", "Extension aggregates"); 368 369 -- check ultimate ancestor types 370 371 if not C432001_0.Check (N_Object, 372 375, 373 C432001_0.Paleozoic) then 374 Report.Failed ("Object of " & 375 "nonprivate type " & 376 "failed content check"); 377 end if; 378 379 if not C432001_0.Check (P_Object) then 380 Report.Failed ("Object of " & 381 "private type " & 382 "failed content check"); 383 end if; 384 385 -- check direct type extensions 386 387 if not C432001_1.Check (N_N_Object, 388 375, 389 C432001_0.Paleozoic, 390 C432001_1.Devonian) then 391 Report.Failed ("Object of " & 392 "nonprivate extension of nonprivate type " & 393 "failed content check"); 394 end if; 395 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"); 400 end if; 401 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"); 407 end if; 408 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"); 413 end if; 414 415 if not C432001_1.Check (P_P_Null_Ob) then 416 Report.Failed ("Object of " & 417 "private type " & 418 "failed content check"); 419 end if; 420 421 422 -- check direct extensions of extensions 423 424 if not C432001_2.Check (N_N_N_Object, 425 375, 426 C432001_0.Paleozoic, 427 C432001_1.Devonian, 428 True) then 429 Report.Failed ("Object of " & 430 "nonprivate extension of nonprivate extension " & 431 "(of nonprivate parent) " & 432 "failed content check"); 433 end if; 434 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"); 440 end if; 441 442 if not C432001_2.Check (P_N_N_Object, 443 C432001_1.Jurassic, 444 True) then 445 Report.Failed ("Object of " & 446 "nonprivate extension of nonprivate extension " & 447 "(of private parent) " & 448 "failed content check"); 449 end if; 450 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"); 456 end if; 457 458 -- check that the extension aggregate may specify an expression of 459 -- a "grandparent" ancestor type 460 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) 464 465 N_N_N_Object := 466 (N_Object with Period => C432001_1.Devonian, 467 Sample_On_Loan => Report.Ident_Bool(True)); 468 469 if not C432001_2.Check (N_N_N_Object, 470 375, 471 C432001_0.Paleozoic, 472 C432001_1.Devonian, 473 True) then 474 Report.Failed ("Object of " & 475 "nonprivate extension " & 476 "of nonprivate ancestor " & 477 "failed content check"); 478 end if; 479 480 P_N_N_Object := 481 (P_Object with Period => C432001_1.Jurassic, 482 Sample_On_Loan => Report.Ident_Bool(True)); 483 484 if not C432001_2.Check (P_N_N_Object, 485 C432001_1.Jurassic, 486 True) then 487 Report.Failed ("Object of " & 488 "nonprivate extension " & 489 "of private ancestor " & 490 "failed content check"); 491 end if; 492 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"); 499 end if; 500 501 if not C432001_1.Check (N_N_Object_2, 502 42, 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"); 508 end if; 509 510 Report.Result; 511 512end C432001; 513