1-- C391002.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 structures nesting discriminated records as 28-- components in record extension are correctly supported. 29-- Check that record extensions inherit all the visible components 30-- of their ancestor types. 31-- Check that discriminants are correctly inherited. 32-- 33-- TEST DESCRIPTION: 34-- This test defines a simple class hierarchy, where the final 35-- derivations exercise the different possible "permissions" available 36-- to a designer. Extension aggregates for discriminated types are used 37-- to set values of these final types. The key difference between 38-- this test and C391001 is that the types are visible, and allow the 39-- creation of complex discriminated extension aggregates. Another 40-- layer of derivation is present to more robustly check that the 41-- inheritance is correctly supported. 42-- 43-- 44-- CHANGE HISTORY: 45-- 06 Dec 94 SAIC ACVC 2.0 46-- 16 Dec 94 SAIC Removed offending parenthesis in aggregate 47-- extensions, corrected typo: TC_MC SB TC_PC, 48-- corrected visibility errors for literals, 49-- added qualification for aggregate expressions 50-- used in extension aggregates, corrected parameter 51-- order in call to Communications.Creator 52-- 01 MAY 95 SAIC Removed "limited" from the definition of Mil_Comm 53-- 14 OCT 95 SAIC Fixed some value bugs for ACVC 2.0.1 54-- 04 MAR 96 SAIC Altered 3 overambitious extension aggregates 55-- 11 APR 96 SAIC Updated documentation for 2.1 56-- 27 FEB 97 PWB.CTA Deleted extra (illegal) component association 57--! 58 59----------------------------------------------------------------- C391002_1 60 61package C391002_1 is 62 63 type Object is tagged private; 64 65 -- Constructor operation 66 procedure Create( The_Plaque : in out Object ); 67 68 -- Selector operations 69 function TC_Match( Left_Plaque : Object; Right_Natural : Natural ) 70 return Boolean; 71 72 function Serial_Number( A_Plaque : Object ) return Natural; 73 74 Unserialized : exception; -- Serial_Number called before Create 75 Reserialized : exception; -- Create called twice 76 77private 78 type Object is tagged record 79 Serial_Number : Natural := 0; 80 end record; 81end C391002_1; 82 83-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 84 85package body C391002_1 is 86 87 Counter : Natural := 0; 88 89 procedure Create( The_Plaque : in out Object ) is 90 begin 91 if The_Plaque.Serial_Number = 0 then 92 Counter := Counter +1; 93 The_Plaque.Serial_Number := Counter; 94 else 95 raise Reserialized; 96 end if; 97 end Create; 98 99 function TC_Match( Left_Plaque : Object; Right_Natural : Natural ) 100 return Boolean is 101 begin 102 return (Left_Plaque.Serial_Number = Right_Natural); 103 end TC_Match; 104 105 function Serial_Number( A_Plaque : Object ) return Natural is 106 begin 107 if A_Plaque.Serial_Number = 0 then 108 raise Unserialized; 109 end if; 110 return A_Plaque.Serial_Number; 111 end Serial_Number; 112end C391002_1; 113 114----------------------------------------------------------------- C391002_2 115 116with C391002_1; 117package C391002_2 is -- package Boards is 118 119 package Plaque renames C391002_1; 120 121 type Modes is (Receiving, Transmitting, Standby); 122 type Link(Mode: Modes := Standby) is record 123 case Mode is 124 when Receiving => TC_R : Integer := 100; 125 when Transmitting => TC_T : Integer := 200; 126 when Standby => TC_S : Integer := 300; -- TGA, TSA, SSA 127 end case; 128 end record; 129 130 type Data_Formats is (S_Band, KU_Band, UHF); 131 132 type Transceiver(Band: Data_Formats) is tagged record 133 ID : Plaque.Object; 134 The_Link: Link; 135 case Band is 136 when S_Band => TC_S_Band_Data : Integer := 1; -- TGA, SSA, Milnet 137 when KU_Band => TC_KU_Band_Data : Integer := 2; -- TSA, Usenet 138 when UHF => TC_UHF_Data : Integer := 3; -- Gossip 139 end case; 140 end record; 141end C391002_2; 142 143----------------------------------------------------------------- C391002_3 144 145with C391002_1; 146with C391002_2; 147package C391002_3 is -- package Modules 148 149 package Plaque renames C391002_1; 150 package Boards renames C391002_2; 151 use type Boards.Modes; 152 use type Boards.Data_Formats; 153 154 type Command_Formats is ( Set_Compression_Code, 155 Set_Data_Rate, 156 Set_Power_State ); 157 158 type Electronics_Module(EBand : Boards.Data_Formats; 159 The_Command : Command_Formats) 160 is new Boards.Transceiver(EBand) with record 161 case The_Command is 162 when Set_Compression_Code => TC_SCC : Integer := 10; -- SSA, Gossip 163 when Set_Data_Rate => TC_SDR : Integer := 20; -- TGA, Usenet 164 when Set_Power_State => TC_SPS : Integer := 30; -- TSA, Milnet 165 end case; 166 end record; 167end C391002_3; 168 169----------------------------------------------------------------- C391002_4 170 171with C391002_3; 172package C391002_4 is -- Communications 173 package Modules renames C391002_3; 174 175 type Public_Comm is new Modules.Electronics_Module with 176 record 177 TC_VC : Integer; 178 end record; 179 180 type Private_Comm is new Modules.Electronics_Module with private; 181 182 type Mil_Comm is new Modules.Electronics_Module with private; 183 184 procedure Creator( Plugs : in Modules.Electronics_Module; 185 Gives : out Mil_Comm); 186 187 function Creator( Key : Integer; Plugs : in Modules.Electronics_Module ) 188 return Private_Comm; 189 190 procedure Setup( It : in out Public_Comm; Value : in Integer ); 191 procedure Setup( It : in out Private_Comm; Value : in Integer ); 192 procedure Setup( It : in out Mil_Comm; Value : in Integer ); 193 194 function Selector( It : Public_Comm ) return Integer; 195 function Selector( It : Private_Comm ) return Integer; 196 function Selector( It : Mil_Comm ) return Integer; 197 198private 199 type Private_Comm is new Modules.Electronics_Module with 200 record 201 TC_PC : Integer; 202 end record; 203 204 type Mil_Comm is new Modules.Electronics_Module with 205 record 206 TC_MC : Integer; 207 end record; 208end C391002_4; -- Communications 209 210-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 211 212with Report; 213with TCTouch; 214package body C391002_4 is -- Communications 215 216 procedure Creator( Plugs : in Modules.Electronics_Module; 217 Gives : out Mil_Comm) is 218 begin 219 Gives := ( Plugs with TC_MC => -1 ); 220 end Creator; 221 222 function Creator( Key : Integer; Plugs : in Modules.Electronics_Module ) 223 return Private_Comm is 224 begin 225 return ( Plugs with TC_PC => Key ); 226 end Creator; 227 228 procedure Setup( It : in out Public_Comm; Value : in Integer ) is 229 begin 230 It.TC_VC := Value; 231 TCTouch.Assert( Value = 1, "Public_Comm"); 232 end Setup; 233 234 procedure Setup( It : in out Private_Comm; Value : in Integer ) is 235 begin 236 It.TC_PC := Value; 237 TCTouch.Assert( Value = 2, "Private_Comm"); 238 end Setup; 239 240 procedure Setup( It : in out Mil_Comm; Value : in Integer ) is 241 begin 242 It.TC_MC := Value; 243 TCTouch.Assert( Value = 3, "Private_Comm"); 244 end Setup; 245 246 function Selector( It : Public_Comm ) return Integer is 247 begin 248 return It.TC_VC; 249 end Selector; 250 251 function Selector( It : Private_Comm ) return Integer is 252 begin 253 return It.TC_PC; 254 end Selector; 255 256 function Selector( It : Mil_Comm ) return Integer is 257 begin 258 return It.TC_MC; 259 end Selector; 260 261end C391002_4; -- Communications 262 263------------------------------------------------------------------- C391002 264 265with Report; 266with TCTouch; 267with C391002_1; 268with C391002_2; 269with C391002_3; 270with C391002_4; 271procedure C391002 is 272 273 package Plaque renames C391002_1; 274 package Boards renames C391002_2; 275 package Modules renames C391002_3; 276 package Communications renames C391002_4; 277 278 procedure Assert( Condition: Boolean; Message: String ) 279 renames TCTouch.Assert; 280 281 use type Boards.Modes; 282 use type Boards.Data_Formats; 283 use type Modules.Command_Formats; 284 285 type Azimuth is range 0..359; 286 287 type Ground_Antenna(The_Band : Boards.Data_Formats; 288 The_Command : Modules.Command_Formats) is 289 record 290 ID : Plaque.Object; 291 Electronics : Modules.Electronics_Module(The_Band,The_Command); 292 Pointing : Azimuth; 293 end record; 294 295 type Space_Antenna(The_Band : Boards.Data_Formats := Boards.KU_Band; 296 The_Command : Modules.Command_Formats 297 := Modules.Set_Power_State) 298 is 299 record 300 ID : Plaque.Object; 301 Electronics : Modules.Electronics_Module(The_Band,The_Command); 302 end record; 303 304 The_Ground_Antenna : Ground_Antenna (Boards.S_Band, 305 Modules.Set_Data_Rate); 306 The_Space_Antenna : Space_Antenna; 307 Space_Station_Antenna : Space_Antenna (Boards.UHF, 308 Modules.Set_Compression_Code); 309 310 Gossip : Communications.Public_Comm (Boards.UHF, 311 Modules.Set_Compression_Code); 312 Usenet : Communications.Private_Comm (Boards.KU_Band, 313 Modules.Set_Data_Rate); 314 Milnet : Communications.Mil_Comm (Boards.S_Band, 315 Modules.Set_Power_State); 316 317 318begin 319 320 Report.Test("C391002", "Check nested tagged discriminated" 321 & " record structures"); 322 323 Plaque.Create( The_Ground_Antenna.ID ); -- 1 324 Plaque.Create( The_Ground_Antenna.Electronics.ID ); -- 2 325 Plaque.Create( The_Space_Antenna.ID ); -- 3 326 Plaque.Create( The_Space_Antenna.Electronics.ID ); -- 4 327 Plaque.Create( Space_Station_Antenna.ID ); -- 5 328 Plaque.Create( Space_Station_Antenna.Electronics.ID );-- 6 329 330 The_Ground_Antenna := ( The_Band => Boards.S_Band, 331 The_Command => Modules.Set_Data_Rate, 332 ID => The_Ground_Antenna.ID, 333 Electronics => 334 ( Boards.Transceiver'( 335 Band => Boards.S_Band, 336 ID => The_Ground_Antenna.Electronics.ID, 337 The_Link => ( Mode => Boards.Transmitting, 338 TC_T => 222 ), 339 TC_S_Band_Data => 8 ) 340 with EBand => Boards.S_Band, 341 The_Command => Modules.Set_Data_Rate, 342 TC_SDR => 11 ), 343 Pointing => 270 ); 344 345 The_Space_Antenna := ( The_Band => Boards.S_Band, 346 The_Command => Modules.Set_Data_Rate, 347 ID => The_Space_Antenna.ID, 348 Electronics => 349 ( Boards.Transceiver'( 350 Band => Boards.S_Band, 351 ID => The_Space_Antenna.Electronics.ID, 352 The_Link => ( Mode => Boards.Transmitting, 353 TC_T => 456 ), 354 TC_S_Band_Data => 88 ) 355 with 356 EBand => Boards.S_Band, 357 The_Command => Modules.Set_Data_Rate, 358 TC_SDR => 42 359 ) ); 360 361 Space_Station_Antenna := ( Boards.UHF, Modules.Set_Compression_Code, 362 Space_Station_Antenna.ID, 363 ( Boards.Transceiver'( 364 Boards.UHF, 365 Space_Station_Antenna.Electronics.ID, 366 ( Boards.Transmitting, 202 ), 367 42 ) 368 with Boards.UHF, 369 Modules.Set_Compression_Code, 370 TC_SCC => 101 371 ) ); 372 373 Assert( The_Ground_Antenna.The_Band = Boards.S_Band, "TGA disc 1" ); 374 Assert( The_Ground_Antenna.The_Command = Modules.Set_Data_Rate, 375 "TGA disc 2" ); 376 Assert( Plaque.TC_Match(The_Ground_Antenna.ID,1), "TGA comp 3" ); 377 Assert( The_Ground_Antenna.Electronics.EBand = Boards.S_Band, 378 "TGA comp 2.disc 1" ); 379 Assert( The_Ground_Antenna.Electronics.The_Command 380 = Modules.Set_Data_Rate, 381 "TGA comp 2.disc 2" ); 382 Assert( The_Ground_Antenna.Electronics.TC_SDR = 11, 383 "TGA comp 2.1" ); 384 Assert( Plaque.TC_Match( The_Ground_Antenna.Electronics.ID, 2 ), 385 "TGA comp 2.inher.1" ); 386 Assert( The_Ground_Antenna.Electronics.The_Link.Mode = Boards.Transmitting, 387 "TGA comp 2.inher.2.disc" ); 388 Assert( The_Ground_Antenna.Electronics.The_Link.TC_T = 222, 389 "TGA comp 2.inher.2.1" ); 390 Assert( The_Ground_Antenna.Electronics.TC_S_Band_Data = 8, 391 "TGA comp 2.inher.3" ); 392 Assert( The_Ground_Antenna.Pointing = 270, "TGA comp 3" ); 393 394 Assert( The_Space_Antenna.The_Band = Boards.S_Band, "TSA disc 1"); 395 Assert( The_Space_Antenna.The_Command = Modules.Set_Data_Rate, 396 "TSA disc 2"); 397 Assert( Plaque.TC_Match(The_Space_Antenna.ID,3), 398 "TSA comp 1"); 399 Assert( The_Space_Antenna.Electronics.EBand = Boards.S_Band, 400 "TSA comp 2.disc 1"); 401 Assert( The_Space_Antenna.Electronics.The_Command = Modules.Set_Data_Rate, 402 "TSA comp 2.disc 2"); 403 Assert( The_Space_Antenna.Electronics.TC_SDR = 42, 404 "TSA comp 2.1"); 405 Assert( Plaque.TC_Match(The_Space_Antenna.Electronics.ID,4), 406 "TSA comp 2.inher.1"); 407 Assert( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Transmitting, 408 "TSA comp 2.inher.2.disc"); 409 Assert( The_Space_Antenna.Electronics.The_Link.TC_T = 456, 410 "TSA comp 2.inher.2.1"); 411 Assert( The_Space_Antenna.Electronics.TC_S_Band_Data = 88, 412 "TSA comp 2.inher.3"); 413 414 Assert( Space_Station_Antenna.The_Band = Boards.UHF, "SSA disc 1"); 415 Assert( Space_Station_Antenna.The_Command = Modules.Set_Compression_Code, 416 "SSA disc 2"); 417 Assert( Plaque.TC_Match(Space_Station_Antenna.ID,5), 418 "SSA comp 1"); 419 Assert( Space_Station_Antenna.Electronics.EBand = Boards.UHF, 420 "SSA comp 2.disc 1"); 421 Assert( Space_Station_Antenna.Electronics.The_Command 422 = Modules.Set_Compression_Code, 423 "SSA comp 2.disc 2"); 424 Assert( Space_Station_Antenna.Electronics.TC_SCC = 101, 425 "SSA comp 2.1"); 426 Assert( Plaque.TC_Match(Space_Station_Antenna.Electronics.ID,6), 427 "SSA comp 2.inher.1"); 428 Assert( Space_Station_Antenna.Electronics.The_Link.Mode 429 = Boards.Transmitting, 430 "SSA comp 2.inher.2.disc"); 431 Assert( Space_Station_Antenna.Electronics.The_Link.TC_T = 202, 432 "SSA comp 2.inher.2.1"); 433 Assert( Space_Station_Antenna.Electronics.TC_UHF_Data = 42, 434 "SSA comp 2.inher.3"); 435 436 437 The_Space_Antenna := ( The_Band => Boards.S_Band, 438 The_Command => Modules.Set_Power_State, 439 ID => The_Space_Antenna.ID, 440 Electronics => 441 ( Boards.Transceiver'( 442 Band => Boards.S_Band, 443 ID => The_Space_Antenna.Electronics.ID, 444 The_Link => ( Mode => Boards.Transmitting, 445 TC_T => 1 ), 446 TC_S_Band_Data => 5 ) 447 with 448 EBand => Boards.S_Band, 449 The_Command => Modules.Set_Power_State, 450 TC_SPS => 101 451 ) ); 452 453 Communications.Creator( The_Space_Antenna.Electronics, Milnet ); 454 Assert( Communications.Selector( Milnet ) = -1, "Milnet creator" ); 455 456 Usenet := Communications.Creator( -2, 457 ( Boards.Transceiver'( 458 Band => Boards.KU_Band, 459 ID => The_Space_Antenna.Electronics.ID, 460 The_Link => ( Boards.Transmitting, TC_T => 101 ), 461 TC_KU_Band_Data => 395 ) 462 with Boards.KU_Band, Modules.Set_Data_Rate, 66 ) ); 463 464 Assert( Communications.Selector( Usenet ) = -2, "Usenet creator" ); 465 466 Gossip := ( 467 Modules.Electronics_Module'( 468 Boards.Transceiver'( 469 Band => Boards.UHF, 470 ID => The_Space_Antenna.Electronics.ID, 471 The_Link => ( Boards.Transmitting, TC_T => 101 ), 472 TC_UHF_Data => 395 ) 473 with 474 Boards.UHF, Modules.Set_Compression_Code, 66 ) 475 with 476 TC_VC => -3 ); 477 478 Assert( Gossip.TC_VC = -3, "Gossip Aggregate" ); 479 480 Communications.Setup( Gossip, 1 ); -- (Boards.UHF, 481 -- Modules.Set_Compression_Code) 482 Communications.Setup( Usenet, 2 ); -- (Boards.KU_Band, 483 -- Modules.Set_Data_Rate) 484 Communications.Setup( Milnet, 3 ); -- (Boards.S_Band, 485 -- Modules.Set_Power_State) 486 487 Assert( Communications.Selector( Gossip ) = 1, "Gossip Setup" ); 488 Assert( Communications.Selector( Usenet ) = 2, "Usenet Setup" ); 489 Assert( Communications.Selector( Milnet ) = 3, "Milnet Setup" ); 490 491 Report.Result; 492 493end C391002; 494