Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/ca/ca13a02.a @ 111:04ced10e8804
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 -- CA13A02.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 subunits declared in generic child units of a public | |
28 -- parent have the same visibility into its parent, its siblings | |
29 -- (public and private), and packages on which its parent depends | |
30 -- as is available at the point of their declaration. | |
31 -- | |
32 -- TEST DESCRIPTION: | |
33 -- Declare an outside elevator button operation as a subunit in a | |
34 -- generic child package of the basic operation package (FA13A00.A). | |
35 -- This procedure has visibility into its parent ancestor and its | |
36 -- private sibling. | |
37 -- | |
38 -- In the main program, instantiate the child package. Check that | |
39 -- subunits perform as expected. | |
40 -- | |
41 -- TEST FILES: | |
42 -- The following files comprise this test: | |
43 -- | |
44 -- FA13A00.A | |
45 -- CA13A02.A | |
46 -- | |
47 -- | |
48 -- CHANGE HISTORY: | |
49 -- 06 Dec 94 SAIC ACVC 2.0 | |
50 -- | |
51 --! | |
52 | |
53 -- Public generic child package of an elevator application. This package | |
54 -- provides outside elevator button operations. | |
55 | |
56 generic -- Instantiate once for each floor. | |
57 Our_Floor : in Floor; -- Reference type declared in parent. | |
58 | |
59 package FA13A00_1.CA13A02_4 is -- Outside Elevator Button Operations | |
60 | |
61 type Light is (Up, Down, Express, Off); | |
62 | |
63 type Direction is (Up, Down, Express); | |
64 | |
65 function Call_Elevator (D : Direction) return Light; | |
66 | |
67 -- other type definitions and procedure declarations in real application. | |
68 | |
69 end FA13A00_1.CA13A02_4; | |
70 | |
71 --==================================================================-- | |
72 | |
73 -- Context clauses required for visibility needed by separate subunit. | |
74 | |
75 with FA13A00_0; -- Building Manager | |
76 | |
77 with FA13A00_1.FA13A00_2; -- Floor Calculation (private) | |
78 | |
79 with FA13A00_1.FA13A00_3; -- Move Elevator | |
80 | |
81 use FA13A00_0; | |
82 | |
83 package body FA13A00_1.CA13A02_4 is | |
84 | |
85 function Call_Elevator (D : Direction) return Light is separate; | |
86 | |
87 end FA13A00_1.CA13A02_4; | |
88 | |
89 --==================================================================-- | |
90 | |
91 separate (FA13A00_1.CA13A02_4) | |
92 | |
93 -- Subunit Call_Elevator declared in Outside Elevator Button Operations. | |
94 | |
95 function Call_Elevator (D : Direction) return Light is | |
96 Elevator_Button : Light; | |
97 | |
98 begin | |
99 -- See if power is on. | |
100 | |
101 if Power = Off then -- Reference package with'ed by | |
102 Elevator_Button := Off; -- the subunit parent's body. | |
103 | |
104 else | |
105 case D is | |
106 when Express => | |
107 FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of | |
108 (Penthouse, Call_Waiting); -- the subunit parent's body. | |
109 | |
110 Elevator_Button := Express; | |
111 | |
112 when Up => | |
113 if Current_Floor < Our_Floor then | |
114 FA13A00_1.FA13A00_2.Up -- Reference private sibling of | |
115 (Floor'pos (Our_Floor) -- the subunit parent's body. | |
116 - Floor'pos (Current_Floor)); | |
117 else | |
118 FA13A00_1.FA13A00_2.Down -- Reference private sibling of | |
119 (Floor'pos (Current_Floor) -- the subunit parent's body. | |
120 - Floor'pos (Our_Floor)); | |
121 end if; | |
122 | |
123 -- Call elevator. | |
124 | |
125 Call | |
126 (Current_Floor, Call_Waiting); -- Reference subprogram declared | |
127 -- in the parent of the subunit | |
128 -- parent's body. | |
129 Elevator_Button := Up; | |
130 | |
131 when Down => | |
132 if Current_Floor > Our_Floor then | |
133 FA13A00_1.FA13A00_2.Down -- Reference private sibling of | |
134 (Floor'pos (Current_Floor) -- the subunit parent's body. | |
135 - Floor'pos (Our_Floor)); | |
136 else | |
137 FA13A00_1.FA13A00_2.Up -- Reference private sibling of | |
138 (Floor'pos (Our_Floor) -- the subunit parent's body. | |
139 - Floor'pos (Current_Floor)); | |
140 end if; | |
141 | |
142 Elevator_Button := Down; | |
143 | |
144 -- Call elevator. | |
145 | |
146 Call | |
147 (Current_Floor, Call_Waiting); -- Reference subprogram declared | |
148 -- in the parent of the subunit | |
149 -- parent's body. | |
150 end case; | |
151 | |
152 if not Call_Waiting (Current_Floor) -- Reference private part of the | |
153 then -- parent of the subunit parent's | |
154 -- body. | |
155 TC_Operation := false; | |
156 end if; | |
157 | |
158 end if; | |
159 | |
160 return Elevator_Button; | |
161 | |
162 end Call_Elevator; | |
163 | |
164 --==================================================================-- | |
165 | |
166 with FA13A00_1.CA13A02_4; -- Outside Elevator Button Operations | |
167 -- implicitly with Basic Elevator | |
168 -- Operations | |
169 with Report; | |
170 | |
171 procedure CA13A02 is | |
172 | |
173 begin | |
174 | |
175 Report.Test ("CA13A02", "Check that subunits declared in generic child " & | |
176 "units of a public parent have the same visibility into " & | |
177 "its parent, its parent's siblings, and packages on " & | |
178 "which its parent depends"); | |
179 | |
180 -- Going from floor one to penthouse. | |
181 | |
182 Going_To_Penthouse: | |
183 declare | |
184 -- Declare instance of the child generic elevator package for penthouse. | |
185 | |
186 package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 | |
187 (FA13A00_1.Penthouse); | |
188 | |
189 use Call_Elevator_Pkg; | |
190 | |
191 Call_Button_Light : Light; | |
192 | |
193 begin | |
194 | |
195 Call_Button_Light := Call_Elevator (Express); | |
196 | |
197 if not FA13A00_1.TC_Operation or Call_Button_Light /= Express then | |
198 Report.Failed ("Incorrect elevator operation going to penthouse"); | |
199 end if; | |
200 | |
201 end Going_To_Penthouse; | |
202 | |
203 -- Going from penthouse to basement. | |
204 | |
205 Going_To_Basement: | |
206 declare | |
207 -- Declare instance of the child generic elevator package for basement. | |
208 | |
209 package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 | |
210 (FA13A00_1.Basement); | |
211 | |
212 use Call_Elevator_Pkg; | |
213 | |
214 Call_Button_Light : Light; | |
215 | |
216 begin | |
217 | |
218 Call_Button_Light := Call_Elevator (Down); | |
219 | |
220 if not FA13A00_1.TC_Operation or Call_Button_Light /= Down then | |
221 Report.Failed ("Incorrect elevator operation going to basement"); | |
222 end if; | |
223 | |
224 end Going_To_Basement; | |
225 | |
226 -- Going from basement to floor three. | |
227 | |
228 Going_To_Floor3: | |
229 declare | |
230 -- Declare instance of the child generic elevator package for floor | |
231 -- three. | |
232 | |
233 package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 | |
234 (FA13A00_1.Floor3); | |
235 | |
236 use Call_Elevator_Pkg; | |
237 | |
238 Call_Button_Light : Light; | |
239 | |
240 begin | |
241 | |
242 Call_Button_Light := Call_Elevator (Up); | |
243 | |
244 if not FA13A00_1.TC_Operation or Call_Button_Light /= Up then | |
245 Report.Failed ("Incorrect elevator operation going to floor 3"); | |
246 end if; | |
247 | |
248 end Going_To_Floor3; | |
249 | |
250 -- Going from floor three to floor two. | |
251 | |
252 Going_To_Floor2: | |
253 declare | |
254 -- Declare instance of the child generic elevator package for floor two. | |
255 | |
256 package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 | |
257 (FA13A00_1.Floor2); | |
258 | |
259 use Call_Elevator_Pkg; | |
260 | |
261 Call_Button_Light : Light; | |
262 | |
263 begin | |
264 | |
265 Call_Button_Light := Call_Elevator (Up); | |
266 | |
267 if not FA13A00_1.TC_Operation or Call_Button_Light /= Up then | |
268 Report.Failed ("Incorrect elevator operation going to floor 2"); | |
269 end if; | |
270 | |
271 end Going_To_Floor2; | |
272 | |
273 -- Going to floor one. | |
274 | |
275 Going_To_Floor1: | |
276 declare | |
277 -- Declare instance of the child generic elevator package for floor one. | |
278 | |
279 package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 | |
280 (FA13A00_1.Floor1); | |
281 | |
282 use Call_Elevator_Pkg; | |
283 | |
284 Call_Button_Light : Light; | |
285 | |
286 begin | |
287 -- Calling elevator from floor one. | |
288 | |
289 FA13A00_1.Current_Floor := FA13A00_1.Floor1; | |
290 | |
291 Call_Button_Light := Call_Elevator (Down); | |
292 | |
293 if not FA13A00_1.TC_Operation or Call_Button_Light /= Down then | |
294 Report.Failed ("Incorrect elevator operation going to floor 1"); | |
295 end if; | |
296 | |
297 end Going_To_Floor1; | |
298 | |
299 Report.Result; | |
300 | |
301 end CA13A02; |