-- C392004.A
|
-- C392004.A
|
--
|
--
|
-- Grant of Unlimited Rights
|
-- Grant of Unlimited Rights
|
--
|
--
|
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
|
-- 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
|
-- 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 in the software and documentation contained herein.
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- this public release, the Government intends to confer upon all
|
-- this public release, the Government intends to confer upon all
|
-- recipients unlimited rights equal to those held by the Government.
|
-- recipients unlimited rights equal to those held by the Government.
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- released technical data and computer software in whole or in part, in
|
-- 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
|
-- any manner and for any purpose whatsoever, and to have or permit others
|
-- to do so.
|
-- to do so.
|
--
|
--
|
-- DISCLAIMER
|
-- DISCLAIMER
|
--
|
--
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
--*
|
--*
|
--
|
--
|
-- OBJECTIVE:
|
-- OBJECTIVE:
|
-- Check that subprograms inherited from tagged derivations, which are
|
-- Check that subprograms inherited from tagged derivations, which are
|
-- subsequently redefined for the derived type, are available to the
|
-- subsequently redefined for the derived type, are available to the
|
-- package defining the new class via view conversion. Check
|
-- package defining the new class via view conversion. Check
|
-- that operations performed on objects using view conversion do not
|
-- that operations performed on objects using view conversion do not
|
-- affect the extended fields. Check that visible operations not masked
|
-- affect the extended fields. Check that visible operations not masked
|
-- by the deriving package remain available to the client, and do not
|
-- by the deriving package remain available to the client, and do not
|
-- affect the extended fields.
|
-- affect the extended fields.
|
--
|
--
|
-- TEST DESCRIPTION:
|
-- TEST DESCRIPTION:
|
-- This test declares a tagged type, with a constructor operation,
|
-- This test declares a tagged type, with a constructor operation,
|
-- derives a type from that tagged type, and declares a constructor
|
-- derives a type from that tagged type, and declares a constructor
|
-- operation which masks the inherited operation. It then tests
|
-- operation which masks the inherited operation. It then tests
|
-- that the correct constructor is called, and that the extended
|
-- that the correct constructor is called, and that the extended
|
-- part of the derived type remains untouched as appropriate.
|
-- part of the derived type remains untouched as appropriate.
|
--
|
--
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 19 Dec 94 SAIC Removed RM references from objective text.
|
-- 19 Dec 94 SAIC Removed RM references from objective text.
|
-- 04 Jan 94 SAIC Fixed objective typo, removed dead code.
|
-- 04 Jan 94 SAIC Fixed objective typo, removed dead code.
|
--
|
--
|
--!
|
--!
|
|
|
with Report;
|
with Report;
|
|
|
package C392004_1 is
|
package C392004_1 is
|
|
|
type Vehicle is tagged private;
|
type Vehicle is tagged private;
|
|
|
procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural );
|
procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural );
|
procedure Start ( The_Vehicle : in out Vehicle );
|
procedure Start ( The_Vehicle : in out Vehicle );
|
|
|
private
|
private
|
|
|
type Vehicle is tagged record
|
type Vehicle is tagged record
|
Engine_On : Boolean;
|
Engine_On : Boolean;
|
end record;
|
end record;
|
|
|
end C392004_1;
|
end C392004_1;
|
|
|
package body C392004_1 is
|
package body C392004_1 is
|
procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural ) is
|
procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural ) is
|
begin
|
begin
|
case TC_Flag is
|
case TC_Flag is
|
when 1 => null; -- expected flag for this subprogram
|
when 1 => null; -- expected flag for this subprogram
|
when others =>
|
when others =>
|
Report.Failed ("Called Vehicle Create");
|
Report.Failed ("Called Vehicle Create");
|
end case;
|
end case;
|
The_Vehicle := (Engine_On => False);
|
The_Vehicle := (Engine_On => False);
|
end Create;
|
end Create;
|
|
|
procedure Start ( The_Vehicle : in out Vehicle ) is
|
procedure Start ( The_Vehicle : in out Vehicle ) is
|
begin
|
begin
|
The_Vehicle.Engine_On := True;
|
The_Vehicle.Engine_On := True;
|
end Start;
|
end Start;
|
|
|
end C392004_1;
|
end C392004_1;
|
|
|
----------------------------------------------------------------------------
|
----------------------------------------------------------------------------
|
|
|
with C392004_1;
|
with C392004_1;
|
package C392004_2 is
|
package C392004_2 is
|
|
|
type Car is new C392004_1.Vehicle with record
|
type Car is new C392004_1.Vehicle with record
|
Convertible : Boolean;
|
Convertible : Boolean;
|
end record;
|
end record;
|
|
|
-- masking definition
|
-- masking definition
|
procedure Create( The_Car : out Car; TC_Flag : Natural );
|
procedure Create( The_Car : out Car; TC_Flag : Natural );
|
|
|
type Limo is new Car with null record;
|
type Limo is new Car with null record;
|
|
|
procedure Create( The_Limo : out Limo; TC_Flag : Natural );
|
procedure Create( The_Limo : out Limo; TC_Flag : Natural );
|
|
|
end C392004_2;
|
end C392004_2;
|
|
|
----------------------------------------------------------------------------
|
----------------------------------------------------------------------------
|
|
|
with Report;
|
with Report;
|
package body C392004_2 is
|
package body C392004_2 is
|
|
|
procedure Create( The_Car : out Car; TC_Flag : Natural ) is
|
procedure Create( The_Car : out Car; TC_Flag : Natural ) is
|
begin
|
begin
|
case TC_Flag is
|
case TC_Flag is
|
when 2 => null; -- expected flag for this subprogram
|
when 2 => null; -- expected flag for this subprogram
|
when others => Report.Failed ("Called Car Create");
|
when others => Report.Failed ("Called Car Create");
|
end case;
|
end case;
|
C392004_1.Create( C392004_1.Vehicle(The_Car), 1);
|
C392004_1.Create( C392004_1.Vehicle(The_Car), 1);
|
The_Car.Convertible := False;
|
The_Car.Convertible := False;
|
end Create;
|
end Create;
|
|
|
procedure Create( The_Limo : out Limo; TC_Flag : Natural ) is
|
procedure Create( The_Limo : out Limo; TC_Flag : Natural ) is
|
begin
|
begin
|
case TC_Flag is
|
case TC_Flag is
|
when 3 => null; -- expected flag for this subprogram
|
when 3 => null; -- expected flag for this subprogram
|
when others => Report.Failed ("Called Limo Create");
|
when others => Report.Failed ("Called Limo Create");
|
end case;
|
end case;
|
C392004_1.Create( C392004_1.Vehicle(The_Limo), 1);
|
C392004_1.Create( C392004_1.Vehicle(The_Limo), 1);
|
The_Limo.Convertible := True;
|
The_Limo.Convertible := True;
|
end Create;
|
end Create;
|
|
|
end C392004_2;
|
end C392004_2;
|
|
|
----------------------------------------------------------------------------
|
----------------------------------------------------------------------------
|
|
|
with Report;
|
with Report;
|
with C392004_1; use C392004_1;
|
with C392004_1; use C392004_1;
|
with C392004_2; use C392004_2;
|
with C392004_2; use C392004_2;
|
procedure C392004 is
|
procedure C392004 is
|
|
|
My_Car : Car;
|
My_Car : Car;
|
Your_Car : Limo;
|
Your_Car : Limo;
|
|
|
procedure TC_Assert( Is_True : Boolean; Message : String ) is
|
procedure TC_Assert( Is_True : Boolean; Message : String ) is
|
begin
|
begin
|
if not Is_True then
|
if not Is_True then
|
Report.Failed (Message);
|
Report.Failed (Message);
|
end if;
|
end if;
|
end TC_Assert;
|
end TC_Assert;
|
|
|
begin -- Main test procedure.
|
begin -- Main test procedure.
|
|
|
Report.Test ("C392004", "Check subprogram inheritance & visibility " &
|
Report.Test ("C392004", "Check subprogram inheritance & visibility " &
|
"for derived tagged types" );
|
"for derived tagged types" );
|
|
|
My_Car.Convertible := False;
|
My_Car.Convertible := False;
|
Create( Vehicle( My_Car ), 1 );
|
Create( Vehicle( My_Car ), 1 );
|
TC_Assert( not My_Car.Convertible, "Altered descendent component 1");
|
TC_Assert( not My_Car.Convertible, "Altered descendent component 1");
|
|
|
Create( Your_Car, 3 );
|
Create( Your_Car, 3 );
|
TC_Assert( Your_Car.Convertible, "Did not set inherited component 2");
|
TC_Assert( Your_Car.Convertible, "Did not set inherited component 2");
|
|
|
My_Car.Convertible := True;
|
My_Car.Convertible := True;
|
Create( Vehicle( My_Car ), 1 );
|
Create( Vehicle( My_Car ), 1 );
|
TC_Assert( My_Car.Convertible, "Altered descendent component 3");
|
TC_Assert( My_Car.Convertible, "Altered descendent component 3");
|
|
|
Create( My_Car, 2 );
|
Create( My_Car, 2 );
|
TC_Assert( not My_Car.Convertible, "Did not set extending component 4");
|
TC_Assert( not My_Car.Convertible, "Did not set extending component 4");
|
|
|
My_Car.Convertible := False;
|
My_Car.Convertible := False;
|
Start( Vehicle( My_Car ) );
|
Start( Vehicle( My_Car ) );
|
TC_Assert( not My_Car.Convertible , "Altered descendent component 5");
|
TC_Assert( not My_Car.Convertible , "Altered descendent component 5");
|
|
|
Start( My_Car );
|
Start( My_Car );
|
TC_Assert( not My_Car.Convertible, "Altered unreferenced component 6");
|
TC_Assert( not My_Car.Convertible, "Altered unreferenced component 6");
|
|
|
Your_Car.Convertible := False;
|
Your_Car.Convertible := False;
|
Start( Vehicle( Your_Car ) );
|
Start( Vehicle( Your_Car ) );
|
TC_Assert( not Your_Car.Convertible , "Altered descendent component 7");
|
TC_Assert( not Your_Car.Convertible , "Altered descendent component 7");
|
|
|
Start( Your_Car );
|
Start( Your_Car );
|
TC_Assert( not Your_Car.Convertible, "Altered unreferenced component 8");
|
TC_Assert( not Your_Car.Convertible, "Altered unreferenced component 8");
|
|
|
My_Car.Convertible := True;
|
My_Car.Convertible := True;
|
Start( Vehicle( My_Car ) );
|
Start( Vehicle( My_Car ) );
|
TC_Assert( My_Car.Convertible, "Altered descendent component 9");
|
TC_Assert( My_Car.Convertible, "Altered descendent component 9");
|
|
|
Start( My_Car );
|
Start( My_Car );
|
TC_Assert( My_Car.Convertible, "Altered unreferenced component 10");
|
TC_Assert( My_Car.Convertible, "Altered unreferenced component 10");
|
|
|
Report.Result;
|
Report.Result;
|
|
|
end C392004;
|
end C392004;
|
|
|
