path: root/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c391002.a

-- C391002.A
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     These rights include rights to use, duplicate, release or disclose the 
--     released technical data and computer software in whole or in part, in 
--     any manner and for any purpose whatsoever, and to have or permit others 
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
--      Check that structures nesting discriminated records as
--      components in record extension are correctly supported.
--      Check that record extensions inherit all the visible components
--      of their ancestor types.
--      Check that discriminants are correctly inherited.
--
-- TEST DESCRIPTION:
--      This test defines a simple class hierarchy, where the final
--      derivations exercise the different possible "permissions" available
--      to a designer.  Extension aggregates for discriminated types are used
--      to set values of these final types.  The key difference between
--      this test and C391001 is that the types are visible, and allow the
--      creation of complex discriminated extension aggregates.  Another
--      layer of derivation is present to more robustly check that the
--      inheritance is correctly supported.
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      16 Dec 94   SAIC    Removed offending parenthesis in aggregate
--                          extensions, corrected typo: TC_MC SB TC_PC,
--                          corrected visibility errors for literals,
--                          added qualification for aggregate expressions
--                          used in extension aggregates, corrected parameter
--                          order in call to Communications.Creator
--     01 MAY 95    SAIC    Removed "limited" from the definition of Mil_Comm
--     14 OCT 95    SAIC    Fixed some value bugs for ACVC 2.0.1
--     04 MAR 96    SAIC    Altered 3 overambitious extension aggregates
--     11 APR 96    SAIC    Updated documentation for 2.1
--     27 FEB 97    PWB.CTA Deleted extra (illegal) component association
--!

----------------------------------------------------------------- C391002_1

package C391002_1 is 

  type Object is tagged private;  

  -- Constructor operation
  procedure Create( The_Plaque : in out Object );

  -- Selector operations
  function TC_Match( Left_Plaque : Object; Right_Natural : Natural )
    return Boolean;

  function Serial_Number( A_Plaque : Object ) return Natural;

  Unserialized : exception;  -- Serial_Number called before Create
  Reserialized : exception;  -- Create called twice

private
  type Object is tagged record
    Serial_Number : Natural := 0;
  end record;
end C391002_1;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

package body C391002_1 is

  Counter : Natural := 0;

  procedure Create( The_Plaque : in out Object ) is
  begin
    if The_Plaque.Serial_Number = 0 then
      Counter := Counter +1;
      The_Plaque.Serial_Number := Counter;
    else
      raise Reserialized;
    end if;
  end Create;

  function TC_Match( Left_Plaque : Object; Right_Natural : Natural )
    return Boolean is
  begin
    return (Left_Plaque.Serial_Number = Right_Natural);
  end TC_Match;

  function Serial_Number( A_Plaque : Object ) return Natural is
  begin
    if A_Plaque.Serial_Number = 0 then
      raise Unserialized;
    end if;
    return A_Plaque.Serial_Number;
  end Serial_Number;
end C391002_1;

----------------------------------------------------------------- C391002_2

with C391002_1;
package C391002_2 is -- package Boards is

  package Plaque renames C391002_1;

  type Modes is (Receiving, Transmitting, Standby);
  type Link(Mode: Modes := Standby) is record
    case Mode is
      when Receiving    => TC_R : Integer := 100; 
      when Transmitting => TC_T : Integer := 200;
      when Standby      => TC_S : Integer := 300; -- TGA, TSA, SSA
    end case;
  end record;

  type Data_Formats is (S_Band, KU_Band, UHF);

  type Transceiver(Band: Data_Formats) is tagged record
    ID : Plaque.Object;
    The_Link: Link;
    case Band is
      when S_Band  => TC_S_Band_Data  : Integer := 1; -- TGA, SSA, Milnet
      when KU_Band => TC_KU_Band_Data : Integer := 2; -- TSA, Usenet
      when UHF     => TC_UHF_Data     : Integer := 3; -- Gossip
    end case;
  end record;
end C391002_2;

----------------------------------------------------------------- C391002_3

with C391002_1;
with C391002_2;
package C391002_3 is -- package Modules

  package Plaque renames C391002_1;
  package Boards renames C391002_2;
  use type Boards.Modes;
  use type Boards.Data_Formats;

  type Command_Formats is ( Set_Compression_Code,
                            Set_Data_Rate,
                            Set_Power_State );

  type Electronics_Module(EBand       : Boards.Data_Formats;
                          The_Command : Command_Formats)
    is new Boards.Transceiver(EBand) with record
      case The_Command is
        when Set_Compression_Code => TC_SCC : Integer := 10; -- SSA, Gossip
        when Set_Data_Rate        => TC_SDR : Integer := 20; -- TGA, Usenet
        when Set_Power_State      => TC_SPS : Integer := 30; -- TSA, Milnet
      end case;
    end record;
