-- C393012.A
|
-- C393012.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 a non-abstract subprogram of an abstract type can be
|
-- Check that a non-abstract subprogram of an abstract type can be
|
-- called with a controlling operand that is a type conversion to
|
-- called with a controlling operand that is a type conversion to
|
-- the abstract type.
|
-- the abstract type.
|
--
|
--
|
-- Check that converting to the class-wide type of an abstract type
|
-- Check that converting to the class-wide type of an abstract type
|
-- inside an operation of that type causes a "redispatch" of the
|
-- inside an operation of that type causes a "redispatch" of the
|
-- called operation.
|
-- called operation.
|
--
|
--
|
-- TEST DESCRIPTION:
|
-- TEST DESCRIPTION:
|
-- This test defines an abstract type, and further derives types from it.
|
-- This test defines an abstract type, and further derives types from it.
|
-- The key feature of this test is in the "Display" procedures where
|
-- The key feature of this test is in the "Display" procedures where
|
-- the bodies of these procedures convert an object to the class-wide
|
-- the bodies of these procedures convert an object to the class-wide
|
-- type of the root abstract type, causing a "redispatch".
|
-- type of the root abstract type, causing a "redispatch".
|
--
|
--
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 16 Dec 94 SAIC Add allocation to the object initializations
|
-- 16 Dec 94 SAIC Add allocation to the object initializations
|
--
|
--
|
--!
|
--!
|
|
|
package C393012_0 is
|
package C393012_0 is
|
|
|
subtype Row_Number is Positive range 1..120;
|
subtype Row_Number is Positive range 1..120;
|
subtype Seat_Letter is Character range 'A'..'M';
|
subtype Seat_Letter is Character range 'A'..'M';
|
|
|
type Ticket is abstract tagged
|
type Ticket is abstract tagged
|
record
|
record
|
Flight : Natural;
|
Flight : Natural;
|
Row : Row_Number;
|
Row : Row_Number;
|
Seat : Seat_Letter;
|
Seat : Seat_Letter;
|
end record;
|
end record;
|
|
|
function Display( T: Ticket ) return String;
|
function Display( T: Ticket ) return String;
|
function Service( T: Ticket ) return String is abstract;
|
function Service( T: Ticket ) return String is abstract;
|
|
|
end C393012_0;
|
end C393012_0;
|
|
|
with TCTouch;
|
with TCTouch;
|
package body C393012_0 is
|
package body C393012_0 is
|
function Display( T: Ticket ) return String is
|
function Display( T: Ticket ) return String is
|
begin
|
begin
|
TCTouch.Touch('T'); --------------------------------------------------- T
|
TCTouch.Touch('T'); --------------------------------------------------- T
|
return "Fl:" & Natural'Image(T.Flight)
|
return "Fl:" & Natural'Image(T.Flight)
|
& Service( Ticket'Class( T ) )
|
& Service( Ticket'Class( T ) )
|
& " Seat:" & Row_Number'Image(T.Row) & T.Seat;
|
& " Seat:" & Row_Number'Image(T.Row) & T.Seat;
|
end Display;
|
end Display;
|
end C393012_0;
|
end C393012_0;
|
|
|
with C393012_0;
|
with C393012_0;
|
package C393012_1 is
|
package C393012_1 is
|
type Economy is new C393012_0.Ticket with null record;
|
type Economy is new C393012_0.Ticket with null record;
|
function Display( T: Economy ) return String;
|
function Display( T: Economy ) return String;
|
function Service( T: Economy ) return String;
|
function Service( T: Economy ) return String;
|
|
|
type Meal_Designator is ( B, L, D, V, SN );
|
type Meal_Designator is ( B, L, D, V, SN );
|
|
|
type First is new C393012_0.Ticket with
|
type First is new C393012_0.Ticket with
|
record
|
record
|
Meal : Meal_Designator;
|
Meal : Meal_Designator;
|
end record;
|
end record;
|
function Display( T: First ) return String;
|
function Display( T: First ) return String;
|
function Service( T: First ) return String;
|
function Service( T: First ) return String;
|
procedure Set_Meal( T: in out First; To_Meal : Meal_Designator );
|
procedure Set_Meal( T: in out First; To_Meal : Meal_Designator );
|
|
|
end C393012_1;
|
end C393012_1;
|
|
|
with TCTouch;
|
with TCTouch;
|
package body C393012_1 is
|
package body C393012_1 is
|
function Display( T: Economy ) return String is
|
function Display( T: Economy ) return String is
|
begin
|
begin
|
TCTouch.Touch('E'); --------------------------------------------------- E
|
TCTouch.Touch('E'); --------------------------------------------------- E
|
return C393012_0.Display( C393012_0.Ticket( T ) );
|
return C393012_0.Display( C393012_0.Ticket( T ) );
|
end Display; -- conversion to abstract type
|
end Display; -- conversion to abstract type
|
|
|
function Service( T: Economy ) return String is
|
function Service( T: Economy ) return String is
|
begin
|
begin
|
TCTouch.Touch('e'); --------------------------------------------------- e
|
TCTouch.Touch('e'); --------------------------------------------------- e
|
return " K";
|
return " K";
|
end Service;
|
end Service;
|
|
|
function Display( T: First ) return String is
|
function Display( T: First ) return String is
|
begin
|
begin
|
TCTouch.Touch('F'); --------------------------------------------------- F
|
TCTouch.Touch('F'); --------------------------------------------------- F
|
return C393012_0.Display( C393012_0.Ticket( T ) );
|
return C393012_0.Display( C393012_0.Ticket( T ) );
|
end Display; -- conversion to abstract type
|
end Display; -- conversion to abstract type
|
|
|
function Service( T: First ) return String is
|
function Service( T: First ) return String is
|
begin
|
begin
|
TCTouch.Touch('f'); --------------------------------------------------- f
|
TCTouch.Touch('f'); --------------------------------------------------- f
|
return " F" & Meal_Designator'Image(T.Meal);
|
return " F" & Meal_Designator'Image(T.Meal);
|
end Service;
|
end Service;
|
|
|
procedure Set_Meal( T: in out First; To_Meal : Meal_Designator ) is
|
procedure Set_Meal( T: in out First; To_Meal : Meal_Designator ) is
|
begin
|
begin
|
T.Meal := To_Meal;
|
T.Meal := To_Meal;
|
end Set_Meal;
|
end Set_Meal;
|
|
|
end C393012_1;
|
end C393012_1;
|
|
|
with Report;
|
with Report;
|
with TCTouch;
|
with TCTouch;
|
with C393012_0;
|
with C393012_0;
|
with C393012_1;
|
with C393012_1;
|
procedure C393012 is
|
procedure C393012 is
|
|
|
package Rt renames C393012_0;
|
package Rt renames C393012_0;
|
package Tx renames C393012_1;
|
package Tx renames C393012_1;
|
|
|
type Tix is access Rt.Ticket'Class;
|
type Tix is access Rt.Ticket'Class;
|
type Itinerary is array(Positive range 1..3) of Tix;
|
type Itinerary is array(Positive range 1..3) of Tix;
|
|
|
-- Outbound and Inbound itineraries provide different orderings of mixtures
|
-- Outbound and Inbound itineraries provide different orderings of mixtures
|
-- of Economy and First_Class. Not that that should make any difference...
|
-- of Economy and First_Class. Not that that should make any difference...
|
|
|
Outbound : Itinerary := ( 1 => new Tx.Economy'( 5335, 5, 'B' ),
|
Outbound : Itinerary := ( 1 => new Tx.Economy'( 5335, 5, 'B' ),
|
2 => new Tx.First' ( 67, 1, 'J', Tx.L ),
|
2 => new Tx.First' ( 67, 1, 'J', Tx.L ),
|
3 => new Tx.Economy'( 345, 37, 'C' ) );
|
3 => new Tx.Economy'( 345, 37, 'C' ) );
|
|
|
Inbound : Itinerary := ( 1 => new Tx.First' ( 456, 4, 'F', Tx.SN ),
|
Inbound : Itinerary := ( 1 => new Tx.First' ( 456, 4, 'F', Tx.SN ),
|
2 => new Tx.Economy'( 68, 12, 'D' ),
|
2 => new Tx.Economy'( 68, 12, 'D' ),
|
3 => new Tx.Economy'( 5336, 6, 'A' ) );
|
3 => new Tx.Economy'( 5336, 6, 'A' ) );
|
|
|
-- Each call to Display uses a parameter that is a type conversion
|
-- Each call to Display uses a parameter that is a type conversion
|
-- to the abstract type Ticket.
|
-- to the abstract type Ticket.
|
|
|
procedure TC_Convert( I: Itinerary; Leg1,Leg2,Leg3: String ) is
|
procedure TC_Convert( I: Itinerary; Leg1,Leg2,Leg3: String ) is
|
begin
|
begin
|
if Rt.Display( Rt.Ticket( I(1).all ) ) /= Leg1 then
|
if Rt.Display( Rt.Ticket( I(1).all ) ) /= Leg1 then
|
Report.Failed( Rt.Display( Rt.Ticket( I(1).all ) ) & " /= " & Leg1 );
|
Report.Failed( Rt.Display( Rt.Ticket( I(1).all ) ) & " /= " & Leg1 );
|
end if;
|
end if;
|
if Rt.Display( Rt.Ticket( I(2).all ) ) /= Leg2 then
|
if Rt.Display( Rt.Ticket( I(2).all ) ) /= Leg2 then
|
Report.Failed( Rt.Display( Rt.Ticket( I(2).all ) ) & " /= " & Leg2 );
|
Report.Failed( Rt.Display( Rt.Ticket( I(2).all ) ) & " /= " & Leg2 );
|
end if;
|
end if;
|
if Rt.Display( Rt.Ticket( I(3).all ) ) /= Leg3 then
|
if Rt.Display( Rt.Ticket( I(3).all ) ) /= Leg3 then
|
Report.Failed( Rt.Display( Rt.Ticket( I(3).all ) ) & " /= " & Leg3 );
|
Report.Failed( Rt.Display( Rt.Ticket( I(3).all ) ) & " /= " & Leg3 );
|
end if;
|
end if;
|
end TC_Convert;
|
end TC_Convert;
|
|
|
-- Each call to Display uses a parameter that is not a type conversion
|
-- Each call to Display uses a parameter that is not a type conversion
|
|
|
procedure TC_Match( I: Itinerary; Leg1,Leg2,Leg3: String ) is
|
procedure TC_Match( I: Itinerary; Leg1,Leg2,Leg3: String ) is
|
begin
|
begin
|
if Rt.Display( I(1).all ) /= Leg1 then
|
if Rt.Display( I(1).all ) /= Leg1 then
|
Report.Failed( Rt.Display( I(1).all ) & " /= " & Leg1 );
|
Report.Failed( Rt.Display( I(1).all ) & " /= " & Leg1 );
|
end if;
|
end if;
|
if Rt.Display( I(2).all ) /= Leg2 then
|
if Rt.Display( I(2).all ) /= Leg2 then
|
Report.Failed( Rt.Display( I(2).all ) & " /= " & Leg2 );
|
Report.Failed( Rt.Display( I(2).all ) & " /= " & Leg2 );
|
end if;
|
end if;
|
if Rt.Display( I(3).all ) /= Leg3 then
|
if Rt.Display( I(3).all ) /= Leg3 then
|
Report.Failed( Rt.Display( I(3).all ) & " /= " & Leg3 );
|
Report.Failed( Rt.Display( I(3).all ) & " /= " & Leg3 );
|
end if;
|
end if;
|
end TC_Match;
|
end TC_Match;
|
|
|
begin -- Main test procedure.
|
begin -- Main test procedure.
|
|
|
Report.Test ("C393012", "Check that a non-abstract subprogram of an "
|
Report.Test ("C393012", "Check that a non-abstract subprogram of an "
|
& "abstract type can be called with a "
|
& "abstract type can be called with a "
|
& "controlling operand that is a type "
|
& "controlling operand that is a type "
|
& "conversion to the abstract type. "
|
& "conversion to the abstract type. "
|
& "Check that converting to the class-wide type "
|
& "Check that converting to the class-wide type "
|
& "of an abstract type inside an operation of "
|
& "of an abstract type inside an operation of "
|
& "that type causes a redispatch" );
|
& "that type causes a redispatch" );
|
|
|
-- Test conversions to abstract type
|
-- Test conversions to abstract type
|
|
|
TC_Convert( Outbound, "Fl: 5335 K Seat: 5B",
|
TC_Convert( Outbound, "Fl: 5335 K Seat: 5B",
|
"Fl: 67 FL Seat: 1J",
|
"Fl: 67 FL Seat: 1J",
|
"Fl: 345 K Seat: 37C" );
|
"Fl: 345 K Seat: 37C" );
|
|
|
TCTouch.Validate( "TeTfTe", "Outbound flight (converted)" );
|
TCTouch.Validate( "TeTfTe", "Outbound flight (converted)" );
|
|
|
TC_Convert( Inbound, "Fl: 456 FSN Seat: 4F",
|
TC_Convert( Inbound, "Fl: 456 FSN Seat: 4F",
|
"Fl: 68 K Seat: 12D",
|
"Fl: 68 K Seat: 12D",
|
"Fl: 5336 K Seat: 6A" );
|
"Fl: 5336 K Seat: 6A" );
|
|
|
TCTouch.Validate( "TfTeTe", "Inbound flight (converted)" );
|
TCTouch.Validate( "TfTeTe", "Inbound flight (converted)" );
|
|
|
-- Test without conversions to abstract type
|
-- Test without conversions to abstract type
|
|
|
TC_Match( Outbound, "Fl: 5335 K Seat: 5B",
|
TC_Match( Outbound, "Fl: 5335 K Seat: 5B",
|
"Fl: 67 FL Seat: 1J",
|
"Fl: 67 FL Seat: 1J",
|
"Fl: 345 K Seat: 37C" );
|
"Fl: 345 K Seat: 37C" );
|
|
|
TCTouch.Validate( "ETeFTfETe", "Outbound flight" );
|
TCTouch.Validate( "ETeFTfETe", "Outbound flight" );
|
|
|
TC_Match( Inbound, "Fl: 456 FSN Seat: 4F",
|
TC_Match( Inbound, "Fl: 456 FSN Seat: 4F",
|
"Fl: 68 K Seat: 12D",
|
"Fl: 68 K Seat: 12D",
|
"Fl: 5336 K Seat: 6A" );
|
"Fl: 5336 K Seat: 6A" );
|
|
|
TCTouch.Validate( "FTfETeETe", "Inbound flight" );
|
TCTouch.Validate( "FTfETeETe", "Inbound flight" );
|
|
|
Report.Result;
|
Report.Result;
|
|
|
end C393012;
|
end C393012;
|
|
|
