Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c393012.a @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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;