llvm-gcc-4.0/gcc/testsuite/ada/acats/tests/c3/c392004.a

-- C392004.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 subprograms inherited from tagged derivations, which are
--      subsequently redefined for the derived type, are available to the
--      package defining the new class via view conversion.  Check
--      that operations performed on objects using view conversion do not 
--      affect the extended fields.  Check that visible operations not masked 
--      by the deriving package remain available to the client, and do not 
--      affect the extended fields.
--
-- TEST DESCRIPTION:
--      This test declares a tagged type, with a constructor operation,
--      derives a type from that tagged type, and declares a constructor
--      operation which masks the inherited operation.  It then tests
--      that the correct constructor is called, and that the extended
--      part of the derived type remains untouched as appropriate.
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      19 Dec 94   SAIC    Removed RM references from objective text.
--      04 Jan 94   SAIC    Fixed objective typo, removed dead code.
--
--!

with Report;

package C392004_1 is

  type Vehicle is tagged private;

  procedure Create ( The_Vehicle :    out Vehicle; TC_Flag : Natural );
  procedure Start  ( The_Vehicle : in out Vehicle );

private

  type Vehicle is tagged record
    Engine_On : Boolean;
  end record;

end C392004_1;

package body C392004_1 is
  procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural ) is
  begin
    case TC_Flag is
      when 1 => null; -- expected flag for this subprogram
      when others =>
         Report.Failed ("Called Vehicle Create");
    end case;
    The_Vehicle := (Engine_On => False);
  end Create;

  procedure Start ( The_Vehicle : in out Vehicle ) is
  begin
    The_Vehicle.Engine_On := True;
  end Start;

end C392004_1;

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

with C392004_1;
package C392004_2 is

  type Car is new C392004_1.Vehicle with record
    Convertible : Boolean;
  end record;

  -- masking definition
  procedure Create( The_Car : out Car; TC_Flag : Natural );

  type Limo is new Car with null record;

  procedure Create( The_Limo : out Limo; TC_Flag : Natural );

end C392004_2;

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

with Report;
package body C392004_2 is

  procedure Create( The_Car : out Car; TC_Flag : Natural ) is
  begin
    case TC_Flag is
      when 2      => null; -- expected flag for this subprogram
      when others => Report.Failed ("Called Car Create");
    end case;
    C392004_1.Create( C392004_1.Vehicle(The_Car), 1);
    The_Car.Convertible := False;
  end Create;

  procedure Create( The_Limo : out Limo; TC_Flag : Natural ) is
  begin
    case TC_Flag is
      when 3      => null; -- expected flag for this subprogram
      when others => Report.Failed ("Called Limo Create");
    end case;
    C392004_1.Create( C392004_1.Vehicle(The_Limo), 1);
    The_Limo.Convertible := True;
 end Create;

end C392004_2;

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

with Report;
with C392004_1; use C392004_1;
with C392004_2; use C392004_2;
procedure C392004 is

  My_Car : Car;
  Your_Car : Limo;

  procedure TC_Assert( Is_True : Boolean; Message : String ) is
  begin
    if not Is_True then
      Report.Failed (Message);
    end if;
  end TC_Assert;

begin  -- Main test procedure.

  Report.Test ("C392004", "Check subprogram inheritance & visibility " &
                          "for derived tagged types" );

  My_Car.Convertible := False;
  Create( Vehicle( My_Car ), 1 );
  TC_Assert( not My_Car.Convertible, "Altered descendent component 1");

  Create( Your_Car, 3 );
  TC_Assert( Your_Car.Convertible, "Did not set inherited component 2");

  My_Car.Convertible := True;
  Create( Vehicle( My_Car ), 1 );
  TC_Assert( My_Car.Convertible, "Altered descendent component 3");

  Create( My_Car, 2 );
  TC_Assert( not My_Car.Convertible, "Did not set extending component 4");

  My_Car.Convertible := False;
  Start( Vehicle( My_Car ) );
  TC_Assert( not My_Car.Convertible , "Altered descendent component 5");

  Start( My_Car );
  TC_Assert( not My_Car.Convertible, "Altered unreferenced component 6");

  Your_Car.Convertible := False;
  Start( Vehicle( Your_Car ) );
  TC_Assert( not Your_Car.Convertible , "Altered descendent component 7");

  Start( Your_Car );
  TC_Assert( not Your_Car.Convertible, "Altered unreferenced component 8");

  My_Car.Convertible := True;
  Start( Vehicle( My_Car ) );
  TC_Assert( My_Car.Convertible, "Altered descendent component 9");

  Start( My_Car );
  TC_Assert( My_Car.Convertible, "Altered unreferenced component 10");

  Report.Result;

end C392004;