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 a non-abstract subprogram of an abstract type can be
28 -- called with a controlling operand that is a type conversion to
31 -- Check that converting to the class-wide type of an abstract type
32 -- inside an operation of that type causes a "redispatch" of the
36 -- This test defines an abstract type, and further derives types from it.
37 -- The key feature of this test is in the "Display" procedures where
38 -- the bodies of these procedures convert an object to the class-wide
39 -- type of the root abstract type, causing a "redispatch".
43 -- 06 Dec 94 SAIC ACVC 2.0
44 -- 16 Dec 94 SAIC Add allocation to the object initializations
50 subtype Row_Number
is Positive range 1..120;
51 subtype Seat_Letter
is Character range 'A'..'M';
53 type Ticket
is abstract tagged
60 function Display
( T
: Ticket
) return String;
61 function Service
( T
: Ticket
) return String is abstract;
66 package body C393012_0
is
67 function Display
( T
: Ticket
) return String is
69 TCTouch
.Touch
('T'); --------------------------------------------------- T
70 return "Fl:" & Natural'Image(T
.Flight
)
71 & Service
( Ticket
'Class( T
) )
72 & " Seat:" & Row_Number
'Image(T
.Row
) & T
.Seat
;
78 type Economy
is new C393012_0
.Ticket
with null record;
79 function Display
( T
: Economy
) return String;
80 function Service
( T
: Economy
) return String;
82 type Meal_Designator
is ( B
, L
, D
, V
, SN
);
84 type First
is new C393012_0
.Ticket
with
86 Meal
: Meal_Designator
;
88 function Display
( T
: First
) return String;
89 function Service
( T
: First
) return String;
90 procedure Set_Meal
( T
: in out First
; To_Meal
: Meal_Designator
);
95 package body C393012_1
is
96 function Display
( T
: Economy
) return String is
98 TCTouch
.Touch
('E'); --------------------------------------------------- E
99 return C393012_0
.Display
( C393012_0
.Ticket
( T
) );
100 end Display
; -- conversion to abstract type
102 function Service
( T
: Economy
) return String is
104 TCTouch
.Touch
('e'); --------------------------------------------------- e
108 function Display
( T
: First
) return String is
110 TCTouch
.Touch
('F'); --------------------------------------------------- F
111 return C393012_0
.Display
( C393012_0
.Ticket
( T
) );
112 end Display
; -- conversion to abstract type
114 function Service
( T
: First
) return String is
116 TCTouch
.Touch
('f'); --------------------------------------------------- f
117 return " F" & Meal_Designator
'Image(T
.Meal
);
120 procedure Set_Meal
( T
: in out First
; To_Meal
: Meal_Designator
) is
133 package Rt
renames C393012_0
;
134 package Tx
renames C393012_1
;
136 type Tix
is access Rt
.Ticket
'Class;
137 type Itinerary
is array(Positive range 1..3) of Tix
;
139 -- Outbound and Inbound itineraries provide different orderings of mixtures
140 -- of Economy and First_Class. Not that that should make any difference...
142 Outbound
: Itinerary
:= ( 1 => new Tx
.Economy
'( 5335, 5, 'B
' ),
143 2 => new Tx.First' ( 67, 1, 'J', Tx
.L
),
144 3 => new Tx
.Economy
'( 345, 37, 'C
' ) );
146 Inbound : Itinerary := ( 1 => new Tx.First' ( 456, 4, 'F', Tx
.SN
),
147 2 => new Tx
.Economy
'( 68, 12, 'D
' ),
148 3 => new Tx.Economy'( 5336, 6, 'A' ) );
150 -- Each call to Display uses a parameter that is a type conversion
151 -- to the abstract type Ticket.
153 procedure TC_Convert
( I
: Itinerary
; Leg1
,Leg2
,Leg3
: String ) is
155 if Rt
.Display
( Rt
.Ticket
( I
(1).all ) ) /= Leg1
then
156 Report
.Failed
( Rt
.Display
( Rt
.Ticket
( I
(1).all ) ) & " /= " & Leg1
);
158 if Rt
.Display
( Rt
.Ticket
( I
(2).all ) ) /= Leg2
then
159 Report
.Failed
( Rt
.Display
( Rt
.Ticket
( I
(2).all ) ) & " /= " & Leg2
);
161 if Rt
.Display
( Rt
.Ticket
( I
(3).all ) ) /= Leg3
then
162 Report
.Failed
( Rt
.Display
( Rt
.Ticket
( I
(3).all ) ) & " /= " & Leg3
);
166 -- Each call to Display uses a parameter that is not a type conversion
168 procedure TC_Match
( I
: Itinerary
; Leg1
,Leg2
,Leg3
: String ) is
170 if Rt
.Display
( I
(1).all ) /= Leg1
then
171 Report
.Failed
( Rt
.Display
( I
(1).all ) & " /= " & Leg1
);
173 if Rt
.Display
( I
(2).all ) /= Leg2
then
174 Report
.Failed
( Rt
.Display
( I
(2).all ) & " /= " & Leg2
);
176 if Rt
.Display
( I
(3).all ) /= Leg3
then
177 Report
.Failed
( Rt
.Display
( I
(3).all ) & " /= " & Leg3
);
181 begin -- Main test procedure.
183 Report
.Test
("C393012", "Check that a non-abstract subprogram of an "
184 & "abstract type can be called with a "
185 & "controlling operand that is a type "
186 & "conversion to the abstract type. "
187 & "Check that converting to the class-wide type "
188 & "of an abstract type inside an operation of "
189 & "that type causes a redispatch" );
191 -- Test conversions to abstract type
193 TC_Convert
( Outbound
, "Fl: 5335 K Seat: 5B",
194 "Fl: 67 FL Seat: 1J",
195 "Fl: 345 K Seat: 37C" );
197 TCTouch
.Validate
( "TeTfTe", "Outbound flight (converted)" );
199 TC_Convert
( Inbound
, "Fl: 456 FSN Seat: 4F",
200 "Fl: 68 K Seat: 12D",
201 "Fl: 5336 K Seat: 6A" );
203 TCTouch
.Validate
( "TfTeTe", "Inbound flight (converted)" );
205 -- Test without conversions to abstract type
207 TC_Match
( Outbound
, "Fl: 5335 K Seat: 5B",
208 "Fl: 67 FL Seat: 1J",
209 "Fl: 345 K Seat: 37C" );
211 TCTouch
.Validate
( "ETeFTfETe", "Outbound flight" );
213 TC_Match
( Inbound
, "Fl: 456 FSN Seat: 4F",
214 "Fl: 68 K Seat: 12D",
215 "Fl: 5336 K Seat: 6A" );
217 TCTouch
.Validate
( "FTfETeETe", "Inbound flight" );