old-autovect-branch/gcc/testsuite/ada/acats/tests/c3/c391002.a

   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
  61 package 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
  77 private
  78   type Object is tagged record
  79     Serial_Number : Natural := 0;
  80   end record;
  81 end C391002_1;
  82
  83 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
  84
  85 package 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;
 112 end C391002_1;
 113
 114 ----------------------------------------------------------------- C391002_2
 115
 116 with C391002_1;
 117 package 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;
 141 end C391002_2;
 142
 143 ----------------------------------------------------------------- C391002_3
 144
 145 with C391002_1;
 146 with C391002_2;
 147 package 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;
 167 end C391002_3;
 168
 169 ----------------------------------------------------------------- C391002_4
 170
 171 with C391002_3;
 172 package 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
 198 private
 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;
 208 end C391002_4; -- Communications
 209
 210 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 211
 212 with Report;
 213 with TCTouch;
 214 package 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
 261 end C391002_4; -- Communications
 262
 263 ------------------------------------------------------------------- C391002
 264
 265 with Report;
 266 with TCTouch;
 267 with C391002_1;
 268 with C391002_2;
 269 with C391002_3;
 270 with C391002_4;
 271 procedure 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
 318 begin
 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
 493 end C391002;