|
111
|
1 -- C393012.A
|
|
|
2 --
|
|
|
3 -- Grant of Unlimited Rights
|
|
|
4 --
|
|
|
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
|
|
|
14 -- to do so.
|
|
|
15 --
|
|
|
16 -- DISCLAIMER
|
|
|
17 --
|
|
|
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.
|
|
|
24 --*
|
|
|
25 --
|
|
|
26 -- OBJECTIVE:
|
|
|
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
|
|
|
29 -- the abstract type.
|
|
|
30 --
|
|
|
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
|
|
|
33 -- called operation.
|
|
|
34 --
|
|
|
35 -- TEST DESCRIPTION:
|
|
|
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".
|
|
|
40 --
|
|
|
41 --
|
|
|
42 -- CHANGE HISTORY:
|
|
|
43 -- 06 Dec 94 SAIC ACVC 2.0
|
|
|
44 -- 16 Dec 94 SAIC Add allocation to the object initializations
|
|
|
45 --
|
|
|
46 --!
|
|
|
47
|
|
|
48 package C393012_0 is
|
|
|
49
|
|
|
50 subtype Row_Number is Positive range 1..120;
|
|
|
51 subtype Seat_Letter is Character range 'A'..'M';
|
|
|
52
|
|
|
53 type Ticket is abstract tagged
|
|
|
54 record
|
|
|
55 Flight : Natural;
|
|
|
56 Row : Row_Number;
|
|
|
57 Seat : Seat_Letter;
|
|
|
58 end record;
|
|
|
59
|
|
|
60 function Display( T: Ticket ) return String;
|
|
|
61 function Service( T: Ticket ) return String is abstract;
|
|
|
62
|
|
|
63 end C393012_0;
|
|
|
64
|
|
|
65 with TCTouch;
|
|
|
66 package body C393012_0 is
|
|
|
67 function Display( T: Ticket ) return String is
|
|
|
68 begin
|
|
|
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;
|
|
|
73 end Display;
|
|
|
74 end C393012_0;
|
|
|
75
|
|
|
76 with C393012_0;
|
|
|
77 package C393012_1 is
|
|
|
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;
|
|
|
81
|
|
|
82 type Meal_Designator is ( B, L, D, V, SN );
|
|
|
83
|
|
|
84 type First is new C393012_0.Ticket with
|
|
|
85 record
|
|
|
86 Meal : Meal_Designator;
|
|
|
87 end record;
|
|
|
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 );
|
|
|
91
|
|
|
92 end C393012_1;
|
|
|
93
|
|
|
94 with TCTouch;
|
|
|
95 package body C393012_1 is
|
|
|
96 function Display( T: Economy ) return String is
|
|
|
97 begin
|
|
|
98 TCTouch.Touch('E'); --------------------------------------------------- E
|
|
|
99 return C393012_0.Display( C393012_0.Ticket( T ) );
|
|
|
100 end Display; -- conversion to abstract type
|
|
|
101
|
|
|
102 function Service( T: Economy ) return String is
|
|
|
103 begin
|
|
|
104 TCTouch.Touch('e'); --------------------------------------------------- e
|
|
|
105 return " K";
|
|
|
106 end Service;
|
|
|
107
|
|
|
108 function Display( T: First ) return String is
|
|
|
109 begin
|
|
|
110 TCTouch.Touch('F'); --------------------------------------------------- F
|
|
|
111 return C393012_0.Display( C393012_0.Ticket( T ) );
|
|
|
112 end Display; -- conversion to abstract type
|
|
|
113
|
|
|
114 function Service( T: First ) return String is
|
|
|
115 begin
|
|
|
116 TCTouch.Touch('f'); --------------------------------------------------- f
|
|
|
117 return " F" & Meal_Designator'Image(T.Meal);
|
|
|
118 end Service;
|
|
|
119
|
|
|
120 procedure Set_Meal( T: in out First; To_Meal : Meal_Designator ) is
|
|
|
121 begin
|
|
|
122 T.Meal := To_Meal;
|
|
|
123 end Set_Meal;
|
|
|
124
|
|
|
125 end C393012_1;
|
|
|
126
|
|
|
127 with Report;
|
|
|
128 with TCTouch;
|
|
|
129 with C393012_0;
|
|
|
130 with C393012_1;
|
|
|
131 procedure C393012 is
|
|
|
132
|
|
|
133 package Rt renames C393012_0;
|
|
|
134 package Tx renames C393012_1;
|
|
|
135
|
|
|
136 type Tix is access Rt.Ticket'Class;
|
|
|
137 type Itinerary is array(Positive range 1..3) of Tix;
|
|
|
138
|
|
|
139 -- Outbound and Inbound itineraries provide different orderings of mixtures
|
|
|
140 -- of Economy and First_Class. Not that that should make any difference...
|
|
|
141
|
|
|
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' ) );
|
|
|
145
|
|
|
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' ) );
|
|
|
149
|
|
|
150 -- Each call to Display uses a parameter that is a type conversion
|
|
|
151 -- to the abstract type Ticket.
|
|
|
152
|
|
|
153 procedure TC_Convert( I: Itinerary; Leg1,Leg2,Leg3: String ) is
|
|
|
154 begin
|
|
|
155 if Rt.Display( Rt.Ticket( I(1).all ) ) /= Leg1 then
|
|
|
156 Report.Failed( Rt.Display( Rt.Ticket( I(1).all ) ) & " /= " & Leg1 );
|
|
|
157 end if;
|
|
|
158 if Rt.Display( Rt.Ticket( I(2).all ) ) /= Leg2 then
|
|
|
159 Report.Failed( Rt.Display( Rt.Ticket( I(2).all ) ) & " /= " & Leg2 );
|
|
|
160 end if;
|
|
|
161 if Rt.Display( Rt.Ticket( I(3).all ) ) /= Leg3 then
|
|
|
162 Report.Failed( Rt.Display( Rt.Ticket( I(3).all ) ) & " /= " & Leg3 );
|
|
|
163 end if;
|
|
|
164 end TC_Convert;
|
|
|
165
|
|
|
166 -- Each call to Display uses a parameter that is not a type conversion
|
|
|
167
|
|
|
168 procedure TC_Match( I: Itinerary; Leg1,Leg2,Leg3: String ) is
|
|
|
169 begin
|
|
|
170 if Rt.Display( I(1).all ) /= Leg1 then
|
|
|
171 Report.Failed( Rt.Display( I(1).all ) & " /= " & Leg1 );
|
|
|
172 end if;
|
|
|
173 if Rt.Display( I(2).all ) /= Leg2 then
|
|
|
174 Report.Failed( Rt.Display( I(2).all ) & " /= " & Leg2 );
|
|
|
175 end if;
|
|
|
176 if Rt.Display( I(3).all ) /= Leg3 then
|
|
|
177 Report.Failed( Rt.Display( I(3).all ) & " /= " & Leg3 );
|
|
|
178 end if;
|
|
|
179 end TC_Match;
|
|
|
180
|
|
|
181 begin -- Main test procedure.
|
|
|
182
|
|
|
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" );
|
|
|
190
|
|
|
191 -- Test conversions to abstract type
|
|
|
192
|
|
|
193 TC_Convert( Outbound, "Fl: 5335 K Seat: 5B",
|
|
|
194 "Fl: 67 FL Seat: 1J",
|
|
|
195 "Fl: 345 K Seat: 37C" );
|
|
|
196
|
|
|
197 TCTouch.Validate( "TeTfTe", "Outbound flight (converted)" );
|
|
|
198
|
|
|
199 TC_Convert( Inbound, "Fl: 456 FSN Seat: 4F",
|
|
|
200 "Fl: 68 K Seat: 12D",
|
|
|
201 "Fl: 5336 K Seat: 6A" );
|
|
|
202
|
|
|
203 TCTouch.Validate( "TfTeTe", "Inbound flight (converted)" );
|
|
|
204
|
|
|
205 -- Test without conversions to abstract type
|
|
|
206
|
|
|
207 TC_Match( Outbound, "Fl: 5335 K Seat: 5B",
|
|
|
208 "Fl: 67 FL Seat: 1J",
|
|
|
209 "Fl: 345 K Seat: 37C" );
|
|
|
210
|
|
|
211 TCTouch.Validate( "ETeFTfETe", "Outbound flight" );
|
|
|
212
|
|
|
213 TC_Match( Inbound, "Fl: 456 FSN Seat: 4F",
|
|
|
214 "Fl: 68 K Seat: 12D",
|
|
|
215 "Fl: 5336 K Seat: 6A" );
|
|
|
216
|
|
|
217 TCTouch.Validate( "FTfETeETe", "Inbound flight" );
|
|
|
218
|
|
|
219 Report.Result;
|
|
|
220
|
|
|
221 end C393012;
|
