-- C393010.A
|
-- C393010.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.
|
--*
|
--*
|
--
|
--
|
-- TEST OBJECTIVE:
|
-- TEST OBJECTIVE:
|
-- Check that an extended type can be derived from an abstract type and
|
-- Check that an extended type can be derived from an abstract type and
|
-- that a call on an abstract operation is a dispatching operation.
|
-- that a call on an abstract operation is a dispatching operation.
|
-- Check that such a call can dispatch to an overriding operation
|
-- Check that such a call can dispatch to an overriding operation
|
-- declared in the private part of a package.
|
-- declared in the private part of a package.
|
--
|
--
|
-- TEST DESCRIPTION:
|
-- TEST DESCRIPTION:
|
-- Taking from a classroom example of a typical usage: declare a basic
|
-- Taking from a classroom example of a typical usage: declare a basic
|
-- abstract type containing data germane to the entire class structure,
|
-- abstract type containing data germane to the entire class structure,
|
-- derive from that a type with specific data, and derive from that
|
-- derive from that a type with specific data, and derive from that
|
-- another type merely providing a "secret" override. The abstract type
|
-- another type merely providing a "secret" override. The abstract type
|
-- provides a concrete procedure that itself "redispatches" to an
|
-- provides a concrete procedure that itself "redispatches" to an
|
-- abstract procedure; the abstract procedure must be provided by one or
|
-- abstract procedure; the abstract procedure must be provided by one or
|
-- more of the concrete types derived from the abstract type, and hence
|
-- more of the concrete types derived from the abstract type, and hence
|
-- upon re-evaluating the actual type of the operand should dispatch
|
-- upon re-evaluating the actual type of the operand should dispatch
|
-- accordingly.
|
-- accordingly.
|
--
|
--
|
--
|
--
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 15 Mar 96 SAIC ACVC 2.1
|
-- 15 Mar 96 SAIC ACVC 2.1
|
--
|
--
|
--!
|
--!
|
|
|
----------------------------------------------------------------- C393010_0
|
----------------------------------------------------------------- C393010_0
|
|
|
package C393010_0 is
|
package C393010_0 is
|
|
|
type Ticket is abstract tagged record
|
type Ticket is abstract tagged record
|
Flight : Natural;
|
Flight : Natural;
|
Serial_Number : Natural;
|
Serial_Number : Natural;
|
end record;
|
end record;
|
|
|
function Issue return Ticket is abstract;
|
function Issue return Ticket is abstract;
|
procedure Label( T: Ticket ) is abstract;
|
procedure Label( T: Ticket ) is abstract;
|
|
|
procedure Print( T: Ticket );
|
procedure Print( T: Ticket );
|
|
|
end C393010_0;
|
end C393010_0;
|
|
|
with TCTouch;
|
with TCTouch;
|
package body C393010_0 is
|
package body C393010_0 is
|
|
|
procedure Print( T: Ticket ) is
|
procedure Print( T: Ticket ) is
|
begin
|
begin
|
-- Check that a call on an abstract operation is a dispatching operation
|
-- Check that a call on an abstract operation is a dispatching operation
|
Label( Ticket'Class( T ) );
|
Label( Ticket'Class( T ) );
|
-- Appropriate_IO.Put( T.Flight & T.Serial_Number );
|
-- Appropriate_IO.Put( T.Flight & T.Serial_Number );
|
TCTouch.Touch('P'); -------------------------------------------------- P
|
TCTouch.Touch('P'); -------------------------------------------------- P
|
end Print;
|
end Print;
|
|
|
end C393010_0;
|
end C393010_0;
|
|
|
----------------------------------------------------------------- C393010_1
|
----------------------------------------------------------------- C393010_1
|
|
|
with C393010_0;
|
with C393010_0;
|
package C393010_1 is
|
package C393010_1 is
|
|
|
type Service_Classes is (First, Business, Coach);
|
type Service_Classes is (First, Business, Coach);
|
|
|
type Menu is (Steak, Lobster, Fowl, Vegan);
|
type Menu is (Steak, Lobster, Fowl, Vegan);
|
|
|
-- Check that an extended type can be derived from an abstract type.
|
-- Check that an extended type can be derived from an abstract type.
|
type Passenger_Ticket(Service : Service_Classes) is
|
type Passenger_Ticket(Service : Service_Classes) is
|
new C393010_0.Ticket with record
|
new C393010_0.Ticket with record
|
Row_Seat : String(1..3);
|
Row_Seat : String(1..3);
|
case Service is
|
case Service is
|
when First | Business => Meal : Menu;
|
when First | Business => Meal : Menu;
|
when Coach => null;
|
when Coach => null;
|
end case;
|
end case;
|
end record;
|
end record;
|
|
|
function Issue return Passenger_Ticket;
|
function Issue return Passenger_Ticket;
|
function Issue( Service : Service_Classes;
|
function Issue( Service : Service_Classes;
|
Flight : Natural;
|
Flight : Natural;
|
Seat : String;
|
Seat : String;
|
Meal : Menu := Fowl ) return Passenger_Ticket;
|
Meal : Menu := Fowl ) return Passenger_Ticket;
|
|
|
procedure Label( T: Passenger_Ticket );
|
procedure Label( T: Passenger_Ticket );
|
|
|
procedure Print( T: Passenger_Ticket );
|
procedure Print( T: Passenger_Ticket );
|
|
|
end C393010_1;
|
end C393010_1;
|
|
|
with TCTouch;
|
with TCTouch;
|
package body C393010_1 is
|
package body C393010_1 is
|
|
|
procedure Label( T: Passenger_Ticket ) is
|
procedure Label( T: Passenger_Ticket ) is
|
begin
|
begin
|
-- Appropriate_IO.Put( T.Service );
|
-- Appropriate_IO.Put( T.Service );
|
TCTouch.Touch('L'); -------------------------------------------------- L
|
TCTouch.Touch('L'); -------------------------------------------------- L
|
end Label;
|
end Label;
|
|
|
procedure Print( T: Passenger_Ticket ) is
|
procedure Print( T: Passenger_Ticket ) is
|
begin
|
begin
|
-- call parent print:
|
-- call parent print:
|
C393010_0.Print( C393010_0.Ticket( T ) );
|
C393010_0.Print( C393010_0.Ticket( T ) );
|
case T.Service is
|
case T.Service is
|
when First => -- Appropriate_IO.Put( Meal );
|
when First => -- Appropriate_IO.Put( Meal );
|
TCTouch.Touch('F'); ---------------------------------------------- F
|
TCTouch.Touch('F'); ---------------------------------------------- F
|
when Business => -- Appropriate_IO.Put( Meal );
|
when Business => -- Appropriate_IO.Put( Meal );
|
TCTouch.Touch('B'); ---------------------------------------------- B
|
TCTouch.Touch('B'); ---------------------------------------------- B
|
when Coach => -- Appropriate_IO.Put( "BYO" & " peanuts" );
|
when Coach => -- Appropriate_IO.Put( "BYO" & " peanuts" );
|
TCTouch.Touch('C'); ---------------------------------------------- C
|
TCTouch.Touch('C'); ---------------------------------------------- C
|
end case;
|
end case;
|
end Print;
|
end Print;
|
|
|
Num : Natural := 1000;
|
Num : Natural := 1000;
|
|
|
function Issue( Service : Service_Classes;
|
function Issue( Service : Service_Classes;
|
Flight : Natural;
|
Flight : Natural;
|
Seat : String;
|
Seat : String;
|
Meal : Menu := Fowl ) return Passenger_Ticket is
|
Meal : Menu := Fowl ) return Passenger_Ticket is
|
begin
|
begin
|
Num := Num +1;
|
Num := Num +1;
|
case Service is
|
case Service is
|
when First =>
|
when First =>
|
return Passenger_Ticket'(Service => First, Flight => Flight,
|
return Passenger_Ticket'(Service => First, Flight => Flight,
|
Row_Seat => Seat, Meal => Meal, Serial_Number => Num );
|
Row_Seat => Seat, Meal => Meal, Serial_Number => Num );
|
when Business =>
|
when Business =>
|
return Passenger_Ticket'(Service => Business, Flight => Flight,
|
return Passenger_Ticket'(Service => Business, Flight => Flight,
|
Row_Seat => Seat, Meal => Meal, Serial_Number => Num );
|
Row_Seat => Seat, Meal => Meal, Serial_Number => Num );
|
when Coach =>
|
when Coach =>
|
return Passenger_Ticket'(Service => Coach, Flight => Flight,
|
return Passenger_Ticket'(Service => Coach, Flight => Flight,
|
Row_Seat => Seat, Serial_Number => Num );
|
Row_Seat => Seat, Serial_Number => Num );
|
end case;
|
end case;
|
end Issue;
|
end Issue;
|
|
|
function Issue return Passenger_Ticket is
|
function Issue return Passenger_Ticket is
|
begin
|
begin
|
return Issue( Coach, 0, "non" );
|
return Issue( Coach, 0, "non" );
|
end Issue;
|
end Issue;
|
|
|
end C393010_1;
|
end C393010_1;
|
|
|
----------------------------------------------------------------- C393010_1
|
----------------------------------------------------------------- C393010_1
|
|
|
with C393010_1;
|
with C393010_1;
|
package C393010_2 is
|
package C393010_2 is
|
|
|
type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach )
|
type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach )
|
with private;
|
with private;
|
|
|
function Issue return Charter;
|
function Issue return Charter;
|
|
|
-- procedure Print( T: Passenger_Ticket );
|
-- procedure Print( T: Passenger_Ticket );
|
|
|
private
|
private
|
type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach )
|
type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach )
|
with null record;
|
with null record;
|
|
|
-- Check that the dispatching call to the abstract operation will dispatch
|
-- Check that the dispatching call to the abstract operation will dispatch
|
-- to a procedure defined in the private part of a package.
|
-- to a procedure defined in the private part of a package.
|
procedure Label( T: Charter );
|
procedure Label( T: Charter );
|
|
|
-- an example of a required function the users shouldn't see:
|
-- an example of a required function the users shouldn't see:
|
function Issue( Service : C393010_1.Service_Classes;
|
function Issue( Service : C393010_1.Service_Classes;
|
Flight : Natural;
|
Flight : Natural;
|
Seat : String;
|
Seat : String;
|
Meal : C393010_1.Menu ) return Charter;
|
Meal : C393010_1.Menu ) return Charter;
|
|
|
end C393010_2;
|
end C393010_2;
|
|
|
with TCTouch;
|
with TCTouch;
|
package body C393010_2 is
|
package body C393010_2 is
|
|
|
procedure Label( T: Charter ) is
|
procedure Label( T: Charter ) is
|
begin
|
begin
|
-- Appropriate_IO.Put( "Excursion Fare" );
|
-- Appropriate_IO.Put( "Excursion Fare" );
|
TCTouch.Touch('X'); -------------------------------------------------- X
|
TCTouch.Touch('X'); -------------------------------------------------- X
|
end Label;
|
end Label;
|
|
|
Num : Natural := 4000;
|
Num : Natural := 4000;
|
|
|
function Issue return Charter is
|
function Issue return Charter is
|
begin
|
begin
|
Num := Num +1;
|
Num := Num +1;
|
return Charter'(Service => C393010_1.Coach, Flight => 1001,
|
return Charter'(Service => C393010_1.Coach, Flight => 1001,
|
Row_Seat => "OPN", Serial_Number => Num );
|
Row_Seat => "OPN", Serial_Number => Num );
|
end Issue;
|
end Issue;
|
|
|
function Issue( Service : C393010_1.Service_Classes;
|
function Issue( Service : C393010_1.Service_Classes;
|
Flight : Natural;
|
Flight : Natural;
|
Seat : String;
|
Seat : String;
|
Meal : C393010_1.Menu ) return Charter is
|
Meal : C393010_1.Menu ) return Charter is
|
begin
|
begin
|
return Issue;
|
return Issue;
|
end Issue;
|
end Issue;
|
|
|
end C393010_2;
|
end C393010_2;
|
|
|
----------------------------------------------------------------- C393010_1
|
----------------------------------------------------------------- C393010_1
|
|
|
with Report;
|
with Report;
|
with TCTouch;
|
with TCTouch;
|
with C393010_0;
|
with C393010_0;
|
with C393010_1;
|
with C393010_1;
|
with C393010_2; -- Charter Tours
|
with C393010_2; -- Charter Tours
|
|
|
procedure C393010 is
|
procedure C393010 is
|
|
|
type Agents_Handle is access all C393010_0.Ticket'Class;
|
type Agents_Handle is access all C393010_0.Ticket'Class;
|
|
|
type Itinerary;
|
type Itinerary;
|
|
|
type Next_Leg is access Itinerary;
|
type Next_Leg is access Itinerary;
|
|
|
type Itinerary is record
|
type Itinerary is record
|
Leg : Agents_Handle;
|
Leg : Agents_Handle;
|
Next : Next_Leg;
|
Next : Next_Leg;
|
end record;
|
end record;
|
|
|
function Travel_Agent_1 return Next_Leg is
|
function Travel_Agent_1 return Next_Leg is
|
begin
|
begin
|
-- ORL -> JFK -> LAX -> SAN -> DFW -> ORL
|
-- ORL -> JFK -> LAX -> SAN -> DFW -> ORL
|
return new Itinerary'(
|
return new Itinerary'(
|
-- ORL -> JFK 01 12 2A First, Lobster
|
-- ORL -> JFK 01 12 2A First, Lobster
|
new C393010_1.Passenger_Ticket'(
|
new C393010_1.Passenger_Ticket'(
|
C393010_1.Issue(C393010_1.First, 12, " 2A", C393010_1.Lobster )),
|
C393010_1.Issue(C393010_1.First, 12, " 2A", C393010_1.Lobster )),
|
new Itinerary'(
|
new Itinerary'(
|
-- JFK -> LAX 02 18 2B First, Steak
|
-- JFK -> LAX 02 18 2B First, Steak
|
new C393010_1.Passenger_Ticket'(
|
new C393010_1.Passenger_Ticket'(
|
C393010_1.Issue(C393010_1.First, 18, " 2B", C393010_1.Steak )),
|
C393010_1.Issue(C393010_1.First, 18, " 2B", C393010_1.Steak )),
|
new Itinerary'(
|
new Itinerary'(
|
-- LAX -> SAN 03 5225 34H Coach
|
-- LAX -> SAN 03 5225 34H Coach
|
new C393010_1.Passenger_Ticket'(
|
new C393010_1.Passenger_Ticket'(
|
C393010_1.Issue(C393010_1.Coach, 5225, "34H")),
|
C393010_1.Issue(C393010_1.Coach, 5225, "34H")),
|
new Itinerary'(
|
new Itinerary'(
|
-- SAN -> DFW 04 25 13A Business, Fowl
|
-- SAN -> DFW 04 25 13A Business, Fowl
|
new C393010_1.Passenger_Ticket'(
|
new C393010_1.Passenger_Ticket'(
|
C393010_1.Issue(C393010_1.Business, 25, "13A")),
|
C393010_1.Issue(C393010_1.Business, 25, "13A")),
|
new Itinerary'(
|
new Itinerary'(
|
-- DFW -> ORL 05 15 1D First, Lobster
|
-- DFW -> ORL 05 15 1D First, Lobster
|
new C393010_1.Passenger_Ticket'(
|
new C393010_1.Passenger_Ticket'(
|
C393010_1.Issue(C393010_1.First, 15, " 1D", C393010_1.Lobster )),
|
C393010_1.Issue(C393010_1.First, 15, " 1D", C393010_1.Lobster )),
|
null )))));
|
null )))));
|
end Travel_Agent_1;
|
end Travel_Agent_1;
|
|
|
function Travel_Agent_2 return Next_Leg is
|
function Travel_Agent_2 return Next_Leg is
|
begin
|
begin
|
-- LAX -> NRT -> SYD -> LAX
|
-- LAX -> NRT -> SYD -> LAX
|
return new Itinerary'(
|
return new Itinerary'(
|
new C393010_2.Charter'( C393010_2.Issue ),
|
new C393010_2.Charter'( C393010_2.Issue ),
|
new Itinerary'(
|
new Itinerary'(
|
new C393010_2.Charter'( C393010_2.Issue ),
|
new C393010_2.Charter'( C393010_2.Issue ),
|
new Itinerary'(
|
new Itinerary'(
|
new C393010_2.Charter'( C393010_2.Issue ),
|
new C393010_2.Charter'( C393010_2.Issue ),
|
new Itinerary'(
|
new Itinerary'(
|
new C393010_2.Charter'( C393010_2.Issue ),
|
new C393010_2.Charter'( C393010_2.Issue ),
|
null ))));
|
null ))));
|
end Travel_Agent_2;
|
end Travel_Agent_2;
|
|
|
procedure Traveler( Pax_Tix : in Next_Leg ) is
|
procedure Traveler( Pax_Tix : in Next_Leg ) is
|
Fly_Me : Next_Leg := Pax_Tix;
|
Fly_Me : Next_Leg := Pax_Tix;
|
begin
|
begin
|
-- a particularly consumptive process...
|
-- a particularly consumptive process...
|
while Fly_Me /= null loop
|
while Fly_Me /= null loop
|
C393010_0.Print( Fly_Me.Leg.all ); -- herein lies the test.
|
C393010_0.Print( Fly_Me.Leg.all ); -- herein lies the test.
|
Fly_Me := Fly_Me.Next;
|
Fly_Me := Fly_Me.Next;
|
end loop;
|
end loop;
|
end Traveler;
|
end Traveler;
|
|
|
begin
|
begin
|
|
|
Report.Test ("C393010", "Check that an extended type can be derived from "
|
Report.Test ("C393010", "Check that an extended type can be derived from "
|
& "an abstract type and that a call on an abstract "
|
& "an abstract type and that a call on an abstract "
|
& "operation is a dispatching operation. Check "
|
& "operation is a dispatching operation. Check "
|
& "that such a call can dispatch to an overriding "
|
& "that such a call can dispatch to an overriding "
|
& "operation declared in the private part of a "
|
& "operation declared in the private part of a "
|
& "package" );
|
& "package" );
|
|
|
Traveler( Travel_Agent_1 );
|
Traveler( Travel_Agent_1 );
|
TCTouch.Validate("LPFLPFLPCLPBLPF","First Trip");
|
TCTouch.Validate("LPFLPFLPCLPBLPF","First Trip");
|
|
|
Traveler( Travel_Agent_2 );
|
Traveler( Travel_Agent_2 );
|
TCTouch.Validate("XPCXPCXPCXPC","Second Trip");
|
TCTouch.Validate("XPCXPCXPCXPC","Second Trip");
|
|
|
Report.Result;
|
Report.Result;
|
|
|
end C393010;
|
end C393010;
|
|
|
