c391002.a

linux下编程用 编译软件

-- 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