c3a2001.a

来自「linux下编程用 编译软件」· A 代码 · 共 461 行 · 第 1/2 页

-- C3A2001.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 an access type may be defined to designate the
--      class-wide type of an abstract type.  Check that the access type
--      may then be used subsequently with types derived from the abstract
--      type.  Check that dispatching operations dispatch correctly, when
--      called using values designated by objects of the access type.
--
-- TEST DESCRIPTION:
--      This test declares an abstract type Breaker in a package, and
--      then derives from it.  The type Basic_Breaker defines the least
--      possible in order to not be abstract.  The type Ground_Fault is
--      defined to inherit as much as possible, whereas type Special_Breaker
--      overrides everything it can.  The type Special_Breaker also includes
--      an embedded Basic_Breaker object.  The main program then utilizes
--      each of the three types of breaker, and to ascertain that the
--      overloading and tagging resolution are correct, each "Create"
--      procedure is called with a unique value.  The diagram below
--      illustrates the relationships.
--
--              Abstract type:           Breaker(1)
--                                           |
--                                    Basic_Breaker(2)
--                                    /           \
--                           Ground_Fault(3)    Special_Breaker(4)
--
--      Test structure is a polymorphic linked list, modeling a circuit
--      as a list of components.  The type component is the access type
--      defined to designate Breaker'Class values.  The test then creates
--      some values, and traverses the list to determine correct operation.
--      This test is instrumented with a the trace facility found in
--      foundation F392C00 to simplify the verification process.
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      10 Nov 95   SAIC    Checked compilation for ACVC 2.0.1
--      23 APR 96   SAIC    Added pragma Elaborate_All
--      26 NOV 96   SAIC    Elaborate_Body changed to Elaborate_All
--
--!

with Report;
with TCTouch;
package C3A2001_1 is

  type Breaker is abstract tagged private;
  type Status  is ( Power_Off, Power_On, Tripped, Failed );

  procedure Flip ( The_Breaker : in out Breaker ) is abstract;
  procedure Trip ( The_Breaker : in out Breaker ) is abstract;
  procedure Reset( The_Breaker : in out Breaker ) is abstract;
  procedure Fail ( The_Breaker : in out Breaker );

  procedure Set ( The_Breaker : in out Breaker'Class; To_State : Status );

  function  Status_Of( The_Breaker : Breaker ) return Status;

private
  type Breaker is abstract tagged record
    State : Status := Power_Off;
  end record;
end C3A2001_1;

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

with TCTouch;
package body C3A2001_1 is
  procedure Fail( The_Breaker : in out Breaker ) is
  begin
    TCTouch.Touch( 'a' ); --------------------------------------------- a
    The_Breaker.State := Failed;
  end Fail;

  procedure Set( The_Breaker : in out Breaker'Class; To_State : Status ) is
  begin
    The_Breaker.State := To_State;
  end Set;

  function  Status_Of( The_Breaker : Breaker ) return Status is
  begin
    TCTouch.Touch( 'b' ); --------------------------------------------- b
    return The_Breaker.State;
  end Status_Of;
end C3A2001_1;

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

with C3A2001_1;
package C3A2001_2 is

  type Basic_Breaker is new C3A2001_1.Breaker with private;

  type Voltages is ( V12, V110, V220, V440 );
  type Amps     is ( A1, A5, A10, A25, A100 );

  function Construct( Voltage : Voltages; Amperage : Amps )
    return Basic_Breaker;

  procedure Flip ( The_Breaker : in out Basic_Breaker );
  procedure Trip ( The_Breaker : in out Basic_Breaker );
  procedure Reset( The_Breaker : in out Basic_Breaker );
private
  type Basic_Breaker is new C3A2001_1.Breaker with record
    Voltage_Level : Voltages := V110;
    Amperage      : Amps;
  end record;
end C3A2001_2;

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

with TCTouch;
package body C3A2001_2 is
  function Construct( Voltage : Voltages; Amperage : Amps )
    return Basic_Breaker is
    It : Basic_Breaker;
  begin
    TCTouch.Touch( 'c' ); --------------------------------------------- c
    It.Amperage := Amperage;
    It.Voltage_Level := Voltage;
    C3A2001_1.Set( It, C3A2001_1.Power_Off );
    return It;
  end Construct;

  procedure Flip ( The_Breaker : in out Basic_Breaker ) is
  begin
    TCTouch.Touch( 'd' ); --------------------------------------------- d
    case Status_Of( The_Breaker ) is
      when C3A2001_1.Power_Off =>
        C3A2001_1.Set( The_Breaker, C3A2001_1.Power_On );
      when C3A2001_1.Power_On =>
        C3A2001_1.Set( The_Breaker, C3A2001_1.Power_Off );
      when C3A2001_1.Tripped | C3A2001_1.Failed  => null;
    end case;
  end Flip;

  procedure Trip ( The_Breaker : in out Basic_Breaker ) is
  begin
    TCTouch.Touch( 'e' ); --------------------------------------------- e
    C3A2001_1.Set( The_Breaker, C3A2001_1.Tripped );
  end Trip;

  procedure Reset( The_Breaker : in out Basic_Breaker ) is
  begin
    TCTouch.Touch( 'f' ); --------------------------------------------- f
    case Status_Of( The_Breaker ) is
      when C3A2001_1.Power_Off | C3A2001_1.Tripped =>
        C3A2001_1.Set( The_Breaker, C3A2001_1.Power_On );
      when C3A2001_1.Power_On  | C3A2001_1.Failed  => null;
    end case;
  end Reset;

end C3A2001_2;

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

with C3A2001_1,C3A2001_2;
package C3A2001_3 is
  use type C3A2001_1.Status;

  type Ground_Fault is new C3A2001_2.Basic_Breaker with private;

  function Construct( Voltage  : C3A2001_2.Voltages;
                      Amperage : C3A2001_2.Amps )
    return Ground_Fault;

  procedure Set_Trip( The_Breaker : in out Ground_Fault;
                      Capacitance : in     Integer );

private
  type Ground_Fault is new C3A2001_2.Basic_Breaker with record
    Capacitance : Integer;
  end record;
end C3A2001_3;

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

with TCTouch;
package body C3A2001_3 is

  function Construct( Voltage  : C3A2001_2.Voltages;
                      Amperage : C3A2001_2.Amps )
    return Ground_Fault is
  begin
    TCTouch.Touch( 'g' ); --------------------------------------------- g
    return ( C3A2001_2.Construct( Voltage, Amperage )
             with Capacitance => 0 );
  end Construct;


  procedure Set_Trip( The_Breaker : in out Ground_Fault;
                      Capacitance : in     Integer ) is
  begin
    TCTouch.Touch( 'h' ); --------------------------------------------- h
    The_Breaker.Capacitance := Capacitance;
  end Set_Trip;

end C3A2001_3;

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

with C3A2001_1, C3A2001_2;
package C3A2001_4 is

  type Special_Breaker is new C3A2001_2.Basic_Breaker with private;

  function Construct( Voltage     : C3A2001_2.Voltages;