old-autovect-branch/gcc/testsuite/ada/acats/tests/c3/c392004.a

   1 -- C392004.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 subprograms inherited from tagged derivations, which are
  28 --      subsequently redefined for the derived type, are available to the
  29 --      package defining the new class via view conversion.  Check
  30 --      that operations performed on objects using view conversion do not
  31 --      affect the extended fields.  Check that visible operations not masked
  32 --      by the deriving package remain available to the client, and do not
  33 --      affect the extended fields.
  34 --
  35 -- TEST DESCRIPTION:
  36 --      This test declares a tagged type, with a constructor operation,
  37 --      derives a type from that tagged type, and declares a constructor
  38 --      operation which masks the inherited operation.  It then tests
  39 --      that the correct constructor is called, and that the extended
  40 --      part of the derived type remains untouched as appropriate.
  41 --
  42 --
  43 -- CHANGE HISTORY:
  44 --      06 Dec 94   SAIC    ACVC 2.0
  45 --      19 Dec 94   SAIC    Removed RM references from objective text.
  46 --      04 Jan 94   SAIC    Fixed objective typo, removed dead code.
  47 --
  48 --!
  49
  50 with Report;
  51
  52 package C392004_1 is
  53
  54   type Vehicle is tagged private;
  55
  56   procedure Create ( The_Vehicle :    out Vehicle; TC_Flag : Natural );
  57   procedure Start  ( The_Vehicle : in out Vehicle );
  58
  59 private
  60
  61   type Vehicle is tagged record
  62     Engine_On : Boolean;
  63   end record;
  64
  65 end C392004_1;
  66
  67 package body C392004_1 is
  68   procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural ) is
  69   begin
  70     case TC_Flag is
  71       when 1 => null; -- expected flag for this subprogram
  72       when others =>
  73          Report.Failed ("Called Vehicle Create");
  74     end case;
  75     The_Vehicle := (Engine_On => False);
  76   end Create;
  77
  78   procedure Start ( The_Vehicle : in out Vehicle ) is
  79   begin
  80     The_Vehicle.Engine_On := True;
  81   end Start;
  82
  83 end C392004_1;
  84
  85 ----------------------------------------------------------------------------
  86
  87 with C392004_1;
  88 package C392004_2 is
  89
  90   type Car is new C392004_1.Vehicle with record
  91     Convertible : Boolean;
  92   end record;
  93
  94   -- masking definition
  95   procedure Create( The_Car : out Car; TC_Flag : Natural );
  96
  97   type Limo is new Car with null record;
  98
  99   procedure Create( The_Limo : out Limo; TC_Flag : Natural );
 100
 101 end C392004_2;
 102
 103 ----------------------------------------------------------------------------
 104
 105 with Report;
 106 package body C392004_2 is
 107
 108   procedure Create( The_Car : out Car; TC_Flag : Natural ) is
 109   begin
 110     case TC_Flag is
 111       when 2      => null; -- expected flag for this subprogram
 112       when others => Report.Failed ("Called Car Create");
 113     end case;
 114     C392004_1.Create( C392004_1.Vehicle(The_Car), 1);
 115     The_Car.Convertible := False;
 116   end Create;
 117
 118   procedure Create( The_Limo : out Limo; TC_Flag : Natural ) is
 119   begin
 120     case TC_Flag is
 121       when 3      => null; -- expected flag for this subprogram
 122       when others => Report.Failed ("Called Limo Create");
 123     end case;
 124     C392004_1.Create( C392004_1.Vehicle(The_Limo), 1);
 125     The_Limo.Convertible := True;
 126  end Create;
 127
 128 end C392004_2;
 129
 130 ----------------------------------------------------------------------------
 131
 132 with Report;
 133 with C392004_1; use C392004_1;
 134 with C392004_2; use C392004_2;
 135 procedure C392004 is
 136
 137   My_Car : Car;
 138   Your_Car : Limo;
 139
 140   procedure TC_Assert( Is_True : Boolean; Message : String ) is
 141   begin
 142     if not Is_True then
 143       Report.Failed (Message);
 144     end if;
 145   end TC_Assert;
 146
 147 begin  -- Main test procedure.
 148
 149   Report.Test ("C392004", "Check subprogram inheritance & visibility " &
 150                           "for derived tagged types" );
 151
 152   My_Car.Convertible := False;
 153   Create( Vehicle( My_Car ), 1 );
 154   TC_Assert( not My_Car.Convertible, "Altered descendent component 1");
 155
 156   Create( Your_Car, 3 );
 157   TC_Assert( Your_Car.Convertible, "Did not set inherited component 2");
 158
 159   My_Car.Convertible := True;
 160   Create( Vehicle( My_Car ), 1 );
 161   TC_Assert( My_Car.Convertible, "Altered descendent component 3");
 162
 163   Create( My_Car, 2 );
 164   TC_Assert( not My_Car.Convertible, "Did not set extending component 4");
 165
 166   My_Car.Convertible := False;
 167   Start( Vehicle( My_Car ) );
 168   TC_Assert( not My_Car.Convertible , "Altered descendent component 5");
 169
 170   Start( My_Car );
 171   TC_Assert( not My_Car.Convertible, "Altered unreferenced component 6");
 172
 173   Your_Car.Convertible := False;
 174   Start( Vehicle( Your_Car ) );
 175   TC_Assert( not Your_Car.Convertible , "Altered descendent component 7");
 176
 177   Start( Your_Car );
 178   TC_Assert( not Your_Car.Convertible, "Altered unreferenced component 8");
 179
 180   My_Car.Convertible := True;
 181   Start( Vehicle( My_Car ) );
 182   TC_Assert( My_Car.Convertible, "Altered descendent component 9");
 183
 184   Start( My_Car );
 185   TC_Assert( My_Car.Convertible, "Altered unreferenced component 10");
 186
 187   Report.Result;
 188
 189 end C392004;