1-- C431001.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 a record aggregate can be given for a nonprivate, 28-- nonlimited record extension and that the tag of the aggregate 29-- values are initialized to the tag of the record extension. 30-- 31-- TEST DESCRIPTION: 32-- From an initial parent tagged type, several type extensions 33-- are declared. Each type extension adds components onto 34-- the existing record structure. 35-- 36-- In the main procedure, aggregates are declared in two ways. 37-- In the declarative part, aggregates are used to supply 38-- initial values for objects of specific types. In the executable 39-- part, aggregates are used directly as actual parameters to 40-- a class-wide formal parameter. 41-- 42-- The abstraction is for a catalog of recordings. A recording 43-- can be a CD or a record (vinyl). Additionally, a CD may also 44-- be a CD-ROM, containing both music and data. This type is declared 45-- as an extension to a type extension, to test that the inclusion 46-- of record components is transitive across multiple extensions. 47-- 48-- That the aggregate has the correct tag is verify by feeding 49-- it to a dispatching operation and confirming that the 50-- expected subprogram is called as a result. To accomplish this, 51-- an enumeration type is declared with an enumeration literal 52-- representing each of the declared types in the hierarchy. A value 53-- of this type is passed as a parameter to the dispatching 54-- operation which passes it along to the dispatched subprogram. 55-- Each dispatched subprogram verifies that it received the 56-- expected enumeration literal. 57-- 58-- Not quite fitting the above abstraction are several test cases 59-- for null records. These tests verify that the new syntax for 60-- null record aggregates, (null record), is supported. A type is 61-- declared which extends a null tagged type and adds components. 62-- Aggregates of this type should include associations for the 63-- components of the type extension only. Finally, a type is 64-- declared that adds a null type extension onto a non-null tagged 65-- type. The aggregate associations should remain the same. 66-- 67-- 68-- CHANGE HISTORY: 69-- 06 Dec 94 SAIC ACVC 2.0 70-- 19 Dec 94 SAIC Removed RM references from objective text. 71-- 72--! 73-- 74package C431001_0 is 75 76 -- Values of TC_Type_ID are passed through to dispatched subprogram 77 -- calls so that it can be verified that the dispatching resulted in 78 -- the expected call. 79 type TC_Type_ID is (TC_Recording, TC_CD, TC_Vinyl, TC_CD_ROM); 80 81 type Genre is (Classical, Country, Jazz, Rap, Rock, World); 82 83 type Recording is tagged record 84 Artist : String (1..20); 85 Category : Genre; 86 Length : Duration; 87 Selections : Positive; 88 end record; 89 90 function Summary (R : in Recording; 91 TC_Type : in TC_Type_ID) return String; 92 93 type Recording_Method is (Audio, Digital); 94 type CD is new Recording with record 95 Recorded : Recording_Method; 96 Mastered : Recording_Method; 97 end record; 98 99 function Summary (Disc : in CD; 100 TC_Type : in TC_Type_ID) return String; 101 102 type Playing_Speed is (LP_33, Single_45, Old_78); 103 type Vinyl is new Recording with record 104 Speed : Playing_Speed; 105 end record; 106 107 function Summary (Album : in Vinyl; 108 TC_Type : in TC_Type_ID) return String; 109 110 111 type CD_ROM is new CD with record 112 Storage : Positive; 113 end record; 114 115 function Summary (Disk : in CD_ROM; 116 TC_Type : in TC_Type_ID) return String; 117 118 function Catalog_Entry (R : in Recording'Class; 119 TC_Type : in TC_Type_ID) return String; 120 121 procedure Print (S : in String); -- provides somewhere for the 122 -- results of Catalog_Entry to 123 -- "go", so they don't get 124 -- optimized away. 125 126 -- The types and procedures declared below are not a continuation 127 -- of the Recording abstraction. These types are intended to test 128 -- support for null tagged types and type extensions. TC_Check mirrors 129 -- the operation of function Summary, above. Similarly, TC_Dispatch 130 -- mirrors the operation of Catalog_Entry. 131 132 type TC_N_Type_ID is 133 (TC_Null_Tagged, TC_Null_Extension, 134 TC_Extension_Of_Null, TC_Null_Extension_Of_Nonnull); 135 136 type Null_Tagged is tagged null record; 137 procedure TC_Check (N : in Null_Tagged; 138 TC_Type : in TC_N_Type_ID); 139 140 type Null_Extension is new Null_Tagged with null record; 141 procedure TC_Check (N : in Null_Extension; 142 TC_Type : in TC_N_Type_ID); 143 144 type Extension_Of_Null is new Null_Tagged with record 145 New_Component1 : Boolean; 146 New_Component2 : Natural; 147 end record; 148 procedure TC_Check (N : in Extension_Of_Null; 149 TC_Type : in TC_N_Type_ID); 150 151 type Null_Extension_Of_Nonnull is new Extension_Of_Null 152 with null record; 153 procedure TC_Check (N : in Null_Extension_Of_Nonnull; 154 TC_Type : in TC_N_Type_ID); 155 156 procedure TC_Dispatch (N : in Null_Tagged'Class; 157 TC_Type : in TC_N_Type_ID); 158 159end C431001_0; 160 161with Report; 162package body C431001_0 is 163 164 function Summary (R : in Recording; 165 TC_Type : in TC_Type_ID) return String is 166 begin 167 168 if TC_Type /= TC_Recording then 169 Report.Failed ("Did not dispatch on tag for tagged parent " & 170 "type Recording"); 171 end if; 172 173 return R.Artist (1..10) 174 & ' ' & Genre'Image (R.Category) (1..2) 175 & ' ' & Duration'Image (R.Length) 176 & ' ' & Integer'Image (R.Selections); 177 178 end Summary; 179 180 function Summary (Disc : in CD; 181 TC_Type : in TC_Type_ID) return String is 182 begin 183 184 if TC_Type /= TC_CD then 185 Report.Failed ("Did not dispatch on tag for type extension " & 186 "CD"); 187 end if; 188 189 return Summary (Recording (Disc), TC_Type => TC_Recording) 190 & ' ' & Recording_Method'Image(Disc.Recorded)(1) 191 & Recording_Method'Image(Disc.Mastered)(1); 192 193 end Summary; 194 195 function Summary (Album : in Vinyl; 196 TC_Type : in TC_Type_ID) return String is 197 begin 198 if TC_Type /= TC_Vinyl then 199 Report.Failed ("Did not dispatch on tag for type extension " & 200 "Vinyl"); 201 end if; 202 203 case Album.Speed is 204 when LP_33 => 205 return Summary (Recording (Album), TC_Type => TC_Recording) 206 & " 33"; 207 when Single_45 => 208 return Summary (Recording (Album), TC_Type => TC_Recording) 209 & " 45"; 210 when Old_78 => 211 return Summary (Recording (Album), TC_Type => TC_Recording) 212 & " 78"; 213 end case; 214 215 end Summary; 216 217 function Summary (Disk : in CD_ROM; 218 TC_Type : in TC_Type_ID) return String is 219 begin 220 if TC_Type /= TC_CD_ROM then 221 Report.Failed ("Did not dispatch on tag for type extension " & 222 "CD_ROM. This is an extension of the type " & 223 "extension CD"); 224 end if; 225 226 return Summary (Recording(Disk), TC_Type => TC_Recording) 227 & ' ' & Integer'Image (Disk.Storage) & 'K'; 228 229 end Summary; 230 231 function Catalog_Entry (R : in Recording'Class; 232 TC_Type : in TC_Type_ID) return String is 233 begin 234 return Summary (R, TC_Type); -- dispatched call 235 end Catalog_Entry; 236 237 procedure Print (S : in String) is 238 T : String (1..S'Length) := Report.Ident_Str (S); 239 begin 240 -- Ada.Text_IO.Put_Line (S); 241 null; 242 end Print; 243 244 -- Bodies for null type checks 245 procedure TC_Check (N : in Null_Tagged; 246 TC_Type : in TC_N_Type_ID) is 247 begin 248 if TC_Type /= TC_Null_Tagged then 249 Report.Failed ("Did not dispatch on tag for null tagged " & 250 "type Null_Tagged"); 251 end if; 252 end TC_Check; 253 254 procedure TC_Check (N : in Null_Extension; 255 TC_Type : in TC_N_Type_ID) is 256 begin 257 if TC_Type /= TC_Null_Extension then 258 Report.Failed ("Did not dispatch on tag for null tagged " & 259 "type extension Null_Extension"); 260 end if; 261 end TC_Check; 262 263 procedure TC_Check (N : in Extension_Of_Null; 264 TC_Type : in TC_N_Type_ID) is 265 begin 266 if TC_Type /= TC_Extension_Of_Null then 267 Report.Failed 268 ("Did not dispatch on tag for extension of null parent" & 269 "type"); 270 end if; 271 end TC_Check; 272 273 procedure TC_Check (N : in Null_Extension_Of_Nonnull; 274 TC_Type : in TC_N_Type_ID) is 275 begin 276 if TC_Type /= TC_Null_Extension_Of_Nonnull then 277 Report.Failed 278 ("Did not dispatch on tag for null extension of nonnull " & 279 "parent type"); 280 end if; 281 end TC_Check; 282 283 procedure TC_Dispatch (N : in Null_Tagged'Class; 284 TC_Type : in TC_N_Type_ID) is 285 begin 286 TC_Check (N, TC_Type); -- dispatched call 287 end TC_Dispatch; 288 289end C431001_0; 290 291 292with C431001_0; 293with Report; 294procedure C431001 is 295 296 -- Tagged type 297 -- Named component associations 298 DAT : C431001_0.Recording := 299 (Artist => "Aerosmith ", 300 Category => C431001_0.Rock, 301 Length => 48.5, 302 Selections => 10); 303 304 -- Type extensions 305 -- Named component associations 306 Disc1 : C431001_0.CD := 307 (Artist => "London Symphony ", 308 Category => C431001_0.Classical, 309 Length => 55.0, 310 Selections => 4, 311 Recorded => C431001_0.Digital, 312 Mastered => C431001_0.Digital); 313 314 -- Named component associations with others 315 Disc2 : C431001_0.CD := 316 (Artist => "Pink Floyd ", 317 Category => C431001_0.Rock, 318 Length => 51.8, 319 Selections => 5, 320 others => C431001_0.Audio); -- Recorded 321 -- Mastered 322 323 -- Positional component associations 324 Album1 : C431001_0.Vinyl := 325 ("Hammer ", -- Artist 326 C431001_0.Rap, -- Category 327 46.2, -- Length 328 9, -- Selections 329 C431001_0.LP_33); -- Speed 330 331 -- Mixed positional and named component associations 332 -- Named component associations out of order 333 Album2 : C431001_0.Vinyl := 334 ("Balinese Gamelan ", -- Artist 335 C431001_0.World, -- Category 336 42.6, -- Length 337 14, -- Selections 338 C431001_0.LP_33); -- Speed 339 340 -- Type extension, parent is also type extension 341 -- Named notation, components out of order 342 Data : C431001_0.CD_ROM := 343 (Storage => 140, 344 Mastered => C431001_0.Digital, 345 Category => C431001_0.Rock, 346 Selections => 10, 347 Recorded => C431001_0.Digital, 348 Artist => "Black, Clint ", 349 Length => 48.5); 350 351 -- Null tagged type 352 Null_Rec : C431001_0.Null_Tagged := (null record); 353 354 -- Null type extension 355 Null_Ext : C431001_0.Null_Extension := (null record); 356 357 -- Nonnull extension of null parent 358 Ext_Of_Null : C431001_0.Extension_Of_Null := (True, 0); 359 360 -- Null extension of nonnull parent 361 Null_Ext_Of_Nonnull : C431001_0.Null_Extension_Of_Nonnull 362 := (False, 1); 363 364begin 365 366 Report.Test ("C431001", "Aggregate values for type extensions"); 367 368 C431001_0.Print (C431001_0.Catalog_Entry (DAT, C431001_0.TC_Recording)); 369 C431001_0.Print (C431001_0.Catalog_Entry (Disc1, C431001_0.TC_CD)); 370 C431001_0.Print (C431001_0.Catalog_Entry (Disc2, C431001_0.TC_CD)); 371 C431001_0.Print (C431001_0.Catalog_Entry (Album1, C431001_0.TC_Vinyl)); 372 C431001_0.Print (C431001_0.Catalog_Entry (Album2, C431001_0.TC_Vinyl)); 373 C431001_0.Print (C431001_0.Catalog_Entry (Data, C431001_0.TC_CD_ROM)); 374 375 C431001_0.TC_Dispatch (Null_Rec, C431001_0.TC_Null_Tagged); 376 C431001_0.TC_Dispatch (Null_Ext, C431001_0.TC_Null_Extension); 377 C431001_0.TC_Dispatch (Ext_Of_Null, C431001_0.TC_Extension_Of_Null); 378 C431001_0.TC_Dispatch 379 (Null_Ext_Of_Nonnull, C431001_0.TC_Null_Extension_Of_Nonnull); 380 381 -- Tagged type 382 -- Named component associations 383 C431001_0.Print (C431001_0.Catalog_Entry 384 (TC_Type => C431001_0.TC_Recording, 385 R => C431001_0.Recording'(Artist => "Zappa, Frank ", 386 Category => C431001_0.Rock, 387 Length => 70.0, 388 Selections => 38))); 389 390 -- Type extensions 391 -- Named component associations 392 C431001_0.Print (C431001_0.Catalog_Entry 393 (TC_Type => C431001_0.TC_CD, 394 R => C431001_0.CD'(Artist => "Dog, Snoop Doggy ", 395 Category => C431001_0.Rap, 396 Length => 37.3, 397 Selections => 8, 398 Recorded => C431001_0.Audio, 399 Mastered => C431001_0.Digital))); 400 401 -- Named component associations with others 402 C431001_0.Print (C431001_0.Catalog_Entry 403 (TC_Type => C431001_0.TC_CD, 404 R => C431001_0.CD'(Artist => "Judd, Winona ", 405 Category => C431001_0.Country, 406 Length => 51.2, 407 Selections => 11, 408 others => C431001_0.Digital))); -- Recorded 409 -- Mastered 410 411 -- Positional component associations 412 C431001_0.Print (C431001_0.Catalog_Entry 413 (TC_Type => C431001_0.TC_Vinyl, 414 R => C431001_0.Vinyl'("Davis, Miles ", -- Artist 415 C431001_0.Jazz, -- Category 416 50.4, -- Length 417 10, -- Selections 418 C431001_0.LP_33))); -- Speed 419 420 -- Mixed positional and named component associations 421 -- Named component associations out of order 422 C431001_0.Print (C431001_0.Catalog_Entry 423 (TC_Type => C431001_0.TC_Vinyl, 424 R => C431001_0.Vinyl'("Zamfir ", -- Artist 425 C431001_0.World, -- Category 426 Speed => C431001_0.LP_33, 427 Selections => 14, 428 Length => 56.5))); 429 430 -- Type extension, parent is also type extension 431 -- Named notation, components out of order 432 C431001_0.Print (C431001_0.Catalog_Entry 433 (TC_Type => C431001_0.TC_CD_ROM, 434 R => C431001_0.CD_ROM'(Storage => 720, 435 Category => C431001_0.Classical, 436 Recorded => C431001_0.Digital, 437 Artist => "Baltimore Symphony ", 438 Length => 68.9, 439 Mastered => C431001_0.Digital, 440 Selections => 5))); 441 442 -- Null tagged type 443 C431001_0.TC_Dispatch 444 (TC_Type => C431001_0.TC_Null_Tagged, 445 N => C431001_0.Null_Tagged'(null record)); 446 447 -- Null type extension 448 C431001_0.TC_Dispatch 449 (TC_Type => C431001_0.TC_Null_Extension, 450 N => C431001_0.Null_Extension'(null record)); 451 452 -- Nonnull extension of null parent 453 C431001_0.TC_Dispatch 454 (TC_Type => C431001_0.TC_Extension_Of_Null, 455 N => C431001_0.Extension_Of_Null'(True, 3)); 456 457 -- Null extension of nonnull parent 458 C431001_0.TC_Dispatch 459 (TC_Type => C431001_0.TC_Extension_Of_Null, 460 N => C431001_0.Extension_Of_Null'(False, 4)); 461 462 Report.Result; 463 464end C431001; 465