end C391002_3;

----------------------------------------------------------------- C391002_4

with C391002_3;
package C391002_4 is -- Communications
  package Modules renames C391002_3;

  type Public_Comm is new Modules.Electronics_Module with
    record
      TC_VC : Integer;
    end record;

  type Private_Comm is new Modules.Electronics_Module with private;

  type Mil_Comm is new Modules.Electronics_Module with private;

  procedure Creator( Plugs : in Modules.Electronics_Module;
                     Gives : out Mil_Comm);

  function  Creator( Key : Integer; Plugs : in Modules.Electronics_Module )
            return Private_Comm;

  procedure Setup( It : in out Public_Comm;  Value : in Integer );
  procedure Setup( It : in out Private_Comm; Value : in Integer );
  procedure Setup( It : in out Mil_Comm;     Value : in Integer );

  function  Selector( It : Public_Comm )  return Integer;
  function  Selector( It : Private_Comm ) return Integer;
  function  Selector( It : Mil_Comm )     return Integer;

private
  type Private_Comm is new Modules.Electronics_Module with
    record
      TC_PC : Integer;
    end record;

  type Mil_Comm is new Modules.Electronics_Module with 
    record
      TC_MC : Integer;
    end record;
end C391002_4; -- Communications

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

with Report;
with TCTouch;
package body C391002_4 is -- Communications

  procedure Creator( Plugs : in Modules.Electronics_Module;
                     Gives : out Mil_Comm) is
  begin
    Gives := ( Plugs with TC_MC => -1 );
  end Creator;

  function  Creator( Key : Integer; Plugs : in Modules.Electronics_Module )
            return Private_Comm is
  begin
    return ( Plugs with TC_PC => Key );
  end Creator;

  procedure Setup( It : in out Public_Comm; Value : in Integer ) is
  begin
    It.TC_VC := Value;
    TCTouch.Assert( Value = 1, "Public_Comm");
  end Setup;

  procedure Setup( It : in out Private_Comm; Value : in Integer ) is
  begin
    It.TC_PC := Value;
    TCTouch.Assert( Value = 2, "Private_Comm");
  end Setup;

  procedure Setup( It : in out Mil_Comm; Value : in Integer ) is
  begin
    It.TC_MC := Value;
    TCTouch.Assert( Value = 3, "Private_Comm");
  end Setup;

  function  Selector( It : Public_Comm )  return Integer is
  begin
    return It.TC_VC;
  end Selector;

  function  Selector( It : Private_Comm ) return Integer is
  begin
    return It.TC_PC;
  end Selector;

  function  Selector( It : Mil_Comm )     return Integer is
  begin
    return It.TC_MC;
  end Selector;

end C391002_4; -- Communications

------------------------------------------------------------------- C391002

with Report;
with TCTouch;
with C391002_1;
with C391002_2;
with C391002_3;
with C391002_4;
procedure C391002 is

  package Plaque  renames C391002_1;
  package Boards  renames C391002_2;
  package Modules renames C391002_3;
  package Communications renames C391002_4;

  procedure Assert( Condition: Boolean; Message: String )
    renames TCTouch.Assert;

  use type Boards.Modes;
  use type Boards.Data_Formats;
  use type Modules.Command_Formats;

  type Azimuth is range 0..359;

  type Ground_Antenna(The_Band    : Boards.Data_Formats;
                      The_Command : Modules.Command_Formats) is
    record
      ID          : Plaque.Object;
      Electronics : Modules.Electronics_Module(The_Band,The_Command);
      Pointing    : Azimuth;
    end record;

  type Space_Antenna(The_Band    : Boards.Data_Formats    := Boards.KU_Band;
                     The_Command : Modules.Command_Formats
                                   := Modules.Set_Power_State)
  is
    record
      ID          : Plaque.Object;
      Electronics : Modules.Electronics_Module(The_Band,The_Command);
    end record;

  The_Ground_Antenna     : Ground_Antenna (Boards.S_Band,
                                           Modules.Set_Data_Rate);
  The_Space_Antenna      : Space_Antenna;
  Space_Station_Antenna  : Space_Antenna  (Boards.UHF,
                                           Modules.Set_Compression_Code);

  Gossip : Communications.Public_Comm  (Boards.UHF,
                                        Modules.Set_Compression_Code);
  Usenet : Communications.Private_Comm (Boards.KU_Band,
                                        Modules.Set_Data_Rate);
  Milnet : Communications.Mil_Comm     (Boards.S_Band,
                                        Modules.Set_Power_State);


