gcc/testsuite/ada/acats/tests/c3/c393001.a

   1 -- C393001.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 an abstract type can be declared, and in turn concrete
  28 --      types can be derived from it.  Check that the definition of
  29 --      actual subprograms associated with the derived types dispatch
  30 --      correctly.
  31 --
  32 -- TEST DESCRIPTION:
  33 --      This test declares an abstract type Breaker in a package, and
  34 --      then derives from it.  The type Basic_Breaker defines the least
  35 --      possible in order to not be abstract.  The type Ground_Fault is
  36 --      defined to inherit as much as possible, whereas type Special_Breaker
  37 --      overrides everything it can.  The type Special_Breaker also includes
  38 --      an embedded Basic_Breaker object.  The main program then utilizes
  39 --      each of the three types of breaker, and to ascertain that the
  40 --      overloading and tagging resolution are correct, each "Create"
  41 --      procedure is called with a unique value.  The diagram below
  42 --      illustrates the relationships.  This test is derived from C3A2001.
  43 --
  44 --              Abstract type:           Breaker
  45 --                                           |
  46 --                                    Basic_Breaker (Short)
  47 --                                    /           \
  48 --                     (Sharp) Ground_Fault    Special_Breaker (Shock)
  49 --
  50 --      Test structure is an array of class-wide objects, modeling a circuit
  51 --      as a list of components.  The test then creates some values, and
  52 --      traverses the list to determine correct operation.
  53 --
  54 --
  55 -- CHANGE HISTORY:
  56 --      06 Dec 94   SAIC    ACVC 2.0
  57 --      13 Nov 95   SAIC    Revised for 2.0.1
  58 --
  59 --!
  60
  61 ----------------------------------------------------------------- C393001_1
  62
  63 with Report;
  64 package C393001_1 is
  65
  66   type Breaker is abstract tagged private;
  67   type Status  is ( Power_Off, Power_On, Tripped, Failed );
  68
  69   procedure Flip ( The_Breaker : in out Breaker ) is abstract;
  70   procedure Trip ( The_Breaker : in out Breaker ) is abstract;
  71   procedure Reset( The_Breaker : in out Breaker ) is abstract;
  72   procedure Fail ( The_Breaker : in out Breaker );
  73
  74   procedure Set ( The_Breaker : in out Breaker'Class; To_State : Status );
  75
  76   function  Status_Of( The_Breaker : Breaker ) return Status;
  77
  78 private
  79   type Breaker is abstract tagged record
  80     State : Status := Power_Off;
  81   end record;
  82 end C393001_1;
  83
  84 with TCTouch;
  85 package body C393001_1 is
  86   procedure Fail( The_Breaker : in out Breaker ) is ------------------- a
  87   begin
  88     TCTouch.Touch( 'a' );
  89     The_Breaker.State := Failed;
  90   end Fail;
  91
  92   procedure Set( The_Breaker : in out Breaker'Class; To_State : Status ) is
  93   begin
  94     The_Breaker.State := To_State;
  95   end Set;
  96
  97   function  Status_Of( The_Breaker : Breaker ) return Status is ------- b
  98   begin
  99     TCTouch.Touch( 'b' );
 100     return The_Breaker.State;
 101   end Status_Of;
 102 end C393001_1;
 103
 104 ----------------------------------------------------------------- C393001_2
 105
 106 with C393001_1;
 107 package C393001_2 is
 108
 109   type Basic_Breaker is new C393001_1.Breaker with private;
 110
 111   type Voltages is ( V12, V110, V220, V440 );
 112   type Amps     is ( A1, A5, A10, A25, A100 );
 113
 114   function Construct( Voltage : Voltages; Amperage : Amps )
 115     return Basic_Breaker;
 116
 117   procedure Flip ( The_Breaker : in out Basic_Breaker );
 118   procedure Trip ( The_Breaker : in out Basic_Breaker );
 119   procedure Reset( The_Breaker : in out Basic_Breaker );
 120 private
 121   type Basic_Breaker is new C393001_1.Breaker with record
 122     Voltage_Level : Voltages := V110;
 123     Amperage      : Amps;
 124   end record;
 125 end C393001_2;
 126
 127 with TCTouch;
 128 package body C393001_2 is
 129   function Construct( Voltage : Voltages; Amperage : Amps ) ----------- c
 130     return Basic_Breaker is
 131     It : Basic_Breaker;
 132   begin
 133     TCTouch.Touch( 'c' );
 134     It.Amperage := Amperage;
 135     It.Voltage_Level := Voltage;
 136     C393001_1.Set( It, C393001_1.Power_Off );
 137     return It;
 138   end Construct;
 139
 140   procedure Flip ( The_Breaker : in out Basic_Breaker ) is ------------ d
 141   begin
 142     TCTouch.Touch( 'd' );
 143     case Status_Of( The_Breaker ) is
 144       when C393001_1.Power_Off =>
 145         C393001_1.Set( The_Breaker, C393001_1.Power_On );
 146       when C393001_1.Power_On =>
 147         C393001_1.Set( The_Breaker, C393001_1.Power_Off );
 148       when C393001_1.Tripped | C393001_1.Failed  => null;
 149     end case;
 150   end Flip;
 151
 152   procedure Trip ( The_Breaker : in out Basic_Breaker ) is ------------ e
 153   begin
 154     TCTouch.Touch( 'e' );
 155     C393001_1.Set( The_Breaker, C393001_1.Tripped );
 156   end Trip;
 157
 158   procedure Reset( The_Breaker : in out Basic_Breaker ) is ------------ f
 159   begin
 160     TCTouch.Touch( 'f' );
 161     case Status_Of( The_Breaker ) is
 162       when C393001_1.Power_Off | C393001_1.Tripped =>
 163         C393001_1.Set( The_Breaker, C393001_1.Power_On );
 164       when C393001_1.Power_On  | C393001_1.Failed  => null;
 165     end case;
 166   end Reset;
 167
 168 end C393001_2;
 169
 170 with C393001_1,C393001_2;
 171 package C393001_3 is
 172
 173   type Ground_Fault is new C393001_2.Basic_Breaker with private;
 174
 175   function Construct( Voltage : C393001_2.Voltages; Amperage : C393001_2.Amps
 176 )
 177     return Ground_Fault;
 178
 179   procedure Set_Trip( The_Breaker : in out Ground_Fault;
 180                       Capacitance : in     Integer );
 181
 182 private
 183   type Ground_Fault is new C393001_2.Basic_Breaker with record
 184     Capacitance : Integer;
 185   end record;
 186 end C393001_3;
 187
 188 ----------------------------------------------------------------- C393001_3
 189
 190 with TCTouch;
 191 package body C393001_3 is
 192
 193   function Construct( Voltage  : C393001_2.Voltages; ------------------ g
 194                       Amperage : C393001_2.Amps )
 195     return Ground_Fault is
 196
 197     It : Ground_Fault;
 198
 199     procedure Set_Root( It: in out C393001_2.Basic_Breaker ) is
 200     begin
 201       It := C393001_2.Construct( Voltage, Amperage );
 202     end Set_Root;
 203
 204   begin
 205     TCTouch.Touch( 'g' );
 206     Set_Root( C393001_2.Basic_Breaker( It ) );
 207     It.Capacitance := 0;
 208     return It;
 209   end Construct;
 210
 211   procedure Set_Trip( The_Breaker : in out Ground_Fault; -------------- h
 212                       Capacitance : in     Integer ) is
 213   begin
 214     TCTouch.Touch( 'h' );
 215     The_Breaker.Capacitance := Capacitance;
 216   end Set_Trip;
 217
 218 end C393001_3;
 219
 220 ----------------------------------------------------------------- C393001_4
 221
 222 with C393001_1, C393001_2;
 223 package C393001_4 is
 224
 225   type Special_Breaker is new C393001_2.Basic_Breaker with private;
 226
 227   function Construct( Voltage     : C393001_2.Voltages;
 228                       Amperage    : C393001_2.Amps )
 229     return Special_Breaker;
 230
 231   procedure Flip ( The_Breaker : in out Special_Breaker );
 232   procedure Trip ( The_Breaker : in out Special_Breaker );
 233   procedure Reset( The_Breaker : in out Special_Breaker );
 234   procedure Fail ( The_Breaker : in out Special_Breaker );
 235
 236   function Status_Of( The_Breaker : Special_Breaker ) return C393001_1.Status;
 237   function On_Backup( The_Breaker : Special_Breaker ) return Boolean;
 238
 239 private
 240   type Special_Breaker is new C393001_2.Basic_Breaker with record
 241     Backup : C393001_2.Basic_Breaker;
 242   end record;
 243 end C393001_4;
 244
 245 with TCTouch;
 246 package body C393001_4 is
 247
 248   function Construct( Voltage     : C393001_2.Voltages; --------------- i
 249                       Amperage    : C393001_2.Amps )
 250     return Special_Breaker is
 251     It: Special_Breaker;
 252     procedure Set_Root( It: in out C393001_2.Basic_Breaker ) is
 253     begin
 254       It := C393001_2.Construct( Voltage, Amperage );
 255     end Set_Root;
 256   begin
 257     TCTouch.Touch( 'i' );
 258     Set_Root( C393001_2.Basic_Breaker( It ) );
 259     Set_Root( It.Backup );
 260     return It;
 261   end Construct;
 262
 263   function Status_Of( It: C393001_1.Breaker ) return C393001_1.Status
 264     renames C393001_1.Status_Of;
 265
 266   procedure Flip ( The_Breaker : in out Special_Breaker ) is ---------- j
 267   begin
 268     TCTouch.Touch( 'j' );
 269     case Status_Of( C393001_1.Breaker( The_Breaker )) is
 270       when C393001_1.Power_Off | C393001_1.Power_On =>
 271         C393001_2.Flip( C393001_2.Basic_Breaker( The_Breaker ) );
 272       when others =>
 273         C393001_2.Flip( The_Breaker.Backup );
 274     end case;
 275   end Flip;
 276
 277   procedure Trip ( The_Breaker : in out Special_Breaker ) is ---------- k
 278   begin
 279     TCTouch.Touch( 'k' );
 280     case Status_Of( C393001_1.Breaker( The_Breaker )) is
 281       when C393001_1.Power_Off => null;
 282       when C393001_1.Power_On  =>
 283         C393001_2.Reset( The_Breaker.Backup );
 284         C393001_2.Trip( C393001_2.Basic_Breaker( The_Breaker ) );
 285       when others =>
 286         C393001_2.Trip( The_Breaker.Backup );
 287     end case;
 288   end Trip;
 289
 290   procedure Reset( The_Breaker : in out Special_Breaker ) is ---------- l
 291   begin
 292     TCTouch.Touch( 'l' );
 293     case Status_Of( C393001_1.Breaker( The_Breaker )) is
 294       when C393001_1.Tripped  =>
 295         C393001_2.Reset( C393001_2.Basic_Breaker( The_Breaker ));
 296       when C393001_1.Failed  =>
 297         C393001_2.Reset( The_Breaker.Backup );
 298       when C393001_1.Power_On | C393001_1.Power_Off =>
 299         null;
 300     end case;
 301   end Reset;
 302
 303   procedure Fail ( The_Breaker : in out Special_Breaker ) is ---------- m
 304   begin
 305     TCTouch.Touch( 'm' );
 306     case Status_Of( C393001_1.Breaker( The_Breaker )) is
 307       when C393001_1.Failed  =>
 308         C393001_2.Fail( The_Breaker.Backup );
 309       when others =>
 310         C393001_2.Fail( C393001_2.Basic_Breaker( The_Breaker ));
 311         C393001_2.Reset( The_Breaker.Backup );
 312     end case;
 313   end Fail;
 314
 315   function Status_Of( The_Breaker : Special_Breaker ) ----------------- n
 316     return C393001_1.Status is
 317   begin
 318     TCTouch.Touch( 'n' );
 319     case Status_Of( C393001_1.Breaker( The_Breaker )) is
 320       when C393001_1.Power_On  => return C393001_1.Power_On;
 321       when C393001_1.Power_Off => return C393001_1.Power_Off;
 322       when others =>
 323         return C393001_2.Status_Of( The_Breaker.Backup );
 324     end case;
 325   end Status_Of;
 326
 327   function On_Backup( The_Breaker : Special_Breaker ) return Boolean is
 328     use C393001_2;
 329     use type C393001_1.Status;
 330   begin
 331     return Status_Of(Basic_Breaker(The_Breaker)) = C393001_1.Tripped
 332         or Status_Of(Basic_Breaker(The_Breaker)) = C393001_1.Failed;
 333   end On_Backup;
 334
 335 end C393001_4;
 336
 337 ------------------------------------------------------------------- C393001
 338
 339 with Report, TCTouch;
 340 with C393001_1, C393001_2, C393001_3, C393001_4;
 341 procedure C393001 is
 342
 343   procedure Flipper( The_Circuit : in out C393001_1.Breaker'Class ) is
 344   begin
 345       C393001_1.Flip( The_Circuit );
 346   end Flipper;
 347
 348   procedure Tripper( The_Circuit : in out C393001_1.Breaker'Class ) is
 349   begin
 350       C393001_1.Trip( The_Circuit );
 351   end Tripper;
 352
 353   procedure Restore( The_Circuit : in out C393001_1.Breaker'Class ) is
 354   begin
 355       C393001_1.Reset( The_Circuit );
 356   end Restore;
 357
 358   procedure Failure( The_Circuit : in out C393001_1.Breaker'Class ) is
 359   begin
 360       C393001_1.Fail( The_Circuit );
 361   end Failure;
 362
 363   Short : C393001_1.Breaker'Class -- Basic_Breaker
 364           := C393001_2.Construct( C393001_2.V440, C393001_2.A5 );
 365   Sharp : C393001_1.Breaker'Class -- Ground_Fault
 366           := C393001_3.Construct( C393001_2.V110, C393001_2.A1 );
 367   Shock : C393001_1.Breaker'Class -- Special_Breaker
 368           := C393001_4.Construct( C393001_2.V12,  C393001_2.A100 );
 369
 370 begin  -- Main test procedure.
 371
 372   Report.Test ("C393001", "Check that an abstract type can be declared " &
 373                "and used.  Check actual subprograms dispatch correctly" );
 374
 375   TCTouch.Validate( "cgcicc", "Declaration" );
 376
 377   Flipper( Short );
 378   TCTouch.Validate( "db", "Flipping Short" );
 379   Flipper( Sharp );
 380   TCTouch.Validate( "db", "Flipping Sharp" );
 381   Flipper( Shock );
 382   TCTouch.Validate( "jbdb", "Flipping Shock" );
 383
 384   Tripper( Short );
 385   TCTouch.Validate( "e", "Tripping Short" );
 386   Tripper( Sharp );
 387   TCTouch.Validate( "e", "Tripping Sharp" );
 388   Tripper( Shock );
 389   TCTouch.Validate( "kbfbe", "Tripping Shock" );
 390
 391   Restore( Short );
 392   TCTouch.Validate( "fb", "Restoring Short" );
 393   Restore( Sharp );
 394   TCTouch.Validate( "fb", "Restoring Sharp" );
 395   Restore( Shock );
 396   TCTouch.Validate( "lbfb", "Restoring Shock" );
 397
 398   Failure( Short );
 399   TCTouch.Validate( "a", "Shock Failing" );
 400   Failure( Sharp );
 401   TCTouch.Validate( "a", "Shock Failing" );
 402   Failure( Shock );
 403   TCTouch.Validate( "mbafb", "Shock Failing" );
 404
 405   Report.Result;
 406
 407 end C393001;