gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c3/c3a2001.a

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