begin

  Report.Test("C391002", "Check nested tagged discriminated"
                       & " record structures");

  Plaque.Create( The_Ground_Antenna.ID );               -- 1
  Plaque.Create( The_Ground_Antenna.Electronics.ID );   -- 2
  Plaque.Create( The_Space_Antenna.ID );                -- 3
  Plaque.Create( The_Space_Antenna.Electronics.ID );    -- 4
  Plaque.Create( Space_Station_Antenna.ID );            -- 5
  Plaque.Create( Space_Station_Antenna.Electronics.ID );-- 6

  The_Ground_Antenna := ( The_Band    => Boards.S_Band,
                          The_Command => Modules.Set_Data_Rate,
                          ID          => The_Ground_Antenna.ID,
                          Electronics =>
                          ( Boards.Transceiver'(
                              Band     => Boards.S_Band,
                              ID       => The_Ground_Antenna.Electronics.ID,
                              The_Link => ( Mode => Boards.Transmitting,
                                            TC_T => 222 ),
                              TC_S_Band_Data => 8 )
                            with   EBand       => Boards.S_Band,
                                   The_Command => Modules.Set_Data_Rate,
                                   TC_SDR      => 11 ),
                          Pointing    => 270 );

  The_Space_Antenna := ( The_Band    => Boards.S_Band,
                         The_Command => Modules.Set_Data_Rate,
                         ID          => The_Space_Antenna.ID,
                         Electronics =>
                         ( Boards.Transceiver'(
                             Band     => Boards.S_Band,
                             ID       => The_Space_Antenna.Electronics.ID,
                             The_Link => ( Mode => Boards.Transmitting,
                                           TC_T => 456 ),
                             TC_S_Band_Data => 88 )
                           with
                               EBand       => Boards.S_Band,
                               The_Command => Modules.Set_Data_Rate,
                               TC_SDR      => 42
                        ) );

  Space_Station_Antenna := ( Boards.UHF, Modules.Set_Compression_Code,
                             Space_Station_Antenna.ID,
                             ( Boards.Transceiver'(
                                 Boards.UHF,
                                 Space_Station_Antenna.Electronics.ID,
                                 ( Boards.Transmitting, 202 ),
                                 42 )
                                 with Boards.UHF, 
                                      Modules.Set_Compression_Code,
                                      TC_SCC => 101
                           ) );

  Assert( The_Ground_Antenna.The_Band = Boards.S_Band, "TGA disc 1" );
  Assert( The_Ground_Antenna.The_Command = Modules.Set_Data_Rate,
            "TGA disc 2" );
  Assert( Plaque.TC_Match(The_Ground_Antenna.ID,1), "TGA comp 3" );
  Assert( The_Ground_Antenna.Electronics.EBand = Boards.S_Band,
            "TGA comp 2.disc 1" );
  Assert( The_Ground_Antenna.Electronics.The_Command
             = Modules.Set_Data_Rate,
            "TGA comp 2.disc 2" );
  Assert( The_Ground_Antenna.Electronics.TC_SDR = 11,
            "TGA comp 2.1" );
  Assert( Plaque.TC_Match( The_Ground_Antenna.Electronics.ID, 2 ),
            "TGA comp 2.inher.1" );
  Assert( The_Ground_Antenna.Electronics.The_Link.Mode = Boards.Transmitting,
            "TGA comp 2.inher.2.disc" );
  Assert( The_Ground_Antenna.Electronics.The_Link.TC_T = 222,
            "TGA comp 2.inher.2.1" );
  Assert( The_Ground_Antenna.Electronics.TC_S_Band_Data = 8,
            "TGA comp 2.inher.3" );
  Assert( The_Ground_Antenna.Pointing = 270, "TGA comp 3" );

  Assert( The_Space_Antenna.The_Band = Boards.S_Band, "TSA disc 1");
  Assert( The_Space_Antenna.The_Command = Modules.Set_Data_Rate,
            "TSA disc 2");
  Assert( Plaque.TC_Match(The_Space_Antenna.ID,3),
            "TSA comp 1");
  Assert( The_Space_Antenna.Electronics.EBand = Boards.S_Band,
            "TSA comp 2.disc 1");
  Assert( The_Space_Antenna.Electronics.The_Command = Modules.Set_Data_Rate,
            "TSA comp 2.disc 2");
  Assert( The_Space_Antenna.Electronics.TC_SDR = 42,
            "TSA comp 2.1");
  Assert( Plaque.TC_Match(The_Space_Antenna.Electronics.ID,4),
            "TSA comp 2.inher.1");
  Assert( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Transmitting,
            "TSA comp 2.inher.2.disc");
  Assert( The_Space_Antenna.Electronics.The_Link.TC_T = 456,
            "TSA comp 2.inher.2.1");
  Assert( The_Space_Antenna.Electronics.TC_S_Band_Data = 88,
            "TSA comp 2.inher.3");

  Assert( Space_Station_Antenna.The_Band = Boards.UHF, "SSA disc 1");
  Assert( Space_Station_Antenna.The_Command = Modules.Set_Compression_Code,
            "SSA disc 2");
  Assert( Plaque.TC_Match(Space_Station_Antenna.ID,5),
            "SSA comp 1");
  Assert( Space_Station_Antenna.Electronics.EBand = Boards.UHF,
            "SSA comp 2.disc 1");
  Assert( Space_Station_Antenna.Electronics.The_Command
             = Modules.Set_Compression_Code,
            "SSA comp 2.disc 2");
  Assert( Space_Station_Antenna.Electronics.TC_SCC = 101,
            "SSA comp 2.1");
  Assert( Plaque.TC_Match(Space_Station_Antenna.Electronics.ID,6),
            "SSA comp 2.inher.1");
  Assert( Space_Station_Antenna.Electronics.The_Link.Mode
            = Boards.Transmitting,
            "SSA comp 2.inher.2.disc");
  Assert( Space_Station_Antenna.Electronics.The_Link.TC_T = 202,
            "SSA comp 2.inher.2.1");
  Assert( Space_Station_Antenna.Electronics.TC_UHF_Data = 42,
            "SSA comp 2.inher.3");


  The_Space_Antenna := ( The_Band    => Boards.S_Band,
                         The_Command => Modules.Set_Power_State,
                         ID          => The_Space_Antenna.ID,
                         Electronics =>
                         ( Boards.Transceiver'(
                             Band     => Boards.S_Band,
                             ID       => The_Space_Antenna.Electronics.ID,
                             The_Link => ( Mode => Boards.Transmitting,
                                           TC_T => 1 ),
                             TC_S_Band_Data => 5 )
                           with
                               EBand       => Boards.S_Band,
                               The_Command => Modules.Set_Power_State,
                               TC_SPS      => 101
                        ) );

  Communications.Creator( The_Space_Antenna.Electronics, Milnet );
  Assert( Communications.Selector( Milnet ) = -1, "Milnet creator" );

  Usenet := Communications.Creator( -2, 
                     ( Boards.Transceiver'(
                         Band        => Boards.KU_Band,
                         ID          => The_Space_Antenna.Electronics.ID,
                         The_Link    => ( Boards.Transmitting, TC_T => 101 ),
                         TC_KU_Band_Data => 395 )
                    with Boards.KU_Band, Modules.Set_Data_Rate, 66 ) );

  Assert( Communications.Selector( Usenet ) = -2, "Usenet creator" );

  Gossip := ( 
    Modules.Electronics_Module'(
      Boards.Transceiver'(
         Band        => Boards.UHF,
         ID          => The_Space_Antenna.Electronics.ID,
         The_Link    => ( Boards.Transmitting, TC_T => 101 ),
         TC_UHF_Data => 395 )
       with 
         Boards.UHF, Modules.Set_Compression_Code, 66 )
     with
       TC_VC => -3 ); 

  Assert( Gossip.TC_VC = -3, "Gossip Aggregate" );

  Communications.Setup( Gossip, 1 ); -- (Boards.UHF,
                                     -- Modules.Set_Compression_Code)
  Communications.Setup( Usenet, 2 ); -- (Boards.KU_Band,
                                     -- Modules.Set_Data_Rate)
  Communications.Setup( Milnet, 3 ); -- (Boards.S_Band,
                                     -- Modules.Set_Power_State)

  Assert( Communications.Selector( Gossip ) = 1, "Gossip Setup" );
  Assert( Communications.Selector( Usenet ) = 2, "Usenet Setup" );
  Assert( Communications.Selector( Milnet ) = 3, "Milnet Setup" );

  Report.Result;

end C391002;