3 -- Grant of Unlimited Rights
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
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.
27 -- Check that an extended type can be derived from an abstract type and
28 -- that a call on an abstract operation is a dispatching operation.
29 -- Check that such a call can dispatch to an overriding operation
30 -- declared in the private part of a package.
33 -- Taking from a classroom example of a typical usage: declare a basic
34 -- abstract type containing data germane to the entire class structure,
35 -- derive from that a type with specific data, and derive from that
36 -- another type merely providing a "secret" override. The abstract type
37 -- provides a concrete procedure that itself "redispatches" to an
38 -- abstract procedure; the abstract procedure must be provided by one or
39 -- more of the concrete types derived from the abstract type, and hence
40 -- upon re-evaluating the actual type of the operand should dispatch
46 -- 06 Dec 94 SAIC ACVC 2.0
47 -- 15 Mar 96 SAIC ACVC 2.1
51 ----------------------------------------------------------------- C393010_0
55 type Ticket
is abstract tagged record
57 Serial_Number
: Natural;
60 function Issue
return Ticket
is abstract;
61 procedure Label
( T
: Ticket
) is abstract;
63 procedure Print
( T
: Ticket
);
68 package body C393010_0
is
70 procedure Print
( T
: Ticket
) is
72 -- Check that a call on an abstract operation is a dispatching operation
73 Label
( Ticket
'Class( T
) );
74 -- Appropriate_IO.Put( T.Flight & T.Serial_Number );
75 TCTouch
.Touch
('P'); -------------------------------------------------- P
80 ----------------------------------------------------------------- C393010_1
85 type Service_Classes
is (First
, Business
, Coach
);
87 type Menu
is (Steak
, Lobster
, Fowl
, Vegan
);
89 -- Check that an extended type can be derived from an abstract type.
90 type Passenger_Ticket
(Service
: Service_Classes
) is
91 new C393010_0
.Ticket
with record
92 Row_Seat
: String(1..3);
94 when First | Business
=> Meal
: Menu
;
99 function Issue
return Passenger_Ticket
;
100 function Issue
( Service
: Service_Classes
;
103 Meal
: Menu
:= Fowl
) return Passenger_Ticket
;
105 procedure Label
( T
: Passenger_Ticket
);
107 procedure Print
( T
: Passenger_Ticket
);
112 package body C393010_1
is
114 procedure Label
( T
: Passenger_Ticket
) is
116 -- Appropriate_IO.Put( T.Service );
117 TCTouch
.Touch
('L'); -------------------------------------------------- L
120 procedure Print
( T
: Passenger_Ticket
) is
122 -- call parent print:
123 C393010_0
.Print
( C393010_0
.Ticket
( T
) );
125 when First
=> -- Appropriate_IO.Put( Meal );
126 TCTouch
.Touch
('F'); ---------------------------------------------- F
127 when Business
=> -- Appropriate_IO.Put( Meal );
128 TCTouch
.Touch
('B'); ---------------------------------------------- B
129 when Coach
=> -- Appropriate_IO.Put( "BYO" & " peanuts" );
130 TCTouch
.Touch
('C'); ---------------------------------------------- C
134 Num
: Natural := 1000;
136 function Issue
( Service
: Service_Classes
;
139 Meal
: Menu
:= Fowl
) return Passenger_Ticket
is
144 return Passenger_Ticket
'(Service => First, Flight => Flight,
145 Row_Seat => Seat, Meal => Meal, Serial_Number => Num );
147 return Passenger_Ticket'(Service
=> Business
, Flight
=> Flight
,
148 Row_Seat
=> Seat
, Meal
=> Meal
, Serial_Number
=> Num
);
150 return Passenger_Ticket
'(Service => Coach, Flight => Flight,
151 Row_Seat => Seat, Serial_Number => Num );
155 function Issue return Passenger_Ticket is
157 return Issue( Coach, 0, "non" );
162 ----------------------------------------------------------------- C393010_1
167 type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach )
170 function Issue return Charter;
172 -- procedure Print( T: Passenger_Ticket );
175 type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach )
178 -- Check that the dispatching call to the abstract operation will dispatch
179 -- to a procedure defined in the private part of a package.
180 procedure Label( T: Charter );
182 -- an example of a required function the users shouldn't see:
183 function Issue( Service : C393010_1.Service_Classes;
186 Meal : C393010_1.Menu ) return Charter;
191 package body C393010_2 is
193 procedure Label( T: Charter ) is
195 -- Appropriate_IO.Put( "Excursion Fare" );
196 TCTouch.Touch('X
'); -------------------------------------------------- X
199 Num : Natural := 4000;
201 function Issue return Charter is
204 return Charter'(Service
=> C393010_1
.Coach
, Flight
=> 1001,
205 Row_Seat
=> "OPN", Serial_Number
=> Num
);
208 function Issue
( Service
: C393010_1
.Service_Classes
;
211 Meal
: C393010_1
.Menu
) return Charter
is
218 ----------------------------------------------------------------- C393010_1
224 with C393010_2
; -- Charter Tours
228 type Agents_Handle
is access all C393010_0
.Ticket
'Class;
232 type Next_Leg
is access Itinerary
;
234 type Itinerary
is record
239 function Travel_Agent_1
return Next_Leg
is
241 -- ORL -> JFK -> LAX -> SAN -> DFW -> ORL
242 return new Itinerary
'(
243 -- ORL -> JFK 01 12 2A First, Lobster
244 new C393010_1.Passenger_Ticket'(
245 C393010_1
.Issue
(C393010_1
.First
, 12, " 2A", C393010_1
.Lobster
)),
247 -- JFK -> LAX 02 18 2B First, Steak
248 new C393010_1.Passenger_Ticket'(
249 C393010_1
.Issue
(C393010_1
.First
, 18, " 2B", C393010_1
.Steak
)),
251 -- LAX -> SAN 03 5225 34H Coach
252 new C393010_1.Passenger_Ticket'(
253 C393010_1
.Issue
(C393010_1
.Coach
, 5225, "34H")),
255 -- SAN -> DFW 04 25 13A Business, Fowl
256 new C393010_1.Passenger_Ticket'(
257 C393010_1
.Issue
(C393010_1
.Business
, 25, "13A")),
259 -- DFW -> ORL 05 15 1D First, Lobster
260 new C393010_1.Passenger_Ticket'(
261 C393010_1
.Issue
(C393010_1
.First
, 15, " 1D", C393010_1
.Lobster
)),
265 function Travel_Agent_2
return Next_Leg
is
267 -- LAX -> NRT -> SYD -> LAX
268 return new Itinerary
'(
269 new C393010_2.Charter'( C393010_2
.Issue
),
271 new C393010_2.Charter'( C393010_2
.Issue
),
273 new C393010_2.Charter'( C393010_2
.Issue
),
275 new C393010_2.Charter'( C393010_2
.Issue
),
279 procedure Traveler
( Pax_Tix
: in Next_Leg
) is
280 Fly_Me
: Next_Leg
:= Pax_Tix
;
282 -- a particularly consumptive process...
283 while Fly_Me
/= null loop
284 C393010_0
.Print
( Fly_Me
.Leg
.all ); -- herein lies the test.
285 Fly_Me
:= Fly_Me
.Next
;
291 Report
.Test
("C393010", "Check that an extended type can be derived from "
292 & "an abstract type and that a call on an abstract "
293 & "operation is a dispatching operation. Check "
294 & "that such a call can dispatch to an overriding "
295 & "operation declared in the private part of a "
298 Traveler
( Travel_Agent_1
);
299 TCTouch
.Validate
("LPFLPFLPCLPBLPF","First Trip");
301 Traveler
( Travel_Agent_2
);
302 TCTouch
.Validate
("XPCXPCXPCXPC","Second Trip");