]>
Commit | Line | Data |
---|---|---|
996ae0b0 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S E M _ E L A B -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
1d005acc | 9 | -- Copyright (C) 1997-2019, Free Software Foundation, Inc. -- |
996ae0b0 RK |
10 | -- -- |
11 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
996ae0b0 RK |
14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
17 | -- for more details. You should have received a copy of the GNU General -- | |
b5c84c3c RD |
18 | -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
19 | -- http://www.gnu.org/licenses for a complete copy of the license. -- | |
996ae0b0 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
996ae0b0 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
69e6ee2f | 26 | with ALI; use ALI; |
996ae0b0 | 27 | with Atree; use Atree; |
967947ed | 28 | with Checks; use Checks; |
996ae0b0 RK |
29 | with Debug; use Debug; |
30 | with Einfo; use Einfo; | |
7cc7f3aa | 31 | with Elists; use Elists; |
996ae0b0 | 32 | with Errout; use Errout; |
8f8f531f | 33 | with Exp_Ch11; use Exp_Ch11; |
fbf5a39b | 34 | with Exp_Tss; use Exp_Tss; |
996ae0b0 | 35 | with Exp_Util; use Exp_Util; |
967947ed | 36 | with Expander; use Expander; |
996ae0b0 RK |
37 | with Lib; use Lib; |
38 | with Lib.Load; use Lib.Load; | |
39 | with Namet; use Namet; | |
40 | with Nlists; use Nlists; | |
41 | with Nmake; use Nmake; | |
42 | with Opt; use Opt; | |
967947ed | 43 | with Output; use Output; |
996ae0b0 | 44 | with Restrict; use Restrict; |
6e937c1c | 45 | with Rident; use Rident; |
90e491a7 | 46 | with Rtsfind; use Rtsfind; |
996ae0b0 | 47 | with Sem; use Sem; |
414b312e | 48 | with Sem_Aux; use Sem_Aux; |
967947ed | 49 | with Sem_Cat; use Sem_Cat; |
996ae0b0 RK |
50 | with Sem_Ch7; use Sem_Ch7; |
51 | with Sem_Ch8; use Sem_Ch8; | |
bab15911 | 52 | with Sem_Disp; use Sem_Disp; |
90e491a7 | 53 | with Sem_Prag; use Sem_Prag; |
996ae0b0 RK |
54 | with Sem_Util; use Sem_Util; |
55 | with Sinfo; use Sinfo; | |
967947ed | 56 | with Sinput; use Sinput; |
996ae0b0 RK |
57 | with Snames; use Snames; |
58 | with Stand; use Stand; | |
59 | with Table; | |
60 | with Tbuild; use Tbuild; | |
824e9320 | 61 | with Uintp; use Uintp; |
996ae0b0 RK |
62 | with Uname; use Uname; |
63 | ||
69e6ee2f HK |
64 | with GNAT; use GNAT; |
65 | with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; | |
66 | with GNAT.Lists; use GNAT.Lists; | |
67 | with GNAT.Sets; use GNAT.Sets; | |
90e491a7 | 68 | |
996ae0b0 RK |
69 | package body Sem_Elab is |
70 | ||
90e491a7 PMR |
71 | ----------------------------------------- |
72 | -- Access-before-elaboration mechanism -- | |
73 | ----------------------------------------- | |
74 | ||
75 | -- The access-before-elaboration (ABE) mechanism implemented in this unit | |
76 | -- has the following objectives: | |
77 | -- | |
78 | -- * Diagnose at compile-time or install run-time checks to prevent ABE | |
79 | -- access to data and behaviour. | |
80 | -- | |
c23f55b4 | 81 | -- The high-level idea is to accurately diagnose ABE issues within a |
90e491a7 PMR |
82 | -- single unit because the ABE mechanism can inspect the whole unit. |
83 | -- As soon as the elaboration graph extends to an external unit, the | |
84 | -- diagnostics stop because the body of the unit may not be available. | |
85 | -- Due to control and data flow, the ABE mechanism cannot accurately | |
86 | -- determine whether a particular scenario will be elaborated or not. | |
87 | -- Conditional ABE checks are therefore used to verify the elaboration | |
69e6ee2f | 88 | -- status of local and external targets at run time. |
90e491a7 | 89 | -- |
69e6ee2f | 90 | -- * Supply implicit elaboration dependencies for a unit to binde |
90e491a7 | 91 | -- |
69e6ee2f HK |
92 | -- The ABE mechanism creates implicit dependencies in the form of with |
93 | -- clauses subject to pragma Elaborate[_All] when the elaboration graph | |
94 | -- reaches into an external unit. The implicit dependencies are encoded | |
95 | -- in the ALI file of the main unit. GNATbind and binde then use these | |
96 | -- dependencies to augment the library item graph and determine the | |
97 | -- elaboration order of all units in the compilation. | |
98 | -- | |
99 | -- * Supply pieces of the invocation graph for a unit to bindo | |
100 | -- | |
101 | -- The ABE mechanism captures paths starting from elaboration code or | |
102 | -- top level constructs that reach into an external unit. The paths are | |
103 | -- encoded in the ALI file of the main unit in the form of declarations | |
104 | -- which represent nodes, and relations which represent edges. GNATbind | |
105 | -- and bindo then build the full invocation graph in order to augment | |
106 | -- the library item graph and determine the elaboration order of all | |
107 | -- units in the compilation. | |
90e491a7 PMR |
108 | -- |
109 | -- The ABE mechanism supports three models of elaboration: | |
110 | -- | |
111 | -- * Dynamic model - This is the most permissive of the three models. | |
69e6ee2f HK |
112 | -- When the dynamic model is in effect, the mechanism diagnoses and |
113 | -- installs run-time checks to detect ABE issues in the main unit. | |
114 | -- The behaviour of this model is identical to that specified by the | |
115 | -- Ada RM. This model is enabled with switch -gnatE. | |
90e491a7 | 116 | -- |
69e6ee2f | 117 | -- Static model - This is the middle ground of the three models. When |
90e491a7 PMR |
118 | -- the static model is in effect, the mechanism diagnoses and installs |
119 | -- run-time checks to detect ABE issues in the main unit. In addition, | |
69e6ee2f HK |
120 | -- the mechanism generates implicit dependencies between units in the |
121 | -- form of with clauses subject to pragma Elaborate[_All] to ensure | |
122 | -- the prior elaboration of withed units. This is the default model. | |
90e491a7 PMR |
123 | -- |
124 | -- * SPARK model - This is the most conservative of the three models and | |
125 | -- impelements the semantics defined in SPARK RM 7.7. The SPARK model | |
126 | -- is in effect only when a context resides in a SPARK_Mode On region, | |
127 | -- otherwise the mechanism falls back to one of the previous models. | |
128 | -- | |
129 | -- The ABE mechanism consists of a "recording" phase and a "processing" | |
130 | -- phase. | |
131 | ||
132 | ----------------- | |
133 | -- Terminology -- | |
134 | ----------------- | |
135 | ||
69e6ee2f HK |
136 | -- * ABE - An attempt to invoke a scenario which has not been elaborated |
137 | -- yet. | |
b91f986b | 138 | -- |
90e491a7 PMR |
139 | -- * Bridge target - A type of target. A bridge target is a link between |
140 | -- scenarios. It is usually a byproduct of expansion and does not have | |
141 | -- any direct ABE ramifications. | |
142 | -- | |
143 | -- * Call marker - A special node used to indicate the presence of a call | |
144 | -- in the tree in case expansion transforms or eliminates the original | |
145 | -- call. N_Call_Marker nodes do not have static and run-time semantics. | |
146 | -- | |
147 | -- * Conditional ABE - A type of ABE. A conditional ABE occurs when the | |
69e6ee2f HK |
148 | -- invocation of a target by a scenario within the main unit causes an |
149 | -- ABE, but does not cause an ABE for another scenarios within the main | |
150 | -- unit. | |
90e491a7 PMR |
151 | -- |
152 | -- * Declaration level - A type of enclosing level. A scenario or target is | |
153 | -- at the declaration level when it appears within the declarations of a | |
154 | -- block statement, entry body, subprogram body, or task body, ignoring | |
d0567dc0 | 155 | -- enclosing packages. |
90e491a7 | 156 | -- |
8dce7371 PMR |
157 | -- * Early call region - A section of code which ends at a subprogram body |
158 | -- and starts from the nearest non-preelaborable construct which precedes | |
159 | -- the subprogram body. The early call region extends from a package body | |
160 | -- to a package spec when the spec carries pragma Elaborate_Body. | |
161 | -- | |
90e491a7 PMR |
162 | -- * Generic library level - A type of enclosing level. A scenario or |
163 | -- target is at the generic library level if it appears in a generic | |
164 | -- package library unit, ignoring enclosing packages. | |
165 | -- | |
166 | -- * Guaranteed ABE - A type of ABE. A guaranteed ABE occurs when the | |
69e6ee2f HK |
167 | -- invocation of a target by all scenarios within the main unit causes |
168 | -- an ABE. | |
90e491a7 PMR |
169 | -- |
170 | -- * Instantiation library level - A type of enclosing level. A scenario | |
171 | -- or target is at the instantiation library level if it appears in an | |
172 | -- instantiation library unit, ignoring enclosing packages. | |
173 | -- | |
69e6ee2f HK |
174 | -- * Invocation - The act of activating a task, calling a subprogram, or |
175 | -- instantiating a generic. | |
176 | -- | |
177 | -- * Invocation construct - An entry declaration, [single] protected type, | |
178 | -- subprogram declaration, subprogram instantiation, or a [single] task | |
179 | -- type declared in the visible, private, or body declarations of the | |
180 | -- main unit. | |
181 | -- | |
182 | -- * Invocation relation - A flow link between two invocation constructs | |
183 | -- | |
184 | -- * Invocation signature - A set of attributes that uniquely identify an | |
185 | -- invocation construct within the namespace of all ALI files. | |
186 | -- | |
90e491a7 PMR |
187 | -- * Library level - A type of enclosing level. A scenario or target is at |
188 | -- the library level if it appears in a package library unit, ignoring | |
189 | -- enclosng packages. | |
190 | -- | |
c23f55b4 PMR |
191 | -- * Non-library-level encapsulator - A construct that cannot be elaborated |
192 | -- on its own and requires elaboration by a top-level scenario. | |
90e491a7 | 193 | -- |
69e6ee2f HK |
194 | -- * Scenario - A construct or context which is invoked by elaboration code |
195 | -- or invocation construct. The scenarios recognized by the ABE mechanism | |
196 | -- are as follows: | |
90e491a7 PMR |
197 | -- |
198 | -- - '[Unrestricted_]Access of entries, operators, and subprograms | |
199 | -- | |
8dce7371 PMR |
200 | -- - Assignments to variables |
201 | -- | |
202 | -- - Calls to entries, operators, and subprograms | |
90e491a7 | 203 | -- |
8dce7371 | 204 | -- - Derived type declarations |
90e491a7 | 205 | -- |
8dce7371 | 206 | -- - Instantiations |
90e491a7 | 207 | -- |
8dce7371 | 208 | -- - Pragma Refined_State |
90e491a7 | 209 | -- |
8dce7371 PMR |
210 | -- - Reads of variables |
211 | -- | |
212 | -- - Task activation | |
90e491a7 | 213 | -- |
69e6ee2f HK |
214 | -- * Target - A construct invoked by a scenario. The targets recognized by |
215 | -- the ABE mechanism are as follows: | |
90e491a7 PMR |
216 | -- |
217 | -- - For '[Unrestricted_]Access of entries, operators, and subprograms, | |
218 | -- the target is the entry, operator, or subprogram. | |
219 | -- | |
220 | -- - For assignments to variables, the target is the variable | |
221 | -- | |
222 | -- - For calls, the target is the entry, operator, or subprogram | |
223 | -- | |
8dce7371 PMR |
224 | -- - For derived type declarations, the target is the derived type |
225 | -- | |
90e491a7 PMR |
226 | -- - For instantiations, the target is the generic template |
227 | -- | |
8dce7371 PMR |
228 | -- - For pragma Refined_State, the targets are the constituents |
229 | -- | |
fb9dd1c7 | 230 | -- - For reads of variables, the target is the variable |
90e491a7 PMR |
231 | -- |
232 | -- - For task activation, the target is the task body | |
69e6ee2f HK |
233 | |
234 | ------------------ | |
235 | -- Architecture -- | |
236 | ------------------ | |
237 | ||
238 | -- Analysis/Resolution | |
239 | -- | | |
240 | -- +- Build_Call_Marker | |
241 | -- | | |
242 | -- +- Build_Variable_Reference_Marker | |
243 | -- | | |
244 | -- +- | -------------------- Recording phase ---------------------------+ | |
245 | -- | v | | |
246 | -- | Record_Elaboration_Scenario | | |
247 | -- | | | | |
248 | -- | +--> Check_Preelaborated_Call | | |
249 | -- | | | | |
250 | -- | +--> Process_Guaranteed_ABE | | |
251 | -- | | | | | |
252 | -- | | +--> Process_Guaranteed_ABE_Activation | | |
253 | -- | | +--> Process_Guaranteed_ABE_Call | | |
254 | -- | | +--> Process_Guaranteed_ABE_Instantiation | | |
255 | -- | | | | |
256 | -- +- | ----------------------------------------------------------------+ | |
257 | -- | | |
258 | -- | | |
259 | -- +--> Internal_Representation | |
260 | -- | | |
261 | -- +--> Scenario_Storage | |
262 | -- | | |
263 | -- End of Compilation | |
264 | -- | | |
265 | -- +- | --------------------- Processing phase -------------------------+ | |
266 | -- | v | | |
267 | -- | Check_Elaboration_Scenarios | | |
268 | -- | | | | |
269 | -- | +--> Check_Conditional_ABE_Scenarios | | |
270 | -- | | | | | |
271 | -- | | +--> Process_Conditional_ABE <----------------------+ | | |
272 | -- | | | | | | |
273 | -- | | +--> Process_Conditional_ABE_Activation | | | |
274 | -- | | | | | | | |
275 | -- | | | +-----------------------------+ | | | |
276 | -- | | | | | | | |
277 | -- | | +--> Process_Conditional_ABE_Call +---> Traverse_Body | | |
278 | -- | | | | | | | |
279 | -- | | | +-----------------------------+ | | |
280 | -- | | | | | |
281 | -- | | +--> Process_Conditional_ABE_Access_Taken | | |
282 | -- | | +--> Process_Conditional_ABE_Instantiation | | |
283 | -- | | +--> Process_Conditional_ABE_Variable_Assignment | | |
284 | -- | | +--> Process_Conditional_ABE_Variable_Reference | | |
285 | -- | | | | |
286 | -- | +--> Check_SPARK_Scenario | | |
287 | -- | | | | | |
288 | -- | | +--> Process_SPARK_Scenario | | |
289 | -- | | | | | |
290 | -- | | +--> Process_SPARK_Derived_Type | | |
291 | -- | | +--> Process_SPARK_Instantiation | | |
292 | -- | | +--> Process_SPARK_Refined_State_Pragma | | |
293 | -- | | | | |
294 | -- | +--> Record_Invocation_Graph | | |
295 | -- | | | | |
296 | -- | +--> Process_Invocation_Body_Scenarios | | |
297 | -- | +--> Process_Invocation_Spec_Scenarios | | |
298 | -- | +--> Process_Main_Unit | | |
299 | -- | | | | |
300 | -- | +--> Process_Invocation_Scenario <-------------+ | | |
301 | -- | | | | | |
302 | -- | +--> Process_Invocation_Activation | | | |
303 | -- | | | | | | |
304 | -- | | +------------------------+ | | | |
305 | -- | | | | | | |
306 | -- | +--> Process_Invocation_Call +---> Traverse_Body | | |
307 | -- | | | | | |
308 | -- | +------------------------+ | | |
309 | -- | | | |
310 | -- +--------------------------------------------------------------------+ | |
90e491a7 PMR |
311 | |
312 | --------------------- | |
313 | -- Recording phase -- | |
314 | --------------------- | |
315 | ||
316 | -- The Recording phase coincides with the analysis/resolution phase of the | |
317 | -- compiler. It has the following objectives: | |
318 | -- | |
69e6ee2f | 319 | -- * Record all suitable scenarios for examination by the Processing |
90e491a7 PMR |
320 | -- phase. |
321 | -- | |
322 | -- Saving only a certain number of nodes improves the performance of | |
323 | -- the ABE mechanism. This eliminates the need to examine the whole | |
324 | -- tree in a separate pass. | |
325 | -- | |
69e6ee2f | 326 | -- * Record certain SPARK scenarios which are not necessarily invoked |
8dce7371 PMR |
327 | -- during elaboration, but still require elaboration-related checks. |
328 | -- | |
329 | -- Saving only a certain number of nodes improves the performance of | |
330 | -- the ABE mechanism. This eliminates the need to examine the whole | |
331 | -- tree in a separate pass. | |
332 | -- | |
90e491a7 PMR |
333 | -- * Detect and diagnose calls in preelaborable or pure units, including |
334 | -- generic bodies. | |
335 | -- | |
336 | -- This diagnostic is carried out during the Recording phase because it | |
337 | -- does not need the heavy recursive traversal done by the Processing | |
338 | -- phase. | |
339 | -- | |
69e6ee2f HK |
340 | -- * Detect and diagnose guaranteed ABEs caused by instantiations, calls, |
341 | -- and task activation. | |
90e491a7 PMR |
342 | -- |
343 | -- The issues detected by the ABE mechanism are reported as warnings | |
344 | -- because they do not violate Ada semantics. Forward instantiations | |
345 | -- may thus reach gigi, however gigi cannot handle certain kinds of | |
346 | -- premature instantiations and may crash. To avoid this limitation, | |
347 | -- the ABE mechanism must identify forward instantiations as early as | |
348 | -- possible and suppress their bodies. Calls and task activations are | |
349 | -- included in this category for completeness. | |
350 | ||
351 | ---------------------- | |
352 | -- Processing phase -- | |
353 | ---------------------- | |
354 | ||
355 | -- The Processing phase is a separate pass which starts after instantiating | |
356 | -- and/or inlining of bodies, but before the removal of Ghost code. It has | |
357 | -- the following objectives: | |
358 | -- | |
69e6ee2f HK |
359 | -- * Examine all scenarios saved during the Recording phase, and perform |
360 | -- the following actions: | |
90e491a7 | 361 | -- |
69e6ee2f | 362 | -- - Dynamic model |
90e491a7 | 363 | -- |
69e6ee2f HK |
364 | -- Diagnose conditional ABEs, and install run-time conditional ABE |
365 | -- checks for all scenarios. | |
8dce7371 | 366 | -- |
69e6ee2f | 367 | -- - SPARK model |
90e491a7 | 368 | -- |
69e6ee2f | 369 | -- Enforce the SPARK elaboration rules |
90e491a7 | 370 | -- |
69e6ee2f | 371 | -- - Static model |
90e491a7 | 372 | -- |
69e6ee2f HK |
373 | -- Diagnose conditional ABEs, install run-time conditional ABE |
374 | -- checks only for scenarios are reachable from elaboration code, | |
375 | -- and guarantee the elaboration of external units by creating | |
376 | -- implicit with clauses subject to pragma Elaborate[_All]. | |
90e491a7 | 377 | -- |
69e6ee2f HK |
378 | -- * Examine library-level scenarios and invocation constructs, and |
379 | -- perform the following actions: | |
90e491a7 | 380 | -- |
69e6ee2f HK |
381 | -- - Determine whether the flow of execution reaches into an external |
382 | -- unit. If this is the case, encode the path in the ALI file of | |
383 | -- the main unit. | |
384 | -- | |
385 | -- - Create declarations for invocation constructs in the ALI file of | |
386 | -- the main unit. | |
90e491a7 PMR |
387 | |
388 | ---------------------- | |
389 | -- Important points -- | |
390 | ---------------------- | |
391 | ||
392 | -- The Processing phase starts after the analysis, resolution, expansion | |
393 | -- phase has completed. As a result, no current semantic information is | |
394 | -- available. The scope stack is empty, global flags such as In_Instance | |
395 | -- or Inside_A_Generic become useless. To remedy this, the ABE mechanism | |
396 | -- must either save or recompute semantic information. | |
69e6ee2f | 397 | -- |
90e491a7 PMR |
398 | -- Expansion heavily transforms calls and to some extent instantiations. To |
399 | -- remedy this, the ABE mechanism generates N_Call_Marker nodes in order to | |
400 | -- capture the target and relevant attributes of the original call. | |
69e6ee2f | 401 | -- |
90e491a7 PMR |
402 | -- The diagnostics of the ABE mechanism depend on accurate source locations |
403 | -- to determine the spacial relation of nodes. | |
404 | ||
162ed06f HK |
405 | ----------------------------------------- |
406 | -- Suppression of elaboration warnings -- | |
407 | ----------------------------------------- | |
408 | ||
409 | -- Elaboration warnings along multiple traversal paths rooted at a scenario | |
410 | -- are suppressed when the scenario has elaboration warnings suppressed. | |
411 | -- | |
412 | -- Root scenario | |
413 | -- | | |
414 | -- +-- Child scenario 1 | |
415 | -- | | | |
416 | -- | +-- Grandchild scenario 1 | |
417 | -- | | | |
418 | -- | +-- Grandchild scenario N | |
419 | -- | | |
420 | -- +-- Child scenario N | |
421 | -- | |
422 | -- If the root scenario has elaboration warnings suppressed, then all its | |
423 | -- child, grandchild, etc. scenarios will have their elaboration warnings | |
424 | -- suppressed. | |
425 | -- | |
426 | -- In addition to switch -gnatwL, pragma Warnings may be used to suppress | |
a0f3668c | 427 | -- elaboration-related warnings when used in the following manner: |
162ed06f HK |
428 | -- |
429 | -- pragma Warnings ("L"); | |
a0f3668c HK |
430 | -- <scenario-or-target> |
431 | -- | |
432 | -- <target> | |
433 | -- pragma Warnings (Off, target); | |
434 | -- | |
435 | -- pragma Warnings (Off); | |
436 | -- <scenario-or-target> | |
162ed06f HK |
437 | -- |
438 | -- * To suppress elaboration warnings for '[Unrestricted_]Access of | |
439 | -- entries, operators, and subprograms, either: | |
440 | -- | |
a0f3668c HK |
441 | -- - Suppress the entry, operator, or subprogram, or |
442 | -- - Suppress the attribute, or | |
162ed06f HK |
443 | -- - Use switch -gnatw.f |
444 | -- | |
445 | -- * To suppress elaboration warnings for calls to entries, operators, | |
446 | -- and subprograms, either: | |
447 | -- | |
a0f3668c HK |
448 | -- - Suppress the entry, operator, or subprogram, or |
449 | -- - Suppress the call | |
162ed06f | 450 | -- |
a0f3668c | 451 | -- * To suppress elaboration warnings for instantiations, suppress the |
162ed06f HK |
452 | -- instantiation. |
453 | -- | |
454 | -- * To suppress elaboration warnings for task activations, either: | |
455 | -- | |
a0f3668c HK |
456 | -- - Suppress the task object, or |
457 | -- - Suppress the task type, or | |
458 | -- - Suppress the activation call | |
162ed06f | 459 | |
90e491a7 PMR |
460 | -------------- |
461 | -- Switches -- | |
462 | -------------- | |
463 | ||
464 | -- The following switches may be used to control the behavior of the ABE | |
465 | -- mechanism. | |
466 | -- | |
967947ed PMR |
467 | -- -gnatd_a stop elaboration checks on accept or select statement |
468 | -- | |
469 | -- The ABE mechanism stops the traversal of a task body when it | |
470 | -- encounters an accept or a select statement. This behavior is | |
471 | -- equivalent to restriction No_Entry_Calls_In_Elaboration_Code, | |
472 | -- but without penalizing actual entry calls during elaboration. | |
473 | -- | |
474 | -- -gnatd_e ignore entry calls and requeue statements for elaboration | |
475 | -- | |
476 | -- The ABE mechanism does not generate N_Call_Marker nodes for | |
477 | -- protected or task entry calls as well as requeue statements. | |
478 | -- As a result, the calls and requeues are not recorded or | |
479 | -- processed. | |
480 | -- | |
90e491a7 PMR |
481 | -- -gnatdE elaboration checks on predefined units |
482 | -- | |
483 | -- The ABE mechanism considers scenarios which appear in internal | |
484 | -- units (Ada, GNAT, Interfaces, System). | |
485 | -- | |
69e6ee2f HK |
486 | -- -gnatd_F encode full invocation paths in ALI files |
487 | -- | |
488 | -- The ABE mechanism encodes the full path from an elaboration | |
489 | -- procedure or invocable construct to an external target. The | |
490 | -- path contains all intermediate activations, instantiations, | |
491 | -- and calls. | |
492 | -- | |
90e491a7 PMR |
493 | -- -gnatd.G ignore calls through generic formal parameters for elaboration |
494 | -- | |
495 | -- The ABE mechanism does not generate N_Call_Marker nodes for | |
496 | -- calls which occur in expanded instances, and invoke generic | |
497 | -- actual subprograms through generic formal subprograms. As a | |
498 | -- result, the calls are not recorded or processed. | |
499 | -- | |
c581c520 | 500 | -- -gnatd_i ignore activations and calls to instances for elaboration |
90e491a7 | 501 | -- |
967947ed PMR |
502 | -- The ABE mechanism ignores calls and task activations when they |
503 | -- target a subprogram or task type defined an external instance. | |
504 | -- As a result, the calls and task activations are not processed. | |
90e491a7 | 505 | -- |
c581c520 PMR |
506 | -- -gnatdL ignore external calls from instances for elaboration |
507 | -- | |
508 | -- The ABE mechanism does not generate N_Call_Marker nodes for | |
509 | -- calls which occur in expanded instances, do not invoke generic | |
510 | -- actual subprograms through formal subprograms, and the target | |
511 | -- is external to the instance. As a result, the calls are not | |
512 | -- recorded or processed. | |
513 | -- | |
8f8f531f | 514 | -- -gnatd.o conservative elaboration order for indirect calls |
90e491a7 PMR |
515 | -- |
516 | -- The ABE mechanism treats '[Unrestricted_]Access of an entry, | |
517 | -- operator, or subprogram as an immediate invocation of the | |
518 | -- target. As a result, it performs ABE checks and diagnostics on | |
519 | -- the immediate call. | |
520 | -- | |
967947ed PMR |
521 | -- -gnatd_p ignore assertion pragmas for elaboration |
522 | -- | |
523 | -- The ABE mechanism does not generate N_Call_Marker nodes for | |
524 | -- calls to subprograms which verify the run-time semantics of | |
525 | -- the following assertion pragmas: | |
526 | -- | |
b91f986b PMR |
527 | -- Default_Initial_Condition |
528 | -- Initial_Condition | |
967947ed PMR |
529 | -- Invariant |
530 | -- Invariant'Class | |
531 | -- Post | |
532 | -- Post'Class | |
533 | -- Postcondition | |
534 | -- Type_Invariant | |
535 | -- Type_Invariant_Class | |
536 | -- | |
b91f986b PMR |
537 | -- As a result, the assertion expressions of the pragmas are not |
538 | -- processed. | |
967947ed | 539 | -- |
0c9849e1 HK |
540 | -- -gnatd_s stop elaboration checks on synchronous suspension |
541 | -- | |
542 | -- The ABE mechanism stops the traversal of a task body when it | |
543 | -- encounters a call to one of the following routines: | |
544 | -- | |
545 | -- Ada.Synchronous_Barriers.Wait_For_Release | |
546 | -- Ada.Synchronous_Task_Control.Suspend_Until_True | |
547 | -- | |
69e6ee2f HK |
548 | -- -gnatd_T output trace information on invocation relation construction |
549 | -- | |
550 | -- The ABE mechanism outputs text information concerning relation | |
551 | -- construction to standard output. | |
552 | -- | |
90e491a7 PMR |
553 | -- -gnatd.U ignore indirect calls for static elaboration |
554 | -- | |
555 | -- The ABE mechanism does not consider '[Unrestricted_]Access of | |
556 | -- entries, operators, and subprograms. As a result, the scenarios | |
557 | -- are not recorder or processed. | |
558 | -- | |
92b751fd PMR |
559 | -- -gnatd.v enforce SPARK elaboration rules in SPARK code |
560 | -- | |
561 | -- The ABE mechanism applies some of the SPARK elaboration rules | |
562 | -- defined in the SPARK reference manual, chapter 7.7. Note that | |
563 | -- certain rules are always enforced, regardless of whether the | |
564 | -- switch is active. | |
565 | -- | |
90e491a7 PMR |
566 | -- -gnatd.y disable implicit pragma Elaborate_All on task bodies |
567 | -- | |
568 | -- The ABE mechanism does not generate implicit Elaborate_All when | |
569 | -- the need for the pragma came from a task body. | |
570 | -- | |
571 | -- -gnatE dynamic elaboration checking mode enabled | |
572 | -- | |
573 | -- The ABE mechanism assumes that any scenario is elaborated or | |
574 | -- invoked by elaboration code. The ABE mechanism performs very | |
575 | -- little diagnostics and generates condintional ABE checks to | |
576 | -- detect ABE issues at run-time. | |
577 | -- | |
578 | -- -gnatel turn on info messages on generated Elaborate[_All] pragmas | |
579 | -- | |
580 | -- The ABE mechanism produces information messages on generated | |
581 | -- implicit Elabote[_All] pragmas along with traceback showing | |
582 | -- why the pragma was generated. In addition, the ABE mechanism | |
583 | -- produces information messages for each scenario elaborated or | |
584 | -- invoked by elaboration code. | |
585 | -- | |
586 | -- -gnateL turn off info messages on generated Elaborate[_All] pragmas | |
587 | -- | |
a3f9da70 | 588 | -- The complementary switch for -gnatel. |
90e491a7 | 589 | -- |
967947ed PMR |
590 | -- -gnatH legacy elaboration checking mode enabled |
591 | -- | |
592 | -- When this switch is in effect, the pre-18.x ABE model becomes | |
593 | -- the defacto ABE model. This ammounts to cutting off all entry | |
594 | -- points into the new ABE mechanism, and giving full control to | |
595 | -- the old ABE mechanism. | |
596 | -- | |
597 | -- -gnatJ permissive elaboration checking mode enabled | |
598 | -- | |
599 | -- This switch activates the following switches: | |
600 | -- | |
601 | -- -gnatd_a | |
602 | -- -gnatd_e | |
603 | -- -gnatd.G | |
c581c520 | 604 | -- -gnatd_i |
967947ed PMR |
605 | -- -gnatdL |
606 | -- -gnatd_p | |
0c9849e1 | 607 | -- -gnatd_s |
967947ed PMR |
608 | -- -gnatd.U |
609 | -- -gnatd.y | |
610 | -- | |
611 | -- IMPORTANT: The behavior of the ABE mechanism becomes more | |
612 | -- permissive at the cost of accurate diagnostics and runtime | |
613 | -- ABE checks. | |
614 | -- | |
90e491a7 PMR |
615 | -- -gnatw.f turn on warnings for suspicious Subp'Access |
616 | -- | |
617 | -- The ABE mechanism treats '[Unrestricted_]Access of an entry, | |
618 | -- operator, or subprogram as a pseudo invocation of the target. | |
619 | -- As a result, it performs ABE diagnostics on the pseudo call. | |
620 | -- | |
621 | -- -gnatw.F turn off warnings for suspicious Subp'Access | |
622 | -- | |
a3f9da70 | 623 | -- The complementary switch for -gnatw.f. |
7fb62ca1 HK |
624 | -- |
625 | -- -gnatwl turn on warnings for elaboration problems | |
626 | -- | |
627 | -- The ABE mechanism produces warnings on detected ABEs along with | |
a3f9da70 | 628 | -- a traceback showing the graph of the ABE. |
7fb62ca1 HK |
629 | -- |
630 | -- -gnatwL turn off warnings for elaboration problems | |
631 | -- | |
a3f9da70 | 632 | -- The complementary switch for -gnatwl. |
90e491a7 | 633 | |
90e491a7 PMR |
634 | -------------------------- |
635 | -- Debugging ABE issues -- | |
636 | -------------------------- | |
637 | ||
638 | -- * If the issue involves a call, ensure that the call is eligible for ABE | |
639 | -- processing and receives a corresponding call marker. The routines of | |
640 | -- interest are | |
641 | -- | |
642 | -- Build_Call_Marker | |
643 | -- Record_Elaboration_Scenario | |
69e6ee2f | 644 | -- |
90e491a7 PMR |
645 | -- * If the issue involves an arbitrary scenario, ensure that the scenario |
646 | -- is either recorded, or is successfully recognized while traversing a | |
647 | -- body. The routines of interest are | |
648 | -- | |
649 | -- Record_Elaboration_Scenario | |
8dce7371 PMR |
650 | -- Process_Conditional_ABE |
651 | -- Process_Guaranteed_ABE | |
90e491a7 | 652 | -- Traverse_Body |
69e6ee2f | 653 | -- |
90e491a7 PMR |
654 | -- * If the issue involves a circularity in the elaboration order, examine |
655 | -- the ALI files and look for the following encodings next to units: | |
656 | -- | |
657 | -- E indicates a source Elaborate | |
658 | -- | |
659 | -- EA indicates a source Elaborate_All | |
660 | -- | |
661 | -- AD indicates an implicit Elaborate_All | |
662 | -- | |
663 | -- ED indicates an implicit Elaborate | |
664 | -- | |
665 | -- If possible, compare these encodings with those generated by the old | |
666 | -- ABE mechanism. The routines of interest are | |
667 | -- | |
668 | -- Ensure_Prior_Elaboration | |
669 | ||
69e6ee2f HK |
670 | ----------- |
671 | -- Kinds -- | |
672 | ----------- | |
90e491a7 | 673 | |
0839ffce HK |
674 | -- The following type enumerates all possible elaboration phase statutes |
675 | ||
676 | type Elaboration_Phase_Status is | |
677 | (Inactive, | |
678 | -- The elaboration phase of the compiler has not started yet | |
679 | ||
680 | Active, | |
681 | -- The elaboration phase of the compiler is currently in progress | |
682 | ||
683 | Completed); | |
684 | -- The elaboration phase of the compiler has finished | |
685 | ||
686 | Elaboration_Phase : Elaboration_Phase_Status := Inactive; | |
687 | -- The status of the elaboration phase. Use routine Set_Elaboration_Phase | |
688 | -- to alter its value. | |
689 | ||
69e6ee2f | 690 | -- The following type enumerates all subprogram body traversal modes |
8dce7371 | 691 | |
69e6ee2f HK |
692 | type Body_Traversal_Kind is |
693 | (Deep_Traversal, | |
694 | -- The traversal examines the internals of a subprogram | |
90e491a7 | 695 | |
69e6ee2f | 696 | No_Traversal); |
90e491a7 | 697 | |
69e6ee2f | 698 | -- The following type enumerates all operation modes |
7fb62ca1 | 699 | |
69e6ee2f HK |
700 | type Processing_Kind is |
701 | (Conditional_ABE_Processing, | |
702 | -- The ABE mechanism detects and diagnoses conditional ABEs for library | |
703 | -- and declaration-level scenarios. | |
90e491a7 | 704 | |
69e6ee2f HK |
705 | Dynamic_Model_Processing, |
706 | -- The ABE mechanism installs conditional ABE checks for all eligible | |
707 | -- scenarios when the dynamic model is in effect. | |
90e491a7 | 708 | |
69e6ee2f HK |
709 | Guaranteed_ABE_Processing, |
710 | -- The ABE mechanism detects and diagnoses guaranteed ABEs caused by | |
711 | -- calls, instantiations, and task activations. | |
90e491a7 | 712 | |
69e6ee2f HK |
713 | Invocation_Construct_Processing, |
714 | -- The ABE mechanism locates all invocation constructs within the main | |
715 | -- unit and utilizes them as roots of miltiple DFS traversals aimed at | |
716 | -- detecting transitions from the main unit to an external unit. | |
90e491a7 | 717 | |
69e6ee2f HK |
718 | Invocation_Body_Processing, |
719 | -- The ABE mechanism utilizes all library-level body scenarios as roots | |
720 | -- of miltiple DFS traversals aimed at detecting transitions from the | |
721 | -- main unit to an external unit. | |
90e491a7 | 722 | |
69e6ee2f HK |
723 | Invocation_Spec_Processing, |
724 | -- The ABE mechanism utilizes all library-level spec scenarios as roots | |
725 | -- of miltiple DFS traversals aimed at detecting transitions from the | |
726 | -- main unit to an external unit. | |
90e491a7 | 727 | |
69e6ee2f HK |
728 | SPARK_Processing, |
729 | -- The ABE mechanism detects and diagnoses violations of the SPARK | |
730 | -- elaboration rules for SPARK-specific scenarios. | |
90e491a7 | 731 | |
69e6ee2f | 732 | No_Processing); |
90e491a7 | 733 | |
69e6ee2f | 734 | -- The following type enumerates all possible scenario kinds |
90e491a7 | 735 | |
69e6ee2f HK |
736 | type Scenario_Kind is |
737 | (Access_Taken_Scenario, | |
738 | -- An attribute reference which takes 'Access or 'Unrestricted_Access of | |
739 | -- an entry, operator, or subprogram. | |
7fb62ca1 | 740 | |
69e6ee2f HK |
741 | Call_Scenario, |
742 | -- A call which invokes an entry, operator, or subprogram | |
90e491a7 | 743 | |
69e6ee2f HK |
744 | Derived_Type_Scenario, |
745 | -- A declaration of a derived type. This is a SPARK-specific scenario. | |
90e491a7 | 746 | |
69e6ee2f HK |
747 | Instantiation_Scenario, |
748 | -- An instantiation which instantiates a generic package or subprogram. | |
749 | -- This scenario is also subject to SPARK-specific rules. | |
750 | ||
751 | Refined_State_Pragma_Scenario, | |
752 | -- A Refined_State pragma. This is a SPARK-specific scenario. | |
753 | ||
754 | Task_Activation_Scenario, | |
755 | -- A call which activates objects of various task types | |
756 | ||
757 | Variable_Assignment_Scenario, | |
758 | -- An assignment statement which modifies the value of some variable | |
759 | ||
760 | Variable_Reference_Scenario, | |
761 | -- A reference to a variable. This is a SPARK-specific scenario. | |
762 | ||
763 | No_Scenario); | |
764 | ||
765 | -- The following type enumerates all possible consistency models of target | |
766 | -- and scenario representations. | |
767 | ||
768 | type Representation_Kind is | |
769 | (Inconsistent_Representation, | |
770 | -- A representation is said to be "inconsistent" when it is created from | |
771 | -- a partially analyzed tree. In such an environment, certain attributes | |
772 | -- such as a completing body may not be available yet. | |
773 | ||
774 | Consistent_Representation, | |
775 | -- A representation is said to be "consistent" when it is created from a | |
776 | -- fully analyzed tree, where all attributes are available. | |
777 | ||
778 | No_Representation); | |
779 | ||
780 | -- The following type enumerates all possible target kinds | |
781 | ||
782 | type Target_Kind is | |
783 | (Generic_Target, | |
784 | -- A generic unit being instantiated | |
785 | ||
3eb5e54a HK |
786 | Package_Target, |
787 | -- The package form of an instantiation | |
788 | ||
69e6ee2f HK |
789 | Subprogram_Target, |
790 | -- An entry, operator, or subprogram being invoked, or aliased through | |
791 | -- 'Access or 'Unrestricted_Access. | |
792 | ||
793 | Task_Target, | |
794 | -- A task being activated by an activation call | |
795 | ||
796 | Variable_Target, | |
797 | -- A variable being updated through an assignment statement, or read | |
798 | -- through a variable reference. | |
799 | ||
800 | No_Target); | |
801 | ||
802 | ----------- | |
803 | -- Types -- | |
804 | ----------- | |
805 | ||
806 | procedure Destroy (NE : in out Node_Or_Entity_Id); | |
807 | pragma Inline (Destroy); | |
808 | -- Destroy node or entity NE | |
809 | ||
810 | function Hash (NE : Node_Or_Entity_Id) return Bucket_Range_Type; | |
811 | pragma Inline (Hash); | |
812 | -- Obtain the hash value of key NE | |
813 | ||
814 | -- The following is a general purpose list for nodes and entities | |
815 | ||
816 | package NE_List is new Doubly_Linked_Lists | |
817 | (Element_Type => Node_Or_Entity_Id, | |
818 | "=" => "=", | |
819 | Destroy_Element => Destroy); | |
820 | ||
821 | -- The following is a general purpose map which relates nodes and entities | |
822 | -- to lists of nodes and entities. | |
823 | ||
824 | package NE_List_Map is new Dynamic_Hash_Tables | |
825 | (Key_Type => Node_Or_Entity_Id, | |
826 | Value_Type => NE_List.Doubly_Linked_List, | |
827 | No_Value => NE_List.Nil, | |
828 | Expansion_Threshold => 1.5, | |
829 | Expansion_Factor => 2, | |
830 | Compression_Threshold => 0.3, | |
831 | Compression_Factor => 2, | |
832 | "=" => "=", | |
833 | Destroy_Value => NE_List.Destroy, | |
834 | Hash => Hash); | |
835 | ||
836 | -- The following is a general purpose membership set for nodes and entities | |
837 | ||
838 | package NE_Set is new Membership_Sets | |
839 | (Element_Type => Node_Or_Entity_Id, | |
840 | "=" => "=", | |
841 | Hash => Hash); | |
90e491a7 | 842 | |
967947ed | 843 | -- The following type captures relevant attributes which pertain to the |
69e6ee2f HK |
844 | -- in state of the Processing phase. |
845 | ||
846 | type Processing_In_State is record | |
847 | Processing : Processing_Kind := No_Processing; | |
848 | -- Operation mode of the Processing phase. Once set, this value should | |
849 | -- not be changed. | |
850 | ||
851 | Representation : Representation_Kind := No_Representation; | |
852 | -- Required level of scenario and target representation. Once set, this | |
853 | -- value should not be changed. | |
967947ed | 854 | |
69e6ee2f HK |
855 | Suppress_Checks : Boolean := False; |
856 | -- This flag is set when the Processing phase must not generate any ABE | |
857 | -- checks. | |
858 | ||
859 | Suppress_Implicit_Pragmas : Boolean := False; | |
967947ed PMR |
860 | -- This flag is set when the Processing phase must not generate any |
861 | -- implicit Elaborate[_All] pragmas. | |
862 | ||
69e6ee2f HK |
863 | Suppress_Info_Messages : Boolean := False; |
864 | -- This flag is set when the Processing phase must not emit any info | |
865 | -- messages. | |
866 | ||
867 | Suppress_Up_Level_Targets : Boolean := False; | |
868 | -- This flag is set when the Processing phase must ignore up-level | |
869 | -- targets. | |
870 | ||
871 | Suppress_Warnings : Boolean := False; | |
162ed06f HK |
872 | -- This flag is set when the Processing phase must not emit any warnings |
873 | -- on elaboration problems. | |
874 | ||
69e6ee2f HK |
875 | Traversal : Body_Traversal_Kind := No_Traversal; |
876 | -- The subprogram body traversal mode. Once set, this value should not | |
877 | -- be changed. | |
878 | ||
879 | Within_Generic : Boolean := False; | |
880 | -- This flag is set when the Processing phase is currently within a | |
881 | -- generic unit. | |
967947ed | 882 | |
69e6ee2f | 883 | Within_Initial_Condition : Boolean := False; |
967947ed | 884 | -- This flag is set when the Processing phase is currently examining a |
69e6ee2f | 885 | -- scenario which was reached from an initial condition procedure. |
967947ed | 886 | |
69e6ee2f | 887 | Within_Partial_Finalization : Boolean := False; |
967947ed PMR |
888 | -- This flag is set when the Processing phase is currently examining a |
889 | -- scenario which was reached from a partial finalization procedure. | |
890 | ||
69e6ee2f | 891 | Within_Task_Body : Boolean := False; |
967947ed PMR |
892 | -- This flag is set when the Processing phase is currently examining a |
893 | -- scenario which was reached from a task body. | |
894 | end record; | |
895 | ||
69e6ee2f HK |
896 | -- The following constants define the various operational states of the |
897 | -- Processing phase. | |
898 | ||
899 | -- The conditional ABE state is used when processing scenarios that appear | |
900 | -- at the declaration, instantiation, and library levels to detect errors | |
901 | -- and install conditional ABE checks. | |
902 | ||
903 | Conditional_ABE_State : constant Processing_In_State := | |
904 | (Processing => Conditional_ABE_Processing, | |
905 | Representation => Consistent_Representation, | |
906 | Traversal => Deep_Traversal, | |
907 | others => False); | |
908 | ||
909 | -- The dynamic model state is used to install conditional ABE checks when | |
910 | -- switch -gnatE (dynamic elaboration checking mode enabled) is in effect. | |
911 | ||
912 | Dynamic_Model_State : constant Processing_In_State := | |
913 | (Processing => Dynamic_Model_Processing, | |
914 | Representation => Consistent_Representation, | |
915 | Suppress_Implicit_Pragmas => True, | |
916 | Suppress_Info_Messages => True, | |
917 | Suppress_Up_Level_Targets => True, | |
918 | Suppress_Warnings => True, | |
919 | Traversal => No_Traversal, | |
920 | others => False); | |
921 | ||
922 | -- The guaranteed ABE state is used when processing scenarios that appear | |
923 | -- at the declaration, instantiation, and library levels to detect errors | |
924 | -- and install guarateed ABE failures. | |
925 | ||
926 | Guaranteed_ABE_State : constant Processing_In_State := | |
927 | (Processing => Guaranteed_ABE_Processing, | |
928 | Representation => Inconsistent_Representation, | |
929 | Suppress_Implicit_Pragmas => True, | |
930 | Traversal => No_Traversal, | |
931 | others => False); | |
932 | ||
933 | -- The invocation body state is used when processing scenarios that appear | |
934 | -- at the body library level to encode paths that start from elaboration | |
935 | -- code and ultimately reach into external units. | |
936 | ||
937 | Invocation_Body_State : constant Processing_In_State := | |
938 | (Processing => Invocation_Body_Processing, | |
939 | Representation => Consistent_Representation, | |
940 | Suppress_Checks => True, | |
941 | Suppress_Implicit_Pragmas => True, | |
942 | Suppress_Info_Messages => True, | |
943 | Suppress_Up_Level_Targets => True, | |
944 | Suppress_Warnings => True, | |
945 | Traversal => Deep_Traversal, | |
946 | others => False); | |
947 | ||
948 | -- The invocation construct state is used when processing constructs that | |
949 | -- appear within the spec and body of the main unit and eventually reach | |
950 | -- into external units. | |
951 | ||
952 | Invocation_Construct_State : constant Processing_In_State := | |
953 | (Processing => Invocation_Construct_Processing, | |
954 | Representation => Consistent_Representation, | |
955 | Suppress_Checks => True, | |
956 | Suppress_Implicit_Pragmas => True, | |
957 | Suppress_Info_Messages => True, | |
958 | Suppress_Up_Level_Targets => True, | |
959 | Suppress_Warnings => True, | |
960 | Traversal => Deep_Traversal, | |
961 | others => False); | |
962 | ||
963 | -- The invocation spec state is used when processing scenarios that appear | |
964 | -- at the spec library level to encode paths that start from elaboration | |
965 | -- code and ultimately reach into external units. | |
966 | ||
967 | Invocation_Spec_State : constant Processing_In_State := | |
968 | (Processing => Invocation_Spec_Processing, | |
969 | Representation => Consistent_Representation, | |
970 | Suppress_Checks => True, | |
971 | Suppress_Implicit_Pragmas => True, | |
972 | Suppress_Info_Messages => True, | |
973 | Suppress_Up_Level_Targets => True, | |
974 | Suppress_Warnings => True, | |
975 | Traversal => Deep_Traversal, | |
976 | others => False); | |
977 | ||
978 | -- The SPARK state is used when verying SPARK-specific semantics of certain | |
979 | -- scenarios. | |
980 | ||
981 | SPARK_State : constant Processing_In_State := | |
982 | (Processing => SPARK_Processing, | |
983 | Representation => Consistent_Representation, | |
984 | Traversal => No_Traversal, | |
985 | others => False); | |
986 | ||
987 | -- The following type identifies a scenario representation | |
988 | ||
989 | type Scenario_Rep_Id is new Natural; | |
990 | ||
991 | No_Scenario_Rep : constant Scenario_Rep_Id := Scenario_Rep_Id'First; | |
992 | First_Scenario_Rep : constant Scenario_Rep_Id := No_Scenario_Rep + 1; | |
993 | ||
994 | -- The following type identifies a target representation | |
995 | ||
996 | type Target_Rep_Id is new Natural; | |
997 | ||
998 | No_Target_Rep : constant Target_Rep_Id := Target_Rep_Id'First; | |
999 | First_Target_Rep : constant Target_Rep_Id := No_Target_Rep + 1; | |
967947ed | 1000 | |
69e6ee2f HK |
1001 | -------------- |
1002 | -- Services -- | |
1003 | -------------- | |
90e491a7 | 1004 | |
69e6ee2f HK |
1005 | -- The following package keeps track of all active scenarios during a DFS |
1006 | -- traversal. | |
90e491a7 | 1007 | |
69e6ee2f | 1008 | package Active_Scenarios is |
162ed06f | 1009 | |
69e6ee2f HK |
1010 | ----------- |
1011 | -- Types -- | |
1012 | ----------- | |
90e491a7 | 1013 | |
69e6ee2f HK |
1014 | -- The following type defines the position within the active scenario |
1015 | -- stack. | |
90e491a7 | 1016 | |
69e6ee2f | 1017 | type Active_Scenario_Pos is new Natural; |
90e491a7 | 1018 | |
69e6ee2f HK |
1019 | --------------------- |
1020 | -- Data structures -- | |
1021 | --------------------- | |
90e491a7 | 1022 | |
69e6ee2f HK |
1023 | -- The following table stores all active scenarios in a DFS traversal. |
1024 | -- This table must be maintained in a FIFO fashion. | |
1025 | ||
1026 | package Active_Scenario_Stack is new Table.Table | |
1027 | (Table_Index_Type => Active_Scenario_Pos, | |
1028 | Table_Component_Type => Node_Id, | |
1029 | Table_Low_Bound => 1, | |
1030 | Table_Initial => 50, | |
1031 | Table_Increment => 200, | |
1032 | Table_Name => "Active_Scenario_Stack"); | |
1033 | ||
1034 | --------- | |
1035 | -- API -- | |
1036 | --------- | |
1037 | ||
1038 | procedure Output_Active_Scenarios | |
1039 | (Error_Nod : Node_Id; | |
1040 | In_State : Processing_In_State); | |
1041 | pragma Inline (Output_Active_Scenarios); | |
1042 | -- Output the contents of the active scenario stack from earliest to | |
1043 | -- latest to supplement an earlier error emitted for node Error_Nod. | |
1044 | -- In_State denotes the current state of the Processing phase. | |
1045 | ||
1046 | procedure Pop_Active_Scenario (N : Node_Id); | |
1047 | pragma Inline (Pop_Active_Scenario); | |
1048 | -- Pop the top of the scenario stack. A check is made to ensure that the | |
1049 | -- scenario being removed is the same as N. | |
1050 | ||
1051 | procedure Push_Active_Scenario (N : Node_Id); | |
1052 | pragma Inline (Push_Active_Scenario); | |
1053 | -- Push scenario N on top of the scenario stack | |
1054 | ||
1055 | function Root_Scenario return Node_Id; | |
1056 | pragma Inline (Root_Scenario); | |
1057 | -- Return the scenario which started a DFS traversal | |
1058 | ||
1059 | end Active_Scenarios; | |
1060 | use Active_Scenarios; | |
1061 | ||
1062 | -- The following package provides the main entry point for task activation | |
1063 | -- processing. | |
90e491a7 | 1064 | |
69e6ee2f HK |
1065 | package Activation_Processor is |
1066 | ||
1067 | ----------- | |
1068 | -- Types -- | |
1069 | ----------- | |
1070 | ||
1071 | type Activation_Processor_Ptr is access procedure | |
1072 | (Call : Node_Id; | |
1073 | Call_Rep : Scenario_Rep_Id; | |
1074 | Obj_Id : Entity_Id; | |
1075 | Obj_Rep : Target_Rep_Id; | |
1076 | Task_Typ : Entity_Id; | |
1077 | Task_Rep : Target_Rep_Id; | |
1078 | In_State : Processing_In_State); | |
1079 | -- Reference to a procedure that takes all attributes of an activation | |
1080 | -- and performs a desired action. Call is the activation call. Call_Rep | |
1081 | -- is the representation of the call. Obj_Id is the task object being | |
1082 | -- activated. Obj_Rep is the representation of the object. Task_Typ is | |
1083 | -- the task type whose body is being activated. Task_Rep denotes the | |
1084 | -- representation of the task type. In_State is the current state of | |
1085 | -- the Processing phase. | |
1086 | ||
1087 | --------- | |
1088 | -- API -- | |
1089 | --------- | |
1090 | ||
1091 | procedure Process_Activation | |
1092 | (Call : Node_Id; | |
1093 | Call_Rep : Scenario_Rep_Id; | |
1094 | Processor : Activation_Processor_Ptr; | |
1095 | In_State : Processing_In_State); | |
1096 | -- Find all task objects activated by activation call Call and invoke | |
1097 | -- Processor on them. Call_Rep denotes the representation of the call. | |
1098 | -- In_State is the current state of the Processing phase. | |
1099 | ||
1100 | end Activation_Processor; | |
1101 | use Activation_Processor; | |
1102 | ||
1103 | -- The following package profides functionality for traversing subprogram | |
1104 | -- bodies in DFS manner and processing of eligible scenarios within. | |
1105 | ||
1106 | package Body_Processor is | |
1107 | ||
1108 | ----------- | |
1109 | -- Types -- | |
1110 | ----------- | |
1111 | ||
1112 | type Scenario_Predicate_Ptr is access function | |
1113 | (N : Node_Id) return Boolean; | |
1114 | -- Reference to a function which determines whether arbitrary node N | |
1115 | -- denotes a suitable scenario for processing. | |
1116 | ||
1117 | type Scenario_Processor_Ptr is access procedure | |
1118 | (N : Node_Id; In_State : Processing_In_State); | |
1119 | -- Reference to a procedure which processes scenario N. In_State is the | |
1120 | -- current state of the Processing phase. | |
1121 | ||
1122 | --------- | |
1123 | -- API -- | |
1124 | --------- | |
1125 | ||
1126 | procedure Traverse_Body | |
1127 | (N : Node_Id; | |
1128 | Requires_Processing : Scenario_Predicate_Ptr; | |
1129 | Processor : Scenario_Processor_Ptr; | |
1130 | In_State : Processing_In_State); | |
1131 | pragma Inline (Traverse_Body); | |
1132 | -- Traverse the declarations and handled statements of subprogram body | |
1133 | -- N, looking for scenarios that satisfy predicate Requires_Processing. | |
1134 | -- Routine Processor is invoked for each such scenario. | |
1135 | ||
1136 | procedure Reset_Traversed_Bodies; | |
1137 | pragma Inline (Reset_Traversed_Bodies); | |
1138 | -- Reset the visited status of all subprogram bodies that have already | |
1139 | -- been processed by routine Traverse_Body. | |
90e491a7 | 1140 | |
69e6ee2f HK |
1141 | ----------------- |
1142 | -- Maintenance -- | |
1143 | ----------------- | |
90e491a7 | 1144 | |
69e6ee2f HK |
1145 | procedure Finalize_Body_Processor; |
1146 | pragma Inline (Finalize_Body_Processor); | |
1147 | -- Finalize all internal data structures | |
1148 | ||
1149 | procedure Initialize_Body_Processor; | |
1150 | pragma Inline (Initialize_Body_Processor); | |
1151 | -- Initialize all internal data structures | |
1152 | ||
1153 | end Body_Processor; | |
1154 | use Body_Processor; | |
1155 | ||
1156 | -- The following package provides functionality for installing ABE-related | |
1157 | -- checks and failures. | |
1158 | ||
1159 | package Check_Installer is | |
1160 | ||
1161 | --------- | |
1162 | -- API -- | |
1163 | --------- | |
1164 | ||
1165 | function Check_Or_Failure_Generation_OK return Boolean; | |
1166 | pragma Inline (Check_Or_Failure_Generation_OK); | |
1167 | -- Determine whether a conditional ABE check or guaranteed ABE failure | |
1168 | -- can be generated. | |
1169 | ||
1170 | procedure Install_Dynamic_ABE_Checks; | |
1171 | pragma Inline (Install_Dynamic_ABE_Checks); | |
1172 | -- Install conditional ABE checks for all saved scenarios when the | |
1173 | -- dynamic model is in effect. | |
1174 | ||
1175 | procedure Install_Scenario_ABE_Check | |
1176 | (N : Node_Id; | |
1177 | Targ_Id : Entity_Id; | |
1178 | Targ_Rep : Target_Rep_Id; | |
1179 | Disable : Scenario_Rep_Id); | |
1180 | pragma Inline (Install_Scenario_ABE_Check); | |
1181 | -- Install a conditional ABE check for scenario N to ensure that target | |
1182 | -- Targ_Id is properly elaborated. Targ_Rep is the representation of the | |
1183 | -- target. If the check is installed, disable the elaboration checks of | |
1184 | -- scenario Disable. | |
1185 | ||
1186 | procedure Install_Scenario_ABE_Check | |
1187 | (N : Node_Id; | |
1188 | Targ_Id : Entity_Id; | |
1189 | Targ_Rep : Target_Rep_Id; | |
1190 | Disable : Target_Rep_Id); | |
1191 | pragma Inline (Install_Scenario_ABE_Check); | |
1192 | -- Install a conditional ABE check for scenario N to ensure that target | |
1193 | -- Targ_Id is properly elaborated. Targ_Rep is the representation of the | |
1194 | -- target. If the check is installed, disable the elaboration checks of | |
1195 | -- target Disable. | |
1196 | ||
1197 | procedure Install_Scenario_ABE_Failure | |
1198 | (N : Node_Id; | |
1199 | Targ_Id : Entity_Id; | |
1200 | Targ_Rep : Target_Rep_Id; | |
1201 | Disable : Scenario_Rep_Id); | |
1202 | pragma Inline (Install_Scenario_ABE_Failure); | |
1203 | -- Install a guaranteed ABE failure for scenario N with target Targ_Id. | |
1204 | -- Targ_Rep denotes the representation of the target. If the failure is | |
1205 | -- installed, disable the elaboration checks of scenario Disable. | |
1206 | ||
1207 | procedure Install_Scenario_ABE_Failure | |
1208 | (N : Node_Id; | |
1209 | Targ_Id : Entity_Id; | |
1210 | Targ_Rep : Target_Rep_Id; | |
1211 | Disable : Target_Rep_Id); | |
1212 | pragma Inline (Install_Scenario_ABE_Failure); | |
1213 | -- Install a guaranteed ABE failure for scenario N with target Targ_Id. | |
1214 | -- Targ_Rep denotes the representation of the target. If the failure is | |
1215 | -- installed, disable the elaboration checks of target Disable. | |
1216 | ||
1217 | procedure Install_Unit_ABE_Check | |
1218 | (N : Node_Id; | |
1219 | Unit_Id : Entity_Id; | |
1220 | Disable : Scenario_Rep_Id); | |
1221 | pragma Inline (Install_Unit_ABE_Check); | |
1222 | -- Install a conditional ABE check for scenario N to ensure that unit | |
1223 | -- Unit_Id is properly elaborated. If the check is installed, disable | |
1224 | -- the elaboration checks of scenario Disable. | |
1225 | ||
1226 | procedure Install_Unit_ABE_Check | |
1227 | (N : Node_Id; | |
1228 | Unit_Id : Entity_Id; | |
1229 | Disable : Target_Rep_Id); | |
1230 | pragma Inline (Install_Unit_ABE_Check); | |
1231 | -- Install a conditional ABE check for scenario N to ensure that unit | |
1232 | -- Unit_Id is properly elaborated. If the check is installed, disable | |
1233 | -- the elaboration checks of target Disable. | |
1234 | ||
1235 | end Check_Installer; | |
1236 | use Check_Installer; | |
1237 | ||
1238 | -- The following package provides the main entry point for conditional ABE | |
1239 | -- checks and diagnostics. | |
1240 | ||
1241 | package Conditional_ABE_Processor is | |
1242 | ||
1243 | --------- | |
1244 | -- API -- | |
1245 | --------- | |
1246 | ||
1247 | procedure Check_Conditional_ABE_Scenarios | |
1248 | (Iter : in out NE_Set.Iterator); | |
1249 | pragma Inline (Check_Conditional_ABE_Scenarios); | |
1250 | -- Perform conditional ABE checks and diagnostics for all scenarios | |
1251 | -- available through iterator Iter. | |
1252 | ||
1253 | procedure Process_Conditional_ABE | |
1254 | (N : Node_Id; | |
1255 | In_State : Processing_In_State); | |
1256 | pragma Inline (Process_Conditional_ABE); | |
1257 | -- Perform conditional ABE checks and diagnostics for scenario N. | |
1258 | -- In_State denotes the current state of the Processing phase. | |
1259 | ||
1260 | end Conditional_ABE_Processor; | |
1261 | use Conditional_ABE_Processor; | |
1262 | ||
1263 | -- The following package provides functionality to emit errors, information | |
1264 | -- messages, and warnings. | |
1265 | ||
1266 | package Diagnostics is | |
1267 | ||
1268 | --------- | |
1269 | -- API -- | |
1270 | --------- | |
1271 | ||
1272 | procedure Elab_Msg_NE | |
1273 | (Msg : String; | |
1274 | N : Node_Id; | |
1275 | Id : Entity_Id; | |
1276 | Info_Msg : Boolean; | |
1277 | In_SPARK : Boolean); | |
1278 | pragma Inline (Elab_Msg_NE); | |
1279 | -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary | |
1280 | -- node N and entity. If flag Info_Msg is set, the routine emits an | |
1281 | -- information message, otherwise it emits an error. If flag In_SPARK | |
1282 | -- is set, then string " in SPARK" is added to the end of the message. | |
1283 | ||
1284 | procedure Info_Call | |
1285 | (Call : Node_Id; | |
1286 | Subp_Id : Entity_Id; | |
1287 | Info_Msg : Boolean; | |
1288 | In_SPARK : Boolean); | |
1289 | pragma Inline (Info_Call); | |
1290 | -- Output information concerning call Call that invokes subprogram | |
1291 | -- Subp_Id. When flag Info_Msg is set, the routine emits an information | |
1292 | -- message, otherwise it emits an error. When flag In_SPARK is set, " in | |
1293 | -- SPARK" is added to the end of the message. | |
1294 | ||
1295 | procedure Info_Instantiation | |
1296 | (Inst : Node_Id; | |
1297 | Gen_Id : Entity_Id; | |
1298 | Info_Msg : Boolean; | |
1299 | In_SPARK : Boolean); | |
1300 | pragma Inline (Info_Instantiation); | |
1301 | -- Output information concerning instantiation Inst which instantiates | |
1302 | -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an | |
1303 | -- information message, otherwise it emits an error. If flag In_SPARK | |
1304 | -- is set, then string " in SPARK" is added to the end of the message. | |
1305 | ||
1306 | procedure Info_Variable_Reference | |
1307 | (Ref : Node_Id; | |
1308 | Var_Id : Entity_Id; | |
1309 | Info_Msg : Boolean; | |
1310 | In_SPARK : Boolean); | |
1311 | pragma Inline (Info_Variable_Reference); | |
1312 | -- Output information concerning reference Ref which mentions variable | |
1313 | -- Var_Id. If flag Info_Msg is set, the routine emits an information | |
1314 | -- message, otherwise it emits an error. If flag In_SPARK is set, then | |
1315 | -- string " in SPARK" is added to the end of the message. | |
1316 | ||
1317 | end Diagnostics; | |
1318 | use Diagnostics; | |
1319 | ||
1320 | -- The following package provides functionality to locate the early call | |
1321 | -- region of a subprogram body. | |
1322 | ||
1323 | package Early_Call_Region_Processor is | |
1324 | ||
1325 | --------- | |
1326 | -- API -- | |
1327 | --------- | |
1328 | ||
1329 | function Find_Early_Call_Region | |
1330 | (Body_Decl : Node_Id; | |
1331 | Assume_Elab_Body : Boolean := False; | |
1332 | Skip_Memoization : Boolean := False) return Node_Id; | |
1333 | pragma Inline (Find_Early_Call_Region); | |
1334 | -- Find the start of the early call region that belongs to subprogram | |
1335 | -- body Body_Decl as defined in SPARK RM 7.7. This routine finds the | |
1336 | -- early call region, memoizes it, and returns it, but this behavior | |
1337 | -- can be altered. Flag Assume_Elab_Body should be set when a package | |
1338 | -- spec may lack pragma Elaborate_Body, but the routine must still | |
1339 | -- examine that spec. Flag Skip_Memoization should be set when the | |
1340 | -- routine must avoid memoizing the region. | |
90e491a7 | 1341 | |
69e6ee2f HK |
1342 | ----------------- |
1343 | -- Maintenance -- | |
1344 | ----------------- | |
90e491a7 | 1345 | |
69e6ee2f HK |
1346 | procedure Finalize_Early_Call_Region_Processor; |
1347 | pragma Inline (Finalize_Early_Call_Region_Processor); | |
1348 | -- Finalize all internal data structures | |
1349 | ||
1350 | procedure Initialize_Early_Call_Region_Processor; | |
1351 | pragma Inline (Initialize_Early_Call_Region_Processor); | |
1352 | -- Initialize all internal data structures | |
1353 | ||
1354 | end Early_Call_Region_Processor; | |
1355 | use Early_Call_Region_Processor; | |
1356 | ||
1357 | -- The following package provides access to the elaboration statuses of all | |
1358 | -- units withed by the main unit. | |
1359 | ||
1360 | package Elaborated_Units is | |
1361 | ||
1362 | --------- | |
1363 | -- API -- | |
1364 | --------- | |
1365 | ||
1366 | procedure Collect_Elaborated_Units; | |
1367 | pragma Inline (Collect_Elaborated_Units); | |
1368 | -- Save the elaboration statuses of all units withed by the main unit | |
1369 | ||
1370 | procedure Ensure_Prior_Elaboration | |
1371 | (N : Node_Id; | |
1372 | Unit_Id : Entity_Id; | |
1373 | Prag_Nam : Name_Id; | |
1374 | In_State : Processing_In_State); | |
1375 | pragma Inline (Ensure_Prior_Elaboration); | |
1376 | -- Guarantee the elaboration of unit Unit_Id with respect to the main | |
1377 | -- unit by either suggesting or installing an Elaborate[_All] pragma | |
1378 | -- denoted by Prag_Nam. N denotes the related scenario. In_State is the | |
1379 | -- current state of the Processing phase. | |
1380 | ||
1381 | function Has_Prior_Elaboration | |
1382 | (Unit_Id : Entity_Id; | |
1383 | Context_OK : Boolean := False; | |
1384 | Elab_Body_OK : Boolean := False; | |
1385 | Same_Unit_OK : Boolean := False) return Boolean; | |
1386 | pragma Inline (Has_Prior_Elaboration); | |
1387 | -- Determine whether unit Unit_Id is elaborated prior to the main unit. | |
1388 | -- If flag Context_OK is set, the routine considers the following case | |
1389 | -- as valid prior elaboration: | |
90e491a7 | 1390 | -- |
69e6ee2f | 1391 | -- * Unit_Id is in the elaboration context of the main unit |
90e491a7 | 1392 | -- |
69e6ee2f HK |
1393 | -- If flag Elab_Body_OK is set, the routine considers the following case |
1394 | -- as valid prior elaboration: | |
90e491a7 | 1395 | -- |
69e6ee2f | 1396 | -- * Unit_Id has pragma Elaborate_Body and is not the main unit |
90e491a7 | 1397 | -- |
69e6ee2f HK |
1398 | -- If flag Same_Unit_OK is set, the routine considers the following |
1399 | -- cases as valid prior elaboration: | |
90e491a7 | 1400 | -- |
69e6ee2f | 1401 | -- * Unit_Id is the main unit |
90e491a7 | 1402 | -- |
69e6ee2f HK |
1403 | -- * Unit_Id denotes the spec of the main unit body |
1404 | ||
1405 | procedure Meet_Elaboration_Requirement | |
1406 | (N : Node_Id; | |
1407 | Targ_Id : Entity_Id; | |
1408 | Req_Nam : Name_Id; | |
1409 | In_State : Processing_In_State); | |
1410 | pragma Inline (Meet_Elaboration_Requirement); | |
1411 | -- Determine whether elaboration requirement Req_Nam for scenario N with | |
1412 | -- target Targ_Id is met by the context of the main unit using the SPARK | |
1413 | -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an | |
1414 | -- error if this is not the case. In_State denotes the current state of | |
1415 | -- the Processing phase. | |
90e491a7 | 1416 | |
69e6ee2f HK |
1417 | ----------------- |
1418 | -- Maintenance -- | |
1419 | ----------------- | |
90e491a7 | 1420 | |
69e6ee2f HK |
1421 | procedure Finalize_Elaborated_Units; |
1422 | pragma Inline (Finalize_Elaborated_Units); | |
1423 | -- Finalize all internal data structures | |
90e491a7 | 1424 | |
69e6ee2f HK |
1425 | procedure Initialize_Elaborated_Units; |
1426 | pragma Inline (Initialize_Elaborated_Units); | |
1427 | -- Initialize all internal data structures | |
90e491a7 | 1428 | |
69e6ee2f HK |
1429 | end Elaborated_Units; |
1430 | use Elaborated_Units; | |
162ed06f | 1431 | |
69e6ee2f HK |
1432 | -- The following package provides the main entry point for guaranteed ABE |
1433 | -- checks and diagnostics. | |
90e491a7 | 1434 | |
69e6ee2f | 1435 | package Guaranteed_ABE_Processor is |
90e491a7 | 1436 | |
69e6ee2f HK |
1437 | --------- |
1438 | -- API -- | |
1439 | --------- | |
90e491a7 | 1440 | |
69e6ee2f HK |
1441 | procedure Process_Guaranteed_ABE |
1442 | (N : Node_Id; | |
1443 | In_State : Processing_In_State); | |
1444 | pragma Inline (Process_Guaranteed_ABE); | |
1445 | -- Perform guaranteed ABE checks and diagnostics for scenario N. | |
1446 | -- In_State is the current state of the Processing phase. | |
90e491a7 | 1447 | |
69e6ee2f HK |
1448 | end Guaranteed_ABE_Processor; |
1449 | use Guaranteed_ABE_Processor; | |
90e491a7 | 1450 | |
69e6ee2f HK |
1451 | -- The following package provides access to the internal representation of |
1452 | -- scenarios and targets. | |
90e491a7 | 1453 | |
69e6ee2f | 1454 | package Internal_Representation is |
90e491a7 | 1455 | |
69e6ee2f HK |
1456 | ----------- |
1457 | -- Types -- | |
1458 | ----------- | |
90e491a7 | 1459 | |
604801a4 | 1460 | -- The following type enumerates all possible Ghost mode kinds |
8dce7371 | 1461 | |
69e6ee2f HK |
1462 | type Extended_Ghost_Mode is |
1463 | (Is_Ignored, | |
1464 | Is_Checked_Or_Not_Specified); | |
8dce7371 | 1465 | |
69e6ee2f | 1466 | -- The following type enumerates all possible SPARK mode kinds |
8dce7371 | 1467 | |
69e6ee2f HK |
1468 | type Extended_SPARK_Mode is |
1469 | (Is_On, | |
1470 | Is_Off_Or_Not_Specified); | |
8dce7371 | 1471 | |
69e6ee2f HK |
1472 | -------------- |
1473 | -- Builders -- | |
1474 | -------------- | |
8dce7371 | 1475 | |
69e6ee2f HK |
1476 | function Scenario_Representation_Of |
1477 | (N : Node_Id; | |
1478 | In_State : Processing_In_State) return Scenario_Rep_Id; | |
1479 | pragma Inline (Scenario_Representation_Of); | |
1480 | -- Obtain the id of elaboration scenario N's representation. The routine | |
1481 | -- constructs the representation if it is not available. In_State is the | |
1482 | -- current state of the Processing phase. | |
1483 | ||
1484 | function Target_Representation_Of | |
1485 | (Id : Entity_Id; | |
1486 | In_State : Processing_In_State) return Target_Rep_Id; | |
1487 | pragma Inline (Target_Representation_Of); | |
1488 | -- Obtain the id of elaboration target Id's representation. The routine | |
1489 | -- constructs the representation if it is not available. In_State is the | |
1490 | -- current state of the Processing phase. | |
8dce7371 | 1491 | |
69e6ee2f HK |
1492 | ------------------------- |
1493 | -- Scenario attributes -- | |
1494 | ------------------------- | |
8dce7371 | 1495 | |
69e6ee2f HK |
1496 | function Activated_Task_Objects |
1497 | (S_Id : Scenario_Rep_Id) return NE_List.Doubly_Linked_List; | |
1498 | pragma Inline (Activated_Task_Objects); | |
1499 | -- For Task_Activation_Scenario S_Id, obtain the list of task objects | |
1500 | -- the scenario is activating. | |
1501 | ||
1502 | function Activated_Task_Type (S_Id : Scenario_Rep_Id) return Entity_Id; | |
1503 | pragma Inline (Activated_Task_Type); | |
1504 | -- For Task_Activation_Scenario S_Id, obtain the currently activated | |
1505 | -- task type. | |
1506 | ||
1507 | procedure Disable_Elaboration_Checks (S_Id : Scenario_Rep_Id); | |
1508 | pragma Inline (Disable_Elaboration_Checks); | |
1509 | -- Disable elaboration checks of scenario S_Id | |
1510 | ||
1511 | function Elaboration_Checks_OK (S_Id : Scenario_Rep_Id) return Boolean; | |
1512 | pragma Inline (Elaboration_Checks_OK); | |
1513 | -- Determine whether scenario S_Id may be subjected to elaboration | |
1514 | -- checks. | |
1515 | ||
1516 | function Elaboration_Warnings_OK (S_Id : Scenario_Rep_Id) return Boolean; | |
1517 | pragma Inline (Elaboration_Warnings_OK); | |
1518 | -- Determine whether scenario S_Id may be subjected to elaboration | |
1519 | -- warnings. | |
1520 | ||
1521 | function Ghost_Mode_Of | |
1522 | (S_Id : Scenario_Rep_Id) return Extended_Ghost_Mode; | |
1523 | pragma Inline (Ghost_Mode_Of); | |
1524 | -- Obtain the Ghost mode of scenario S_Id | |
1525 | ||
1526 | function Is_Dispatching_Call (S_Id : Scenario_Rep_Id) return Boolean; | |
1527 | pragma Inline (Is_Dispatching_Call); | |
1528 | -- For Call_Scenario S_Id, determine whether the call is dispatching | |
1529 | ||
1530 | function Is_Read_Reference (S_Id : Scenario_Rep_Id) return Boolean; | |
1531 | pragma Inline (Is_Read_Reference); | |
1532 | -- For Variable_Reference_Scenario S_Id, determine whether the reference | |
1533 | -- is a read. | |
1534 | ||
1535 | function Kind (S_Id : Scenario_Rep_Id) return Scenario_Kind; | |
1536 | pragma Inline (Kind); | |
1537 | -- Obtain the nature of scenario S_Id | |
1538 | ||
1539 | function Level (S_Id : Scenario_Rep_Id) return Enclosing_Level_Kind; | |
1540 | pragma Inline (Level); | |
1541 | -- Obtain the enclosing level of scenario S_Id | |
1542 | ||
1543 | procedure Set_Activated_Task_Objects | |
1544 | (S_Id : Scenario_Rep_Id; | |
1545 | Task_Objs : NE_List.Doubly_Linked_List); | |
1546 | pragma Inline (Set_Activated_Task_Objects); | |
1547 | -- For Task_Activation_Scenario S_Id, set the list of task objects | |
1548 | -- activated by the scenario to Task_Objs. | |
1549 | ||
1550 | procedure Set_Activated_Task_Type | |
1551 | (S_Id : Scenario_Rep_Id; | |
1552 | Task_Typ : Entity_Id); | |
1553 | pragma Inline (Set_Activated_Task_Type); | |
1554 | -- For Task_Activation_Scenario S_Id, set the currently activated task | |
1555 | -- type to Task_Typ. | |
1556 | ||
1557 | function SPARK_Mode_Of | |
1558 | (S_Id : Scenario_Rep_Id) return Extended_SPARK_Mode; | |
1559 | pragma Inline (SPARK_Mode_Of); | |
1560 | -- Obtain the SPARK mode of scenario S_Id | |
1561 | ||
1562 | function Target (S_Id : Scenario_Rep_Id) return Entity_Id; | |
1563 | pragma Inline (Target); | |
1564 | -- Obtain the target of scenario S_Id | |
8dce7371 | 1565 | |
69e6ee2f HK |
1566 | ----------------------- |
1567 | -- Target attributes -- | |
1568 | ----------------------- | |
90e491a7 | 1569 | |
69e6ee2f HK |
1570 | function Barrier_Body_Declaration (T_Id : Target_Rep_Id) return Node_Id; |
1571 | pragma Inline (Barrier_Body_Declaration); | |
1572 | -- For Subprogram_Target T_Id, obtain the declaration of the barrier | |
1573 | -- function's body. | |
90e491a7 | 1574 | |
69e6ee2f HK |
1575 | function Body_Declaration (T_Id : Target_Rep_Id) return Node_Id; |
1576 | pragma Inline (Body_Declaration); | |
1577 | -- Obtain the declaration of the body which belongs to target T_Id | |
90e491a7 | 1578 | |
69e6ee2f HK |
1579 | procedure Disable_Elaboration_Checks (T_Id : Target_Rep_Id); |
1580 | pragma Inline (Disable_Elaboration_Checks); | |
1581 | -- Disable elaboration checks of target T_Id | |
90e491a7 | 1582 | |
69e6ee2f HK |
1583 | function Elaboration_Checks_OK (T_Id : Target_Rep_Id) return Boolean; |
1584 | pragma Inline (Elaboration_Checks_OK); | |
1585 | -- Determine whether target T_Id may be subjected to elaboration checks | |
8dce7371 | 1586 | |
69e6ee2f HK |
1587 | function Elaboration_Warnings_OK (T_Id : Target_Rep_Id) return Boolean; |
1588 | pragma Inline (Elaboration_Warnings_OK); | |
1589 | -- Determine whether target T_Id may be subjected to elaboration | |
1590 | -- warnings. | |
8dce7371 | 1591 | |
69e6ee2f HK |
1592 | function Ghost_Mode_Of (T_Id : Target_Rep_Id) return Extended_Ghost_Mode; |
1593 | pragma Inline (Ghost_Mode_Of); | |
1594 | -- Obtain the Ghost mode of target T_Id | |
8dce7371 | 1595 | |
69e6ee2f HK |
1596 | function Kind (T_Id : Target_Rep_Id) return Target_Kind; |
1597 | pragma Inline (Kind); | |
1598 | -- Obtain the nature of target T_Id | |
8dce7371 | 1599 | |
69e6ee2f HK |
1600 | function SPARK_Mode_Of (T_Id : Target_Rep_Id) return Extended_SPARK_Mode; |
1601 | pragma Inline (SPARK_Mode_Of); | |
1602 | -- Obtain the SPARK mode of target T_Id | |
8dce7371 | 1603 | |
69e6ee2f HK |
1604 | function Spec_Declaration (T_Id : Target_Rep_Id) return Node_Id; |
1605 | pragma Inline (Spec_Declaration); | |
1606 | -- Obtain the declaration of the spec which belongs to target T_Id | |
8dce7371 | 1607 | |
69e6ee2f HK |
1608 | function Unit (T_Id : Target_Rep_Id) return Entity_Id; |
1609 | pragma Inline (Unit); | |
1610 | -- Obtain the unit where the target is defined | |
8dce7371 | 1611 | |
69e6ee2f HK |
1612 | function Variable_Declaration (T_Id : Target_Rep_Id) return Node_Id; |
1613 | pragma Inline (Variable_Declaration); | |
1614 | -- For Variable_Target T_Id, obtain the declaration of the variable | |
8dce7371 | 1615 | |
69e6ee2f HK |
1616 | ----------------- |
1617 | -- Maintenance -- | |
1618 | ----------------- | |
90e491a7 | 1619 | |
69e6ee2f HK |
1620 | procedure Finalize_Internal_Representation; |
1621 | pragma Inline (Finalize_Internal_Representation); | |
1622 | -- Finalize all internal data structures | |
c23f55b4 | 1623 | |
69e6ee2f HK |
1624 | procedure Initialize_Internal_Representation; |
1625 | pragma Inline (Initialize_Internal_Representation); | |
1626 | -- Initialize all internal data structures | |
c23f55b4 | 1627 | |
69e6ee2f HK |
1628 | end Internal_Representation; |
1629 | use Internal_Representation; | |
c23f55b4 | 1630 | |
69e6ee2f HK |
1631 | -- The following package provides functionality for recording pieces of the |
1632 | -- invocation graph in the ALI file of the main unit. | |
c23f55b4 | 1633 | |
69e6ee2f | 1634 | package Invocation_Graph is |
8dce7371 | 1635 | |
69e6ee2f HK |
1636 | --------- |
1637 | -- API -- | |
1638 | --------- | |
8dce7371 | 1639 | |
69e6ee2f HK |
1640 | procedure Record_Invocation_Graph; |
1641 | pragma Inline (Record_Invocation_Graph); | |
1642 | -- Process all declaration, instantiation, and library level scenarios, | |
1643 | -- along with invocation construct within the spec and body of the main | |
1644 | -- unit to determine whether any of these reach into an external unit. | |
1645 | -- If such a path exists, encode in the ALI file of the main unit. | |
c23f55b4 | 1646 | |
69e6ee2f HK |
1647 | ----------------- |
1648 | -- Maintenance -- | |
1649 | ----------------- | |
90e491a7 | 1650 | |
69e6ee2f HK |
1651 | procedure Finalize_Invocation_Graph; |
1652 | pragma Inline (Finalize_Invocation_Graph); | |
1653 | -- Finalize all internal data structures | |
90e491a7 | 1654 | |
69e6ee2f HK |
1655 | procedure Initialize_Invocation_Graph; |
1656 | pragma Inline (Initialize_Invocation_Graph); | |
1657 | -- Initialize all internal data structures | |
8dce7371 | 1658 | |
69e6ee2f HK |
1659 | end Invocation_Graph; |
1660 | use Invocation_Graph; | |
90e491a7 | 1661 | |
69e6ee2f | 1662 | -- The following package stores scenarios |
90e491a7 | 1663 | |
69e6ee2f | 1664 | package Scenario_Storage is |
90e491a7 | 1665 | |
69e6ee2f HK |
1666 | --------- |
1667 | -- API -- | |
1668 | --------- | |
90e491a7 | 1669 | |
69e6ee2f HK |
1670 | procedure Add_Declaration_Scenario (N : Node_Id); |
1671 | pragma Inline (Add_Declaration_Scenario); | |
1672 | -- Save declaration level scenario N | |
90e491a7 | 1673 | |
69e6ee2f HK |
1674 | procedure Add_Dynamic_ABE_Check_Scenario (N : Node_Id); |
1675 | pragma Inline (Add_Dynamic_ABE_Check_Scenario); | |
1676 | -- Save scenario N for conditional ABE check installation purposes when | |
1677 | -- the dynamic model is in effect. | |
90e491a7 | 1678 | |
69e6ee2f HK |
1679 | procedure Add_Library_Body_Scenario (N : Node_Id); |
1680 | pragma Inline (Add_Library_Body_Scenario); | |
1681 | -- Save library-level body scenario N | |
90e491a7 | 1682 | |
69e6ee2f HK |
1683 | procedure Add_Library_Spec_Scenario (N : Node_Id); |
1684 | pragma Inline (Add_Library_Spec_Scenario); | |
1685 | -- Save library-level spec scenario N | |
90e491a7 | 1686 | |
69e6ee2f HK |
1687 | procedure Add_SPARK_Scenario (N : Node_Id); |
1688 | pragma Inline (Add_SPARK_Scenario); | |
1689 | -- Save SPARK scenario N | |
90e491a7 | 1690 | |
69e6ee2f HK |
1691 | procedure Delete_Scenario (N : Node_Id); |
1692 | pragma Inline (Delete_Scenario); | |
1693 | -- Delete arbitrary scenario N | |
fb9dd1c7 | 1694 | |
69e6ee2f HK |
1695 | function Iterate_Declaration_Scenarios return NE_Set.Iterator; |
1696 | pragma Inline (Iterate_Declaration_Scenarios); | |
1697 | -- Obtain an iterator over all declaration level scenarios | |
90e491a7 | 1698 | |
69e6ee2f HK |
1699 | function Iterate_Dynamic_ABE_Check_Scenarios return NE_Set.Iterator; |
1700 | pragma Inline (Iterate_Dynamic_ABE_Check_Scenarios); | |
1701 | -- Obtain an iterator over all scenarios that require a conditional ABE | |
1702 | -- check when the dynamic model is in effect. | |
90e491a7 | 1703 | |
69e6ee2f HK |
1704 | function Iterate_Library_Body_Scenarios return NE_Set.Iterator; |
1705 | pragma Inline (Iterate_Library_Body_Scenarios); | |
1706 | -- Obtain an iterator over all library level body scenarios | |
90e491a7 | 1707 | |
69e6ee2f HK |
1708 | function Iterate_Library_Spec_Scenarios return NE_Set.Iterator; |
1709 | pragma Inline (Iterate_Library_Spec_Scenarios); | |
1710 | -- Obtain an iterator over all library level spec scenarios | |
1711 | ||
1712 | function Iterate_SPARK_Scenarios return NE_Set.Iterator; | |
1713 | pragma Inline (Iterate_SPARK_Scenarios); | |
1714 | -- Obtain an iterator over all SPARK scenarios | |
1715 | ||
1716 | procedure Replace_Scenario (Old_N : Node_Id; New_N : Node_Id); | |
1717 | pragma Inline (Replace_Scenario); | |
1718 | -- Replace scenario Old_N with scenario New_N | |
1719 | ||
1720 | ----------------- | |
1721 | -- Maintenance -- | |
1722 | ----------------- | |
1723 | ||
1724 | procedure Finalize_Scenario_Storage; | |
1725 | pragma Inline (Finalize_Scenario_Storage); | |
1726 | -- Finalize all internal data structures | |
1727 | ||
1728 | procedure Initialize_Scenario_Storage; | |
1729 | pragma Inline (Initialize_Scenario_Storage); | |
1730 | -- Initialize all internal data structures | |
1731 | ||
1732 | end Scenario_Storage; | |
1733 | use Scenario_Storage; | |
1734 | ||
1735 | -- The following package provides various semantic predicates | |
1736 | ||
1737 | package Semantics is | |
1738 | ||
1739 | --------- | |
1740 | -- API -- | |
1741 | --------- | |
1742 | ||
1743 | function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean; | |
1744 | pragma Inline (Is_Accept_Alternative_Proc); | |
1745 | -- Determine whether arbitrary entity Id denotes an internally generated | |
1746 | -- procedure which encapsulates the statements of an accept alternative. | |
1747 | ||
1748 | function Is_Activation_Proc (Id : Entity_Id) return Boolean; | |
1749 | pragma Inline (Is_Activation_Proc); | |
1750 | -- Determine whether arbitrary entity Id denotes a runtime procedure in | |
1751 | -- charge with activating tasks. | |
1752 | ||
1753 | function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean; | |
1754 | pragma Inline (Is_Ada_Semantic_Target); | |
1755 | -- Determine whether arbitrary entity Id denodes a source or internally | |
1756 | -- generated subprogram which emulates Ada semantics. | |
1757 | ||
1758 | function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean; | |
1759 | pragma Inline (Is_Assertion_Pragma_Target); | |
1760 | -- Determine whether arbitrary entity Id denotes a procedure which | |
1761 | -- varifies the run-time semantics of an assertion pragma. | |
1762 | ||
1763 | function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean; | |
1764 | pragma Inline (Is_Bodiless_Subprogram); | |
1765 | -- Determine whether subprogram Subp_Id will never have a body | |
1766 | ||
1767 | function Is_Bridge_Target (Id : Entity_Id) return Boolean; | |
1768 | pragma Inline (Is_Bridge_Target); | |
1769 | -- Determine whether arbitrary entity Id denotes a bridge target | |
1770 | ||
1771 | function Is_Controlled_Proc | |
1772 | (Subp_Id : Entity_Id; | |
1773 | Subp_Nam : Name_Id) return Boolean; | |
1774 | pragma Inline (Is_Controlled_Proc); | |
1775 | -- Determine whether subprogram Subp_Id denotes controlled type | |
1776 | -- primitives Adjust, Finalize, or Initialize as denoted by name | |
1777 | -- Subp_Nam. | |
1778 | ||
1779 | function Is_Default_Initial_Condition_Proc | |
1780 | (Id : Entity_Id) return Boolean; | |
1781 | pragma Inline (Is_Default_Initial_Condition_Proc); | |
1782 | -- Determine whether arbitrary entity Id denotes internally generated | |
1783 | -- routine Default_Initial_Condition. | |
1784 | ||
1785 | function Is_Finalizer_Proc (Id : Entity_Id) return Boolean; | |
1786 | pragma Inline (Is_Finalizer_Proc); | |
1787 | -- Determine whether arbitrary entity Id denotes internally generated | |
1788 | -- routine _Finalizer. | |
1789 | ||
1790 | function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean; | |
1791 | pragma Inline (Is_Initial_Condition_Proc); | |
1792 | -- Determine whether arbitrary entity Id denotes internally generated | |
1793 | -- routine Initial_Condition. | |
1794 | ||
1795 | function Is_Initialized (Obj_Decl : Node_Id) return Boolean; | |
1796 | pragma Inline (Is_Initialized); | |
1797 | -- Determine whether object declaration Obj_Decl is initialized | |
1798 | ||
1799 | function Is_Invariant_Proc (Id : Entity_Id) return Boolean; | |
1800 | pragma Inline (Is_Invariant_Proc); | |
1801 | -- Determine whether arbitrary entity Id denotes an invariant procedure | |
1802 | ||
1803 | function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean; | |
1804 | pragma Inline (Is_Non_Library_Level_Encapsulator); | |
1805 | -- Determine whether arbitrary node N is a non-library encapsulator | |
1806 | ||
1807 | function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean; | |
1808 | pragma Inline (Is_Partial_Invariant_Proc); | |
1809 | -- Determine whether arbitrary entity Id denotes a partial invariant | |
1810 | -- procedure. | |
1811 | ||
1812 | function Is_Postconditions_Proc (Id : Entity_Id) return Boolean; | |
1813 | pragma Inline (Is_Postconditions_Proc); | |
1814 | -- Determine whether arbitrary entity Id denotes internally generated | |
1815 | -- routine _Postconditions. | |
1816 | ||
1817 | function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean; | |
1818 | pragma Inline (Is_Preelaborated_Unit); | |
1819 | -- Determine whether arbitrary entity Id denotes a unit which is subject | |
1820 | -- to one of the following pragmas: | |
1821 | -- | |
1822 | -- * Preelaborable | |
1823 | -- * Pure | |
1824 | -- * Remote_Call_Interface | |
1825 | -- * Remote_Types | |
1826 | -- * Shared_Passive | |
1827 | ||
1828 | function Is_Protected_Entry (Id : Entity_Id) return Boolean; | |
1829 | pragma Inline (Is_Protected_Entry); | |
1830 | -- Determine whether arbitrary entity Id denotes a protected entry | |
1831 | ||
1832 | function Is_Protected_Subp (Id : Entity_Id) return Boolean; | |
1833 | pragma Inline (Is_Protected_Subp); | |
1834 | -- Determine whether entity Id denotes a protected subprogram | |
1835 | ||
1836 | function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean; | |
1837 | pragma Inline (Is_Protected_Body_Subp); | |
1838 | -- Determine whether entity Id denotes the protected or unprotected | |
1839 | -- version of a protected subprogram. | |
1840 | ||
1841 | function Is_Scenario (N : Node_Id) return Boolean; | |
1842 | pragma Inline (Is_Scenario); | |
1843 | -- Determine whether attribute node N denotes a scenario. The scenario | |
1844 | -- may not necessarily be eligible for ABE processing. | |
1845 | ||
1846 | function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean; | |
1847 | pragma Inline (Is_SPARK_Semantic_Target); | |
1848 | -- Determine whether arbitrary entity Id nodes a source or internally | |
1849 | -- generated subprogram which emulates SPARK semantics. | |
1850 | ||
1851 | function Is_Subprogram_Inst (Id : Entity_Id) return Boolean; | |
1852 | pragma Inline (Is_Subprogram_Inst); | |
1853 | -- Determine whether arbitrary entity Id denotes a subprogram instance | |
1854 | ||
1855 | function Is_Suitable_Access_Taken (N : Node_Id) return Boolean; | |
1856 | pragma Inline (Is_Suitable_Access_Taken); | |
1857 | -- Determine whether arbitrary node N denotes a suitable attribute for | |
1858 | -- ABE processing. | |
1859 | ||
1860 | function Is_Suitable_Call (N : Node_Id) return Boolean; | |
1861 | pragma Inline (Is_Suitable_Call); | |
1862 | -- Determine whether arbitrary node N denotes a suitable call for ABE | |
1863 | -- processing. | |
1864 | ||
1865 | function Is_Suitable_Instantiation (N : Node_Id) return Boolean; | |
1866 | pragma Inline (Is_Suitable_Instantiation); | |
1867 | -- Determine whether arbitrary node N is a suitable instantiation for | |
1868 | -- ABE processing. | |
1869 | ||
1870 | function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean; | |
1871 | pragma Inline (Is_Suitable_SPARK_Derived_Type); | |
1872 | -- Determine whether arbitrary node N denotes a suitable derived type | |
1873 | -- declaration for ABE processing using the SPARK rules. | |
1874 | ||
1875 | function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean; | |
1876 | pragma Inline (Is_Suitable_SPARK_Instantiation); | |
1877 | -- Determine whether arbitrary node N denotes a suitable instantiation | |
1878 | -- for ABE processing using the SPARK rules. | |
1879 | ||
1880 | function Is_Suitable_SPARK_Refined_State_Pragma | |
1881 | (N : Node_Id) return Boolean; | |
1882 | pragma Inline (Is_Suitable_SPARK_Refined_State_Pragma); | |
1883 | -- Determine whether arbitrary node N denotes a suitable Refined_State | |
1884 | -- pragma for ABE processing using the SPARK rules. | |
1885 | ||
1886 | function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean; | |
1887 | pragma Inline (Is_Suitable_Variable_Assignment); | |
1888 | -- Determine whether arbitrary node N denotes a suitable assignment for | |
1889 | -- ABE processing. | |
1890 | ||
1891 | function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean; | |
1892 | pragma Inline (Is_Suitable_Variable_Reference); | |
1893 | -- Determine whether arbitrary node N is a suitable variable reference | |
1894 | -- for ABE processing. | |
1895 | ||
1896 | function Is_Task_Entry (Id : Entity_Id) return Boolean; | |
1897 | pragma Inline (Is_Task_Entry); | |
1898 | -- Determine whether arbitrary entity Id denotes a task entry | |
1899 | ||
1900 | function Is_Up_Level_Target | |
1901 | (Targ_Decl : Node_Id; | |
1902 | In_State : Processing_In_State) return Boolean; | |
1903 | pragma Inline (Is_Up_Level_Target); | |
1904 | -- Determine whether the current root resides at the declaration level. | |
1905 | -- If this is the case, determine whether a target with by declaration | |
1906 | -- Target_Decl is within a context which encloses the current root or is | |
1907 | -- in a different unit. In_State is the current state of the Processing | |
1908 | -- phase. | |
1909 | ||
1910 | end Semantics; | |
1911 | use Semantics; | |
1912 | ||
1913 | -- The following package provides the main entry point for SPARK-related | |
1914 | -- checks and diagnostics. | |
1915 | ||
1916 | package SPARK_Processor is | |
1917 | ||
1918 | --------- | |
1919 | -- API -- | |
1920 | --------- | |
1921 | ||
1922 | procedure Check_SPARK_Model_In_Effect; | |
1923 | pragma Inline (Check_SPARK_Model_In_Effect); | |
1924 | -- Determine whether a suitable elaboration model is currently in effect | |
1925 | -- for verifying SPARK rules. Emit a warning if this is not the case. | |
1926 | ||
1927 | procedure Check_SPARK_Scenarios; | |
1928 | pragma Inline (Check_SPARK_Scenarios); | |
1929 | -- Examine SPARK scenarios which are not necessarily executable during | |
1930 | -- elaboration, but still requires elaboration-related checks. | |
1931 | ||
1932 | end SPARK_Processor; | |
1933 | use SPARK_Processor; | |
1934 | ||
1935 | ----------------------- | |
1936 | -- Local subprograms -- | |
1937 | ----------------------- | |
1938 | ||
1939 | function Assignment_Target (Asmt : Node_Id) return Node_Id; | |
1940 | pragma Inline (Assignment_Target); | |
1941 | -- Obtain the target of assignment statement Asmt | |
1942 | ||
1943 | function Call_Name (Call : Node_Id) return Node_Id; | |
1944 | pragma Inline (Call_Name); | |
1945 | -- Obtain the name of an entry, operator, or subprogram call Call | |
1946 | ||
1947 | function Canonical_Subprogram (Subp_Id : Entity_Id) return Entity_Id; | |
1948 | pragma Inline (Canonical_Subprogram); | |
1949 | -- Obtain the uniform canonical entity of subprogram Subp_Id | |
1950 | ||
1951 | function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id; | |
1952 | pragma Inline (Compilation_Unit); | |
1953 | -- Return the N_Compilation_Unit node of unit Unit_Id | |
1954 | ||
1955 | function Find_Enclosing_Instance (N : Node_Id) return Node_Id; | |
1956 | pragma Inline (Find_Enclosing_Instance); | |
1957 | -- Find the declaration or body of the nearest expanded instance which | |
1958 | -- encloses arbitrary node N. Return Empty if no such instance exists. | |
1959 | ||
1960 | function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id; | |
1961 | pragma Inline (Find_Top_Unit); | |
1962 | -- Return the top unit which contains arbitrary node or entity N. The unit | |
1963 | -- is obtained by logically unwinding instantiations and subunits when N | |
1964 | -- resides within one. | |
1965 | ||
1966 | function Find_Unit_Entity (N : Node_Id) return Entity_Id; | |
1967 | pragma Inline (Find_Unit_Entity); | |
1968 | -- Return the entity of unit N | |
1969 | ||
1970 | function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id; | |
1971 | pragma Inline (First_Formal_Type); | |
1972 | -- Return the type of subprogram Subp_Id's first formal parameter. If the | |
1973 | -- subprogram lacks formal parameters, return Empty. | |
1974 | ||
0839ffce HK |
1975 | function Elaboration_Phase_Active return Boolean; |
1976 | pragma Inline (Elaboration_Phase_Active); | |
1977 | -- Determine whether the elaboration phase of the compilation has started | |
1978 | ||
1979 | procedure Finalize_All_Data_Structures; | |
1980 | pragma Inline (Finalize_All_Data_Structures); | |
1981 | -- Destroy all internal data structures | |
1982 | ||
69e6ee2f HK |
1983 | function Has_Body (Pack_Decl : Node_Id) return Boolean; |
1984 | pragma Inline (Has_Body); | |
1985 | -- Determine whether package declaration Pack_Decl has a corresponding body | |
1986 | -- or would eventually have one. | |
1987 | ||
1988 | function In_External_Instance | |
1989 | (N : Node_Id; | |
1990 | Target_Decl : Node_Id) return Boolean; | |
2e60feb5 | 1991 | pragma Inline (In_External_Instance); |
90e491a7 PMR |
1992 | -- Determine whether a target desctibed by its declaration Target_Decl |
1993 | -- resides in a package instance which is external to scenario N. | |
1994 | ||
1995 | function In_Main_Context (N : Node_Id) return Boolean; | |
1996 | pragma Inline (In_Main_Context); | |
1997 | -- Determine whether arbitrary node N appears within the main compilation | |
1998 | -- unit. | |
1999 | ||
2000 | function In_Same_Context | |
2001 | (N1 : Node_Id; | |
2002 | N2 : Node_Id; | |
2003 | Nested_OK : Boolean := False) return Boolean; | |
69e6ee2f | 2004 | pragma Inline (In_Same_Context); |
90e491a7 PMR |
2005 | -- Determine whether two arbitrary nodes N1 and N2 appear within the same |
2006 | -- context ignoring enclosing library levels. Nested_OK should be set when | |
2007 | -- the context of N1 can enclose that of N2. | |
2008 | ||
0839ffce HK |
2009 | procedure Initialize_All_Data_Structures; |
2010 | pragma Inline (Initialize_All_Data_Structures); | |
2011 | -- Create all internal data structures | |
2012 | ||
69e6ee2f HK |
2013 | function Instantiated_Generic (Inst : Node_Id) return Entity_Id; |
2014 | pragma Inline (Instantiated_Generic); | |
2015 | -- Obtain the generic instantiated by instance Inst | |
c23f55b4 | 2016 | |
90e491a7 | 2017 | function Is_Safe_Activation |
69e6ee2f HK |
2018 | (Call : Node_Id; |
2019 | Task_Rep : Target_Rep_Id) return Boolean; | |
90e491a7 | 2020 | pragma Inline (Is_Safe_Activation); |
69e6ee2f HK |
2021 | -- Determine whether activation call Call which activates an object of a |
2022 | -- task type described by representation Task_Rep is always ABE-safe. | |
90e491a7 PMR |
2023 | |
2024 | function Is_Safe_Call | |
69e6ee2f HK |
2025 | (Call : Node_Id; |
2026 | Subp_Id : Entity_Id; | |
2027 | Subp_Rep : Target_Rep_Id) return Boolean; | |
90e491a7 | 2028 | pragma Inline (Is_Safe_Call); |
69e6ee2f HK |
2029 | -- Determine whether call Call which invokes entry, operator, or subprogram |
2030 | -- Subp_Id is always ABE-safe. Subp_Rep is the representation of the entry, | |
2031 | -- operator, or subprogram. | |
90e491a7 PMR |
2032 | |
2033 | function Is_Safe_Instantiation | |
69e6ee2f HK |
2034 | (Inst : Node_Id; |
2035 | Gen_Id : Entity_Id; | |
2036 | Gen_Rep : Target_Rep_Id) return Boolean; | |
90e491a7 | 2037 | pragma Inline (Is_Safe_Instantiation); |
69e6ee2f HK |
2038 | -- Determine whether instantiation Inst which instantiates generic Gen_Id |
2039 | -- is always ABE-safe. Gen_Rep is the representation of the generic. | |
90e491a7 PMR |
2040 | |
2041 | function Is_Same_Unit | |
2042 | (Unit_1 : Entity_Id; | |
2043 | Unit_2 : Entity_Id) return Boolean; | |
2044 | pragma Inline (Is_Same_Unit); | |
2045 | -- Determine whether entities Unit_1 and Unit_2 denote the same unit | |
2046 | ||
3eb5e54a HK |
2047 | function Main_Unit_Entity return Entity_Id; |
2048 | pragma Inline (Main_Unit_Entity); | |
2049 | -- Return the entity of the main unit | |
2050 | ||
90e491a7 PMR |
2051 | function Non_Private_View (Typ : Entity_Id) return Entity_Id; |
2052 | pragma Inline (Non_Private_View); | |
2053 | -- Return the full view of private type Typ if available, otherwise return | |
2054 | -- type Typ. | |
2055 | ||
69e6ee2f HK |
2056 | function Scenario (N : Node_Id) return Node_Id; |
2057 | pragma Inline (Scenario); | |
2058 | -- Return the appropriate scenario node for scenario N | |
90e491a7 | 2059 | |
0839ffce HK |
2060 | procedure Set_Elaboration_Phase (Status : Elaboration_Phase_Status); |
2061 | pragma Inline (Set_Elaboration_Phase); | |
2062 | -- Change the status of the elaboration phase of the compiler to Status | |
2063 | ||
69e6ee2f HK |
2064 | procedure Spec_And_Body_From_Entity |
2065 | (Id : Node_Id; | |
2066 | Spec_Decl : out Node_Id; | |
2067 | Body_Decl : out Node_Id); | |
2068 | pragma Inline (Spec_And_Body_From_Entity); | |
2069 | -- Given arbitrary entity Id representing a construct with a spec and body, | |
2070 | -- retrieve declaration of the spec in Spec_Decl and the declaration of the | |
2071 | -- body in Body_Decl. | |
90e491a7 | 2072 | |
69e6ee2f HK |
2073 | procedure Spec_And_Body_From_Node |
2074 | (N : Node_Id; | |
2075 | Spec_Decl : out Node_Id; | |
2076 | Body_Decl : out Node_Id); | |
2077 | pragma Inline (Spec_And_Body_From_Node); | |
2078 | -- Given arbitrary node N representing a construct with a spec and body, | |
2079 | -- retrieve declaration of the spec in Spec_Decl and the declaration of | |
2080 | -- the body in Body_Decl. | |
8dce7371 | 2081 | |
90e491a7 PMR |
2082 | function Static_Elaboration_Checks return Boolean; |
2083 | pragma Inline (Static_Elaboration_Checks); | |
2084 | -- Determine whether the static model is in effect | |
2085 | ||
7255f3c3 HK |
2086 | function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id; |
2087 | pragma Inline (Unit_Entity); | |
2088 | -- Return the entity of the initial declaration for unit Unit_Id | |
2089 | ||
90e491a7 | 2090 | procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id); |
2e60feb5 | 2091 | pragma Inline (Update_Elaboration_Scenario); |
90e491a7 PMR |
2092 | -- Update all relevant internal data structures when scenario Old_N is |
2093 | -- transformed into scenario New_N by Atree.Rewrite. | |
2094 | ||
69e6ee2f HK |
2095 | ---------------------- |
2096 | -- Active_Scenarios -- | |
2097 | ---------------------- | |
c581c520 | 2098 | |
69e6ee2f | 2099 | package body Active_Scenarios is |
90e491a7 | 2100 | |
69e6ee2f HK |
2101 | ----------------------- |
2102 | -- Local subprograms -- | |
2103 | ----------------------- | |
90e491a7 | 2104 | |
69e6ee2f HK |
2105 | procedure Output_Access_Taken |
2106 | (Attr : Node_Id; | |
2107 | Attr_Rep : Scenario_Rep_Id; | |
2108 | Error_Nod : Node_Id); | |
2109 | pragma Inline (Output_Access_Taken); | |
2110 | -- Emit a specific diagnostic message for 'Access attribute reference | |
2111 | -- Attr with representation Attr_Rep. The message is associated with | |
2112 | -- node Error_Nod. | |
90e491a7 | 2113 | |
69e6ee2f HK |
2114 | procedure Output_Active_Scenario |
2115 | (N : Node_Id; | |
2116 | Error_Nod : Node_Id; | |
2117 | In_State : Processing_In_State); | |
2118 | pragma Inline (Output_Active_Scenario); | |
2119 | -- Top level dispatcher for outputting a scenario. Emit a specific | |
2120 | -- diagnostic message for scenario N. The message is associated with | |
2121 | -- node Error_Nod. In_State is the current state of the Processing | |
2122 | -- phase. | |
2123 | ||
2124 | procedure Output_Call | |
2125 | (Call : Node_Id; | |
2126 | Call_Rep : Scenario_Rep_Id; | |
2127 | Error_Nod : Node_Id); | |
2128 | pragma Inline (Output_Call); | |
2129 | -- Emit a diagnostic message for call Call with representation Call_Rep. | |
2130 | -- The message is associated with node Error_Nod. | |
2131 | ||
2132 | procedure Output_Header (Error_Nod : Node_Id); | |
2133 | pragma Inline (Output_Header); | |
2134 | -- Emit a specific diagnostic message for the unit of the root scenario. | |
2135 | -- The message is associated with node Error_Nod. | |
2136 | ||
2137 | procedure Output_Instantiation | |
2138 | (Inst : Node_Id; | |
2139 | Inst_Rep : Scenario_Rep_Id; | |
2140 | Error_Nod : Node_Id); | |
2141 | pragma Inline (Output_Instantiation); | |
2142 | -- Emit a specific diagnostic message for instantiation Inst with | |
2143 | -- representation Inst_Rep. The message is associated with node | |
2144 | -- Error_Nod. | |
2145 | ||
2146 | procedure Output_Refined_State_Pragma | |
2147 | (Prag : Node_Id; | |
2148 | Prag_Rep : Scenario_Rep_Id; | |
2149 | Error_Nod : Node_Id); | |
2150 | pragma Inline (Output_Refined_State_Pragma); | |
2151 | -- Emit a specific diagnostic message for Refined_State pragma Prag | |
2152 | -- with representation Prag_Rep. The message is associated with node | |
2153 | -- Error_Nod. | |
2154 | ||
2155 | procedure Output_Task_Activation | |
2156 | (Call : Node_Id; | |
2157 | Call_Rep : Scenario_Rep_Id; | |
2158 | Error_Nod : Node_Id); | |
2159 | pragma Inline (Output_Task_Activation); | |
2160 | -- Emit a specific diagnostic message for activation call Call | |
2161 | -- with representation Call_Rep. The message is associated with | |
2162 | -- node Error_Nod. | |
2163 | ||
2164 | procedure Output_Variable_Assignment | |
2165 | (Asmt : Node_Id; | |
2166 | Asmt_Rep : Scenario_Rep_Id; | |
2167 | Error_Nod : Node_Id); | |
2168 | pragma Inline (Output_Variable_Assignment); | |
2169 | -- Emit a specific diagnostic message for assignment statement Asmt | |
2170 | -- with representation Asmt_Rep. The message is associated with node | |
2171 | -- Error_Nod. | |
2172 | ||
2173 | procedure Output_Variable_Reference | |
2174 | (Ref : Node_Id; | |
2175 | Ref_Rep : Scenario_Rep_Id; | |
2176 | Error_Nod : Node_Id); | |
2177 | pragma Inline (Output_Variable_Reference); | |
2178 | -- Emit a specific diagnostic message for read reference Ref with | |
2179 | -- representation Ref_Rep. The message is associated with node | |
2180 | -- Error_Nod. | |
90e491a7 | 2181 | |
69e6ee2f HK |
2182 | ------------------- |
2183 | -- Output_Access -- | |
2184 | ------------------- | |
c581c520 | 2185 | |
69e6ee2f HK |
2186 | procedure Output_Access_Taken |
2187 | (Attr : Node_Id; | |
2188 | Attr_Rep : Scenario_Rep_Id; | |
2189 | Error_Nod : Node_Id) | |
c581c520 | 2190 | is |
69e6ee2f | 2191 | Subp_Id : constant Entity_Id := Target (Attr_Rep); |
c581c520 PMR |
2192 | |
2193 | begin | |
69e6ee2f HK |
2194 | Error_Msg_Name_1 := Attribute_Name (Attr); |
2195 | Error_Msg_Sloc := Sloc (Attr); | |
2196 | Error_Msg_NE ("\\ % of & taken #", Error_Nod, Subp_Id); | |
2197 | end Output_Access_Taken; | |
c581c520 | 2198 | |
69e6ee2f HK |
2199 | ---------------------------- |
2200 | -- Output_Active_Scenario -- | |
2201 | ---------------------------- | |
c581c520 | 2202 | |
69e6ee2f HK |
2203 | procedure Output_Active_Scenario |
2204 | (N : Node_Id; | |
2205 | Error_Nod : Node_Id; | |
2206 | In_State : Processing_In_State) | |
2207 | is | |
2208 | Scen : constant Node_Id := Scenario (N); | |
2209 | Scen_Rep : Scenario_Rep_Id; | |
c581c520 | 2210 | |
69e6ee2f HK |
2211 | begin |
2212 | -- 'Access | |
c581c520 | 2213 | |
69e6ee2f HK |
2214 | if Is_Suitable_Access_Taken (Scen) then |
2215 | Output_Access_Taken | |
2216 | (Attr => Scen, | |
2217 | Attr_Rep => Scenario_Representation_Of (Scen, In_State), | |
2218 | Error_Nod => Error_Nod); | |
c581c520 | 2219 | |
69e6ee2f | 2220 | -- Call or task activation |
c581c520 | 2221 | |
69e6ee2f HK |
2222 | elsif Is_Suitable_Call (Scen) then |
2223 | Scen_Rep := Scenario_Representation_Of (Scen, In_State); | |
c581c520 | 2224 | |
69e6ee2f HK |
2225 | if Kind (Scen_Rep) = Call_Scenario then |
2226 | Output_Call | |
2227 | (Call => Scen, | |
2228 | Call_Rep => Scen_Rep, | |
2229 | Error_Nod => Error_Nod); | |
c581c520 | 2230 | |
69e6ee2f HK |
2231 | else |
2232 | pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); | |
c581c520 | 2233 | |
69e6ee2f HK |
2234 | Output_Task_Activation |
2235 | (Call => Scen, | |
2236 | Call_Rep => Scen_Rep, | |
2237 | Error_Nod => Error_Nod); | |
c581c520 | 2238 | end if; |
c581c520 | 2239 | |
69e6ee2f | 2240 | -- Instantiation |
90e491a7 | 2241 | |
69e6ee2f HK |
2242 | elsif Is_Suitable_Instantiation (Scen) then |
2243 | Output_Instantiation | |
2244 | (Inst => Scen, | |
2245 | Inst_Rep => Scenario_Representation_Of (Scen, In_State), | |
2246 | Error_Nod => Error_Nod); | |
90e491a7 | 2247 | |
69e6ee2f | 2248 | -- Pragma Refined_State |
90e491a7 | 2249 | |
69e6ee2f HK |
2250 | elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then |
2251 | Output_Refined_State_Pragma | |
2252 | (Prag => Scen, | |
2253 | Prag_Rep => Scenario_Representation_Of (Scen, In_State), | |
2254 | Error_Nod => Error_Nod); | |
90e491a7 | 2255 | |
69e6ee2f | 2256 | -- Variable assignment |
90e491a7 | 2257 | |
69e6ee2f HK |
2258 | elsif Is_Suitable_Variable_Assignment (Scen) then |
2259 | Output_Variable_Assignment | |
2260 | (Asmt => Scen, | |
2261 | Asmt_Rep => Scenario_Representation_Of (Scen, In_State), | |
2262 | Error_Nod => Error_Nod); | |
90e491a7 | 2263 | |
69e6ee2f | 2264 | -- Variable reference |
90e491a7 | 2265 | |
69e6ee2f HK |
2266 | elsif Is_Suitable_Variable_Reference (Scen) then |
2267 | Output_Variable_Reference | |
2268 | (Ref => Scen, | |
2269 | Ref_Rep => Scenario_Representation_Of (Scen, In_State), | |
2270 | Error_Nod => Error_Nod); | |
2271 | end if; | |
2272 | end Output_Active_Scenario; | |
90e491a7 | 2273 | |
69e6ee2f HK |
2274 | ----------------------------- |
2275 | -- Output_Active_Scenarios -- | |
2276 | ----------------------------- | |
90e491a7 | 2277 | |
69e6ee2f HK |
2278 | procedure Output_Active_Scenarios |
2279 | (Error_Nod : Node_Id; | |
2280 | In_State : Processing_In_State) | |
2281 | is | |
2282 | package Scenarios renames Active_Scenario_Stack; | |
90e491a7 | 2283 | |
69e6ee2f | 2284 | Header_Posted : Boolean := False; |
90e491a7 | 2285 | |
90e491a7 | 2286 | begin |
69e6ee2f HK |
2287 | -- Output the contents of the active scenario stack starting from the |
2288 | -- bottom, or the least recent scenario. | |
90e491a7 | 2289 | |
69e6ee2f HK |
2290 | for Index in Scenarios.First .. Scenarios.Last loop |
2291 | if not Header_Posted then | |
2292 | Output_Header (Error_Nod); | |
2293 | Header_Posted := True; | |
2294 | end if; | |
90e491a7 | 2295 | |
69e6ee2f HK |
2296 | Output_Active_Scenario |
2297 | (N => Scenarios.Table (Index), | |
2298 | Error_Nod => Error_Nod, | |
2299 | In_State => In_State); | |
2300 | end loop; | |
2301 | end Output_Active_Scenarios; | |
90e491a7 | 2302 | |
69e6ee2f HK |
2303 | ----------------- |
2304 | -- Output_Call -- | |
2305 | ----------------- | |
90e491a7 | 2306 | |
69e6ee2f HK |
2307 | procedure Output_Call |
2308 | (Call : Node_Id; | |
2309 | Call_Rep : Scenario_Rep_Id; | |
2310 | Error_Nod : Node_Id) | |
2311 | is | |
2312 | procedure Output_Accept_Alternative (Alt_Id : Entity_Id); | |
2313 | pragma Inline (Output_Accept_Alternative); | |
2314 | -- Emit a specific diagnostic message concerning accept alternative | |
2315 | -- with entity Alt_Id. | |
90e491a7 | 2316 | |
69e6ee2f HK |
2317 | procedure Output_Call (Subp_Id : Entity_Id; Kind : String); |
2318 | pragma Inline (Output_Call); | |
2319 | -- Emit a specific diagnostic message concerning a call of kind Kind | |
2320 | -- which invokes subprogram Subp_Id. | |
90e491a7 | 2321 | |
69e6ee2f HK |
2322 | procedure Output_Type_Actions (Subp_Id : Entity_Id; Action : String); |
2323 | pragma Inline (Output_Type_Actions); | |
2324 | -- Emit a specific diagnostic message concerning action Action of a | |
2325 | -- type performed by subprogram Subp_Id. | |
90e491a7 | 2326 | |
69e6ee2f HK |
2327 | procedure Output_Verification_Call |
2328 | (Pred : String; | |
2329 | Id : Entity_Id; | |
2330 | Id_Kind : String); | |
2331 | pragma Inline (Output_Verification_Call); | |
2332 | -- Emit a specific diagnostic message concerning the verification of | |
2333 | -- predicate Pred applied to related entity Id with kind Id_Kind. | |
90e491a7 | 2334 | |
69e6ee2f HK |
2335 | ------------------------------- |
2336 | -- Output_Accept_Alternative -- | |
2337 | ------------------------------- | |
90e491a7 | 2338 | |
69e6ee2f HK |
2339 | procedure Output_Accept_Alternative (Alt_Id : Entity_Id) is |
2340 | Entry_Id : constant Entity_Id := Receiving_Entry (Alt_Id); | |
2341 | ||
2342 | begin | |
2343 | pragma Assert (Present (Entry_Id)); | |
2344 | ||
2345 | Error_Msg_NE ("\\ entry & selected #", Error_Nod, Entry_Id); | |
2346 | end Output_Accept_Alternative; | |
2347 | ||
2348 | ----------------- | |
2349 | -- Output_Call -- | |
2350 | ----------------- | |
2351 | ||
2352 | procedure Output_Call (Subp_Id : Entity_Id; Kind : String) is | |
2353 | begin | |
2354 | Error_Msg_NE ("\\ " & Kind & " & called #", Error_Nod, Subp_Id); | |
2355 | end Output_Call; | |
2356 | ||
2357 | ------------------------- | |
2358 | -- Output_Type_Actions -- | |
2359 | ------------------------- | |
2360 | ||
2361 | procedure Output_Type_Actions | |
2362 | (Subp_Id : Entity_Id; | |
2363 | Action : String) | |
2364 | is | |
2365 | Typ : constant Entity_Id := First_Formal_Type (Subp_Id); | |
2366 | ||
2367 | begin | |
2368 | pragma Assert (Present (Typ)); | |
2369 | ||
2370 | Error_Msg_NE | |
2371 | ("\\ " & Action & " actions for type & #", Error_Nod, Typ); | |
2372 | end Output_Type_Actions; | |
2373 | ||
2374 | ------------------------------ | |
2375 | -- Output_Verification_Call -- | |
2376 | ------------------------------ | |
2377 | ||
2378 | procedure Output_Verification_Call | |
2379 | (Pred : String; | |
2380 | Id : Entity_Id; | |
2381 | Id_Kind : String) | |
2382 | is | |
2383 | begin | |
2384 | pragma Assert (Present (Id)); | |
2385 | ||
2386 | Error_Msg_NE | |
2387 | ("\\ " & Pred & " of " & Id_Kind & " & verified #", | |
2388 | Error_Nod, Id); | |
2389 | end Output_Verification_Call; | |
2390 | ||
2391 | -- Local variables | |
2392 | ||
2393 | Subp_Id : constant Entity_Id := Target (Call_Rep); | |
2394 | ||
2395 | -- Start of processing for Output_Call | |
2396 | ||
2397 | begin | |
2398 | Error_Msg_Sloc := Sloc (Call); | |
2399 | ||
2400 | -- Accept alternative | |
2401 | ||
2402 | if Is_Accept_Alternative_Proc (Subp_Id) then | |
2403 | Output_Accept_Alternative (Subp_Id); | |
2404 | ||
2405 | -- Adjustment | |
2406 | ||
2407 | elsif Is_TSS (Subp_Id, TSS_Deep_Adjust) then | |
2408 | Output_Type_Actions (Subp_Id, "adjustment"); | |
2409 | ||
2410 | -- Default_Initial_Condition | |
2411 | ||
2412 | elsif Is_Default_Initial_Condition_Proc (Subp_Id) then | |
2413 | Output_Verification_Call | |
2414 | (Pred => "Default_Initial_Condition", | |
2415 | Id => First_Formal_Type (Subp_Id), | |
2416 | Id_Kind => "type"); | |
2417 | ||
2418 | -- Entries | |
2419 | ||
2420 | elsif Is_Protected_Entry (Subp_Id) then | |
2421 | Output_Call (Subp_Id, "entry"); | |
2422 | ||
2423 | -- Task entry calls are never processed because the entry being | |
2424 | -- invoked does not have a corresponding "body", it has a select. A | |
2425 | -- task entry call appears in the stack of active scenarios for the | |
2426 | -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and | |
2427 | -- nothing more. | |
2428 | ||
2429 | elsif Is_Task_Entry (Subp_Id) then | |
2430 | null; | |
2431 | ||
2432 | -- Finalization | |
2433 | ||
2434 | elsif Is_TSS (Subp_Id, TSS_Deep_Finalize) then | |
2435 | Output_Type_Actions (Subp_Id, "finalization"); | |
2436 | ||
2437 | -- Calls to _Finalizer procedures must not appear in the output | |
2438 | -- because this creates confusing noise. | |
2439 | ||
2440 | elsif Is_Finalizer_Proc (Subp_Id) then | |
2441 | null; | |
2442 | ||
2443 | -- Initial_Condition | |
2444 | ||
2445 | elsif Is_Initial_Condition_Proc (Subp_Id) then | |
2446 | Output_Verification_Call | |
2447 | (Pred => "Initial_Condition", | |
2448 | Id => Find_Enclosing_Scope (Call), | |
2449 | Id_Kind => "package"); | |
2450 | ||
2451 | -- Initialization | |
2452 | ||
2453 | elsif Is_Init_Proc (Subp_Id) | |
2454 | or else Is_TSS (Subp_Id, TSS_Deep_Initialize) | |
2455 | then | |
2456 | Output_Type_Actions (Subp_Id, "initialization"); | |
2457 | ||
2458 | -- Invariant | |
2459 | ||
2460 | elsif Is_Invariant_Proc (Subp_Id) then | |
2461 | Output_Verification_Call | |
2462 | (Pred => "invariants", | |
2463 | Id => First_Formal_Type (Subp_Id), | |
2464 | Id_Kind => "type"); | |
2465 | ||
2466 | -- Partial invariant calls must not appear in the output because this | |
2467 | -- creates confusing noise. Note that a partial invariant is always | |
2468 | -- invoked by the "full" invariant which is already placed on the | |
2469 | -- stack. | |
2470 | ||
2471 | elsif Is_Partial_Invariant_Proc (Subp_Id) then | |
2472 | null; | |
2473 | ||
2474 | -- _Postconditions | |
2475 | ||
2476 | elsif Is_Postconditions_Proc (Subp_Id) then | |
2477 | Output_Verification_Call | |
2478 | (Pred => "postconditions", | |
2479 | Id => Find_Enclosing_Scope (Call), | |
2480 | Id_Kind => "subprogram"); | |
2481 | ||
2482 | -- Subprograms must come last because some of the previous cases fall | |
2483 | -- under this category. | |
2484 | ||
2485 | elsif Ekind (Subp_Id) = E_Function then | |
2486 | Output_Call (Subp_Id, "function"); | |
2487 | ||
2488 | elsif Ekind (Subp_Id) = E_Procedure then | |
2489 | Output_Call (Subp_Id, "procedure"); | |
2490 | ||
2491 | else | |
2492 | pragma Assert (False); | |
2493 | return; | |
2494 | end if; | |
2495 | end Output_Call; | |
2496 | ||
2497 | ------------------- | |
2498 | -- Output_Header -- | |
2499 | ------------------- | |
2500 | ||
2501 | procedure Output_Header (Error_Nod : Node_Id) is | |
2502 | Unit_Id : constant Entity_Id := Find_Top_Unit (Root_Scenario); | |
2503 | ||
2504 | begin | |
2505 | if Ekind (Unit_Id) = E_Package then | |
2506 | Error_Msg_NE ("\\ spec of unit & elaborated", Error_Nod, Unit_Id); | |
2507 | ||
2508 | elsif Ekind (Unit_Id) = E_Package_Body then | |
2509 | Error_Msg_NE ("\\ body of unit & elaborated", Error_Nod, Unit_Id); | |
2510 | ||
2511 | else | |
2512 | Error_Msg_NE ("\\ in body of unit &", Error_Nod, Unit_Id); | |
2513 | end if; | |
2514 | end Output_Header; | |
2515 | ||
2516 | -------------------------- | |
2517 | -- Output_Instantiation -- | |
2518 | -------------------------- | |
2519 | ||
2520 | procedure Output_Instantiation | |
2521 | (Inst : Node_Id; | |
2522 | Inst_Rep : Scenario_Rep_Id; | |
2523 | Error_Nod : Node_Id) | |
2524 | is | |
2525 | procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String); | |
2526 | pragma Inline (Output_Instantiation); | |
2527 | -- Emit a specific diagnostic message concerning an instantiation of | |
2528 | -- generic unit Gen_Id. Kind denotes the kind of the instantiation. | |
2529 | ||
2530 | -------------------------- | |
2531 | -- Output_Instantiation -- | |
2532 | -------------------------- | |
2533 | ||
2534 | procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String) is | |
2535 | begin | |
2536 | Error_Msg_NE | |
2537 | ("\\ " & Kind & " & instantiated as & #", Error_Nod, Gen_Id); | |
2538 | end Output_Instantiation; | |
2539 | ||
2540 | -- Local variables | |
2541 | ||
2542 | Gen_Id : constant Entity_Id := Target (Inst_Rep); | |
2543 | ||
2544 | -- Start of processing for Output_Instantiation | |
2545 | ||
2546 | begin | |
2547 | Error_Msg_Node_2 := Defining_Entity (Inst); | |
2548 | Error_Msg_Sloc := Sloc (Inst); | |
2549 | ||
2550 | if Nkind (Inst) = N_Function_Instantiation then | |
2551 | Output_Instantiation (Gen_Id, "function"); | |
2552 | ||
2553 | elsif Nkind (Inst) = N_Package_Instantiation then | |
2554 | Output_Instantiation (Gen_Id, "package"); | |
2555 | ||
2556 | elsif Nkind (Inst) = N_Procedure_Instantiation then | |
2557 | Output_Instantiation (Gen_Id, "procedure"); | |
2558 | ||
2559 | else | |
2560 | pragma Assert (False); | |
2561 | return; | |
2562 | end if; | |
2563 | end Output_Instantiation; | |
2564 | ||
2565 | --------------------------------- | |
2566 | -- Output_Refined_State_Pragma -- | |
2567 | --------------------------------- | |
2568 | ||
2569 | procedure Output_Refined_State_Pragma | |
2570 | (Prag : Node_Id; | |
2571 | Prag_Rep : Scenario_Rep_Id; | |
2572 | Error_Nod : Node_Id) | |
2573 | is | |
2574 | pragma Unreferenced (Prag_Rep); | |
2575 | ||
2576 | begin | |
2577 | Error_Msg_Sloc := Sloc (Prag); | |
2578 | Error_Msg_N ("\\ refinement constituents read #", Error_Nod); | |
2579 | end Output_Refined_State_Pragma; | |
2580 | ||
2581 | ---------------------------- | |
2582 | -- Output_Task_Activation -- | |
2583 | ---------------------------- | |
2584 | ||
2585 | procedure Output_Task_Activation | |
2586 | (Call : Node_Id; | |
2587 | Call_Rep : Scenario_Rep_Id; | |
2588 | Error_Nod : Node_Id) | |
2589 | is | |
2590 | pragma Unreferenced (Call_Rep); | |
2591 | ||
2592 | function Find_Activator return Entity_Id; | |
2593 | -- Find the nearest enclosing construct which houses call Call | |
2594 | ||
2595 | -------------------- | |
2596 | -- Find_Activator -- | |
2597 | -------------------- | |
2598 | ||
2599 | function Find_Activator return Entity_Id is | |
2600 | Par : Node_Id; | |
2601 | ||
2602 | begin | |
2603 | -- Climb the parent chain looking for a package [body] or a | |
2604 | -- construct with a statement sequence. | |
2605 | ||
2606 | Par := Parent (Call); | |
2607 | while Present (Par) loop | |
2608 | if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then | |
2609 | return Defining_Entity (Par); | |
2610 | ||
2611 | elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then | |
2612 | return Defining_Entity (Parent (Par)); | |
2613 | end if; | |
2614 | ||
2615 | Par := Parent (Par); | |
2616 | end loop; | |
2617 | ||
2618 | return Empty; | |
2619 | end Find_Activator; | |
2620 | ||
2621 | -- Local variables | |
2622 | ||
2623 | Activator : constant Entity_Id := Find_Activator; | |
2624 | ||
2625 | -- Start of processing for Output_Task_Activation | |
2626 | ||
2627 | begin | |
2628 | pragma Assert (Present (Activator)); | |
2629 | ||
2630 | Error_Msg_NE ("\\ local tasks of & activated", Error_Nod, Activator); | |
2631 | end Output_Task_Activation; | |
2632 | ||
2633 | -------------------------------- | |
2634 | -- Output_Variable_Assignment -- | |
2635 | -------------------------------- | |
2636 | ||
2637 | procedure Output_Variable_Assignment | |
2638 | (Asmt : Node_Id; | |
2639 | Asmt_Rep : Scenario_Rep_Id; | |
2640 | Error_Nod : Node_Id) | |
2641 | is | |
2642 | Var_Id : constant Entity_Id := Target (Asmt_Rep); | |
2643 | ||
2644 | begin | |
2645 | Error_Msg_Sloc := Sloc (Asmt); | |
2646 | Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id); | |
2647 | end Output_Variable_Assignment; | |
2648 | ||
2649 | ------------------------------- | |
2650 | -- Output_Variable_Reference -- | |
2651 | ------------------------------- | |
2652 | ||
2653 | procedure Output_Variable_Reference | |
2654 | (Ref : Node_Id; | |
2655 | Ref_Rep : Scenario_Rep_Id; | |
2656 | Error_Nod : Node_Id) | |
2657 | is | |
2658 | Var_Id : constant Entity_Id := Target (Ref_Rep); | |
2659 | ||
2660 | begin | |
2661 | Error_Msg_Sloc := Sloc (Ref); | |
2662 | Error_Msg_NE ("\\ variable & read #", Error_Nod, Var_Id); | |
2663 | end Output_Variable_Reference; | |
2664 | ||
2665 | ------------------------- | |
2666 | -- Pop_Active_Scenario -- | |
2667 | ------------------------- | |
2668 | ||
2669 | procedure Pop_Active_Scenario (N : Node_Id) is | |
2670 | package Scenarios renames Active_Scenario_Stack; | |
2671 | Top : Node_Id renames Scenarios.Table (Scenarios.Last); | |
2672 | ||
2673 | begin | |
2674 | pragma Assert (Top = N); | |
2675 | Scenarios.Decrement_Last; | |
2676 | end Pop_Active_Scenario; | |
2677 | ||
2678 | -------------------------- | |
2679 | -- Push_Active_Scenario -- | |
2680 | -------------------------- | |
2681 | ||
2682 | procedure Push_Active_Scenario (N : Node_Id) is | |
2683 | begin | |
2684 | Active_Scenario_Stack.Append (N); | |
2685 | end Push_Active_Scenario; | |
2686 | ||
2687 | ------------------- | |
2688 | -- Root_Scenario -- | |
2689 | ------------------- | |
2690 | ||
2691 | function Root_Scenario return Node_Id is | |
2692 | package Scenarios renames Active_Scenario_Stack; | |
2693 | ||
2694 | begin | |
2695 | -- Ensure that the scenario stack has at least one active scenario in | |
2696 | -- it. The one at the bottom (index First) is the root scenario. | |
2697 | ||
2698 | pragma Assert (Scenarios.Last >= Scenarios.First); | |
2699 | return Scenarios.Table (Scenarios.First); | |
2700 | end Root_Scenario; | |
2701 | end Active_Scenarios; | |
2702 | ||
2703 | -------------------------- | |
2704 | -- Activation_Processor -- | |
2705 | -------------------------- | |
2706 | ||
2707 | package body Activation_Processor is | |
2708 | ||
2709 | ------------------------ | |
2710 | -- Process_Activation -- | |
2711 | ------------------------ | |
2712 | ||
2713 | procedure Process_Activation | |
2714 | (Call : Node_Id; | |
2715 | Call_Rep : Scenario_Rep_Id; | |
2716 | Processor : Activation_Processor_Ptr; | |
2717 | In_State : Processing_In_State) | |
2718 | is | |
2719 | procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id); | |
2720 | pragma Inline (Process_Task_Object); | |
2721 | -- Invoke Processor for task object Obj_Id of type Typ | |
2722 | ||
2723 | procedure Process_Task_Objects | |
2724 | (Task_Objs : NE_List.Doubly_Linked_List); | |
2725 | pragma Inline (Process_Task_Objects); | |
2726 | -- Invoke Processor for all task objects found in list Task_Objs | |
2727 | ||
2728 | procedure Traverse_List | |
2729 | (List : List_Id; | |
2730 | Task_Objs : NE_List.Doubly_Linked_List); | |
2731 | pragma Inline (Traverse_List); | |
2732 | -- Traverse declarative or statement list List while searching for | |
2733 | -- objects of a task type, or containing task components. If such an | |
2734 | -- object is found, first save it in list Task_Objs and then invoke | |
2735 | -- Processor on it. | |
2736 | ||
2737 | ------------------------- | |
2738 | -- Process_Task_Object -- | |
2739 | ------------------------- | |
2740 | ||
2741 | procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id) is | |
2742 | Root_Typ : constant Entity_Id := | |
2743 | Non_Private_View (Root_Type (Typ)); | |
2744 | Comp_Id : Entity_Id; | |
2745 | Obj_Rep : Target_Rep_Id; | |
2746 | Root_Rep : Target_Rep_Id; | |
2747 | ||
2748 | New_In_State : Processing_In_State := In_State; | |
2749 | -- Each step of the Processing phase constitutes a new state | |
2750 | ||
2751 | begin | |
2752 | if Is_Task_Type (Typ) then | |
2753 | Obj_Rep := Target_Representation_Of (Obj_Id, New_In_State); | |
2754 | Root_Rep := Target_Representation_Of (Root_Typ, New_In_State); | |
2755 | ||
2756 | -- Warnings are suppressed when a prior scenario is already in | |
2757 | -- that mode, or when the object, activation call, or task type | |
2758 | -- have warnings suppressed. Update the state of the Processing | |
2759 | -- phase to reflect this. | |
2760 | ||
2761 | New_In_State.Suppress_Warnings := | |
2762 | New_In_State.Suppress_Warnings | |
2763 | or else not Elaboration_Warnings_OK (Call_Rep) | |
2764 | or else not Elaboration_Warnings_OK (Obj_Rep) | |
2765 | or else not Elaboration_Warnings_OK (Root_Rep); | |
2766 | ||
2767 | -- Update the state of the Processing phase to indicate that | |
2768 | -- any further traversal is now within a task body. | |
2769 | ||
2770 | New_In_State.Within_Task_Body := True; | |
2771 | ||
2772 | -- Associate the current task type with the activation call | |
2773 | ||
2774 | Set_Activated_Task_Type (Call_Rep, Root_Typ); | |
2775 | ||
2776 | -- Process the activation of the current task object by calling | |
2777 | -- the supplied processor. | |
2778 | ||
2779 | Processor.all | |
2780 | (Call => Call, | |
2781 | Call_Rep => Call_Rep, | |
2782 | Obj_Id => Obj_Id, | |
2783 | Obj_Rep => Obj_Rep, | |
2784 | Task_Typ => Root_Typ, | |
2785 | Task_Rep => Root_Rep, | |
2786 | In_State => New_In_State); | |
2787 | ||
2788 | -- Reset the association between the current task and the | |
2789 | -- activtion call. | |
2790 | ||
2791 | Set_Activated_Task_Type (Call_Rep, Empty); | |
2792 | ||
2793 | -- Examine the component type when the object is an array | |
2794 | ||
2795 | elsif Is_Array_Type (Typ) and then Has_Task (Root_Typ) then | |
2796 | Process_Task_Object | |
2797 | (Obj_Id => Obj_Id, | |
2798 | Typ => Component_Type (Typ)); | |
2799 | ||
2800 | -- Examine individual component types when the object is a record | |
2801 | ||
2802 | elsif Is_Record_Type (Typ) and then Has_Task (Root_Typ) then | |
2803 | Comp_Id := First_Component (Typ); | |
2804 | while Present (Comp_Id) loop | |
2805 | Process_Task_Object | |
2806 | (Obj_Id => Obj_Id, | |
2807 | Typ => Etype (Comp_Id)); | |
2808 | ||
2809 | Next_Component (Comp_Id); | |
2810 | end loop; | |
2811 | end if; | |
2812 | end Process_Task_Object; | |
2813 | ||
2814 | -------------------------- | |
2815 | -- Process_Task_Objects -- | |
2816 | -------------------------- | |
2817 | ||
2818 | procedure Process_Task_Objects | |
2819 | (Task_Objs : NE_List.Doubly_Linked_List) | |
2820 | is | |
2821 | Iter : NE_List.Iterator; | |
2822 | Obj_Id : Entity_Id; | |
2823 | ||
2824 | begin | |
2825 | Iter := NE_List.Iterate (Task_Objs); | |
2826 | while NE_List.Has_Next (Iter) loop | |
2827 | NE_List.Next (Iter, Obj_Id); | |
2828 | ||
2829 | Process_Task_Object | |
2830 | (Obj_Id => Obj_Id, | |
2831 | Typ => Etype (Obj_Id)); | |
2832 | end loop; | |
2833 | end Process_Task_Objects; | |
2834 | ||
2835 | ------------------- | |
2836 | -- Traverse_List -- | |
2837 | ------------------- | |
2838 | ||
2839 | procedure Traverse_List | |
2840 | (List : List_Id; | |
2841 | Task_Objs : NE_List.Doubly_Linked_List) | |
2842 | is | |
2843 | Item : Node_Id; | |
2844 | Item_Id : Entity_Id; | |
2845 | Item_Typ : Entity_Id; | |
2846 | ||
2847 | begin | |
2848 | -- Examine the contents of the list looking for an object | |
2849 | -- declaration of a task type or one that contains a task | |
2850 | -- within. | |
2851 | ||
2852 | Item := First (List); | |
2853 | while Present (Item) loop | |
2854 | if Nkind (Item) = N_Object_Declaration then | |
2855 | Item_Id := Defining_Entity (Item); | |
2856 | Item_Typ := Etype (Item_Id); | |
2857 | ||
2858 | if Has_Task (Item_Typ) then | |
2859 | ||
2860 | -- The object is either of a task type, or contains a | |
2861 | -- task component. Save it in the list of task objects | |
2862 | -- associated with the activation call. | |
2863 | ||
2864 | NE_List.Append (Task_Objs, Item_Id); | |
2865 | ||
2866 | Process_Task_Object | |
2867 | (Obj_Id => Item_Id, | |
2868 | Typ => Item_Typ); | |
2869 | end if; | |
2870 | end if; | |
2871 | ||
2872 | Next (Item); | |
2873 | end loop; | |
2874 | end Traverse_List; | |
2875 | ||
2876 | -- Local variables | |
2877 | ||
2878 | Context : Node_Id; | |
2879 | Spec : Node_Id; | |
2880 | Task_Objs : NE_List.Doubly_Linked_List; | |
2881 | ||
2882 | -- Start of processing for Process_Activation | |
2883 | ||
2884 | begin | |
2885 | -- Nothing to do when the activation is a guaranteed ABE | |
2886 | ||
2887 | if Is_Known_Guaranteed_ABE (Call) then | |
2888 | return; | |
2889 | end if; | |
2890 | ||
2891 | Task_Objs := Activated_Task_Objects (Call_Rep); | |
2892 | ||
2893 | -- The activation call has been processed at least once, and all | |
2894 | -- task objects have already been collected. Directly process the | |
2895 | -- objects without having to reexamine the context of the call. | |
2896 | ||
2897 | if NE_List.Present (Task_Objs) then | |
2898 | Process_Task_Objects (Task_Objs); | |
2899 | ||
2900 | -- Otherwise the activation call is being processed for the first | |
2901 | -- time. Collect all task objects in case the call is reprocessed | |
2902 | -- multiple times. | |
2903 | ||
2904 | else | |
2905 | Task_Objs := NE_List.Create; | |
2906 | Set_Activated_Task_Objects (Call_Rep, Task_Objs); | |
2907 | ||
2908 | -- Find the context of the activation call where all task objects | |
2909 | -- being activated are declared. This is usually the parent of the | |
2910 | -- call. | |
2911 | ||
2912 | Context := Parent (Call); | |
2913 | ||
2914 | -- Handle the case where the activation call appears within the | |
2915 | -- handled statements of a block or a body. | |
2916 | ||
2917 | if Nkind (Context) = N_Handled_Sequence_Of_Statements then | |
2918 | Context := Parent (Context); | |
2919 | end if; | |
2920 | ||
2921 | -- Process all task objects in both the spec and body when the | |
2922 | -- activation call appears in a package body. | |
2923 | ||
2924 | if Nkind (Context) = N_Package_Body then | |
2925 | Spec := | |
2926 | Specification | |
2927 | (Unit_Declaration_Node (Corresponding_Spec (Context))); | |
2928 | ||
2929 | Traverse_List | |
2930 | (List => Visible_Declarations (Spec), | |
2931 | Task_Objs => Task_Objs); | |
2932 | ||
2933 | Traverse_List | |
2934 | (List => Private_Declarations (Spec), | |
2935 | Task_Objs => Task_Objs); | |
2936 | ||
2937 | Traverse_List | |
2938 | (List => Declarations (Context), | |
2939 | Task_Objs => Task_Objs); | |
2940 | ||
2941 | -- Process all task objects in the spec when the activation call | |
2942 | -- appears in a package spec. | |
2943 | ||
2944 | elsif Nkind (Context) = N_Package_Specification then | |
2945 | Traverse_List | |
2946 | (List => Visible_Declarations (Context), | |
2947 | Task_Objs => Task_Objs); | |
2948 | ||
2949 | Traverse_List | |
2950 | (List => Private_Declarations (Context), | |
2951 | Task_Objs => Task_Objs); | |
2952 | ||
2953 | -- Otherwise the context must be a block or a body. Process all | |
2954 | -- task objects found in the declarations. | |
2955 | ||
2956 | else | |
2957 | pragma Assert (Nkind_In (Context, N_Block_Statement, | |
2958 | N_Entry_Body, | |
2959 | N_Protected_Body, | |
2960 | N_Subprogram_Body, | |
2961 | N_Task_Body)); | |
2962 | ||
2963 | Traverse_List | |
2964 | (List => Declarations (Context), | |
2965 | Task_Objs => Task_Objs); | |
2966 | end if; | |
2967 | end if; | |
2968 | end Process_Activation; | |
2969 | end Activation_Processor; | |
2970 | ||
2971 | ----------------------- | |
2972 | -- Assignment_Target -- | |
2973 | ----------------------- | |
2974 | ||
2975 | function Assignment_Target (Asmt : Node_Id) return Node_Id is | |
2976 | Nam : Node_Id; | |
2977 | ||
2978 | begin | |
2979 | Nam := Name (Asmt); | |
2980 | ||
2981 | -- When the name denotes an array or record component, find the whole | |
2982 | -- object. | |
2983 | ||
2984 | while Nkind_In (Nam, N_Explicit_Dereference, | |
2985 | N_Indexed_Component, | |
2986 | N_Selected_Component, | |
2987 | N_Slice) | |
2988 | loop | |
2989 | Nam := Prefix (Nam); | |
2990 | end loop; | |
2991 | ||
2992 | return Nam; | |
2993 | end Assignment_Target; | |
2994 | ||
2995 | -------------------- | |
2996 | -- Body_Processor -- | |
2997 | -------------------- | |
2998 | ||
2999 | package body Body_Processor is | |
3000 | ||
3001 | --------------------- | |
3002 | -- Data structures -- | |
3003 | --------------------- | |
3004 | ||
3005 | -- The following map relates scenario lists to subprogram bodies | |
3006 | ||
3007 | Nested_Scenarios_Map : NE_List_Map.Dynamic_Hash_Table := NE_List_Map.Nil; | |
3008 | ||
3009 | -- The following set contains all subprogram bodies that have been | |
3010 | -- processed by routine Traverse_Body. | |
3011 | ||
3012 | Traversed_Bodies_Set : NE_Set.Membership_Set := NE_Set.Nil; | |
3013 | ||
3014 | ----------------------- | |
3015 | -- Local subprograms -- | |
3016 | ----------------------- | |
3017 | ||
3018 | function Is_Traversed_Body (N : Node_Id) return Boolean; | |
3019 | pragma Inline (Is_Traversed_Body); | |
3020 | -- Determine whether subprogram body N has already been traversed | |
3021 | ||
3022 | function Nested_Scenarios | |
3023 | (N : Node_Id) return NE_List.Doubly_Linked_List; | |
3024 | pragma Inline (Nested_Scenarios); | |
3025 | -- Obtain the list of scenarios associated with subprogram body N | |
3026 | ||
3027 | procedure Set_Is_Traversed_Body | |
3028 | (N : Node_Id; | |
3029 | Val : Boolean := True); | |
3030 | pragma Inline (Set_Is_Traversed_Body); | |
3031 | -- Mark subprogram body N as traversed depending on value Val | |
3032 | ||
3033 | procedure Set_Nested_Scenarios | |
3034 | (N : Node_Id; | |
3035 | Scenarios : NE_List.Doubly_Linked_List); | |
3036 | pragma Inline (Set_Nested_Scenarios); | |
3037 | -- Associate scenario list Scenarios with subprogram body N | |
3038 | ||
3039 | ----------------------------- | |
3040 | -- Finalize_Body_Processor -- | |
3041 | ----------------------------- | |
3042 | ||
3043 | procedure Finalize_Body_Processor is | |
3044 | begin | |
3045 | NE_List_Map.Destroy (Nested_Scenarios_Map); | |
3046 | NE_Set.Destroy (Traversed_Bodies_Set); | |
3047 | end Finalize_Body_Processor; | |
3048 | ||
3049 | ------------------------------- | |
3050 | -- Initialize_Body_Processor -- | |
3051 | ------------------------------- | |
3052 | ||
3053 | procedure Initialize_Body_Processor is | |
3054 | begin | |
3055 | Nested_Scenarios_Map := NE_List_Map.Create (250); | |
3056 | Traversed_Bodies_Set := NE_Set.Create (250); | |
3057 | end Initialize_Body_Processor; | |
3058 | ||
3059 | ----------------------- | |
3060 | -- Is_Traversed_Body -- | |
3061 | ----------------------- | |
3062 | ||
3063 | function Is_Traversed_Body (N : Node_Id) return Boolean is | |
3064 | pragma Assert (Present (N)); | |
3065 | begin | |
3066 | return NE_Set.Contains (Traversed_Bodies_Set, N); | |
3067 | end Is_Traversed_Body; | |
3068 | ||
3069 | ---------------------- | |
3070 | -- Nested_Scenarios -- | |
3071 | ---------------------- | |
3072 | ||
3073 | function Nested_Scenarios | |
3074 | (N : Node_Id) return NE_List.Doubly_Linked_List | |
3075 | is | |
3076 | pragma Assert (Present (N)); | |
3077 | pragma Assert (Nkind (N) = N_Subprogram_Body); | |
3078 | ||
3079 | begin | |
3080 | return NE_List_Map.Get (Nested_Scenarios_Map, N); | |
3081 | end Nested_Scenarios; | |
3082 | ||
3083 | ---------------------------- | |
3084 | -- Reset_Traversed_Bodies -- | |
3085 | ---------------------------- | |
3086 | ||
3087 | procedure Reset_Traversed_Bodies is | |
3088 | begin | |
3089 | NE_Set.Reset (Traversed_Bodies_Set); | |
3090 | end Reset_Traversed_Bodies; | |
3091 | ||
3092 | --------------------------- | |
3093 | -- Set_Is_Traversed_Body -- | |
3094 | --------------------------- | |
3095 | ||
3096 | procedure Set_Is_Traversed_Body | |
3097 | (N : Node_Id; | |
3098 | Val : Boolean := True) | |
3099 | is | |
3100 | pragma Assert (Present (N)); | |
3101 | ||
3102 | begin | |
3103 | if Val then | |
3104 | NE_Set.Insert (Traversed_Bodies_Set, N); | |
3105 | else | |
3106 | NE_Set.Delete (Traversed_Bodies_Set, N); | |
3107 | end if; | |
3108 | end Set_Is_Traversed_Body; | |
3109 | ||
3110 | -------------------------- | |
3111 | -- Set_Nested_Scenarios -- | |
3112 | -------------------------- | |
3113 | ||
3114 | procedure Set_Nested_Scenarios | |
3115 | (N : Node_Id; | |
3116 | Scenarios : NE_List.Doubly_Linked_List) | |
3117 | is | |
3118 | pragma Assert (Present (N)); | |
3119 | begin | |
3120 | NE_List_Map.Put (Nested_Scenarios_Map, N, Scenarios); | |
3121 | end Set_Nested_Scenarios; | |
3122 | ||
3123 | ------------------- | |
3124 | -- Traverse_Body -- | |
3125 | ------------------- | |
3126 | ||
3127 | procedure Traverse_Body | |
3128 | (N : Node_Id; | |
3129 | Requires_Processing : Scenario_Predicate_Ptr; | |
3130 | Processor : Scenario_Processor_Ptr; | |
3131 | In_State : Processing_In_State) | |
3132 | is | |
3133 | Scenarios : NE_List.Doubly_Linked_List := NE_List.Nil; | |
3134 | -- The list of scenarios that appear within the declarations and | |
3135 | -- statement of subprogram body N. The variable is intentionally | |
3136 | -- global because Is_Potential_Scenario needs to populate it. | |
3137 | ||
3138 | function In_Task_Body (Nod : Node_Id) return Boolean; | |
3139 | pragma Inline (In_Task_Body); | |
3140 | -- Determine whether arbitrary node Nod appears within a task body | |
3141 | ||
3142 | function Is_Synchronous_Suspension_Call | |
3143 | (Nod : Node_Id) return Boolean; | |
3144 | pragma Inline (Is_Synchronous_Suspension_Call); | |
3145 | -- Determine whether arbitrary node Nod denotes a call to one of | |
3146 | -- these routines: | |
3147 | -- | |
3148 | -- Ada.Synchronous_Barriers.Wait_For_Release | |
3149 | -- Ada.Synchronous_Task_Control.Suspend_Until_True | |
3150 | ||
3151 | procedure Traverse_Collected_Scenarios; | |
3152 | pragma Inline (Traverse_Collected_Scenarios); | |
3153 | -- Traverse the already collected scenarios in list Scenarios by | |
3154 | -- invoking Processor on each individual one. | |
3155 | ||
3156 | procedure Traverse_List (List : List_Id); | |
3157 | pragma Inline (Traverse_List); | |
3158 | -- Invoke Traverse_Potential_Scenarios on each node in list List | |
3159 | ||
3160 | function Traverse_Potential_Scenario | |
3161 | (Scen : Node_Id) return Traverse_Result; | |
3162 | pragma Inline (Traverse_Potential_Scenario); | |
3163 | -- Determine whether arbitrary node Scen is a suitable scenario using | |
3164 | -- predicate Is_Scenario and traverse it by invoking Processor on it. | |
3165 | ||
3166 | procedure Traverse_Potential_Scenarios is | |
3167 | new Traverse_Proc (Traverse_Potential_Scenario); | |
3168 | ||
3169 | ------------------ | |
3170 | -- In_Task_Body -- | |
3171 | ------------------ | |
3172 | ||
3173 | function In_Task_Body (Nod : Node_Id) return Boolean is | |
3174 | Par : Node_Id; | |
3175 | ||
3176 | begin | |
3177 | -- Climb the parent chain looking for a task body [procedure] | |
3178 | ||
3179 | Par := Nod; | |
3180 | while Present (Par) loop | |
3181 | if Nkind (Par) = N_Task_Body then | |
3182 | return True; | |
3183 | ||
3184 | elsif Nkind (Par) = N_Subprogram_Body | |
3185 | and then Is_Task_Body_Procedure (Par) | |
3186 | then | |
3187 | return True; | |
3188 | ||
3189 | -- Prevent the search from going too far. Note that this test | |
3190 | -- shares nodes with the two cases above, and must come last. | |
3191 | ||
3192 | elsif Is_Body_Or_Package_Declaration (Par) then | |
3193 | return False; | |
3194 | end if; | |
3195 | ||
3196 | Par := Parent (Par); | |
3197 | end loop; | |
3198 | ||
3199 | return False; | |
3200 | end In_Task_Body; | |
3201 | ||
3202 | ------------------------------------ | |
3203 | -- Is_Synchronous_Suspension_Call -- | |
3204 | ------------------------------------ | |
3205 | ||
3206 | function Is_Synchronous_Suspension_Call | |
3207 | (Nod : Node_Id) return Boolean | |
3208 | is | |
3209 | Subp_Id : Entity_Id; | |
3210 | ||
3211 | begin | |
3212 | -- To qualify, the call must invoke one of the runtime routines | |
3213 | -- which perform synchronous suspension. | |
3214 | ||
3215 | if Is_Suitable_Call (Nod) then | |
3216 | Subp_Id := Target (Nod); | |
3217 | ||
3218 | return | |
3219 | Is_RTE (Subp_Id, RE_Suspend_Until_True) | |
3220 | or else | |
3221 | Is_RTE (Subp_Id, RE_Wait_For_Release); | |
3222 | end if; | |
3223 | ||
3224 | return False; | |
3225 | end Is_Synchronous_Suspension_Call; | |
3226 | ||
3227 | ---------------------------------- | |
3228 | -- Traverse_Collected_Scenarios -- | |
3229 | ---------------------------------- | |
3230 | ||
3231 | procedure Traverse_Collected_Scenarios is | |
3232 | Iter : NE_List.Iterator; | |
3233 | Scen : Node_Id; | |
3234 | ||
3235 | begin | |
3236 | Iter := NE_List.Iterate (Scenarios); | |
3237 | while NE_List.Has_Next (Iter) loop | |
3238 | NE_List.Next (Iter, Scen); | |
3239 | ||
3240 | -- The current scenario satisfies the input predicate, process | |
3241 | -- it. | |
3242 | ||
3243 | if Requires_Processing.all (Scen) then | |
3244 | Processor.all (Scen, In_State); | |
3245 | end if; | |
3246 | end loop; | |
3247 | end Traverse_Collected_Scenarios; | |
3248 | ||
3249 | ------------------- | |
3250 | -- Traverse_List -- | |
3251 | ------------------- | |
3252 | ||
3253 | procedure Traverse_List (List : List_Id) is | |
3254 | Scen : Node_Id; | |
3255 | ||
3256 | begin | |
3257 | Scen := First (List); | |
3258 | while Present (Scen) loop | |
3259 | Traverse_Potential_Scenarios (Scen); | |
3260 | Next (Scen); | |
3261 | end loop; | |
3262 | end Traverse_List; | |
3263 | ||
3264 | --------------------------------- | |
3265 | -- Traverse_Potential_Scenario -- | |
3266 | --------------------------------- | |
3267 | ||
3268 | function Traverse_Potential_Scenario | |
3269 | (Scen : Node_Id) return Traverse_Result | |
3270 | is | |
3271 | begin | |
3272 | -- Special cases | |
3273 | ||
3274 | -- Skip constructs which do not have elaboration of their own and | |
3275 | -- need to be elaborated by other means such as invocation, task | |
3276 | -- activation, etc. | |
3277 | ||
3278 | if Is_Non_Library_Level_Encapsulator (Scen) then | |
3279 | return Skip; | |
3280 | ||
3281 | -- Terminate the traversal of a task body when encountering an | |
3282 | -- accept or select statement, and | |
3283 | -- | |
3284 | -- * Entry calls during elaboration are not allowed. In this | |
3285 | -- case the accept or select statement will cause the task | |
3286 | -- to block at elaboration time because there are no entry | |
3287 | -- calls to unblock it. | |
3288 | -- | |
3289 | -- or | |
3290 | -- | |
3291 | -- * Switch -gnatd_a (stop elaboration checks on accept or | |
3292 | -- select statement) is in effect. | |
3293 | ||
3294 | elsif (Debug_Flag_Underscore_A | |
3295 | or else Restriction_Active | |
3296 | (No_Entry_Calls_In_Elaboration_Code)) | |
3297 | and then Nkind_In (Original_Node (Scen), N_Accept_Statement, | |
3298 | N_Selective_Accept) | |
3299 | then | |
3300 | return Abandon; | |
3301 | ||
3302 | -- Terminate the traversal of a task body when encountering a | |
3303 | -- suspension call, and | |
3304 | -- | |
3305 | -- * Entry calls during elaboration are not allowed. In this | |
3306 | -- case the suspension call emulates an entry call and will | |
3307 | -- cause the task to block at elaboration time. | |
3308 | -- | |
3309 | -- or | |
3310 | -- | |
3311 | -- * Switch -gnatd_s (stop elaboration checks on synchronous | |
3312 | -- suspension) is in effect. | |
3313 | -- | |
3314 | -- Note that the guard should not be checking the state of flag | |
3315 | -- Within_Task_Body because only suspension calls which appear | |
3316 | -- immediately within the statements of the task are supported. | |
3317 | -- Flag Within_Task_Body carries over to deeper levels of the | |
3318 | -- traversal. | |
3319 | ||
3320 | elsif (Debug_Flag_Underscore_S | |
3321 | or else Restriction_Active | |
3322 | (No_Entry_Calls_In_Elaboration_Code)) | |
3323 | and then Is_Synchronous_Suspension_Call (Scen) | |
3324 | and then In_Task_Body (Scen) | |
3325 | then | |
3326 | return Abandon; | |
3327 | ||
3328 | -- Certain nodes carry semantic lists which act as repositories | |
3329 | -- until expansion transforms the node and relocates the contents. | |
3330 | -- Examine these lists in case expansion is disabled. | |
3331 | ||
3332 | elsif Nkind_In (Scen, N_And_Then, N_Or_Else) then | |
3333 | Traverse_List (Actions (Scen)); | |
3334 | ||
3335 | elsif Nkind_In (Scen, N_Elsif_Part, N_Iteration_Scheme) then | |
3336 | Traverse_List (Condition_Actions (Scen)); | |
3337 | ||
3338 | elsif Nkind (Scen) = N_If_Expression then | |
3339 | Traverse_List (Then_Actions (Scen)); | |
3340 | Traverse_List (Else_Actions (Scen)); | |
3341 | ||
3342 | elsif Nkind_In (Scen, N_Component_Association, | |
3343 | N_Iterated_Component_Association) | |
3344 | then | |
3345 | Traverse_List (Loop_Actions (Scen)); | |
3346 | ||
3347 | -- General case | |
3348 | ||
3349 | -- The current node satisfies the input predicate, process it | |
3350 | ||
3351 | elsif Requires_Processing.all (Scen) then | |
3352 | Processor.all (Scen, In_State); | |
3353 | end if; | |
3354 | ||
3355 | -- Save a general scenario regardless of whether it satisfies the | |
3356 | -- input predicate. This allows for quick subsequent traversals of | |
3357 | -- general scenarios, even with different predicates. | |
3358 | ||
3359 | if Is_Suitable_Access_Taken (Scen) | |
3360 | or else Is_Suitable_Call (Scen) | |
3361 | or else Is_Suitable_Instantiation (Scen) | |
3362 | or else Is_Suitable_Variable_Assignment (Scen) | |
3363 | or else Is_Suitable_Variable_Reference (Scen) | |
3364 | then | |
3365 | NE_List.Append (Scenarios, Scen); | |
3366 | end if; | |
3367 | ||
3368 | return OK; | |
3369 | end Traverse_Potential_Scenario; | |
3370 | ||
3371 | -- Start of processing for Traverse_Body | |
3372 | ||
3373 | begin | |
3374 | -- Nothing to do when the traversal is suppressed | |
3375 | ||
3376 | if In_State.Traversal = No_Traversal then | |
3377 | return; | |
3378 | ||
3379 | -- Nothing to do when there is no input | |
3380 | ||
3381 | elsif No (N) then | |
3382 | return; | |
3383 | ||
3384 | -- Nothing to do when the input is not a subprogram body | |
3385 | ||
3386 | elsif Nkind (N) /= N_Subprogram_Body then | |
3387 | return; | |
3388 | ||
3389 | -- Nothing to do if the subprogram body was already traversed | |
3390 | ||
3391 | elsif Is_Traversed_Body (N) then | |
3392 | return; | |
3393 | end if; | |
3394 | ||
3395 | -- Mark the subprogram body as traversed | |
3396 | ||
3397 | Set_Is_Traversed_Body (N); | |
3398 | ||
3399 | Scenarios := Nested_Scenarios (N); | |
3400 | ||
3401 | -- The subprogram body has been traversed at least once, and all | |
3402 | -- scenarios that appear within its declarations and statements | |
3403 | -- have already been collected. Directly retraverse the scenarios | |
3404 | -- without having to retraverse the subprogram body subtree. | |
3405 | ||
3406 | if NE_List.Present (Scenarios) then | |
3407 | Traverse_Collected_Scenarios; | |
3408 | ||
3409 | -- Otherwise the subprogram body is being traversed for the first | |
3410 | -- time. Collect all scenarios that appear within its declarations | |
3411 | -- and statements in case the subprogram body has to be retraversed | |
3412 | -- multiple times. | |
3413 | ||
3414 | else | |
3415 | Scenarios := NE_List.Create; | |
3416 | Set_Nested_Scenarios (N, Scenarios); | |
3417 | ||
3418 | Traverse_List (Declarations (N)); | |
3419 | Traverse_Potential_Scenarios (Handled_Statement_Sequence (N)); | |
3420 | end if; | |
3421 | end Traverse_Body; | |
3422 | end Body_Processor; | |
3423 | ||
3424 | ----------------------- | |
3425 | -- Build_Call_Marker -- | |
3426 | ----------------------- | |
3427 | ||
3428 | procedure Build_Call_Marker (N : Node_Id) is | |
3429 | function In_External_Context | |
3430 | (Call : Node_Id; | |
3431 | Subp_Id : Entity_Id) return Boolean; | |
3432 | pragma Inline (In_External_Context); | |
3433 | -- Determine whether entry, operator, or subprogram Subp_Id is external | |
3434 | -- to call Call which must reside within an instance. | |
3435 | ||
3436 | function In_Premature_Context (Call : Node_Id) return Boolean; | |
3437 | pragma Inline (In_Premature_Context); | |
3438 | -- Determine whether call Call appears within a premature context | |
3439 | ||
3440 | function Is_Default_Expression (Call : Node_Id) return Boolean; | |
3441 | pragma Inline (Is_Default_Expression); | |
3442 | -- Determine whether call Call acts as the expression of a defaulted | |
3443 | -- parameter within a source call. | |
3444 | ||
3445 | function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean; | |
3446 | pragma Inline (Is_Generic_Formal_Subp); | |
3447 | -- Determine whether subprogram Subp_Id denotes a generic formal | |
3448 | -- subprogram which appears in the "prologue" of an instantiation. | |
3449 | ||
3450 | ------------------------- | |
3451 | -- In_External_Context -- | |
3452 | ------------------------- | |
3453 | ||
3454 | function In_External_Context | |
3455 | (Call : Node_Id; | |
3456 | Subp_Id : Entity_Id) return Boolean | |
3457 | is | |
3458 | Spec_Decl : constant Entity_Id := Unit_Declaration_Node (Subp_Id); | |
3459 | ||
3460 | Inst : Node_Id; | |
3461 | Inst_Body : Node_Id; | |
3462 | Inst_Spec : Node_Id; | |
3463 | ||
3464 | begin | |
3465 | Inst := Find_Enclosing_Instance (Call); | |
3466 | ||
3467 | -- The call appears within an instance | |
3468 | ||
3469 | if Present (Inst) then | |
3470 | ||
3471 | -- The call comes from the main unit and the target does not | |
3472 | ||
3473 | if In_Extended_Main_Code_Unit (Call) | |
3474 | and then not In_Extended_Main_Code_Unit (Spec_Decl) | |
3475 | then | |
3476 | return True; | |
3477 | ||
3478 | -- Otherwise the target declaration must not appear within the | |
3479 | -- instance spec or body. | |
3480 | ||
3481 | else | |
3482 | Spec_And_Body_From_Node | |
3483 | (N => Inst, | |
3484 | Spec_Decl => Inst_Spec, | |
3485 | Body_Decl => Inst_Body); | |
3486 | ||
3487 | return not In_Subtree | |
3488 | (N => Spec_Decl, | |
3489 | Root1 => Inst_Spec, | |
3490 | Root2 => Inst_Body); | |
3491 | end if; | |
3492 | end if; | |
3493 | ||
3494 | return False; | |
3495 | end In_External_Context; | |
3496 | ||
3497 | -------------------------- | |
3498 | -- In_Premature_Context -- | |
3499 | -------------------------- | |
3500 | ||
3501 | function In_Premature_Context (Call : Node_Id) return Boolean is | |
3502 | Par : Node_Id; | |
3503 | ||
3504 | begin | |
3505 | -- Climb the parent chain looking for premature contexts | |
3506 | ||
3507 | Par := Parent (Call); | |
3508 | while Present (Par) loop | |
3509 | ||
3510 | -- Aspect specifications and generic associations are premature | |
3511 | -- contexts because nested calls has not been relocated to their | |
3512 | -- final context. | |
3513 | ||
3514 | if Nkind_In (Par, N_Aspect_Specification, | |
3515 | N_Generic_Association) | |
3516 | then | |
3517 | return True; | |
3518 | ||
3519 | -- Prevent the search from going too far | |
3520 | ||
3521 | elsif Is_Body_Or_Package_Declaration (Par) then | |
3522 | exit; | |
3523 | end if; | |
3524 | ||
3525 | Par := Parent (Par); | |
3526 | end loop; | |
3527 | ||
3528 | return False; | |
3529 | end In_Premature_Context; | |
3530 | ||
3531 | --------------------------- | |
3532 | -- Is_Default_Expression -- | |
3533 | --------------------------- | |
3534 | ||
3535 | function Is_Default_Expression (Call : Node_Id) return Boolean is | |
3536 | Outer_Call : constant Node_Id := Parent (Call); | |
3537 | Outer_Nam : Node_Id; | |
3538 | ||
3539 | begin | |
3540 | -- To qualify, the node must appear immediately within a source call | |
3541 | -- which invokes a source target. | |
3542 | ||
3543 | if Nkind_In (Outer_Call, N_Entry_Call_Statement, | |
3544 | N_Function_Call, | |
3545 | N_Procedure_Call_Statement) | |
3546 | and then Comes_From_Source (Outer_Call) | |
3547 | then | |
3548 | Outer_Nam := Call_Name (Outer_Call); | |
3549 | ||
3550 | return | |
3551 | Is_Entity_Name (Outer_Nam) | |
3552 | and then Present (Entity (Outer_Nam)) | |
3553 | and then Is_Subprogram_Or_Entry (Entity (Outer_Nam)) | |
3554 | and then Comes_From_Source (Entity (Outer_Nam)); | |
3555 | end if; | |
3556 | ||
3557 | return False; | |
3558 | end Is_Default_Expression; | |
3559 | ||
3560 | ---------------------------- | |
3561 | -- Is_Generic_Formal_Subp -- | |
3562 | ---------------------------- | |
3563 | ||
3564 | function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean is | |
3565 | Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); | |
3566 | Context : constant Node_Id := Parent (Subp_Decl); | |
3567 | ||
3568 | begin | |
3569 | -- To qualify, the subprogram must rename a generic actual subprogram | |
90e491a7 PMR |
3570 | -- where the enclosing context is an instantiation. |
3571 | ||
69e6ee2f HK |
3572 | return |
3573 | Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration | |
3574 | and then not Comes_From_Source (Subp_Decl) | |
3575 | and then Nkind_In (Context, N_Function_Specification, | |
3576 | N_Package_Specification, | |
3577 | N_Procedure_Specification) | |
3578 | and then Present (Generic_Parent (Context)); | |
3579 | end Is_Generic_Formal_Subp; | |
3580 | ||
3581 | -- Local variables | |
3582 | ||
3583 | Call_Nam : Node_Id; | |
3584 | Marker : Node_Id; | |
3585 | Subp_Id : Entity_Id; | |
3586 | ||
3587 | -- Start of processing for Build_Call_Marker | |
3588 | ||
3589 | begin | |
3590 | -- Nothing to do when switch -gnatH (legacy elaboration checking mode | |
3591 | -- enabled) is in effect because the legacy ABE mechanism does not need | |
3592 | -- to carry out this action. | |
3593 | ||
3594 | if Legacy_Elaboration_Checks then | |
3595 | return; | |
3596 | ||
3597 | -- Nothing to do for ASIS because ABE checks and diagnostics are not | |
3598 | -- performed in this mode. | |
3599 | ||
3600 | elsif ASIS_Mode then | |
3601 | return; | |
3602 | ||
3603 | -- Nothing to do when the call is being preanalyzed as the marker will | |
3604 | -- be inserted in the wrong place. | |
3605 | ||
3606 | elsif Preanalysis_Active then | |
3607 | return; | |
3608 | ||
0839ffce HK |
3609 | -- Nothing to do when the elaboration phase of the compiler is not |
3610 | -- active. | |
3611 | ||
3612 | elsif not Elaboration_Phase_Active then | |
3613 | return; | |
3614 | ||
69e6ee2f HK |
3615 | -- Nothing to do when the input does not denote a call or a requeue |
3616 | ||
3617 | elsif not Nkind_In (N, N_Entry_Call_Statement, | |
3618 | N_Function_Call, | |
3619 | N_Procedure_Call_Statement, | |
3620 | N_Requeue_Statement) | |
3621 | then | |
3622 | return; | |
3623 | ||
3624 | -- Nothing to do when the input denotes entry call or requeue statement, | |
3625 | -- and switch -gnatd_e (ignore entry calls and requeue statements for | |
3626 | -- elaboration) is in effect. | |
3627 | ||
3628 | elsif Debug_Flag_Underscore_E | |
3629 | and then Nkind_In (N, N_Entry_Call_Statement, N_Requeue_Statement) | |
3630 | then | |
3631 | return; | |
3632 | ||
3633 | -- Nothing to do when the call is analyzed/resolved too early within an | |
3634 | -- intermediate context. This check is saved for last because it incurs | |
3635 | -- a performance penalty. | |
3636 | ||
3637 | elsif In_Premature_Context (N) then | |
3638 | return; | |
3639 | end if; | |
3640 | ||
3641 | Call_Nam := Call_Name (N); | |
3642 | ||
3643 | -- Nothing to do when the call is erroneous or left in a bad state | |
3644 | ||
3645 | if not (Is_Entity_Name (Call_Nam) | |
3646 | and then Present (Entity (Call_Nam)) | |
3647 | and then Is_Subprogram_Or_Entry (Entity (Call_Nam))) | |
3648 | then | |
3649 | return; | |
3650 | end if; | |
3651 | ||
3652 | Subp_Id := Canonical_Subprogram (Entity (Call_Nam)); | |
3653 | ||
3654 | -- Nothing to do when the call invokes a generic formal subprogram and | |
3655 | -- switch -gnatd.G (ignore calls through generic formal parameters for | |
3656 | -- elaboration) is in effect. This check must be performed with the | |
3657 | -- direct target of the call to avoid the side effects of mapping | |
3658 | -- actuals to formals using renamings. | |
3659 | ||
3660 | if Debug_Flag_Dot_GG | |
3661 | and then Is_Generic_Formal_Subp (Entity (Call_Nam)) | |
3662 | then | |
3663 | return; | |
3664 | ||
3665 | -- Nothing to do when the call appears within the expanded spec or | |
3666 | -- body of an instantiated generic, the call does not invoke a generic | |
3667 | -- formal subprogram, the target is external to the instance, and switch | |
3668 | -- -gnatdL (ignore external calls from instances for elaboration) is in | |
3669 | -- effect. This check must be performed with the direct target of the | |
3670 | -- call to avoid the side effects of mapping actuals to formals using | |
3671 | -- renamings. | |
3672 | ||
3673 | elsif Debug_Flag_LL | |
3674 | and then not Is_Generic_Formal_Subp (Entity (Call_Nam)) | |
3675 | and then In_External_Context | |
3676 | (Call => N, | |
3677 | Subp_Id => Subp_Id) | |
3678 | then | |
3679 | return; | |
3680 | ||
3681 | -- Nothing to do when the call invokes an assertion pragma procedure | |
3682 | -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is | |
3683 | -- in effect. | |
3684 | ||
3685 | elsif Debug_Flag_Underscore_P | |
3686 | and then Is_Assertion_Pragma_Target (Subp_Id) | |
3687 | then | |
3688 | return; | |
3689 | ||
3690 | -- Source calls to source targets are always considered because they | |
3691 | -- reflect the original call graph. | |
3692 | ||
3693 | elsif Comes_From_Source (N) and then Comes_From_Source (Subp_Id) then | |
3694 | null; | |
3695 | ||
3696 | -- A call to a source function which acts as the default expression in | |
3697 | -- another call requires special detection. | |
3698 | ||
3699 | elsif Comes_From_Source (Subp_Id) | |
3700 | and then Nkind (N) = N_Function_Call | |
3701 | and then Is_Default_Expression (N) | |
3702 | then | |
3703 | null; | |
3704 | ||
3705 | -- The target emulates Ada semantics | |
3706 | ||
3707 | elsif Is_Ada_Semantic_Target (Subp_Id) then | |
3708 | null; | |
3709 | ||
3710 | -- The target acts as a link between scenarios | |
3711 | ||
3712 | elsif Is_Bridge_Target (Subp_Id) then | |
3713 | null; | |
3714 | ||
3715 | -- The target emulates SPARK semantics | |
3716 | ||
3717 | elsif Is_SPARK_Semantic_Target (Subp_Id) then | |
3718 | null; | |
3719 | ||
3720 | -- Otherwise the call is not suitable for ABE processing. This prevents | |
3721 | -- the generation of call markers which will never play a role in ABE | |
3722 | -- diagnostics. | |
3723 | ||
3724 | else | |
3725 | return; | |
3726 | end if; | |
3727 | ||
3728 | -- At this point it is known that the call will play some role in ABE | |
3729 | -- checks and diagnostics. Create a corresponding call marker in case | |
3730 | -- the original call is heavily transformed by expansion later on. | |
3731 | ||
3732 | Marker := Make_Call_Marker (Sloc (N)); | |
3733 | ||
3734 | -- Inherit the attributes of the original call | |
3735 | ||
3736 | Set_Is_Declaration_Level_Node | |
3737 | (Marker, Find_Enclosing_Level (N) = Declaration_Level); | |
3738 | ||
3739 | Set_Is_Dispatching_Call | |
3740 | (Marker, Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) | |
3741 | and then Present (Controlling_Argument (N))); | |
3742 | ||
3743 | Set_Is_Elaboration_Checks_OK_Node | |
3744 | (Marker, Is_Elaboration_Checks_OK_Node (N)); | |
3745 | ||
3746 | Set_Is_Elaboration_Warnings_OK_Node | |
3747 | (Marker, Is_Elaboration_Warnings_OK_Node (N)); | |
3748 | ||
3749 | Set_Is_Ignored_Ghost_Node (Marker, Is_Ignored_Ghost_Node (N)); | |
3750 | Set_Is_Source_Call (Marker, Comes_From_Source (N)); | |
3751 | Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N)); | |
3752 | Set_Target (Marker, Subp_Id); | |
3753 | ||
3754 | -- The marker is inserted prior to the original call. This placement has | |
3755 | -- several desirable effects: | |
3756 | ||
3757 | -- 1) The marker appears in the same context, in close proximity to | |
3758 | -- the call. | |
3759 | ||
3760 | -- <marker> | |
3761 | -- <call> | |
3762 | ||
3763 | -- 2) Inserting the marker prior to the call ensures that an ABE check | |
3764 | -- will take effect prior to the call. | |
3765 | ||
3766 | -- <ABE check> | |
3767 | -- <marker> | |
3768 | -- <call> | |
3769 | ||
3770 | -- 3) The above two properties are preserved even when the call is a | |
3771 | -- function which is subsequently relocated in order to capture its | |
3772 | -- result. Note that if the call is relocated to a new context, the | |
3773 | -- relocated call will receive a marker of its own. | |
3774 | ||
3775 | -- <ABE check> | |
3776 | -- <maker> | |
3777 | -- Temp : ... := Func_Call ...; | |
3778 | -- ... Temp ... | |
3779 | ||
3780 | -- The insertion must take place even when the call does not occur in | |
3781 | -- the main unit to keep the tree symmetric. This ensures that internal | |
3782 | -- name serialization is consistent in case the call marker causes the | |
3783 | -- tree to transform in some way. | |
3784 | ||
3785 | Insert_Action (N, Marker); | |
3786 | ||
3787 | -- The marker becomes the "corresponding" scenario for the call. Save | |
3788 | -- the marker for later processing by the ABE phase. | |
3789 | ||
3790 | Record_Elaboration_Scenario (Marker); | |
3791 | end Build_Call_Marker; | |
3792 | ||
3793 | ------------------------------------- | |
3794 | -- Build_Variable_Reference_Marker -- | |
3795 | ------------------------------------- | |
3796 | ||
3797 | procedure Build_Variable_Reference_Marker | |
3798 | (N : Node_Id; | |
3799 | Read : Boolean; | |
3800 | Write : Boolean) | |
3801 | is | |
3802 | function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id; | |
3803 | pragma Inline (Ultimate_Variable); | |
3804 | -- Obtain the ultimate renamed variable of variable Var_Id | |
3805 | ||
3806 | ----------------------- | |
3807 | -- Ultimate_Variable -- | |
3808 | ----------------------- | |
3809 | ||
3810 | function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id is | |
3811 | Ren_Id : Entity_Id; | |
3812 | ||
3813 | begin | |
3814 | Ren_Id := Var_Id; | |
3815 | while Present (Renamed_Entity (Ren_Id)) | |
3816 | and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity | |
3817 | loop | |
3818 | Ren_Id := Renamed_Entity (Ren_Id); | |
3819 | end loop; | |
3820 | ||
3821 | return Ren_Id; | |
3822 | end Ultimate_Variable; | |
3823 | ||
3824 | -- Local variables | |
3825 | ||
3826 | Var_Id : constant Entity_Id := Ultimate_Variable (Entity (N)); | |
3827 | Marker : Node_Id; | |
3828 | ||
3829 | -- Start of processing for Build_Variable_Reference_Marker | |
3830 | ||
3831 | begin | |
0839ffce HK |
3832 | -- Nothing to do when the elaboration phase of the compiler is not |
3833 | -- active. | |
3834 | ||
3835 | if not Elaboration_Phase_Active then | |
3836 | return; | |
3837 | end if; | |
3838 | ||
69e6ee2f HK |
3839 | Marker := Make_Variable_Reference_Marker (Sloc (N)); |
3840 | ||
3841 | -- Inherit the attributes of the original variable reference | |
3842 | ||
3843 | Set_Is_Elaboration_Checks_OK_Node | |
3844 | (Marker, Is_Elaboration_Checks_OK_Node (N)); | |
3845 | ||
3846 | Set_Is_Elaboration_Warnings_OK_Node | |
3847 | (Marker, Is_Elaboration_Warnings_OK_Node (N)); | |
3848 | ||
3849 | Set_Is_Read (Marker, Read); | |
3850 | Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N)); | |
3851 | Set_Is_Write (Marker, Write); | |
3852 | Set_Target (Marker, Var_Id); | |
3853 | ||
3854 | -- The marker is inserted prior to the original variable reference. The | |
3855 | -- insertion must take place even when the reference does not occur in | |
3856 | -- the main unit to keep the tree symmetric. This ensures that internal | |
3857 | -- name serialization is consistent in case the variable marker causes | |
3858 | -- the tree to transform in some way. | |
3859 | ||
3860 | Insert_Action (N, Marker); | |
3861 | ||
3862 | -- The marker becomes the "corresponding" scenario for the reference. | |
3863 | -- Save the marker for later processing for the ABE phase. | |
3864 | ||
3865 | Record_Elaboration_Scenario (Marker); | |
3866 | end Build_Variable_Reference_Marker; | |
3867 | ||
3868 | --------------- | |
3869 | -- Call_Name -- | |
3870 | --------------- | |
3871 | ||
3872 | function Call_Name (Call : Node_Id) return Node_Id is | |
3873 | Nam : Node_Id; | |
3874 | ||
3875 | begin | |
3876 | Nam := Name (Call); | |
3877 | ||
3878 | -- When the call invokes an entry family, the name appears as an indexed | |
3879 | -- component. | |
90e491a7 | 3880 | |
69e6ee2f HK |
3881 | if Nkind (Nam) = N_Indexed_Component then |
3882 | Nam := Prefix (Nam); | |
3883 | end if; | |
90e491a7 | 3884 | |
69e6ee2f HK |
3885 | -- When the call employs the object.operation form, the name appears as |
3886 | -- a selected component. | |
90e491a7 | 3887 | |
69e6ee2f HK |
3888 | if Nkind (Nam) = N_Selected_Component then |
3889 | Nam := Selector_Name (Nam); | |
3890 | end if; | |
3891 | ||
3892 | return Nam; | |
3893 | end Call_Name; | |
3894 | ||
3895 | -------------------------- | |
3896 | -- Canonical_Subprogram -- | |
3897 | -------------------------- | |
3898 | ||
3899 | function Canonical_Subprogram (Subp_Id : Entity_Id) return Entity_Id is | |
3900 | Canon_Id : Entity_Id; | |
3901 | ||
3902 | begin | |
3903 | Canon_Id := Subp_Id; | |
3904 | ||
3905 | -- Use the original protected subprogram when dealing with one of the | |
3906 | -- specialized lock-manipulating versions. | |
3907 | ||
3908 | if Is_Protected_Body_Subp (Canon_Id) then | |
3909 | Canon_Id := Protected_Subprogram (Canon_Id); | |
3910 | end if; | |
3911 | ||
3912 | -- Obtain the original subprogram except when the subprogram is also | |
3913 | -- an instantiation. In this case the alias is the internally generated | |
3914 | -- subprogram which appears within the anonymous package created for the | |
3915 | -- instantiation, making it unuitable. | |
3916 | ||
3917 | if not Is_Generic_Instance (Canon_Id) then | |
3918 | Canon_Id := Get_Renamed_Entity (Canon_Id); | |
3919 | end if; | |
3920 | ||
3921 | return Canon_Id; | |
3922 | end Canonical_Subprogram; | |
3923 | ||
3924 | --------------------------------- | |
3925 | -- Check_Elaboration_Scenarios -- | |
3926 | --------------------------------- | |
3927 | ||
3928 | procedure Check_Elaboration_Scenarios is | |
3929 | Iter : NE_Set.Iterator; | |
90e491a7 PMR |
3930 | |
3931 | begin | |
967947ed PMR |
3932 | -- Nothing to do when switch -gnatH (legacy elaboration checking mode |
3933 | -- enabled) is in effect because the legacy ABE mechanism does not need | |
3934 | -- to carry out this action. | |
3935 | ||
3936 | if Legacy_Elaboration_Checks then | |
0839ffce | 3937 | Finalize_All_Data_Structures; |
967947ed PMR |
3938 | return; |
3939 | ||
692918a9 HK |
3940 | -- Nothing to do for ASIS because ABE checks and diagnostics are not |
3941 | -- performed in this mode. | |
90e491a7 | 3942 | |
967947ed | 3943 | elsif ASIS_Mode then |
0839ffce | 3944 | Finalize_All_Data_Structures; |
90e491a7 PMR |
3945 | return; |
3946 | ||
0839ffce HK |
3947 | -- Nothing to do when the elaboration phase of the compiler is not |
3948 | -- active. | |
daf82dd8 | 3949 | |
0839ffce HK |
3950 | elsif not Elaboration_Phase_Active then |
3951 | Finalize_All_Data_Structures; | |
3952 | return; | |
3953 | end if; | |
daf82dd8 | 3954 | |
69e6ee2f HK |
3955 | -- Restore the original elaboration model which was in effect when the |
3956 | -- scenarios were first recorded. The model may be specified by pragma | |
3957 | -- Elaboration_Checks which appears on the initial declaration of the | |
3958 | -- main unit. | |
90e491a7 | 3959 | |
3eb5e54a | 3960 | Install_Elaboration_Model (Unit_Entity (Main_Unit_Entity)); |
69e6ee2f HK |
3961 | |
3962 | -- Examine the context of the main unit and record all units with prior | |
3963 | -- elaboration with respect to it. | |
3964 | ||
3965 | Collect_Elaborated_Units; | |
3966 | ||
3967 | -- Examine all scenarios saved during the Recording phase applying the | |
3968 | -- Ada or SPARK elaboration rules in order to detect and diagnose ABE | |
3969 | -- issues, install conditional ABE checks, and ensure the elaboration | |
3970 | -- of units. | |
3971 | ||
3972 | Iter := Iterate_Declaration_Scenarios; | |
3973 | Check_Conditional_ABE_Scenarios (Iter); | |
3974 | ||
3975 | Iter := Iterate_Library_Body_Scenarios; | |
3976 | Check_Conditional_ABE_Scenarios (Iter); | |
3977 | ||
3978 | Iter := Iterate_Library_Spec_Scenarios; | |
3979 | Check_Conditional_ABE_Scenarios (Iter); | |
3980 | ||
3981 | -- Examine each SPARK scenario saved during the Recording phase which | |
3982 | -- is not necessarily executable during elaboration, but still requires | |
3983 | -- elaboration-related checks. | |
3984 | ||
3985 | Check_SPARK_Scenarios; | |
3986 | ||
3987 | -- Add conditional ABE checks for all scenarios that require one when | |
3988 | -- the dynamic model is in effect. | |
3989 | ||
3990 | Install_Dynamic_ABE_Checks; | |
3991 | ||
3992 | -- Examine all scenarios saved during the Recording phase along with | |
3993 | -- invocation constructs within the spec and body of the main unit. | |
3994 | -- Record the declarations and paths that reach into an external unit | |
3995 | -- in the ALI file of the main unit. | |
3996 | ||
3997 | Record_Invocation_Graph; | |
3998 | ||
0839ffce HK |
3999 | -- Destroy all internal data structures and complete the elaboration |
4000 | -- phase of the compiler. | |
69e6ee2f | 4001 | |
0839ffce HK |
4002 | Finalize_All_Data_Structures; |
4003 | Set_Elaboration_Phase (Completed); | |
69e6ee2f HK |
4004 | end Check_Elaboration_Scenarios; |
4005 | ||
4006 | --------------------- | |
4007 | -- Check_Installer -- | |
4008 | --------------------- | |
4009 | ||
4010 | package body Check_Installer is | |
4011 | ||
4012 | ----------------------- | |
4013 | -- Local subprograms -- | |
4014 | ----------------------- | |
4015 | ||
4016 | function ABE_Check_Or_Failure_OK | |
4017 | (N : Node_Id; | |
4018 | Targ_Id : Entity_Id; | |
4019 | Unit_Id : Entity_Id) return Boolean; | |
4020 | pragma Inline (ABE_Check_Or_Failure_OK); | |
4021 | -- Determine whether a conditional ABE check or guaranteed ABE failure | |
4022 | -- can be installed for scenario N with target Targ_Id which resides in | |
4023 | -- unit Unit_Id. | |
4024 | ||
4025 | function Insertion_Node (N : Node_Id) return Node_Id; | |
4026 | pragma Inline (Insertion_Node); | |
4027 | -- Obtain the proper insertion node of an ABE check or failure for | |
4028 | -- scenario N. | |
4029 | ||
4030 | procedure Insert_ABE_Check_Or_Failure (N : Node_Id; Check : Node_Id); | |
4031 | pragma Inline (Insert_ABE_Check_Or_Failure); | |
4032 | -- Insert conditional ABE check or guaranteed ABE failure Check prior to | |
4033 | -- scenario N. | |
4034 | ||
4035 | procedure Install_Scenario_ABE_Check_Common | |
4036 | (N : Node_Id; | |
4037 | Targ_Id : Entity_Id; | |
4038 | Targ_Rep : Target_Rep_Id); | |
4039 | pragma Inline (Install_Scenario_ABE_Check_Common); | |
4040 | -- Install a conditional ABE check for scenario N to ensure that target | |
4041 | -- Targ_Id is properly elaborated. Targ_Rep is the representation of the | |
4042 | -- target. | |
4043 | ||
4044 | procedure Install_Scenario_ABE_Failure_Common (N : Node_Id); | |
4045 | pragma Inline (Install_Scenario_ABE_Failure_Common); | |
4046 | -- Install a guaranteed ABE failure for scenario N | |
4047 | ||
4048 | procedure Install_Unit_ABE_Check_Common | |
4049 | (N : Node_Id; | |
4050 | Unit_Id : Entity_Id); | |
4051 | pragma Inline (Install_Unit_ABE_Check_Common); | |
4052 | -- Install a conditional ABE check for scenario N to ensure that unit | |
4053 | -- Unit_Id is properly elaborated. | |
4054 | ||
4055 | ----------------------------- | |
4056 | -- ABE_Check_Or_Failure_OK -- | |
4057 | ----------------------------- | |
4058 | ||
4059 | function ABE_Check_Or_Failure_OK | |
4060 | (N : Node_Id; | |
4061 | Targ_Id : Entity_Id; | |
4062 | Unit_Id : Entity_Id) return Boolean | |
4063 | is | |
4064 | pragma Unreferenced (Targ_Id); | |
4065 | ||
4066 | Ins_Node : constant Node_Id := Insertion_Node (N); | |
4067 | ||
4068 | begin | |
4069 | if not Check_Or_Failure_Generation_OK then | |
4070 | return False; | |
4071 | ||
4072 | -- Nothing to do when the scenario denots a compilation unit because | |
4073 | -- there is no executable environment at that level. | |
4074 | ||
4075 | elsif Nkind (Parent (Ins_Node)) = N_Compilation_Unit then | |
4076 | return False; | |
4077 | ||
4078 | -- An ABE check or failure is not needed when the target is defined | |
4079 | -- in a unit which is elaborated prior to the main unit. This check | |
4080 | -- must also consider the following cases: | |
4081 | -- | |
4082 | -- * The unit of the target appears in the context of the main unit | |
4083 | -- | |
4084 | -- * The unit of the target is subject to pragma Elaborate_Body. An | |
4085 | -- ABE check MUST NOT be generated because the unit is always | |
4086 | -- elaborated prior to the main unit. | |
4087 | -- | |
4088 | -- * The unit of the target is the main unit. An ABE check MUST be | |
4089 | -- added in this case because a conditional ABE may be raised | |
4090 | -- depending on the flow of execution within the main unit (flag | |
4091 | -- Same_Unit_OK is False). | |
4092 | ||
4093 | elsif Has_Prior_Elaboration | |
4094 | (Unit_Id => Unit_Id, | |
4095 | Context_OK => True, | |
4096 | Elab_Body_OK => True) | |
4097 | then | |
4098 | return False; | |
4099 | end if; | |
4100 | ||
4101 | return True; | |
4102 | end ABE_Check_Or_Failure_OK; | |
4103 | ||
4104 | ------------------------------------ | |
4105 | -- Check_Or_Failure_Generation_OK -- | |
4106 | ------------------------------------ | |
4107 | ||
4108 | function Check_Or_Failure_Generation_OK return Boolean is | |
4109 | begin | |
4110 | -- An ABE check or failure is not needed when the compilation will | |
4111 | -- not produce an executable. | |
4112 | ||
4113 | if Serious_Errors_Detected > 0 then | |
4114 | return False; | |
4115 | ||
4116 | -- An ABE check or failure must not be installed when compiling for | |
4117 | -- GNATprove because raise statements are not supported. | |
4118 | ||
4119 | elsif GNATprove_Mode then | |
4120 | return False; | |
4121 | end if; | |
4122 | ||
4123 | return True; | |
4124 | end Check_Or_Failure_Generation_OK; | |
4125 | ||
4126 | -------------------- | |
4127 | -- Insertion_Node -- | |
4128 | -------------------- | |
4129 | ||
4130 | function Insertion_Node (N : Node_Id) return Node_Id is | |
4131 | begin | |
4132 | -- When the scenario denotes an instantiation, the proper insertion | |
4133 | -- node is the instance spec. This ensures that the generic actuals | |
4134 | -- will not be evaluated prior to a potential ABE. | |
4135 | ||
4136 | if Nkind (N) in N_Generic_Instantiation | |
4137 | and then Present (Instance_Spec (N)) | |
4138 | then | |
4139 | return Instance_Spec (N); | |
4140 | ||
4141 | -- Otherwise the proper insertion node is the scenario itself | |
4142 | ||
4143 | else | |
4144 | return N; | |
4145 | end if; | |
4146 | end Insertion_Node; | |
4147 | ||
4148 | --------------------------------- | |
4149 | -- Insert_ABE_Check_Or_Failure -- | |
4150 | --------------------------------- | |
4151 | ||
4152 | procedure Insert_ABE_Check_Or_Failure (N : Node_Id; Check : Node_Id) is | |
4153 | Ins_Nod : constant Node_Id := Insertion_Node (N); | |
4154 | Scop_Id : constant Entity_Id := Find_Enclosing_Scope (Ins_Nod); | |
4155 | ||
4156 | begin | |
4157 | -- Install the nearest enclosing scope of the scenario as there must | |
4158 | -- be something on the scope stack. | |
4159 | ||
4160 | Push_Scope (Scop_Id); | |
4161 | ||
4162 | Insert_Action (Ins_Nod, Check); | |
4163 | ||
4164 | Pop_Scope; | |
4165 | end Insert_ABE_Check_Or_Failure; | |
4166 | ||
4167 | -------------------------------- | |
4168 | -- Install_Dynamic_ABE_Checks -- | |
4169 | -------------------------------- | |
4170 | ||
4171 | procedure Install_Dynamic_ABE_Checks is | |
4172 | Iter : NE_Set.Iterator; | |
4173 | N : Node_Id; | |
4174 | ||
4175 | begin | |
4176 | if not Check_Or_Failure_Generation_OK then | |
4177 | return; | |
4178 | ||
4179 | -- Nothing to do if the dynamic model is not in effect | |
4180 | ||
4181 | elsif not Dynamic_Elaboration_Checks then | |
4182 | return; | |
4183 | end if; | |
4184 | ||
4185 | -- Install a conditional ABE check for each saved scenario | |
4186 | ||
4187 | Iter := Iterate_Dynamic_ABE_Check_Scenarios; | |
4188 | while NE_Set.Has_Next (Iter) loop | |
4189 | NE_Set.Next (Iter, N); | |
4190 | ||
4191 | Process_Conditional_ABE | |
4192 | (N => N, | |
4193 | In_State => Dynamic_Model_State); | |
4194 | end loop; | |
4195 | end Install_Dynamic_ABE_Checks; | |
4196 | ||
4197 | -------------------------------- | |
4198 | -- Install_Scenario_ABE_Check -- | |
4199 | -------------------------------- | |
4200 | ||
4201 | procedure Install_Scenario_ABE_Check | |
4202 | (N : Node_Id; | |
4203 | Targ_Id : Entity_Id; | |
4204 | Targ_Rep : Target_Rep_Id; | |
4205 | Disable : Scenario_Rep_Id) | |
4206 | is | |
4207 | begin | |
4208 | -- Nothing to do when the scenario does not need an ABE check | |
4209 | ||
4210 | if not ABE_Check_Or_Failure_OK | |
4211 | (N => N, | |
4212 | Targ_Id => Targ_Id, | |
4213 | Unit_Id => Unit (Targ_Rep)) | |
4214 | then | |
4215 | return; | |
4216 | end if; | |
4217 | ||
4218 | -- Prevent multiple attempts to install the same ABE check | |
4219 | ||
4220 | Disable_Elaboration_Checks (Disable); | |
4221 | ||
4222 | Install_Scenario_ABE_Check_Common | |
4223 | (N => N, | |
4224 | Targ_Id => Targ_Id, | |
4225 | Targ_Rep => Targ_Rep); | |
4226 | end Install_Scenario_ABE_Check; | |
4227 | ||
4228 | -------------------------------- | |
4229 | -- Install_Scenario_ABE_Check -- | |
4230 | -------------------------------- | |
4231 | ||
4232 | procedure Install_Scenario_ABE_Check | |
4233 | (N : Node_Id; | |
4234 | Targ_Id : Entity_Id; | |
4235 | Targ_Rep : Target_Rep_Id; | |
4236 | Disable : Target_Rep_Id) | |
4237 | is | |
4238 | begin | |
4239 | -- Nothing to do when the scenario does not need an ABE check | |
4240 | ||
4241 | if not ABE_Check_Or_Failure_OK | |
4242 | (N => N, | |
4243 | Targ_Id => Targ_Id, | |
4244 | Unit_Id => Unit (Targ_Rep)) | |
4245 | then | |
4246 | return; | |
4247 | end if; | |
4248 | ||
4249 | -- Prevent multiple attempts to install the same ABE check | |
4250 | ||
4251 | Disable_Elaboration_Checks (Disable); | |
4252 | ||
4253 | Install_Scenario_ABE_Check_Common | |
4254 | (N => N, | |
4255 | Targ_Id => Targ_Id, | |
4256 | Targ_Rep => Targ_Rep); | |
4257 | end Install_Scenario_ABE_Check; | |
4258 | ||
4259 | --------------------------------------- | |
4260 | -- Install_Scenario_ABE_Check_Common -- | |
4261 | --------------------------------------- | |
4262 | ||
4263 | procedure Install_Scenario_ABE_Check_Common | |
4264 | (N : Node_Id; | |
4265 | Targ_Id : Entity_Id; | |
4266 | Targ_Rep : Target_Rep_Id) | |
4267 | is | |
4268 | Targ_Body : constant Node_Id := Body_Declaration (Targ_Rep); | |
4269 | Targ_Decl : constant Node_Id := Spec_Declaration (Targ_Rep); | |
4270 | ||
4271 | pragma Assert (Present (Targ_Body)); | |
4272 | pragma Assert (Present (Targ_Decl)); | |
4273 | ||
4274 | procedure Build_Elaboration_Entity; | |
4275 | pragma Inline (Build_Elaboration_Entity); | |
4276 | -- Create a new elaboration flag for Targ_Id, insert it prior to | |
4277 | -- Targ_Decl, and set it after Targ_Body. | |
4278 | ||
4279 | ------------------------------ | |
4280 | -- Build_Elaboration_Entity -- | |
4281 | ------------------------------ | |
4282 | ||
4283 | procedure Build_Elaboration_Entity is | |
4284 | Loc : constant Source_Ptr := Sloc (Targ_Id); | |
4285 | Flag_Id : Entity_Id; | |
4286 | ||
4287 | begin | |
4288 | -- Nothing to do if the target has an elaboration flag | |
4289 | ||
4290 | if Present (Elaboration_Entity (Targ_Id)) then | |
4291 | return; | |
4292 | end if; | |
4293 | ||
4294 | -- Create the declaration of the elaboration flag. The name | |
4295 | -- carries a unique counter in case the name is overloaded. | |
4296 | ||
4297 | Flag_Id := | |
4298 | Make_Defining_Identifier (Loc, | |
4299 | Chars => New_External_Name (Chars (Targ_Id), 'E', -1)); | |
4300 | ||
4301 | Set_Elaboration_Entity (Targ_Id, Flag_Id); | |
4302 | Set_Elaboration_Entity_Required (Targ_Id); | |
4303 | ||
4304 | Push_Scope (Scope (Targ_Id)); | |
4305 | ||
4306 | -- Generate: | |
4307 | -- Enn : Short_Integer := 0; | |
4308 | ||
4309 | Insert_Action (Targ_Decl, | |
4310 | Make_Object_Declaration (Loc, | |
4311 | Defining_Identifier => Flag_Id, | |
4312 | Object_Definition => | |
4313 | New_Occurrence_Of (Standard_Short_Integer, Loc), | |
4314 | Expression => Make_Integer_Literal (Loc, Uint_0))); | |
4315 | ||
4316 | -- Generate: | |
4317 | -- Enn := 1; | |
4318 | ||
4319 | Set_Elaboration_Flag (Targ_Body, Targ_Id); | |
4320 | ||
4321 | Pop_Scope; | |
4322 | end Build_Elaboration_Entity; | |
4323 | ||
4324 | -- Local variables | |
4325 | ||
4326 | Loc : constant Source_Ptr := Sloc (N); | |
4327 | ||
4328 | -- Start for processing for Install_Scenario_ABE_Check_Common | |
4329 | ||
4330 | begin | |
4331 | -- Create an elaboration flag for the target when it does not have | |
4332 | -- one. | |
4333 | ||
4334 | Build_Elaboration_Entity; | |
4335 | ||
4336 | -- Generate: | |
4337 | -- if not Targ_Id'Elaborated then | |
4338 | -- raise Program_Error with "access before elaboration"; | |
4339 | -- end if; | |
4340 | ||
4341 | Insert_ABE_Check_Or_Failure | |
4342 | (N => N, | |
4343 | Check => | |
4344 | Make_Raise_Program_Error (Loc, | |
4345 | Condition => | |
4346 | Make_Op_Not (Loc, | |
4347 | Right_Opnd => | |
4348 | Make_Attribute_Reference (Loc, | |
4349 | Prefix => New_Occurrence_Of (Targ_Id, Loc), | |
4350 | Attribute_Name => Name_Elaborated)), | |
4351 | Reason => PE_Access_Before_Elaboration)); | |
4352 | end Install_Scenario_ABE_Check_Common; | |
4353 | ||
4354 | ---------------------------------- | |
4355 | -- Install_Scenario_ABE_Failure -- | |
4356 | ---------------------------------- | |
4357 | ||
4358 | procedure Install_Scenario_ABE_Failure | |
4359 | (N : Node_Id; | |
4360 | Targ_Id : Entity_Id; | |
4361 | Targ_Rep : Target_Rep_Id; | |
4362 | Disable : Scenario_Rep_Id) | |
4363 | is | |
4364 | begin | |
4365 | -- Nothing to do when the scenario does not require an ABE failure | |
4366 | ||
4367 | if not ABE_Check_Or_Failure_OK | |
4368 | (N => N, | |
4369 | Targ_Id => Targ_Id, | |
4370 | Unit_Id => Unit (Targ_Rep)) | |
4371 | then | |
4372 | return; | |
4373 | end if; | |
4374 | ||
4375 | -- Prevent multiple attempts to install the same ABE check | |
4376 | ||
4377 | Disable_Elaboration_Checks (Disable); | |
4378 | ||
4379 | Install_Scenario_ABE_Failure_Common (N); | |
4380 | end Install_Scenario_ABE_Failure; | |
4381 | ||
4382 | ---------------------------------- | |
4383 | -- Install_Scenario_ABE_Failure -- | |
4384 | ---------------------------------- | |
4385 | ||
4386 | procedure Install_Scenario_ABE_Failure | |
4387 | (N : Node_Id; | |
4388 | Targ_Id : Entity_Id; | |
4389 | Targ_Rep : Target_Rep_Id; | |
4390 | Disable : Target_Rep_Id) | |
4391 | is | |
4392 | begin | |
4393 | -- Nothing to do when the scenario does not require an ABE failure | |
4394 | ||
4395 | if not ABE_Check_Or_Failure_OK | |
4396 | (N => N, | |
4397 | Targ_Id => Targ_Id, | |
4398 | Unit_Id => Unit (Targ_Rep)) | |
4399 | then | |
4400 | return; | |
4401 | end if; | |
4402 | ||
4403 | -- Prevent multiple attempts to install the same ABE check | |
4404 | ||
4405 | Disable_Elaboration_Checks (Disable); | |
4406 | ||
4407 | Install_Scenario_ABE_Failure_Common (N); | |
4408 | end Install_Scenario_ABE_Failure; | |
4409 | ||
4410 | ----------------------------------------- | |
4411 | -- Install_Scenario_ABE_Failure_Common -- | |
4412 | ----------------------------------------- | |
4413 | ||
4414 | procedure Install_Scenario_ABE_Failure_Common (N : Node_Id) is | |
4415 | Loc : constant Source_Ptr := Sloc (N); | |
4416 | ||
4417 | begin | |
4418 | -- Generate: | |
4419 | -- raise Program_Error with "access before elaboration"; | |
4420 | ||
4421 | Insert_ABE_Check_Or_Failure | |
4422 | (N => N, | |
4423 | Check => | |
4424 | Make_Raise_Program_Error (Loc, | |
4425 | Reason => PE_Access_Before_Elaboration)); | |
4426 | end Install_Scenario_ABE_Failure_Common; | |
4427 | ||
4428 | ---------------------------- | |
4429 | -- Install_Unit_ABE_Check -- | |
4430 | ---------------------------- | |
4431 | ||
4432 | procedure Install_Unit_ABE_Check | |
4433 | (N : Node_Id; | |
4434 | Unit_Id : Entity_Id; | |
4435 | Disable : Scenario_Rep_Id) | |
4436 | is | |
4437 | Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id); | |
4438 | ||
4439 | begin | |
4440 | -- Nothing to do when the scenario does not require an ABE check | |
90e491a7 | 4441 | |
69e6ee2f HK |
4442 | if not ABE_Check_Or_Failure_OK |
4443 | (N => N, | |
4444 | Targ_Id => Empty, | |
4445 | Unit_Id => Spec_Id) | |
4446 | then | |
4447 | return; | |
4448 | end if; | |
90e491a7 | 4449 | |
69e6ee2f | 4450 | -- Prevent multiple attempts to install the same ABE check |
90e491a7 | 4451 | |
69e6ee2f | 4452 | Disable_Elaboration_Checks (Disable); |
90e491a7 | 4453 | |
69e6ee2f HK |
4454 | Install_Unit_ABE_Check_Common |
4455 | (N => N, | |
4456 | Unit_Id => Unit_Id); | |
4457 | end Install_Unit_ABE_Check; | |
90e491a7 | 4458 | |
69e6ee2f HK |
4459 | ---------------------------- |
4460 | -- Install_Unit_ABE_Check -- | |
4461 | ---------------------------- | |
90e491a7 | 4462 | |
69e6ee2f HK |
4463 | procedure Install_Unit_ABE_Check |
4464 | (N : Node_Id; | |
4465 | Unit_Id : Entity_Id; | |
4466 | Disable : Target_Rep_Id) | |
4467 | is | |
4468 | Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id); | |
90e491a7 | 4469 | |
69e6ee2f HK |
4470 | begin |
4471 | -- Nothing to do when the scenario does not require an ABE check | |
967947ed | 4472 | |
69e6ee2f HK |
4473 | if not ABE_Check_Or_Failure_OK |
4474 | (N => N, | |
4475 | Targ_Id => Empty, | |
4476 | Unit_Id => Spec_Id) | |
4477 | then | |
4478 | return; | |
4479 | end if; | |
967947ed | 4480 | |
69e6ee2f | 4481 | -- Prevent multiple attempts to install the same ABE check |
967947ed | 4482 | |
69e6ee2f | 4483 | Disable_Elaboration_Checks (Disable); |
90e491a7 | 4484 | |
69e6ee2f HK |
4485 | Install_Unit_ABE_Check_Common |
4486 | (N => N, | |
4487 | Unit_Id => Unit_Id); | |
4488 | end Install_Unit_ABE_Check; | |
90e491a7 | 4489 | |
69e6ee2f HK |
4490 | ----------------------------------- |
4491 | -- Install_Unit_ABE_Check_Common -- | |
4492 | ----------------------------------- | |
90e491a7 | 4493 | |
69e6ee2f HK |
4494 | procedure Install_Unit_ABE_Check_Common |
4495 | (N : Node_Id; | |
4496 | Unit_Id : Entity_Id) | |
4497 | is | |
4498 | Loc : constant Source_Ptr := Sloc (N); | |
4499 | Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id); | |
c581c520 | 4500 | |
69e6ee2f HK |
4501 | begin |
4502 | -- Generate: | |
4503 | -- if not Spec_Id'Elaborated then | |
4504 | -- raise Program_Error with "access before elaboration"; | |
4505 | -- end if; | |
4506 | ||
4507 | Insert_ABE_Check_Or_Failure | |
4508 | (N => N, | |
4509 | Check => | |
4510 | Make_Raise_Program_Error (Loc, | |
4511 | Condition => | |
4512 | Make_Op_Not (Loc, | |
4513 | Right_Opnd => | |
4514 | Make_Attribute_Reference (Loc, | |
4515 | Prefix => New_Occurrence_Of (Spec_Id, Loc), | |
4516 | Attribute_Name => Name_Elaborated)), | |
4517 | Reason => PE_Access_Before_Elaboration)); | |
4518 | end Install_Unit_ABE_Check_Common; | |
4519 | end Check_Installer; | |
c581c520 | 4520 | |
69e6ee2f HK |
4521 | ---------------------- |
4522 | -- Compilation_Unit -- | |
4523 | ---------------------- | |
c581c520 | 4524 | |
69e6ee2f HK |
4525 | function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is |
4526 | Comp_Unit : Node_Id; | |
c581c520 | 4527 | |
69e6ee2f HK |
4528 | begin |
4529 | Comp_Unit := Parent (Unit_Id); | |
90e491a7 | 4530 | |
69e6ee2f HK |
4531 | -- Handle the case where a concurrent subunit is rewritten as a null |
4532 | -- statement due to expansion activities. | |
4533 | ||
4534 | if Nkind (Comp_Unit) = N_Null_Statement | |
4535 | and then Nkind_In (Original_Node (Comp_Unit), N_Protected_Body, | |
4536 | N_Task_Body) | |
90e491a7 | 4537 | then |
69e6ee2f HK |
4538 | Comp_Unit := Parent (Comp_Unit); |
4539 | pragma Assert (Nkind (Comp_Unit) = N_Subunit); | |
90e491a7 | 4540 | |
69e6ee2f | 4541 | -- Otherwise use the declaration node of the unit |
90e491a7 | 4542 | |
69e6ee2f HK |
4543 | else |
4544 | Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id)); | |
4545 | end if; | |
90e491a7 | 4546 | |
69e6ee2f HK |
4547 | -- Handle the case where a subprogram instantiation which acts as a |
4548 | -- compilation unit is expanded into an anonymous package that wraps | |
4549 | -- the instantiated subprogram. | |
90e491a7 | 4550 | |
69e6ee2f HK |
4551 | if Nkind (Comp_Unit) = N_Package_Specification |
4552 | and then Nkind_In (Original_Node (Parent (Comp_Unit)), | |
4553 | N_Function_Instantiation, | |
4554 | N_Procedure_Instantiation) | |
90e491a7 | 4555 | then |
69e6ee2f | 4556 | Comp_Unit := Parent (Parent (Comp_Unit)); |
90e491a7 | 4557 | |
69e6ee2f | 4558 | -- Handle the case where the compilation unit is a subunit |
90e491a7 | 4559 | |
69e6ee2f HK |
4560 | elsif Nkind (Comp_Unit) = N_Subunit then |
4561 | Comp_Unit := Parent (Comp_Unit); | |
4562 | end if; | |
90e491a7 | 4563 | |
69e6ee2f | 4564 | pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); |
90e491a7 | 4565 | |
69e6ee2f HK |
4566 | return Comp_Unit; |
4567 | end Compilation_Unit; | |
90e491a7 | 4568 | |
69e6ee2f HK |
4569 | ------------------------------- |
4570 | -- Conditional_ABE_Processor -- | |
4571 | ------------------------------- | |
90e491a7 | 4572 | |
69e6ee2f | 4573 | package body Conditional_ABE_Processor is |
90e491a7 | 4574 | |
69e6ee2f HK |
4575 | ----------------------- |
4576 | -- Local subprograms -- | |
4577 | ----------------------- | |
90e491a7 | 4578 | |
69e6ee2f HK |
4579 | function Is_Conditional_ABE_Scenario (N : Node_Id) return Boolean; |
4580 | pragma Inline (Is_Conditional_ABE_Scenario); | |
4581 | -- Determine whether node N is a suitable scenario for conditional ABE | |
4582 | -- checks and diagnostics. | |
4583 | ||
4584 | procedure Process_Conditional_ABE_Access_Taken | |
4585 | (Attr : Node_Id; | |
4586 | Attr_Rep : Scenario_Rep_Id; | |
4587 | In_State : Processing_In_State); | |
4588 | pragma Inline (Process_Conditional_ABE_Access_Taken); | |
4589 | -- Perform ABE checks and diagnostics for attribute reference Attr with | |
4590 | -- representation Attr_Rep which takes 'Access of an entry, operator, or | |
4591 | -- subprogram. In_State is the current state of the Processing phase. | |
4592 | ||
4593 | procedure Process_Conditional_ABE_Activation | |
4594 | (Call : Node_Id; | |
4595 | Call_Rep : Scenario_Rep_Id; | |
4596 | Obj_Id : Entity_Id; | |
4597 | Obj_Rep : Target_Rep_Id; | |
4598 | Task_Typ : Entity_Id; | |
4599 | Task_Rep : Target_Rep_Id; | |
4600 | In_State : Processing_In_State); | |
4601 | pragma Inline (Process_Conditional_ABE_Activation); | |
4602 | -- Perform common conditional ABE checks and diagnostics for activation | |
4603 | -- call Call which activates object Obj_Id of task type Task_Typ. Formal | |
4604 | -- Call_Rep denotes the representation of the call. Obj_Rep denotes the | |
4605 | -- representation of the object. Task_Rep denotes the representation of | |
4606 | -- the task type. In_State is the current state of the Processing phase. | |
4607 | ||
4608 | procedure Process_Conditional_ABE_Call | |
4609 | (Call : Node_Id; | |
4610 | Call_Rep : Scenario_Rep_Id; | |
4611 | In_State : Processing_In_State); | |
4612 | pragma Inline (Process_Conditional_ABE_Call); | |
4613 | -- Top-level dispatcher for processing of calls. Perform ABE checks and | |
4614 | -- diagnostics for call Call with representation Call_Rep. In_State is | |
4615 | -- the current state of the Processing phase. | |
4616 | ||
4617 | procedure Process_Conditional_ABE_Call_Ada | |
4618 | (Call : Node_Id; | |
4619 | Call_Rep : Scenario_Rep_Id; | |
4620 | Subp_Id : Entity_Id; | |
4621 | Subp_Rep : Target_Rep_Id; | |
4622 | In_State : Processing_In_State); | |
4623 | pragma Inline (Process_Conditional_ABE_Call_Ada); | |
4624 | -- Perform ABE checks and diagnostics for call Call which invokes entry, | |
4625 | -- operator, or subprogram Subp_Id using the Ada rules. Call_Rep denotes | |
4626 | -- the representation of the call. Subp_Rep denotes the representation | |
4627 | -- of the subprogram. In_State is the current state of the Processing | |
4628 | -- phase. | |
4629 | ||
4630 | procedure Process_Conditional_ABE_Call_SPARK | |
4631 | (Call : Node_Id; | |
4632 | Call_Rep : Scenario_Rep_Id; | |
4633 | Subp_Id : Entity_Id; | |
4634 | Subp_Rep : Target_Rep_Id; | |
4635 | In_State : Processing_In_State); | |
4636 | pragma Inline (Process_Conditional_ABE_Call_SPARK); | |
4637 | -- Perform ABE checks and diagnostics for call Call which invokes entry, | |
4638 | -- operator, or subprogram Subp_Id using the SPARK rules. Call_Rep is | |
4639 | -- the representation of the call. Subp_Rep denotes the representation | |
4640 | -- of the subprogram. In_State is the current state of the Processing | |
4641 | -- phase. | |
4642 | ||
4643 | procedure Process_Conditional_ABE_Instantiation | |
4644 | (Inst : Node_Id; | |
4645 | Inst_Rep : Scenario_Rep_Id; | |
4646 | In_State : Processing_In_State); | |
4647 | pragma Inline (Process_Conditional_ABE_Instantiation); | |
4648 | -- Top-level dispatcher for processing of instantiations. Perform ABE | |
4649 | -- checks and diagnostics for instantiation Inst with representation | |
4650 | -- Inst_Rep. In_State is the current state of the Processing phase. | |
4651 | ||
4652 | procedure Process_Conditional_ABE_Instantiation_Ada | |
4653 | (Inst : Node_Id; | |
4654 | Inst_Rep : Scenario_Rep_Id; | |
4655 | Gen_Id : Entity_Id; | |
4656 | Gen_Rep : Target_Rep_Id; | |
4657 | In_State : Processing_In_State); | |
4658 | pragma Inline (Process_Conditional_ABE_Instantiation_Ada); | |
4659 | -- Perform ABE checks and diagnostics for instantiation Inst of generic | |
4660 | -- Gen_Id using the Ada rules. Inst_Rep denotes the representation of | |
4661 | -- the instnace. Gen_Rep is the representation of the generic. In_State | |
4662 | -- is the current state of the Processing phase. | |
4663 | ||
4664 | procedure Process_Conditional_ABE_Instantiation_SPARK | |
4665 | (Inst : Node_Id; | |
4666 | Inst_Rep : Scenario_Rep_Id; | |
4667 | Gen_Id : Entity_Id; | |
4668 | Gen_Rep : Target_Rep_Id; | |
4669 | In_State : Processing_In_State); | |
4670 | pragma Inline (Process_Conditional_ABE_Instantiation_SPARK); | |
4671 | -- Perform ABE checks and diagnostics for instantiation Inst of generic | |
4672 | -- Gen_Id using the SPARK rules. Inst_Rep denotes the representation of | |
4673 | -- the instnace. Gen_Rep is the representation of the generic. In_State | |
4674 | -- is the current state of the Processing phase. | |
4675 | ||
4676 | procedure Process_Conditional_ABE_Variable_Assignment | |
4677 | (Asmt : Node_Id; | |
4678 | Asmt_Rep : Scenario_Rep_Id; | |
4679 | In_State : Processing_In_State); | |
4680 | pragma Inline (Process_Conditional_ABE_Variable_Assignment); | |
4681 | -- Top-level dispatcher for processing of variable assignments. Perform | |
4682 | -- ABE checks and diagnostics for assignment Asmt with representation | |
4683 | -- Asmt_Rep. In_State denotes the current state of the Processing phase. | |
4684 | ||
4685 | procedure Process_Conditional_ABE_Variable_Assignment_Ada | |
4686 | (Asmt : Node_Id; | |
4687 | Asmt_Rep : Scenario_Rep_Id; | |
4688 | Var_Id : Entity_Id; | |
4689 | Var_Rep : Target_Rep_Id; | |
4690 | In_State : Processing_In_State); | |
4691 | pragma Inline (Process_Conditional_ABE_Variable_Assignment_Ada); | |
4692 | -- Perform ABE checks and diagnostics for assignment statement Asmt that | |
4693 | -- modifies the value of variable Var_Id using the Ada rules. Asmt_Rep | |
4694 | -- denotes the representation of the assignment. Var_Rep denotes the | |
4695 | -- representation of the variable. In_State is the current state of the | |
4696 | -- Processing phase. | |
4697 | ||
4698 | procedure Process_Conditional_ABE_Variable_Assignment_SPARK | |
4699 | (Asmt : Node_Id; | |
4700 | Asmt_Rep : Scenario_Rep_Id; | |
4701 | Var_Id : Entity_Id; | |
4702 | Var_Rep : Target_Rep_Id; | |
4703 | In_State : Processing_In_State); | |
4704 | pragma Inline (Process_Conditional_ABE_Variable_Assignment_SPARK); | |
4705 | -- Perform ABE checks and diagnostics for assignment statement Asmt that | |
4706 | -- modifies the value of variable Var_Id using the SPARK rules. Asmt_Rep | |
4707 | -- denotes the representation of the assignment. Var_Rep denotes the | |
4708 | -- representation of the variable. In_State is the current state of the | |
4709 | -- Processing phase. | |
4710 | ||
4711 | procedure Process_Conditional_ABE_Variable_Reference | |
4712 | (Ref : Node_Id; | |
4713 | Ref_Rep : Scenario_Rep_Id; | |
4714 | In_State : Processing_In_State); | |
4715 | pragma Inline (Process_Conditional_ABE_Variable_Reference); | |
4716 | -- Perform ABE checks and diagnostics for variable reference Ref with | |
4717 | -- representation Ref_Rep. In_State denotes the current state of the | |
4718 | -- Processing phase. | |
4719 | ||
4720 | procedure Traverse_Conditional_ABE_Body | |
4721 | (N : Node_Id; | |
4722 | In_State : Processing_In_State); | |
4723 | pragma Inline (Traverse_Conditional_ABE_Body); | |
4724 | -- Traverse subprogram body N looking for suitable scenarios that need | |
4725 | -- to be processed for conditional ABE checks and diagnostics. In_State | |
4726 | -- is the current state of the Processing phase. | |
4727 | ||
4728 | ------------------------------------- | |
4729 | -- Check_Conditional_ABE_Scenarios -- | |
4730 | ------------------------------------- | |
4731 | ||
4732 | procedure Check_Conditional_ABE_Scenarios | |
4733 | (Iter : in out NE_Set.Iterator) | |
4734 | is | |
4735 | N : Node_Id; | |
90e491a7 | 4736 | |
69e6ee2f HK |
4737 | begin |
4738 | while NE_Set.Has_Next (Iter) loop | |
4739 | NE_Set.Next (Iter, N); | |
90e491a7 | 4740 | |
69e6ee2f HK |
4741 | -- Reset the traversed status of all subprogram bodies because the |
4742 | -- current conditional scenario acts as a new DFS traversal root. | |
90e491a7 | 4743 | |
69e6ee2f | 4744 | Reset_Traversed_Bodies; |
90e491a7 | 4745 | |
69e6ee2f HK |
4746 | Process_Conditional_ABE |
4747 | (N => N, | |
4748 | In_State => Conditional_ABE_State); | |
4749 | end loop; | |
4750 | end Check_Conditional_ABE_Scenarios; | |
90e491a7 | 4751 | |
69e6ee2f HK |
4752 | --------------------------------- |
4753 | -- Is_Conditional_ABE_Scenario -- | |
4754 | --------------------------------- | |
90e491a7 | 4755 | |
69e6ee2f HK |
4756 | function Is_Conditional_ABE_Scenario (N : Node_Id) return Boolean is |
4757 | begin | |
4758 | return | |
4759 | Is_Suitable_Access_Taken (N) | |
4760 | or else Is_Suitable_Call (N) | |
4761 | or else Is_Suitable_Instantiation (N) | |
4762 | or else Is_Suitable_Variable_Assignment (N) | |
4763 | or else Is_Suitable_Variable_Reference (N); | |
4764 | end Is_Conditional_ABE_Scenario; | |
90e491a7 | 4765 | |
69e6ee2f HK |
4766 | ----------------------------- |
4767 | -- Process_Conditional_ABE -- | |
4768 | ----------------------------- | |
90e491a7 | 4769 | |
69e6ee2f HK |
4770 | procedure Process_Conditional_ABE |
4771 | (N : Node_Id; | |
4772 | In_State : Processing_In_State) | |
4773 | is | |
4774 | Scen : constant Node_Id := Scenario (N); | |
4775 | Scen_Rep : Scenario_Rep_Id; | |
90e491a7 | 4776 | |
69e6ee2f HK |
4777 | begin |
4778 | -- Add the current scenario to the stack of active scenarios | |
90e491a7 | 4779 | |
69e6ee2f | 4780 | Push_Active_Scenario (Scen); |
90e491a7 | 4781 | |
69e6ee2f | 4782 | -- 'Access |
90e491a7 | 4783 | |
69e6ee2f HK |
4784 | if Is_Suitable_Access_Taken (Scen) then |
4785 | Process_Conditional_ABE_Access_Taken | |
4786 | (Attr => Scen, | |
4787 | Attr_Rep => Scenario_Representation_Of (Scen, In_State), | |
4788 | In_State => In_State); | |
90e491a7 | 4789 | |
69e6ee2f | 4790 | -- Call or task activation |
90e491a7 | 4791 | |
69e6ee2f HK |
4792 | elsif Is_Suitable_Call (Scen) then |
4793 | Scen_Rep := Scenario_Representation_Of (Scen, In_State); | |
90e491a7 | 4794 | |
69e6ee2f HK |
4795 | -- Routine Build_Call_Marker creates call markers regardless of |
4796 | -- whether the call occurs within the main unit or not. This way | |
4797 | -- the serialization of internal names is kept consistent. Only | |
4798 | -- call markers found within the main unit must be processed. | |
90e491a7 | 4799 | |
69e6ee2f HK |
4800 | if In_Main_Context (Scen) then |
4801 | Scen_Rep := Scenario_Representation_Of (Scen, In_State); | |
daf82dd8 | 4802 | |
69e6ee2f HK |
4803 | if Kind (Scen_Rep) = Call_Scenario then |
4804 | Process_Conditional_ABE_Call | |
4805 | (Call => Scen, | |
4806 | Call_Rep => Scen_Rep, | |
4807 | In_State => In_State); | |
daf82dd8 | 4808 | |
69e6ee2f HK |
4809 | else |
4810 | pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); | |
daf82dd8 | 4811 | |
69e6ee2f HK |
4812 | Process_Activation |
4813 | (Call => Scen, | |
4814 | Call_Rep => Scen_Rep, | |
4815 | Processor => Process_Conditional_ABE_Activation'Access, | |
4816 | In_State => In_State); | |
4817 | end if; | |
4818 | end if; | |
daf82dd8 | 4819 | |
69e6ee2f | 4820 | -- Instantiation |
daf82dd8 | 4821 | |
69e6ee2f HK |
4822 | elsif Is_Suitable_Instantiation (Scen) then |
4823 | Process_Conditional_ABE_Instantiation | |
4824 | (Inst => Scen, | |
4825 | Inst_Rep => Scenario_Representation_Of (Scen, In_State), | |
4826 | In_State => In_State); | |
daf82dd8 | 4827 | |
69e6ee2f | 4828 | -- Variable assignments |
daf82dd8 | 4829 | |
69e6ee2f HK |
4830 | elsif Is_Suitable_Variable_Assignment (Scen) then |
4831 | Process_Conditional_ABE_Variable_Assignment | |
4832 | (Asmt => Scen, | |
4833 | Asmt_Rep => Scenario_Representation_Of (Scen, In_State), | |
4834 | In_State => In_State); | |
daf82dd8 | 4835 | |
69e6ee2f | 4836 | -- Variable references |
daf82dd8 | 4837 | |
69e6ee2f | 4838 | elsif Is_Suitable_Variable_Reference (Scen) then |
daf82dd8 | 4839 | |
69e6ee2f HK |
4840 | -- Routine Build_Variable_Reference_Marker makes variable markers |
4841 | -- regardless of whether the reference occurs within the main unit | |
4842 | -- or not. This way the serialization of internal names is kept | |
4843 | -- consistent. Only variable markers within the main unit must be | |
4844 | -- processed. | |
90e491a7 | 4845 | |
69e6ee2f HK |
4846 | if In_Main_Context (Scen) then |
4847 | Process_Conditional_ABE_Variable_Reference | |
4848 | (Ref => Scen, | |
4849 | Ref_Rep => Scenario_Representation_Of (Scen, In_State), | |
4850 | In_State => In_State); | |
4851 | end if; | |
4852 | end if; | |
967947ed | 4853 | |
69e6ee2f HK |
4854 | -- Remove the current scenario from the stack of active scenarios |
4855 | -- once all ABE diagnostics and checks have been performed. | |
967947ed | 4856 | |
69e6ee2f HK |
4857 | Pop_Active_Scenario (Scen); |
4858 | end Process_Conditional_ABE; | |
90e491a7 | 4859 | |
69e6ee2f HK |
4860 | ------------------------------------------ |
4861 | -- Process_Conditional_ABE_Access_Taken -- | |
4862 | ------------------------------------------ | |
90e491a7 | 4863 | |
69e6ee2f HK |
4864 | procedure Process_Conditional_ABE_Access_Taken |
4865 | (Attr : Node_Id; | |
4866 | Attr_Rep : Scenario_Rep_Id; | |
4867 | In_State : Processing_In_State) | |
4868 | is | |
4869 | function Build_Access_Marker (Subp_Id : Entity_Id) return Node_Id; | |
4870 | pragma Inline (Build_Access_Marker); | |
4871 | -- Create a suitable call marker which invokes subprogram Subp_Id | |
7255f3c3 | 4872 | |
69e6ee2f HK |
4873 | ------------------------- |
4874 | -- Build_Access_Marker -- | |
4875 | ------------------------- | |
7255f3c3 | 4876 | |
69e6ee2f HK |
4877 | function Build_Access_Marker (Subp_Id : Entity_Id) return Node_Id is |
4878 | Marker : Node_Id; | |
90e491a7 | 4879 | |
69e6ee2f HK |
4880 | begin |
4881 | Marker := Make_Call_Marker (Sloc (Attr)); | |
90e491a7 | 4882 | |
69e6ee2f | 4883 | -- Inherit relevant attributes from the attribute |
90e491a7 | 4884 | |
69e6ee2f HK |
4885 | Set_Target (Marker, Subp_Id); |
4886 | Set_Is_Declaration_Level_Node | |
4887 | (Marker, Level (Attr_Rep) = Declaration_Level); | |
4888 | Set_Is_Dispatching_Call | |
4889 | (Marker, False); | |
4890 | Set_Is_Elaboration_Checks_OK_Node | |
4891 | (Marker, Elaboration_Checks_OK (Attr_Rep)); | |
4892 | Set_Is_Elaboration_Warnings_OK_Node | |
4893 | (Marker, Elaboration_Warnings_OK (Attr_Rep)); | |
4894 | Set_Is_Source_Call | |
4895 | (Marker, Comes_From_Source (Attr)); | |
4896 | Set_Is_SPARK_Mode_On_Node | |
4897 | (Marker, SPARK_Mode_Of (Attr_Rep) = Is_On); | |
90e491a7 | 4898 | |
69e6ee2f HK |
4899 | -- Partially insert the call marker into the tree by setting its |
4900 | -- parent pointer. | |
90e491a7 | 4901 | |
69e6ee2f | 4902 | Set_Parent (Marker, Attr); |
90e491a7 | 4903 | |
69e6ee2f HK |
4904 | return Marker; |
4905 | end Build_Access_Marker; | |
90e491a7 | 4906 | |
69e6ee2f | 4907 | -- Local variables |
90e491a7 | 4908 | |
69e6ee2f HK |
4909 | Root : constant Node_Id := Root_Scenario; |
4910 | Subp_Id : constant Entity_Id := Target (Attr_Rep); | |
4911 | Subp_Rep : constant Target_Rep_Id := | |
4912 | Target_Representation_Of (Subp_Id, In_State); | |
4913 | Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); | |
90e491a7 | 4914 | |
69e6ee2f HK |
4915 | New_In_State : Processing_In_State := In_State; |
4916 | -- Each step of the Processing phase constitutes a new state | |
90e491a7 | 4917 | |
69e6ee2f | 4918 | -- Start of processing for Process_Conditional_ABE_Access |
90e491a7 PMR |
4919 | |
4920 | begin | |
69e6ee2f HK |
4921 | -- Output relevant information when switch -gnatel (info messages on |
4922 | -- implicit Elaborate[_All] pragmas) is in effect. | |
90e491a7 | 4923 | |
69e6ee2f HK |
4924 | if Elab_Info_Messages |
4925 | and then not New_In_State.Suppress_Info_Messages | |
90e491a7 | 4926 | then |
69e6ee2f HK |
4927 | Error_Msg_NE |
4928 | ("info: access to & during elaboration", Attr, Subp_Id); | |
4929 | end if; | |
90e491a7 | 4930 | |
69e6ee2f HK |
4931 | -- Warnings are suppressed when a prior scenario is already in that |
4932 | -- mode or when the attribute or the target have warnings suppressed. | |
4933 | -- Update the state of the Processing phase to reflect this. | |
4934 | ||
4935 | New_In_State.Suppress_Warnings := | |
4936 | New_In_State.Suppress_Warnings | |
4937 | or else not Elaboration_Warnings_OK (Attr_Rep) | |
4938 | or else not Elaboration_Warnings_OK (Subp_Rep); | |
4939 | ||
4940 | -- Do not emit any ABE diagnostics when the current or previous | |
4941 | -- scenario in this traversal has suppressed elaboration warnings. | |
4942 | ||
4943 | if New_In_State.Suppress_Warnings then | |
4944 | null; | |
4945 | ||
4946 | -- Both the attribute and the corresponding subprogram body are in | |
4947 | -- the same unit. The body must appear prior to the root scenario | |
4948 | -- which started the recursive search. If this is not the case, then | |
4949 | -- there is a potential ABE if the access value is used to call the | |
4950 | -- subprogram. Emit a warning only when switch -gnatw.f (warnings on | |
4951 | -- suspucious 'Access) is in effect. | |
4952 | ||
4953 | elsif Warn_On_Elab_Access | |
4954 | and then Present (Body_Decl) | |
4955 | and then In_Extended_Main_Code_Unit (Body_Decl) | |
4956 | and then Earlier_In_Extended_Unit (Root, Body_Decl) | |
4957 | then | |
4958 | Error_Msg_Name_1 := Attribute_Name (Attr); | |
4959 | Error_Msg_NE | |
4960 | ("??% attribute of & before body seen", Attr, Subp_Id); | |
4961 | Error_Msg_N ("\possible Program_Error on later references", Attr); | |
4962 | ||
4963 | Output_Active_Scenarios (Attr, New_In_State); | |
4964 | end if; | |
4965 | ||
604801a4 | 4966 | -- Treat the attribute an immediate invocation of the target when |
69e6ee2f HK |
4967 | -- switch -gnatd.o (conservative elaboration order for indirect |
4968 | -- calls) is in effect. This has the following desirable effects: | |
4969 | -- | |
4970 | -- * Ensure that the unit with the corresponding body is elaborated | |
4971 | -- prior to the main unit. | |
4972 | -- | |
4973 | -- * Perform conditional ABE checks and diagnostics | |
4974 | -- | |
4975 | -- * Traverse the body of the target (if available) | |
4976 | ||
4977 | if Debug_Flag_Dot_O then | |
4978 | Process_Conditional_ABE | |
4979 | (N => Build_Access_Marker (Subp_Id), | |
4980 | In_State => New_In_State); | |
4981 | ||
4982 | -- Otherwise ensure that the unit with the corresponding body is | |
4983 | -- elaborated prior to the main unit. | |
90e491a7 PMR |
4984 | |
4985 | else | |
69e6ee2f HK |
4986 | Ensure_Prior_Elaboration |
4987 | (N => Attr, | |
4988 | Unit_Id => Unit (Subp_Rep), | |
4989 | Prag_Nam => Name_Elaborate_All, | |
4990 | In_State => New_In_State); | |
90e491a7 | 4991 | end if; |
69e6ee2f | 4992 | end Process_Conditional_ABE_Access_Taken; |
90e491a7 | 4993 | |
69e6ee2f HK |
4994 | ---------------------------------------- |
4995 | -- Process_Conditional_ABE_Activation -- | |
4996 | ---------------------------------------- | |
90e491a7 | 4997 | |
69e6ee2f HK |
4998 | procedure Process_Conditional_ABE_Activation |
4999 | (Call : Node_Id; | |
5000 | Call_Rep : Scenario_Rep_Id; | |
5001 | Obj_Id : Entity_Id; | |
5002 | Obj_Rep : Target_Rep_Id; | |
5003 | Task_Typ : Entity_Id; | |
5004 | Task_Rep : Target_Rep_Id; | |
5005 | In_State : Processing_In_State) | |
5006 | is | |
5007 | pragma Unreferenced (Task_Typ); | |
5008 | ||
5009 | Body_Decl : constant Node_Id := Body_Declaration (Task_Rep); | |
5010 | Spec_Decl : constant Node_Id := Spec_Declaration (Task_Rep); | |
5011 | Root : constant Node_Id := Root_Scenario; | |
5012 | Unit_Id : constant Node_Id := Unit (Task_Rep); | |
5013 | ||
5014 | Check_OK : constant Boolean := | |
5015 | not In_State.Suppress_Checks | |
5016 | and then Ghost_Mode_Of (Obj_Rep) /= Is_Ignored | |
5017 | and then Ghost_Mode_Of (Task_Rep) /= Is_Ignored | |
5018 | and then Elaboration_Checks_OK (Obj_Rep) | |
5019 | and then Elaboration_Checks_OK (Task_Rep); | |
5020 | -- A run-time ABE check may be installed only when the object and the | |
5021 | -- task type have active elaboration checks, and both are not ignored | |
5022 | -- Ghost constructs. | |
5023 | ||
5024 | New_In_State : Processing_In_State := In_State; | |
5025 | -- Each step of the Processing phase constitutes a new state | |
90e491a7 | 5026 | |
69e6ee2f HK |
5027 | begin |
5028 | -- Output relevant information when switch -gnatel (info messages on | |
5029 | -- implicit Elaborate[_All] pragmas) is in effect. | |
90e491a7 | 5030 | |
69e6ee2f HK |
5031 | if Elab_Info_Messages |
5032 | and then not New_In_State.Suppress_Info_Messages | |
5033 | then | |
5034 | Error_Msg_NE | |
5035 | ("info: activation of & during elaboration", Call, Obj_Id); | |
5036 | end if; | |
90e491a7 | 5037 | |
69e6ee2f HK |
5038 | -- Nothing to do when the call activates a task whose type is defined |
5039 | -- within an instance and switch -gnatd_i (ignore activations and | |
5040 | -- calls to instances for elaboration) is in effect. | |
90e491a7 | 5041 | |
69e6ee2f HK |
5042 | if Debug_Flag_Underscore_I |
5043 | and then In_External_Instance | |
5044 | (N => Call, | |
5045 | Target_Decl => Spec_Decl) | |
5046 | then | |
5047 | return; | |
90e491a7 | 5048 | |
69e6ee2f | 5049 | -- Nothing to do when the activation is a guaranteed ABE |
90e491a7 | 5050 | |
69e6ee2f HK |
5051 | elsif Is_Known_Guaranteed_ABE (Call) then |
5052 | return; | |
90e491a7 | 5053 | |
69e6ee2f HK |
5054 | -- Nothing to do when the root scenario appears at the declaration |
5055 | -- level and the task is in the same unit, but outside this context. | |
5056 | -- | |
5057 | -- task type Task_Typ; -- task declaration | |
5058 | -- | |
5059 | -- procedure Proc is | |
5060 | -- function A ... is | |
5061 | -- begin | |
5062 | -- if Some_Condition then | |
5063 | -- declare | |
5064 | -- T : Task_Typ; | |
5065 | -- begin | |
5066 | -- <activation call> -- activation site | |
5067 | -- end; | |
5068 | -- ... | |
5069 | -- end A; | |
5070 | -- | |
5071 | -- X : ... := A; -- root scenario | |
5072 | -- ... | |
5073 | -- | |
5074 | -- task body Task_Typ is | |
5075 | -- ... | |
5076 | -- end Task_Typ; | |
5077 | -- | |
5078 | -- In the example above, the context of X is the declarative list of | |
5079 | -- Proc. The "elaboration" of X may reach the activation of T whose | |
5080 | -- body is defined outside of X's context. The task body is relevant | |
5081 | -- only when Proc is invoked, but this happens only during "normal" | |
5082 | -- elaboration, therefore the task body must not be considered if | |
5083 | -- this is not the case. | |
5084 | ||
5085 | elsif Is_Up_Level_Target | |
5086 | (Targ_Decl => Spec_Decl, | |
5087 | In_State => New_In_State) | |
5088 | then | |
5089 | return; | |
90e491a7 | 5090 | |
69e6ee2f HK |
5091 | -- Nothing to do when the activation is ABE-safe |
5092 | -- | |
5093 | -- generic | |
5094 | -- package Gen is | |
5095 | -- task type Task_Typ; | |
5096 | -- end Gen; | |
5097 | -- | |
5098 | -- package body Gen is | |
5099 | -- task body Task_Typ is | |
5100 | -- begin | |
5101 | -- ... | |
5102 | -- end Task_Typ; | |
5103 | -- end Gen; | |
5104 | -- | |
5105 | -- with Gen; | |
5106 | -- procedure Main is | |
5107 | -- package Nested is | |
5108 | -- package Inst is new Gen; | |
5109 | -- T : Inst.Task_Typ; | |
5110 | -- <activation call> -- safe activation | |
5111 | -- end Nested; | |
5112 | -- ... | |
90e491a7 | 5113 | |
69e6ee2f | 5114 | elsif Is_Safe_Activation (Call, Task_Rep) then |
90e491a7 | 5115 | |
69e6ee2f HK |
5116 | -- Note that the task body must still be examined for any nested |
5117 | -- scenarios. | |
90e491a7 | 5118 | |
69e6ee2f | 5119 | null; |
90e491a7 | 5120 | |
69e6ee2f HK |
5121 | -- The activation call and the task body are both in the main unit |
5122 | -- | |
5123 | -- If the root scenario appears prior to the task body, then this is | |
5124 | -- a possible ABE with respect to the root scenario. | |
5125 | -- | |
5126 | -- task type Task_Typ; | |
5127 | -- | |
5128 | -- function A ... is | |
5129 | -- begin | |
5130 | -- if Some_Condition then | |
5131 | -- declare | |
5132 | -- package Pack is | |
5133 | -- T : Task_Typ; | |
5134 | -- end Pack; -- activation of T | |
5135 | -- ... | |
5136 | -- end A; | |
5137 | -- | |
5138 | -- X : ... := A; -- root scenario | |
5139 | -- | |
5140 | -- task body Task_Typ is -- task body | |
5141 | -- ... | |
5142 | -- end Task_Typ; | |
5143 | -- | |
5144 | -- Y : ... := A; -- root scenario | |
5145 | -- | |
5146 | -- IMPORTANT: The activation of T is a possible ABE for X, but | |
5147 | -- not for Y. Intalling an unconditional ABE raise prior to the | |
5148 | -- activation call would be wrong as it will fail for Y as well | |
5149 | -- but in Y's case the activation of T is never an ABE. | |
90e491a7 | 5150 | |
69e6ee2f HK |
5151 | elsif Present (Body_Decl) |
5152 | and then In_Extended_Main_Code_Unit (Body_Decl) | |
5153 | then | |
5154 | if Earlier_In_Extended_Unit (Root, Body_Decl) then | |
90e491a7 | 5155 | |
69e6ee2f HK |
5156 | -- Do not emit any ABE diagnostics when a previous scenario in |
5157 | -- this traversal has suppressed elaboration warnings. | |
90e491a7 | 5158 | |
69e6ee2f HK |
5159 | if New_In_State.Suppress_Warnings then |
5160 | null; | |
90e491a7 | 5161 | |
69e6ee2f HK |
5162 | -- Do not emit any ABE diagnostics when the activation occurs |
5163 | -- in a partial finalization context because this action leads | |
5164 | -- to confusing noise. | |
90e491a7 | 5165 | |
69e6ee2f HK |
5166 | elsif New_In_State.Within_Partial_Finalization then |
5167 | null; | |
90e491a7 | 5168 | |
69e6ee2f | 5169 | -- Otherwise emit the ABE disgnostic |
90e491a7 | 5170 | |
69e6ee2f HK |
5171 | else |
5172 | Error_Msg_Sloc := Sloc (Call); | |
5173 | Error_Msg_N | |
5174 | ("??task & will be activated # before elaboration of its " | |
5175 | & "body", Obj_Id); | |
5176 | Error_Msg_N | |
5177 | ("\Program_Error may be raised at run time", Obj_Id); | |
5178 | ||
5179 | Output_Active_Scenarios (Obj_Id, New_In_State); | |
5180 | end if; | |
90e491a7 | 5181 | |
69e6ee2f HK |
5182 | -- Install a conditional run-time ABE check to verify that the |
5183 | -- task body has been elaborated prior to the activation call. | |
5184 | ||
5185 | if Check_OK then | |
5186 | Install_Scenario_ABE_Check | |
5187 | (N => Call, | |
5188 | Targ_Id => Defining_Entity (Spec_Decl), | |
5189 | Targ_Rep => Task_Rep, | |
5190 | Disable => Obj_Rep); | |
5191 | ||
5192 | -- Update the state of the Processing phase to indicate that | |
5193 | -- no implicit Elaborate[_All] pragma must be generated from | |
5194 | -- this point on. | |
5195 | -- | |
5196 | -- task type Task_Typ; | |
5197 | -- | |
5198 | -- function A ... is | |
5199 | -- begin | |
5200 | -- if Some_Condition then | |
5201 | -- declare | |
5202 | -- package Pack is | |
5203 | -- <ABE check> | |
5204 | -- T : Task_Typ; | |
5205 | -- end Pack; -- activation of T | |
5206 | -- ... | |
5207 | -- end A; | |
5208 | -- | |
5209 | -- X : ... := A; | |
5210 | -- | |
5211 | -- task body Task_Typ is | |
5212 | -- begin | |
5213 | -- External.Subp; -- imparts Elaborate_All | |
5214 | -- end Task_Typ; | |
5215 | -- | |
5216 | -- If Some_Condition is True, then the ABE check will fail | |
5217 | -- at runtime and the call to External.Subp will never take | |
5218 | -- place, rendering the implicit Elaborate_All useless. | |
5219 | -- | |
5220 | -- If the value of Some_Condition is False, then the call | |
5221 | -- to External.Subp will never take place, rendering the | |
5222 | -- implicit Elaborate_All useless. | |
5223 | ||
5224 | New_In_State.Suppress_Implicit_Pragmas := True; | |
5225 | end if; | |
5226 | end if; | |
90e491a7 | 5227 | |
69e6ee2f HK |
5228 | -- Otherwise the task body is not available in this compilation or |
5229 | -- it resides in an external unit. Install a run-time ABE check to | |
5230 | -- verify that the task body has been elaborated prior to the | |
5231 | -- activation call when the dynamic model is in effect. | |
90e491a7 | 5232 | |
69e6ee2f HK |
5233 | elsif Check_OK |
5234 | and then New_In_State.Processing = Dynamic_Model_Processing | |
5235 | then | |
5236 | Install_Unit_ABE_Check | |
5237 | (N => Call, | |
5238 | Unit_Id => Unit_Id, | |
5239 | Disable => Obj_Rep); | |
5240 | end if; | |
fb9dd1c7 | 5241 | |
69e6ee2f HK |
5242 | -- Both the activation call and task type are subject to SPARK_Mode |
5243 | -- On, this triggers the SPARK rules for task activation. Compared | |
5244 | -- to calls and instantiations, task activation in SPARK does not | |
5245 | -- require the presence of Elaborate[_All] pragmas in case the task | |
5246 | -- type is defined outside the main unit. This is because SPARK uses | |
5247 | -- a special policy which activates all tasks after the main unit has | |
5248 | -- finished its elaboration. | |
fb9dd1c7 | 5249 | |
69e6ee2f HK |
5250 | if SPARK_Mode_Of (Call_Rep) = Is_On |
5251 | and then SPARK_Mode_Of (Task_Rep) = Is_On | |
5252 | then | |
5253 | null; | |
fb9dd1c7 | 5254 | |
69e6ee2f HK |
5255 | -- Otherwise the Ada rules are in effect. Ensure that the unit with |
5256 | -- the task body is elaborated prior to the main unit. | |
7a500fd7 | 5257 | |
69e6ee2f HK |
5258 | else |
5259 | Ensure_Prior_Elaboration | |
5260 | (N => Call, | |
5261 | Unit_Id => Unit_Id, | |
5262 | Prag_Nam => Name_Elaborate_All, | |
5263 | In_State => New_In_State); | |
7a500fd7 HK |
5264 | end if; |
5265 | ||
69e6ee2f HK |
5266 | Traverse_Conditional_ABE_Body |
5267 | (N => Body_Decl, | |
5268 | In_State => New_In_State); | |
5269 | end Process_Conditional_ABE_Activation; | |
90e491a7 | 5270 | |
69e6ee2f HK |
5271 | ---------------------------------- |
5272 | -- Process_Conditional_ABE_Call -- | |
5273 | ---------------------------------- | |
90e491a7 | 5274 | |
69e6ee2f HK |
5275 | procedure Process_Conditional_ABE_Call |
5276 | (Call : Node_Id; | |
5277 | Call_Rep : Scenario_Rep_Id; | |
5278 | In_State : Processing_In_State) | |
5279 | is | |
5280 | function In_Initialization_Context (N : Node_Id) return Boolean; | |
5281 | pragma Inline (In_Initialization_Context); | |
5282 | -- Determine whether arbitrary node N appears within a type init | |
5283 | -- proc, primitive [Deep_]Initialize, or a block created for | |
5284 | -- initialization purposes. | |
5285 | ||
5286 | function Is_Partial_Finalization_Proc | |
5287 | (Subp_Id : Entity_Id) return Boolean; | |
5288 | pragma Inline (Is_Partial_Finalization_Proc); | |
5289 | -- Determine whether subprogram Subp_Id is a partial finalization | |
5290 | -- procedure. | |
90e491a7 | 5291 | |
69e6ee2f HK |
5292 | ------------------------------- |
5293 | -- In_Initialization_Context -- | |
5294 | ------------------------------- | |
90e491a7 | 5295 | |
69e6ee2f HK |
5296 | function In_Initialization_Context (N : Node_Id) return Boolean is |
5297 | Par : Node_Id; | |
5298 | Spec_Id : Entity_Id; | |
90e491a7 | 5299 | |
69e6ee2f HK |
5300 | begin |
5301 | -- Climb the parent chain looking for initialization actions | |
90e491a7 | 5302 | |
69e6ee2f HK |
5303 | Par := Parent (N); |
5304 | while Present (Par) loop | |
8dce7371 | 5305 | |
69e6ee2f HK |
5306 | -- A block may be part of the initialization actions of a |
5307 | -- default initialized object. | |
90e491a7 | 5308 | |
69e6ee2f HK |
5309 | if Nkind (Par) = N_Block_Statement |
5310 | and then Is_Initialization_Block (Par) | |
5311 | then | |
5312 | return True; | |
90e491a7 | 5313 | |
69e6ee2f | 5314 | -- A subprogram body may denote an initialization routine |
90e491a7 | 5315 | |
69e6ee2f HK |
5316 | elsif Nkind (Par) = N_Subprogram_Body then |
5317 | Spec_Id := Unique_Defining_Entity (Par); | |
90e491a7 | 5318 | |
69e6ee2f HK |
5319 | -- The current subprogram body denotes a type init proc or |
5320 | -- primitive [Deep_]Initialize. | |
90e491a7 | 5321 | |
69e6ee2f HK |
5322 | if Is_Init_Proc (Spec_Id) |
5323 | or else Is_Controlled_Proc (Spec_Id, Name_Initialize) | |
5324 | or else Is_TSS (Spec_Id, TSS_Deep_Initialize) | |
5325 | then | |
5326 | return True; | |
5327 | end if; | |
90e491a7 | 5328 | |
69e6ee2f | 5329 | -- Prevent the search from going too far |
90e491a7 | 5330 | |
69e6ee2f HK |
5331 | elsif Is_Body_Or_Package_Declaration (Par) then |
5332 | exit; | |
5333 | end if; | |
90e491a7 | 5334 | |
69e6ee2f HK |
5335 | Par := Parent (Par); |
5336 | end loop; | |
90e491a7 | 5337 | |
69e6ee2f HK |
5338 | return False; |
5339 | end In_Initialization_Context; | |
90e491a7 | 5340 | |
69e6ee2f HK |
5341 | ---------------------------------- |
5342 | -- Is_Partial_Finalization_Proc -- | |
5343 | ---------------------------------- | |
90e491a7 | 5344 | |
69e6ee2f HK |
5345 | function Is_Partial_Finalization_Proc |
5346 | (Subp_Id : Entity_Id) return Boolean | |
5347 | is | |
5348 | begin | |
5349 | -- To qualify, the subprogram must denote a finalizer procedure | |
5350 | -- or primitive [Deep_]Finalize, and the call must appear within | |
5351 | -- an initialization context. | |
90e491a7 | 5352 | |
69e6ee2f HK |
5353 | return |
5354 | (Is_Controlled_Proc (Subp_Id, Name_Finalize) | |
5355 | or else Is_Finalizer_Proc (Subp_Id) | |
5356 | or else Is_TSS (Subp_Id, TSS_Deep_Finalize)) | |
5357 | and then In_Initialization_Context (Call); | |
5358 | end Is_Partial_Finalization_Proc; | |
90e491a7 | 5359 | |
69e6ee2f | 5360 | -- Local variables |
90e491a7 | 5361 | |
69e6ee2f HK |
5362 | Subp_Id : constant Entity_Id := Target (Call_Rep); |
5363 | Subp_Rep : constant Target_Rep_Id := | |
5364 | Target_Representation_Of (Subp_Id, In_State); | |
5365 | Subp_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); | |
90e491a7 | 5366 | |
69e6ee2f HK |
5367 | SPARK_Rules_On : constant Boolean := |
5368 | SPARK_Mode_Of (Call_Rep) = Is_On | |
5369 | and then SPARK_Mode_Of (Subp_Rep) = Is_On; | |
90e491a7 | 5370 | |
69e6ee2f HK |
5371 | New_In_State : Processing_In_State := In_State; |
5372 | -- Each step of the Processing phase constitutes a new state | |
90e491a7 | 5373 | |
69e6ee2f | 5374 | -- Start of processing for Process_Conditional_ABE_Call |
e5148da0 | 5375 | |
69e6ee2f HK |
5376 | begin |
5377 | -- Output relevant information when switch -gnatel (info messages on | |
5378 | -- implicit Elaborate[_All] pragmas) is in effect. | |
e5148da0 | 5379 | |
69e6ee2f HK |
5380 | if Elab_Info_Messages |
5381 | and then not New_In_State.Suppress_Info_Messages | |
5382 | then | |
5383 | Info_Call | |
5384 | (Call => Call, | |
5385 | Subp_Id => Subp_Id, | |
5386 | Info_Msg => True, | |
5387 | In_SPARK => SPARK_Rules_On); | |
5388 | end if; | |
90e491a7 | 5389 | |
69e6ee2f HK |
5390 | -- Check whether the invocation of an entry clashes with an existing |
5391 | -- restriction. This check is relevant only when the processing was | |
5392 | -- started from some library-level scenario. | |
90e491a7 | 5393 | |
69e6ee2f HK |
5394 | if Is_Protected_Entry (Subp_Id) then |
5395 | Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); | |
90e491a7 | 5396 | |
69e6ee2f HK |
5397 | elsif Is_Task_Entry (Subp_Id) then |
5398 | Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call); | |
90e491a7 | 5399 | |
69e6ee2f HK |
5400 | -- Task entry calls are never processed because the entry being |
5401 | -- invoked does not have a corresponding "body", it has a select. | |
90e491a7 | 5402 | |
69e6ee2f | 5403 | return; |
8dce7371 | 5404 | end if; |
90e491a7 | 5405 | |
69e6ee2f HK |
5406 | -- Nothing to do when the call invokes a target defined within an |
5407 | -- instance and switch -gnatd_i (ignore activations and calls to | |
5408 | -- instances for elaboration) is in effect. | |
90e491a7 | 5409 | |
69e6ee2f HK |
5410 | if Debug_Flag_Underscore_I |
5411 | and then In_External_Instance | |
5412 | (N => Call, | |
5413 | Target_Decl => Subp_Decl) | |
5414 | then | |
5415 | return; | |
90e491a7 | 5416 | |
69e6ee2f | 5417 | -- Nothing to do when the call is a guaranteed ABE |
90e491a7 | 5418 | |
69e6ee2f HK |
5419 | elsif Is_Known_Guaranteed_ABE (Call) then |
5420 | return; | |
90e491a7 | 5421 | |
69e6ee2f HK |
5422 | -- Nothing to do when the root scenario appears at the declaration |
5423 | -- level and the target is in the same unit but outside this context. | |
5424 | -- | |
5425 | -- function B ...; -- target declaration | |
5426 | -- | |
5427 | -- procedure Proc is | |
5428 | -- function A ... is | |
5429 | -- begin | |
5430 | -- if Some_Condition then | |
5431 | -- return B; -- call site | |
5432 | -- ... | |
5433 | -- end A; | |
5434 | -- | |
5435 | -- X : ... := A; -- root scenario | |
5436 | -- ... | |
5437 | -- | |
5438 | -- function B ... is | |
5439 | -- ... | |
5440 | -- end B; | |
5441 | -- | |
5442 | -- In the example above, the context of X is the declarative region | |
5443 | -- of Proc. The "elaboration" of X may eventually reach B which is | |
5444 | -- defined outside of X's context. B is relevant only when Proc is | |
5445 | -- invoked, but this happens only by means of "normal" elaboration, | |
5446 | -- therefore B must not be considered if this is not the case. | |
5447 | ||
5448 | elsif Is_Up_Level_Target | |
5449 | (Targ_Decl => Subp_Decl, | |
5450 | In_State => New_In_State) | |
5451 | then | |
5452 | return; | |
5453 | end if; | |
90e491a7 | 5454 | |
69e6ee2f HK |
5455 | -- Warnings are suppressed when a prior scenario is already in that |
5456 | -- mode, or the call or target have warnings suppressed. Update the | |
5457 | -- state of the Processing phase to reflect this. | |
90e491a7 | 5458 | |
69e6ee2f HK |
5459 | New_In_State.Suppress_Warnings := |
5460 | New_In_State.Suppress_Warnings | |
5461 | or else not Elaboration_Warnings_OK (Call_Rep) | |
5462 | or else not Elaboration_Warnings_OK (Subp_Rep); | |
90e491a7 | 5463 | |
69e6ee2f HK |
5464 | -- The call occurs in an initial condition context when a prior |
5465 | -- scenario is already in that mode, or when the target is an | |
5466 | -- Initial_Condition procedure. Update the state of the Processing | |
5467 | -- phase to reflect this. | |
90e491a7 | 5468 | |
69e6ee2f HK |
5469 | New_In_State.Within_Initial_Condition := |
5470 | New_In_State.Within_Initial_Condition | |
5471 | or else Is_Initial_Condition_Proc (Subp_Id); | |
90e491a7 | 5472 | |
69e6ee2f HK |
5473 | -- The call occurs in a partial finalization context when a prior |
5474 | -- scenario is already in that mode, or when the target denotes a | |
5475 | -- [Deep_]Finalize primitive or a finalizer within an initialization | |
5476 | -- context. Update the state of the Processing phase to reflect this. | |
8dce7371 | 5477 | |
69e6ee2f HK |
5478 | New_In_State.Within_Partial_Finalization := |
5479 | New_In_State.Within_Partial_Finalization | |
5480 | or else Is_Partial_Finalization_Proc (Subp_Id); | |
8dce7371 | 5481 | |
69e6ee2f HK |
5482 | -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK |
5483 | -- elaboration rules in SPARK code) is intentionally not taken into | |
5484 | -- account here because Process_Conditional_ABE_Call_SPARK has two | |
5485 | -- separate modes of operation. | |
8dce7371 | 5486 | |
69e6ee2f HK |
5487 | if SPARK_Rules_On then |
5488 | Process_Conditional_ABE_Call_SPARK | |
5489 | (Call => Call, | |
5490 | Call_Rep => Call_Rep, | |
5491 | Subp_Id => Subp_Id, | |
5492 | Subp_Rep => Subp_Rep, | |
5493 | In_State => New_In_State); | |
8dce7371 | 5494 | |
69e6ee2f | 5495 | -- Otherwise the Ada rules are in effect |
8dce7371 | 5496 | |
69e6ee2f HK |
5497 | else |
5498 | Process_Conditional_ABE_Call_Ada | |
5499 | (Call => Call, | |
5500 | Call_Rep => Call_Rep, | |
5501 | Subp_Id => Subp_Id, | |
5502 | Subp_Rep => Subp_Rep, | |
5503 | In_State => New_In_State); | |
8dce7371 | 5504 | end if; |
90e491a7 | 5505 | |
69e6ee2f HK |
5506 | -- Inspect the target body (and barried function) for other suitable |
5507 | -- elaboration scenarios. | |
8dce7371 | 5508 | |
69e6ee2f HK |
5509 | Traverse_Conditional_ABE_Body |
5510 | (N => Barrier_Body_Declaration (Subp_Rep), | |
5511 | In_State => New_In_State); | |
8dce7371 | 5512 | |
69e6ee2f HK |
5513 | Traverse_Conditional_ABE_Body |
5514 | (N => Body_Declaration (Subp_Rep), | |
5515 | In_State => New_In_State); | |
5516 | end Process_Conditional_ABE_Call; | |
8dce7371 | 5517 | |
69e6ee2f HK |
5518 | -------------------------------------- |
5519 | -- Process_Conditional_ABE_Call_Ada -- | |
5520 | -------------------------------------- | |
8dce7371 | 5521 | |
69e6ee2f HK |
5522 | procedure Process_Conditional_ABE_Call_Ada |
5523 | (Call : Node_Id; | |
5524 | Call_Rep : Scenario_Rep_Id; | |
5525 | Subp_Id : Entity_Id; | |
5526 | Subp_Rep : Target_Rep_Id; | |
5527 | In_State : Processing_In_State) | |
5528 | is | |
5529 | Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); | |
5530 | Root : constant Node_Id := Root_Scenario; | |
5531 | Unit_Id : constant Node_Id := Unit (Subp_Rep); | |
5532 | ||
5533 | Check_OK : constant Boolean := | |
5534 | not In_State.Suppress_Checks | |
5535 | and then Ghost_Mode_Of (Call_Rep) /= Is_Ignored | |
5536 | and then Ghost_Mode_Of (Subp_Rep) /= Is_Ignored | |
5537 | and then Elaboration_Checks_OK (Call_Rep) | |
5538 | and then Elaboration_Checks_OK (Subp_Rep); | |
5539 | -- A run-time ABE check may be installed only when both the call | |
5540 | -- and the target have active elaboration checks, and both are not | |
5541 | -- ignored Ghost constructs. | |
5542 | ||
5543 | New_In_State : Processing_In_State := In_State; | |
5544 | -- Each step of the Processing phase constitutes a new state | |
8dce7371 | 5545 | |
69e6ee2f HK |
5546 | begin |
5547 | -- Nothing to do for an Ada dispatching call because there are no | |
5548 | -- ABE diagnostics for either models. ABE checks for the dynamic | |
5549 | -- model are handled by Install_Primitive_Elaboration_Check. | |
90e491a7 | 5550 | |
69e6ee2f HK |
5551 | if Is_Dispatching_Call (Call_Rep) then |
5552 | return; | |
2e60feb5 | 5553 | |
69e6ee2f HK |
5554 | -- Nothing to do when the call is ABE-safe |
5555 | -- | |
5556 | -- generic | |
5557 | -- function Gen ...; | |
5558 | -- | |
5559 | -- function Gen ... is | |
5560 | -- begin | |
5561 | -- ... | |
5562 | -- end Gen; | |
5563 | -- | |
5564 | -- with Gen; | |
5565 | -- procedure Main is | |
5566 | -- function Inst is new Gen; | |
5567 | -- X : ... := Inst; -- safe call | |
5568 | -- ... | |
2e60feb5 | 5569 | |
69e6ee2f HK |
5570 | elsif Is_Safe_Call (Call, Subp_Id, Subp_Rep) then |
5571 | return; | |
2e60feb5 | 5572 | |
69e6ee2f HK |
5573 | -- The call and the target body are both in the main unit |
5574 | -- | |
5575 | -- If the root scenario appears prior to the target body, then this | |
5576 | -- is a possible ABE with respect to the root scenario. | |
5577 | -- | |
5578 | -- function B ...; | |
5579 | -- | |
5580 | -- function A ... is | |
5581 | -- begin | |
5582 | -- if Some_Condition then | |
5583 | -- return B; -- call site | |
5584 | -- ... | |
5585 | -- end A; | |
5586 | -- | |
5587 | -- X : ... := A; -- root scenario | |
5588 | -- | |
5589 | -- function B ... is -- target body | |
5590 | -- ... | |
5591 | -- end B; | |
5592 | -- | |
5593 | -- Y : ... := A; -- root scenario | |
5594 | -- | |
5595 | -- IMPORTANT: The call to B from A is a possible ABE for X, but | |
5596 | -- not for Y. Installing an unconditional ABE raise prior to the | |
5597 | -- call to B would be wrong as it will fail for Y as well, but in | |
5598 | -- Y's case the call to B is never an ABE. | |
2e60feb5 | 5599 | |
69e6ee2f HK |
5600 | elsif Present (Body_Decl) |
5601 | and then In_Extended_Main_Code_Unit (Body_Decl) | |
5602 | then | |
5603 | if Earlier_In_Extended_Unit (Root, Body_Decl) then | |
2e60feb5 | 5604 | |
69e6ee2f HK |
5605 | -- Do not emit any ABE diagnostics when a previous scenario in |
5606 | -- this traversal has suppressed elaboration warnings. | |
2e60feb5 | 5607 | |
69e6ee2f HK |
5608 | if New_In_State.Suppress_Warnings then |
5609 | null; | |
2e60feb5 | 5610 | |
69e6ee2f HK |
5611 | -- Do not emit any ABE diagnostics when the call occurs in a |
5612 | -- partial finalization context because this leads to confusing | |
5613 | -- noise. | |
2e60feb5 | 5614 | |
69e6ee2f HK |
5615 | elsif New_In_State.Within_Partial_Finalization then |
5616 | null; | |
2e60feb5 | 5617 | |
69e6ee2f | 5618 | -- Otherwise emit the ABE diagnostic |
2e60feb5 | 5619 | |
69e6ee2f HK |
5620 | else |
5621 | Error_Msg_NE | |
5622 | ("??cannot call & before body seen", Call, Subp_Id); | |
5623 | Error_Msg_N | |
5624 | ("\Program_Error may be raised at run time", Call); | |
b91f986b | 5625 | |
69e6ee2f HK |
5626 | Output_Active_Scenarios (Call, New_In_State); |
5627 | end if; | |
b91f986b | 5628 | |
69e6ee2f HK |
5629 | -- Install a conditional run-time ABE check to verify that the |
5630 | -- target body has been elaborated prior to the call. | |
5631 | ||
5632 | if Check_OK then | |
5633 | Install_Scenario_ABE_Check | |
5634 | (N => Call, | |
5635 | Targ_Id => Subp_Id, | |
5636 | Targ_Rep => Subp_Rep, | |
5637 | Disable => Call_Rep); | |
5638 | ||
5639 | -- Update the state of the Processing phase to indicate that | |
5640 | -- no implicit Elaborate[_All] pragma must be generated from | |
5641 | -- this point on. | |
5642 | -- | |
5643 | -- function B ...; | |
5644 | -- | |
5645 | -- function A ... is | |
5646 | -- begin | |
5647 | -- if Some_Condition then | |
5648 | -- <ABE check> | |
5649 | -- return B; | |
5650 | -- ... | |
5651 | -- end A; | |
5652 | -- | |
5653 | -- X : ... := A; | |
5654 | -- | |
5655 | -- function B ... is | |
5656 | -- External.Subp; -- imparts Elaborate_All | |
5657 | -- end B; | |
5658 | -- | |
5659 | -- If Some_Condition is True, then the ABE check will fail | |
5660 | -- at runtime and the call to External.Subp will never take | |
5661 | -- place, rendering the implicit Elaborate_All useless. | |
5662 | -- | |
5663 | -- If the value of Some_Condition is False, then the call | |
5664 | -- to External.Subp will never take place, rendering the | |
5665 | -- implicit Elaborate_All useless. | |
5666 | ||
5667 | New_In_State.Suppress_Implicit_Pragmas := True; | |
5668 | end if; | |
5669 | end if; | |
b91f986b | 5670 | |
69e6ee2f HK |
5671 | -- Otherwise the target body is not available in this compilation or |
5672 | -- it resides in an external unit. Install a run-time ABE check to | |
5673 | -- verify that the target body has been elaborated prior to the call | |
5674 | -- site when the dynamic model is in effect. | |
b91f986b | 5675 | |
69e6ee2f HK |
5676 | elsif Check_OK |
5677 | and then New_In_State.Processing = Dynamic_Model_Processing | |
5678 | then | |
5679 | Install_Unit_ABE_Check | |
5680 | (N => Call, | |
5681 | Unit_Id => Unit_Id, | |
5682 | Disable => Call_Rep); | |
5683 | end if; | |
b91f986b | 5684 | |
69e6ee2f HK |
5685 | -- Ensure that the unit with the target body is elaborated prior to |
5686 | -- the main unit. The implicit Elaborate[_All] is generated only when | |
5687 | -- the call has elaboration checks enabled. This behaviour parallels | |
5688 | -- that of the old ABE mechanism. | |
5689 | ||
5690 | if Elaboration_Checks_OK (Call_Rep) then | |
5691 | Ensure_Prior_Elaboration | |
5692 | (N => Call, | |
5693 | Unit_Id => Unit_Id, | |
5694 | Prag_Nam => Name_Elaborate_All, | |
5695 | In_State => New_In_State); | |
5696 | end if; | |
5697 | end Process_Conditional_ABE_Call_Ada; | |
b91f986b | 5698 | |
69e6ee2f HK |
5699 | ---------------------------------------- |
5700 | -- Process_Conditional_ABE_Call_SPARK -- | |
5701 | ---------------------------------------- | |
b91f986b | 5702 | |
69e6ee2f HK |
5703 | procedure Process_Conditional_ABE_Call_SPARK |
5704 | (Call : Node_Id; | |
5705 | Call_Rep : Scenario_Rep_Id; | |
5706 | Subp_Id : Entity_Id; | |
5707 | Subp_Rep : Target_Rep_Id; | |
5708 | In_State : Processing_In_State) | |
5709 | is | |
5710 | pragma Unreferenced (Call_Rep); | |
b91f986b | 5711 | |
69e6ee2f HK |
5712 | Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); |
5713 | Region : Node_Id; | |
b91f986b | 5714 | |
69e6ee2f HK |
5715 | begin |
5716 | -- Ensure that a suitable elaboration model is in effect for SPARK | |
5717 | -- rule verification. | |
b91f986b | 5718 | |
69e6ee2f | 5719 | Check_SPARK_Model_In_Effect; |
2e60feb5 | 5720 | |
69e6ee2f | 5721 | -- The call and the target body are both in the main unit |
b91f986b | 5722 | |
69e6ee2f HK |
5723 | if Present (Body_Decl) |
5724 | and then In_Extended_Main_Code_Unit (Body_Decl) | |
5725 | and then Earlier_In_Extended_Unit (Call, Body_Decl) | |
5726 | then | |
5727 | -- Do not emit any ABE diagnostics when a previous scenario in | |
5728 | -- this traversal has suppressed elaboration warnings. | |
b91f986b | 5729 | |
69e6ee2f HK |
5730 | if In_State.Suppress_Warnings then |
5731 | null; | |
2e60feb5 | 5732 | |
69e6ee2f HK |
5733 | -- Do not emit any ABE diagnostics when the call occurs in an |
5734 | -- initial condition context because this leads to incorrect | |
5735 | -- diagnostics. | |
2e60feb5 | 5736 | |
69e6ee2f HK |
5737 | elsif In_State.Within_Initial_Condition then |
5738 | null; | |
8dce7371 | 5739 | |
69e6ee2f HK |
5740 | -- Do not emit any ABE diagnostics when the call occurs in a |
5741 | -- partial finalization context because this leads to confusing | |
5742 | -- noise. | |
8dce7371 | 5743 | |
69e6ee2f HK |
5744 | elsif In_State.Within_Partial_Finalization then |
5745 | null; | |
2e60feb5 | 5746 | |
69e6ee2f HK |
5747 | -- Ensure that a call that textually precedes the subprogram body |
5748 | -- it invokes appears within the early call region of the body. | |
5749 | -- | |
5750 | -- IMPORTANT: This check must always be performed even when switch | |
5751 | -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not | |
5752 | -- specified because the static model cannot guarantee the absence | |
5753 | -- of elaboration issues when dispatching calls are involved. | |
2e60feb5 | 5754 | |
69e6ee2f HK |
5755 | else |
5756 | Region := Find_Early_Call_Region (Body_Decl); | |
2e60feb5 | 5757 | |
69e6ee2f HK |
5758 | if Earlier_In_Extended_Unit (Call, Region) then |
5759 | Error_Msg_NE | |
5760 | ("call must appear within early call region of subprogram " | |
5761 | & "body & (SPARK RM 7.7(3))", | |
5762 | Call, Subp_Id); | |
2e60feb5 | 5763 | |
69e6ee2f HK |
5764 | Error_Msg_Sloc := Sloc (Region); |
5765 | Error_Msg_N ("\region starts #", Call); | |
2e60feb5 | 5766 | |
69e6ee2f HK |
5767 | Error_Msg_Sloc := Sloc (Body_Decl); |
5768 | Error_Msg_N ("\region ends #", Call); | |
2e60feb5 | 5769 | |
69e6ee2f HK |
5770 | Output_Active_Scenarios (Call, In_State); |
5771 | end if; | |
5772 | end if; | |
5773 | end if; | |
2e60feb5 | 5774 | |
69e6ee2f HK |
5775 | -- A call to a source target or to a target which emulates Ada |
5776 | -- or SPARK semantics imposes an Elaborate_All requirement on the | |
5777 | -- context of the main unit. Determine whether the context has a | |
5778 | -- pragma strong enough to meet the requirement. | |
5779 | -- | |
5780 | -- IMPORTANT: This check must be performed only when switch -gnatd.v | |
5781 | -- (enforce SPARK elaboration rules in SPARK code) is active because | |
5782 | -- the static model can ensure the prior elaboration of the unit | |
5783 | -- which contains a body by installing an implicit Elaborate[_All] | |
5784 | -- pragma. | |
5785 | ||
5786 | if Debug_Flag_Dot_V then | |
5787 | if Comes_From_Source (Subp_Id) | |
5788 | or else Is_Ada_Semantic_Target (Subp_Id) | |
5789 | or else Is_SPARK_Semantic_Target (Subp_Id) | |
5790 | then | |
5791 | Meet_Elaboration_Requirement | |
5792 | (N => Call, | |
5793 | Targ_Id => Subp_Id, | |
5794 | Req_Nam => Name_Elaborate_All, | |
5795 | In_State => In_State); | |
5796 | end if; | |
2e60feb5 | 5797 | |
69e6ee2f HK |
5798 | -- Otherwise ensure that the unit with the target body is elaborated |
5799 | -- prior to the main unit. | |
2e60feb5 | 5800 | |
69e6ee2f HK |
5801 | else |
5802 | Ensure_Prior_Elaboration | |
5803 | (N => Call, | |
5804 | Unit_Id => Unit (Subp_Rep), | |
5805 | Prag_Nam => Name_Elaborate_All, | |
5806 | In_State => In_State); | |
5807 | end if; | |
5808 | end Process_Conditional_ABE_Call_SPARK; | |
2e60feb5 | 5809 | |
69e6ee2f HK |
5810 | ------------------------------------------- |
5811 | -- Process_Conditional_ABE_Instantiation -- | |
5812 | ------------------------------------------- | |
2e60feb5 | 5813 | |
69e6ee2f HK |
5814 | procedure Process_Conditional_ABE_Instantiation |
5815 | (Inst : Node_Id; | |
5816 | Inst_Rep : Scenario_Rep_Id; | |
5817 | In_State : Processing_In_State) | |
5818 | is | |
5819 | Gen_Id : constant Entity_Id := Target (Inst_Rep); | |
5820 | Gen_Rep : constant Target_Rep_Id := | |
5821 | Target_Representation_Of (Gen_Id, In_State); | |
2e60feb5 | 5822 | |
69e6ee2f HK |
5823 | SPARK_Rules_On : constant Boolean := |
5824 | SPARK_Mode_Of (Inst_Rep) = Is_On | |
5825 | and then SPARK_Mode_Of (Gen_Rep) = Is_On; | |
8dce7371 | 5826 | |
69e6ee2f HK |
5827 | New_In_State : Processing_In_State := In_State; |
5828 | -- Each step of the Processing phase constitutes a new state | |
8dce7371 | 5829 | |
69e6ee2f HK |
5830 | begin |
5831 | -- Output relevant information when switch -gnatel (info messages on | |
5832 | -- implicit Elaborate[_All] pragmas) is in effect. | |
8dce7371 | 5833 | |
69e6ee2f HK |
5834 | if Elab_Info_Messages |
5835 | and then not New_In_State.Suppress_Info_Messages | |
5836 | then | |
5837 | Info_Instantiation | |
5838 | (Inst => Inst, | |
5839 | Gen_Id => Gen_Id, | |
5840 | Info_Msg => True, | |
5841 | In_SPARK => SPARK_Rules_On); | |
2e60feb5 PMR |
5842 | end if; |
5843 | ||
69e6ee2f | 5844 | -- Nothing to do when the instantiation is a guaranteed ABE |
2e60feb5 | 5845 | |
69e6ee2f HK |
5846 | if Is_Known_Guaranteed_ABE (Inst) then |
5847 | return; | |
90e491a7 | 5848 | |
69e6ee2f HK |
5849 | -- Nothing to do when the root scenario appears at the declaration |
5850 | -- level and the generic is in the same unit, but outside this | |
5851 | -- context. | |
5852 | -- | |
5853 | -- generic | |
5854 | -- procedure Gen is ...; -- generic declaration | |
5855 | -- | |
5856 | -- procedure Proc is | |
5857 | -- function A ... is | |
5858 | -- begin | |
5859 | -- if Some_Condition then | |
5860 | -- declare | |
5861 | -- procedure I is new Gen; -- instantiation site | |
5862 | -- ... | |
5863 | -- ... | |
5864 | -- end A; | |
5865 | -- | |
5866 | -- X : ... := A; -- root scenario | |
5867 | -- ... | |
5868 | -- | |
5869 | -- procedure Gen is | |
5870 | -- ... | |
5871 | -- end Gen; | |
5872 | -- | |
5873 | -- In the example above, the context of X is the declarative region | |
5874 | -- of Proc. The "elaboration" of X may eventually reach Gen which | |
5875 | -- appears outside of X's context. Gen is relevant only when Proc is | |
5876 | -- invoked, but this happens only by means of "normal" elaboration, | |
5877 | -- therefore Gen must not be considered if this is not the case. | |
5878 | ||
5879 | elsif Is_Up_Level_Target | |
5880 | (Targ_Decl => Spec_Declaration (Gen_Rep), | |
5881 | In_State => New_In_State) | |
8dce7371 | 5882 | then |
69e6ee2f HK |
5883 | return; |
5884 | end if; | |
90e491a7 | 5885 | |
69e6ee2f HK |
5886 | -- Warnings are suppressed when a prior scenario is already in that |
5887 | -- mode, or when the instantiation has warnings suppressed. Update | |
5888 | -- the state of the processing phase to reflect this. | |
90e491a7 | 5889 | |
69e6ee2f HK |
5890 | New_In_State.Suppress_Warnings := |
5891 | New_In_State.Suppress_Warnings | |
5892 | or else not Elaboration_Warnings_OK (Inst_Rep); | |
90e491a7 | 5893 | |
69e6ee2f | 5894 | -- The SPARK rules are in effect |
90e491a7 | 5895 | |
69e6ee2f HK |
5896 | if SPARK_Rules_On then |
5897 | Process_Conditional_ABE_Instantiation_SPARK | |
5898 | (Inst => Inst, | |
5899 | Inst_Rep => Inst_Rep, | |
5900 | Gen_Id => Gen_Id, | |
5901 | Gen_Rep => Gen_Rep, | |
5902 | In_State => New_In_State); | |
90e491a7 | 5903 | |
69e6ee2f HK |
5904 | -- Otherwise the Ada rules are in effect, or SPARK code is allowed to |
5905 | -- violate the SPARK rules. | |
90e491a7 | 5906 | |
69e6ee2f HK |
5907 | else |
5908 | Process_Conditional_ABE_Instantiation_Ada | |
5909 | (Inst => Inst, | |
5910 | Inst_Rep => Inst_Rep, | |
5911 | Gen_Id => Gen_Id, | |
5912 | Gen_Rep => Gen_Rep, | |
5913 | In_State => New_In_State); | |
8dce7371 | 5914 | end if; |
69e6ee2f HK |
5915 | end Process_Conditional_ABE_Instantiation; |
5916 | ||
5917 | ----------------------------------------------- | |
5918 | -- Process_Conditional_ABE_Instantiation_Ada -- | |
5919 | ----------------------------------------------- | |
5920 | ||
5921 | procedure Process_Conditional_ABE_Instantiation_Ada | |
5922 | (Inst : Node_Id; | |
5923 | Inst_Rep : Scenario_Rep_Id; | |
5924 | Gen_Id : Entity_Id; | |
5925 | Gen_Rep : Target_Rep_Id; | |
5926 | In_State : Processing_In_State) | |
5927 | is | |
5928 | Body_Decl : constant Node_Id := Body_Declaration (Gen_Rep); | |
5929 | Root : constant Node_Id := Root_Scenario; | |
5930 | Unit_Id : constant Entity_Id := Unit (Gen_Rep); | |
5931 | ||
5932 | Check_OK : constant Boolean := | |
5933 | not In_State.Suppress_Checks | |
5934 | and then Ghost_Mode_Of (Inst_Rep) /= Is_Ignored | |
5935 | and then Ghost_Mode_Of (Gen_Rep) /= Is_Ignored | |
5936 | and then Elaboration_Checks_OK (Inst_Rep) | |
5937 | and then Elaboration_Checks_OK (Gen_Rep); | |
5938 | -- A run-time ABE check may be installed only when both the instance | |
5939 | -- and the generic have active elaboration checks and both are not | |
5940 | -- ignored Ghost constructs. | |
5941 | ||
5942 | New_In_State : Processing_In_State := In_State; | |
5943 | -- Each step of the Processing phase constitutes a new state | |
90e491a7 | 5944 | |
8dce7371 | 5945 | begin |
69e6ee2f HK |
5946 | -- Nothing to do when the instantiation is ABE-safe |
5947 | -- | |
5948 | -- generic | |
5949 | -- package Gen is | |
5950 | -- ... | |
5951 | -- end Gen; | |
5952 | -- | |
5953 | -- package body Gen is | |
5954 | -- ... | |
5955 | -- end Gen; | |
5956 | -- | |
5957 | -- with Gen; | |
5958 | -- procedure Main is | |
5959 | -- package Inst is new Gen (ABE); -- safe instantiation | |
5960 | -- ... | |
90e491a7 | 5961 | |
69e6ee2f | 5962 | if Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then |
8dce7371 | 5963 | return; |
90e491a7 | 5964 | |
69e6ee2f HK |
5965 | -- The instantiation and the generic body are both in the main unit |
5966 | -- | |
5967 | -- If the root scenario appears prior to the generic body, then this | |
5968 | -- is a possible ABE with respect to the root scenario. | |
5969 | -- | |
5970 | -- generic | |
5971 | -- package Gen is | |
5972 | -- ... | |
5973 | -- end Gen; | |
5974 | -- | |
5975 | -- function A ... is | |
5976 | -- begin | |
5977 | -- if Some_Condition then | |
5978 | -- declare | |
5979 | -- package Inst is new Gen; -- instantiation site | |
5980 | -- ... | |
5981 | -- end A; | |
5982 | -- | |
5983 | -- X : ... := A; -- root scenario | |
5984 | -- | |
5985 | -- package body Gen is -- generic body | |
5986 | -- ... | |
5987 | -- end Gen; | |
5988 | -- | |
5989 | -- Y : ... := A; -- root scenario | |
5990 | -- | |
5991 | -- IMPORTANT: The instantiation of Gen is a possible ABE for X, | |
5992 | -- but not for Y. Installing an unconditional ABE raise prior to | |
5993 | -- the instance site would be wrong as it will fail for Y as well, | |
5994 | -- but in Y's case the instantiation of Gen is never an ABE. | |
5995 | ||
5996 | elsif Present (Body_Decl) | |
5997 | and then In_Extended_Main_Code_Unit (Body_Decl) | |
5998 | then | |
5999 | if Earlier_In_Extended_Unit (Root, Body_Decl) then | |
8dce7371 | 6000 | |
69e6ee2f HK |
6001 | -- Do not emit any ABE diagnostics when a previous scenario in |
6002 | -- this traversal has suppressed elaboration warnings. | |
90e491a7 | 6003 | |
69e6ee2f HK |
6004 | if New_In_State.Suppress_Warnings then |
6005 | null; | |
90e491a7 | 6006 | |
69e6ee2f HK |
6007 | -- Do not emit any ABE diagnostics when the instantiation |
6008 | -- occurs in partial finalization context because this leads | |
6009 | -- to unwanted noise. | |
90e491a7 | 6010 | |
69e6ee2f HK |
6011 | elsif New_In_State.Within_Partial_Finalization then |
6012 | null; | |
90e491a7 | 6013 | |
69e6ee2f | 6014 | -- Otherwise output the diagnostic |
90e491a7 | 6015 | |
69e6ee2f HK |
6016 | else |
6017 | Error_Msg_NE | |
6018 | ("??cannot instantiate & before body seen", Inst, Gen_Id); | |
6019 | Error_Msg_N | |
6020 | ("\Program_Error may be raised at run time", Inst); | |
6021 | ||
6022 | Output_Active_Scenarios (Inst, New_In_State); | |
6023 | end if; | |
90e491a7 | 6024 | |
69e6ee2f HK |
6025 | -- Install a conditional run-time ABE check to verify that the |
6026 | -- generic body has been elaborated prior to the instantiation. | |
6027 | ||
6028 | if Check_OK then | |
6029 | Install_Scenario_ABE_Check | |
6030 | (N => Inst, | |
6031 | Targ_Id => Gen_Id, | |
6032 | Targ_Rep => Gen_Rep, | |
6033 | Disable => Inst_Rep); | |
6034 | ||
6035 | -- Update the state of the Processing phase to indicate that | |
6036 | -- no implicit Elaborate[_All] pragma must be generated from | |
6037 | -- this point on. | |
6038 | -- | |
6039 | -- generic | |
6040 | -- package Gen is | |
6041 | -- ... | |
6042 | -- end Gen; | |
6043 | -- | |
6044 | -- function A ... is | |
6045 | -- begin | |
6046 | -- if Some_Condition then | |
6047 | -- <ABE check> | |
6048 | -- declare Inst is new Gen; | |
6049 | -- ... | |
6050 | -- end A; | |
6051 | -- | |
6052 | -- X : ... := A; | |
6053 | -- | |
6054 | -- package body Gen is | |
6055 | -- begin | |
6056 | -- External.Subp; -- imparts Elaborate_All | |
6057 | -- end Gen; | |
6058 | -- | |
6059 | -- If Some_Condition is True, then the ABE check will fail | |
6060 | -- at runtime and the call to External.Subp will never take | |
6061 | -- place, rendering the implicit Elaborate_All useless. | |
6062 | -- | |
6063 | -- If the value of Some_Condition is False, then the call | |
6064 | -- to External.Subp will never take place, rendering the | |
6065 | -- implicit Elaborate_All useless. | |
6066 | ||
6067 | New_In_State.Suppress_Implicit_Pragmas := True; | |
6068 | end if; | |
6069 | end if; | |
90e491a7 | 6070 | |
69e6ee2f HK |
6071 | -- Otherwise the generic body is not available in this compilation |
6072 | -- or it resides in an external unit. Install a run-time ABE check | |
6073 | -- to verify that the generic body has been elaborated prior to the | |
6074 | -- instantiation when the dynamic model is in effect. | |
90e491a7 | 6075 | |
69e6ee2f HK |
6076 | elsif Check_OK |
6077 | and then New_In_State.Processing = Dynamic_Model_Processing | |
8dce7371 | 6078 | then |
69e6ee2f HK |
6079 | Install_Unit_ABE_Check |
6080 | (N => Inst, | |
6081 | Unit_Id => Unit_Id, | |
6082 | Disable => Inst_Rep); | |
8dce7371 | 6083 | end if; |
90e491a7 | 6084 | |
69e6ee2f HK |
6085 | -- Ensure that the unit with the generic body is elaborated prior |
6086 | -- to the main unit. No implicit pragma has to be generated if the | |
6087 | -- instantiation has elaboration checks suppressed. This behaviour | |
6088 | -- parallels that of the old ABE mechanism. | |
6089 | ||
6090 | if Elaboration_Checks_OK (Inst_Rep) then | |
6091 | Ensure_Prior_Elaboration | |
6092 | (N => Inst, | |
6093 | Unit_Id => Unit_Id, | |
6094 | Prag_Nam => Name_Elaborate, | |
6095 | In_State => New_In_State); | |
6096 | end if; | |
6097 | end Process_Conditional_ABE_Instantiation_Ada; | |
6098 | ||
6099 | ------------------------------------------------- | |
6100 | -- Process_Conditional_ABE_Instantiation_SPARK -- | |
6101 | ------------------------------------------------- | |
6102 | ||
6103 | procedure Process_Conditional_ABE_Instantiation_SPARK | |
6104 | (Inst : Node_Id; | |
6105 | Inst_Rep : Scenario_Rep_Id; | |
6106 | Gen_Id : Entity_Id; | |
6107 | Gen_Rep : Target_Rep_Id; | |
6108 | In_State : Processing_In_State) | |
6109 | is | |
6110 | pragma Unreferenced (Inst_Rep); | |
90e491a7 | 6111 | |
69e6ee2f | 6112 | Req_Nam : Name_Id; |
90e491a7 | 6113 | |
8dce7371 | 6114 | begin |
69e6ee2f HK |
6115 | -- Ensure that a suitable elaboration model is in effect for SPARK |
6116 | -- rule verification. | |
90e491a7 | 6117 | |
69e6ee2f | 6118 | Check_SPARK_Model_In_Effect; |
90e491a7 | 6119 | |
69e6ee2f HK |
6120 | -- A source instantiation imposes an Elaborate[_All] requirement |
6121 | -- on the context of the main unit. Determine whether the context | |
6122 | -- has a pragma strong enough to meet the requirement. The check | |
6123 | -- is orthogonal to the ABE ramifications of the instantiation. | |
6124 | -- | |
6125 | -- IMPORTANT: This check must be performed only when switch -gnatd.v | |
6126 | -- (enforce SPARK elaboration rules in SPARK code) is active because | |
6127 | -- the static model can ensure the prior elaboration of the unit | |
6128 | -- which contains a body by installing an implicit Elaborate[_All] | |
6129 | -- pragma. | |
6130 | ||
6131 | if Debug_Flag_Dot_V then | |
6132 | if Nkind (Inst) = N_Package_Instantiation then | |
6133 | Req_Nam := Name_Elaborate_All; | |
6134 | else | |
6135 | Req_Nam := Name_Elaborate; | |
8dce7371 | 6136 | end if; |
90e491a7 | 6137 | |
69e6ee2f HK |
6138 | Meet_Elaboration_Requirement |
6139 | (N => Inst, | |
6140 | Targ_Id => Gen_Id, | |
6141 | Req_Nam => Req_Nam, | |
6142 | In_State => In_State); | |
90e491a7 | 6143 | |
69e6ee2f HK |
6144 | -- Otherwise ensure that the unit with the target body is elaborated |
6145 | -- prior to the main unit. | |
90e491a7 | 6146 | |
69e6ee2f HK |
6147 | else |
6148 | Ensure_Prior_Elaboration | |
6149 | (N => Inst, | |
6150 | Unit_Id => Unit (Gen_Rep), | |
6151 | Prag_Nam => Name_Elaborate, | |
6152 | In_State => In_State); | |
6153 | end if; | |
6154 | end Process_Conditional_ABE_Instantiation_SPARK; | |
90e491a7 | 6155 | |
69e6ee2f HK |
6156 | ------------------------------------------------- |
6157 | -- Process_Conditional_ABE_Variable_Assignment -- | |
6158 | ------------------------------------------------- | |
90e491a7 | 6159 | |
69e6ee2f HK |
6160 | procedure Process_Conditional_ABE_Variable_Assignment |
6161 | (Asmt : Node_Id; | |
6162 | Asmt_Rep : Scenario_Rep_Id; | |
6163 | In_State : Processing_In_State) | |
6164 | is | |
90e491a7 | 6165 | |
69e6ee2f HK |
6166 | Var_Id : constant Entity_Id := Target (Asmt_Rep); |
6167 | Var_Rep : constant Target_Rep_Id := | |
6168 | Target_Representation_Of (Var_Id, In_State); | |
90e491a7 | 6169 | |
69e6ee2f HK |
6170 | SPARK_Rules_On : constant Boolean := |
6171 | SPARK_Mode_Of (Asmt_Rep) = Is_On | |
6172 | and then SPARK_Mode_Of (Var_Rep) = Is_On; | |
90e491a7 | 6173 | |
69e6ee2f HK |
6174 | begin |
6175 | -- Output relevant information when switch -gnatel (info messages on | |
6176 | -- implicit Elaborate[_All] pragmas) is in effect. | |
90e491a7 | 6177 | |
69e6ee2f HK |
6178 | if Elab_Info_Messages |
6179 | and then not In_State.Suppress_Info_Messages | |
6180 | then | |
6181 | Elab_Msg_NE | |
6182 | (Msg => "assignment to & during elaboration", | |
6183 | N => Asmt, | |
6184 | Id => Var_Id, | |
6185 | Info_Msg => True, | |
6186 | In_SPARK => SPARK_Rules_On); | |
6187 | end if; | |
90e491a7 | 6188 | |
69e6ee2f HK |
6189 | -- The SPARK rules are in effect. These rules are applied regardless |
6190 | -- of whether switch -gnatd.v (enforce SPARK elaboration rules in | |
6191 | -- SPARK code) is in effect because the static model cannot ensure | |
6192 | -- safe assignment of variables. | |
8dce7371 | 6193 | |
69e6ee2f HK |
6194 | if SPARK_Rules_On then |
6195 | Process_Conditional_ABE_Variable_Assignment_SPARK | |
6196 | (Asmt => Asmt, | |
6197 | Asmt_Rep => Asmt_Rep, | |
6198 | Var_Id => Var_Id, | |
6199 | Var_Rep => Var_Rep, | |
6200 | In_State => In_State); | |
8dce7371 | 6201 | |
69e6ee2f | 6202 | -- Otherwise the Ada rules are in effect |
8dce7371 | 6203 | |
69e6ee2f HK |
6204 | else |
6205 | Process_Conditional_ABE_Variable_Assignment_Ada | |
6206 | (Asmt => Asmt, | |
6207 | Asmt_Rep => Asmt_Rep, | |
6208 | Var_Id => Var_Id, | |
6209 | Var_Rep => Var_Rep, | |
6210 | In_State => In_State); | |
6211 | end if; | |
6212 | end Process_Conditional_ABE_Variable_Assignment; | |
6213 | ||
6214 | ----------------------------------------------------- | |
6215 | -- Process_Conditional_ABE_Variable_Assignment_Ada -- | |
6216 | ----------------------------------------------------- | |
6217 | ||
6218 | procedure Process_Conditional_ABE_Variable_Assignment_Ada | |
6219 | (Asmt : Node_Id; | |
6220 | Asmt_Rep : Scenario_Rep_Id; | |
6221 | Var_Id : Entity_Id; | |
6222 | Var_Rep : Target_Rep_Id; | |
6223 | In_State : Processing_In_State) | |
6224 | is | |
6225 | pragma Unreferenced (Asmt_Rep); | |
90e491a7 | 6226 | |
69e6ee2f HK |
6227 | Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep); |
6228 | Unit_Id : constant Entity_Id := Unit (Var_Rep); | |
90e491a7 | 6229 | |
69e6ee2f HK |
6230 | begin |
6231 | -- Emit a warning when an uninitialized variable declared in a | |
6232 | -- package spec without a pragma Elaborate_Body is initialized | |
6233 | -- by elaboration code within the corresponding body. | |
90e491a7 | 6234 | |
69e6ee2f HK |
6235 | if Is_Elaboration_Warnings_OK_Id (Var_Id) |
6236 | and then not Is_Initialized (Var_Decl) | |
6237 | and then not Has_Pragma_Elaborate_Body (Unit_Id) | |
6238 | then | |
6239 | -- Do not emit any ABE diagnostics when a previous scenario in | |
6240 | -- this traversal has suppressed elaboration warnings. | |
90e491a7 | 6241 | |
69e6ee2f HK |
6242 | if not In_State.Suppress_Warnings then |
6243 | Error_Msg_NE | |
6244 | ("??variable & can be accessed by clients before this " | |
6245 | & "initialization", Asmt, Var_Id); | |
90e491a7 | 6246 | |
69e6ee2f HK |
6247 | Error_Msg_NE |
6248 | ("\add pragma ""Elaborate_Body"" to spec & to ensure proper " | |
6249 | & "initialization", Asmt, Unit_Id); | |
90e491a7 | 6250 | |
69e6ee2f HK |
6251 | Output_Active_Scenarios (Asmt, In_State); |
6252 | end if; | |
90e491a7 | 6253 | |
69e6ee2f | 6254 | -- Generate an implicit Elaborate_Body in the spec |
90e491a7 | 6255 | |
69e6ee2f HK |
6256 | Set_Elaborate_Body_Desirable (Unit_Id); |
6257 | end if; | |
6258 | end Process_Conditional_ABE_Variable_Assignment_Ada; | |
6259 | ||
6260 | ------------------------------------------------------- | |
6261 | -- Process_Conditional_ABE_Variable_Assignment_SPARK -- | |
6262 | ------------------------------------------------------- | |
6263 | ||
6264 | procedure Process_Conditional_ABE_Variable_Assignment_SPARK | |
6265 | (Asmt : Node_Id; | |
6266 | Asmt_Rep : Scenario_Rep_Id; | |
6267 | Var_Id : Entity_Id; | |
6268 | Var_Rep : Target_Rep_Id; | |
6269 | In_State : Processing_In_State) | |
6270 | is | |
6271 | pragma Unreferenced (Asmt_Rep); | |
90e491a7 | 6272 | |
69e6ee2f HK |
6273 | Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep); |
6274 | Unit_Id : constant Entity_Id := Unit (Var_Rep); | |
90e491a7 | 6275 | |
69e6ee2f HK |
6276 | begin |
6277 | -- Ensure that a suitable elaboration model is in effect for SPARK | |
6278 | -- rule verification. | |
90e491a7 | 6279 | |
69e6ee2f | 6280 | Check_SPARK_Model_In_Effect; |
90e491a7 | 6281 | |
69e6ee2f HK |
6282 | -- Do not emit any ABE diagnostics when a previous scenario in this |
6283 | -- traversal has suppressed elaboration warnings. | |
90e491a7 | 6284 | |
69e6ee2f HK |
6285 | if In_State.Suppress_Warnings then |
6286 | null; | |
90e491a7 | 6287 | |
69e6ee2f HK |
6288 | -- Emit an error when an initialized variable declared in a package |
6289 | -- spec that is missing pragma Elaborate_Body is further modified by | |
6290 | -- elaboration code within the corresponding body. | |
90e491a7 | 6291 | |
69e6ee2f HK |
6292 | elsif Is_Elaboration_Warnings_OK_Id (Var_Id) |
6293 | and then Is_Initialized (Var_Decl) | |
6294 | and then not Has_Pragma_Elaborate_Body (Unit_Id) | |
6295 | then | |
6296 | Error_Msg_NE | |
6297 | ("variable & modified by elaboration code in package body", | |
6298 | Asmt, Var_Id); | |
90e491a7 | 6299 | |
69e6ee2f HK |
6300 | Error_Msg_NE |
6301 | ("\add pragma ""Elaborate_Body"" to spec & to ensure full " | |
6302 | & "initialization", Asmt, Unit_Id); | |
90e491a7 | 6303 | |
69e6ee2f | 6304 | Output_Active_Scenarios (Asmt, In_State); |
8dce7371 | 6305 | end if; |
69e6ee2f | 6306 | end Process_Conditional_ABE_Variable_Assignment_SPARK; |
8dce7371 | 6307 | |
69e6ee2f HK |
6308 | ------------------------------------------------ |
6309 | -- Process_Conditional_ABE_Variable_Reference -- | |
6310 | ------------------------------------------------ | |
6311 | ||
6312 | procedure Process_Conditional_ABE_Variable_Reference | |
6313 | (Ref : Node_Id; | |
6314 | Ref_Rep : Scenario_Rep_Id; | |
6315 | In_State : Processing_In_State) | |
6316 | is | |
6317 | Var_Id : constant Entity_Id := Target (Ref); | |
6318 | Var_Rep : Target_Rep_Id; | |
6319 | Unit_Id : Entity_Id; | |
8dce7371 | 6320 | |
8dce7371 | 6321 | begin |
69e6ee2f | 6322 | -- Nothing to do when the variable reference is not a read |
8dce7371 | 6323 | |
69e6ee2f HK |
6324 | if not Is_Read_Reference (Ref_Rep) then |
6325 | return; | |
6326 | end if; | |
8dce7371 | 6327 | |
69e6ee2f HK |
6328 | Var_Rep := Target_Representation_Of (Var_Id, In_State); |
6329 | Unit_Id := Unit (Var_Rep); | |
8dce7371 | 6330 | |
69e6ee2f HK |
6331 | -- Output relevant information when switch -gnatel (info messages on |
6332 | -- implicit Elaborate[_All] pragmas) is in effect. | |
8dce7371 | 6333 | |
69e6ee2f HK |
6334 | if Elab_Info_Messages |
6335 | and then not In_State.Suppress_Info_Messages | |
6336 | then | |
6337 | Elab_Msg_NE | |
6338 | (Msg => "read of variable & during elaboration", | |
6339 | N => Ref, | |
6340 | Id => Var_Id, | |
6341 | Info_Msg => True, | |
6342 | In_SPARK => True); | |
6343 | end if; | |
8dce7371 | 6344 | |
69e6ee2f HK |
6345 | -- Nothing to do when the variable appears within the main unit |
6346 | -- because diagnostics on reads are relevant only for external | |
6347 | -- variables. | |
8dce7371 | 6348 | |
3eb5e54a | 6349 | if Is_Same_Unit (Unit_Id, Main_Unit_Entity) then |
69e6ee2f | 6350 | null; |
8dce7371 | 6351 | |
69e6ee2f HK |
6352 | -- Nothing to do when the variable is already initialized. Note that |
6353 | -- the variable may be further modified by the external unit. | |
8dce7371 | 6354 | |
69e6ee2f HK |
6355 | elsif Is_Initialized (Variable_Declaration (Var_Rep)) then |
6356 | null; | |
8dce7371 | 6357 | |
69e6ee2f HK |
6358 | -- Nothing to do when the external unit guarantees the initialization |
6359 | -- of the variable by means of pragma Elaborate_Body. | |
8dce7371 | 6360 | |
69e6ee2f HK |
6361 | elsif Has_Pragma_Elaborate_Body (Unit_Id) then |
6362 | null; | |
967947ed | 6363 | |
69e6ee2f HK |
6364 | -- A variable read imposes an Elaborate requirement on the context of |
6365 | -- the main unit. Determine whether the context has a pragma strong | |
6366 | -- enough to meet the requirement. | |
967947ed | 6367 | |
69e6ee2f HK |
6368 | else |
6369 | Meet_Elaboration_Requirement | |
6370 | (N => Ref, | |
6371 | Targ_Id => Var_Id, | |
6372 | Req_Nam => Name_Elaborate, | |
6373 | In_State => In_State); | |
6374 | end if; | |
6375 | end Process_Conditional_ABE_Variable_Reference; | |
8dce7371 | 6376 | |
69e6ee2f HK |
6377 | ----------------------------------- |
6378 | -- Traverse_Conditional_ABE_Body -- | |
6379 | ----------------------------------- | |
8dce7371 | 6380 | |
69e6ee2f HK |
6381 | procedure Traverse_Conditional_ABE_Body |
6382 | (N : Node_Id; | |
6383 | In_State : Processing_In_State) | |
6384 | is | |
6385 | begin | |
6386 | Traverse_Body | |
6387 | (N => N, | |
6388 | Requires_Processing => Is_Conditional_ABE_Scenario'Access, | |
6389 | Processor => Process_Conditional_ABE'Access, | |
6390 | In_State => In_State); | |
6391 | end Traverse_Conditional_ABE_Body; | |
6392 | end Conditional_ABE_Processor; | |
8dce7371 | 6393 | |
69e6ee2f HK |
6394 | ------------- |
6395 | -- Destroy -- | |
6396 | ------------- | |
8dce7371 | 6397 | |
69e6ee2f HK |
6398 | procedure Destroy (NE : in out Node_Or_Entity_Id) is |
6399 | pragma Unreferenced (NE); | |
6400 | begin | |
6401 | null; | |
6402 | end Destroy; | |
8dce7371 | 6403 | |
69e6ee2f HK |
6404 | ----------------- |
6405 | -- Diagnostics -- | |
6406 | ----------------- | |
8dce7371 | 6407 | |
69e6ee2f | 6408 | package body Diagnostics is |
8dce7371 | 6409 | |
69e6ee2f HK |
6410 | ----------------- |
6411 | -- Elab_Msg_NE -- | |
6412 | ----------------- | |
8dce7371 | 6413 | |
69e6ee2f HK |
6414 | procedure Elab_Msg_NE |
6415 | (Msg : String; | |
6416 | N : Node_Id; | |
6417 | Id : Entity_Id; | |
6418 | Info_Msg : Boolean; | |
6419 | In_SPARK : Boolean) | |
6420 | is | |
6421 | function Prefix return String; | |
6422 | pragma Inline (Prefix); | |
6423 | -- Obtain the prefix of the message | |
8dce7371 | 6424 | |
69e6ee2f HK |
6425 | function Suffix return String; |
6426 | pragma Inline (Suffix); | |
6427 | -- Obtain the suffix of the message | |
8dce7371 | 6428 | |
69e6ee2f HK |
6429 | ------------ |
6430 | -- Prefix -- | |
6431 | ------------ | |
8dce7371 | 6432 | |
69e6ee2f HK |
6433 | function Prefix return String is |
6434 | begin | |
6435 | if Info_Msg then | |
6436 | return "info: "; | |
6437 | else | |
6438 | return ""; | |
6439 | end if; | |
6440 | end Prefix; | |
8dce7371 | 6441 | |
69e6ee2f HK |
6442 | ------------ |
6443 | -- Suffix -- | |
6444 | ------------ | |
8dce7371 | 6445 | |
69e6ee2f HK |
6446 | function Suffix return String is |
6447 | begin | |
6448 | if In_SPARK then | |
6449 | return " in SPARK"; | |
6450 | else | |
6451 | return ""; | |
6452 | end if; | |
6453 | end Suffix; | |
8dce7371 | 6454 | |
69e6ee2f | 6455 | -- Start of processing for Elab_Msg_NE |
8dce7371 | 6456 | |
69e6ee2f HK |
6457 | begin |
6458 | Error_Msg_NE (Prefix & Msg & Suffix, N, Id); | |
6459 | end Elab_Msg_NE; | |
8dce7371 | 6460 | |
69e6ee2f HK |
6461 | --------------- |
6462 | -- Info_Call -- | |
6463 | --------------- | |
8dce7371 | 6464 | |
69e6ee2f HK |
6465 | procedure Info_Call |
6466 | (Call : Node_Id; | |
6467 | Subp_Id : Entity_Id; | |
6468 | Info_Msg : Boolean; | |
6469 | In_SPARK : Boolean) | |
6470 | is | |
6471 | procedure Info_Accept_Alternative; | |
6472 | pragma Inline (Info_Accept_Alternative); | |
6473 | -- Output information concerning an accept alternative | |
8dce7371 | 6474 | |
69e6ee2f HK |
6475 | procedure Info_Simple_Call; |
6476 | pragma Inline (Info_Simple_Call); | |
6477 | -- Output information concerning the call | |
8dce7371 | 6478 | |
69e6ee2f HK |
6479 | procedure Info_Type_Actions (Action : String); |
6480 | pragma Inline (Info_Type_Actions); | |
6481 | -- Output information concerning action Action of a type | |
8dce7371 | 6482 | |
69e6ee2f HK |
6483 | procedure Info_Verification_Call |
6484 | (Pred : String; | |
6485 | Id : Entity_Id; | |
6486 | Id_Kind : String); | |
6487 | pragma Inline (Info_Verification_Call); | |
6488 | -- Output information concerning the verification of predicate Pred | |
6489 | -- applied to related entity Id with kind Id_Kind. | |
8dce7371 | 6490 | |
69e6ee2f HK |
6491 | ----------------------------- |
6492 | -- Info_Accept_Alternative -- | |
6493 | ----------------------------- | |
8dce7371 | 6494 | |
69e6ee2f HK |
6495 | procedure Info_Accept_Alternative is |
6496 | Entry_Id : constant Entity_Id := Receiving_Entry (Subp_Id); | |
6497 | pragma Assert (Present (Entry_Id)); | |
8dce7371 | 6498 | |
69e6ee2f HK |
6499 | begin |
6500 | Elab_Msg_NE | |
6501 | (Msg => "accept for entry & during elaboration", | |
6502 | N => Call, | |
6503 | Id => Entry_Id, | |
6504 | Info_Msg => Info_Msg, | |
6505 | In_SPARK => In_SPARK); | |
6506 | end Info_Accept_Alternative; | |
6507 | ||
6508 | ---------------------- | |
6509 | -- Info_Simple_Call -- | |
6510 | ---------------------- | |
6511 | ||
6512 | procedure Info_Simple_Call is | |
6513 | begin | |
6514 | Elab_Msg_NE | |
6515 | (Msg => "call to & during elaboration", | |
6516 | N => Call, | |
6517 | Id => Subp_Id, | |
6518 | Info_Msg => Info_Msg, | |
6519 | In_SPARK => In_SPARK); | |
6520 | end Info_Simple_Call; | |
6521 | ||
6522 | ----------------------- | |
6523 | -- Info_Type_Actions -- | |
6524 | ----------------------- | |
6525 | ||
6526 | procedure Info_Type_Actions (Action : String) is | |
6527 | Typ : constant Entity_Id := First_Formal_Type (Subp_Id); | |
6528 | pragma Assert (Present (Typ)); | |
8dce7371 | 6529 | |
69e6ee2f HK |
6530 | begin |
6531 | Elab_Msg_NE | |
6532 | (Msg => Action & " actions for type & during elaboration", | |
6533 | N => Call, | |
6534 | Id => Typ, | |
6535 | Info_Msg => Info_Msg, | |
6536 | In_SPARK => In_SPARK); | |
6537 | end Info_Type_Actions; | |
6538 | ||
6539 | ---------------------------- | |
6540 | -- Info_Verification_Call -- | |
6541 | ---------------------------- | |
6542 | ||
6543 | procedure Info_Verification_Call | |
6544 | (Pred : String; | |
6545 | Id : Entity_Id; | |
6546 | Id_Kind : String) | |
6547 | is | |
6548 | pragma Assert (Present (Id)); | |
8dce7371 | 6549 | |
69e6ee2f HK |
6550 | begin |
6551 | Elab_Msg_NE | |
6552 | (Msg => | |
6553 | "verification of " & Pred & " of " & Id_Kind & " & during " | |
6554 | & "elaboration", | |
6555 | N => Call, | |
6556 | Id => Id, | |
6557 | Info_Msg => Info_Msg, | |
6558 | In_SPARK => In_SPARK); | |
6559 | end Info_Verification_Call; | |
6560 | ||
6561 | -- Start of processing for Info_Call | |
8dce7371 | 6562 | |
69e6ee2f HK |
6563 | begin |
6564 | -- Do not output anything for targets defined in internal units | |
6565 | -- because this creates noise. | |
8dce7371 | 6566 | |
69e6ee2f | 6567 | if not In_Internal_Unit (Subp_Id) then |
8dce7371 | 6568 | |
69e6ee2f | 6569 | -- Accept alternative |
8dce7371 | 6570 | |
69e6ee2f HK |
6571 | if Is_Accept_Alternative_Proc (Subp_Id) then |
6572 | Info_Accept_Alternative; | |
8dce7371 | 6573 | |
69e6ee2f | 6574 | -- Adjustment |
8dce7371 | 6575 | |
69e6ee2f HK |
6576 | elsif Is_TSS (Subp_Id, TSS_Deep_Adjust) then |
6577 | Info_Type_Actions ("adjustment"); | |
8dce7371 | 6578 | |
69e6ee2f | 6579 | -- Default_Initial_Condition |
8dce7371 | 6580 | |
69e6ee2f HK |
6581 | elsif Is_Default_Initial_Condition_Proc (Subp_Id) then |
6582 | Info_Verification_Call | |
6583 | (Pred => "Default_Initial_Condition", | |
6584 | Id => First_Formal_Type (Subp_Id), | |
6585 | Id_Kind => "type"); | |
8dce7371 | 6586 | |
69e6ee2f | 6587 | -- Entries |
8dce7371 | 6588 | |
69e6ee2f HK |
6589 | elsif Is_Protected_Entry (Subp_Id) then |
6590 | Info_Simple_Call; | |
8dce7371 | 6591 | |
69e6ee2f HK |
6592 | -- Task entry calls are never processed because the entry being |
6593 | -- invoked does not have a corresponding "body", it has a select. | |
8dce7371 | 6594 | |
69e6ee2f HK |
6595 | elsif Is_Task_Entry (Subp_Id) then |
6596 | null; | |
8dce7371 | 6597 | |
69e6ee2f | 6598 | -- Finalization |
8dce7371 | 6599 | |
69e6ee2f HK |
6600 | elsif Is_TSS (Subp_Id, TSS_Deep_Finalize) then |
6601 | Info_Type_Actions ("finalization"); | |
8dce7371 | 6602 | |
69e6ee2f HK |
6603 | -- Calls to _Finalizer procedures must not appear in the output |
6604 | -- because this creates confusing noise. | |
8dce7371 | 6605 | |
69e6ee2f HK |
6606 | elsif Is_Finalizer_Proc (Subp_Id) then |
6607 | null; | |
8dce7371 | 6608 | |
69e6ee2f | 6609 | -- Initial_Condition |
8dce7371 | 6610 | |
69e6ee2f HK |
6611 | elsif Is_Initial_Condition_Proc (Subp_Id) then |
6612 | Info_Verification_Call | |
6613 | (Pred => "Initial_Condition", | |
6614 | Id => Find_Enclosing_Scope (Call), | |
6615 | Id_Kind => "package"); | |
8dce7371 | 6616 | |
69e6ee2f | 6617 | -- Initialization |
8dce7371 | 6618 | |
69e6ee2f HK |
6619 | elsif Is_Init_Proc (Subp_Id) |
6620 | or else Is_TSS (Subp_Id, TSS_Deep_Initialize) | |
6621 | then | |
6622 | Info_Type_Actions ("initialization"); | |
8dce7371 | 6623 | |
69e6ee2f | 6624 | -- Invariant |
8dce7371 | 6625 | |
69e6ee2f HK |
6626 | elsif Is_Invariant_Proc (Subp_Id) then |
6627 | Info_Verification_Call | |
6628 | (Pred => "invariants", | |
6629 | Id => First_Formal_Type (Subp_Id), | |
6630 | Id_Kind => "type"); | |
8dce7371 | 6631 | |
69e6ee2f HK |
6632 | -- Partial invariant calls must not appear in the output because |
6633 | -- this creates confusing noise. | |
8dce7371 | 6634 | |
69e6ee2f HK |
6635 | elsif Is_Partial_Invariant_Proc (Subp_Id) then |
6636 | null; | |
8dce7371 | 6637 | |
69e6ee2f | 6638 | -- _Postconditions |
8dce7371 | 6639 | |
69e6ee2f HK |
6640 | elsif Is_Postconditions_Proc (Subp_Id) then |
6641 | Info_Verification_Call | |
6642 | (Pred => "postconditions", | |
6643 | Id => Find_Enclosing_Scope (Call), | |
6644 | Id_Kind => "subprogram"); | |
8dce7371 | 6645 | |
69e6ee2f HK |
6646 | -- Subprograms must come last because some of the previous cases |
6647 | -- fall under this category. | |
8dce7371 | 6648 | |
69e6ee2f HK |
6649 | elsif Ekind (Subp_Id) = E_Function then |
6650 | Info_Simple_Call; | |
8dce7371 | 6651 | |
69e6ee2f HK |
6652 | elsif Ekind (Subp_Id) = E_Procedure then |
6653 | Info_Simple_Call; | |
8dce7371 | 6654 | |
69e6ee2f HK |
6655 | else |
6656 | pragma Assert (False); | |
6657 | return; | |
6658 | end if; | |
6659 | end if; | |
6660 | end Info_Call; | |
8dce7371 | 6661 | |
69e6ee2f HK |
6662 | ------------------------ |
6663 | -- Info_Instantiation -- | |
6664 | ------------------------ | |
8dce7371 | 6665 | |
69e6ee2f HK |
6666 | procedure Info_Instantiation |
6667 | (Inst : Node_Id; | |
6668 | Gen_Id : Entity_Id; | |
6669 | Info_Msg : Boolean; | |
6670 | In_SPARK : Boolean) | |
6671 | is | |
6672 | begin | |
6673 | Elab_Msg_NE | |
6674 | (Msg => "instantiation of & during elaboration", | |
6675 | N => Inst, | |
6676 | Id => Gen_Id, | |
6677 | Info_Msg => Info_Msg, | |
6678 | In_SPARK => In_SPARK); | |
6679 | end Info_Instantiation; | |
8dce7371 | 6680 | |
69e6ee2f HK |
6681 | ----------------------------- |
6682 | -- Info_Variable_Reference -- | |
6683 | ----------------------------- | |
8dce7371 | 6684 | |
69e6ee2f HK |
6685 | procedure Info_Variable_Reference |
6686 | (Ref : Node_Id; | |
6687 | Var_Id : Entity_Id; | |
6688 | Info_Msg : Boolean; | |
6689 | In_SPARK : Boolean) | |
6690 | is | |
6691 | begin | |
6692 | if Is_Read (Ref) then | |
6693 | Elab_Msg_NE | |
6694 | (Msg => "read of variable & during elaboration", | |
6695 | N => Ref, | |
6696 | Id => Var_Id, | |
6697 | Info_Msg => Info_Msg, | |
6698 | In_SPARK => In_SPARK); | |
6699 | end if; | |
6700 | end Info_Variable_Reference; | |
6701 | end Diagnostics; | |
8dce7371 | 6702 | |
69e6ee2f HK |
6703 | --------------------------------- |
6704 | -- Early_Call_Region_Processor -- | |
6705 | --------------------------------- | |
8dce7371 | 6706 | |
69e6ee2f | 6707 | package body Early_Call_Region_Processor is |
8dce7371 | 6708 | |
69e6ee2f HK |
6709 | --------------------- |
6710 | -- Data structures -- | |
6711 | --------------------- | |
8dce7371 | 6712 | |
69e6ee2f | 6713 | -- The following map relates early call regions to subprogram bodies |
8dce7371 | 6714 | |
69e6ee2f HK |
6715 | procedure Destroy (N : in out Node_Id); |
6716 | -- Destroy node N | |
8dce7371 | 6717 | |
69e6ee2f HK |
6718 | package ECR_Map is new Dynamic_Hash_Tables |
6719 | (Key_Type => Entity_Id, | |
6720 | Value_Type => Node_Id, | |
6721 | No_Value => Empty, | |
6722 | Expansion_Threshold => 1.5, | |
6723 | Expansion_Factor => 2, | |
6724 | Compression_Threshold => 0.3, | |
6725 | Compression_Factor => 2, | |
6726 | "=" => "=", | |
6727 | Destroy_Value => Destroy, | |
6728 | Hash => Hash); | |
8dce7371 | 6729 | |
69e6ee2f | 6730 | Early_Call_Regions_Map : ECR_Map.Dynamic_Hash_Table := ECR_Map.Nil; |
8dce7371 | 6731 | |
69e6ee2f HK |
6732 | ----------------------- |
6733 | -- Local subprograms -- | |
6734 | ----------------------- | |
8dce7371 | 6735 | |
69e6ee2f HK |
6736 | function Early_Call_Region (Body_Id : Entity_Id) return Node_Id; |
6737 | pragma Inline (Early_Call_Region); | |
6738 | -- Obtain the early call region associated with entry or subprogram body | |
6739 | -- Body_Id. | |
8dce7371 | 6740 | |
69e6ee2f HK |
6741 | procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id); |
6742 | pragma Inline (Set_Early_Call_Region); | |
6743 | -- Associate an early call region with begins at construct Start with | |
6744 | -- entry or subprogram body Body_Id. | |
8dce7371 | 6745 | |
69e6ee2f HK |
6746 | ------------- |
6747 | -- Destroy -- | |
6748 | ------------- | |
8dce7371 | 6749 | |
69e6ee2f HK |
6750 | procedure Destroy (N : in out Node_Id) is |
6751 | pragma Unreferenced (N); | |
6752 | begin | |
6753 | null; | |
6754 | end Destroy; | |
8dce7371 | 6755 | |
69e6ee2f HK |
6756 | ----------------------- |
6757 | -- Early_Call_Region -- | |
6758 | ----------------------- | |
8dce7371 | 6759 | |
69e6ee2f HK |
6760 | function Early_Call_Region (Body_Id : Entity_Id) return Node_Id is |
6761 | pragma Assert (Present (Body_Id)); | |
6762 | begin | |
6763 | return ECR_Map.Get (Early_Call_Regions_Map, Body_Id); | |
6764 | end Early_Call_Region; | |
8dce7371 | 6765 | |
69e6ee2f HK |
6766 | ------------------------------------------ |
6767 | -- Finalize_Early_Call_Region_Processor -- | |
6768 | ------------------------------------------ | |
8dce7371 | 6769 | |
69e6ee2f HK |
6770 | procedure Finalize_Early_Call_Region_Processor is |
6771 | begin | |
6772 | ECR_Map.Destroy (Early_Call_Regions_Map); | |
6773 | end Finalize_Early_Call_Region_Processor; | |
8dce7371 | 6774 | |
69e6ee2f HK |
6775 | ---------------------------- |
6776 | -- Find_Early_Call_Region -- | |
6777 | ---------------------------- | |
8dce7371 | 6778 | |
69e6ee2f HK |
6779 | function Find_Early_Call_Region |
6780 | (Body_Decl : Node_Id; | |
6781 | Assume_Elab_Body : Boolean := False; | |
6782 | Skip_Memoization : Boolean := False) return Node_Id | |
6783 | is | |
6784 | -- NOTE: The routines within Find_Early_Call_Region are intentionally | |
6785 | -- unnested to avoid deep indentation of code. | |
6786 | ||
6787 | ECR_Found : exception; | |
6788 | -- This exception is raised when the early call region has been found | |
6789 | ||
6790 | Start : Node_Id := Empty; | |
6791 | -- The start of the early call region. This variable is updated by | |
6792 | -- the various nested routines. Due to the use of exceptions, the | |
6793 | -- variable must be global to the nested routines. | |
6794 | ||
6795 | -- The algorithm implemented in this routine attempts to find the | |
6796 | -- early call region of a subprogram body by inspecting constructs | |
6797 | -- in reverse declarative order, while navigating the tree. The | |
6798 | -- algorithm consists of an Inspection phase and Advancement phase. | |
6799 | -- The pseudocode is as follows: | |
6800 | -- | |
6801 | -- loop | |
6802 | -- inspection phase | |
6803 | -- advancement phase | |
6804 | -- end loop | |
6805 | -- | |
6806 | -- The infinite loop is terminated by raising exception ECR_Found. | |
6807 | -- The algorithm utilizes two pointers, Curr and Start, to represent | |
6808 | -- the current construct to inspect and the start of the early call | |
6809 | -- region. | |
6810 | -- | |
6811 | -- IMPORTANT: The algorithm must maintain the following invariant at | |
6812 | -- all time for it to function properly: | |
6813 | -- | |
6814 | -- A nested construct is entered only when it contains suitable | |
6815 | -- constructs. | |
6816 | -- | |
6817 | -- This guarantees that leaving a nested or encapsulating construct | |
6818 | -- functions properly. | |
6819 | -- | |
6820 | -- The Inspection phase determines whether the current construct is | |
6821 | -- non-preelaborable, and if it is, the algorithm terminates. | |
6822 | -- | |
6823 | -- The Advancement phase walks the tree in reverse declarative order, | |
6824 | -- while entering and leaving nested and encapsulating constructs. It | |
6825 | -- may also terminate the elaborithm. There are several special cases | |
6826 | -- of advancement. | |
6827 | -- | |
6828 | -- 1) General case: | |
6829 | -- | |
6830 | -- <construct 1> | |
6831 | -- ... | |
6832 | -- <construct N-1> <- Curr | |
6833 | -- <construct N> <- Start | |
6834 | -- <subprogram body> | |
6835 | -- | |
6836 | -- In the general case, a declarative or statement list is traversed | |
6837 | -- in reverse order where Curr is the lead pointer, and Start is the | |
6838 | -- last preelaborable construct. | |
6839 | -- | |
6840 | -- 2) Entering handled bodies | |
6841 | -- | |
6842 | -- package body Nested is <- Curr (2.3) | |
6843 | -- <declarations> <- Curr (2.2) | |
6844 | -- begin | |
6845 | -- <statements> <- Curr (2.1) | |
6846 | -- end Nested; | |
6847 | -- <construct> <- Start | |
6848 | -- | |
6849 | -- In this case, the algorithm enters a handled body by starting from | |
6850 | -- the last statement (2.1), or the last declaration (2.2), or the | |
6851 | -- body is consumed (2.3) because it is empty and thus preelaborable. | |
6852 | -- | |
6853 | -- 3) Entering package declarations | |
6854 | -- | |
6855 | -- package Nested is <- Curr (2.3) | |
6856 | -- <visible declarations> <- Curr (2.2) | |
6857 | -- private | |
6858 | -- <private declarations> <- Curr (2.1) | |
6859 | -- end Nested; | |
6860 | -- <construct> <- Start | |
6861 | -- | |
6862 | -- In this case, the algorithm enters a package declaration by | |
6863 | -- starting from the last private declaration (2.1), the last visible | |
6864 | -- declaration (2.2), or the package is consumed (2.3) because it is | |
6865 | -- empty and thus preelaborable. | |
6866 | -- | |
6867 | -- 4) Transitioning from list to list of the same construct | |
6868 | -- | |
6869 | -- Certain constructs have two eligible lists. The algorithm must | |
6870 | -- thus transition from the second to the first list when the second | |
6871 | -- list is exhausted. | |
6872 | -- | |
6873 | -- declare <- Curr (4.2) | |
6874 | -- <declarations> <- Curr (4.1) | |
6875 | -- begin | |
6876 | -- <statements> <- Start | |
6877 | -- end; | |
6878 | -- | |
6879 | -- In this case, the algorithm has exhausted the second list (the | |
6880 | -- statements in the example above), and continues with the last | |
6881 | -- declaration (4.1) or the construct is consumed (4.2) because it | |
6882 | -- contains only preelaborable code. | |
6883 | -- | |
6884 | -- 5) Transitioning from list to construct | |
6885 | -- | |
6886 | -- tack body Task is <- Curr (5.1) | |
6887 | -- <- Curr (Empty) | |
6888 | -- <construct 1> <- Start | |
6889 | -- | |
6890 | -- In this case, the algorithm has exhausted a list, Curr is Empty, | |
6891 | -- and the owner of the list is consumed (5.1). | |
6892 | -- | |
6893 | -- 6) Transitioning from unit to unit | |
6894 | -- | |
6895 | -- A package body with a spec subject to pragma Elaborate_Body | |
6896 | -- extends the possible range of the early call region to the package | |
6897 | -- spec. | |
6898 | -- | |
6899 | -- package Pack is <- Curr (6.3) | |
6900 | -- pragma Elaborate_Body; <- Curr (6.2) | |
6901 | -- <visible declarations> <- Curr (6.2) | |
6902 | -- private | |
6903 | -- <private declarations> <- Curr (6.1) | |
6904 | -- end Pack; | |
6905 | -- | |
6906 | -- package body Pack is <- Curr, Start | |
6907 | -- | |
6908 | -- In this case, the algorithm has reached a package body compilation | |
6909 | -- unit whose spec is subject to pragma Elaborate_Body, or the caller | |
6910 | -- of the algorithm has specified this behavior. This transition is | |
6911 | -- equivalent to 3). | |
6912 | -- | |
6913 | -- 7) Transitioning from unit to termination | |
6914 | -- | |
6915 | -- Reaching a compilation unit always terminates the algorithm as | |
6916 | -- there are no more lists to examine. This must take case 6) into | |
6917 | -- account. | |
6918 | -- | |
6919 | -- 8) Transitioning from subunit to stub | |
6920 | -- | |
6921 | -- package body Pack is separate; <- Curr (8.1) | |
6922 | -- | |
6923 | -- separate (...) | |
6924 | -- package body Pack is <- Curr, Start | |
6925 | -- | |
6926 | -- Reaching a subunit continues the search from the corresponding | |
6927 | -- stub (8.1). | |
6928 | ||
6929 | procedure Advance (Curr : in out Node_Id); | |
6930 | pragma Inline (Advance); | |
6931 | -- Update the Curr and Start pointers depending on their location | |
6932 | -- in the tree to the next eligible construct. This routine raises | |
6933 | -- ECR_Found. | |
6934 | ||
6935 | procedure Enter_Handled_Body (Curr : in out Node_Id); | |
6936 | pragma Inline (Enter_Handled_Body); | |
6937 | -- Update the Curr and Start pointers to enter a nested handled body | |
6938 | -- if applicable. This routine raises ECR_Found. | |
6939 | ||
6940 | procedure Enter_Package_Declaration (Curr : in out Node_Id); | |
6941 | pragma Inline (Enter_Package_Declaration); | |
6942 | -- Update the Curr and Start pointers to enter a nested package spec | |
6943 | -- if applicable. This routine raises ECR_Found. | |
6944 | ||
6945 | function Find_ECR (N : Node_Id) return Node_Id; | |
6946 | pragma Inline (Find_ECR); | |
6947 | -- Find an early call region starting from arbitrary node N | |
6948 | ||
6949 | function Has_Suitable_Construct (List : List_Id) return Boolean; | |
6950 | pragma Inline (Has_Suitable_Construct); | |
6951 | -- Determine whether list List contains a suitable construct for | |
6952 | -- inclusion into an early call region. | |
6953 | ||
6954 | procedure Include (N : Node_Id; Curr : out Node_Id); | |
6955 | pragma Inline (Include); | |
6956 | -- Update the Curr and Start pointers to include arbitrary construct | |
6957 | -- N in the early call region. This routine raises ECR_Found. | |
6958 | ||
6959 | function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean; | |
6960 | pragma Inline (Is_OK_Preelaborable_Construct); | |
6961 | -- Determine whether arbitrary node N denotes a preelaboration-safe | |
6962 | -- construct. | |
6963 | ||
6964 | function Is_Suitable_Construct (N : Node_Id) return Boolean; | |
6965 | pragma Inline (Is_Suitable_Construct); | |
6966 | -- Determine whether arbitrary node N denotes a suitable construct | |
6967 | -- for inclusion into the early call region. | |
6968 | ||
6969 | procedure Transition_Body_Declarations | |
6970 | (Bod : Node_Id; | |
6971 | Curr : out Node_Id); | |
6972 | pragma Inline (Transition_Body_Declarations); | |
6973 | -- Update the Curr and Start pointers when construct Bod denotes a | |
6974 | -- block statement or a suitable body. This routine raises ECR_Found. | |
6975 | ||
6976 | procedure Transition_Handled_Statements | |
6977 | (HSS : Node_Id; | |
6978 | Curr : out Node_Id); | |
6979 | pragma Inline (Transition_Handled_Statements); | |
6980 | -- Update the Curr and Start pointers when node HSS denotes a handled | |
6981 | -- sequence of statements. This routine raises ECR_Found. | |
6982 | ||
6983 | procedure Transition_Spec_Declarations | |
6984 | (Spec : Node_Id; | |
6985 | Curr : out Node_Id); | |
6986 | pragma Inline (Transition_Spec_Declarations); | |
6987 | -- Update the Curr and Start pointers when construct Spec denotes | |
6988 | -- a concurrent definition or a package spec. This routine raises | |
6989 | -- ECR_Found. | |
6990 | ||
6991 | procedure Transition_Unit (Unit : Node_Id; Curr : out Node_Id); | |
6992 | pragma Inline (Transition_Unit); | |
6993 | -- Update the Curr and Start pointers when node Unit denotes a | |
6994 | -- potential compilation unit. This routine raises ECR_Found. | |
6995 | ||
6996 | ------------- | |
6997 | -- Advance -- | |
6998 | ------------- | |
6999 | ||
7000 | procedure Advance (Curr : in out Node_Id) is | |
7001 | Context : Node_Id; | |
8dce7371 | 7002 | |
69e6ee2f HK |
7003 | begin |
7004 | -- Curr denotes one of the following cases upon entry into this | |
7005 | -- routine: | |
7006 | -- | |
7007 | -- * Empty - There is no current construct when a declarative or | |
7008 | -- a statement list has been exhausted. This does not indicate | |
7009 | -- that the early call region has been computed as it is still | |
7010 | -- possible to transition to another list. | |
7011 | -- | |
7012 | -- * Encapsulator - The current construct wraps declarations | |
7013 | -- and/or statements. This indicates that the early call | |
7014 | -- region may extend within the nested construct. | |
7015 | -- | |
7016 | -- * Preelaborable - The current construct is preelaborable | |
7017 | -- because Find_ECR would not invoke Advance if this was not | |
7018 | -- the case. | |
8dce7371 | 7019 | |
69e6ee2f | 7020 | -- The current construct is an encapsulator or is preelaborable |
8dce7371 | 7021 | |
69e6ee2f | 7022 | if Present (Curr) then |
8dce7371 | 7023 | |
69e6ee2f HK |
7024 | -- Enter encapsulators by inspecting their declarations and/or |
7025 | -- statements. | |
8dce7371 | 7026 | |
69e6ee2f HK |
7027 | if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then |
7028 | Enter_Handled_Body (Curr); | |
8dce7371 | 7029 | |
69e6ee2f HK |
7030 | elsif Nkind (Curr) = N_Package_Declaration then |
7031 | Enter_Package_Declaration (Curr); | |
8dce7371 | 7032 | |
69e6ee2f HK |
7033 | -- Early call regions have a property which can be exploited to |
7034 | -- optimize the algorithm. | |
7035 | -- | |
7036 | -- <preceding subprogram body> | |
7037 | -- <preelaborable construct 1> | |
7038 | -- ... | |
7039 | -- <preelaborable construct N> | |
7040 | -- <initiating subprogram body> | |
7041 | -- | |
7042 | -- If a traversal initiated from a subprogram body reaches a | |
7043 | -- preceding subprogram body, then both bodies share the same | |
7044 | -- early call region. | |
7045 | -- | |
7046 | -- The property results in the following desirable effects: | |
7047 | -- | |
7048 | -- * If the preceding body already has an early call region, | |
7049 | -- then the initiating body can reuse it. This minimizes the | |
7050 | -- amount of processing performed by the algorithm. | |
7051 | -- | |
7052 | -- * If the preceding body lack an early call region, then the | |
7053 | -- algorithm can compute the early call region, and reuse it | |
7054 | -- for the initiating body. This processing performs the same | |
7055 | -- amount of work, but has the beneficial effect of computing | |
7056 | -- the early call regions of all preceding bodies. | |
8dce7371 | 7057 | |
69e6ee2f HK |
7058 | elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then |
7059 | Start := | |
7060 | Find_Early_Call_Region | |
7061 | (Body_Decl => Curr, | |
7062 | Assume_Elab_Body => Assume_Elab_Body, | |
7063 | Skip_Memoization => Skip_Memoization); | |
8dce7371 | 7064 | |
69e6ee2f | 7065 | raise ECR_Found; |
8dce7371 | 7066 | |
69e6ee2f HK |
7067 | -- Otherwise current construct is preelaborable. Unpdate the |
7068 | -- early call region to include it. | |
8dce7371 | 7069 | |
69e6ee2f HK |
7070 | else |
7071 | Include (Curr, Curr); | |
7072 | end if; | |
8dce7371 | 7073 | |
69e6ee2f HK |
7074 | -- Otherwise the current construct is missing, indicating that the |
7075 | -- current list has been exhausted. Depending on the context of | |
7076 | -- the list, several transitions are possible. | |
8dce7371 | 7077 | |
69e6ee2f HK |
7078 | else |
7079 | -- The invariant of the algorithm ensures that Curr and Start | |
7080 | -- are at the same level of nesting at the point of transition. | |
7081 | -- The algorithm can determine which list the traversal came | |
7082 | -- from by examining Start. | |
8dce7371 | 7083 | |
69e6ee2f | 7084 | Context := Parent (Start); |
8dce7371 | 7085 | |
69e6ee2f HK |
7086 | -- Attempt the following transitions: |
7087 | -- | |
7088 | -- private declarations -> visible declarations | |
7089 | -- private declarations -> upper level | |
7090 | -- private declarations -> terminate | |
7091 | -- visible declarations -> upper level | |
7092 | -- visible declarations -> terminate | |
7093 | ||
7094 | if Nkind_In (Context, N_Package_Specification, | |
7095 | N_Protected_Definition, | |
7096 | N_Task_Definition) | |
7097 | then | |
7098 | Transition_Spec_Declarations (Context, Curr); | |
8dce7371 | 7099 | |
69e6ee2f HK |
7100 | -- Attempt the following transitions: |
7101 | -- | |
7102 | -- statements -> declarations | |
7103 | -- statements -> upper level | |
7104 | -- statements -> corresponding package spec (Elab_Body) | |
7105 | -- statements -> terminate | |
8dce7371 | 7106 | |
69e6ee2f HK |
7107 | elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then |
7108 | Transition_Handled_Statements (Context, Curr); | |
90e491a7 | 7109 | |
69e6ee2f HK |
7110 | -- Attempt the following transitions: |
7111 | -- | |
7112 | -- declarations -> upper level | |
7113 | -- declarations -> corresponding package spec (Elab_Body) | |
7114 | -- declarations -> terminate | |
7115 | ||
7116 | elsif Nkind_In (Context, N_Block_Statement, | |
7117 | N_Entry_Body, | |
7118 | N_Package_Body, | |
7119 | N_Protected_Body, | |
7120 | N_Subprogram_Body, | |
7121 | N_Task_Body) | |
7122 | then | |
7123 | Transition_Body_Declarations (Context, Curr); | |
90e491a7 | 7124 | |
69e6ee2f HK |
7125 | -- Otherwise it is not possible to transition. Stop the search |
7126 | -- because there are no more declarations or statements to | |
7127 | -- check. | |
90e491a7 | 7128 | |
69e6ee2f HK |
7129 | else |
7130 | raise ECR_Found; | |
7131 | end if; | |
7132 | end if; | |
7133 | end Advance; | |
90e491a7 | 7134 | |
69e6ee2f HK |
7135 | -------------------------- |
7136 | -- Enter_Handled_Body -- | |
7137 | -------------------------- | |
90e491a7 | 7138 | |
69e6ee2f HK |
7139 | procedure Enter_Handled_Body (Curr : in out Node_Id) is |
7140 | Decls : constant List_Id := Declarations (Curr); | |
7141 | HSS : constant Node_Id := Handled_Statement_Sequence (Curr); | |
7142 | Stmts : List_Id := No_List; | |
90e491a7 | 7143 | |
69e6ee2f HK |
7144 | begin |
7145 | if Present (HSS) then | |
7146 | Stmts := Statements (HSS); | |
7147 | end if; | |
90e491a7 | 7148 | |
69e6ee2f HK |
7149 | -- The handled body has a non-empty statement sequence. The |
7150 | -- construct to inspect is the last statement. | |
90e491a7 | 7151 | |
69e6ee2f HK |
7152 | if Has_Suitable_Construct (Stmts) then |
7153 | Curr := Last (Stmts); | |
90e491a7 | 7154 | |
69e6ee2f HK |
7155 | -- The handled body lacks statements, but has non-empty |
7156 | -- declarations. The construct to inspect is the last declaration. | |
90e491a7 | 7157 | |
69e6ee2f HK |
7158 | elsif Has_Suitable_Construct (Decls) then |
7159 | Curr := Last (Decls); | |
90e491a7 | 7160 | |
69e6ee2f HK |
7161 | -- Otherwise the handled body lacks both declarations and |
7162 | -- statements. The construct to inspect is the node which precedes | |
7163 | -- the handled body. Update the early call region to include the | |
7164 | -- handled body. | |
90e491a7 | 7165 | |
69e6ee2f HK |
7166 | else |
7167 | Include (Curr, Curr); | |
7168 | end if; | |
7169 | end Enter_Handled_Body; | |
90e491a7 | 7170 | |
69e6ee2f HK |
7171 | ------------------------------- |
7172 | -- Enter_Package_Declaration -- | |
7173 | ------------------------------- | |
90e491a7 | 7174 | |
69e6ee2f HK |
7175 | procedure Enter_Package_Declaration (Curr : in out Node_Id) is |
7176 | Pack_Spec : constant Node_Id := Specification (Curr); | |
7177 | Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec); | |
7178 | Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec); | |
90e491a7 | 7179 | |
69e6ee2f HK |
7180 | begin |
7181 | -- The package has a non-empty private declarations. The construct | |
7182 | -- to inspect is the last private declaration. | |
90e491a7 | 7183 | |
69e6ee2f HK |
7184 | if Has_Suitable_Construct (Prv_Decls) then |
7185 | Curr := Last (Prv_Decls); | |
90e491a7 | 7186 | |
69e6ee2f HK |
7187 | -- The package lacks private declarations, but has non-empty |
7188 | -- visible declarations. In this case the construct to inspect | |
7189 | -- is the last visible declaration. | |
90e491a7 | 7190 | |
69e6ee2f HK |
7191 | elsif Has_Suitable_Construct (Vis_Decls) then |
7192 | Curr := Last (Vis_Decls); | |
90e491a7 | 7193 | |
69e6ee2f HK |
7194 | -- Otherwise the package lacks any declarations. The construct |
7195 | -- to inspect is the node which precedes the package. Update the | |
7196 | -- early call region to include the package declaration. | |
90e491a7 | 7197 | |
69e6ee2f HK |
7198 | else |
7199 | Include (Curr, Curr); | |
7200 | end if; | |
7201 | end Enter_Package_Declaration; | |
90e491a7 | 7202 | |
69e6ee2f HK |
7203 | -------------- |
7204 | -- Find_ECR -- | |
7205 | -------------- | |
90e491a7 | 7206 | |
69e6ee2f HK |
7207 | function Find_ECR (N : Node_Id) return Node_Id is |
7208 | Curr : Node_Id; | |
90e491a7 | 7209 | |
69e6ee2f HK |
7210 | begin |
7211 | -- The early call region starts at N | |
90e491a7 | 7212 | |
69e6ee2f HK |
7213 | Curr := Prev (N); |
7214 | Start := N; | |
90e491a7 | 7215 | |
69e6ee2f HK |
7216 | -- Inspect each node in reverse declarative order while going in |
7217 | -- and out of nested and enclosing constructs. Note that the only | |
7218 | -- way to terminate this infinite loop is to raise ECR_Found. | |
90e491a7 | 7219 | |
69e6ee2f HK |
7220 | loop |
7221 | -- The current construct is not preelaboration-safe. Terminate | |
7222 | -- the traversal. | |
90e491a7 | 7223 | |
69e6ee2f HK |
7224 | if Present (Curr) |
7225 | and then not Is_OK_Preelaborable_Construct (Curr) | |
7226 | then | |
7227 | raise ECR_Found; | |
7228 | end if; | |
90e491a7 | 7229 | |
69e6ee2f HK |
7230 | -- Advance to the next suitable construct. This may terminate |
7231 | -- the traversal by raising ECR_Found. | |
90e491a7 | 7232 | |
69e6ee2f HK |
7233 | Advance (Curr); |
7234 | end loop; | |
90e491a7 | 7235 | |
69e6ee2f HK |
7236 | exception |
7237 | when ECR_Found => | |
7238 | return Start; | |
7239 | end Find_ECR; | |
90e491a7 | 7240 | |
69e6ee2f HK |
7241 | ---------------------------- |
7242 | -- Has_Suitable_Construct -- | |
7243 | ---------------------------- | |
90e491a7 | 7244 | |
69e6ee2f HK |
7245 | function Has_Suitable_Construct (List : List_Id) return Boolean is |
7246 | Item : Node_Id; | |
90e491a7 | 7247 | |
69e6ee2f HK |
7248 | begin |
7249 | -- Examine the list in reverse declarative order, looking for a | |
7250 | -- suitable construct. | |
7251 | ||
7252 | if Present (List) then | |
7253 | Item := Last (List); | |
7254 | while Present (Item) loop | |
7255 | if Is_Suitable_Construct (Item) then | |
7256 | return True; | |
7257 | end if; | |
90e491a7 | 7258 | |
69e6ee2f HK |
7259 | Prev (Item); |
7260 | end loop; | |
7261 | end if; | |
90e491a7 | 7262 | |
69e6ee2f HK |
7263 | return False; |
7264 | end Has_Suitable_Construct; | |
90e491a7 | 7265 | |
69e6ee2f HK |
7266 | ------------- |
7267 | -- Include -- | |
7268 | ------------- | |
90e491a7 | 7269 | |
69e6ee2f HK |
7270 | procedure Include (N : Node_Id; Curr : out Node_Id) is |
7271 | begin | |
7272 | Start := N; | |
90e491a7 | 7273 | |
69e6ee2f HK |
7274 | -- The input node is a compilation unit. This terminates the |
7275 | -- search because there are no more lists to inspect and there are | |
7276 | -- no more enclosing constructs to climb up to. The transitions | |
7277 | -- are: | |
7278 | -- | |
7279 | -- private declarations -> terminate | |
7280 | -- visible declarations -> terminate | |
7281 | -- statements -> terminate | |
7282 | -- declarations -> terminate | |
90e491a7 | 7283 | |
69e6ee2f HK |
7284 | if Nkind (Parent (Start)) = N_Compilation_Unit then |
7285 | raise ECR_Found; | |
90e491a7 | 7286 | |
69e6ee2f | 7287 | -- Otherwise the input node is still within some list |
90e491a7 | 7288 | |
69e6ee2f HK |
7289 | else |
7290 | Curr := Prev (Start); | |
90e491a7 | 7291 | end if; |
69e6ee2f | 7292 | end Include; |
90e491a7 | 7293 | |
69e6ee2f HK |
7294 | ----------------------------------- |
7295 | -- Is_OK_Preelaborable_Construct -- | |
7296 | ----------------------------------- | |
90e491a7 | 7297 | |
69e6ee2f HK |
7298 | function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is |
7299 | begin | |
7300 | -- Assignment statements are acceptable as long as they were | |
7301 | -- produced by the ABE mechanism to update elaboration flags. | |
90e491a7 | 7302 | |
69e6ee2f HK |
7303 | if Nkind (N) = N_Assignment_Statement then |
7304 | return Is_Elaboration_Code (N); | |
7305 | ||
7306 | -- Block statements are acceptable even though they directly | |
7307 | -- violate preelaborability. The intention is not to penalize | |
7308 | -- the early call region when a block contains only preelaborable | |
7309 | -- constructs. | |
7310 | -- | |
7311 | -- declare | |
7312 | -- Val : constant Integer := 1; | |
7313 | -- begin | |
7314 | -- pragma Assert (Val = 1); | |
7315 | -- null; | |
7316 | -- end; | |
7317 | -- | |
7318 | -- Note that the Advancement phase does enter blocks, and will | |
7319 | -- detect any non-preelaborable declarations or statements within. | |
90e491a7 | 7320 | |
69e6ee2f HK |
7321 | elsif Nkind (N) = N_Block_Statement then |
7322 | return True; | |
7323 | end if; | |
90e491a7 | 7324 | |
69e6ee2f HK |
7325 | -- Otherwise the construct must be preelaborable. The check must |
7326 | -- take the syntactic and semantic structure of the construct. DO | |
7327 | -- NOT use Is_Preelaborable_Construct here. | |
90e491a7 | 7328 | |
69e6ee2f HK |
7329 | return not Is_Non_Preelaborable_Construct (N); |
7330 | end Is_OK_Preelaborable_Construct; | |
90e491a7 | 7331 | |
69e6ee2f HK |
7332 | --------------------------- |
7333 | -- Is_Suitable_Construct -- | |
7334 | --------------------------- | |
90e491a7 | 7335 | |
69e6ee2f HK |
7336 | function Is_Suitable_Construct (N : Node_Id) return Boolean is |
7337 | Context : constant Node_Id := Parent (N); | |
90e491a7 | 7338 | |
69e6ee2f HK |
7339 | begin |
7340 | -- An internally-generated statement sequence which contains only | |
7341 | -- a single null statement is not a suitable construct because it | |
7342 | -- is a byproduct of the parser. Such a null statement should be | |
7343 | -- excluded from the early call region because it carries the | |
7344 | -- source location of the "end" keyword, and may lead to confusing | |
7345 | -- diagnistics. | |
7346 | ||
7347 | if Nkind (N) = N_Null_Statement | |
7348 | and then not Comes_From_Source (N) | |
7349 | and then Present (Context) | |
7350 | and then Nkind (Context) = N_Handled_Sequence_Of_Statements | |
7351 | then | |
7352 | return False; | |
90e491a7 PMR |
7353 | end if; |
7354 | ||
69e6ee2f HK |
7355 | -- Otherwise only constructs which correspond to pure Ada |
7356 | -- constructs are considered suitable. | |
7357 | ||
7358 | case Nkind (N) is | |
7359 | when N_Call_Marker | |
7360 | | N_Freeze_Entity | |
7361 | | N_Freeze_Generic_Entity | |
7362 | | N_Implicit_Label_Declaration | |
7363 | | N_Itype_Reference | |
7364 | | N_Pop_Constraint_Error_Label | |
7365 | | N_Pop_Program_Error_Label | |
7366 | | N_Pop_Storage_Error_Label | |
7367 | | N_Push_Constraint_Error_Label | |
7368 | | N_Push_Program_Error_Label | |
7369 | | N_Push_Storage_Error_Label | |
7370 | | N_SCIL_Dispatch_Table_Tag_Init | |
7371 | | N_SCIL_Dispatching_Call | |
7372 | | N_SCIL_Membership_Test | |
7373 | | N_Variable_Reference_Marker | |
7374 | => | |
7375 | return False; | |
7376 | ||
7377 | when others => | |
7378 | return True; | |
7379 | end case; | |
7380 | end Is_Suitable_Construct; | |
90e491a7 | 7381 | |
69e6ee2f HK |
7382 | ---------------------------------- |
7383 | -- Transition_Body_Declarations -- | |
7384 | ---------------------------------- | |
90e491a7 | 7385 | |
69e6ee2f HK |
7386 | procedure Transition_Body_Declarations |
7387 | (Bod : Node_Id; | |
7388 | Curr : out Node_Id) | |
7389 | is | |
7390 | Decls : constant List_Id := Declarations (Bod); | |
90e491a7 | 7391 | |
69e6ee2f HK |
7392 | begin |
7393 | -- The search must come from the declarations of the body | |
90e491a7 | 7394 | |
69e6ee2f HK |
7395 | pragma Assert |
7396 | (Is_Non_Empty_List (Decls) | |
7397 | and then List_Containing (Start) = Decls); | |
90e491a7 | 7398 | |
69e6ee2f HK |
7399 | -- The search finished inspecting the declarations. The construct |
7400 | -- to inspect is the node which precedes the handled body, unless | |
7401 | -- the body is a compilation unit. The transitions are: | |
7402 | -- | |
7403 | -- declarations -> upper level | |
7404 | -- declarations -> corresponding package spec (Elab_Body) | |
7405 | -- declarations -> terminate | |
90e491a7 | 7406 | |
69e6ee2f HK |
7407 | Transition_Unit (Bod, Curr); |
7408 | end Transition_Body_Declarations; | |
90e491a7 | 7409 | |
69e6ee2f HK |
7410 | ----------------------------------- |
7411 | -- Transition_Handled_Statements -- | |
7412 | ----------------------------------- | |
90e491a7 | 7413 | |
69e6ee2f HK |
7414 | procedure Transition_Handled_Statements |
7415 | (HSS : Node_Id; | |
7416 | Curr : out Node_Id) | |
7417 | is | |
7418 | Bod : constant Node_Id := Parent (HSS); | |
7419 | Decls : constant List_Id := Declarations (Bod); | |
7420 | Stmts : constant List_Id := Statements (HSS); | |
90e491a7 | 7421 | |
69e6ee2f HK |
7422 | begin |
7423 | -- The search must come from the statements of certain bodies or | |
7424 | -- statements. | |
90e491a7 | 7425 | |
69e6ee2f HK |
7426 | pragma Assert (Nkind_In (Bod, N_Block_Statement, |
7427 | N_Entry_Body, | |
7428 | N_Package_Body, | |
7429 | N_Protected_Body, | |
7430 | N_Subprogram_Body, | |
7431 | N_Task_Body)); | |
90e491a7 | 7432 | |
69e6ee2f HK |
7433 | -- The search must come from the statements of the handled |
7434 | -- sequence. | |
90e491a7 | 7435 | |
69e6ee2f HK |
7436 | pragma Assert |
7437 | (Is_Non_Empty_List (Stmts) | |
7438 | and then List_Containing (Start) = Stmts); | |
90e491a7 | 7439 | |
69e6ee2f HK |
7440 | -- The search finished inspecting the statements. The handled body |
7441 | -- has non-empty declarations. The construct to inspect is the | |
7442 | -- last declaration. The transitions are: | |
7443 | -- | |
7444 | -- statements -> declarations | |
90e491a7 | 7445 | |
69e6ee2f HK |
7446 | if Has_Suitable_Construct (Decls) then |
7447 | Curr := Last (Decls); | |
90e491a7 | 7448 | |
69e6ee2f HK |
7449 | -- Otherwise the handled body lacks declarations. The construct to |
7450 | -- inspect is the node which precedes the handled body, unless the | |
7451 | -- body is a compilation unit. The transitions are: | |
7452 | -- | |
7453 | -- statements -> upper level | |
7454 | -- statements -> corresponding package spec (Elab_Body) | |
7455 | -- statements -> terminate | |
90e491a7 | 7456 | |
69e6ee2f HK |
7457 | else |
7458 | Transition_Unit (Bod, Curr); | |
7459 | end if; | |
7460 | end Transition_Handled_Statements; | |
90e491a7 | 7461 | |
69e6ee2f HK |
7462 | ---------------------------------- |
7463 | -- Transition_Spec_Declarations -- | |
7464 | ---------------------------------- | |
90e491a7 | 7465 | |
69e6ee2f HK |
7466 | procedure Transition_Spec_Declarations |
7467 | (Spec : Node_Id; | |
7468 | Curr : out Node_Id) | |
7469 | is | |
7470 | Prv_Decls : constant List_Id := Private_Declarations (Spec); | |
7471 | Vis_Decls : constant List_Id := Visible_Declarations (Spec); | |
90e491a7 | 7472 | |
69e6ee2f HK |
7473 | begin |
7474 | pragma Assert (Present (Start) and then Is_List_Member (Start)); | |
90e491a7 | 7475 | |
69e6ee2f HK |
7476 | -- The search came from the private declarations and finished |
7477 | -- their inspection. | |
90e491a7 | 7478 | |
69e6ee2f HK |
7479 | if Has_Suitable_Construct (Prv_Decls) |
7480 | and then List_Containing (Start) = Prv_Decls | |
7481 | then | |
7482 | -- The context has non-empty visible declarations. The node to | |
7483 | -- inspect is the last visible declaration. The transitions | |
7484 | -- are: | |
7485 | -- | |
7486 | -- private declarations -> visible declarations | |
90e491a7 | 7487 | |
69e6ee2f HK |
7488 | if Has_Suitable_Construct (Vis_Decls) then |
7489 | Curr := Last (Vis_Decls); | |
90e491a7 | 7490 | |
69e6ee2f HK |
7491 | -- Otherwise the context lacks visible declarations. The |
7492 | -- construct to inspect is the node which precedes the context | |
7493 | -- unless the context is a compilation unit. The transitions | |
7494 | -- are: | |
7495 | -- | |
7496 | -- private declarations -> upper level | |
7497 | -- private declarations -> terminate | |
90e491a7 | 7498 | |
69e6ee2f HK |
7499 | else |
7500 | Transition_Unit (Parent (Spec), Curr); | |
7501 | end if; | |
90e491a7 | 7502 | |
69e6ee2f HK |
7503 | -- The search came from the visible declarations and finished |
7504 | -- their inspections. The construct to inspect is the node which | |
7505 | -- precedes the context, unless the context is a compilaton unit. | |
7506 | -- The transitions are: | |
7507 | -- | |
7508 | -- visible declarations -> upper level | |
7509 | -- visible declarations -> terminate | |
90e491a7 | 7510 | |
69e6ee2f HK |
7511 | elsif Has_Suitable_Construct (Vis_Decls) |
7512 | and then List_Containing (Start) = Vis_Decls | |
7513 | then | |
7514 | Transition_Unit (Parent (Spec), Curr); | |
90e491a7 | 7515 | |
69e6ee2f HK |
7516 | -- At this point both declarative lists are empty, but the |
7517 | -- traversal still came from within the spec. This indicates | |
7518 | -- that the invariant of the algorithm has been violated. | |
90e491a7 | 7519 | |
69e6ee2f HK |
7520 | else |
7521 | pragma Assert (False); | |
7522 | raise ECR_Found; | |
7523 | end if; | |
7524 | end Transition_Spec_Declarations; | |
90e491a7 | 7525 | |
69e6ee2f HK |
7526 | --------------------- |
7527 | -- Transition_Unit -- | |
7528 | --------------------- | |
90e491a7 | 7529 | |
69e6ee2f HK |
7530 | procedure Transition_Unit |
7531 | (Unit : Node_Id; | |
7532 | Curr : out Node_Id) | |
7533 | is | |
7534 | Context : constant Node_Id := Parent (Unit); | |
90e491a7 | 7535 | |
69e6ee2f HK |
7536 | begin |
7537 | -- The unit is a compilation unit. This terminates the search | |
7538 | -- because there are no more lists to inspect and there are no | |
7539 | -- more enclosing constructs to climb up to. | |
90e491a7 | 7540 | |
69e6ee2f | 7541 | if Nkind (Context) = N_Compilation_Unit then |
90e491a7 | 7542 | |
69e6ee2f HK |
7543 | -- A package body with a corresponding spec subject to pragma |
7544 | -- Elaborate_Body is an exception to the above. The annotation | |
7545 | -- allows the search to continue into the package declaration. | |
7546 | -- The transitions are: | |
7547 | -- | |
7548 | -- statements -> corresponding package spec (Elab_Body) | |
7549 | -- declarations -> corresponding package spec (Elab_Body) | |
90e491a7 | 7550 | |
69e6ee2f HK |
7551 | if Nkind (Unit) = N_Package_Body |
7552 | and then (Assume_Elab_Body | |
7553 | or else Has_Pragma_Elaborate_Body | |
7554 | (Corresponding_Spec (Unit))) | |
7555 | then | |
7556 | Curr := Unit_Declaration_Node (Corresponding_Spec (Unit)); | |
7557 | Enter_Package_Declaration (Curr); | |
90e491a7 | 7558 | |
69e6ee2f HK |
7559 | -- Otherwise terminate the search. The transitions are: |
7560 | -- | |
7561 | -- private declarations -> terminate | |
7562 | -- visible declarations -> terminate | |
7563 | -- statements -> terminate | |
7564 | -- declarations -> terminate | |
90e491a7 | 7565 | |
69e6ee2f HK |
7566 | else |
7567 | raise ECR_Found; | |
7568 | end if; | |
90e491a7 | 7569 | |
69e6ee2f HK |
7570 | -- The unit is a subunit. The construct to inspect is the node |
7571 | -- which precedes the corresponding stub. Update the early call | |
7572 | -- region to include the unit. | |
90e491a7 | 7573 | |
69e6ee2f HK |
7574 | elsif Nkind (Context) = N_Subunit then |
7575 | Start := Unit; | |
7576 | Curr := Corresponding_Stub (Context); | |
90e491a7 | 7577 | |
69e6ee2f HK |
7578 | -- Otherwise the unit is nested. The construct to inspect is the |
7579 | -- node which precedes the unit. Update the early call region to | |
7580 | -- include the unit. | |
90e491a7 | 7581 | |
69e6ee2f HK |
7582 | else |
7583 | Include (Unit, Curr); | |
7584 | end if; | |
7585 | end Transition_Unit; | |
90e491a7 | 7586 | |
69e6ee2f | 7587 | -- Local variables |
90e491a7 | 7588 | |
69e6ee2f HK |
7589 | Body_Id : constant Entity_Id := Unique_Defining_Entity (Body_Decl); |
7590 | Region : Node_Id; | |
90e491a7 | 7591 | |
69e6ee2f | 7592 | -- Start of processing for Find_Early_Call_Region |
90e491a7 | 7593 | |
69e6ee2f HK |
7594 | begin |
7595 | -- The caller demands the start of the early call region without | |
7596 | -- saving or retrieving it to/from internal data structures. | |
90e491a7 | 7597 | |
69e6ee2f HK |
7598 | if Skip_Memoization then |
7599 | Region := Find_ECR (Body_Decl); | |
90e491a7 | 7600 | |
69e6ee2f | 7601 | -- Default behavior |
90e491a7 | 7602 | |
69e6ee2f HK |
7603 | else |
7604 | -- Check whether the early call region of the subprogram body is | |
7605 | -- available. | |
90e491a7 | 7606 | |
69e6ee2f | 7607 | Region := Early_Call_Region (Body_Id); |
90e491a7 | 7608 | |
69e6ee2f HK |
7609 | if No (Region) then |
7610 | Region := Find_ECR (Body_Decl); | |
90e491a7 | 7611 | |
69e6ee2f HK |
7612 | -- Associate the early call region with the subprogram body in |
7613 | -- case other scenarios need it. | |
90e491a7 | 7614 | |
69e6ee2f HK |
7615 | Set_Early_Call_Region (Body_Id, Region); |
7616 | end if; | |
7617 | end if; | |
90e491a7 | 7618 | |
69e6ee2f | 7619 | -- A subprogram body must always have an early call region |
90e491a7 | 7620 | |
69e6ee2f | 7621 | pragma Assert (Present (Region)); |
90e491a7 | 7622 | |
69e6ee2f HK |
7623 | return Region; |
7624 | end Find_Early_Call_Region; | |
90e491a7 | 7625 | |
69e6ee2f HK |
7626 | -------------------------------------------- |
7627 | -- Initialize_Early_Call_Region_Processor -- | |
7628 | -------------------------------------------- | |
90e491a7 | 7629 | |
69e6ee2f HK |
7630 | procedure Initialize_Early_Call_Region_Processor is |
7631 | begin | |
7632 | Early_Call_Regions_Map := ECR_Map.Create (100); | |
7633 | end Initialize_Early_Call_Region_Processor; | |
90e491a7 | 7634 | |
69e6ee2f HK |
7635 | --------------------------- |
7636 | -- Set_Early_Call_Region -- | |
7637 | --------------------------- | |
90e491a7 | 7638 | |
69e6ee2f HK |
7639 | procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id) is |
7640 | pragma Assert (Present (Body_Id)); | |
7641 | pragma Assert (Present (Start)); | |
daf82dd8 | 7642 | |
69e6ee2f HK |
7643 | begin |
7644 | ECR_Map.Put (Early_Call_Regions_Map, Body_Id, Start); | |
7645 | end Set_Early_Call_Region; | |
7646 | end Early_Call_Region_Processor; | |
daf82dd8 | 7647 | |
69e6ee2f HK |
7648 | ---------------------- |
7649 | -- Elaborated_Units -- | |
7650 | ---------------------- | |
daf82dd8 | 7651 | |
69e6ee2f | 7652 | package body Elaborated_Units is |
daf82dd8 | 7653 | |
69e6ee2f HK |
7654 | ----------- |
7655 | -- Types -- | |
7656 | ----------- | |
daf82dd8 | 7657 | |
69e6ee2f | 7658 | -- The following type idenfities the elaboration attributes of a unit |
daf82dd8 | 7659 | |
69e6ee2f | 7660 | type Elaboration_Attributes_Id is new Natural; |
daf82dd8 | 7661 | |
69e6ee2f HK |
7662 | No_Elaboration_Attributes : constant Elaboration_Attributes_Id := |
7663 | Elaboration_Attributes_Id'First; | |
7664 | First_Elaboration_Attributes : constant Elaboration_Attributes_Id := | |
7665 | No_Elaboration_Attributes + 1; | |
90e491a7 | 7666 | |
69e6ee2f | 7667 | -- The following type represents the elaboration attributes of a unit |
90e491a7 | 7668 | |
69e6ee2f HK |
7669 | type Elaboration_Attributes_Record is record |
7670 | Elab_Pragma : Node_Id := Empty; | |
7671 | -- This attribute denotes a source Elaborate or Elaborate_All pragma | |
7672 | -- which guarantees the prior elaboration of some unit with respect | |
7673 | -- to the main unit. The pragma may come from the following contexts: | |
7674 | -- | |
7675 | -- * The main unit | |
7676 | -- * The spec of the main unit (if applicable) | |
7677 | -- * Any parent spec of the main unit (if applicable) | |
7678 | -- * Any parent subunit of the main unit (if applicable) | |
7679 | -- | |
7680 | -- The attribute remains Empty if no such pragma is available. Source | |
7681 | -- pragmas play a role in satisfying SPARK elaboration requirements. | |
daf82dd8 | 7682 | |
69e6ee2f HK |
7683 | With_Clause : Node_Id := Empty; |
7684 | -- This attribute denotes an internally-generated or a source with | |
7685 | -- clause for some unit withed by the main unit. With clauses carry | |
7686 | -- flags which represent implicit Elaborate or Elaborate_All pragmas. | |
7687 | -- These clauses play a role in supplying elaboration dependencies to | |
7688 | -- binde. | |
7689 | end record; | |
daf82dd8 | 7690 | |
69e6ee2f HK |
7691 | --------------------- |
7692 | -- Data structures -- | |
7693 | --------------------- | |
90e491a7 | 7694 | |
69e6ee2f HK |
7695 | -- The following table stores all elaboration attributes |
7696 | ||
7697 | package Elaboration_Attributes is new Table.Table | |
7698 | (Table_Index_Type => Elaboration_Attributes_Id, | |
7699 | Table_Component_Type => Elaboration_Attributes_Record, | |
7700 | Table_Low_Bound => First_Elaboration_Attributes, | |
7701 | Table_Initial => 250, | |
7702 | Table_Increment => 200, | |
7703 | Table_Name => "Elaboration_Attributes"); | |
7704 | ||
7705 | procedure Destroy (EA_Id : in out Elaboration_Attributes_Id); | |
7706 | -- Destroy elaboration attributes EA_Id | |
7707 | ||
7708 | package UA_Map is new Dynamic_Hash_Tables | |
7709 | (Key_Type => Entity_Id, | |
7710 | Value_Type => Elaboration_Attributes_Id, | |
7711 | No_Value => No_Elaboration_Attributes, | |
7712 | Expansion_Threshold => 1.5, | |
7713 | Expansion_Factor => 2, | |
7714 | Compression_Threshold => 0.3, | |
7715 | Compression_Factor => 2, | |
7716 | "=" => "=", | |
7717 | Destroy_Value => Destroy, | |
7718 | Hash => Hash); | |
7719 | ||
7720 | -- The following map relates an elaboration attributes of a unit to the | |
7721 | -- unit. | |
90e491a7 | 7722 | |
0839ffce | 7723 | Unit_To_Attributes_Map : UA_Map.Dynamic_Hash_Table := UA_Map.Nil; |
90e491a7 | 7724 | |
69e6ee2f HK |
7725 | ------------------ |
7726 | -- Constructors -- | |
7727 | ------------------ | |
90e491a7 | 7728 | |
69e6ee2f HK |
7729 | function Elaboration_Attributes_Of |
7730 | (Unit_Id : Entity_Id) return Elaboration_Attributes_Id; | |
7731 | pragma Inline (Elaboration_Attributes_Of); | |
7732 | -- Obtain the elaboration attributes of unit Unit_Id | |
90e491a7 | 7733 | |
69e6ee2f HK |
7734 | ----------------------- |
7735 | -- Local subprograms -- | |
7736 | ----------------------- | |
8dce7371 | 7737 | |
69e6ee2f HK |
7738 | function Elab_Pragma (EA_Id : Elaboration_Attributes_Id) return Node_Id; |
7739 | pragma Inline (Elab_Pragma); | |
7740 | -- Obtain the Elaborate[_All] pragma of elaboration attributes EA_Id | |
7741 | ||
7742 | procedure Ensure_Prior_Elaboration_Dynamic | |
7743 | (N : Node_Id; | |
7744 | Unit_Id : Entity_Id; | |
7745 | Prag_Nam : Name_Id; | |
7746 | In_State : Processing_In_State); | |
7747 | pragma Inline (Ensure_Prior_Elaboration_Dynamic); | |
7748 | -- Guarantee the elaboration of unit Unit_Id with respect to the main | |
7749 | -- unit by suggesting the use of Elaborate[_All] with name Prag_Nam. N | |
7750 | -- denotes the related scenario. In_State is the current state of the | |
7751 | -- Processing phase. | |
7752 | ||
7753 | procedure Ensure_Prior_Elaboration_Static | |
7754 | (N : Node_Id; | |
7755 | Unit_Id : Entity_Id; | |
7756 | Prag_Nam : Name_Id; | |
7757 | In_State : Processing_In_State); | |
7758 | pragma Inline (Ensure_Prior_Elaboration_Static); | |
7759 | -- Guarantee the elaboration of unit Unit_Id with respect to the main | |
7760 | -- unit by installing an implicit Elaborate[_All] pragma with name | |
7761 | -- Prag_Nam. N denotes the related scenario. In_State is the current | |
7762 | -- state of the Processing phase. | |
7763 | ||
7764 | function Present (EA_Id : Elaboration_Attributes_Id) return Boolean; | |
7765 | pragma Inline (Present); | |
7766 | -- Determine whether elaboration attributes UA_Id exist | |
7767 | ||
7768 | procedure Set_Elab_Pragma | |
7769 | (EA_Id : Elaboration_Attributes_Id; | |
7770 | Prag : Node_Id); | |
7771 | pragma Inline (Set_Elab_Pragma); | |
7772 | -- Set the Elaborate[_All] pragma of elaboration attributes EA_Id to | |
7773 | -- Prag. | |
7774 | ||
7775 | procedure Set_With_Clause | |
7776 | (EA_Id : Elaboration_Attributes_Id; | |
7777 | Clause : Node_Id); | |
7778 | pragma Inline (Set_With_Clause); | |
7779 | -- Set the with clause of elaboration attributes EA_Id to Clause | |
7780 | ||
7781 | function With_Clause (EA_Id : Elaboration_Attributes_Id) return Node_Id; | |
7782 | pragma Inline (With_Clause); | |
7783 | -- Obtain the implicit or source with clause of elaboration attributes | |
7784 | -- EA_Id. | |
8dce7371 | 7785 | |
69e6ee2f HK |
7786 | ------------------------------ |
7787 | -- Collect_Elaborated_Units -- | |
7788 | ------------------------------ | |
8dce7371 | 7789 | |
69e6ee2f HK |
7790 | procedure Collect_Elaborated_Units is |
7791 | procedure Add_Pragma (Prag : Node_Id); | |
7792 | pragma Inline (Add_Pragma); | |
7793 | -- Determine whether pragma Prag denotes a legal Elaborate[_All] | |
7794 | -- pragma. If this is the case, add the related unit to the context. | |
7795 | -- For pragma Elaborate_All, include recursively all units withed by | |
7796 | -- the related unit. | |
7797 | ||
7798 | procedure Add_Unit | |
7799 | (Unit_Id : Entity_Id; | |
7800 | Prag : Node_Id; | |
7801 | Full_Context : Boolean); | |
7802 | pragma Inline (Add_Unit); | |
7803 | -- Add unit Unit_Id to the elaboration context. Prag denotes the | |
7804 | -- pragma which prompted the inclusion of the unit to the context. | |
7805 | -- If flag Full_Context is set, examine the nonlimited clauses of | |
7806 | -- unit Unit_Id and add each withed unit to the context. | |
7807 | ||
7808 | procedure Find_Elaboration_Context (Comp_Unit : Node_Id); | |
7809 | pragma Inline (Find_Elaboration_Context); | |
7810 | -- Examine the context items of compilation unit Comp_Unit for | |
7811 | -- suitable elaboration-related pragmas and add all related units | |
7812 | -- to the context. | |
7813 | ||
7814 | ---------------- | |
7815 | -- Add_Pragma -- | |
7816 | ---------------- | |
7817 | ||
7818 | procedure Add_Pragma (Prag : Node_Id) is | |
7819 | Prag_Args : constant List_Id := | |
7820 | Pragma_Argument_Associations (Prag); | |
7821 | Prag_Nam : constant Name_Id := Pragma_Name (Prag); | |
7822 | Unit_Arg : Node_Id; | |
8dce7371 | 7823 | |
69e6ee2f HK |
7824 | begin |
7825 | -- Nothing to do if the pragma is not related to elaboration | |
8dce7371 | 7826 | |
69e6ee2f HK |
7827 | if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then |
7828 | return; | |
8dce7371 | 7829 | |
69e6ee2f | 7830 | -- Nothing to do when the pragma is illegal |
8dce7371 | 7831 | |
69e6ee2f HK |
7832 | elsif Error_Posted (Prag) then |
7833 | return; | |
7834 | end if; | |
8dce7371 | 7835 | |
69e6ee2f | 7836 | Unit_Arg := Get_Pragma_Arg (First (Prag_Args)); |
8dce7371 | 7837 | |
69e6ee2f | 7838 | -- The argument of the pragma may appear in package.package form |
8dce7371 | 7839 | |
69e6ee2f HK |
7840 | if Nkind (Unit_Arg) = N_Selected_Component then |
7841 | Unit_Arg := Selector_Name (Unit_Arg); | |
7842 | end if; | |
8dce7371 | 7843 | |
69e6ee2f HK |
7844 | Add_Unit |
7845 | (Unit_Id => Entity (Unit_Arg), | |
7846 | Prag => Prag, | |
7847 | Full_Context => Prag_Nam = Name_Elaborate_All); | |
7848 | end Add_Pragma; | |
8dce7371 | 7849 | |
69e6ee2f HK |
7850 | -------------- |
7851 | -- Add_Unit -- | |
7852 | -------------- | |
8dce7371 | 7853 | |
69e6ee2f HK |
7854 | procedure Add_Unit |
7855 | (Unit_Id : Entity_Id; | |
7856 | Prag : Node_Id; | |
7857 | Full_Context : Boolean) | |
7858 | is | |
7859 | Clause : Node_Id; | |
7860 | EA_Id : Elaboration_Attributes_Id; | |
7861 | Unit_Prag : Node_Id; | |
8dce7371 | 7862 | |
69e6ee2f HK |
7863 | begin |
7864 | -- Nothing to do when some previous error left a with clause or a | |
7865 | -- pragma in a bad state. | |
8dce7371 | 7866 | |
69e6ee2f HK |
7867 | if No (Unit_Id) then |
7868 | return; | |
7869 | end if; | |
8dce7371 | 7870 | |
69e6ee2f HK |
7871 | EA_Id := Elaboration_Attributes_Of (Unit_Id); |
7872 | Unit_Prag := Elab_Pragma (EA_Id); | |
8dce7371 | 7873 | |
69e6ee2f HK |
7874 | -- The unit is already included in the context by means of pragma |
7875 | -- Elaborate[_All]. | |
8dce7371 | 7876 | |
69e6ee2f | 7877 | if Present (Unit_Prag) then |
8dce7371 | 7878 | |
69e6ee2f HK |
7879 | -- Upgrade an existing pragma Elaborate when the unit is |
7880 | -- subject to Elaborate_All because the new pragma covers a | |
7881 | -- larger set of units. | |
8dce7371 | 7882 | |
69e6ee2f HK |
7883 | if Pragma_Name (Unit_Prag) = Name_Elaborate |
7884 | and then Pragma_Name (Prag) = Name_Elaborate_All | |
7885 | then | |
7886 | Set_Elab_Pragma (EA_Id, Prag); | |
8dce7371 | 7887 | |
69e6ee2f HK |
7888 | -- Otherwise the unit retains its existing pragma and does not |
7889 | -- need to be included in the context again. | |
8dce7371 | 7890 | |
69e6ee2f HK |
7891 | else |
7892 | return; | |
7893 | end if; | |
8dce7371 | 7894 | |
69e6ee2f | 7895 | -- Otherwise the current unit is not included in the context |
8dce7371 PMR |
7896 | |
7897 | else | |
69e6ee2f | 7898 | Set_Elab_Pragma (EA_Id, Prag); |
8dce7371 | 7899 | end if; |
8dce7371 | 7900 | |
69e6ee2f HK |
7901 | -- Includes all units withed by the current one when computing the |
7902 | -- full context. | |
8dce7371 | 7903 | |
69e6ee2f | 7904 | if Full_Context then |
8dce7371 | 7905 | |
69e6ee2f HK |
7906 | -- Process all nonlimited with clauses found in the context of |
7907 | -- the current unit. Note that limited clauses do not impose an | |
7908 | -- elaboration order. | |
8dce7371 | 7909 | |
69e6ee2f HK |
7910 | Clause := First (Context_Items (Compilation_Unit (Unit_Id))); |
7911 | while Present (Clause) loop | |
7912 | if Nkind (Clause) = N_With_Clause | |
7913 | and then not Error_Posted (Clause) | |
7914 | and then not Limited_Present (Clause) | |
7915 | then | |
7916 | Add_Unit | |
7917 | (Unit_Id => Entity (Name (Clause)), | |
7918 | Prag => Prag, | |
7919 | Full_Context => Full_Context); | |
7920 | end if; | |
8dce7371 | 7921 | |
69e6ee2f HK |
7922 | Next (Clause); |
7923 | end loop; | |
7924 | end if; | |
7925 | end Add_Unit; | |
8dce7371 | 7926 | |
69e6ee2f HK |
7927 | ------------------------------ |
7928 | -- Find_Elaboration_Context -- | |
7929 | ------------------------------ | |
8dce7371 | 7930 | |
69e6ee2f HK |
7931 | procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is |
7932 | pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit); | |
8dce7371 | 7933 | |
69e6ee2f | 7934 | Prag : Node_Id; |
8dce7371 | 7935 | |
69e6ee2f HK |
7936 | begin |
7937 | -- Process all elaboration-related pragmas found in the context of | |
7938 | -- the compilation unit. | |
8dce7371 | 7939 | |
69e6ee2f HK |
7940 | Prag := First (Context_Items (Comp_Unit)); |
7941 | while Present (Prag) loop | |
7942 | if Nkind (Prag) = N_Pragma then | |
7943 | Add_Pragma (Prag); | |
7944 | end if; | |
8dce7371 | 7945 | |
69e6ee2f HK |
7946 | Next (Prag); |
7947 | end loop; | |
7948 | end Find_Elaboration_Context; | |
8dce7371 | 7949 | |
69e6ee2f | 7950 | -- Local variables |
8dce7371 | 7951 | |
69e6ee2f HK |
7952 | Par_Id : Entity_Id; |
7953 | Unit_Id : Node_Id; | |
8dce7371 | 7954 | |
69e6ee2f | 7955 | -- Start of processing for Collect_Elaborated_Units |
8dce7371 | 7956 | |
69e6ee2f HK |
7957 | begin |
7958 | -- Perform a traversal to examines the context of the main unit. The | |
7959 | -- traversal performs the following jumps: | |
7960 | -- | |
7961 | -- subunit -> parent subunit | |
7962 | -- parent subunit -> body | |
7963 | -- body -> spec | |
7964 | -- spec -> parent spec | |
7965 | -- parent spec -> grandparent spec and so on | |
7966 | -- | |
7967 | -- The traversal relies on units rather than scopes because the scope | |
7968 | -- of a subunit is some spec, while this traversal must process the | |
7969 | -- body as well. Given that protected and task bodies can also be | |
7970 | -- subunits, this complicates the scope approach even further. | |
8dce7371 | 7971 | |
69e6ee2f | 7972 | Unit_Id := Unit (Cunit (Main_Unit)); |
8dce7371 | 7973 | |
69e6ee2f HK |
7974 | -- Perform the following traversals when the main unit is a subunit |
7975 | -- | |
7976 | -- subunit -> parent subunit | |
7977 | -- parent subunit -> body | |
8dce7371 | 7978 | |
69e6ee2f HK |
7979 | while Present (Unit_Id) and then Nkind (Unit_Id) = N_Subunit loop |
7980 | Find_Elaboration_Context (Parent (Unit_Id)); | |
8dce7371 | 7981 | |
69e6ee2f HK |
7982 | -- Continue the traversal by going to the unit which contains the |
7983 | -- corresponding stub. | |
8dce7371 | 7984 | |
69e6ee2f HK |
7985 | if Present (Corresponding_Stub (Unit_Id)) then |
7986 | Unit_Id := | |
7987 | Unit (Cunit (Get_Source_Unit (Corresponding_Stub (Unit_Id)))); | |
8dce7371 | 7988 | |
69e6ee2f | 7989 | -- Otherwise the subunit may be erroneous or left in a bad state |
8dce7371 | 7990 | |
69e6ee2f HK |
7991 | else |
7992 | exit; | |
8dce7371 | 7993 | end if; |
69e6ee2f | 7994 | end loop; |
8dce7371 | 7995 | |
69e6ee2f HK |
7996 | -- Perform the following traversal now that subunits have been taken |
7997 | -- care of, or the main unit is a body. | |
7998 | -- | |
7999 | -- body -> spec | |
8dce7371 | 8000 | |
69e6ee2f HK |
8001 | if Present (Unit_Id) |
8002 | and then Nkind_In (Unit_Id, N_Package_Body, N_Subprogram_Body) | |
8003 | then | |
8004 | Find_Elaboration_Context (Parent (Unit_Id)); | |
8dce7371 | 8005 | |
69e6ee2f HK |
8006 | -- Continue the traversal by going to the unit which contains the |
8007 | -- corresponding spec. | |
8dce7371 | 8008 | |
69e6ee2f HK |
8009 | if Present (Corresponding_Spec (Unit_Id)) then |
8010 | Unit_Id := | |
8011 | Unit (Cunit (Get_Source_Unit (Corresponding_Spec (Unit_Id)))); | |
8012 | end if; | |
8013 | end if; | |
8dce7371 | 8014 | |
69e6ee2f HK |
8015 | -- Perform the following traversals now that the body has been taken |
8016 | -- care of, or the main unit is a spec. | |
8017 | -- | |
8018 | -- spec -> parent spec | |
8019 | -- parent spec -> grandparent spec and so on | |
8020 | ||
8021 | if Present (Unit_Id) | |
8022 | and then Nkind_In (Unit_Id, N_Generic_Package_Declaration, | |
8023 | N_Generic_Subprogram_Declaration, | |
8024 | N_Package_Declaration, | |
8025 | N_Subprogram_Declaration) | |
8026 | then | |
8027 | Find_Elaboration_Context (Parent (Unit_Id)); | |
8dce7371 | 8028 | |
69e6ee2f HK |
8029 | -- Process a potential chain of parent units which ends with the |
8030 | -- main unit spec. The traversal can now safely rely on the scope | |
8031 | -- chain. | |
8dce7371 | 8032 | |
69e6ee2f HK |
8033 | Par_Id := Scope (Defining_Entity (Unit_Id)); |
8034 | while Present (Par_Id) and then Par_Id /= Standard_Standard loop | |
8035 | Find_Elaboration_Context (Compilation_Unit (Par_Id)); | |
8dce7371 | 8036 | |
69e6ee2f | 8037 | Par_Id := Scope (Par_Id); |
8dce7371 PMR |
8038 | end loop; |
8039 | end if; | |
69e6ee2f | 8040 | end Collect_Elaborated_Units; |
8dce7371 PMR |
8041 | |
8042 | ------------- | |
69e6ee2f | 8043 | -- Destroy -- |
8dce7371 PMR |
8044 | ------------- |
8045 | ||
69e6ee2f HK |
8046 | procedure Destroy (EA_Id : in out Elaboration_Attributes_Id) is |
8047 | pragma Unreferenced (EA_Id); | |
8dce7371 | 8048 | begin |
69e6ee2f HK |
8049 | null; |
8050 | end Destroy; | |
19c6e49c | 8051 | |
69e6ee2f HK |
8052 | ----------------- |
8053 | -- Elab_Pragma -- | |
8054 | ----------------- | |
19c6e49c | 8055 | |
69e6ee2f HK |
8056 | function Elab_Pragma |
8057 | (EA_Id : Elaboration_Attributes_Id) return Node_Id | |
8058 | is | |
8059 | pragma Assert (Present (EA_Id)); | |
8060 | begin | |
8061 | return Elaboration_Attributes.Table (EA_Id).Elab_Pragma; | |
8062 | end Elab_Pragma; | |
19c6e49c | 8063 | |
69e6ee2f HK |
8064 | ------------------------------- |
8065 | -- Elaboration_Attributes_Of -- | |
8066 | ------------------------------- | |
8dce7371 | 8067 | |
69e6ee2f HK |
8068 | function Elaboration_Attributes_Of |
8069 | (Unit_Id : Entity_Id) return Elaboration_Attributes_Id | |
8070 | is | |
8071 | EA_Id : Elaboration_Attributes_Id; | |
8dce7371 | 8072 | |
8dce7371 | 8073 | begin |
69e6ee2f | 8074 | EA_Id := UA_Map.Get (Unit_To_Attributes_Map, Unit_Id); |
8dce7371 | 8075 | |
69e6ee2f HK |
8076 | -- The unit lacks elaboration attributes. This indicates that the |
8077 | -- unit is encountered for the first time. Create the elaboration | |
8078 | -- attributes for it. | |
8dce7371 | 8079 | |
69e6ee2f HK |
8080 | if not Present (EA_Id) then |
8081 | Elaboration_Attributes.Append | |
8082 | ((Elab_Pragma => Empty, | |
8083 | With_Clause => Empty)); | |
8084 | EA_Id := Elaboration_Attributes.Last; | |
8dce7371 | 8085 | |
69e6ee2f HK |
8086 | -- Associate the elaboration attributes with the unit |
8087 | ||
8088 | UA_Map.Put (Unit_To_Attributes_Map, Unit_Id, EA_Id); | |
8dce7371 PMR |
8089 | end if; |
8090 | ||
69e6ee2f | 8091 | pragma Assert (Present (EA_Id)); |
8dce7371 | 8092 | |
69e6ee2f HK |
8093 | return EA_Id; |
8094 | end Elaboration_Attributes_Of; | |
8dce7371 | 8095 | |
69e6ee2f HK |
8096 | ------------------------------ |
8097 | -- Ensure_Prior_Elaboration -- | |
8098 | ------------------------------ | |
8dce7371 | 8099 | |
69e6ee2f HK |
8100 | procedure Ensure_Prior_Elaboration |
8101 | (N : Node_Id; | |
8102 | Unit_Id : Entity_Id; | |
8103 | Prag_Nam : Name_Id; | |
8104 | In_State : Processing_In_State) | |
8105 | is | |
8106 | pragma Assert (Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All)); | |
8dce7371 PMR |
8107 | |
8108 | begin | |
69e6ee2f HK |
8109 | -- Nothing to do when the need for prior elaboration came from a |
8110 | -- partial finalization routine which occurs in an initialization | |
8111 | -- context. This behaviour parallels that of the old ABE mechanism. | |
8112 | ||
8113 | if In_State.Within_Partial_Finalization then | |
8114 | return; | |
8dce7371 | 8115 | |
69e6ee2f HK |
8116 | -- Nothing to do when the need for prior elaboration came from a task |
8117 | -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on | |
8118 | -- task bodies) is in effect. | |
8119 | ||
8120 | elsif Debug_Flag_Dot_Y and then In_State.Within_Task_Body then | |
8121 | return; | |
8122 | ||
8123 | -- Nothing to do when the unit is elaborated prior to the main unit. | |
8124 | -- This check must also consider the following cases: | |
8125 | -- | |
8126 | -- * No check is made against the context of the main unit because | |
8127 | -- this is specific to the elaboration model in effect and requires | |
8128 | -- custom handling (see Ensure_xxx_Prior_Elaboration). | |
8129 | -- | |
8130 | -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma | |
8131 | -- Elaborate[_All] MUST be generated even though Unit_Id is always | |
8132 | -- elaborated prior to the main unit. This conservative strategy | |
8133 | -- ensures that other units withed by Unit_Id will not lead to an | |
8134 | -- ABE. | |
8135 | -- | |
8136 | -- package A is package body A is | |
8137 | -- procedure ABE; procedure ABE is ... end ABE; | |
8138 | -- end A; end A; | |
8139 | -- | |
8140 | -- with A; | |
8141 | -- package B is package body B is | |
8142 | -- pragma Elaborate_Body; procedure Proc is | |
8143 | -- begin | |
8144 | -- procedure Proc; A.ABE; | |
8145 | -- package B; end Proc; | |
8146 | -- end B; | |
8147 | -- | |
8148 | -- with B; | |
8149 | -- package C is package body C is | |
8150 | -- ... ... | |
8151 | -- end C; begin | |
8152 | -- B.Proc; | |
8153 | -- end C; | |
8154 | -- | |
8155 | -- In the example above, the elaboration of C invokes B.Proc. B is | |
8156 | -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] | |
8157 | -- is gnerated for B in C, then the following elaboratio order will | |
8158 | -- lead to an ABE: | |
8159 | -- | |
8160 | -- spec of A elaborated | |
8161 | -- spec of B elaborated | |
8162 | -- body of B elaborated | |
8163 | -- spec of C elaborated | |
8164 | -- body of C elaborated <-- calls B.Proc which calls A.ABE | |
8165 | -- body of A elaborated <-- problem | |
8166 | -- | |
8167 | -- The generation of an implicit pragma Elaborate_All (B) ensures | |
3eb5e54a | 8168 | -- that the elaboration-order mechanism will not pick the above |
69e6ee2f HK |
8169 | -- order. |
8170 | -- | |
8171 | -- An implicit Elaborate is NOT generated when the unit is subject | |
8172 | -- to Elaborate_Body because both pragmas have the same effect. | |
8173 | -- | |
8174 | -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] | |
8175 | -- MUST NOT be generated in this case because a unit cannot depend | |
8176 | -- on its own elaboration. This case is therefore treated as valid | |
8177 | -- prior elaboration. | |
8178 | ||
8179 | elsif Has_Prior_Elaboration | |
8180 | (Unit_Id => Unit_Id, | |
8181 | Same_Unit_OK => True, | |
8182 | Elab_Body_OK => Prag_Nam = Name_Elaborate) | |
8dce7371 | 8183 | then |
69e6ee2f | 8184 | return; |
8dce7371 PMR |
8185 | end if; |
8186 | ||
69e6ee2f HK |
8187 | -- Suggest the use of pragma Prag_Nam when the dynamic model is in |
8188 | -- effect. | |
8dce7371 | 8189 | |
69e6ee2f HK |
8190 | if Dynamic_Elaboration_Checks then |
8191 | Ensure_Prior_Elaboration_Dynamic | |
8192 | (N => N, | |
8193 | Unit_Id => Unit_Id, | |
8194 | Prag_Nam => Prag_Nam, | |
8195 | In_State => In_State); | |
8dce7371 | 8196 | |
69e6ee2f HK |
8197 | -- Install an implicit pragma Prag_Nam when the static model is in |
8198 | -- effect. | |
8dce7371 | 8199 | |
69e6ee2f HK |
8200 | else |
8201 | pragma Assert (Static_Elaboration_Checks); | |
8202 | ||
8203 | Ensure_Prior_Elaboration_Static | |
8204 | (N => N, | |
8205 | Unit_Id => Unit_Id, | |
8206 | Prag_Nam => Prag_Nam, | |
8207 | In_State => In_State); | |
8208 | end if; | |
8209 | end Ensure_Prior_Elaboration; | |
8210 | ||
8211 | -------------------------------------- | |
8212 | -- Ensure_Prior_Elaboration_Dynamic -- | |
8213 | -------------------------------------- | |
8dce7371 | 8214 | |
69e6ee2f HK |
8215 | procedure Ensure_Prior_Elaboration_Dynamic |
8216 | (N : Node_Id; | |
8217 | Unit_Id : Entity_Id; | |
8218 | Prag_Nam : Name_Id; | |
8219 | In_State : Processing_In_State) | |
8dce7371 | 8220 | is |
69e6ee2f HK |
8221 | procedure Info_Missing_Pragma; |
8222 | pragma Inline (Info_Missing_Pragma); | |
8223 | -- Output information concerning missing Elaborate or Elaborate_All | |
8224 | -- pragma with name Prag_Nam for scenario N, which would ensure the | |
8225 | -- prior elaboration of Unit_Id. | |
8dce7371 | 8226 | |
69e6ee2f HK |
8227 | ------------------------- |
8228 | -- Info_Missing_Pragma -- | |
8229 | ------------------------- | |
8dce7371 | 8230 | |
69e6ee2f HK |
8231 | procedure Info_Missing_Pragma is |
8232 | begin | |
8233 | -- Internal units are ignored as they cause unnecessary noise | |
8dce7371 | 8234 | |
69e6ee2f | 8235 | if not In_Internal_Unit (Unit_Id) then |
8dce7371 | 8236 | |
69e6ee2f HK |
8237 | -- The name of the unit subjected to the elaboration pragma is |
8238 | -- fully qualified to improve the clarity of the info message. | |
8dce7371 | 8239 | |
69e6ee2f HK |
8240 | Error_Msg_Name_1 := Prag_Nam; |
8241 | Error_Msg_Qual_Level := Nat'Last; | |
8dce7371 | 8242 | |
69e6ee2f HK |
8243 | Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id); |
8244 | Error_Msg_Qual_Level := 0; | |
8245 | end if; | |
8246 | end Info_Missing_Pragma; | |
8247 | ||
8248 | -- Local variables | |
8249 | ||
8250 | EA_Id : constant Elaboration_Attributes_Id := | |
8251 | Elaboration_Attributes_Of (Unit_Id); | |
8252 | N_Lvl : Enclosing_Level_Kind; | |
8253 | N_Rep : Scenario_Rep_Id; | |
8254 | ||
8255 | -- Start of processing for Ensure_Prior_Elaboration_Dynamic | |
8dce7371 PMR |
8256 | |
8257 | begin | |
69e6ee2f HK |
8258 | -- Nothing to do when the unit is guaranteed prior elaboration by |
8259 | -- means of a source Elaborate[_All] pragma. | |
8dce7371 | 8260 | |
69e6ee2f HK |
8261 | if Present (Elab_Pragma (EA_Id)) then |
8262 | return; | |
8263 | end if; | |
8dce7371 | 8264 | |
69e6ee2f HK |
8265 | -- Output extra information on a missing Elaborate[_All] pragma when |
8266 | -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas | |
8267 | -- is in effect. | |
8dce7371 | 8268 | |
69e6ee2f HK |
8269 | if Elab_Info_Messages |
8270 | and then not In_State.Suppress_Info_Messages | |
8271 | then | |
8272 | N_Rep := Scenario_Representation_Of (N, In_State); | |
8273 | N_Lvl := Level (N_Rep); | |
8dce7371 | 8274 | |
69e6ee2f | 8275 | -- Declaration-level scenario |
8dce7371 | 8276 | |
69e6ee2f HK |
8277 | if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N)) |
8278 | and then N_Lvl = Declaration_Level | |
8279 | then | |
8280 | null; | |
8dce7371 | 8281 | |
69e6ee2f | 8282 | -- Library-level scenario |
8dce7371 | 8283 | |
69e6ee2f HK |
8284 | elsif N_Lvl in Library_Level then |
8285 | null; | |
8286 | ||
8287 | -- Instantiation library-level scenario | |
8288 | ||
8289 | elsif N_Lvl = Instantiation_Level then | |
8290 | null; | |
8291 | ||
8292 | -- Otherwise the scenario does not appear at the proper level | |
8293 | ||
8294 | else | |
8295 | return; | |
8296 | end if; | |
8297 | ||
8298 | Info_Missing_Pragma; | |
8dce7371 | 8299 | end if; |
69e6ee2f | 8300 | end Ensure_Prior_Elaboration_Dynamic; |
8dce7371 | 8301 | |
69e6ee2f HK |
8302 | ------------------------------------- |
8303 | -- Ensure_Prior_Elaboration_Static -- | |
8304 | ------------------------------------- | |
8dce7371 | 8305 | |
69e6ee2f HK |
8306 | procedure Ensure_Prior_Elaboration_Static |
8307 | (N : Node_Id; | |
8308 | Unit_Id : Entity_Id; | |
8309 | Prag_Nam : Name_Id; | |
8310 | In_State : Processing_In_State) | |
8dce7371 | 8311 | is |
69e6ee2f HK |
8312 | function Find_With_Clause |
8313 | (Items : List_Id; | |
8314 | Withed_Id : Entity_Id) return Node_Id; | |
8315 | pragma Inline (Find_With_Clause); | |
8316 | -- Find a nonlimited with clause in the list of context items Items | |
8317 | -- that withs unit Withed_Id. Return Empty if no such clause exists. | |
8318 | ||
8319 | procedure Info_Implicit_Pragma; | |
8320 | pragma Inline (Info_Implicit_Pragma); | |
8321 | -- Output information concerning an implicitly generated Elaborate | |
8322 | -- or Elaborate_All pragma with name Prag_Nam for scenario N which | |
8323 | -- ensures the prior elaboration of unit Unit_Id. | |
8324 | ||
8325 | ---------------------- | |
8326 | -- Find_With_Clause -- | |
8327 | ---------------------- | |
8328 | ||
8329 | function Find_With_Clause | |
8330 | (Items : List_Id; | |
8331 | Withed_Id : Entity_Id) return Node_Id | |
8332 | is | |
8333 | Item : Node_Id; | |
8dce7371 | 8334 | |
69e6ee2f HK |
8335 | begin |
8336 | -- Examine the context clauses looking for a suitable with. Note | |
8337 | -- that limited clauses do not affect the elaboration order. | |
8dce7371 | 8338 | |
69e6ee2f HK |
8339 | Item := First (Items); |
8340 | while Present (Item) loop | |
8341 | if Nkind (Item) = N_With_Clause | |
8342 | and then not Error_Posted (Item) | |
8343 | and then not Limited_Present (Item) | |
8344 | and then Entity (Name (Item)) = Withed_Id | |
8345 | then | |
8346 | return Item; | |
8347 | end if; | |
8dce7371 | 8348 | |
69e6ee2f HK |
8349 | Next (Item); |
8350 | end loop; | |
8dce7371 | 8351 | |
69e6ee2f HK |
8352 | return Empty; |
8353 | end Find_With_Clause; | |
8dce7371 | 8354 | |
69e6ee2f HK |
8355 | -------------------------- |
8356 | -- Info_Implicit_Pragma -- | |
8357 | -------------------------- | |
8dce7371 | 8358 | |
69e6ee2f HK |
8359 | procedure Info_Implicit_Pragma is |
8360 | begin | |
8361 | -- Internal units are ignored as they cause unnecessary noise | |
8dce7371 | 8362 | |
69e6ee2f | 8363 | if not In_Internal_Unit (Unit_Id) then |
8dce7371 | 8364 | |
69e6ee2f HK |
8365 | -- The name of the unit subjected to the elaboration pragma is |
8366 | -- fully qualified to improve the clarity of the info message. | |
8dce7371 | 8367 | |
69e6ee2f HK |
8368 | Error_Msg_Name_1 := Prag_Nam; |
8369 | Error_Msg_Qual_Level := Nat'Last; | |
8dce7371 | 8370 | |
69e6ee2f HK |
8371 | Error_Msg_NE |
8372 | ("info: implicit pragma % generated for unit &", N, Unit_Id); | |
8dce7371 | 8373 | |
69e6ee2f HK |
8374 | Error_Msg_Qual_Level := 0; |
8375 | Output_Active_Scenarios (N, In_State); | |
8376 | end if; | |
8377 | end Info_Implicit_Pragma; | |
8dce7371 | 8378 | |
69e6ee2f HK |
8379 | -- Local variables |
8380 | ||
8381 | EA_Id : constant Elaboration_Attributes_Id := | |
8382 | Elaboration_Attributes_Of (Unit_Id); | |
8383 | ||
8384 | Main_Cunit : constant Node_Id := Cunit (Main_Unit); | |
8385 | Loc : constant Source_Ptr := Sloc (Main_Cunit); | |
8386 | Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id); | |
8387 | Unit_Prag : constant Node_Id := Elab_Pragma (EA_Id); | |
8388 | Unit_With : constant Node_Id := With_Clause (EA_Id); | |
8389 | ||
8390 | Clause : Node_Id; | |
8391 | Items : List_Id; | |
8392 | ||
8393 | -- Start of processing for Ensure_Prior_Elaboration_Static | |
8dce7371 PMR |
8394 | |
8395 | begin | |
69e6ee2f HK |
8396 | -- Nothing to do when the caller has suppressed the generation of |
8397 | -- implicit Elaborate[_All] pragmas. | |
8dce7371 | 8398 | |
69e6ee2f HK |
8399 | if In_State.Suppress_Implicit_Pragmas then |
8400 | return; | |
8dce7371 | 8401 | |
69e6ee2f HK |
8402 | -- Nothing to do when the unit is guaranteed prior elaboration by |
8403 | -- means of a source Elaborate[_All] pragma. | |
8dce7371 | 8404 | |
69e6ee2f HK |
8405 | elsif Present (Unit_Prag) then |
8406 | return; | |
8dce7371 | 8407 | |
69e6ee2f HK |
8408 | -- Nothing to do when the unit has an existing implicit Elaborate or |
8409 | -- Elaborate_All pragma installed by a previous scenario. | |
8dce7371 | 8410 | |
69e6ee2f HK |
8411 | elsif Present (Unit_With) then |
8412 | ||
8413 | -- The unit is already guaranteed prior elaboration by means of an | |
8414 | -- implicit Elaborate pragma, however the current scenario imposes | |
8415 | -- a stronger requirement of Elaborate_All. "Upgrade" the existing | |
8416 | -- pragma to match this new requirement. | |
8417 | ||
8418 | if Elaborate_Desirable (Unit_With) | |
8419 | and then Prag_Nam = Name_Elaborate_All | |
8420 | then | |
8421 | Set_Elaborate_All_Desirable (Unit_With); | |
8422 | Set_Elaborate_Desirable (Unit_With, False); | |
8dce7371 PMR |
8423 | end if; |
8424 | ||
69e6ee2f HK |
8425 | return; |
8426 | end if; | |
8dce7371 | 8427 | |
69e6ee2f HK |
8428 | -- At this point it is known that the unit has no prior elaboration |
8429 | -- according to pragmas and hierarchical relationships. | |
8dce7371 | 8430 | |
69e6ee2f | 8431 | Items := Context_Items (Main_Cunit); |
8dce7371 | 8432 | |
69e6ee2f HK |
8433 | if No (Items) then |
8434 | Items := New_List; | |
8435 | Set_Context_Items (Main_Cunit, Items); | |
8dce7371 | 8436 | end if; |
8dce7371 | 8437 | |
69e6ee2f HK |
8438 | -- Locate the with clause for the unit. Note that there may not be a |
8439 | -- clause if the unit is visible through a subunit-body, body-spec, | |
8440 | -- or spec-parent relationship. | |
8dce7371 | 8441 | |
69e6ee2f HK |
8442 | Clause := |
8443 | Find_With_Clause | |
8444 | (Items => Items, | |
8445 | Withed_Id => Unit_Id); | |
8dce7371 | 8446 | |
69e6ee2f HK |
8447 | -- Generate: |
8448 | -- with Id; | |
8dce7371 | 8449 | |
69e6ee2f HK |
8450 | -- Note that adding implicit with clauses is safe because analysis, |
8451 | -- resolution, and expansion have already taken place and it is not | |
8452 | -- possible to interfere with visibility. | |
8dce7371 | 8453 | |
69e6ee2f HK |
8454 | if No (Clause) then |
8455 | Clause := | |
8456 | Make_With_Clause (Loc, | |
8457 | Name => New_Occurrence_Of (Unit_Id, Loc)); | |
8dce7371 | 8458 | |
69e6ee2f HK |
8459 | Set_Implicit_With (Clause); |
8460 | Set_Library_Unit (Clause, Unit_Cunit); | |
8dce7371 | 8461 | |
69e6ee2f HK |
8462 | Append_To (Items, Clause); |
8463 | end if; | |
8dce7371 | 8464 | |
69e6ee2f | 8465 | -- Mark the with clause depending on the pragma required |
8dce7371 | 8466 | |
69e6ee2f HK |
8467 | if Prag_Nam = Name_Elaborate then |
8468 | Set_Elaborate_Desirable (Clause); | |
8469 | else | |
8470 | Set_Elaborate_All_Desirable (Clause); | |
8471 | end if; | |
8dce7371 | 8472 | |
69e6ee2f HK |
8473 | -- The implicit Elaborate[_All] ensures the prior elaboration of |
8474 | -- the unit. Include the unit in the elaboration context of the | |
8475 | -- main unit. | |
8dce7371 | 8476 | |
69e6ee2f | 8477 | Set_With_Clause (EA_Id, Clause); |
8dce7371 | 8478 | |
69e6ee2f HK |
8479 | -- Output extra information on an implicit Elaborate[_All] pragma |
8480 | -- when switch -gnatel (info messages on implicit Elaborate[_All] | |
8481 | -- pragmas is in effect. | |
8dce7371 | 8482 | |
69e6ee2f HK |
8483 | if Elab_Info_Messages then |
8484 | Info_Implicit_Pragma; | |
8dce7371 | 8485 | end if; |
69e6ee2f | 8486 | end Ensure_Prior_Elaboration_Static; |
8dce7371 | 8487 | |
69e6ee2f HK |
8488 | ------------------------------- |
8489 | -- Finalize_Elaborated_Units -- | |
8490 | ------------------------------- | |
8dce7371 | 8491 | |
69e6ee2f HK |
8492 | procedure Finalize_Elaborated_Units is |
8493 | begin | |
8494 | UA_Map.Destroy (Unit_To_Attributes_Map); | |
8495 | end Finalize_Elaborated_Units; | |
90e491a7 | 8496 | |
69e6ee2f HK |
8497 | --------------------------- |
8498 | -- Has_Prior_Elaboration -- | |
8499 | --------------------------- | |
90e491a7 | 8500 | |
69e6ee2f | 8501 | function Has_Prior_Elaboration |
90e491a7 | 8502 | (Unit_Id : Entity_Id; |
69e6ee2f HK |
8503 | Context_OK : Boolean := False; |
8504 | Elab_Body_OK : Boolean := False; | |
8505 | Same_Unit_OK : Boolean := False) return Boolean | |
8506 | is | |
3eb5e54a HK |
8507 | EA_Id : constant Elaboration_Attributes_Id := |
8508 | Elaboration_Attributes_Of (Unit_Id); | |
8509 | Main_Id : constant Entity_Id := Main_Unit_Entity; | |
69e6ee2f HK |
8510 | Unit_Prag : constant Node_Id := Elab_Pragma (EA_Id); |
8511 | Unit_With : constant Node_Id := With_Clause (EA_Id); | |
90e491a7 | 8512 | |
69e6ee2f HK |
8513 | begin |
8514 | -- A preelaborated unit is always elaborated prior to the main unit | |
90e491a7 | 8515 | |
69e6ee2f HK |
8516 | if Is_Preelaborated_Unit (Unit_Id) then |
8517 | return True; | |
90e491a7 | 8518 | |
69e6ee2f HK |
8519 | -- An internal unit is always elaborated prior to a non-internal main |
8520 | -- unit. | |
90e491a7 | 8521 | |
69e6ee2f HK |
8522 | elsif In_Internal_Unit (Unit_Id) |
8523 | and then not In_Internal_Unit (Main_Id) | |
8524 | then | |
8525 | return True; | |
90e491a7 | 8526 | |
69e6ee2f HK |
8527 | -- A unit has prior elaboration if it appears within the context |
8528 | -- of the main unit. Consider this case only when requested by the | |
8529 | -- caller. | |
90e491a7 | 8530 | |
69e6ee2f HK |
8531 | elsif Context_OK |
8532 | and then (Present (Unit_Prag) or else Present (Unit_With)) | |
8533 | then | |
8534 | return True; | |
90e491a7 | 8535 | |
69e6ee2f HK |
8536 | -- A unit whose body is elaborated together with its spec has prior |
8537 | -- elaboration except with respect to itself. Consider this case only | |
8538 | -- when requested by the caller. | |
8539 | ||
8540 | elsif Elab_Body_OK | |
8541 | and then Has_Pragma_Elaborate_Body (Unit_Id) | |
8542 | and then not Is_Same_Unit (Unit_Id, Main_Id) | |
8543 | then | |
8544 | return True; | |
90e491a7 | 8545 | |
69e6ee2f HK |
8546 | -- A unit has no prior elaboration with respect to itself, but does |
8547 | -- not require any means of ensuring its own elaboration either. | |
8548 | -- Treat this case as valid prior elaboration only when requested by | |
8549 | -- the caller. | |
90e491a7 | 8550 | |
69e6ee2f HK |
8551 | elsif Same_Unit_OK and then Is_Same_Unit (Unit_Id, Main_Id) then |
8552 | return True; | |
90e491a7 PMR |
8553 | end if; |
8554 | ||
69e6ee2f HK |
8555 | return False; |
8556 | end Has_Prior_Elaboration; | |
90e491a7 | 8557 | |
69e6ee2f HK |
8558 | --------------------------------- |
8559 | -- Initialize_Elaborated_Units -- | |
8560 | --------------------------------- | |
90e491a7 | 8561 | |
69e6ee2f HK |
8562 | procedure Initialize_Elaborated_Units is |
8563 | begin | |
0839ffce | 8564 | Unit_To_Attributes_Map := UA_Map.Create (250); |
69e6ee2f HK |
8565 | end Initialize_Elaborated_Units; |
8566 | ||
8567 | ---------------------------------- | |
8568 | -- Meet_Elaboration_Requirement -- | |
8569 | ---------------------------------- | |
8570 | ||
8571 | procedure Meet_Elaboration_Requirement | |
8572 | (N : Node_Id; | |
8573 | Targ_Id : Entity_Id; | |
8574 | Req_Nam : Name_Id; | |
8575 | In_State : Processing_In_State) | |
90e491a7 | 8576 | is |
69e6ee2f | 8577 | pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All)); |
90e491a7 | 8578 | |
3eb5e54a | 8579 | Main_Id : constant Entity_Id := Main_Unit_Entity; |
69e6ee2f | 8580 | Unit_Id : constant Entity_Id := Find_Top_Unit (Targ_Id); |
90e491a7 | 8581 | |
69e6ee2f HK |
8582 | procedure Elaboration_Requirement_Error; |
8583 | pragma Inline (Elaboration_Requirement_Error); | |
8584 | -- Emit an error concerning scenario N which has failed to meet the | |
8585 | -- elaboration requirement. | |
90e491a7 | 8586 | |
69e6ee2f HK |
8587 | function Find_Preelaboration_Pragma |
8588 | (Prag_Nam : Name_Id) return Node_Id; | |
8589 | pragma Inline (Find_Preelaboration_Pragma); | |
8590 | -- Traverse the visible declarations of unit Unit_Id and locate a | |
8591 | -- source preelaboration-related pragma with name Prag_Nam. | |
90e491a7 | 8592 | |
69e6ee2f HK |
8593 | procedure Info_Requirement_Met (Prag : Node_Id); |
8594 | pragma Inline (Info_Requirement_Met); | |
8595 | -- Output information concerning pragma Prag which meets requirement | |
8596 | -- Req_Nam. | |
90e491a7 | 8597 | |
69e6ee2f HK |
8598 | ----------------------------------- |
8599 | -- Elaboration_Requirement_Error -- | |
8600 | ----------------------------------- | |
90e491a7 | 8601 | |
69e6ee2f HK |
8602 | procedure Elaboration_Requirement_Error is |
8603 | begin | |
8604 | if Is_Suitable_Call (N) then | |
8605 | Info_Call | |
8606 | (Call => N, | |
8607 | Subp_Id => Targ_Id, | |
8608 | Info_Msg => False, | |
8609 | In_SPARK => True); | |
8610 | ||
8611 | elsif Is_Suitable_Instantiation (N) then | |
8612 | Info_Instantiation | |
8613 | (Inst => N, | |
8614 | Gen_Id => Targ_Id, | |
8615 | Info_Msg => False, | |
8616 | In_SPARK => True); | |
8617 | ||
8618 | elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then | |
8619 | Error_Msg_N | |
8620 | ("read of refinement constituents during elaboration in " | |
8621 | & "SPARK", N); | |
90e491a7 | 8622 | |
69e6ee2f HK |
8623 | elsif Is_Suitable_Variable_Reference (N) then |
8624 | Info_Variable_Reference | |
8625 | (Ref => N, | |
8626 | Var_Id => Targ_Id, | |
8627 | Info_Msg => False, | |
8628 | In_SPARK => True); | |
8dce7371 | 8629 | |
69e6ee2f HK |
8630 | -- No other scenario may impose a requirement on the context of |
8631 | -- the main unit. | |
8dce7371 PMR |
8632 | |
8633 | else | |
69e6ee2f | 8634 | pragma Assert (False); |
8dce7371 PMR |
8635 | return; |
8636 | end if; | |
90e491a7 | 8637 | |
69e6ee2f HK |
8638 | Error_Msg_Name_1 := Req_Nam; |
8639 | Error_Msg_Node_2 := Unit_Id; | |
8640 | Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id); | |
90e491a7 | 8641 | |
69e6ee2f HK |
8642 | Output_Active_Scenarios (N, In_State); |
8643 | end Elaboration_Requirement_Error; | |
90e491a7 | 8644 | |
69e6ee2f HK |
8645 | -------------------------------- |
8646 | -- Find_Preelaboration_Pragma -- | |
8647 | -------------------------------- | |
8648 | ||
8649 | function Find_Preelaboration_Pragma | |
8650 | (Prag_Nam : Name_Id) return Node_Id | |
8651 | is | |
8652 | Spec : constant Node_Id := Parent (Unit_Id); | |
8653 | Decl : Node_Id; | |
8654 | ||
8655 | begin | |
8656 | -- A preelaboration-related pragma comes from source and appears | |
8657 | -- at the top of the visible declarations of a package. | |
8658 | ||
8659 | if Nkind (Spec) = N_Package_Specification then | |
8660 | Decl := First (Visible_Declarations (Spec)); | |
8661 | while Present (Decl) loop | |
8662 | if Comes_From_Source (Decl) then | |
8663 | if Nkind (Decl) = N_Pragma | |
8664 | and then Pragma_Name (Decl) = Prag_Nam | |
8665 | then | |
8666 | return Decl; | |
8667 | ||
8668 | -- Otherwise the construct terminates the region where | |
8669 | -- the preelaboration-related pragma may appear. | |
8670 | ||
8671 | else | |
8672 | exit; | |
8673 | end if; | |
8674 | end if; | |
90e491a7 | 8675 | |
69e6ee2f HK |
8676 | Next (Decl); |
8677 | end loop; | |
8678 | end if; | |
90e491a7 | 8679 | |
69e6ee2f HK |
8680 | return Empty; |
8681 | end Find_Preelaboration_Pragma; | |
90e491a7 | 8682 | |
69e6ee2f HK |
8683 | -------------------------- |
8684 | -- Info_Requirement_Met -- | |
8685 | -------------------------- | |
90e491a7 | 8686 | |
69e6ee2f HK |
8687 | procedure Info_Requirement_Met (Prag : Node_Id) is |
8688 | pragma Assert (Present (Prag)); | |
90e491a7 | 8689 | |
69e6ee2f HK |
8690 | begin |
8691 | Error_Msg_Name_1 := Req_Nam; | |
8692 | Error_Msg_Sloc := Sloc (Prag); | |
8693 | Error_Msg_NE | |
8694 | ("\\% requirement for unit & met by pragma #", N, Unit_Id); | |
8695 | end Info_Requirement_Met; | |
90e491a7 | 8696 | |
69e6ee2f | 8697 | -- Local variables |
90e491a7 | 8698 | |
69e6ee2f HK |
8699 | EA_Id : Elaboration_Attributes_Id; |
8700 | Elab_Nam : Name_Id; | |
8701 | Req_Met : Boolean; | |
8702 | Unit_Prag : Node_Id; | |
90e491a7 | 8703 | |
69e6ee2f | 8704 | -- Start of processing for Meet_Elaboration_Requirement |
90e491a7 PMR |
8705 | |
8706 | begin | |
69e6ee2f | 8707 | -- Assume that the requirement has not been met |
90e491a7 | 8708 | |
69e6ee2f | 8709 | Req_Met := False; |
90e491a7 | 8710 | |
69e6ee2f HK |
8711 | -- If the target is within the main unit, either at the source level |
8712 | -- or through an instantiation, then there is no real requirement to | |
8713 | -- meet because the main unit cannot force its own elaboration by | |
8714 | -- means of an Elaborate[_All] pragma. Treat this case as valid | |
8715 | -- coverage. | |
90e491a7 | 8716 | |
69e6ee2f HK |
8717 | if In_Extended_Main_Code_Unit (Targ_Id) then |
8718 | Req_Met := True; | |
90e491a7 | 8719 | |
69e6ee2f | 8720 | -- Otherwise the target resides in an external unit |
90e491a7 | 8721 | |
69e6ee2f HK |
8722 | -- The requirement is met when the target comes from an internal unit |
8723 | -- because such a unit is elaborated prior to a non-internal unit. | |
90e491a7 | 8724 | |
69e6ee2f HK |
8725 | elsif In_Internal_Unit (Unit_Id) |
8726 | and then not In_Internal_Unit (Main_Id) | |
8727 | then | |
8728 | Req_Met := True; | |
90e491a7 | 8729 | |
69e6ee2f HK |
8730 | -- The requirement is met when the target comes from a preelaborated |
8731 | -- unit. This portion must parallel predicate Is_Preelaborated_Unit. | |
90e491a7 | 8732 | |
69e6ee2f HK |
8733 | elsif Is_Preelaborated_Unit (Unit_Id) then |
8734 | Req_Met := True; | |
90e491a7 | 8735 | |
69e6ee2f HK |
8736 | -- Output extra information when switch -gnatel (info messages on |
8737 | -- implicit Elaborate[_All] pragmas. | |
90e491a7 | 8738 | |
69e6ee2f HK |
8739 | if Elab_Info_Messages |
8740 | and then not In_State.Suppress_Info_Messages | |
8741 | then | |
8742 | if Is_Preelaborated (Unit_Id) then | |
8743 | Elab_Nam := Name_Preelaborate; | |
90e491a7 | 8744 | |
69e6ee2f HK |
8745 | elsif Is_Pure (Unit_Id) then |
8746 | Elab_Nam := Name_Pure; | |
90e491a7 | 8747 | |
69e6ee2f HK |
8748 | elsif Is_Remote_Call_Interface (Unit_Id) then |
8749 | Elab_Nam := Name_Remote_Call_Interface; | |
90e491a7 | 8750 | |
69e6ee2f HK |
8751 | elsif Is_Remote_Types (Unit_Id) then |
8752 | Elab_Nam := Name_Remote_Types; | |
90e491a7 | 8753 | |
69e6ee2f HK |
8754 | else |
8755 | pragma Assert (Is_Shared_Passive (Unit_Id)); | |
8756 | Elab_Nam := Name_Shared_Passive; | |
8757 | end if; | |
90e491a7 | 8758 | |
69e6ee2f HK |
8759 | Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam)); |
8760 | end if; | |
90e491a7 | 8761 | |
69e6ee2f HK |
8762 | -- Determine whether the context of the main unit has a pragma strong |
8763 | -- enough to meet the requirement. | |
90e491a7 PMR |
8764 | |
8765 | else | |
69e6ee2f HK |
8766 | EA_Id := Elaboration_Attributes_Of (Unit_Id); |
8767 | Unit_Prag := Elab_Pragma (EA_Id); | |
8768 | ||
8769 | -- The pragma must be either Elaborate_All or be as strong as the | |
8770 | -- requirement. | |
90e491a7 | 8771 | |
69e6ee2f HK |
8772 | if Present (Unit_Prag) |
8773 | and then Nam_In (Pragma_Name (Unit_Prag), Name_Elaborate_All, | |
8774 | Req_Nam) | |
8775 | then | |
8776 | Req_Met := True; | |
90e491a7 | 8777 | |
69e6ee2f HK |
8778 | -- Output extra information when switch -gnatel (info messages |
8779 | -- on implicit Elaborate[_All] pragmas. | |
90e491a7 | 8780 | |
69e6ee2f HK |
8781 | if Elab_Info_Messages |
8782 | and then not In_State.Suppress_Info_Messages | |
8783 | then | |
8784 | Info_Requirement_Met (Unit_Prag); | |
8785 | end if; | |
8786 | end if; | |
8787 | end if; | |
90e491a7 | 8788 | |
69e6ee2f HK |
8789 | -- The requirement was not met by the context of the main unit, issue |
8790 | -- an error. | |
90e491a7 | 8791 | |
69e6ee2f HK |
8792 | if not Req_Met then |
8793 | Elaboration_Requirement_Error; | |
90e491a7 | 8794 | end if; |
69e6ee2f HK |
8795 | end Meet_Elaboration_Requirement; |
8796 | ||
8797 | ------------- | |
8798 | -- Present -- | |
8799 | ------------- | |
90e491a7 | 8800 | |
69e6ee2f HK |
8801 | function Present (EA_Id : Elaboration_Attributes_Id) return Boolean is |
8802 | begin | |
8803 | return EA_Id /= No_Elaboration_Attributes; | |
8804 | end Present; | |
90e491a7 | 8805 | |
69e6ee2f HK |
8806 | --------------------- |
8807 | -- Set_Elab_Pragma -- | |
8808 | --------------------- | |
90e491a7 | 8809 | |
69e6ee2f HK |
8810 | procedure Set_Elab_Pragma |
8811 | (EA_Id : Elaboration_Attributes_Id; | |
8812 | Prag : Node_Id) | |
8813 | is | |
8814 | pragma Assert (Present (EA_Id)); | |
8815 | begin | |
8816 | Elaboration_Attributes.Table (EA_Id).Elab_Pragma := Prag; | |
8817 | end Set_Elab_Pragma; | |
90e491a7 | 8818 | |
69e6ee2f HK |
8819 | --------------------- |
8820 | -- Set_With_Clause -- | |
8821 | --------------------- | |
90e491a7 | 8822 | |
69e6ee2f HK |
8823 | procedure Set_With_Clause |
8824 | (EA_Id : Elaboration_Attributes_Id; | |
8825 | Clause : Node_Id) | |
8826 | is | |
8827 | pragma Assert (Present (EA_Id)); | |
8828 | begin | |
8829 | Elaboration_Attributes.Table (EA_Id).With_Clause := Clause; | |
8830 | end Set_With_Clause; | |
90e491a7 | 8831 | |
69e6ee2f HK |
8832 | ----------------- |
8833 | -- With_Clause -- | |
8834 | ----------------- | |
8835 | ||
8836 | function With_Clause | |
8837 | (EA_Id : Elaboration_Attributes_Id) return Node_Id | |
8838 | is | |
8839 | pragma Assert (Present (EA_Id)); | |
8840 | begin | |
8841 | return Elaboration_Attributes.Table (EA_Id).With_Clause; | |
8842 | end With_Clause; | |
8843 | end Elaborated_Units; | |
90e491a7 | 8844 | |
0839ffce HK |
8845 | ------------------------------ |
8846 | -- Elaboration_Phase_Active -- | |
8847 | ------------------------------ | |
8848 | ||
8849 | function Elaboration_Phase_Active return Boolean is | |
8850 | begin | |
8851 | return Elaboration_Phase = Active; | |
8852 | end Elaboration_Phase_Active; | |
8853 | ||
8854 | ---------------------------------- | |
8855 | -- Finalize_All_Data_Structures -- | |
8856 | ---------------------------------- | |
8857 | ||
8858 | procedure Finalize_All_Data_Structures is | |
8859 | begin | |
8860 | Finalize_Body_Processor; | |
8861 | Finalize_Early_Call_Region_Processor; | |
8862 | Finalize_Elaborated_Units; | |
8863 | Finalize_Internal_Representation; | |
8864 | Finalize_Invocation_Graph; | |
8865 | Finalize_Scenario_Storage; | |
8866 | end Finalize_All_Data_Structures; | |
8867 | ||
90e491a7 PMR |
8868 | ----------------------------- |
8869 | -- Find_Enclosing_Instance -- | |
8870 | ----------------------------- | |
8871 | ||
8872 | function Find_Enclosing_Instance (N : Node_Id) return Node_Id is | |
69e6ee2f | 8873 | Par : Node_Id; |
90e491a7 PMR |
8874 | |
8875 | begin | |
8876 | -- Climb the parent chain looking for an enclosing instance spec or body | |
8877 | ||
8878 | Par := N; | |
8879 | while Present (Par) loop | |
69e6ee2f HK |
8880 | if Nkind_In (Par, N_Package_Body, |
8881 | N_Package_Declaration, | |
8882 | N_Subprogram_Body, | |
90e491a7 | 8883 | N_Subprogram_Declaration) |
69e6ee2f | 8884 | and then Is_Generic_Instance (Unique_Defining_Entity (Par)) |
90e491a7 PMR |
8885 | then |
8886 | return Par; | |
90e491a7 PMR |
8887 | end if; |
8888 | ||
8889 | Par := Parent (Par); | |
8890 | end loop; | |
8891 | ||
8892 | return Empty; | |
8893 | end Find_Enclosing_Instance; | |
8894 | ||
8895 | -------------------------- | |
8896 | -- Find_Enclosing_Level -- | |
8897 | -------------------------- | |
8898 | ||
8899 | function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind is | |
8900 | function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind; | |
69e6ee2f | 8901 | pragma Inline (Level_Of); |
90e491a7 PMR |
8902 | -- Obtain the corresponding level of unit Unit |
8903 | ||
8904 | -------------- | |
8905 | -- Level_Of -- | |
8906 | -------------- | |
8907 | ||
8908 | function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind is | |
8909 | Spec_Id : Entity_Id; | |
8910 | ||
8911 | begin | |
8912 | if Nkind (Unit) in N_Generic_Instantiation then | |
69e6ee2f | 8913 | return Instantiation_Level; |
90e491a7 PMR |
8914 | |
8915 | elsif Nkind (Unit) = N_Generic_Package_Declaration then | |
69e6ee2f | 8916 | return Generic_Spec_Level; |
90e491a7 PMR |
8917 | |
8918 | elsif Nkind (Unit) = N_Package_Declaration then | |
69e6ee2f | 8919 | return Library_Spec_Level; |
90e491a7 PMR |
8920 | |
8921 | elsif Nkind (Unit) = N_Package_Body then | |
8922 | Spec_Id := Corresponding_Spec (Unit); | |
8923 | ||
8924 | -- The body belongs to a generic package | |
8925 | ||
8926 | if Present (Spec_Id) | |
8927 | and then Ekind (Spec_Id) = E_Generic_Package | |
8928 | then | |
69e6ee2f | 8929 | return Generic_Body_Level; |
90e491a7 PMR |
8930 | |
8931 | -- Otherwise the body belongs to a non-generic package. This also | |
8932 | -- treats an illegal package body without a corresponding spec as | |
8933 | -- a non-generic package body. | |
8934 | ||
8935 | else | |
69e6ee2f | 8936 | return Library_Body_Level; |
90e491a7 PMR |
8937 | end if; |
8938 | end if; | |
8939 | ||
8940 | return No_Level; | |
8941 | end Level_Of; | |
8942 | ||
8943 | -- Local variables | |
8944 | ||
8945 | Context : Node_Id; | |
8946 | Curr : Node_Id; | |
8947 | Prev : Node_Id; | |
8948 | ||
8949 | -- Start of processing for Find_Enclosing_Level | |
8950 | ||
8951 | begin | |
8952 | -- Call markers and instantiations which appear at the declaration level | |
8953 | -- but are later relocated in a different context retain their original | |
8954 | -- declaration level. | |
8955 | ||
8956 | if Nkind_In (N, N_Call_Marker, | |
8957 | N_Function_Instantiation, | |
8958 | N_Package_Instantiation, | |
8959 | N_Procedure_Instantiation) | |
8960 | and then Is_Declaration_Level_Node (N) | |
8961 | then | |
8962 | return Declaration_Level; | |
8963 | end if; | |
8964 | ||
8965 | -- Climb the parent chain looking at the enclosing levels | |
8966 | ||
8967 | Prev := N; | |
8968 | Curr := Parent (Prev); | |
8969 | while Present (Curr) loop | |
8970 | ||
8971 | -- A traversal from a subunit continues via the corresponding stub | |
8972 | ||
8973 | if Nkind (Curr) = N_Subunit then | |
8974 | Curr := Corresponding_Stub (Curr); | |
8975 | ||
8976 | -- The current construct is a package. Packages are ignored because | |
8977 | -- they are always elaborated when the enclosing context is invoked | |
8978 | -- or elaborated. | |
8979 | ||
8980 | elsif Nkind_In (Curr, N_Package_Body, N_Package_Declaration) then | |
8981 | null; | |
8982 | ||
8983 | -- The current construct is a block statement | |
8984 | ||
8985 | elsif Nkind (Curr) = N_Block_Statement then | |
8986 | ||
8987 | -- Ignore internally generated blocks created by the expander for | |
8988 | -- various purposes such as abort defer/undefer. | |
8989 | ||
8990 | if not Comes_From_Source (Curr) then | |
8991 | null; | |
8992 | ||
8993 | -- If the traversal came from the handled sequence of statments, | |
8994 | -- then the node appears at the level of the enclosing construct. | |
8995 | -- This is a more reliable test because transients scopes within | |
8996 | -- the declarative region of the encapsulator are hard to detect. | |
8997 | ||
8998 | elsif Nkind (Prev) = N_Handled_Sequence_Of_Statements | |
8999 | and then Handled_Statement_Sequence (Curr) = Prev | |
9000 | then | |
9001 | return Find_Enclosing_Level (Parent (Curr)); | |
9002 | ||
9003 | -- Otherwise the traversal came from the declarations, the node is | |
9004 | -- at the declaration level. | |
9005 | ||
9006 | else | |
9007 | return Declaration_Level; | |
9008 | end if; | |
9009 | ||
c23f55b4 | 9010 | -- The current construct is a declaration-level encapsulator |
90e491a7 PMR |
9011 | |
9012 | elsif Nkind_In (Curr, N_Entry_Body, | |
9013 | N_Subprogram_Body, | |
9014 | N_Task_Body) | |
9015 | then | |
9016 | -- If the traversal came from the handled sequence of statments, | |
9017 | -- then the node cannot possibly appear at any level. This is | |
9018 | -- a more reliable test because transients scopes within the | |
9019 | -- declarative region of the encapsulator are hard to detect. | |
9020 | ||
9021 | if Nkind (Prev) = N_Handled_Sequence_Of_Statements | |
9022 | and then Handled_Statement_Sequence (Curr) = Prev | |
9023 | then | |
9024 | return No_Level; | |
9025 | ||
9026 | -- Otherwise the traversal came from the declarations, the node is | |
9027 | -- at the declaration level. | |
9028 | ||
9029 | else | |
9030 | return Declaration_Level; | |
9031 | end if; | |
9032 | ||
c23f55b4 | 9033 | -- The current construct is a non-library-level encapsulator which |
69e6ee2f HK |
9034 | -- indicates that the node cannot possibly appear at any level. Note |
9035 | -- that the check must come after the declaration-level check because | |
9036 | -- both predicates share certain nodes. | |
90e491a7 PMR |
9037 | |
9038 | elsif Is_Non_Library_Level_Encapsulator (Curr) then | |
9039 | Context := Parent (Curr); | |
9040 | ||
9041 | -- The sole exception is when the encapsulator is the compilation | |
9042 | -- utit itself because the compilation unit node requires special | |
9043 | -- processing (see below). | |
9044 | ||
9045 | if Present (Context) | |
9046 | and then Nkind (Context) = N_Compilation_Unit | |
9047 | then | |
9048 | null; | |
9049 | ||
9050 | -- Otherwise the node is not at any level | |
9051 | ||
9052 | else | |
9053 | return No_Level; | |
9054 | end if; | |
9055 | ||
9056 | -- The current construct is a compilation unit. The node appears at | |
9057 | -- the [generic] library level when the unit is a [generic] package. | |
9058 | ||
9059 | elsif Nkind (Curr) = N_Compilation_Unit then | |
9060 | return Level_Of (Unit (Curr)); | |
9061 | end if; | |
9062 | ||
9063 | Prev := Curr; | |
9064 | Curr := Parent (Prev); | |
9065 | end loop; | |
9066 | ||
9067 | return No_Level; | |
9068 | end Find_Enclosing_Level; | |
9069 | ||
9070 | ------------------- | |
9071 | -- Find_Top_Unit -- | |
9072 | ------------------- | |
9073 | ||
9074 | function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id is | |
90e491a7 | 9075 | begin |
fb9dd1c7 | 9076 | return Find_Unit_Entity (Unit (Cunit (Get_Top_Level_Code_Unit (N)))); |
90e491a7 PMR |
9077 | end Find_Top_Unit; |
9078 | ||
fb9dd1c7 PMR |
9079 | ---------------------- |
9080 | -- Find_Unit_Entity -- | |
9081 | ---------------------- | |
9082 | ||
9083 | function Find_Unit_Entity (N : Node_Id) return Entity_Id is | |
9084 | Context : constant Node_Id := Parent (N); | |
9085 | Orig_N : constant Node_Id := Original_Node (N); | |
9086 | ||
9087 | begin | |
9088 | -- The unit denotes a package body of an instantiation which acts as | |
9089 | -- a compilation unit. The proper entity is that of the package spec. | |
9090 | ||
9091 | if Nkind (N) = N_Package_Body | |
9092 | and then Nkind (Orig_N) = N_Package_Instantiation | |
9093 | and then Nkind (Context) = N_Compilation_Unit | |
9094 | then | |
9095 | return Corresponding_Spec (N); | |
9096 | ||
9097 | -- The unit denotes an anonymous package created to wrap a subprogram | |
9098 | -- instantiation which acts as a compilation unit. The proper entity is | |
9099 | -- that of the "related instance". | |
9100 | ||
9101 | elsif Nkind (N) = N_Package_Declaration | |
9102 | and then Nkind_In (Orig_N, N_Function_Instantiation, | |
9103 | N_Procedure_Instantiation) | |
9104 | and then Nkind (Context) = N_Compilation_Unit | |
9105 | then | |
9aa357c7 EB |
9106 | return Related_Instance (Defining_Entity (N)); |
9107 | ||
9108 | -- The unit denotes a concurrent body acting as a subunit. Such bodies | |
9109 | -- are generally rewritten into null statements. The proper entity is | |
9110 | -- that of the "original node". | |
9111 | ||
9112 | elsif Nkind (N) = N_Subunit | |
9113 | and then Nkind (Proper_Body (N)) = N_Null_Statement | |
9114 | and then Nkind_In (Original_Node (Proper_Body (N)), N_Protected_Body, | |
9115 | N_Task_Body) | |
9116 | then | |
9117 | return Defining_Entity (Original_Node (Proper_Body (N))); | |
fb9dd1c7 PMR |
9118 | |
9119 | -- Otherwise the proper entity is the defining entity | |
9120 | ||
9121 | else | |
9aa357c7 | 9122 | return Defining_Entity (N); |
fb9dd1c7 PMR |
9123 | end if; |
9124 | end Find_Unit_Entity; | |
9125 | ||
90e491a7 PMR |
9126 | ----------------------- |
9127 | -- First_Formal_Type -- | |
9128 | ----------------------- | |
9129 | ||
9130 | function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id is | |
9131 | Formal_Id : constant Entity_Id := First_Formal (Subp_Id); | |
9132 | Typ : Entity_Id; | |
9133 | ||
9134 | begin | |
9135 | if Present (Formal_Id) then | |
9136 | Typ := Etype (Formal_Id); | |
9137 | ||
9138 | -- Handle various combinations of concurrent and private types | |
9139 | ||
9140 | loop | |
9141 | if Ekind_In (Typ, E_Protected_Type, E_Task_Type) | |
9142 | and then Present (Anonymous_Object (Typ)) | |
9143 | then | |
9144 | Typ := Anonymous_Object (Typ); | |
9145 | ||
9146 | elsif Is_Concurrent_Record_Type (Typ) then | |
9147 | Typ := Corresponding_Concurrent_Type (Typ); | |
9148 | ||
9149 | elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) then | |
9150 | Typ := Full_View (Typ); | |
9151 | ||
9152 | else | |
9153 | exit; | |
9154 | end if; | |
69e6ee2f HK |
9155 | end loop; |
9156 | ||
9157 | return Typ; | |
9158 | end if; | |
9159 | ||
9160 | return Empty; | |
9161 | end First_Formal_Type; | |
9162 | ||
9163 | ------------------------------ | |
9164 | -- Guaranteed_ABE_Processor -- | |
9165 | ------------------------------ | |
9166 | ||
9167 | package body Guaranteed_ABE_Processor is | |
9168 | function Is_Guaranteed_ABE | |
9169 | (N : Node_Id; | |
9170 | Target_Decl : Node_Id; | |
9171 | Target_Body : Node_Id) return Boolean; | |
9172 | pragma Inline (Is_Guaranteed_ABE); | |
9173 | -- Determine whether scenario N with a target described by its initial | |
9174 | -- declaration Target_Decl and body Target_Decl results in a guaranteed | |
9175 | -- ABE. | |
9176 | ||
9177 | procedure Process_Guaranteed_ABE_Activation | |
9178 | (Call : Node_Id; | |
9179 | Call_Rep : Scenario_Rep_Id; | |
9180 | Obj_Id : Entity_Id; | |
9181 | Obj_Rep : Target_Rep_Id; | |
9182 | Task_Typ : Entity_Id; | |
9183 | Task_Rep : Target_Rep_Id; | |
9184 | In_State : Processing_In_State); | |
9185 | pragma Inline (Process_Guaranteed_ABE_Activation); | |
9186 | -- Perform common guaranteed ABE checks and diagnostics for activation | |
9187 | -- call Call which activates object Obj_Id of task type Task_Typ. Formal | |
9188 | -- Call_Rep denotes the representation of the call. Obj_Rep denotes the | |
9189 | -- representation of the object. Task_Rep denotes the representation of | |
9190 | -- the task type. In_State is the current state of the Processing phase. | |
9191 | ||
9192 | procedure Process_Guaranteed_ABE_Call | |
9193 | (Call : Node_Id; | |
9194 | Call_Rep : Scenario_Rep_Id; | |
9195 | In_State : Processing_In_State); | |
9196 | pragma Inline (Process_Guaranteed_ABE_Call); | |
9197 | -- Perform common guaranteed ABE checks and diagnostics for call Call | |
9198 | -- with representation Call_Rep. In_State denotes the current state of | |
9199 | -- the Processing phase. | |
9200 | ||
9201 | procedure Process_Guaranteed_ABE_Instantiation | |
9202 | (Inst : Node_Id; | |
9203 | Inst_Rep : Scenario_Rep_Id; | |
9204 | In_State : Processing_In_State); | |
9205 | pragma Inline (Process_Guaranteed_ABE_Instantiation); | |
9206 | -- Perform common guaranteed ABE checks and diagnostics for instance | |
9207 | -- Inst with representation Inst_Rep. In_State is the current state of | |
9208 | -- the Processing phase. | |
9209 | ||
9210 | ----------------------- | |
9211 | -- Is_Guaranteed_ABE -- | |
9212 | ----------------------- | |
9213 | ||
9214 | function Is_Guaranteed_ABE | |
9215 | (N : Node_Id; | |
9216 | Target_Decl : Node_Id; | |
9217 | Target_Body : Node_Id) return Boolean | |
9218 | is | |
9219 | begin | |
9220 | -- Avoid cascaded errors if there were previous serious infractions. | |
9221 | -- As a result the scenario will not be treated as a guaranteed ABE. | |
9222 | -- This behaviour parallels that of the old ABE mechanism. | |
9223 | ||
9224 | if Serious_Errors_Detected > 0 then | |
9225 | return False; | |
9226 | ||
9227 | -- The scenario and the target appear in the same context ignoring | |
9228 | -- enclosing library levels. | |
9229 | ||
9230 | elsif In_Same_Context (N, Target_Decl) then | |
9231 | ||
9232 | -- The target body has already been encountered. The scenario | |
9233 | -- results in a guaranteed ABE if it appears prior to the body. | |
9234 | ||
9235 | if Present (Target_Body) then | |
9236 | return Earlier_In_Extended_Unit (N, Target_Body); | |
9237 | ||
9238 | -- Otherwise the body has not been encountered yet. The scenario | |
9239 | -- is a guaranteed ABE since the body will appear later. It is | |
9240 | -- assumed that the caller has already ensured that the scenario | |
9241 | -- is ABE-safe because optional bodies are not considered here. | |
9242 | ||
9243 | else | |
9244 | return True; | |
9245 | end if; | |
9246 | end if; | |
9247 | ||
9248 | return False; | |
9249 | end Is_Guaranteed_ABE; | |
9250 | ||
9251 | ---------------------------- | |
9252 | -- Process_Guaranteed_ABE -- | |
9253 | ---------------------------- | |
9254 | ||
9255 | procedure Process_Guaranteed_ABE | |
9256 | (N : Node_Id; | |
9257 | In_State : Processing_In_State) | |
9258 | is | |
9259 | Scen : constant Node_Id := Scenario (N); | |
9260 | Scen_Rep : Scenario_Rep_Id; | |
9261 | ||
9262 | begin | |
9263 | -- Add the current scenario to the stack of active scenarios | |
9264 | ||
9265 | Push_Active_Scenario (Scen); | |
9266 | ||
9267 | -- Only calls, instantiations, and task activations may result in a | |
9268 | -- guaranteed ABE. | |
9269 | ||
9270 | -- Call or task activation | |
9271 | ||
9272 | if Is_Suitable_Call (Scen) then | |
9273 | Scen_Rep := Scenario_Representation_Of (Scen, In_State); | |
9274 | ||
9275 | if Kind (Scen_Rep) = Call_Scenario then | |
9276 | Process_Guaranteed_ABE_Call | |
9277 | (Call => Scen, | |
9278 | Call_Rep => Scen_Rep, | |
9279 | In_State => In_State); | |
9280 | ||
9281 | else | |
9282 | pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); | |
9283 | ||
9284 | Process_Activation | |
9285 | (Call => Scen, | |
9286 | Call_Rep => Scenario_Representation_Of (Scen, In_State), | |
9287 | Processor => Process_Guaranteed_ABE_Activation'Access, | |
9288 | In_State => In_State); | |
9289 | end if; | |
9290 | ||
9291 | -- Instantiation | |
9292 | ||
9293 | elsif Is_Suitable_Instantiation (Scen) then | |
9294 | Process_Guaranteed_ABE_Instantiation | |
9295 | (Inst => Scen, | |
9296 | Inst_Rep => Scenario_Representation_Of (Scen, In_State), | |
9297 | In_State => In_State); | |
9298 | end if; | |
9299 | ||
9300 | -- Remove the current scenario from the stack of active scenarios | |
9301 | -- once all ABE diagnostics and checks have been performed. | |
9302 | ||
9303 | Pop_Active_Scenario (Scen); | |
9304 | end Process_Guaranteed_ABE; | |
9305 | ||
9306 | --------------------------------------- | |
9307 | -- Process_Guaranteed_ABE_Activation -- | |
9308 | --------------------------------------- | |
9309 | ||
9310 | procedure Process_Guaranteed_ABE_Activation | |
9311 | (Call : Node_Id; | |
9312 | Call_Rep : Scenario_Rep_Id; | |
9313 | Obj_Id : Entity_Id; | |
9314 | Obj_Rep : Target_Rep_Id; | |
9315 | Task_Typ : Entity_Id; | |
9316 | Task_Rep : Target_Rep_Id; | |
9317 | In_State : Processing_In_State) | |
9318 | is | |
9319 | Spec_Decl : constant Node_Id := Spec_Declaration (Task_Rep); | |
9320 | ||
9321 | Check_OK : constant Boolean := | |
9322 | not In_State.Suppress_Checks | |
9323 | and then Ghost_Mode_Of (Obj_Rep) /= Is_Ignored | |
9324 | and then Ghost_Mode_Of (Task_Rep) /= Is_Ignored | |
9325 | and then Elaboration_Checks_OK (Obj_Rep) | |
9326 | and then Elaboration_Checks_OK (Task_Rep); | |
9327 | -- A run-time ABE check may be installed only when the object and the | |
9328 | -- task type have active elaboration checks, and both are not ignored | |
9329 | -- Ghost constructs. | |
9330 | ||
9331 | begin | |
9332 | -- Nothing to do when the root scenario appears at the declaration | |
9333 | -- level and the task is in the same unit, but outside this context. | |
9334 | -- | |
9335 | -- task type Task_Typ; -- task declaration | |
9336 | -- | |
9337 | -- procedure Proc is | |
9338 | -- function A ... is | |
9339 | -- begin | |
9340 | -- if Some_Condition then | |
9341 | -- declare | |
9342 | -- T : Task_Typ; | |
9343 | -- begin | |
9344 | -- <activation call> -- activation site | |
9345 | -- end; | |
9346 | -- ... | |
9347 | -- end A; | |
9348 | -- | |
9349 | -- X : ... := A; -- root scenario | |
9350 | -- ... | |
9351 | -- | |
9352 | -- task body Task_Typ is | |
9353 | -- ... | |
9354 | -- end Task_Typ; | |
9355 | -- | |
9356 | -- In the example above, the context of X is the declarative list | |
9357 | -- of Proc. The "elaboration" of X may reach the activation of T | |
9358 | -- whose body is defined outside of X's context. The task body is | |
9359 | -- relevant only when Proc is invoked, but this happens only in | |
9360 | -- "normal" elaboration, therefore the task body must not be | |
9361 | -- considered if this is not the case. | |
9362 | ||
9363 | if Is_Up_Level_Target | |
9364 | (Targ_Decl => Spec_Decl, | |
9365 | In_State => In_State) | |
9366 | then | |
9367 | return; | |
9368 | ||
9369 | -- Nothing to do when the activation is ABE-safe | |
9370 | -- | |
9371 | -- generic | |
9372 | -- package Gen is | |
9373 | -- task type Task_Typ; | |
9374 | -- end Gen; | |
9375 | -- | |
9376 | -- package body Gen is | |
9377 | -- task body Task_Typ is | |
9378 | -- begin | |
9379 | -- ... | |
9380 | -- end Task_Typ; | |
9381 | -- end Gen; | |
9382 | -- | |
9383 | -- with Gen; | |
9384 | -- procedure Main is | |
9385 | -- package Nested is | |
9386 | -- package Inst is new Gen; | |
9387 | -- T : Inst.Task_Typ; | |
9388 | -- end Nested; -- safe activation | |
9389 | -- ... | |
9390 | ||
9391 | elsif Is_Safe_Activation (Call, Task_Rep) then | |
9392 | return; | |
9393 | ||
9394 | -- An activation call leads to a guaranteed ABE when the activation | |
9395 | -- call and the task appear within the same context ignoring library | |
9396 | -- levels, and the body of the task has not been seen yet or appears | |
9397 | -- after the activation call. | |
9398 | -- | |
9399 | -- procedure Guaranteed_ABE is | |
9400 | -- task type Task_Typ; | |
9401 | -- | |
9402 | -- package Nested is | |
9403 | -- T : Task_Typ; | |
9404 | -- <activation call> -- guaranteed ABE | |
9405 | -- end Nested; | |
9406 | -- | |
9407 | -- task body Task_Typ is | |
9408 | -- ... | |
9409 | -- end Task_Typ; | |
9410 | -- ... | |
9411 | ||
9412 | elsif Is_Guaranteed_ABE | |
9413 | (N => Call, | |
9414 | Target_Decl => Spec_Decl, | |
9415 | Target_Body => Body_Declaration (Task_Rep)) | |
9416 | then | |
9417 | if Elaboration_Warnings_OK (Call_Rep) then | |
9418 | Error_Msg_Sloc := Sloc (Call); | |
9419 | Error_Msg_N | |
9420 | ("??task & will be activated # before elaboration of its " | |
9421 | & "body", Obj_Id); | |
9422 | Error_Msg_N | |
9423 | ("\Program_Error will be raised at run time", Obj_Id); | |
9424 | end if; | |
9425 | ||
9426 | -- Mark the activation call as a guaranteed ABE | |
9427 | ||
9428 | Set_Is_Known_Guaranteed_ABE (Call); | |
9429 | ||
9430 | -- Install a run-time ABE failue because this activation call will | |
9431 | -- always result in an ABE. | |
9432 | ||
9433 | if Check_OK then | |
9434 | Install_Scenario_ABE_Failure | |
9435 | (N => Call, | |
9436 | Targ_Id => Task_Typ, | |
9437 | Targ_Rep => Task_Rep, | |
9438 | Disable => Obj_Rep); | |
9439 | end if; | |
9440 | end if; | |
9441 | end Process_Guaranteed_ABE_Activation; | |
9442 | ||
9443 | --------------------------------- | |
9444 | -- Process_Guaranteed_ABE_Call -- | |
9445 | --------------------------------- | |
9446 | ||
9447 | procedure Process_Guaranteed_ABE_Call | |
9448 | (Call : Node_Id; | |
9449 | Call_Rep : Scenario_Rep_Id; | |
9450 | In_State : Processing_In_State) | |
9451 | is | |
9452 | Subp_Id : constant Entity_Id := Target (Call_Rep); | |
9453 | Subp_Rep : constant Target_Rep_Id := | |
9454 | Target_Representation_Of (Subp_Id, In_State); | |
9455 | Spec_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); | |
9456 | ||
9457 | Check_OK : constant Boolean := | |
9458 | not In_State.Suppress_Checks | |
9459 | and then Ghost_Mode_Of (Call_Rep) /= Is_Ignored | |
9460 | and then Ghost_Mode_Of (Subp_Rep) /= Is_Ignored | |
9461 | and then Elaboration_Checks_OK (Call_Rep) | |
9462 | and then Elaboration_Checks_OK (Subp_Rep); | |
9463 | -- A run-time ABE check may be installed only when both the call | |
9464 | -- and the target have active elaboration checks, and both are not | |
9465 | -- ignored Ghost constructs. | |
9466 | ||
9467 | begin | |
9468 | -- Nothing to do when the root scenario appears at the declaration | |
9469 | -- level and the target is in the same unit but outside this context. | |
9470 | -- | |
9471 | -- function B ...; -- target declaration | |
9472 | -- | |
9473 | -- procedure Proc is | |
9474 | -- function A ... is | |
9475 | -- begin | |
9476 | -- if Some_Condition then | |
9477 | -- return B; -- call site | |
9478 | -- ... | |
9479 | -- end A; | |
9480 | -- | |
9481 | -- X : ... := A; -- root scenario | |
9482 | -- ... | |
9483 | -- | |
9484 | -- function B ... is | |
9485 | -- ... | |
9486 | -- end B; | |
9487 | -- | |
9488 | -- In the example above, the context of X is the declarative region | |
9489 | -- of Proc. The "elaboration" of X may eventually reach B which is | |
9490 | -- defined outside of X's context. B is relevant only when Proc is | |
9491 | -- invoked, but this happens only by means of "normal" elaboration, | |
9492 | -- therefore B must not be considered if this is not the case. | |
9493 | ||
9494 | if Is_Up_Level_Target | |
9495 | (Targ_Decl => Spec_Decl, | |
9496 | In_State => In_State) | |
9497 | then | |
9498 | return; | |
9499 | ||
9500 | -- Nothing to do when the call is ABE-safe | |
9501 | -- | |
9502 | -- generic | |
9503 | -- function Gen ...; | |
9504 | -- | |
9505 | -- function Gen ... is | |
9506 | -- begin | |
9507 | -- ... | |
9508 | -- end Gen; | |
9509 | -- | |
9510 | -- with Gen; | |
9511 | -- procedure Main is | |
9512 | -- function Inst is new Gen; | |
9513 | -- X : ... := Inst; -- safe call | |
9514 | -- ... | |
9515 | ||
9516 | elsif Is_Safe_Call (Call, Subp_Id, Subp_Rep) then | |
9517 | return; | |
9518 | ||
9519 | -- A call leads to a guaranteed ABE when the call and the target | |
9520 | -- appear within the same context ignoring library levels, and the | |
9521 | -- body of the target has not been seen yet or appears after the | |
9522 | -- call. | |
9523 | -- | |
9524 | -- procedure Guaranteed_ABE is | |
9525 | -- function Func ...; | |
9526 | -- | |
9527 | -- package Nested is | |
9528 | -- Obj : ... := Func; -- guaranteed ABE | |
9529 | -- end Nested; | |
9530 | -- | |
9531 | -- function Func ... is | |
9532 | -- ... | |
9533 | -- end Func; | |
9534 | -- ... | |
9535 | ||
9536 | elsif Is_Guaranteed_ABE | |
9537 | (N => Call, | |
9538 | Target_Decl => Spec_Decl, | |
9539 | Target_Body => Body_Declaration (Subp_Rep)) | |
9540 | then | |
9541 | if Elaboration_Warnings_OK (Call_Rep) then | |
9542 | Error_Msg_NE | |
9543 | ("??cannot call & before body seen", Call, Subp_Id); | |
9544 | Error_Msg_N ("\Program_Error will be raised at run time", Call); | |
9545 | end if; | |
9546 | ||
9547 | -- Mark the call as a guarnateed ABE | |
9548 | ||
9549 | Set_Is_Known_Guaranteed_ABE (Call); | |
9550 | ||
9551 | -- Install a run-time ABE failure because the call will always | |
9552 | -- result in an ABE. | |
9553 | ||
9554 | if Check_OK then | |
9555 | Install_Scenario_ABE_Failure | |
9556 | (N => Call, | |
9557 | Targ_Id => Subp_Id, | |
9558 | Targ_Rep => Subp_Rep, | |
9559 | Disable => Call_Rep); | |
9560 | end if; | |
9561 | end if; | |
9562 | end Process_Guaranteed_ABE_Call; | |
9563 | ||
9564 | ------------------------------------------ | |
9565 | -- Process_Guaranteed_ABE_Instantiation -- | |
9566 | ------------------------------------------ | |
9567 | ||
9568 | procedure Process_Guaranteed_ABE_Instantiation | |
9569 | (Inst : Node_Id; | |
9570 | Inst_Rep : Scenario_Rep_Id; | |
9571 | In_State : Processing_In_State) | |
9572 | is | |
9573 | Gen_Id : constant Entity_Id := Target (Inst_Rep); | |
9574 | Gen_Rep : constant Target_Rep_Id := | |
9575 | Target_Representation_Of (Gen_Id, In_State); | |
9576 | Spec_Decl : constant Node_Id := Spec_Declaration (Gen_Rep); | |
9577 | ||
9578 | Check_OK : constant Boolean := | |
9579 | not In_State.Suppress_Checks | |
9580 | and then Ghost_Mode_Of (Inst_Rep) /= Is_Ignored | |
9581 | and then Ghost_Mode_Of (Gen_Rep) /= Is_Ignored | |
9582 | and then Elaboration_Checks_OK (Inst_Rep) | |
9583 | and then Elaboration_Checks_OK (Gen_Rep); | |
9584 | -- A run-time ABE check may be installed only when both the instance | |
9585 | -- and the generic have active elaboration checks and both are not | |
9586 | -- ignored Ghost constructs. | |
9587 | ||
9588 | begin | |
9589 | -- Nothing to do when the root scenario appears at the declaration | |
9590 | -- level and the generic is in the same unit, but outside this | |
9591 | -- context. | |
9592 | -- | |
9593 | -- generic | |
9594 | -- procedure Gen is ...; -- generic declaration | |
9595 | -- | |
9596 | -- procedure Proc is | |
9597 | -- function A ... is | |
9598 | -- begin | |
9599 | -- if Some_Condition then | |
9600 | -- declare | |
9601 | -- procedure I is new Gen; -- instantiation site | |
9602 | -- ... | |
9603 | -- ... | |
9604 | -- end A; | |
9605 | -- | |
9606 | -- X : ... := A; -- root scenario | |
9607 | -- ... | |
9608 | -- | |
9609 | -- procedure Gen is | |
9610 | -- ... | |
9611 | -- end Gen; | |
9612 | -- | |
9613 | -- In the example above, the context of X is the declarative region | |
9614 | -- of Proc. The "elaboration" of X may eventually reach Gen which | |
9615 | -- appears outside of X's context. Gen is relevant only when Proc is | |
9616 | -- invoked, but this happens only by means of "normal" elaboration, | |
9617 | -- therefore Gen must not be considered if this is not the case. | |
9618 | ||
9619 | if Is_Up_Level_Target | |
9620 | (Targ_Decl => Spec_Decl, | |
9621 | In_State => In_State) | |
9622 | then | |
9623 | return; | |
9624 | ||
9625 | -- Nothing to do when the instantiation is ABE-safe | |
9626 | -- | |
9627 | -- generic | |
9628 | -- package Gen is | |
9629 | -- ... | |
9630 | -- end Gen; | |
9631 | -- | |
9632 | -- package body Gen is | |
9633 | -- ... | |
9634 | -- end Gen; | |
9635 | -- | |
9636 | -- with Gen; | |
9637 | -- procedure Main is | |
9638 | -- package Inst is new Gen (ABE); -- safe instantiation | |
9639 | -- ... | |
9640 | ||
9641 | elsif Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then | |
9642 | return; | |
9643 | ||
9644 | -- An instantiation leads to a guaranteed ABE when the instantiation | |
9645 | -- and the generic appear within the same context ignoring library | |
9646 | -- levels, and the body of the generic has not been seen yet or | |
9647 | -- appears after the instantiation. | |
9648 | -- | |
9649 | -- procedure Guaranteed_ABE is | |
9650 | -- generic | |
9651 | -- procedure Gen; | |
9652 | -- | |
9653 | -- package Nested is | |
9654 | -- procedure Inst is new Gen; -- guaranteed ABE | |
9655 | -- end Nested; | |
9656 | -- | |
9657 | -- procedure Gen is | |
9658 | -- ... | |
9659 | -- end Gen; | |
9660 | -- ... | |
9661 | ||
9662 | elsif Is_Guaranteed_ABE | |
9663 | (N => Inst, | |
9664 | Target_Decl => Spec_Decl, | |
9665 | Target_Body => Body_Declaration (Gen_Rep)) | |
9666 | then | |
9667 | if Elaboration_Warnings_OK (Inst_Rep) then | |
9668 | Error_Msg_NE | |
9669 | ("??cannot instantiate & before body seen", Inst, Gen_Id); | |
9670 | Error_Msg_N ("\Program_Error will be raised at run time", Inst); | |
9671 | end if; | |
90e491a7 | 9672 | |
69e6ee2f HK |
9673 | -- Mark the instantiation as a guarantee ABE. This automatically |
9674 | -- suppresses the instantiation of the generic body. | |
90e491a7 | 9675 | |
69e6ee2f HK |
9676 | Set_Is_Known_Guaranteed_ABE (Inst); |
9677 | ||
9678 | -- Install a run-time ABE failure because the instantiation will | |
9679 | -- always result in an ABE. | |
9680 | ||
9681 | if Check_OK then | |
9682 | Install_Scenario_ABE_Failure | |
9683 | (N => Inst, | |
9684 | Targ_Id => Gen_Id, | |
9685 | Targ_Rep => Gen_Rep, | |
9686 | Disable => Inst_Rep); | |
9687 | end if; | |
9688 | end if; | |
9689 | end Process_Guaranteed_ABE_Instantiation; | |
9690 | end Guaranteed_ABE_Processor; | |
90e491a7 PMR |
9691 | |
9692 | -------------- | |
9693 | -- Has_Body -- | |
9694 | -------------- | |
9695 | ||
9696 | function Has_Body (Pack_Decl : Node_Id) return Boolean is | |
9697 | function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id; | |
69e6ee2f | 9698 | pragma Inline (Find_Corresponding_Body); |
90e491a7 PMR |
9699 | -- Try to locate the corresponding body of spec Spec_Id. If no body is |
9700 | -- found, return Empty. | |
9701 | ||
9702 | function Find_Body | |
9703 | (Spec_Id : Entity_Id; | |
9704 | From : Node_Id) return Node_Id; | |
69e6ee2f | 9705 | pragma Inline (Find_Body); |
90e491a7 PMR |
9706 | -- Try to locate the corresponding body of spec Spec_Id in the node list |
9707 | -- which follows arbitrary node From. If no body is found, return Empty. | |
9708 | ||
9709 | function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id; | |
69e6ee2f | 9710 | pragma Inline (Load_Package_Body); |
90e491a7 PMR |
9711 | -- Attempt to load the body of unit Unit_Nam. If the load failed, return |
9712 | -- Empty. If the compilation will not generate code, return Empty. | |
9713 | ||
9714 | ----------------------------- | |
9715 | -- Find_Corresponding_Body -- | |
9716 | ----------------------------- | |
9717 | ||
9718 | function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id is | |
9719 | Context : constant Entity_Id := Scope (Spec_Id); | |
9720 | Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); | |
9721 | Body_Decl : Node_Id; | |
9722 | Body_Id : Entity_Id; | |
9723 | ||
9724 | begin | |
9725 | if Is_Compilation_Unit (Spec_Id) then | |
9726 | Body_Id := Corresponding_Body (Spec_Decl); | |
9727 | ||
9728 | if Present (Body_Id) then | |
9729 | return Unit_Declaration_Node (Body_Id); | |
9730 | ||
9731 | -- The package is at the library and requires a body. Load the | |
9732 | -- corresponding body because the optional body may be declared | |
9733 | -- there. | |
9734 | ||
9735 | elsif Unit_Requires_Body (Spec_Id) then | |
9736 | return | |
9737 | Load_Package_Body | |
9738 | (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec_Decl)))); | |
9739 | ||
9740 | -- Otherwise there is no optional body | |
9741 | ||
9742 | else | |
9743 | return Empty; | |
9744 | end if; | |
9745 | ||
9746 | -- The immediate context is a package. The optional body may be | |
9747 | -- within the body of that package. | |
9748 | ||
9749 | -- procedure Proc is | |
9750 | -- package Nested_1 is | |
9751 | -- package Nested_2 is | |
9752 | -- generic | |
9753 | -- package Pack is | |
9754 | -- end Pack; | |
9755 | -- end Nested_2; | |
9756 | -- end Nested_1; | |
9757 | ||
9758 | -- package body Nested_1 is | |
9759 | -- package body Nested_2 is separate; | |
9760 | -- end Nested_1; | |
9761 | ||
9762 | -- separate (Proc.Nested_1.Nested_2) | |
9763 | -- package body Nested_2 is | |
9764 | -- package body Pack is -- optional body | |
9765 | -- ... | |
9766 | -- end Pack; | |
9767 | -- end Nested_2; | |
9768 | ||
9769 | elsif Is_Package_Or_Generic_Package (Context) then | |
9770 | Body_Decl := Find_Corresponding_Body (Context); | |
9771 | ||
9772 | -- The optional body is within the body of the enclosing package | |
9773 | ||
9774 | if Present (Body_Decl) then | |
9775 | return | |
9776 | Find_Body | |
9777 | (Spec_Id => Spec_Id, | |
9778 | From => First (Declarations (Body_Decl))); | |
9779 | ||
9780 | -- Otherwise the enclosing package does not have a body. This may | |
9781 | -- be the result of an error or a genuine lack of a body. | |
9782 | ||
9783 | else | |
9784 | return Empty; | |
9785 | end if; | |
9786 | ||
9787 | -- Otherwise the immediate context is a body. The optional body may | |
9788 | -- be within the same list as the spec. | |
9789 | ||
9790 | -- procedure Proc is | |
9791 | -- generic | |
9792 | -- package Pack is | |
9793 | -- end Pack; | |
9794 | ||
9795 | -- package body Pack is -- optional body | |
9796 | -- ... | |
9797 | -- end Pack; | |
9798 | ||
9799 | else | |
9800 | return | |
9801 | Find_Body | |
9802 | (Spec_Id => Spec_Id, | |
9803 | From => Next (Spec_Decl)); | |
9804 | end if; | |
9805 | end Find_Corresponding_Body; | |
9806 | ||
9807 | --------------- | |
9808 | -- Find_Body -- | |
9809 | --------------- | |
9810 | ||
9811 | function Find_Body | |
9812 | (Spec_Id : Entity_Id; | |
9813 | From : Node_Id) return Node_Id | |
9814 | is | |
9815 | Spec_Nam : constant Name_Id := Chars (Spec_Id); | |
9816 | Item : Node_Id; | |
9817 | Lib_Unit : Node_Id; | |
9818 | ||
9819 | begin | |
9820 | Item := From; | |
9821 | while Present (Item) loop | |
9822 | ||
9823 | -- The current item denotes the optional body | |
9824 | ||
9825 | if Nkind (Item) = N_Package_Body | |
9826 | and then Chars (Defining_Entity (Item)) = Spec_Nam | |
9827 | then | |
9828 | return Item; | |
9829 | ||
9830 | -- The current item denotes a stub, the optional body may be in | |
9831 | -- the subunit. | |
9832 | ||
9833 | elsif Nkind (Item) = N_Package_Body_Stub | |
9834 | and then Chars (Defining_Entity (Item)) = Spec_Nam | |
9835 | then | |
9836 | Lib_Unit := Library_Unit (Item); | |
9837 | ||
9838 | -- The corresponding subunit was previously loaded | |
9839 | ||
9840 | if Present (Lib_Unit) then | |
9841 | return Lib_Unit; | |
9842 | ||
9843 | -- Otherwise attempt to load the corresponding subunit | |
9844 | ||
9845 | else | |
9846 | return Load_Package_Body (Get_Unit_Name (Item)); | |
9847 | end if; | |
9848 | end if; | |
9849 | ||
9850 | Next (Item); | |
9851 | end loop; | |
9852 | ||
9853 | return Empty; | |
9854 | end Find_Body; | |
9855 | ||
9856 | ----------------------- | |
9857 | -- Load_Package_Body -- | |
9858 | ----------------------- | |
9859 | ||
9860 | function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id is | |
9861 | Body_Decl : Node_Id; | |
9862 | Unit_Num : Unit_Number_Type; | |
9863 | ||
9864 | begin | |
9865 | -- The load is performed only when the compilation will generate code | |
9866 | ||
9867 | if Operating_Mode = Generate_Code then | |
9868 | Unit_Num := | |
9869 | Load_Unit | |
9870 | (Load_Name => Unit_Nam, | |
9871 | Required => False, | |
9872 | Subunit => False, | |
9873 | Error_Node => Pack_Decl); | |
9874 | ||
9875 | -- The load failed most likely because the physical file is | |
9876 | -- missing. | |
9877 | ||
9878 | if Unit_Num = No_Unit then | |
9879 | return Empty; | |
9880 | ||
9881 | -- Otherwise the load was successful, return the body of the unit | |
9882 | ||
9883 | else | |
9884 | Body_Decl := Unit (Cunit (Unit_Num)); | |
9885 | ||
9886 | -- If the unit is a subunit with an available proper body, | |
9887 | -- return the proper body. | |
9888 | ||
9889 | if Nkind (Body_Decl) = N_Subunit | |
9890 | and then Present (Proper_Body (Body_Decl)) | |
9891 | then | |
9892 | Body_Decl := Proper_Body (Body_Decl); | |
9893 | end if; | |
9894 | ||
9895 | return Body_Decl; | |
9896 | end if; | |
9897 | end if; | |
9898 | ||
9899 | return Empty; | |
9900 | end Load_Package_Body; | |
9901 | ||
9902 | -- Local variables | |
9903 | ||
9904 | Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl); | |
9905 | ||
9906 | -- Start of processing for Has_Body | |
9907 | ||
9908 | begin | |
9909 | -- The body is available | |
9910 | ||
9911 | if Present (Corresponding_Body (Pack_Decl)) then | |
9912 | return True; | |
9913 | ||
9914 | -- The body is required if the package spec contains a construct which | |
9915 | -- requires a completion in a body. | |
9916 | ||
9917 | elsif Unit_Requires_Body (Pack_Id) then | |
9918 | return True; | |
9919 | ||
9920 | -- The body may be optional | |
9921 | ||
9922 | else | |
9923 | return Present (Find_Corresponding_Body (Pack_Id)); | |
9924 | end if; | |
9925 | end Has_Body; | |
9926 | ||
69e6ee2f HK |
9927 | ---------- |
9928 | -- Hash -- | |
9929 | ---------- | |
90e491a7 | 9930 | |
69e6ee2f HK |
9931 | function Hash (NE : Node_Or_Entity_Id) return Bucket_Range_Type is |
9932 | pragma Assert (Present (NE)); | |
90e491a7 | 9933 | begin |
69e6ee2f HK |
9934 | return Bucket_Range_Type (NE); |
9935 | end Hash; | |
90e491a7 PMR |
9936 | |
9937 | -------------------------- | |
9938 | -- In_External_Instance -- | |
9939 | -------------------------- | |
9940 | ||
9941 | function In_External_Instance | |
9942 | (N : Node_Id; | |
9943 | Target_Decl : Node_Id) return Boolean | |
9944 | is | |
69e6ee2f | 9945 | Inst : Node_Id; |
90e491a7 | 9946 | Inst_Body : Node_Id; |
69e6ee2f | 9947 | Inst_Spec : Node_Id; |
90e491a7 PMR |
9948 | |
9949 | begin | |
69e6ee2f | 9950 | Inst := Find_Enclosing_Instance (Target_Decl); |
90e491a7 PMR |
9951 | |
9952 | -- The target declaration appears within an instance spec. Visibility is | |
9953 | -- ignored because internally generated primitives for private types may | |
9954 | -- reside in the private declarations and still be invoked from outside. | |
9955 | ||
69e6ee2f HK |
9956 | if Present (Inst) and then Nkind (Inst) = N_Package_Declaration then |
9957 | ||
90e491a7 PMR |
9958 | -- The scenario comes from the main unit and the instance does not |
9959 | ||
9960 | if In_Extended_Main_Code_Unit (N) | |
69e6ee2f | 9961 | and then not In_Extended_Main_Code_Unit (Inst) |
90e491a7 PMR |
9962 | then |
9963 | return True; | |
9964 | ||
9965 | -- Otherwise the scenario must not appear within the instance spec or | |
9966 | -- body. | |
9967 | ||
9968 | else | |
69e6ee2f HK |
9969 | Spec_And_Body_From_Node |
9970 | (N => Inst, | |
9971 | Spec_Decl => Inst_Spec, | |
9972 | Body_Decl => Inst_Body); | |
90e491a7 PMR |
9973 | |
9974 | return not In_Subtree | |
9975 | (N => N, | |
69e6ee2f | 9976 | Root1 => Inst_Spec, |
90e491a7 PMR |
9977 | Root2 => Inst_Body); |
9978 | end if; | |
9979 | end if; | |
9980 | ||
9981 | return False; | |
9982 | end In_External_Instance; | |
9983 | ||
9984 | --------------------- | |
9985 | -- In_Main_Context -- | |
9986 | --------------------- | |
9987 | ||
9988 | function In_Main_Context (N : Node_Id) return Boolean is | |
9989 | begin | |
9990 | -- Scenarios outside the main unit are not considered because the ALI | |
9991 | -- information supplied to binde is for the main unit only. | |
9992 | ||
9993 | if not In_Extended_Main_Code_Unit (N) then | |
9994 | return False; | |
9995 | ||
9996 | -- Scenarios within internal units are not considered unless switch | |
9997 | -- -gnatdE (elaboration checks on predefined units) is in effect. | |
9998 | ||
9999 | elsif not Debug_Flag_EE and then In_Internal_Unit (N) then | |
10000 | return False; | |
10001 | end if; | |
10002 | ||
10003 | return True; | |
10004 | end In_Main_Context; | |
10005 | ||
10006 | --------------------- | |
10007 | -- In_Same_Context -- | |
10008 | --------------------- | |
10009 | ||
10010 | function In_Same_Context | |
10011 | (N1 : Node_Id; | |
10012 | N2 : Node_Id; | |
10013 | Nested_OK : Boolean := False) return Boolean | |
10014 | is | |
10015 | function Find_Enclosing_Context (N : Node_Id) return Node_Id; | |
69e6ee2f | 10016 | pragma Inline (Find_Enclosing_Context); |
c23f55b4 | 10017 | -- Return the nearest enclosing non-library-level or compilation unit |
604801a4 PT |
10018 | -- node which encapsulates arbitrary node N. Return Empty is no such |
10019 | -- context is available. | |
90e491a7 PMR |
10020 | |
10021 | function In_Nested_Context | |
10022 | (Outer : Node_Id; | |
10023 | Inner : Node_Id) return Boolean; | |
69e6ee2f | 10024 | pragma Inline (In_Nested_Context); |
90e491a7 PMR |
10025 | -- Determine whether arbitrary node Outer encapsulates arbitrary node |
10026 | -- Inner. | |
10027 | ||
10028 | ---------------------------- | |
10029 | -- Find_Enclosing_Context -- | |
10030 | ---------------------------- | |
10031 | ||
10032 | function Find_Enclosing_Context (N : Node_Id) return Node_Id is | |
10033 | Context : Node_Id; | |
10034 | Par : Node_Id; | |
10035 | ||
10036 | begin | |
10037 | Par := Parent (N); | |
10038 | while Present (Par) loop | |
10039 | ||
10040 | -- A traversal from a subunit continues via the corresponding stub | |
10041 | ||
10042 | if Nkind (Par) = N_Subunit then | |
10043 | Par := Corresponding_Stub (Par); | |
10044 | ||
8dce7371 | 10045 | -- Stop the traversal when the nearest enclosing non-library-level |
90e491a7 PMR |
10046 | -- encapsulator has been reached. |
10047 | ||
10048 | elsif Is_Non_Library_Level_Encapsulator (Par) then | |
10049 | Context := Parent (Par); | |
10050 | ||
10051 | -- The sole exception is when the encapsulator is the unit of | |
10052 | -- compilation because this case requires special processing | |
10053 | -- (see below). | |
10054 | ||
10055 | if Present (Context) | |
10056 | and then Nkind (Context) = N_Compilation_Unit | |
10057 | then | |
10058 | null; | |
10059 | ||
10060 | else | |
10061 | return Par; | |
10062 | end if; | |
10063 | ||
c23f55b4 | 10064 | -- Reaching a compilation unit node without hitting a non-library- |
90e491a7 PMR |
10065 | -- level encapsulator indicates that N is at the library level in |
10066 | -- which case the compilation unit is the context. | |
10067 | ||
10068 | elsif Nkind (Par) = N_Compilation_Unit then | |
10069 | return Par; | |
10070 | end if; | |
10071 | ||
10072 | Par := Parent (Par); | |
10073 | end loop; | |
10074 | ||
10075 | return Empty; | |
10076 | end Find_Enclosing_Context; | |
10077 | ||
10078 | ----------------------- | |
10079 | -- In_Nested_Context -- | |
10080 | ----------------------- | |
10081 | ||
10082 | function In_Nested_Context | |
10083 | (Outer : Node_Id; | |
10084 | Inner : Node_Id) return Boolean | |
10085 | is | |
10086 | Par : Node_Id; | |
10087 | ||
10088 | begin | |
10089 | Par := Inner; | |
10090 | while Present (Par) loop | |
10091 | ||
10092 | -- A traversal from a subunit continues via the corresponding stub | |
10093 | ||
10094 | if Nkind (Par) = N_Subunit then | |
10095 | Par := Corresponding_Stub (Par); | |
10096 | ||
10097 | elsif Par = Outer then | |
10098 | return True; | |
10099 | end if; | |
10100 | ||
10101 | Par := Parent (Par); | |
10102 | end loop; | |
10103 | ||
10104 | return False; | |
10105 | end In_Nested_Context; | |
10106 | ||
10107 | -- Local variables | |
10108 | ||
10109 | Context_1 : constant Node_Id := Find_Enclosing_Context (N1); | |
10110 | Context_2 : constant Node_Id := Find_Enclosing_Context (N2); | |
10111 | ||
10112 | -- Start of processing for In_Same_Context | |
10113 | ||
10114 | begin | |
10115 | -- Both nodes appear within the same context | |
10116 | ||
10117 | if Context_1 = Context_2 then | |
10118 | return True; | |
10119 | ||
10120 | -- Both nodes appear in compilation units. Determine whether one unit | |
10121 | -- is the body of the other. | |
10122 | ||
10123 | elsif Nkind (Context_1) = N_Compilation_Unit | |
10124 | and then Nkind (Context_2) = N_Compilation_Unit | |
10125 | then | |
10126 | return | |
10127 | Is_Same_Unit | |
10128 | (Unit_1 => Defining_Entity (Unit (Context_1)), | |
10129 | Unit_2 => Defining_Entity (Unit (Context_2))); | |
10130 | ||
10131 | -- The context of N1 encloses the context of N2 | |
10132 | ||
10133 | elsif Nested_OK and then In_Nested_Context (Context_1, Context_2) then | |
10134 | return True; | |
10135 | end if; | |
10136 | ||
10137 | return False; | |
10138 | end In_Same_Context; | |
10139 | ||
69e6ee2f HK |
10140 | ---------------- |
10141 | -- Initialize -- | |
10142 | ---------------- | |
0c9849e1 | 10143 | |
69e6ee2f HK |
10144 | procedure Initialize is |
10145 | begin | |
10146 | -- Set the soft link which enables Atree.Rewrite to update a scenario | |
10147 | -- each time it is transformed into another node. | |
0c9849e1 | 10148 | |
69e6ee2f | 10149 | Set_Rewriting_Proc (Update_Elaboration_Scenario'Access); |
0839ffce HK |
10150 | |
10151 | -- Create all internal data structures and activate the elaboration | |
10152 | -- phase of the compiler. | |
10153 | ||
10154 | Initialize_All_Data_Structures; | |
10155 | Set_Elaboration_Phase (Active); | |
69e6ee2f HK |
10156 | end Initialize; |
10157 | ||
0839ffce HK |
10158 | ------------------------------------ |
10159 | -- Initialize_All_Data_Structures -- | |
10160 | ------------------------------------ | |
10161 | ||
10162 | procedure Initialize_All_Data_Structures is | |
10163 | begin | |
10164 | Initialize_Body_Processor; | |
10165 | Initialize_Early_Call_Region_Processor; | |
10166 | Initialize_Elaborated_Units; | |
10167 | Initialize_Internal_Representation; | |
10168 | Initialize_Invocation_Graph; | |
10169 | Initialize_Scenario_Storage; | |
10170 | end Initialize_All_Data_Structures; | |
10171 | ||
69e6ee2f HK |
10172 | -------------------------- |
10173 | -- Instantiated_Generic -- | |
10174 | -------------------------- | |
10175 | ||
10176 | function Instantiated_Generic (Inst : Node_Id) return Entity_Id is | |
0c9849e1 | 10177 | begin |
69e6ee2f HK |
10178 | -- Traverse a possible chain of renamings to obtain the original generic |
10179 | -- being instantiatied. | |
0c9849e1 | 10180 | |
69e6ee2f HK |
10181 | return Get_Renamed_Entity (Entity (Name (Inst))); |
10182 | end Instantiated_Generic; | |
0c9849e1 | 10183 | |
69e6ee2f HK |
10184 | ----------------------------- |
10185 | -- Internal_Representation -- | |
10186 | ----------------------------- | |
0c9849e1 | 10187 | |
69e6ee2f | 10188 | package body Internal_Representation is |
0c9849e1 | 10189 | |
69e6ee2f HK |
10190 | ----------- |
10191 | -- Types -- | |
10192 | ----------- | |
0c9849e1 | 10193 | |
69e6ee2f | 10194 | -- The following type represents the contents of a scenario |
0c9849e1 | 10195 | |
69e6ee2f HK |
10196 | type Scenario_Rep_Record is record |
10197 | Elab_Checks_OK : Boolean := False; | |
10198 | -- The status of elaboration checks for the scenario | |
0c9849e1 | 10199 | |
69e6ee2f HK |
10200 | Elab_Warnings_OK : Boolean := False; |
10201 | -- The status of elaboration warnings for the scenario | |
90e491a7 | 10202 | |
69e6ee2f HK |
10203 | GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified; |
10204 | -- The Ghost mode of the scenario | |
90e491a7 | 10205 | |
69e6ee2f HK |
10206 | Kind : Scenario_Kind := No_Scenario; |
10207 | -- The nature of the scenario | |
90e491a7 | 10208 | |
69e6ee2f HK |
10209 | Level : Enclosing_Level_Kind := No_Level; |
10210 | -- The enclosing level where the scenario resides | |
90e491a7 | 10211 | |
69e6ee2f HK |
10212 | SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified; |
10213 | -- The SPARK mode of the scenario | |
90e491a7 | 10214 | |
69e6ee2f HK |
10215 | Target : Entity_Id := Empty; |
10216 | -- The target of the scenario | |
10217 | ||
10218 | -- The following attributes are multiplexed and depend on the Kind of | |
10219 | -- the scenario. They are mapped as follows: | |
10220 | -- | |
10221 | -- Call_Scenario | |
10222 | -- Is_Dispatching_Call (Flag_1) | |
10223 | -- | |
10224 | -- Task_Activation_Scenario | |
10225 | -- Activated_Task_Objects (List_1) | |
10226 | -- Activated_Task_Type (Field_1) | |
10227 | -- | |
10228 | -- Variable_Reference | |
10229 | -- Is_Read_Reference (Flag_1) | |
10230 | ||
10231 | Flag_1 : Boolean := False; | |
10232 | Field_1 : Node_Or_Entity_Id := Empty; | |
10233 | List_1 : NE_List.Doubly_Linked_List := NE_List.Nil; | |
10234 | end record; | |
10235 | ||
10236 | -- The following type represents the contents of a target | |
10237 | ||
10238 | type Target_Rep_Record is record | |
10239 | Body_Decl : Node_Id := Empty; | |
10240 | -- The declaration of the target body | |
10241 | ||
10242 | Elab_Checks_OK : Boolean := False; | |
10243 | -- The status of elaboration checks for the target | |
10244 | ||
10245 | Elab_Warnings_OK : Boolean := False; | |
10246 | -- The status of elaboration warnings for the target | |
10247 | ||
10248 | GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified; | |
10249 | -- The Ghost mode of the target | |
10250 | ||
10251 | Kind : Target_Kind := No_Target; | |
10252 | -- The nature of the target | |
10253 | ||
10254 | SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified; | |
10255 | -- The SPARK mode of the target | |
10256 | ||
10257 | Spec_Decl : Node_Id := Empty; | |
10258 | -- The declaration of the target spec | |
10259 | ||
10260 | Unit : Entity_Id := Empty; | |
10261 | -- The top unit where the target is declared | |
10262 | ||
10263 | Version : Representation_Kind := No_Representation; | |
10264 | -- The version of the target representation | |
10265 | ||
10266 | -- The following attributes are multiplexed and depend on the Kind of | |
10267 | -- the target. They are mapped as follows: | |
10268 | -- | |
10269 | -- Subprogram_Target | |
10270 | -- Barrier_Body_Declaration (Field_1) | |
10271 | -- | |
10272 | -- Variable_Target | |
10273 | -- Variable_Declaration (Field_1) | |
10274 | ||
10275 | Field_1 : Node_Or_Entity_Id := Empty; | |
10276 | end record; | |
10277 | ||
10278 | --------------------- | |
10279 | -- Data structures -- | |
10280 | --------------------- | |
10281 | ||
10282 | procedure Destroy (T_Id : in out Target_Rep_Id); | |
10283 | -- Destroy a target representation T_Id | |
10284 | ||
10285 | package ETT_Map is new Dynamic_Hash_Tables | |
10286 | (Key_Type => Entity_Id, | |
10287 | Value_Type => Target_Rep_Id, | |
10288 | No_Value => No_Target_Rep, | |
10289 | Expansion_Threshold => 1.5, | |
10290 | Expansion_Factor => 2, | |
10291 | Compression_Threshold => 0.3, | |
10292 | Compression_Factor => 2, | |
10293 | "=" => "=", | |
10294 | Destroy_Value => Destroy, | |
10295 | Hash => Hash); | |
10296 | ||
10297 | -- The following map relates target representations to entities | |
10298 | ||
0839ffce | 10299 | Entity_To_Target_Map : ETT_Map.Dynamic_Hash_Table := ETT_Map.Nil; |
69e6ee2f HK |
10300 | |
10301 | procedure Destroy (S_Id : in out Scenario_Rep_Id); | |
10302 | -- Destroy a scenario representation S_Id | |
10303 | ||
10304 | package NTS_Map is new Dynamic_Hash_Tables | |
10305 | (Key_Type => Node_Id, | |
10306 | Value_Type => Scenario_Rep_Id, | |
10307 | No_Value => No_Scenario_Rep, | |
10308 | Expansion_Threshold => 1.5, | |
10309 | Expansion_Factor => 2, | |
10310 | Compression_Threshold => 0.3, | |
10311 | Compression_Factor => 2, | |
10312 | "=" => "=", | |
10313 | Destroy_Value => Destroy, | |
10314 | Hash => Hash); | |
10315 | ||
10316 | -- The following map relates scenario representations to nodes | |
10317 | ||
0839ffce | 10318 | Node_To_Scenario_Map : NTS_Map.Dynamic_Hash_Table := NTS_Map.Nil; |
69e6ee2f HK |
10319 | |
10320 | -- The following table stores all scenario representations | |
10321 | ||
10322 | package Scenario_Reps is new Table.Table | |
10323 | (Table_Index_Type => Scenario_Rep_Id, | |
10324 | Table_Component_Type => Scenario_Rep_Record, | |
10325 | Table_Low_Bound => First_Scenario_Rep, | |
10326 | Table_Initial => 1000, | |
10327 | Table_Increment => 200, | |
10328 | Table_Name => "Scenario_Reps"); | |
10329 | ||
10330 | -- The following table stores all target representations | |
10331 | ||
10332 | package Target_Reps is new Table.Table | |
10333 | (Table_Index_Type => Target_Rep_Id, | |
10334 | Table_Component_Type => Target_Rep_Record, | |
10335 | Table_Low_Bound => First_Target_Rep, | |
10336 | Table_Initial => 1000, | |
10337 | Table_Increment => 200, | |
10338 | Table_Name => "Target_Reps"); | |
10339 | ||
10340 | -------------- | |
10341 | -- Builders -- | |
10342 | -------------- | |
10343 | ||
10344 | function Create_Access_Taken_Rep | |
10345 | (Attr : Node_Id) return Scenario_Rep_Record; | |
10346 | pragma Inline (Create_Access_Taken_Rep); | |
10347 | -- Create the representation of 'Access attribute Attr | |
10348 | ||
10349 | function Create_Call_Or_Task_Activation_Rep | |
10350 | (Call : Node_Id) return Scenario_Rep_Record; | |
10351 | pragma Inline (Create_Call_Or_Task_Activation_Rep); | |
10352 | -- Create the representation of call or task activation Call | |
10353 | ||
10354 | function Create_Derived_Type_Rep | |
10355 | (Typ_Decl : Node_Id) return Scenario_Rep_Record; | |
10356 | pragma Inline (Create_Derived_Type_Rep); | |
10357 | -- Create the representation of a derived type described by declaration | |
10358 | -- Typ_Decl. | |
10359 | ||
10360 | function Create_Generic_Rep | |
10361 | (Gen_Id : Entity_Id) return Target_Rep_Record; | |
10362 | pragma Inline (Create_Generic_Rep); | |
10363 | -- Create the representation of generic Gen_Id | |
10364 | ||
10365 | function Create_Instantiation_Rep | |
10366 | (Inst : Node_Id) return Scenario_Rep_Record; | |
10367 | pragma Inline (Create_Instantiation_Rep); | |
10368 | -- Create the representation of instantiation Inst | |
10369 | ||
3eb5e54a HK |
10370 | function Create_Package_Rep |
10371 | (Pack_Id : Entity_Id) return Target_Rep_Record; | |
10372 | pragma Inline (Create_Package_Rep); | |
10373 | -- Create the representation of package Pack_Id | |
10374 | ||
69e6ee2f HK |
10375 | function Create_Protected_Entry_Rep |
10376 | (PE_Id : Entity_Id) return Target_Rep_Record; | |
10377 | pragma Inline (Create_Protected_Entry_Rep); | |
10378 | -- Create the representation of protected entry PE_Id | |
10379 | ||
10380 | function Create_Protected_Subprogram_Rep | |
10381 | (PS_Id : Entity_Id) return Target_Rep_Record; | |
10382 | pragma Inline (Create_Protected_Subprogram_Rep); | |
10383 | -- Create the representation of protected subprogram PS_Id | |
10384 | ||
10385 | function Create_Refined_State_Pragma_Rep | |
10386 | (Prag : Node_Id) return Scenario_Rep_Record; | |
10387 | pragma Inline (Create_Refined_State_Pragma_Rep); | |
10388 | -- Create the representation of Refined_State pragma Prag | |
10389 | ||
10390 | function Create_Scenario_Rep | |
10391 | (N : Node_Id; | |
10392 | In_State : Processing_In_State) return Scenario_Rep_Record; | |
10393 | pragma Inline (Create_Scenario_Rep); | |
10394 | -- Top level dispatcher. Create the representation of elaboration | |
10395 | -- scenario N. In_State is the current state of the Processing phase. | |
10396 | ||
10397 | function Create_Subprogram_Rep | |
10398 | (Subp_Id : Entity_Id) return Target_Rep_Record; | |
10399 | pragma Inline (Create_Subprogram_Rep); | |
10400 | -- Create the representation of entry, operator, or subprogram Subp_Id | |
10401 | ||
10402 | function Create_Target_Rep | |
10403 | (Id : Entity_Id; | |
10404 | In_State : Processing_In_State) return Target_Rep_Record; | |
10405 | pragma Inline (Create_Target_Rep); | |
10406 | -- Top level dispatcher. Create the representation of elaboration target | |
10407 | -- Id. In_State is the current state of the Processing phase. | |
10408 | ||
10409 | function Create_Task_Entry_Rep | |
10410 | (TE_Id : Entity_Id) return Target_Rep_Record; | |
10411 | pragma Inline (Create_Task_Entry_Rep); | |
10412 | -- Create the representation of task entry TE_Id | |
10413 | ||
10414 | function Create_Task_Rep (Task_Typ : Entity_Id) return Target_Rep_Record; | |
10415 | pragma Inline (Create_Task_Rep); | |
10416 | -- Create the representation of task type Typ | |
10417 | ||
10418 | function Create_Variable_Assignment_Rep | |
10419 | (Asmt : Node_Id) return Scenario_Rep_Record; | |
10420 | pragma Inline (Create_Variable_Assignment_Rep); | |
10421 | -- Create the representation of variable assignment Asmt | |
10422 | ||
10423 | function Create_Variable_Reference_Rep | |
10424 | (Ref : Node_Id) return Scenario_Rep_Record; | |
10425 | pragma Inline (Create_Variable_Reference_Rep); | |
10426 | -- Create the representation of variable reference Ref | |
10427 | ||
10428 | function Create_Variable_Rep | |
10429 | (Var_Id : Entity_Id) return Target_Rep_Record; | |
10430 | pragma Inline (Create_Variable_Rep); | |
10431 | -- Create the representation of variable Var_Id | |
10432 | ||
10433 | ----------------------- | |
10434 | -- Local subprograms -- | |
10435 | ----------------------- | |
10436 | ||
10437 | function Ghost_Mode_Of_Entity | |
10438 | (Id : Entity_Id) return Extended_Ghost_Mode; | |
10439 | pragma Inline (Ghost_Mode_Of_Entity); | |
10440 | -- Obtain the extended Ghost mode of arbitrary entity Id | |
10441 | ||
10442 | function Ghost_Mode_Of_Node (N : Node_Id) return Extended_Ghost_Mode; | |
10443 | pragma Inline (Ghost_Mode_Of_Node); | |
10444 | -- Obtain the extended Ghost mode of arbitrary node N | |
90e491a7 | 10445 | |
69e6ee2f HK |
10446 | function Present (S_Id : Scenario_Rep_Id) return Boolean; |
10447 | pragma Inline (Present); | |
10448 | -- Determine whether scenario representation S_Id exists | |
10449 | ||
10450 | function Present (T_Id : Target_Rep_Id) return Boolean; | |
10451 | pragma Inline (Present); | |
10452 | -- Determine whether target representation T_Id exists | |
10453 | ||
10454 | function SPARK_Mode_Of_Entity | |
10455 | (Id : Entity_Id) return Extended_SPARK_Mode; | |
10456 | pragma Inline (SPARK_Mode_Of_Entity); | |
10457 | -- Obtain the extended SPARK mode of arbitrary entity Id | |
10458 | ||
10459 | function SPARK_Mode_Of_Node (N : Node_Id) return Extended_SPARK_Mode; | |
10460 | pragma Inline (SPARK_Mode_Of_Node); | |
10461 | -- Obtain the extended SPARK mode of arbitrary node N | |
10462 | ||
10463 | function To_Ghost_Mode | |
10464 | (Ignored_Status : Boolean) return Extended_Ghost_Mode; | |
10465 | pragma Inline (To_Ghost_Mode); | |
10466 | -- Convert a Ghost mode indicated by Ignored_Status into its extended | |
10467 | -- equivalent. | |
10468 | ||
10469 | function To_SPARK_Mode (On_Status : Boolean) return Extended_SPARK_Mode; | |
10470 | pragma Inline (To_SPARK_Mode); | |
10471 | -- Convert a SPARK mode indicated by On_Status into its extended | |
10472 | -- equivalent. | |
10473 | ||
10474 | function Version (T_Id : Target_Rep_Id) return Representation_Kind; | |
10475 | pragma Inline (Version); | |
10476 | -- Obtain the version of target representation T_Id | |
10477 | ||
10478 | ---------------------------- | |
10479 | -- Activated_Task_Objects -- | |
10480 | ---------------------------- | |
10481 | ||
10482 | function Activated_Task_Objects | |
10483 | (S_Id : Scenario_Rep_Id) return NE_List.Doubly_Linked_List | |
10484 | is | |
10485 | pragma Assert (Present (S_Id)); | |
10486 | pragma Assert (Kind (S_Id) = Task_Activation_Scenario); | |
90e491a7 PMR |
10487 | |
10488 | begin | |
69e6ee2f HK |
10489 | return Scenario_Reps.Table (S_Id).List_1; |
10490 | end Activated_Task_Objects; | |
90e491a7 | 10491 | |
69e6ee2f HK |
10492 | ------------------------- |
10493 | -- Activated_Task_Type -- | |
10494 | ------------------------- | |
10495 | ||
10496 | function Activated_Task_Type | |
10497 | (S_Id : Scenario_Rep_Id) return Entity_Id | |
10498 | is | |
10499 | pragma Assert (Present (S_Id)); | |
10500 | pragma Assert (Kind (S_Id) = Task_Activation_Scenario); | |
10501 | ||
10502 | begin | |
10503 | return Scenario_Reps.Table (S_Id).Field_1; | |
10504 | end Activated_Task_Type; | |
10505 | ||
10506 | ------------------------------ | |
10507 | -- Barrier_Body_Declaration -- | |
10508 | ------------------------------ | |
10509 | ||
10510 | function Barrier_Body_Declaration | |
10511 | (T_Id : Target_Rep_Id) return Node_Id | |
10512 | is | |
10513 | pragma Assert (Present (T_Id)); | |
10514 | pragma Assert (Kind (T_Id) = Subprogram_Target); | |
10515 | ||
10516 | begin | |
10517 | return Target_Reps.Table (T_Id).Field_1; | |
10518 | end Barrier_Body_Declaration; | |
90e491a7 PMR |
10519 | |
10520 | ---------------------- | |
69e6ee2f | 10521 | -- Body_Declaration -- |
90e491a7 PMR |
10522 | ---------------------- |
10523 | ||
69e6ee2f HK |
10524 | function Body_Declaration (T_Id : Target_Rep_Id) return Node_Id is |
10525 | pragma Assert (Present (T_Id)); | |
90e491a7 | 10526 | begin |
69e6ee2f HK |
10527 | return Target_Reps.Table (T_Id).Body_Decl; |
10528 | end Body_Declaration; | |
90e491a7 | 10529 | |
69e6ee2f HK |
10530 | ----------------------------- |
10531 | -- Create_Access_Taken_Rep -- | |
10532 | ----------------------------- | |
90e491a7 | 10533 | |
69e6ee2f HK |
10534 | function Create_Access_Taken_Rep |
10535 | (Attr : Node_Id) return Scenario_Rep_Record | |
10536 | is | |
10537 | Rec : Scenario_Rep_Record; | |
90e491a7 PMR |
10538 | |
10539 | begin | |
69e6ee2f HK |
10540 | Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Attr); |
10541 | Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Attr); | |
10542 | Rec.GM := Is_Checked_Or_Not_Specified; | |
10543 | Rec.SM := SPARK_Mode_Of_Node (Attr); | |
10544 | Rec.Kind := Access_Taken_Scenario; | |
10545 | Rec.Target := Canonical_Subprogram (Entity (Prefix (Attr))); | |
90e491a7 | 10546 | |
69e6ee2f HK |
10547 | return Rec; |
10548 | end Create_Access_Taken_Rep; | |
90e491a7 | 10549 | |
69e6ee2f HK |
10550 | ---------------------------------------- |
10551 | -- Create_Call_Or_Task_Activation_Rep -- | |
10552 | ---------------------------------------- | |
90e491a7 | 10553 | |
69e6ee2f HK |
10554 | function Create_Call_Or_Task_Activation_Rep |
10555 | (Call : Node_Id) return Scenario_Rep_Record | |
90e491a7 | 10556 | is |
69e6ee2f HK |
10557 | Subp_Id : constant Entity_Id := Canonical_Subprogram (Target (Call)); |
10558 | Kind : Scenario_Kind; | |
10559 | Rec : Scenario_Rep_Record; | |
10560 | ||
90e491a7 | 10561 | begin |
69e6ee2f HK |
10562 | if Is_Activation_Proc (Subp_Id) then |
10563 | Kind := Task_Activation_Scenario; | |
10564 | else | |
10565 | Kind := Call_Scenario; | |
10566 | end if; | |
90e491a7 | 10567 | |
69e6ee2f HK |
10568 | Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call); |
10569 | Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call); | |
10570 | Rec.GM := Ghost_Mode_Of_Node (Call); | |
10571 | Rec.SM := SPARK_Mode_Of_Node (Call); | |
10572 | Rec.Kind := Kind; | |
10573 | Rec.Target := Subp_Id; | |
90e491a7 | 10574 | |
69e6ee2f | 10575 | -- Scenario-specific attributes |
90e491a7 | 10576 | |
69e6ee2f | 10577 | Rec.Flag_1 := Is_Dispatching_Call (Call); -- Dispatching_Call |
90e491a7 | 10578 | |
69e6ee2f HK |
10579 | return Rec; |
10580 | end Create_Call_Or_Task_Activation_Rep; | |
90e491a7 | 10581 | |
69e6ee2f HK |
10582 | ----------------------------- |
10583 | -- Create_Derived_Type_Rep -- | |
10584 | ----------------------------- | |
90e491a7 | 10585 | |
69e6ee2f HK |
10586 | function Create_Derived_Type_Rep |
10587 | (Typ_Decl : Node_Id) return Scenario_Rep_Record | |
10588 | is | |
10589 | Typ : constant Entity_Id := Defining_Entity (Typ_Decl); | |
10590 | Rec : Scenario_Rep_Record; | |
90e491a7 | 10591 | |
69e6ee2f HK |
10592 | begin |
10593 | Rec.Elab_Checks_OK := False; -- not relevant | |
10594 | Rec.Elab_Warnings_OK := False; -- not relevant | |
10595 | Rec.GM := Ghost_Mode_Of_Entity (Typ); | |
10596 | Rec.SM := SPARK_Mode_Of_Entity (Typ); | |
10597 | Rec.Kind := Derived_Type_Scenario; | |
10598 | Rec.Target := Typ; | |
10599 | ||
10600 | return Rec; | |
10601 | end Create_Derived_Type_Rep; | |
10602 | ||
10603 | ------------------------ | |
10604 | -- Create_Generic_Rep -- | |
10605 | ------------------------ | |
10606 | ||
10607 | function Create_Generic_Rep | |
10608 | (Gen_Id : Entity_Id) return Target_Rep_Record | |
10609 | is | |
10610 | Rec : Target_Rep_Record; | |
90e491a7 | 10611 | |
69e6ee2f HK |
10612 | begin |
10613 | Rec.Kind := Generic_Target; | |
90e491a7 | 10614 | |
69e6ee2f HK |
10615 | Spec_And_Body_From_Entity |
10616 | (Id => Gen_Id, | |
10617 | Body_Decl => Rec.Body_Decl, | |
10618 | Spec_Decl => Rec.Spec_Decl); | |
90e491a7 | 10619 | |
69e6ee2f HK |
10620 | return Rec; |
10621 | end Create_Generic_Rep; | |
90e491a7 | 10622 | |
69e6ee2f HK |
10623 | ------------------------------ |
10624 | -- Create_Instantiation_Rep -- | |
10625 | ------------------------------ | |
10626 | ||
10627 | function Create_Instantiation_Rep | |
10628 | (Inst : Node_Id) return Scenario_Rep_Record | |
10629 | is | |
10630 | Rec : Scenario_Rep_Record; | |
90e491a7 | 10631 | |
69e6ee2f HK |
10632 | begin |
10633 | Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst); | |
10634 | Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Inst); | |
10635 | Rec.GM := Ghost_Mode_Of_Node (Inst); | |
10636 | Rec.SM := SPARK_Mode_Of_Node (Inst); | |
10637 | Rec.Kind := Instantiation_Scenario; | |
10638 | Rec.Target := Instantiated_Generic (Inst); | |
90e491a7 | 10639 | |
69e6ee2f HK |
10640 | return Rec; |
10641 | end Create_Instantiation_Rep; | |
90e491a7 | 10642 | |
3eb5e54a HK |
10643 | ------------------------ |
10644 | -- Create_Package_Rep -- | |
10645 | ------------------------ | |
10646 | ||
10647 | function Create_Package_Rep | |
10648 | (Pack_Id : Entity_Id) return Target_Rep_Record | |
10649 | is | |
10650 | Rec : Target_Rep_Record; | |
10651 | ||
10652 | begin | |
10653 | Rec.Kind := Package_Target; | |
10654 | ||
10655 | Spec_And_Body_From_Entity | |
10656 | (Id => Pack_Id, | |
10657 | Body_Decl => Rec.Body_Decl, | |
10658 | Spec_Decl => Rec.Spec_Decl); | |
10659 | ||
10660 | return Rec; | |
10661 | end Create_Package_Rep; | |
10662 | ||
69e6ee2f HK |
10663 | -------------------------------- |
10664 | -- Create_Protected_Entry_Rep -- | |
10665 | -------------------------------- | |
90e491a7 | 10666 | |
69e6ee2f HK |
10667 | function Create_Protected_Entry_Rep |
10668 | (PE_Id : Entity_Id) return Target_Rep_Record | |
10669 | is | |
10670 | Prot_Id : constant Entity_Id := Protected_Body_Subprogram (PE_Id); | |
10671 | ||
10672 | Barf_Id : Entity_Id; | |
10673 | Dummy : Node_Id; | |
10674 | Rec : Target_Rep_Record; | |
10675 | Spec_Id : Entity_Id; | |
10676 | ||
10677 | begin | |
10678 | -- When the entry [family] has already been expanded, it carries both | |
10679 | -- the procedure which emulates the behavior of the entry [family] as | |
10680 | -- well as the barrier function. | |
10681 | ||
10682 | if Present (Prot_Id) then | |
10683 | Barf_Id := Barrier_Function (PE_Id); | |
10684 | Spec_Id := Prot_Id; | |
10685 | ||
10686 | -- Otherwise no expansion took place | |
10687 | ||
10688 | else | |
10689 | Barf_Id := Empty; | |
10690 | Spec_Id := PE_Id; | |
10691 | end if; | |
10692 | ||
10693 | Rec.Kind := Subprogram_Target; | |
10694 | ||
10695 | Spec_And_Body_From_Entity | |
10696 | (Id => Spec_Id, | |
10697 | Body_Decl => Rec.Body_Decl, | |
10698 | Spec_Decl => Rec.Spec_Decl); | |
10699 | ||
10700 | -- Target-specific attributes | |
10701 | ||
10702 | if Present (Barf_Id) then | |
10703 | Spec_And_Body_From_Entity | |
10704 | (Id => Barf_Id, | |
10705 | Body_Decl => Rec.Field_1, -- Barrier_Body_Declaration | |
10706 | Spec_Decl => Dummy); | |
10707 | end if; | |
10708 | ||
10709 | return Rec; | |
10710 | end Create_Protected_Entry_Rep; | |
10711 | ||
10712 | ------------------------------------- | |
10713 | -- Create_Protected_Subprogram_Rep -- | |
10714 | ------------------------------------- | |
10715 | ||
10716 | function Create_Protected_Subprogram_Rep | |
10717 | (PS_Id : Entity_Id) return Target_Rep_Record | |
10718 | is | |
10719 | Prot_Id : constant Entity_Id := Protected_Body_Subprogram (PS_Id); | |
10720 | Rec : Target_Rep_Record; | |
10721 | Spec_Id : Entity_Id; | |
10722 | ||
10723 | begin | |
10724 | -- When the protected subprogram has already been expanded, it | |
10725 | -- carries the subprogram which seizes the lock and invokes the | |
10726 | -- original statements. | |
10727 | ||
10728 | if Present (Prot_Id) then | |
10729 | Spec_Id := Prot_Id; | |
10730 | ||
10731 | -- Otherwise no expansion took place | |
10732 | ||
10733 | else | |
10734 | Spec_Id := PS_Id; | |
10735 | end if; | |
10736 | ||
10737 | Rec.Kind := Subprogram_Target; | |
10738 | ||
10739 | Spec_And_Body_From_Entity | |
10740 | (Id => Spec_Id, | |
10741 | Body_Decl => Rec.Body_Decl, | |
10742 | Spec_Decl => Rec.Spec_Decl); | |
10743 | ||
10744 | return Rec; | |
10745 | end Create_Protected_Subprogram_Rep; | |
10746 | ||
10747 | ------------------------------------- | |
10748 | -- Create_Refined_State_Pragma_Rep -- | |
10749 | ------------------------------------- | |
10750 | ||
10751 | function Create_Refined_State_Pragma_Rep | |
10752 | (Prag : Node_Id) return Scenario_Rep_Record | |
10753 | is | |
10754 | Rec : Scenario_Rep_Record; | |
10755 | ||
10756 | begin | |
10757 | Rec.Elab_Checks_OK := False; -- not relevant | |
10758 | Rec.Elab_Warnings_OK := False; -- not relevant | |
10759 | Rec.GM := | |
10760 | To_Ghost_Mode (Is_Ignored_Ghost_Pragma (Prag)); | |
10761 | Rec.SM := Is_Off_Or_Not_Specified; | |
10762 | Rec.Kind := Refined_State_Pragma_Scenario; | |
10763 | Rec.Target := Empty; | |
10764 | ||
10765 | return Rec; | |
10766 | end Create_Refined_State_Pragma_Rep; | |
10767 | ||
10768 | ------------------------- | |
10769 | -- Create_Scenario_Rep -- | |
10770 | ------------------------- | |
10771 | ||
10772 | function Create_Scenario_Rep | |
10773 | (N : Node_Id; | |
10774 | In_State : Processing_In_State) return Scenario_Rep_Record | |
10775 | is | |
10776 | pragma Unreferenced (In_State); | |
10777 | ||
10778 | Rec : Scenario_Rep_Record; | |
10779 | ||
10780 | begin | |
10781 | if Is_Suitable_Access_Taken (N) then | |
10782 | Rec := Create_Access_Taken_Rep (N); | |
10783 | ||
10784 | elsif Is_Suitable_Call (N) then | |
10785 | Rec := Create_Call_Or_Task_Activation_Rep (N); | |
10786 | ||
10787 | elsif Is_Suitable_Instantiation (N) then | |
10788 | Rec := Create_Instantiation_Rep (N); | |
10789 | ||
10790 | elsif Is_Suitable_SPARK_Derived_Type (N) then | |
10791 | Rec := Create_Derived_Type_Rep (N); | |
10792 | ||
10793 | elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then | |
10794 | Rec := Create_Refined_State_Pragma_Rep (N); | |
10795 | ||
10796 | elsif Is_Suitable_Variable_Assignment (N) then | |
10797 | Rec := Create_Variable_Assignment_Rep (N); | |
10798 | ||
10799 | elsif Is_Suitable_Variable_Reference (N) then | |
10800 | Rec := Create_Variable_Reference_Rep (N); | |
10801 | ||
10802 | else | |
10803 | pragma Assert (False); | |
10804 | return Rec; | |
10805 | end if; | |
10806 | ||
10807 | -- Common scenario attributes | |
10808 | ||
10809 | Rec.Level := Find_Enclosing_Level (N); | |
10810 | ||
10811 | return Rec; | |
10812 | end Create_Scenario_Rep; | |
10813 | ||
10814 | --------------------------- | |
10815 | -- Create_Subprogram_Rep -- | |
10816 | --------------------------- | |
90e491a7 | 10817 | |
69e6ee2f HK |
10818 | function Create_Subprogram_Rep |
10819 | (Subp_Id : Entity_Id) return Target_Rep_Record | |
10820 | is | |
10821 | Rec : Target_Rep_Record; | |
10822 | Spec_Id : Entity_Id; | |
90e491a7 | 10823 | |
69e6ee2f HK |
10824 | begin |
10825 | Spec_Id := Subp_Id; | |
90e491a7 | 10826 | |
69e6ee2f HK |
10827 | -- The elaboration target denotes an internal function that returns a |
10828 | -- constrained array type in a SPARK-to-C compilation. In this case | |
10829 | -- the function receives a corresponding procedure which has an out | |
10830 | -- parameter. The proper body for ABE checks and diagnostics is that | |
10831 | -- of the procedure. | |
90e491a7 | 10832 | |
69e6ee2f HK |
10833 | if Ekind (Spec_Id) = E_Function |
10834 | and then Rewritten_For_C (Spec_Id) | |
10835 | then | |
10836 | Spec_Id := Corresponding_Procedure (Spec_Id); | |
10837 | end if; | |
90e491a7 | 10838 | |
69e6ee2f | 10839 | Rec.Kind := Subprogram_Target; |
90e491a7 | 10840 | |
69e6ee2f HK |
10841 | Spec_And_Body_From_Entity |
10842 | (Id => Spec_Id, | |
10843 | Body_Decl => Rec.Body_Decl, | |
10844 | Spec_Decl => Rec.Spec_Decl); | |
90e491a7 | 10845 | |
69e6ee2f HK |
10846 | return Rec; |
10847 | end Create_Subprogram_Rep; | |
90e491a7 | 10848 | |
69e6ee2f HK |
10849 | ----------------------- |
10850 | -- Create_Target_Rep -- | |
10851 | ----------------------- | |
90e491a7 | 10852 | |
69e6ee2f HK |
10853 | function Create_Target_Rep |
10854 | (Id : Entity_Id; | |
10855 | In_State : Processing_In_State) return Target_Rep_Record | |
10856 | is | |
10857 | Rec : Target_Rep_Record; | |
90e491a7 | 10858 | |
69e6ee2f HK |
10859 | begin |
10860 | if Is_Generic_Unit (Id) then | |
10861 | Rec := Create_Generic_Rep (Id); | |
90e491a7 | 10862 | |
69e6ee2f HK |
10863 | elsif Is_Protected_Entry (Id) then |
10864 | Rec := Create_Protected_Entry_Rep (Id); | |
90e491a7 | 10865 | |
69e6ee2f HK |
10866 | elsif Is_Protected_Subp (Id) then |
10867 | Rec := Create_Protected_Subprogram_Rep (Id); | |
90e491a7 | 10868 | |
69e6ee2f HK |
10869 | elsif Is_Task_Entry (Id) then |
10870 | Rec := Create_Task_Entry_Rep (Id); | |
90e491a7 | 10871 | |
69e6ee2f HK |
10872 | elsif Is_Task_Type (Id) then |
10873 | Rec := Create_Task_Rep (Id); | |
90e491a7 | 10874 | |
69e6ee2f HK |
10875 | elsif Ekind_In (Id, E_Constant, E_Variable) then |
10876 | Rec := Create_Variable_Rep (Id); | |
90e491a7 | 10877 | |
69e6ee2f HK |
10878 | elsif Ekind_In (Id, E_Entry, |
10879 | E_Function, | |
10880 | E_Operator, | |
10881 | E_Procedure) | |
10882 | then | |
10883 | Rec := Create_Subprogram_Rep (Id); | |
90e491a7 | 10884 | |
3eb5e54a HK |
10885 | elsif Ekind (Id) = E_Package then |
10886 | Rec := Create_Package_Rep (Id); | |
10887 | ||
90e491a7 PMR |
10888 | else |
10889 | pragma Assert (False); | |
69e6ee2f | 10890 | return Rec; |
90e491a7 | 10891 | end if; |
90e491a7 | 10892 | |
69e6ee2f | 10893 | -- Common target attributes |
90e491a7 | 10894 | |
69e6ee2f HK |
10895 | Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Id); |
10896 | Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Id); | |
10897 | Rec.GM := Ghost_Mode_Of_Entity (Id); | |
10898 | Rec.SM := SPARK_Mode_Of_Entity (Id); | |
10899 | Rec.Unit := Find_Top_Unit (Id); | |
10900 | Rec.Version := In_State.Representation; | |
90e491a7 | 10901 | |
69e6ee2f HK |
10902 | return Rec; |
10903 | end Create_Target_Rep; | |
90e491a7 | 10904 | |
69e6ee2f HK |
10905 | --------------------------- |
10906 | -- Create_Task_Entry_Rep -- | |
10907 | --------------------------- | |
90e491a7 | 10908 | |
69e6ee2f HK |
10909 | function Create_Task_Entry_Rep |
10910 | (TE_Id : Entity_Id) return Target_Rep_Record | |
10911 | is | |
10912 | Task_Typ : constant Entity_Id := Non_Private_View (Scope (TE_Id)); | |
10913 | Task_Body_Id : constant Entity_Id := Task_Body_Procedure (Task_Typ); | |
90e491a7 | 10914 | |
69e6ee2f HK |
10915 | Rec : Target_Rep_Record; |
10916 | Spec_Id : Entity_Id; | |
90e491a7 | 10917 | |
69e6ee2f | 10918 | begin |
604801a4 PT |
10919 | -- The task type has already been expanded, it carries the procedure |
10920 | -- which emulates the behavior of the task body. | |
90e491a7 | 10921 | |
69e6ee2f HK |
10922 | if Present (Task_Body_Id) then |
10923 | Spec_Id := Task_Body_Id; | |
90e491a7 | 10924 | |
69e6ee2f | 10925 | -- Otherwise no expansion took place |
90e491a7 | 10926 | |
69e6ee2f HK |
10927 | else |
10928 | Spec_Id := TE_Id; | |
10929 | end if; | |
90e491a7 | 10930 | |
69e6ee2f | 10931 | Rec.Kind := Subprogram_Target; |
90e491a7 | 10932 | |
69e6ee2f HK |
10933 | Spec_And_Body_From_Entity |
10934 | (Id => Spec_Id, | |
10935 | Body_Decl => Rec.Body_Decl, | |
10936 | Spec_Decl => Rec.Spec_Decl); | |
90e491a7 | 10937 | |
69e6ee2f HK |
10938 | return Rec; |
10939 | end Create_Task_Entry_Rep; | |
98b779ae | 10940 | |
69e6ee2f HK |
10941 | --------------------- |
10942 | -- Create_Task_Rep -- | |
10943 | --------------------- | |
98b779ae | 10944 | |
69e6ee2f HK |
10945 | function Create_Task_Rep |
10946 | (Task_Typ : Entity_Id) return Target_Rep_Record | |
10947 | is | |
10948 | Task_Body_Id : constant Entity_Id := Task_Body_Procedure (Task_Typ); | |
90e491a7 | 10949 | |
69e6ee2f HK |
10950 | Rec : Target_Rep_Record; |
10951 | Spec_Id : Entity_Id; | |
90e491a7 | 10952 | |
69e6ee2f | 10953 | begin |
604801a4 PT |
10954 | -- The task type has already been expanded, it carries the procedure |
10955 | -- which emulates the behavior of the task body. | |
90e491a7 | 10956 | |
69e6ee2f HK |
10957 | if Present (Task_Body_Id) then |
10958 | Spec_Id := Task_Body_Id; | |
90e491a7 | 10959 | |
69e6ee2f | 10960 | -- Otherwise no expansion took place |
90e491a7 | 10961 | |
69e6ee2f HK |
10962 | else |
10963 | Spec_Id := Task_Typ; | |
10964 | end if; | |
90e491a7 | 10965 | |
69e6ee2f | 10966 | Rec.Kind := Task_Target; |
90e491a7 | 10967 | |
69e6ee2f HK |
10968 | Spec_And_Body_From_Entity |
10969 | (Id => Spec_Id, | |
10970 | Body_Decl => Rec.Body_Decl, | |
10971 | Spec_Decl => Rec.Spec_Decl); | |
90e491a7 | 10972 | |
69e6ee2f HK |
10973 | return Rec; |
10974 | end Create_Task_Rep; | |
90e491a7 | 10975 | |
69e6ee2f HK |
10976 | ------------------------------------ |
10977 | -- Create_Variable_Assignment_Rep -- | |
10978 | ------------------------------------ | |
90e491a7 | 10979 | |
69e6ee2f HK |
10980 | function Create_Variable_Assignment_Rep |
10981 | (Asmt : Node_Id) return Scenario_Rep_Record | |
10982 | is | |
10983 | Var_Id : constant Entity_Id := Entity (Assignment_Target (Asmt)); | |
10984 | Rec : Scenario_Rep_Record; | |
90e491a7 | 10985 | |
69e6ee2f HK |
10986 | begin |
10987 | Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Asmt); | |
10988 | Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Var_Id); | |
10989 | Rec.GM := Ghost_Mode_Of_Node (Asmt); | |
10990 | Rec.SM := SPARK_Mode_Of_Node (Asmt); | |
10991 | Rec.Kind := Variable_Assignment_Scenario; | |
10992 | Rec.Target := Var_Id; | |
90e491a7 | 10993 | |
69e6ee2f HK |
10994 | return Rec; |
10995 | end Create_Variable_Assignment_Rep; | |
90e491a7 | 10996 | |
69e6ee2f HK |
10997 | ----------------------------------- |
10998 | -- Create_Variable_Reference_Rep -- | |
10999 | ----------------------------------- | |
90e491a7 | 11000 | |
69e6ee2f HK |
11001 | function Create_Variable_Reference_Rep |
11002 | (Ref : Node_Id) return Scenario_Rep_Record | |
11003 | is | |
11004 | Rec : Scenario_Rep_Record; | |
90e491a7 | 11005 | |
69e6ee2f HK |
11006 | begin |
11007 | Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Ref); | |
11008 | Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Ref); | |
11009 | Rec.GM := Ghost_Mode_Of_Node (Ref); | |
11010 | Rec.SM := SPARK_Mode_Of_Node (Ref); | |
11011 | Rec.Kind := Variable_Reference_Scenario; | |
11012 | Rec.Target := Target (Ref); | |
90e491a7 | 11013 | |
69e6ee2f | 11014 | -- Scenario-specific attributes |
90e491a7 | 11015 | |
69e6ee2f | 11016 | Rec.Flag_1 := Is_Read (Ref); -- Is_Read_Reference |
90e491a7 | 11017 | |
69e6ee2f HK |
11018 | return Rec; |
11019 | end Create_Variable_Reference_Rep; | |
90e491a7 | 11020 | |
69e6ee2f HK |
11021 | ------------------------- |
11022 | -- Create_Variable_Rep -- | |
11023 | ------------------------- | |
90e491a7 | 11024 | |
69e6ee2f HK |
11025 | function Create_Variable_Rep |
11026 | (Var_Id : Entity_Id) return Target_Rep_Record | |
11027 | is | |
11028 | Rec : Target_Rep_Record; | |
11029 | ||
11030 | begin | |
11031 | Rec.Kind := Variable_Target; | |
90e491a7 | 11032 | |
69e6ee2f | 11033 | -- Target-specific attributes |
90e491a7 | 11034 | |
69e6ee2f HK |
11035 | Rec.Field_1 := Declaration_Node (Var_Id); -- Variable_Declaration |
11036 | ||
11037 | return Rec; | |
11038 | end Create_Variable_Rep; | |
11039 | ||
11040 | ------------- | |
11041 | -- Destroy -- | |
11042 | ------------- | |
11043 | ||
11044 | procedure Destroy (S_Id : in out Scenario_Rep_Id) is | |
11045 | pragma Unreferenced (S_Id); | |
90e491a7 | 11046 | begin |
69e6ee2f HK |
11047 | null; |
11048 | end Destroy; | |
90e491a7 | 11049 | |
69e6ee2f HK |
11050 | ------------- |
11051 | -- Destroy -- | |
11052 | ------------- | |
90e491a7 | 11053 | |
69e6ee2f HK |
11054 | procedure Destroy (T_Id : in out Target_Rep_Id) is |
11055 | pragma Unreferenced (T_Id); | |
11056 | begin | |
11057 | null; | |
11058 | end Destroy; | |
90e491a7 | 11059 | |
69e6ee2f HK |
11060 | -------------------------------- |
11061 | -- Disable_Elaboration_Checks -- | |
11062 | -------------------------------- | |
90e491a7 | 11063 | |
69e6ee2f HK |
11064 | procedure Disable_Elaboration_Checks (S_Id : Scenario_Rep_Id) is |
11065 | pragma Assert (Present (S_Id)); | |
11066 | begin | |
11067 | Scenario_Reps.Table (S_Id).Elab_Checks_OK := False; | |
11068 | end Disable_Elaboration_Checks; | |
90e491a7 | 11069 | |
69e6ee2f HK |
11070 | -------------------------------- |
11071 | -- Disable_Elaboration_Checks -- | |
11072 | -------------------------------- | |
90e491a7 | 11073 | |
69e6ee2f HK |
11074 | procedure Disable_Elaboration_Checks (T_Id : Target_Rep_Id) is |
11075 | pragma Assert (Present (T_Id)); | |
11076 | begin | |
11077 | Target_Reps.Table (T_Id).Elab_Checks_OK := False; | |
11078 | end Disable_Elaboration_Checks; | |
90e491a7 | 11079 | |
69e6ee2f HK |
11080 | --------------------------- |
11081 | -- Elaboration_Checks_OK -- | |
11082 | --------------------------- | |
90e491a7 | 11083 | |
69e6ee2f HK |
11084 | function Elaboration_Checks_OK (S_Id : Scenario_Rep_Id) return Boolean is |
11085 | pragma Assert (Present (S_Id)); | |
11086 | begin | |
11087 | return Scenario_Reps.Table (S_Id).Elab_Checks_OK; | |
11088 | end Elaboration_Checks_OK; | |
90e491a7 | 11089 | |
69e6ee2f HK |
11090 | --------------------------- |
11091 | -- Elaboration_Checks_OK -- | |
11092 | --------------------------- | |
90e491a7 | 11093 | |
69e6ee2f HK |
11094 | function Elaboration_Checks_OK (T_Id : Target_Rep_Id) return Boolean is |
11095 | pragma Assert (Present (T_Id)); | |
11096 | begin | |
11097 | return Target_Reps.Table (T_Id).Elab_Checks_OK; | |
11098 | end Elaboration_Checks_OK; | |
90e491a7 | 11099 | |
69e6ee2f HK |
11100 | ----------------------------- |
11101 | -- Elaboration_Warnings_OK -- | |
11102 | ----------------------------- | |
90e491a7 | 11103 | |
69e6ee2f HK |
11104 | function Elaboration_Warnings_OK |
11105 | (S_Id : Scenario_Rep_Id) return Boolean | |
11106 | is | |
11107 | pragma Assert (Present (S_Id)); | |
11108 | begin | |
11109 | return Scenario_Reps.Table (S_Id).Elab_Warnings_OK; | |
11110 | end Elaboration_Warnings_OK; | |
98b779ae | 11111 | |
69e6ee2f HK |
11112 | ----------------------------- |
11113 | -- Elaboration_Warnings_OK -- | |
11114 | ----------------------------- | |
98b779ae | 11115 | |
69e6ee2f HK |
11116 | function Elaboration_Warnings_OK (T_Id : Target_Rep_Id) return Boolean is |
11117 | pragma Assert (Present (T_Id)); | |
11118 | begin | |
11119 | return Target_Reps.Table (T_Id).Elab_Warnings_OK; | |
11120 | end Elaboration_Warnings_OK; | |
90e491a7 | 11121 | |
69e6ee2f HK |
11122 | -------------------------------------- |
11123 | -- Finalize_Internal_Representation -- | |
11124 | -------------------------------------- | |
90e491a7 | 11125 | |
69e6ee2f HK |
11126 | procedure Finalize_Internal_Representation is |
11127 | begin | |
11128 | ETT_Map.Destroy (Entity_To_Target_Map); | |
11129 | NTS_Map.Destroy (Node_To_Scenario_Map); | |
11130 | end Finalize_Internal_Representation; | |
90e491a7 | 11131 | |
69e6ee2f HK |
11132 | ------------------- |
11133 | -- Ghost_Mode_Of -- | |
11134 | ------------------- | |
90e491a7 | 11135 | |
69e6ee2f HK |
11136 | function Ghost_Mode_Of |
11137 | (S_Id : Scenario_Rep_Id) return Extended_Ghost_Mode | |
11138 | is | |
11139 | pragma Assert (Present (S_Id)); | |
11140 | begin | |
11141 | return Scenario_Reps.Table (S_Id).GM; | |
11142 | end Ghost_Mode_Of; | |
90e491a7 | 11143 | |
69e6ee2f HK |
11144 | ------------------- |
11145 | -- Ghost_Mode_Of -- | |
11146 | ------------------- | |
90e491a7 | 11147 | |
69e6ee2f HK |
11148 | function Ghost_Mode_Of |
11149 | (T_Id : Target_Rep_Id) return Extended_Ghost_Mode | |
11150 | is | |
11151 | pragma Assert (Present (T_Id)); | |
11152 | begin | |
11153 | return Target_Reps.Table (T_Id).GM; | |
11154 | end Ghost_Mode_Of; | |
90e491a7 | 11155 | |
69e6ee2f HK |
11156 | -------------------------- |
11157 | -- Ghost_Mode_Of_Entity -- | |
11158 | -------------------------- | |
90e491a7 | 11159 | |
69e6ee2f HK |
11160 | function Ghost_Mode_Of_Entity |
11161 | (Id : Entity_Id) return Extended_Ghost_Mode | |
11162 | is | |
11163 | begin | |
11164 | return To_Ghost_Mode (Is_Ignored_Ghost_Entity (Id)); | |
11165 | end Ghost_Mode_Of_Entity; | |
90e491a7 | 11166 | |
69e6ee2f HK |
11167 | ------------------------ |
11168 | -- Ghost_Mode_Of_Node -- | |
11169 | ------------------------ | |
90e491a7 | 11170 | |
69e6ee2f HK |
11171 | function Ghost_Mode_Of_Node (N : Node_Id) return Extended_Ghost_Mode is |
11172 | begin | |
11173 | return To_Ghost_Mode (Is_Ignored_Ghost_Node (N)); | |
11174 | end Ghost_Mode_Of_Node; | |
90e491a7 | 11175 | |
69e6ee2f HK |
11176 | ---------------------------------------- |
11177 | -- Initialize_Internal_Representation -- | |
11178 | ---------------------------------------- | |
90e491a7 | 11179 | |
69e6ee2f HK |
11180 | procedure Initialize_Internal_Representation is |
11181 | begin | |
0839ffce HK |
11182 | Entity_To_Target_Map := ETT_Map.Create (500); |
11183 | Node_To_Scenario_Map := NTS_Map.Create (500); | |
69e6ee2f | 11184 | end Initialize_Internal_Representation; |
90e491a7 | 11185 | |
69e6ee2f HK |
11186 | ------------------------- |
11187 | -- Is_Dispatching_Call -- | |
11188 | ------------------------- | |
90e491a7 | 11189 | |
69e6ee2f HK |
11190 | function Is_Dispatching_Call (S_Id : Scenario_Rep_Id) return Boolean is |
11191 | pragma Assert (Present (S_Id)); | |
11192 | pragma Assert (Kind (S_Id) = Call_Scenario); | |
90e491a7 | 11193 | |
69e6ee2f HK |
11194 | begin |
11195 | return Scenario_Reps.Table (S_Id).Flag_1; | |
11196 | end Is_Dispatching_Call; | |
98b779ae | 11197 | |
69e6ee2f HK |
11198 | ----------------------- |
11199 | -- Is_Read_Reference -- | |
11200 | ----------------------- | |
98b779ae | 11201 | |
69e6ee2f HK |
11202 | function Is_Read_Reference (S_Id : Scenario_Rep_Id) return Boolean is |
11203 | pragma Assert (Present (S_Id)); | |
11204 | pragma Assert (Kind (S_Id) = Variable_Reference_Scenario); | |
90e491a7 | 11205 | |
69e6ee2f HK |
11206 | begin |
11207 | return Scenario_Reps.Table (S_Id).Flag_1; | |
11208 | end Is_Read_Reference; | |
90e491a7 | 11209 | |
69e6ee2f HK |
11210 | ---------- |
11211 | -- Kind -- | |
11212 | ---------- | |
90e491a7 | 11213 | |
69e6ee2f HK |
11214 | function Kind (S_Id : Scenario_Rep_Id) return Scenario_Kind is |
11215 | pragma Assert (Present (S_Id)); | |
11216 | begin | |
11217 | return Scenario_Reps.Table (S_Id).Kind; | |
11218 | end Kind; | |
90e491a7 | 11219 | |
69e6ee2f HK |
11220 | ---------- |
11221 | -- Kind -- | |
11222 | ---------- | |
90e491a7 | 11223 | |
69e6ee2f HK |
11224 | function Kind (T_Id : Target_Rep_Id) return Target_Kind is |
11225 | pragma Assert (Present (T_Id)); | |
11226 | begin | |
11227 | return Target_Reps.Table (T_Id).Kind; | |
11228 | end Kind; | |
90e491a7 | 11229 | |
69e6ee2f HK |
11230 | ----------- |
11231 | -- Level -- | |
11232 | ----------- | |
90e491a7 | 11233 | |
69e6ee2f HK |
11234 | function Level (S_Id : Scenario_Rep_Id) return Enclosing_Level_Kind is |
11235 | pragma Assert (Present (S_Id)); | |
11236 | begin | |
11237 | return Scenario_Reps.Table (S_Id).Level; | |
11238 | end Level; | |
90e491a7 | 11239 | |
69e6ee2f HK |
11240 | ------------- |
11241 | -- Present -- | |
11242 | ------------- | |
90e491a7 | 11243 | |
69e6ee2f HK |
11244 | function Present (S_Id : Scenario_Rep_Id) return Boolean is |
11245 | begin | |
11246 | return S_Id /= No_Scenario_Rep; | |
11247 | end Present; | |
90e491a7 | 11248 | |
69e6ee2f HK |
11249 | ------------- |
11250 | -- Present -- | |
11251 | ------------- | |
90e491a7 | 11252 | |
69e6ee2f HK |
11253 | function Present (T_Id : Target_Rep_Id) return Boolean is |
11254 | begin | |
11255 | return T_Id /= No_Target_Rep; | |
11256 | end Present; | |
90e491a7 | 11257 | |
69e6ee2f HK |
11258 | -------------------------------- |
11259 | -- Scenario_Representation_Of -- | |
11260 | -------------------------------- | |
90e491a7 | 11261 | |
69e6ee2f HK |
11262 | function Scenario_Representation_Of |
11263 | (N : Node_Id; | |
11264 | In_State : Processing_In_State) return Scenario_Rep_Id | |
11265 | is | |
11266 | S_Id : Scenario_Rep_Id; | |
90e491a7 | 11267 | |
69e6ee2f HK |
11268 | begin |
11269 | S_Id := NTS_Map.Get (Node_To_Scenario_Map, N); | |
90e491a7 | 11270 | |
69e6ee2f HK |
11271 | -- The elaboration scenario lacks a representation. This indicates |
11272 | -- that the scenario is encountered for the first time. Create the | |
11273 | -- representation of it. | |
90e491a7 | 11274 | |
69e6ee2f HK |
11275 | if not Present (S_Id) then |
11276 | Scenario_Reps.Append (Create_Scenario_Rep (N, In_State)); | |
11277 | S_Id := Scenario_Reps.Last; | |
90e491a7 | 11278 | |
69e6ee2f HK |
11279 | -- Associate the internal representation with the elaboration |
11280 | -- scenario. | |
90e491a7 | 11281 | |
69e6ee2f | 11282 | NTS_Map.Put (Node_To_Scenario_Map, N, S_Id); |
90e491a7 | 11283 | end if; |
90e491a7 | 11284 | |
69e6ee2f | 11285 | pragma Assert (Present (S_Id)); |
90e491a7 | 11286 | |
69e6ee2f HK |
11287 | return S_Id; |
11288 | end Scenario_Representation_Of; | |
90e491a7 | 11289 | |
69e6ee2f HK |
11290 | -------------------------------- |
11291 | -- Set_Activated_Task_Objects -- | |
11292 | -------------------------------- | |
90e491a7 | 11293 | |
69e6ee2f HK |
11294 | procedure Set_Activated_Task_Objects |
11295 | (S_Id : Scenario_Rep_Id; | |
11296 | Task_Objs : NE_List.Doubly_Linked_List) | |
11297 | is | |
11298 | pragma Assert (Present (S_Id)); | |
11299 | pragma Assert (Kind (S_Id) = Task_Activation_Scenario); | |
90e491a7 | 11300 | |
69e6ee2f HK |
11301 | begin |
11302 | Scenario_Reps.Table (S_Id).List_1 := Task_Objs; | |
11303 | end Set_Activated_Task_Objects; | |
90e491a7 | 11304 | |
69e6ee2f HK |
11305 | ----------------------------- |
11306 | -- Set_Activated_Task_Type -- | |
11307 | ----------------------------- | |
90e491a7 | 11308 | |
69e6ee2f HK |
11309 | procedure Set_Activated_Task_Type |
11310 | (S_Id : Scenario_Rep_Id; | |
11311 | Task_Typ : Entity_Id) | |
11312 | is | |
11313 | pragma Assert (Present (S_Id)); | |
11314 | pragma Assert (Kind (S_Id) = Task_Activation_Scenario); | |
90e491a7 | 11315 | |
69e6ee2f HK |
11316 | begin |
11317 | Scenario_Reps.Table (S_Id).Field_1 := Task_Typ; | |
11318 | end Set_Activated_Task_Type; | |
90e491a7 | 11319 | |
69e6ee2f HK |
11320 | ------------------- |
11321 | -- SPARK_Mode_Of -- | |
11322 | ------------------- | |
90e491a7 | 11323 | |
69e6ee2f HK |
11324 | function SPARK_Mode_Of |
11325 | (S_Id : Scenario_Rep_Id) return Extended_SPARK_Mode | |
11326 | is | |
11327 | pragma Assert (Present (S_Id)); | |
11328 | begin | |
11329 | return Scenario_Reps.Table (S_Id).SM; | |
11330 | end SPARK_Mode_Of; | |
90e491a7 | 11331 | |
69e6ee2f HK |
11332 | ------------------- |
11333 | -- SPARK_Mode_Of -- | |
11334 | ------------------- | |
90e491a7 | 11335 | |
69e6ee2f HK |
11336 | function SPARK_Mode_Of |
11337 | (T_Id : Target_Rep_Id) return Extended_SPARK_Mode | |
11338 | is | |
11339 | pragma Assert (Present (T_Id)); | |
11340 | begin | |
11341 | return Target_Reps.Table (T_Id).SM; | |
11342 | end SPARK_Mode_Of; | |
90e491a7 | 11343 | |
69e6ee2f HK |
11344 | -------------------------- |
11345 | -- SPARK_Mode_Of_Entity -- | |
11346 | -------------------------- | |
90e491a7 | 11347 | |
69e6ee2f HK |
11348 | function SPARK_Mode_Of_Entity |
11349 | (Id : Entity_Id) return Extended_SPARK_Mode | |
11350 | is | |
11351 | Prag : constant Node_Id := SPARK_Pragma (Id); | |
90e491a7 | 11352 | |
69e6ee2f | 11353 | begin |
90e491a7 | 11354 | return |
69e6ee2f HK |
11355 | To_SPARK_Mode |
11356 | (Present (Prag) | |
11357 | and then Get_SPARK_Mode_From_Annotation (Prag) = On); | |
11358 | end SPARK_Mode_Of_Entity; | |
90e491a7 | 11359 | |
69e6ee2f HK |
11360 | ------------------------ |
11361 | -- SPARK_Mode_Of_Node -- | |
11362 | ------------------------ | |
90e491a7 | 11363 | |
69e6ee2f HK |
11364 | function SPARK_Mode_Of_Node (N : Node_Id) return Extended_SPARK_Mode is |
11365 | begin | |
11366 | return To_SPARK_Mode (Is_SPARK_Mode_On_Node (N)); | |
11367 | end SPARK_Mode_Of_Node; | |
90e491a7 | 11368 | |
69e6ee2f HK |
11369 | ---------------------- |
11370 | -- Spec_Declaration -- | |
11371 | ---------------------- | |
90e491a7 | 11372 | |
69e6ee2f HK |
11373 | function Spec_Declaration (T_Id : Target_Rep_Id) return Node_Id is |
11374 | pragma Assert (Present (T_Id)); | |
11375 | begin | |
11376 | return Target_Reps.Table (T_Id).Spec_Decl; | |
11377 | end Spec_Declaration; | |
90e491a7 | 11378 | |
69e6ee2f HK |
11379 | ------------ |
11380 | -- Target -- | |
11381 | ------------ | |
90e491a7 | 11382 | |
69e6ee2f HK |
11383 | function Target (S_Id : Scenario_Rep_Id) return Entity_Id is |
11384 | pragma Assert (Present (S_Id)); | |
11385 | begin | |
11386 | return Scenario_Reps.Table (S_Id).Target; | |
11387 | end Target; | |
90e491a7 | 11388 | |
69e6ee2f HK |
11389 | ------------------------------ |
11390 | -- Target_Representation_Of -- | |
11391 | ------------------------------ | |
90e491a7 | 11392 | |
69e6ee2f HK |
11393 | function Target_Representation_Of |
11394 | (Id : Entity_Id; | |
11395 | In_State : Processing_In_State) return Target_Rep_Id | |
11396 | is | |
11397 | T_Id : Target_Rep_Id; | |
90e491a7 | 11398 | |
69e6ee2f HK |
11399 | begin |
11400 | T_Id := ETT_Map.Get (Entity_To_Target_Map, Id); | |
90e491a7 | 11401 | |
69e6ee2f HK |
11402 | -- The elaboration target lacks an internal representation. This |
11403 | -- indicates that the target is encountered for the first time. | |
11404 | -- Create the internal representation of it. | |
90e491a7 | 11405 | |
69e6ee2f HK |
11406 | if not Present (T_Id) then |
11407 | Target_Reps.Append (Create_Target_Rep (Id, In_State)); | |
11408 | T_Id := Target_Reps.Last; | |
90e491a7 | 11409 | |
69e6ee2f HK |
11410 | -- Associate the internal representation with the elaboration |
11411 | -- target. | |
90e491a7 | 11412 | |
69e6ee2f | 11413 | ETT_Map.Put (Entity_To_Target_Map, Id, T_Id); |
90e491a7 | 11414 | |
69e6ee2f HK |
11415 | -- The Processing phase is working with a partially analyzed tree, |
11416 | -- where various attributes become available as analysis continues. | |
11417 | -- This case arrises in the context of guaranteed ABE processing. | |
11418 | -- Update the existing representation by including new attributes. | |
90e491a7 | 11419 | |
69e6ee2f HK |
11420 | elsif In_State.Representation = Inconsistent_Representation then |
11421 | Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State); | |
90e491a7 | 11422 | |
69e6ee2f HK |
11423 | -- Otherwise the Processing phase imposes a particular representation |
11424 | -- version which is not satisfied by the target. This case arrises | |
11425 | -- when the Processing phase switches from guaranteed ABE checks and | |
11426 | -- diagnostics to some other mode of operation. Update the existing | |
11427 | -- representation to include all attributes. | |
90e491a7 | 11428 | |
69e6ee2f HK |
11429 | elsif In_State.Representation /= Version (T_Id) then |
11430 | Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State); | |
90e491a7 | 11431 | end if; |
90e491a7 | 11432 | |
69e6ee2f | 11433 | pragma Assert (Present (T_Id)); |
90e491a7 | 11434 | |
69e6ee2f HK |
11435 | return T_Id; |
11436 | end Target_Representation_Of; | |
90e491a7 | 11437 | |
69e6ee2f HK |
11438 | ------------------- |
11439 | -- To_Ghost_Mode -- | |
11440 | ------------------- | |
90e491a7 | 11441 | |
69e6ee2f HK |
11442 | function To_Ghost_Mode |
11443 | (Ignored_Status : Boolean) return Extended_Ghost_Mode | |
11444 | is | |
11445 | begin | |
11446 | if Ignored_Status then | |
11447 | return Is_Ignored; | |
11448 | else | |
11449 | return Is_Checked_Or_Not_Specified; | |
11450 | end if; | |
11451 | end To_Ghost_Mode; | |
2e60feb5 | 11452 | |
69e6ee2f HK |
11453 | ------------------- |
11454 | -- To_SPARK_Mode -- | |
11455 | ------------------- | |
2e60feb5 | 11456 | |
69e6ee2f HK |
11457 | function To_SPARK_Mode |
11458 | (On_Status : Boolean) return Extended_SPARK_Mode | |
11459 | is | |
11460 | begin | |
11461 | if On_Status then | |
11462 | return Is_On; | |
11463 | else | |
11464 | return Is_Off_Or_Not_Specified; | |
11465 | end if; | |
11466 | end To_SPARK_Mode; | |
2e60feb5 | 11467 | |
69e6ee2f HK |
11468 | ---------- |
11469 | -- Unit -- | |
11470 | ---------- | |
90e491a7 | 11471 | |
69e6ee2f HK |
11472 | function Unit (T_Id : Target_Rep_Id) return Entity_Id is |
11473 | pragma Assert (Present (T_Id)); | |
11474 | begin | |
11475 | return Target_Reps.Table (T_Id).Unit; | |
11476 | end Unit; | |
90e491a7 | 11477 | |
69e6ee2f HK |
11478 | -------------------------- |
11479 | -- Variable_Declaration -- | |
11480 | -------------------------- | |
90e491a7 | 11481 | |
69e6ee2f HK |
11482 | function Variable_Declaration (T_Id : Target_Rep_Id) return Node_Id is |
11483 | pragma Assert (Present (T_Id)); | |
11484 | pragma Assert (Kind (T_Id) = Variable_Target); | |
90e491a7 | 11485 | |
69e6ee2f HK |
11486 | begin |
11487 | return Target_Reps.Table (T_Id).Field_1; | |
11488 | end Variable_Declaration; | |
90e491a7 | 11489 | |
69e6ee2f HK |
11490 | ------------- |
11491 | -- Version -- | |
11492 | ------------- | |
90e491a7 | 11493 | |
69e6ee2f HK |
11494 | function Version (T_Id : Target_Rep_Id) return Representation_Kind is |
11495 | pragma Assert (Present (T_Id)); | |
11496 | begin | |
11497 | return Target_Reps.Table (T_Id).Version; | |
11498 | end Version; | |
11499 | end Internal_Representation; | |
90e491a7 | 11500 | |
69e6ee2f HK |
11501 | ---------------------- |
11502 | -- Invocation_Graph -- | |
11503 | ---------------------- | |
90e491a7 | 11504 | |
69e6ee2f | 11505 | package body Invocation_Graph is |
90e491a7 | 11506 | |
69e6ee2f HK |
11507 | ----------- |
11508 | -- Types -- | |
11509 | ----------- | |
90e491a7 | 11510 | |
69e6ee2f HK |
11511 | -- The following type represents simplified version of an invocation |
11512 | -- relation. | |
90e491a7 | 11513 | |
69e6ee2f HK |
11514 | type Invoker_Target_Relation is record |
11515 | Invoker : Entity_Id := Empty; | |
11516 | Target : Entity_Id := Empty; | |
11517 | end record; | |
90e491a7 | 11518 | |
69e6ee2f HK |
11519 | -- The following variables define the entities of the dummy elaboration |
11520 | -- procedures used as origins of library level paths. | |
90e491a7 | 11521 | |
69e6ee2f HK |
11522 | Elab_Body_Id : Entity_Id := Empty; |
11523 | Elab_Spec_Id : Entity_Id := Empty; | |
90e491a7 | 11524 | |
69e6ee2f HK |
11525 | --------------------- |
11526 | -- Data structures -- | |
11527 | --------------------- | |
90e491a7 | 11528 | |
69e6ee2f HK |
11529 | -- The following set contains all declared invocation constructs. It |
11530 | -- ensures that the same construct is not declared multiple times in | |
11531 | -- the ALI file of the main unit. | |
90e491a7 | 11532 | |
69e6ee2f | 11533 | Saved_Constructs_Set : NE_Set.Membership_Set := NE_Set.Nil; |
90e491a7 | 11534 | |
69e6ee2f HK |
11535 | function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type; |
11536 | -- Obtain the hash value of pair Key | |
90e491a7 | 11537 | |
69e6ee2f HK |
11538 | package IR_Set is new Membership_Sets |
11539 | (Element_Type => Invoker_Target_Relation, | |
11540 | "=" => "=", | |
11541 | Hash => Hash); | |
90e491a7 | 11542 | |
69e6ee2f HK |
11543 | -- The following set contains all recorded simple invocation relations. |
11544 | -- It ensures that multiple relations involving the same invoker and | |
11545 | -- target do not appear in the ALI file of the main unit. | |
90e491a7 | 11546 | |
69e6ee2f | 11547 | Saved_Relations_Set : IR_Set.Membership_Set := IR_Set.Nil; |
90e491a7 | 11548 | |
69e6ee2f HK |
11549 | -------------- |
11550 | -- Builders -- | |
11551 | -------------- | |
90e491a7 | 11552 | |
69e6ee2f HK |
11553 | function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id; |
11554 | pragma Inline (Signature_Of); | |
11555 | -- Obtain the invication signature id of arbitrary entity Id | |
90e491a7 | 11556 | |
69e6ee2f HK |
11557 | ----------------------- |
11558 | -- Local subprograms -- | |
11559 | ----------------------- | |
8dce7371 | 11560 | |
69e6ee2f HK |
11561 | procedure Build_Elaborate_Body_Procedure; |
11562 | pragma Inline (Build_Elaborate_Body_Procedure); | |
11563 | -- Create a dummy elaborate body procedure and store its entity in | |
11564 | -- Elab_Body_Id. | |
11565 | ||
11566 | procedure Build_Elaborate_Procedure | |
11567 | (Proc_Id : out Entity_Id; | |
11568 | Proc_Nam : Name_Id; | |
11569 | Loc : Source_Ptr); | |
11570 | pragma Inline (Build_Elaborate_Procedure); | |
11571 | -- Create a dummy elaborate procedure with name Proc_Nam and source | |
11572 | -- location Loc. The entity is returned in Proc_Id. | |
11573 | ||
11574 | procedure Build_Elaborate_Spec_Procedure; | |
11575 | pragma Inline (Build_Elaborate_Spec_Procedure); | |
11576 | -- Create a dummy elaborate spec procedure and store its entity in | |
11577 | -- Elab_Spec_Id. | |
11578 | ||
11579 | function Build_Subprogram_Invocation | |
11580 | (Subp_Id : Entity_Id) return Node_Id; | |
11581 | pragma Inline (Build_Subprogram_Invocation); | |
11582 | -- Create a dummy call marker that invokes subprogram Subp_Id | |
11583 | ||
11584 | function Build_Task_Activation | |
11585 | (Task_Typ : Entity_Id; | |
11586 | In_State : Processing_In_State) return Node_Id; | |
11587 | pragma Inline (Build_Task_Activation); | |
11588 | -- Create a dummy call marker that activates an anonymous task object of | |
11589 | -- type Task_Typ. | |
11590 | ||
11591 | procedure Declare_Invocation_Construct | |
11592 | (Constr_Id : Entity_Id; | |
11593 | In_State : Processing_In_State); | |
11594 | pragma Inline (Declare_Invocation_Construct); | |
11595 | -- Declare invocation construct Constr_Id by creating a declaration for | |
11596 | -- it in the ALI file of the main unit. In_State is the current state of | |
11597 | -- the Processing phase. | |
11598 | ||
11599 | function Invocation_Graph_Recording_OK return Boolean; | |
11600 | pragma Inline (Invocation_Graph_Recording_OK); | |
11601 | -- Determine whether the invocation graph can be recorded | |
11602 | ||
11603 | function Is_Invocation_Scenario (N : Node_Id) return Boolean; | |
11604 | pragma Inline (Is_Invocation_Scenario); | |
11605 | -- Determine whether node N is a suitable scenario for invocation graph | |
11606 | -- recording purposes. | |
11607 | ||
11608 | function Is_Invocation_Target (Id : Entity_Id) return Boolean; | |
11609 | pragma Inline (Is_Invocation_Target); | |
11610 | -- Determine whether arbitrary entity Id denotes an invocation target | |
11611 | ||
11612 | function Is_Saved_Construct (Constr : Entity_Id) return Boolean; | |
11613 | pragma Inline (Is_Saved_Construct); | |
11614 | -- Determine whether invocation construct Constr has already been | |
11615 | -- declared in the ALI file of the main unit. | |
11616 | ||
11617 | function Is_Saved_Relation | |
11618 | (Rel : Invoker_Target_Relation) return Boolean; | |
11619 | pragma Inline (Is_Saved_Relation); | |
11620 | -- Determine whether simple invocation relation Rel has already been | |
11621 | -- recorded in the ALI file of the main unit. | |
11622 | ||
11623 | procedure Process_Declarations | |
11624 | (Decls : List_Id; | |
11625 | In_State : Processing_In_State); | |
11626 | pragma Inline (Process_Declarations); | |
11627 | -- Process declaration list Decls by processing all invocation scenarios | |
11628 | -- within it. | |
11629 | ||
11630 | procedure Process_Freeze_Node | |
11631 | (Fnode : Node_Id; | |
11632 | In_State : Processing_In_State); | |
11633 | pragma Inline (Process_Freeze_Node); | |
11634 | -- Process freeze node Fnode by processing all invocation scenarios in | |
11635 | -- its Actions list. | |
11636 | ||
11637 | procedure Process_Invocation_Activation | |
11638 | (Call : Node_Id; | |
11639 | Call_Rep : Scenario_Rep_Id; | |
11640 | Obj_Id : Entity_Id; | |
11641 | Obj_Rep : Target_Rep_Id; | |
11642 | Task_Typ : Entity_Id; | |
11643 | Task_Rep : Target_Rep_Id; | |
11644 | In_State : Processing_In_State); | |
11645 | pragma Inline (Process_Invocation_Activation); | |
11646 | -- Process activation call Call which activates object Obj_Id of task | |
11647 | -- type Task_Typ by processing all invocation scenarios within the task | |
11648 | -- body. Call_Rep is the representation of the call. Obj_Rep denotes the | |
11649 | -- representation of the object. Task_Rep is the representation of the | |
11650 | -- task type. In_State is the current state of the Processing phase. | |
11651 | ||
11652 | procedure Process_Invocation_Body_Scenarios; | |
11653 | pragma Inline (Process_Invocation_Body_Scenarios); | |
11654 | -- Process all library level body scenarios | |
11655 | ||
11656 | procedure Process_Invocation_Call | |
11657 | (Call : Node_Id; | |
11658 | Call_Rep : Scenario_Rep_Id; | |
11659 | In_State : Processing_In_State); | |
11660 | pragma Inline (Process_Invocation_Call); | |
11661 | -- Process invocation call scenario Call with representation Call_Rep. | |
11662 | -- In_State is the current state of the Processing phase. | |
11663 | ||
3eb5e54a HK |
11664 | procedure Process_Invocation_Instantiation |
11665 | (Inst : Node_Id; | |
11666 | Inst_Rep : Scenario_Rep_Id; | |
11667 | In_State : Processing_In_State); | |
11668 | pragma Inline (Process_Invocation_Instantiation); | |
11669 | -- Process invocation instantiation scenario Inst with representation | |
11670 | -- Inst_Rep. In_State is the current state of the Processing phase. | |
11671 | ||
69e6ee2f HK |
11672 | procedure Process_Invocation_Scenario |
11673 | (N : Node_Id; | |
11674 | In_State : Processing_In_State); | |
11675 | pragma Inline (Process_Invocation_Scenario); | |
11676 | -- Process single invocation scenario N. In_State is the current state | |
11677 | -- of the Processing phase. | |
11678 | ||
11679 | procedure Process_Invocation_Scenarios | |
11680 | (Iter : in out NE_Set.Iterator; | |
11681 | In_State : Processing_In_State); | |
11682 | pragma Inline (Process_Invocation_Scenarios); | |
11683 | -- Process all invocation scenarios obtained via iterator Iter. In_State | |
11684 | -- is the current state of the Processing phase. | |
11685 | ||
11686 | procedure Process_Invocation_Spec_Scenarios; | |
11687 | pragma Inline (Process_Invocation_Spec_Scenarios); | |
11688 | -- Process all library level spec scenarios | |
11689 | ||
11690 | procedure Process_Main_Unit; | |
11691 | pragma Inline (Process_Main_Unit); | |
11692 | -- Process all invocation scenarios within the main unit | |
11693 | ||
11694 | procedure Process_Package_Declaration | |
11695 | (Pack_Decl : Node_Id; | |
11696 | In_State : Processing_In_State); | |
11697 | pragma Inline (Process_Package_Declaration); | |
11698 | -- Process package declaration Pack_Decl by processing all invocation | |
11699 | -- scenarios in its visible and private declarations. If the main unit | |
11700 | -- contains a generic, the declarations of the body are also examined. | |
11701 | -- In_State is the current state of the Processing phase. | |
11702 | ||
11703 | procedure Process_Protected_Type_Declaration | |
11704 | (Prot_Decl : Node_Id; | |
11705 | In_State : Processing_In_State); | |
11706 | pragma Inline (Process_Protected_Type_Declaration); | |
11707 | -- Process the declarations of protected type Prot_Decl. In_State is the | |
11708 | -- current state of the Processing phase. | |
11709 | ||
11710 | procedure Process_Subprogram_Declaration | |
11711 | (Subp_Decl : Node_Id; | |
11712 | In_State : Processing_In_State); | |
11713 | pragma Inline (Process_Subprogram_Declaration); | |
11714 | -- Process subprogram declaration Subp_Decl by processing all invocation | |
11715 | -- scenarios within its body. In_State denotes the current state of the | |
11716 | -- Processing phase. | |
11717 | ||
11718 | procedure Process_Subprogram_Instantiation | |
11719 | (Inst : Node_Id; | |
11720 | In_State : Processing_In_State); | |
11721 | pragma Inline (Process_Subprogram_Instantiation); | |
11722 | -- Process subprogram instantiation Inst. In_State is the current state | |
11723 | -- of the Processing phase. | |
11724 | ||
11725 | procedure Process_Task_Type_Declaration | |
11726 | (Task_Decl : Node_Id; | |
11727 | In_State : Processing_In_State); | |
11728 | pragma Inline (Process_Task_Type_Declaration); | |
11729 | -- Process task declaration Task_Decl by processing all invocation | |
11730 | -- scenarios within its body. In_State is the current state of the | |
11731 | -- Processing phase. | |
11732 | ||
11733 | procedure Record_Full_Invocation_Path (In_State : Processing_In_State); | |
11734 | pragma Inline (Record_Full_Invocation_Path); | |
11735 | -- Record all relations between scenario pairs found in the stack of | |
11736 | -- active scenarios. In_State is the current state of the Processing | |
11737 | -- phase. | |
11738 | ||
9795b203 HK |
11739 | procedure Record_Invocation_Graph_Encoding; |
11740 | pragma Inline (Record_Invocation_Graph_Encoding); | |
11741 | -- Record the encoding format used to capture information related to | |
11742 | -- invocation constructs and relations. | |
11743 | ||
69e6ee2f HK |
11744 | procedure Record_Invocation_Path (In_State : Processing_In_State); |
11745 | pragma Inline (Record_Invocation_Path); | |
11746 | -- Record the invocation relations found within the path represented in | |
11747 | -- the active scenario stack. In_State denotes the current state of the | |
11748 | -- Processing phase. | |
11749 | ||
11750 | procedure Record_Simple_Invocation_Path (In_State : Processing_In_State); | |
11751 | pragma Inline (Record_Simple_Invocation_Path); | |
11752 | -- Record a single relation from the start to the end of the stack of | |
11753 | -- active scenarios. In_State is the current state of the Processing | |
11754 | -- phase. | |
11755 | ||
11756 | procedure Record_Invocation_Relation | |
11757 | (Invk_Id : Entity_Id; | |
11758 | Targ_Id : Entity_Id; | |
11759 | In_State : Processing_In_State); | |
11760 | pragma Inline (Record_Invocation_Relation); | |
11761 | -- Record an invocation relation with invoker Invk_Id and target Targ_Id | |
11762 | -- by creating an entry for it in the ALI file of the main unit. Formal | |
11763 | -- In_State denotes the current state of the Processing phase. | |
11764 | ||
11765 | procedure Set_Is_Saved_Construct | |
11766 | (Constr : Entity_Id; | |
11767 | Val : Boolean := True); | |
11768 | pragma Inline (Set_Is_Saved_Construct); | |
11769 | -- Mark invocation construct Constr as declared in the ALI file of the | |
11770 | -- main unit depending on value Val. | |
11771 | ||
11772 | procedure Set_Is_Saved_Relation | |
11773 | (Rel : Invoker_Target_Relation; | |
11774 | Val : Boolean := True); | |
11775 | pragma Inline (Set_Is_Saved_Relation); | |
11776 | -- Mark simple invocation relation Rel as recorded in the ALI file of | |
11777 | -- the main unit depending on value Val. | |
11778 | ||
11779 | function Target_Of | |
11780 | (Pos : Active_Scenario_Pos; | |
11781 | In_State : Processing_In_State) return Entity_Id; | |
11782 | pragma Inline (Target_Of); | |
11783 | -- Given position within the active scenario stack Pos, obtain the | |
11784 | -- target of the indicated scenario. In_State is the current state | |
11785 | -- of the Processing phase. | |
11786 | ||
11787 | procedure Traverse_Invocation_Body | |
11788 | (N : Node_Id; | |
11789 | In_State : Processing_In_State); | |
11790 | pragma Inline (Traverse_Invocation_Body); | |
11791 | -- Traverse subprogram body N looking for suitable invocation scenarios | |
11792 | -- that need to be processed for invocation graph recording purposes. | |
11793 | -- In_State is the current state of the Processing phase. | |
11794 | ||
11795 | procedure Write_Invocation_Path (In_State : Processing_In_State); | |
11796 | pragma Inline (Write_Invocation_Path); | |
11797 | -- Write out a path represented by the active scenario on the stack to | |
11798 | -- standard output. In_State denotes the current state of the Processing | |
11799 | -- phase. | |
8dce7371 | 11800 | |
69e6ee2f HK |
11801 | ------------------------------------ |
11802 | -- Build_Elaborate_Body_Procedure -- | |
11803 | ------------------------------------ | |
8dce7371 | 11804 | |
69e6ee2f HK |
11805 | procedure Build_Elaborate_Body_Procedure is |
11806 | Body_Decl : Node_Id; | |
11807 | Spec_Decl : Node_Id; | |
c23f55b4 | 11808 | |
69e6ee2f HK |
11809 | begin |
11810 | -- Nothing to do when a previous call already created the procedure | |
8dce7371 | 11811 | |
69e6ee2f HK |
11812 | if Present (Elab_Body_Id) then |
11813 | return; | |
11814 | end if; | |
c23f55b4 | 11815 | |
69e6ee2f | 11816 | Spec_And_Body_From_Entity |
3eb5e54a | 11817 | (Id => Main_Unit_Entity, |
69e6ee2f HK |
11818 | Body_Decl => Body_Decl, |
11819 | Spec_Decl => Spec_Decl); | |
90e491a7 | 11820 | |
69e6ee2f | 11821 | pragma Assert (Present (Body_Decl)); |
90e491a7 | 11822 | |
69e6ee2f HK |
11823 | Build_Elaborate_Procedure |
11824 | (Proc_Id => Elab_Body_Id, | |
11825 | Proc_Nam => Name_B, | |
11826 | Loc => Sloc (Body_Decl)); | |
11827 | end Build_Elaborate_Body_Procedure; | |
90e491a7 | 11828 | |
69e6ee2f HK |
11829 | ------------------------------- |
11830 | -- Build_Elaborate_Procedure -- | |
11831 | ------------------------------- | |
90e491a7 | 11832 | |
69e6ee2f HK |
11833 | procedure Build_Elaborate_Procedure |
11834 | (Proc_Id : out Entity_Id; | |
11835 | Proc_Nam : Name_Id; | |
11836 | Loc : Source_Ptr) | |
11837 | is | |
11838 | Proc_Decl : Node_Id; | |
11839 | pragma Unreferenced (Proc_Decl); | |
90e491a7 | 11840 | |
69e6ee2f HK |
11841 | begin |
11842 | Proc_Id := Make_Defining_Identifier (Loc, Proc_Nam); | |
90e491a7 | 11843 | |
69e6ee2f HK |
11844 | -- Partially decorate the elaboration procedure because it will not |
11845 | -- be insertred into the tree and analyzed. | |
90e491a7 | 11846 | |
69e6ee2f HK |
11847 | Set_Ekind (Proc_Id, E_Procedure); |
11848 | Set_Etype (Proc_Id, Standard_Void_Type); | |
3eb5e54a | 11849 | Set_Scope (Proc_Id, Unique_Entity (Main_Unit_Entity)); |
90e491a7 | 11850 | |
69e6ee2f HK |
11851 | -- Create a dummy declaration for the elaboration procedure. The |
11852 | -- declaration does not need to be syntactically legal, but must | |
11853 | -- carry an accurate source location. | |
90e491a7 | 11854 | |
69e6ee2f HK |
11855 | Proc_Decl := |
11856 | Make_Subprogram_Body (Loc, | |
11857 | Specification => | |
11858 | Make_Procedure_Specification (Loc, | |
11859 | Defining_Unit_Name => Proc_Id), | |
11860 | Declarations => No_List, | |
11861 | Handled_Statement_Sequence => Empty); | |
11862 | end Build_Elaborate_Procedure; | |
90e491a7 | 11863 | |
69e6ee2f HK |
11864 | ------------------------------------ |
11865 | -- Build_Elaborate_Spec_Procedure -- | |
11866 | ------------------------------------ | |
90e491a7 | 11867 | |
69e6ee2f HK |
11868 | procedure Build_Elaborate_Spec_Procedure is |
11869 | Body_Decl : Node_Id; | |
11870 | Spec_Decl : Node_Id; | |
90e491a7 | 11871 | |
69e6ee2f HK |
11872 | begin |
11873 | -- Nothing to do when a previous call already created the procedure | |
90e491a7 | 11874 | |
69e6ee2f HK |
11875 | if Present (Elab_Spec_Id) then |
11876 | return; | |
11877 | end if; | |
90e491a7 | 11878 | |
69e6ee2f | 11879 | Spec_And_Body_From_Entity |
3eb5e54a | 11880 | (Id => Main_Unit_Entity, |
69e6ee2f HK |
11881 | Body_Decl => Body_Decl, |
11882 | Spec_Decl => Spec_Decl); | |
90e491a7 | 11883 | |
69e6ee2f | 11884 | pragma Assert (Present (Spec_Decl)); |
90e491a7 | 11885 | |
69e6ee2f HK |
11886 | Build_Elaborate_Procedure |
11887 | (Proc_Id => Elab_Spec_Id, | |
11888 | Proc_Nam => Name_S, | |
11889 | Loc => Sloc (Spec_Decl)); | |
11890 | end Build_Elaborate_Spec_Procedure; | |
90e491a7 | 11891 | |
69e6ee2f HK |
11892 | --------------------------------- |
11893 | -- Build_Subprogram_Invocation -- | |
11894 | --------------------------------- | |
90e491a7 | 11895 | |
69e6ee2f HK |
11896 | function Build_Subprogram_Invocation |
11897 | (Subp_Id : Entity_Id) return Node_Id | |
11898 | is | |
11899 | Marker : constant Node_Id := Make_Call_Marker (Sloc (Subp_Id)); | |
11900 | Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); | |
90e491a7 | 11901 | |
69e6ee2f HK |
11902 | begin |
11903 | -- Create a dummy call marker which invokes the subprogram | |
90e491a7 | 11904 | |
69e6ee2f HK |
11905 | Set_Is_Declaration_Level_Node (Marker, False); |
11906 | Set_Is_Dispatching_Call (Marker, False); | |
11907 | Set_Is_Elaboration_Checks_OK_Node (Marker, False); | |
11908 | Set_Is_Elaboration_Warnings_OK_Node (Marker, False); | |
11909 | Set_Is_Ignored_Ghost_Node (Marker, False); | |
11910 | Set_Is_Source_Call (Marker, False); | |
11911 | Set_Is_SPARK_Mode_On_Node (Marker, False); | |
90e491a7 | 11912 | |
69e6ee2f | 11913 | -- Invoke the uniform canonical entity of the subprogram |
90e491a7 | 11914 | |
69e6ee2f | 11915 | Set_Target (Marker, Canonical_Subprogram (Subp_Id)); |
90e491a7 | 11916 | |
69e6ee2f | 11917 | -- Partially insert the marker into the tree |
90e491a7 | 11918 | |
69e6ee2f | 11919 | Set_Parent (Marker, Parent (Subp_Decl)); |
90e491a7 | 11920 | |
69e6ee2f HK |
11921 | return Marker; |
11922 | end Build_Subprogram_Invocation; | |
90e491a7 | 11923 | |
69e6ee2f HK |
11924 | --------------------------- |
11925 | -- Build_Task_Activation -- | |
11926 | --------------------------- | |
90e491a7 | 11927 | |
69e6ee2f HK |
11928 | function Build_Task_Activation |
11929 | (Task_Typ : Entity_Id; | |
11930 | In_State : Processing_In_State) return Node_Id | |
11931 | is | |
11932 | Loc : constant Source_Ptr := Sloc (Task_Typ); | |
11933 | Marker : constant Node_Id := Make_Call_Marker (Loc); | |
11934 | Task_Decl : constant Node_Id := Unit_Declaration_Node (Task_Typ); | |
996ae0b0 | 11935 | |
69e6ee2f HK |
11936 | Activ_Id : Entity_Id; |
11937 | Marker_Rep_Id : Scenario_Rep_Id; | |
11938 | Task_Obj : Entity_Id; | |
11939 | Task_Objs : NE_List.Doubly_Linked_List; | |
996ae0b0 | 11940 | |
69e6ee2f HK |
11941 | begin |
11942 | -- Create a dummy call marker which activates some tasks | |
996ae0b0 | 11943 | |
69e6ee2f HK |
11944 | Set_Is_Declaration_Level_Node (Marker, False); |
11945 | Set_Is_Dispatching_Call (Marker, False); | |
11946 | Set_Is_Elaboration_Checks_OK_Node (Marker, False); | |
11947 | Set_Is_Elaboration_Warnings_OK_Node (Marker, False); | |
11948 | Set_Is_Ignored_Ghost_Node (Marker, False); | |
11949 | Set_Is_Source_Call (Marker, False); | |
11950 | Set_Is_SPARK_Mode_On_Node (Marker, False); | |
a6d25cad | 11951 | |
69e6ee2f | 11952 | -- Invoke the appropriate version of Activate_Tasks |
a6d25cad | 11953 | |
69e6ee2f HK |
11954 | if Restricted_Profile then |
11955 | Activ_Id := RTE (RE_Activate_Restricted_Tasks); | |
11956 | else | |
11957 | Activ_Id := RTE (RE_Activate_Tasks); | |
11958 | end if; | |
a6d25cad | 11959 | |
69e6ee2f | 11960 | Set_Target (Marker, Activ_Id); |
996ae0b0 | 11961 | |
69e6ee2f | 11962 | -- Partially insert the marker into the tree |
f192ca5e | 11963 | |
69e6ee2f | 11964 | Set_Parent (Marker, Parent (Task_Decl)); |
996ae0b0 | 11965 | |
69e6ee2f HK |
11966 | -- Create a dummy task object. Partially decorate the object because |
11967 | -- it will not be inserted into the tree and analyzed. | |
f192ca5e | 11968 | |
69e6ee2f HK |
11969 | Task_Obj := Make_Temporary (Loc, 'T'); |
11970 | Set_Ekind (Task_Obj, E_Variable); | |
11971 | Set_Etype (Task_Obj, Task_Typ); | |
f192ca5e | 11972 | |
69e6ee2f | 11973 | -- Associate the dummy task object with the activation call |
f192ca5e | 11974 | |
69e6ee2f HK |
11975 | Task_Objs := NE_List.Create; |
11976 | NE_List.Append (Task_Objs, Task_Obj); | |
f192ca5e | 11977 | |
69e6ee2f HK |
11978 | Marker_Rep_Id := Scenario_Representation_Of (Marker, In_State); |
11979 | Set_Activated_Task_Objects (Marker_Rep_Id, Task_Objs); | |
11980 | Set_Activated_Task_Type (Marker_Rep_Id, Task_Typ); | |
996ae0b0 | 11981 | |
69e6ee2f HK |
11982 | return Marker; |
11983 | end Build_Task_Activation; | |
996ae0b0 | 11984 | |
69e6ee2f HK |
11985 | ---------------------------------- |
11986 | -- Declare_Invocation_Construct -- | |
11987 | ---------------------------------- | |
996ae0b0 | 11988 | |
69e6ee2f HK |
11989 | procedure Declare_Invocation_Construct |
11990 | (Constr_Id : Entity_Id; | |
11991 | In_State : Processing_In_State) | |
11992 | is | |
9795b203 HK |
11993 | function Body_Placement_Of |
11994 | (Id : Entity_Id) return Declaration_Placement_Kind; | |
11995 | pragma Inline (Body_Placement_Of); | |
11996 | -- Obtain the placement of arbitrary entity Id's body | |
11997 | ||
11998 | function Declaration_Placement_Of_Node | |
11999 | (N : Node_Id) return Declaration_Placement_Kind; | |
12000 | pragma Inline (Declaration_Placement_Of_Node); | |
12001 | -- Obtain the placement of arbitrary node N | |
12002 | ||
69e6ee2f HK |
12003 | function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind; |
12004 | pragma Inline (Kind_Of); | |
12005 | -- Obtain the invocation construct kind of arbitrary entity Id | |
996ae0b0 | 12006 | |
9795b203 HK |
12007 | function Spec_Placement_Of |
12008 | (Id : Entity_Id) return Declaration_Placement_Kind; | |
12009 | pragma Inline (Spec_Placement_Of); | |
12010 | -- Obtain the placement of arbitrary entity Id's spec | |
996ae0b0 | 12011 | |
9795b203 HK |
12012 | ----------------------- |
12013 | -- Body_Placement_Of -- | |
12014 | ----------------------- | |
996ae0b0 | 12015 | |
9795b203 HK |
12016 | function Body_Placement_Of |
12017 | (Id : Entity_Id) return Declaration_Placement_Kind | |
12018 | is | |
69e6ee2f HK |
12019 | Id_Rep : constant Target_Rep_Id := |
12020 | Target_Representation_Of (Id, In_State); | |
12021 | Body_Decl : constant Node_Id := Body_Declaration (Id_Rep); | |
12022 | Spec_Decl : constant Node_Id := Spec_Declaration (Id_Rep); | |
07fc65c4 | 12023 | |
69e6ee2f HK |
12024 | begin |
12025 | -- The entity has a body | |
3640a4e7 | 12026 | |
69e6ee2f | 12027 | if Present (Body_Decl) then |
9795b203 | 12028 | return Declaration_Placement_Of_Node (Body_Decl); |
3640a4e7 | 12029 | |
69e6ee2f | 12030 | -- Otherwise the entity must have a spec |
bde33286 | 12031 | |
69e6ee2f HK |
12032 | else |
12033 | pragma Assert (Present (Spec_Decl)); | |
9795b203 | 12034 | return Declaration_Placement_Of_Node (Spec_Decl); |
69e6ee2f | 12035 | end if; |
9795b203 | 12036 | end Body_Placement_Of; |
3640a4e7 | 12037 | |
9795b203 HK |
12038 | ----------------------------------- |
12039 | -- Declaration_Placement_Of_Node -- | |
12040 | ----------------------------------- | |
3640a4e7 | 12041 | |
9795b203 HK |
12042 | function Declaration_Placement_Of_Node |
12043 | (N : Node_Id) return Declaration_Placement_Kind | |
12044 | is | |
3eb5e54a | 12045 | Main_Unit_Id : constant Entity_Id := Main_Unit_Entity; |
69e6ee2f | 12046 | N_Unit_Id : constant Entity_Id := Find_Top_Unit (N); |
3640a4e7 | 12047 | |
69e6ee2f HK |
12048 | begin |
12049 | -- The node is in the main unit, its placement depends on the main | |
12050 | -- unit kind. | |
3640a4e7 | 12051 | |
69e6ee2f | 12052 | if N_Unit_Id = Main_Unit_Id then |
3640a4e7 | 12053 | |
69e6ee2f | 12054 | -- The main unit is a body |
3640a4e7 | 12055 | |
69e6ee2f HK |
12056 | if Ekind_In (Main_Unit_Id, E_Package_Body, |
12057 | E_Subprogram_Body) | |
12058 | then | |
12059 | return In_Body; | |
3640a4e7 | 12060 | |
69e6ee2f | 12061 | -- The main unit is a stand-alone subprogram body |
3640a4e7 | 12062 | |
69e6ee2f HK |
12063 | elsif Ekind_In (Main_Unit_Id, E_Function, E_Procedure) |
12064 | and then Nkind (Unit_Declaration_Node (Main_Unit_Id)) = | |
12065 | N_Subprogram_Body | |
12066 | then | |
12067 | return In_Body; | |
3640a4e7 | 12068 | |
69e6ee2f | 12069 | -- Otherwise the main unit is a spec |
8dce7371 | 12070 | |
69e6ee2f HK |
12071 | else |
12072 | return In_Spec; | |
12073 | end if; | |
90e491a7 | 12074 | |
69e6ee2f HK |
12075 | -- Otherwise the node is in the complementary unit of the main |
12076 | -- unit. The main unit is a body, the node is in the spec. | |
8dce7371 | 12077 | |
69e6ee2f HK |
12078 | elsif Ekind_In (Main_Unit_Id, E_Package_Body, |
12079 | E_Subprogram_Body) | |
12080 | then | |
12081 | return In_Spec; | |
8dce7371 | 12082 | |
69e6ee2f | 12083 | -- The main unit is a spec, the node is in the body |
8dce7371 | 12084 | |
69e6ee2f HK |
12085 | else |
12086 | return In_Body; | |
12087 | end if; | |
9795b203 | 12088 | end Declaration_Placement_Of_Node; |
8dce7371 | 12089 | |
9795b203 HK |
12090 | ------------- |
12091 | -- Kind_Of -- | |
12092 | ------------- | |
12093 | ||
12094 | function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind is | |
12095 | begin | |
12096 | if Id = Elab_Body_Id then | |
12097 | return Elaborate_Body_Procedure; | |
12098 | ||
12099 | elsif Id = Elab_Spec_Id then | |
12100 | return Elaborate_Spec_Procedure; | |
12101 | ||
12102 | else | |
12103 | return Regular_Construct; | |
12104 | end if; | |
12105 | end Kind_Of; | |
8dce7371 | 12106 | |
9795b203 HK |
12107 | ----------------------- |
12108 | -- Spec_Placement_Of -- | |
12109 | ----------------------- | |
12110 | ||
12111 | function Spec_Placement_Of | |
12112 | (Id : Entity_Id) return Declaration_Placement_Kind | |
12113 | is | |
12114 | Id_Rep : constant Target_Rep_Id := | |
12115 | Target_Representation_Of (Id, In_State); | |
12116 | Body_Decl : constant Node_Id := Body_Declaration (Id_Rep); | |
12117 | Spec_Decl : constant Node_Id := Spec_Declaration (Id_Rep); | |
12118 | ||
12119 | begin | |
12120 | -- The entity has a spec | |
12121 | ||
12122 | if Present (Spec_Decl) then | |
12123 | return Declaration_Placement_Of_Node (Spec_Decl); | |
12124 | ||
12125 | -- Otherwise the entity must have a body | |
12126 | ||
12127 | else | |
12128 | pragma Assert (Present (Body_Decl)); | |
12129 | return Declaration_Placement_Of_Node (Body_Decl); | |
12130 | end if; | |
12131 | end Spec_Placement_Of; | |
8dce7371 | 12132 | |
69e6ee2f | 12133 | -- Start of processing for Declare_Invocation_Construct |
8dce7371 | 12134 | |
69e6ee2f HK |
12135 | begin |
12136 | -- Nothing to do when the construct has already been declared in the | |
12137 | -- ALI file. | |
8dce7371 | 12138 | |
69e6ee2f HK |
12139 | if Is_Saved_Construct (Constr_Id) then |
12140 | return; | |
12141 | end if; | |
8dce7371 | 12142 | |
69e6ee2f | 12143 | -- Mark the construct as declared in the ALI file |
8dce7371 | 12144 | |
69e6ee2f | 12145 | Set_Is_Saved_Construct (Constr_Id); |
8dce7371 | 12146 | |
69e6ee2f | 12147 | -- Add the construct in the ALI file |
8dce7371 | 12148 | |
69e6ee2f | 12149 | Add_Invocation_Construct |
9795b203 HK |
12150 | (Body_Placement => Body_Placement_Of (Constr_Id), |
12151 | Kind => Kind_Of (Constr_Id), | |
12152 | Signature => Signature_Of (Constr_Id), | |
12153 | Spec_Placement => Spec_Placement_Of (Constr_Id), | |
12154 | Update_Units => False); | |
69e6ee2f | 12155 | end Declare_Invocation_Construct; |
8dce7371 | 12156 | |
69e6ee2f HK |
12157 | ------------------------------- |
12158 | -- Finalize_Invocation_Graph -- | |
12159 | ------------------------------- | |
8dce7371 | 12160 | |
69e6ee2f HK |
12161 | procedure Finalize_Invocation_Graph is |
12162 | begin | |
12163 | NE_Set.Destroy (Saved_Constructs_Set); | |
12164 | IR_Set.Destroy (Saved_Relations_Set); | |
12165 | end Finalize_Invocation_Graph; | |
8dce7371 | 12166 | |
69e6ee2f HK |
12167 | ---------- |
12168 | -- Hash -- | |
12169 | ---------- | |
90e491a7 | 12170 | |
69e6ee2f HK |
12171 | function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type is |
12172 | pragma Assert (Present (Key.Invoker)); | |
12173 | pragma Assert (Present (Key.Target)); | |
3640a4e7 | 12174 | |
69e6ee2f HK |
12175 | begin |
12176 | return | |
12177 | Hash_Two_Keys | |
12178 | (Bucket_Range_Type (Key.Invoker), | |
12179 | Bucket_Range_Type (Key.Target)); | |
12180 | end Hash; | |
f192ca5e | 12181 | |
69e6ee2f HK |
12182 | --------------------------------- |
12183 | -- Initialize_Invocation_Graph -- | |
12184 | --------------------------------- | |
3640a4e7 | 12185 | |
69e6ee2f HK |
12186 | procedure Initialize_Invocation_Graph is |
12187 | begin | |
12188 | Saved_Constructs_Set := NE_Set.Create (100); | |
12189 | Saved_Relations_Set := IR_Set.Create (200); | |
12190 | end Initialize_Invocation_Graph; | |
f192ca5e | 12191 | |
69e6ee2f HK |
12192 | ----------------------------------- |
12193 | -- Invocation_Graph_Recording_OK -- | |
12194 | ----------------------------------- | |
f192ca5e | 12195 | |
69e6ee2f HK |
12196 | function Invocation_Graph_Recording_OK return Boolean is |
12197 | Main_Cunit : constant Node_Id := Cunit (Main_Unit); | |
bde33286 | 12198 | |
69e6ee2f | 12199 | begin |
69e6ee2f HK |
12200 | -- Nothing to do when compiling for GNATprove because the invocation |
12201 | -- graph is not needed. | |
a5abb241 | 12202 | |
16cc65b6 | 12203 | if GNATprove_Mode then |
69e6ee2f | 12204 | return False; |
ed3fe8cc | 12205 | |
69e6ee2f | 12206 | -- Nothing to do when the compilation will not produce an ALI file |
90e491a7 | 12207 | |
69e6ee2f HK |
12208 | elsif Serious_Errors_Detected > 0 then |
12209 | return False; | |
90e491a7 | 12210 | |
69e6ee2f HK |
12211 | -- Nothing to do when the main unit requires a body. Processing the |
12212 | -- completing body will create the ALI file for the unit and record | |
12213 | -- the invocation graph. | |
ed3fe8cc | 12214 | |
69e6ee2f HK |
12215 | elsif Body_Required (Main_Cunit) then |
12216 | return False; | |
12217 | end if; | |
bde33286 | 12218 | |
69e6ee2f HK |
12219 | return True; |
12220 | end Invocation_Graph_Recording_OK; | |
bde33286 | 12221 | |
69e6ee2f HK |
12222 | ---------------------------- |
12223 | -- Is_Invocation_Scenario -- | |
12224 | ---------------------------- | |
bde33286 | 12225 | |
69e6ee2f HK |
12226 | function Is_Invocation_Scenario (N : Node_Id) return Boolean is |
12227 | begin | |
12228 | return | |
12229 | Is_Suitable_Access_Taken (N) | |
12230 | or else Is_Suitable_Call (N) | |
12231 | or else Is_Suitable_Instantiation (N); | |
12232 | end Is_Invocation_Scenario; | |
bde33286 | 12233 | |
69e6ee2f HK |
12234 | -------------------------- |
12235 | -- Is_Invocation_Target -- | |
12236 | -------------------------- | |
bde33286 | 12237 | |
69e6ee2f HK |
12238 | function Is_Invocation_Target (Id : Entity_Id) return Boolean is |
12239 | begin | |
12240 | -- To qualify, the entity must either come from source, or denote an | |
12241 | -- Ada, bridge, or SPARK target. | |
3640a4e7 | 12242 | |
69e6ee2f HK |
12243 | return |
12244 | Comes_From_Source (Id) | |
12245 | or else Is_Ada_Semantic_Target (Id) | |
12246 | or else Is_Bridge_Target (Id) | |
12247 | or else Is_SPARK_Semantic_Target (Id); | |
12248 | end Is_Invocation_Target; | |
12249 | ||
12250 | ------------------------ | |
12251 | -- Is_Saved_Construct -- | |
12252 | ------------------------ | |
12253 | ||
12254 | function Is_Saved_Construct (Constr : Entity_Id) return Boolean is | |
12255 | pragma Assert (Present (Constr)); | |
12256 | begin | |
12257 | return NE_Set.Contains (Saved_Constructs_Set, Constr); | |
12258 | end Is_Saved_Construct; | |
3640a4e7 | 12259 | |
69e6ee2f HK |
12260 | ----------------------- |
12261 | -- Is_Saved_Relation -- | |
12262 | ----------------------- | |
bde33286 | 12263 | |
69e6ee2f HK |
12264 | function Is_Saved_Relation |
12265 | (Rel : Invoker_Target_Relation) return Boolean | |
12266 | is | |
12267 | pragma Assert (Present (Rel.Invoker)); | |
12268 | pragma Assert (Present (Rel.Target)); | |
bde33286 | 12269 | |
69e6ee2f HK |
12270 | begin |
12271 | return IR_Set.Contains (Saved_Relations_Set, Rel); | |
12272 | end Is_Saved_Relation; | |
519e9fdf | 12273 | |
69e6ee2f HK |
12274 | -------------------------- |
12275 | -- Process_Declarations -- | |
12276 | -------------------------- | |
519e9fdf | 12277 | |
69e6ee2f HK |
12278 | procedure Process_Declarations |
12279 | (Decls : List_Id; | |
12280 | In_State : Processing_In_State) | |
12281 | is | |
12282 | Decl : Node_Id; | |
519e9fdf | 12283 | |
69e6ee2f HK |
12284 | begin |
12285 | Decl := First (Decls); | |
12286 | while Present (Decl) loop | |
519e9fdf | 12287 | |
69e6ee2f | 12288 | -- Freeze node |
519e9fdf | 12289 | |
69e6ee2f HK |
12290 | if Nkind (Decl) = N_Freeze_Entity then |
12291 | Process_Freeze_Node | |
12292 | (Fnode => Decl, | |
12293 | In_State => In_State); | |
ab01e614 | 12294 | |
69e6ee2f | 12295 | -- Package (nested) |
ab01e614 | 12296 | |
69e6ee2f HK |
12297 | elsif Nkind (Decl) = N_Package_Declaration then |
12298 | Process_Package_Declaration | |
12299 | (Pack_Decl => Decl, | |
12300 | In_State => In_State); | |
c8d3b4ff | 12301 | |
69e6ee2f | 12302 | -- Protected type |
996ae0b0 | 12303 | |
69e6ee2f HK |
12304 | elsif Nkind_In (Decl, N_Protected_Type_Declaration, |
12305 | N_Single_Protected_Declaration) | |
12306 | then | |
12307 | Process_Protected_Type_Declaration | |
12308 | (Prot_Decl => Decl, | |
12309 | In_State => In_State); | |
de4899bb | 12310 | |
69e6ee2f | 12311 | -- Subprogram or entry |
0c9849e1 | 12312 | |
69e6ee2f HK |
12313 | elsif Nkind_In (Decl, N_Entry_Declaration, |
12314 | N_Subprogram_Declaration) | |
12315 | then | |
12316 | Process_Subprogram_Declaration | |
12317 | (Subp_Decl => Decl, | |
12318 | In_State => In_State); | |
0c9849e1 | 12319 | |
69e6ee2f | 12320 | -- Subprogram body (stand alone) |
0c9849e1 | 12321 | |
69e6ee2f HK |
12322 | elsif Nkind (Decl) = N_Subprogram_Body |
12323 | and then No (Corresponding_Spec (Decl)) | |
12324 | then | |
12325 | Process_Subprogram_Declaration | |
12326 | (Subp_Decl => Decl, | |
12327 | In_State => In_State); | |
0c9849e1 | 12328 | |
69e6ee2f | 12329 | -- Subprogram instantiation |
0c9849e1 | 12330 | |
69e6ee2f HK |
12331 | elsif Nkind (Decl) in N_Subprogram_Instantiation then |
12332 | Process_Subprogram_Instantiation | |
12333 | (Inst => Decl, | |
12334 | In_State => In_State); | |
0c9849e1 | 12335 | |
69e6ee2f | 12336 | -- Task type |
996ae0b0 | 12337 | |
69e6ee2f HK |
12338 | elsif Nkind_In (Decl, N_Single_Task_Declaration, |
12339 | N_Task_Type_Declaration) | |
12340 | then | |
12341 | Process_Task_Type_Declaration | |
12342 | (Task_Decl => Decl, | |
12343 | In_State => In_State); | |
996ae0b0 | 12344 | |
69e6ee2f | 12345 | -- Task type (derived) |
996ae0b0 | 12346 | |
69e6ee2f HK |
12347 | elsif Nkind (Decl) = N_Full_Type_Declaration |
12348 | and then Is_Task_Type (Defining_Entity (Decl)) | |
12349 | then | |
12350 | Process_Task_Type_Declaration | |
12351 | (Task_Decl => Decl, | |
12352 | In_State => In_State); | |
12353 | end if; | |
996ae0b0 | 12354 | |
69e6ee2f HK |
12355 | Next (Decl); |
12356 | end loop; | |
12357 | end Process_Declarations; | |
996ae0b0 | 12358 | |
69e6ee2f HK |
12359 | ------------------------- |
12360 | -- Process_Freeze_Node -- | |
12361 | ------------------------- | |
996ae0b0 | 12362 | |
69e6ee2f HK |
12363 | procedure Process_Freeze_Node |
12364 | (Fnode : Node_Id; | |
12365 | In_State : Processing_In_State) | |
12366 | is | |
12367 | begin | |
12368 | Process_Declarations | |
12369 | (Decls => Actions (Fnode), | |
12370 | In_State => In_State); | |
12371 | end Process_Freeze_Node; | |
996ae0b0 | 12372 | |
69e6ee2f HK |
12373 | ----------------------------------- |
12374 | -- Process_Invocation_Activation -- | |
12375 | ----------------------------------- | |
996ae0b0 | 12376 | |
69e6ee2f HK |
12377 | procedure Process_Invocation_Activation |
12378 | (Call : Node_Id; | |
12379 | Call_Rep : Scenario_Rep_Id; | |
12380 | Obj_Id : Entity_Id; | |
12381 | Obj_Rep : Target_Rep_Id; | |
12382 | Task_Typ : Entity_Id; | |
12383 | Task_Rep : Target_Rep_Id; | |
12384 | In_State : Processing_In_State) | |
12385 | is | |
12386 | pragma Unreferenced (Call); | |
12387 | pragma Unreferenced (Call_Rep); | |
12388 | pragma Unreferenced (Obj_Id); | |
12389 | pragma Unreferenced (Obj_Rep); | |
996ae0b0 | 12390 | |
69e6ee2f HK |
12391 | begin |
12392 | -- Nothing to do when the task type appears within an internal unit | |
996ae0b0 | 12393 | |
69e6ee2f HK |
12394 | if In_Internal_Unit (Task_Typ) then |
12395 | return; | |
12396 | end if; | |
996ae0b0 | 12397 | |
69e6ee2f HK |
12398 | -- The task type being activated is within the main unit. Extend the |
12399 | -- DFS traversal into its body. | |
996ae0b0 | 12400 | |
69e6ee2f HK |
12401 | if In_Extended_Main_Code_Unit (Task_Typ) then |
12402 | Traverse_Invocation_Body | |
12403 | (N => Body_Declaration (Task_Rep), | |
12404 | In_State => In_State); | |
996ae0b0 | 12405 | |
69e6ee2f HK |
12406 | -- The task type being activated resides within an external unit |
12407 | -- | |
12408 | -- Main unit External unit | |
12409 | -- +-----------+ +-------------+ | |
12410 | -- | | | | | |
12411 | -- | Start ------------> Task_Typ | | |
12412 | -- | | | | | |
12413 | -- +-----------+ +-------------+ | |
12414 | -- | |
12415 | -- Record the invocation path which originates from Start and reaches | |
12416 | -- the task type. | |
0c6826a5 | 12417 | |
90e491a7 | 12418 | else |
69e6ee2f | 12419 | Record_Invocation_Path (In_State); |
996ae0b0 | 12420 | end if; |
69e6ee2f | 12421 | end Process_Invocation_Activation; |
996ae0b0 | 12422 | |
69e6ee2f HK |
12423 | --------------------------------------- |
12424 | -- Process_Invocation_Body_Scenarios -- | |
12425 | --------------------------------------- | |
996ae0b0 | 12426 | |
69e6ee2f HK |
12427 | procedure Process_Invocation_Body_Scenarios is |
12428 | Iter : NE_Set.Iterator := Iterate_Library_Body_Scenarios; | |
12429 | begin | |
12430 | Process_Invocation_Scenarios | |
12431 | (Iter => Iter, | |
12432 | In_State => Invocation_Body_State); | |
12433 | end Process_Invocation_Body_Scenarios; | |
8dce7371 | 12434 | |
69e6ee2f HK |
12435 | ----------------------------- |
12436 | -- Process_Invocation_Call -- | |
12437 | ----------------------------- | |
8dce7371 | 12438 | |
69e6ee2f HK |
12439 | procedure Process_Invocation_Call |
12440 | (Call : Node_Id; | |
12441 | Call_Rep : Scenario_Rep_Id; | |
12442 | In_State : Processing_In_State) | |
12443 | is | |
12444 | pragma Unreferenced (Call); | |
8dce7371 | 12445 | |
69e6ee2f HK |
12446 | Subp_Id : constant Entity_Id := Target (Call_Rep); |
12447 | Subp_Rep : constant Target_Rep_Id := | |
12448 | Target_Representation_Of (Subp_Id, In_State); | |
996ae0b0 | 12449 | |
69e6ee2f HK |
12450 | begin |
12451 | -- Nothing to do when the subprogram appears within an internal unit | |
c23f55b4 | 12452 | |
69e6ee2f HK |
12453 | if In_Internal_Unit (Subp_Id) then |
12454 | return; | |
996ae0b0 | 12455 | |
69e6ee2f HK |
12456 | -- Nothing to do for an abstract subprogram because it has no body to |
12457 | -- examine. | |
c23f55b4 | 12458 | |
69e6ee2f HK |
12459 | elsif Ekind_In (Subp_Id, E_Function, E_Procedure) |
12460 | and then Is_Abstract_Subprogram (Subp_Id) | |
12461 | then | |
12462 | return; | |
c23f55b4 | 12463 | |
69e6ee2f HK |
12464 | -- Nothin to do for a formal subprogram because it has no body to |
12465 | -- examine. | |
c23f55b4 | 12466 | |
69e6ee2f HK |
12467 | elsif Is_Formal_Subprogram (Subp_Id) then |
12468 | return; | |
12469 | end if; | |
8dce7371 | 12470 | |
69e6ee2f HK |
12471 | -- The subprogram being called is within the main unit. Extend the |
12472 | -- DFS traversal into its barrier function and body. | |
8dce7371 | 12473 | |
69e6ee2f HK |
12474 | if In_Extended_Main_Code_Unit (Subp_Id) then |
12475 | if Ekind_In (Subp_Id, E_Entry, E_Entry_Family, E_Procedure) then | |
12476 | Traverse_Invocation_Body | |
12477 | (N => Barrier_Body_Declaration (Subp_Rep), | |
12478 | In_State => In_State); | |
12479 | end if; | |
8dce7371 | 12480 | |
69e6ee2f HK |
12481 | Traverse_Invocation_Body |
12482 | (N => Body_Declaration (Subp_Rep), | |
12483 | In_State => In_State); | |
8dce7371 | 12484 | |
69e6ee2f HK |
12485 | -- The subprogram being called resides within an external unit |
12486 | -- | |
12487 | -- Main unit External unit | |
12488 | -- +-----------+ +-------------+ | |
12489 | -- | | | | | |
12490 | -- | Start ------------> Subp_Id | | |
12491 | -- | | | | | |
12492 | -- +-----------+ +-------------+ | |
12493 | -- | |
12494 | -- Record the invocation path which originates from Start and reaches | |
12495 | -- the subprogram. | |
8dce7371 | 12496 | |
69e6ee2f HK |
12497 | else |
12498 | Record_Invocation_Path (In_State); | |
8dce7371 | 12499 | end if; |
69e6ee2f | 12500 | end Process_Invocation_Call; |
8dce7371 | 12501 | |
3eb5e54a HK |
12502 | -------------------------------------- |
12503 | -- Process_Invocation_Instantiation -- | |
12504 | -------------------------------------- | |
12505 | ||
12506 | procedure Process_Invocation_Instantiation | |
12507 | (Inst : Node_Id; | |
12508 | Inst_Rep : Scenario_Rep_Id; | |
12509 | In_State : Processing_In_State) | |
12510 | is | |
12511 | pragma Unreferenced (Inst); | |
12512 | ||
12513 | Gen_Id : constant Entity_Id := Target (Inst_Rep); | |
12514 | ||
12515 | begin | |
12516 | -- Nothing to do when the generic appears within an internal unit | |
12517 | ||
12518 | if In_Internal_Unit (Gen_Id) then | |
12519 | return; | |
12520 | end if; | |
12521 | ||
12522 | -- The generic being instantiated resides within an external unit | |
12523 | -- | |
12524 | -- Main unit External unit | |
12525 | -- +-----------+ +-------------+ | |
12526 | -- | | | | | |
12527 | -- | Start ------------> Generic | | |
12528 | -- | | | | | |
12529 | -- +-----------+ +-------------+ | |
12530 | -- | |
12531 | -- Record the invocation path which originates from Start and reaches | |
12532 | -- the generic. | |
12533 | ||
12534 | if not In_Extended_Main_Code_Unit (Gen_Id) then | |
12535 | Record_Invocation_Path (In_State); | |
12536 | end if; | |
12537 | end Process_Invocation_Instantiation; | |
12538 | ||
69e6ee2f HK |
12539 | --------------------------------- |
12540 | -- Process_Invocation_Scenario -- | |
12541 | --------------------------------- | |
8dce7371 | 12542 | |
69e6ee2f HK |
12543 | procedure Process_Invocation_Scenario |
12544 | (N : Node_Id; | |
12545 | In_State : Processing_In_State) | |
12546 | is | |
12547 | Scen : constant Node_Id := Scenario (N); | |
12548 | Scen_Rep : Scenario_Rep_Id; | |
8dce7371 PMR |
12549 | |
12550 | begin | |
69e6ee2f | 12551 | -- Add the current scenario to the stack of active scenarios |
8dce7371 | 12552 | |
69e6ee2f | 12553 | Push_Active_Scenario (Scen); |
8dce7371 | 12554 | |
69e6ee2f | 12555 | -- Call or task activation |
8dce7371 | 12556 | |
69e6ee2f HK |
12557 | if Is_Suitable_Call (Scen) then |
12558 | Scen_Rep := Scenario_Representation_Of (Scen, In_State); | |
8dce7371 | 12559 | |
69e6ee2f HK |
12560 | -- Routine Build_Call_Marker creates call markers regardless of |
12561 | -- whether the call occurs within the main unit or not. This way | |
12562 | -- the serialization of internal names is kept consistent. Only | |
12563 | -- call markers found within the main unit must be processed. | |
8dce7371 | 12564 | |
69e6ee2f HK |
12565 | if In_Main_Context (Scen) then |
12566 | Scen_Rep := Scenario_Representation_Of (Scen, In_State); | |
8dce7371 | 12567 | |
69e6ee2f HK |
12568 | if Kind (Scen_Rep) = Call_Scenario then |
12569 | Process_Invocation_Call | |
12570 | (Call => Scen, | |
12571 | Call_Rep => Scen_Rep, | |
12572 | In_State => In_State); | |
12573 | ||
12574 | else | |
12575 | pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario); | |
12576 | ||
12577 | Process_Activation | |
12578 | (Call => Scen, | |
12579 | Call_Rep => Scen_Rep, | |
12580 | Processor => Process_Invocation_Activation'Access, | |
12581 | In_State => In_State); | |
12582 | end if; | |
12583 | end if; | |
3eb5e54a HK |
12584 | |
12585 | -- Instantiation | |
12586 | ||
12587 | elsif Is_Suitable_Instantiation (Scen) then | |
12588 | Process_Invocation_Instantiation | |
12589 | (Inst => Scen, | |
12590 | Inst_Rep => Scenario_Representation_Of (Scen, In_State), | |
12591 | In_State => In_State); | |
8dce7371 | 12592 | end if; |
c23f55b4 | 12593 | |
69e6ee2f HK |
12594 | -- Remove the current scenario from the stack of active scenarios |
12595 | -- once all invocation constructs and paths have been saved. | |
8dce7371 | 12596 | |
69e6ee2f HK |
12597 | Pop_Active_Scenario (Scen); |
12598 | end Process_Invocation_Scenario; | |
967947ed | 12599 | |
69e6ee2f HK |
12600 | ---------------------------------- |
12601 | -- Process_Invocation_Scenarios -- | |
12602 | ---------------------------------- | |
967947ed | 12603 | |
69e6ee2f HK |
12604 | procedure Process_Invocation_Scenarios |
12605 | (Iter : in out NE_Set.Iterator; | |
12606 | In_State : Processing_In_State) | |
12607 | is | |
12608 | N : Node_Id; | |
c23f55b4 | 12609 | |
69e6ee2f HK |
12610 | begin |
12611 | while NE_Set.Has_Next (Iter) loop | |
12612 | NE_Set.Next (Iter, N); | |
2c1b72d7 | 12613 | |
69e6ee2f HK |
12614 | -- Reset the traversed status of all subprogram bodies because the |
12615 | -- current invocation scenario acts as a new DFS traversal root. | |
fbf5a39b | 12616 | |
69e6ee2f | 12617 | Reset_Traversed_Bodies; |
90e491a7 | 12618 | |
69e6ee2f HK |
12619 | Process_Invocation_Scenario (N, In_State); |
12620 | end loop; | |
12621 | end Process_Invocation_Scenarios; | |
90e491a7 | 12622 | |
69e6ee2f HK |
12623 | --------------------------------------- |
12624 | -- Process_Invocation_Spec_Scenarios -- | |
12625 | --------------------------------------- | |
90e491a7 | 12626 | |
69e6ee2f HK |
12627 | procedure Process_Invocation_Spec_Scenarios is |
12628 | Iter : NE_Set.Iterator := Iterate_Library_Spec_Scenarios; | |
12629 | begin | |
12630 | Process_Invocation_Scenarios | |
12631 | (Iter => Iter, | |
12632 | In_State => Invocation_Spec_State); | |
12633 | end Process_Invocation_Spec_Scenarios; | |
90e491a7 | 12634 | |
69e6ee2f HK |
12635 | ----------------------- |
12636 | -- Process_Main_Unit -- | |
12637 | ----------------------- | |
90e491a7 | 12638 | |
69e6ee2f HK |
12639 | procedure Process_Main_Unit is |
12640 | Unit_Decl : constant Node_Id := Unit (Cunit (Main_Unit)); | |
12641 | Spec_Id : Entity_Id; | |
fbf5a39b | 12642 | |
90e491a7 | 12643 | begin |
69e6ee2f | 12644 | -- The main unit is a [generic] package body |
996ae0b0 | 12645 | |
69e6ee2f HK |
12646 | if Nkind (Unit_Decl) = N_Package_Body then |
12647 | Spec_Id := Corresponding_Spec (Unit_Decl); | |
12648 | pragma Assert (Present (Spec_Id)); | |
996ae0b0 | 12649 | |
69e6ee2f HK |
12650 | Process_Package_Declaration |
12651 | (Pack_Decl => Unit_Declaration_Node (Spec_Id), | |
12652 | In_State => Invocation_Construct_State); | |
996ae0b0 | 12653 | |
69e6ee2f | 12654 | -- The main unit is a [generic] package declaration |
90e491a7 | 12655 | |
69e6ee2f HK |
12656 | elsif Nkind (Unit_Decl) = N_Package_Declaration then |
12657 | Process_Package_Declaration | |
12658 | (Pack_Decl => Unit_Decl, | |
12659 | In_State => Invocation_Construct_State); | |
90e491a7 | 12660 | |
69e6ee2f | 12661 | -- The main unit is a [generic] subprogram body |
90e491a7 | 12662 | |
69e6ee2f HK |
12663 | elsif Nkind (Unit_Decl) = N_Subprogram_Body then |
12664 | Spec_Id := Corresponding_Spec (Unit_Decl); | |
90e491a7 | 12665 | |
69e6ee2f | 12666 | -- The body completes a previous declaration |
90e491a7 | 12667 | |
69e6ee2f HK |
12668 | if Present (Spec_Id) then |
12669 | Process_Subprogram_Declaration | |
12670 | (Subp_Decl => Unit_Declaration_Node (Spec_Id), | |
12671 | In_State => Invocation_Construct_State); | |
90e491a7 | 12672 | |
69e6ee2f | 12673 | -- Otherwise the body is stand-alone |
90e491a7 | 12674 | |
69e6ee2f HK |
12675 | else |
12676 | Process_Subprogram_Declaration | |
12677 | (Subp_Decl => Unit_Decl, | |
12678 | In_State => Invocation_Construct_State); | |
12679 | end if; | |
90e491a7 | 12680 | |
69e6ee2f | 12681 | -- The main unit is a subprogram instantiation |
90e491a7 | 12682 | |
69e6ee2f HK |
12683 | elsif Nkind (Unit_Decl) in N_Subprogram_Instantiation then |
12684 | Process_Subprogram_Instantiation | |
12685 | (Inst => Unit_Decl, | |
12686 | In_State => Invocation_Construct_State); | |
8dce7371 | 12687 | |
69e6ee2f | 12688 | -- The main unit is an imported subprogram declaration |
90e491a7 | 12689 | |
69e6ee2f HK |
12690 | elsif Nkind (Unit_Decl) = N_Subprogram_Declaration then |
12691 | Process_Subprogram_Declaration | |
12692 | (Subp_Decl => Unit_Decl, | |
12693 | In_State => Invocation_Construct_State); | |
12694 | end if; | |
12695 | end Process_Main_Unit; | |
12696 | ||
12697 | --------------------------------- | |
12698 | -- Process_Package_Declaration -- | |
12699 | --------------------------------- | |
12700 | ||
12701 | procedure Process_Package_Declaration | |
12702 | (Pack_Decl : Node_Id; | |
12703 | In_State : Processing_In_State) | |
12704 | is | |
12705 | Body_Id : constant Entity_Id := Corresponding_Body (Pack_Decl); | |
12706 | Spec : constant Node_Id := Specification (Pack_Decl); | |
12707 | Spec_Id : constant Entity_Id := Defining_Entity (Pack_Decl); | |
12708 | ||
12709 | begin | |
12710 | -- Add a declaration for the generic package in the ALI of the main | |
12711 | -- unit in case a client unit instantiates it. | |
12712 | ||
12713 | if Ekind (Spec_Id) = E_Generic_Package then | |
12714 | Declare_Invocation_Construct | |
12715 | (Constr_Id => Spec_Id, | |
12716 | In_State => In_State); | |
12717 | ||
12718 | -- Otherwise inspect the visible and private declarations of the | |
12719 | -- package for invocation constructs. | |
996ae0b0 | 12720 | |
0c6826a5 | 12721 | else |
69e6ee2f HK |
12722 | Process_Declarations |
12723 | (Decls => Visible_Declarations (Spec), | |
12724 | In_State => In_State); | |
12725 | ||
12726 | Process_Declarations | |
12727 | (Decls => Private_Declarations (Spec), | |
12728 | In_State => In_State); | |
12729 | ||
12730 | -- The package body containst at least one generic unit or an | |
12731 | -- inlinable subprogram. Such constructs may grant clients of | |
12732 | -- the main unit access to the private enclosing contexts of | |
12733 | -- the constructs. Process the main unit body to discover and | |
12734 | -- encode relevant invocation constructs and relations that | |
12735 | -- may ultimately reach an external unit. | |
12736 | ||
12737 | if Present (Body_Id) | |
12738 | and then Save_Invocation_Graph_Of_Body (Cunit (Main_Unit)) | |
12739 | then | |
12740 | Process_Declarations | |
12741 | (Decls => Declarations (Unit_Declaration_Node (Body_Id)), | |
12742 | In_State => In_State); | |
12743 | end if; | |
996ae0b0 | 12744 | end if; |
69e6ee2f | 12745 | end Process_Package_Declaration; |
996ae0b0 | 12746 | |
69e6ee2f HK |
12747 | ---------------------------------------- |
12748 | -- Process_Protected_Type_Declaration -- | |
12749 | ---------------------------------------- | |
996ae0b0 | 12750 | |
69e6ee2f HK |
12751 | procedure Process_Protected_Type_Declaration |
12752 | (Prot_Decl : Node_Id; | |
12753 | In_State : Processing_In_State) | |
12754 | is | |
12755 | Prot_Def : constant Node_Id := Protected_Definition (Prot_Decl); | |
996ae0b0 | 12756 | |
69e6ee2f HK |
12757 | begin |
12758 | if Present (Prot_Def) then | |
12759 | Process_Declarations | |
12760 | (Decls => Visible_Declarations (Prot_Def), | |
12761 | In_State => In_State); | |
12762 | end if; | |
12763 | end Process_Protected_Type_Declaration; | |
996ae0b0 | 12764 | |
69e6ee2f HK |
12765 | ------------------------------------ |
12766 | -- Process_Subprogram_Declaration -- | |
12767 | ------------------------------------ | |
996ae0b0 | 12768 | |
69e6ee2f HK |
12769 | procedure Process_Subprogram_Declaration |
12770 | (Subp_Decl : Node_Id; | |
12771 | In_State : Processing_In_State) | |
12772 | is | |
12773 | Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); | |
996ae0b0 | 12774 | |
69e6ee2f HK |
12775 | begin |
12776 | -- Nothing to do when the subprogram is not an invocation target | |
996ae0b0 | 12777 | |
69e6ee2f HK |
12778 | if not Is_Invocation_Target (Subp_Id) then |
12779 | return; | |
12780 | end if; | |
367601d1 | 12781 | |
69e6ee2f HK |
12782 | -- Add a declaration for the subprogram in the ALI file of the main |
12783 | -- unit in case a client unit calls or instantiates it. | |
367601d1 | 12784 | |
69e6ee2f HK |
12785 | Declare_Invocation_Construct |
12786 | (Constr_Id => Subp_Id, | |
12787 | In_State => In_State); | |
90e491a7 | 12788 | |
69e6ee2f HK |
12789 | -- Do not process subprograms without a body because they do not |
12790 | -- contain any invocation scenarios. | |
996ae0b0 | 12791 | |
69e6ee2f HK |
12792 | if Is_Bodiless_Subprogram (Subp_Id) then |
12793 | null; | |
996ae0b0 | 12794 | |
69e6ee2f HK |
12795 | -- Do not process generic subprograms because generics must not be |
12796 | -- examined. | |
90e491a7 | 12797 | |
69e6ee2f HK |
12798 | elsif Is_Generic_Subprogram (Subp_Id) then |
12799 | null; | |
996ae0b0 | 12800 | |
69e6ee2f HK |
12801 | -- Otherwise create a dummy scenario which calls the subprogram to |
12802 | -- act as a root for a DFS traversal. | |
90e491a7 | 12803 | |
69e6ee2f HK |
12804 | else |
12805 | -- Reset the traversed status of all subprogram bodies because the | |
12806 | -- subprogram acts as a new DFS traversal root. | |
90e491a7 | 12807 | |
69e6ee2f | 12808 | Reset_Traversed_Bodies; |
996ae0b0 | 12809 | |
69e6ee2f HK |
12810 | Process_Invocation_Scenario |
12811 | (N => Build_Subprogram_Invocation (Subp_Id), | |
12812 | In_State => In_State); | |
12813 | end if; | |
12814 | end Process_Subprogram_Declaration; | |
996ae0b0 | 12815 | |
69e6ee2f HK |
12816 | -------------------------------------- |
12817 | -- Process_Subprogram_Instantiation -- | |
12818 | -------------------------------------- | |
90e491a7 | 12819 | |
69e6ee2f HK |
12820 | procedure Process_Subprogram_Instantiation |
12821 | (Inst : Node_Id; | |
12822 | In_State : Processing_In_State) | |
12823 | is | |
12824 | begin | |
12825 | -- Add a declaration for the instantiation in the ALI file of the | |
12826 | -- main unit in case a client unit calls it. | |
90e491a7 | 12827 | |
69e6ee2f HK |
12828 | Declare_Invocation_Construct |
12829 | (Constr_Id => Defining_Entity (Inst), | |
12830 | In_State => In_State); | |
12831 | end Process_Subprogram_Instantiation; | |
90e491a7 | 12832 | |
69e6ee2f HK |
12833 | ----------------------------------- |
12834 | -- Process_Task_Type_Declaration -- | |
12835 | ----------------------------------- | |
996ae0b0 | 12836 | |
69e6ee2f HK |
12837 | procedure Process_Task_Type_Declaration |
12838 | (Task_Decl : Node_Id; | |
12839 | In_State : Processing_In_State) | |
12840 | is | |
12841 | Task_Typ : constant Entity_Id := Defining_Entity (Task_Decl); | |
12842 | Task_Def : Node_Id; | |
996ae0b0 | 12843 | |
69e6ee2f HK |
12844 | begin |
12845 | -- Add a declaration for the task type the ALI file of the main unit | |
12846 | -- in case a client unit creates a task object and activates it. | |
996ae0b0 | 12847 | |
69e6ee2f HK |
12848 | Declare_Invocation_Construct |
12849 | (Constr_Id => Task_Typ, | |
12850 | In_State => In_State); | |
90e491a7 | 12851 | |
69e6ee2f HK |
12852 | -- Process the entries of the task type because they represent valid |
12853 | -- entry points into the task body. | |
90e491a7 | 12854 | |
69e6ee2f HK |
12855 | if Nkind_In (Task_Decl, N_Single_Task_Declaration, |
12856 | N_Task_Type_Declaration) | |
90e491a7 | 12857 | then |
69e6ee2f | 12858 | Task_Def := Task_Definition (Task_Decl); |
90e491a7 | 12859 | |
69e6ee2f HK |
12860 | if Present (Task_Def) then |
12861 | Process_Declarations | |
12862 | (Decls => Visible_Declarations (Task_Def), | |
12863 | In_State => In_State); | |
90e491a7 PMR |
12864 | end if; |
12865 | end if; | |
90e491a7 | 12866 | |
69e6ee2f HK |
12867 | -- Reset the traversed status of all subprogram bodies because the |
12868 | -- task type acts as a new DFS traversal root. | |
90e491a7 | 12869 | |
69e6ee2f | 12870 | Reset_Traversed_Bodies; |
996ae0b0 | 12871 | |
69e6ee2f HK |
12872 | -- Create a dummy scenario which activates an anonymous object of the |
12873 | -- task type to acts as a root of a DFS traversal. | |
996ae0b0 | 12874 | |
69e6ee2f HK |
12875 | Process_Invocation_Scenario |
12876 | (N => Build_Task_Activation (Task_Typ, In_State), | |
12877 | In_State => In_State); | |
12878 | end Process_Task_Type_Declaration; | |
90e491a7 | 12879 | |
69e6ee2f HK |
12880 | --------------------------------- |
12881 | -- Record_Full_Invocation_Path -- | |
12882 | --------------------------------- | |
996ae0b0 | 12883 | |
69e6ee2f HK |
12884 | procedure Record_Full_Invocation_Path (In_State : Processing_In_State) is |
12885 | package Scenarios renames Active_Scenario_Stack; | |
996ae0b0 | 12886 | |
69e6ee2f HK |
12887 | begin |
12888 | -- The path originates from the elaboration of the body. Add an extra | |
12889 | -- relation from the elaboration body procedure to the first active | |
12890 | -- scenario. | |
fbf5a39b | 12891 | |
69e6ee2f HK |
12892 | if In_State.Processing = Invocation_Body_Processing then |
12893 | Build_Elaborate_Body_Procedure; | |
90e491a7 | 12894 | |
69e6ee2f HK |
12895 | Record_Invocation_Relation |
12896 | (Invk_Id => Elab_Body_Id, | |
12897 | Targ_Id => Target_Of (Scenarios.First, In_State), | |
12898 | In_State => In_State); | |
90e491a7 | 12899 | |
69e6ee2f HK |
12900 | -- The path originates from the elaboration of the spec. Add an extra |
12901 | -- relation from the elaboration spec procedure to the first active | |
12902 | -- scenario. | |
fbf5a39b | 12903 | |
69e6ee2f HK |
12904 | elsif In_State.Processing = Invocation_Spec_Processing then |
12905 | Build_Elaborate_Spec_Procedure; | |
8dce7371 | 12906 | |
69e6ee2f HK |
12907 | Record_Invocation_Relation |
12908 | (Invk_Id => Elab_Spec_Id, | |
12909 | Targ_Id => Target_Of (Scenarios.First, In_State), | |
12910 | In_State => In_State); | |
12911 | end if; | |
996ae0b0 | 12912 | |
69e6ee2f | 12913 | -- Record individual relations formed by pairs of scenarios |
07fc65c4 | 12914 | |
69e6ee2f HK |
12915 | for Index in Scenarios.First .. Scenarios.Last - 1 loop |
12916 | Record_Invocation_Relation | |
12917 | (Invk_Id => Target_Of (Index, In_State), | |
12918 | Targ_Id => Target_Of (Index + 1, In_State), | |
12919 | In_State => In_State); | |
12920 | end loop; | |
12921 | end Record_Full_Invocation_Path; | |
91b1417d | 12922 | |
69e6ee2f HK |
12923 | ----------------------------- |
12924 | -- Record_Invocation_Graph -- | |
12925 | ----------------------------- | |
0c6826a5 | 12926 | |
69e6ee2f | 12927 | procedure Record_Invocation_Graph is |
90e491a7 | 12928 | begin |
69e6ee2f | 12929 | -- Nothing to do when the invocation graph is not recorded |
e77e2429 | 12930 | |
69e6ee2f HK |
12931 | if not Invocation_Graph_Recording_OK then |
12932 | return; | |
12933 | end if; | |
e77e2429 | 12934 | |
9795b203 HK |
12935 | -- Save the encoding format used to capture information about the |
12936 | -- invocation constructs and relations in the ALI file of the main | |
12937 | -- unit. | |
12938 | ||
12939 | Record_Invocation_Graph_Encoding; | |
12940 | ||
69e6ee2f HK |
12941 | -- Examine all library level invocation scenarios and perform DFS |
12942 | -- traversals from each one. Encode a path in the ALI file of the | |
12943 | -- main unit if it reaches into an external unit. | |
e77e2429 | 12944 | |
69e6ee2f HK |
12945 | Process_Invocation_Body_Scenarios; |
12946 | Process_Invocation_Spec_Scenarios; | |
e77e2429 | 12947 | |
69e6ee2f HK |
12948 | -- Examine all invocation constructs within the spec and body of the |
12949 | -- main unit and perform DFS traversals from each one. Encode a path | |
12950 | -- in the ALI file of the main unit if it reaches into an external | |
12951 | -- unit. | |
91b1417d | 12952 | |
69e6ee2f HK |
12953 | Process_Main_Unit; |
12954 | end Record_Invocation_Graph; | |
91b1417d | 12955 | |
9795b203 HK |
12956 | -------------------------------------- |
12957 | -- Record_Invocation_Graph_Encoding -- | |
12958 | -------------------------------------- | |
12959 | ||
12960 | procedure Record_Invocation_Graph_Encoding is | |
12961 | Kind : Invocation_Graph_Encoding_Kind := No_Encoding; | |
12962 | ||
12963 | begin | |
12964 | -- Switch -gnatd_F (encode full invocation paths in ALI files) is in | |
12965 | -- effect. | |
12966 | ||
12967 | if Debug_Flag_Underscore_FF then | |
12968 | Kind := Full_Path_Encoding; | |
12969 | else | |
12970 | Kind := Endpoints_Encoding; | |
12971 | end if; | |
12972 | ||
12973 | -- Save the encoding format in the ALI file of the main unit | |
12974 | ||
12975 | Set_Invocation_Graph_Encoding | |
12976 | (Kind => Kind, | |
12977 | Update_Units => False); | |
12978 | end Record_Invocation_Graph_Encoding; | |
12979 | ||
69e6ee2f HK |
12980 | ---------------------------- |
12981 | -- Record_Invocation_Path -- | |
12982 | ---------------------------- | |
596f7139 | 12983 | |
69e6ee2f HK |
12984 | procedure Record_Invocation_Path (In_State : Processing_In_State) is |
12985 | package Scenarios renames Active_Scenario_Stack; | |
e090bc75 | 12986 | |
69e6ee2f HK |
12987 | begin |
12988 | -- Save a path when the active scenario stack contains at least one | |
12989 | -- invocation scenario. | |
2a1f6a1f | 12990 | |
69e6ee2f HK |
12991 | if Scenarios.Last - Scenarios.First < 0 then |
12992 | return; | |
12993 | end if; | |
fbf5a39b | 12994 | |
69e6ee2f HK |
12995 | -- Register all relations in the path when switch -gnatd_F (encode |
12996 | -- full invocation paths in ALI files) is in effect. | |
de4899bb | 12997 | |
69e6ee2f HK |
12998 | if Debug_Flag_Underscore_FF then |
12999 | Record_Full_Invocation_Path (In_State); | |
de4899bb | 13000 | |
69e6ee2f | 13001 | -- Otherwise register a single relation |
596f7139 | 13002 | |
69e6ee2f HK |
13003 | else |
13004 | Record_Simple_Invocation_Path (In_State); | |
13005 | end if; | |
996ae0b0 | 13006 | |
69e6ee2f HK |
13007 | Write_Invocation_Path (In_State); |
13008 | end Record_Invocation_Path; | |
bde33286 | 13009 | |
69e6ee2f HK |
13010 | -------------------------------- |
13011 | -- Record_Invocation_Relation -- | |
13012 | -------------------------------- | |
596f7139 | 13013 | |
69e6ee2f HK |
13014 | procedure Record_Invocation_Relation |
13015 | (Invk_Id : Entity_Id; | |
13016 | Targ_Id : Entity_Id; | |
13017 | In_State : Processing_In_State) | |
13018 | is | |
13019 | pragma Assert (Present (Invk_Id)); | |
13020 | pragma Assert (Present (Targ_Id)); | |
596f7139 | 13021 | |
69e6ee2f HK |
13022 | procedure Get_Invocation_Attributes |
13023 | (Extra : out Entity_Id; | |
13024 | Kind : out Invocation_Kind); | |
13025 | pragma Inline (Get_Invocation_Attributes); | |
13026 | -- Return the additional entity used in error diagnostics in Extra | |
13027 | -- and the invocation kind in Kind which pertain to the invocation | |
13028 | -- relation with invoker Invk_Id and target Targ_Id. | |
596f7139 | 13029 | |
90e491a7 | 13030 | ------------------------------- |
69e6ee2f | 13031 | -- Get_Invocation_Attributes -- |
90e491a7 | 13032 | ------------------------------- |
2a1f6a1f | 13033 | |
69e6ee2f HK |
13034 | procedure Get_Invocation_Attributes |
13035 | (Extra : out Entity_Id; | |
13036 | Kind : out Invocation_Kind) | |
13037 | is | |
9795b203 HK |
13038 | Targ_Rep : constant Target_Rep_Id := |
13039 | Target_Representation_Of (Targ_Id, In_State); | |
13040 | Spec_Decl : constant Node_Id := Spec_Declaration (Targ_Rep); | |
13041 | ||
90e491a7 | 13042 | begin |
69e6ee2f | 13043 | -- Accept within a task body |
bde33286 | 13044 | |
69e6ee2f HK |
13045 | if Is_Accept_Alternative_Proc (Targ_Id) then |
13046 | Extra := Receiving_Entry (Targ_Id); | |
13047 | Kind := Accept_Alternative; | |
ab01e614 | 13048 | |
69e6ee2f | 13049 | -- Activation of a task object |
ab01e614 | 13050 | |
69e6ee2f HK |
13051 | elsif Is_Activation_Proc (Targ_Id) |
13052 | or else Is_Task_Type (Targ_Id) | |
13053 | then | |
13054 | Extra := Empty; | |
13055 | Kind := Task_Activation; | |
996ae0b0 | 13056 | |
69e6ee2f | 13057 | -- Controlled adjustment actions |
996ae0b0 | 13058 | |
69e6ee2f HK |
13059 | elsif Is_Controlled_Proc (Targ_Id, Name_Adjust) then |
13060 | Extra := First_Formal_Type (Targ_Id); | |
13061 | Kind := Controlled_Adjustment; | |
996ae0b0 | 13062 | |
69e6ee2f | 13063 | -- Controlled finalization actions |
996ae0b0 | 13064 | |
69e6ee2f HK |
13065 | elsif Is_Controlled_Proc (Targ_Id, Name_Finalize) |
13066 | or else Is_Finalizer_Proc (Targ_Id) | |
13067 | then | |
13068 | Extra := First_Formal_Type (Targ_Id); | |
13069 | Kind := Controlled_Finalization; | |
90e491a7 | 13070 | |
69e6ee2f | 13071 | -- Controlled initialization actions |
90e491a7 | 13072 | |
69e6ee2f HK |
13073 | elsif Is_Controlled_Proc (Targ_Id, Name_Initialize) then |
13074 | Extra := First_Formal_Type (Targ_Id); | |
13075 | Kind := Controlled_Initialization; | |
996ae0b0 | 13076 | |
69e6ee2f | 13077 | -- Default_Initial_Condition verification |
91b1417d | 13078 | |
69e6ee2f HK |
13079 | elsif Is_Default_Initial_Condition_Proc (Targ_Id) then |
13080 | Extra := First_Formal_Type (Targ_Id); | |
13081 | Kind := Default_Initial_Condition_Verification; | |
91b1417d | 13082 | |
69e6ee2f | 13083 | -- Initialization of object |
72e9f2b9 | 13084 | |
69e6ee2f HK |
13085 | elsif Is_Init_Proc (Targ_Id) then |
13086 | Extra := First_Formal_Type (Targ_Id); | |
13087 | Kind := Type_Initialization; | |
72e9f2b9 | 13088 | |
69e6ee2f | 13089 | -- Initial_Condition verification |
996ae0b0 | 13090 | |
69e6ee2f HK |
13091 | elsif Is_Initial_Condition_Proc (Targ_Id) then |
13092 | Extra := First_Formal_Type (Targ_Id); | |
13093 | Kind := Initial_Condition_Verification; | |
91b1417d | 13094 | |
69e6ee2f | 13095 | -- Instantiation |
97ed5872 | 13096 | |
69e6ee2f HK |
13097 | elsif Is_Generic_Unit (Targ_Id) then |
13098 | Extra := Empty; | |
13099 | Kind := Instantiation; | |
97ed5872 | 13100 | |
69e6ee2f | 13101 | -- Internal controlled adjustment actions |
91b1417d | 13102 | |
69e6ee2f HK |
13103 | elsif Is_TSS (Targ_Id, TSS_Deep_Adjust) then |
13104 | Extra := First_Formal_Type (Targ_Id); | |
13105 | Kind := Internal_Controlled_Adjustment; | |
91b1417d | 13106 | |
69e6ee2f | 13107 | -- Internal controlled finalization actions |
91b1417d | 13108 | |
69e6ee2f HK |
13109 | elsif Is_TSS (Targ_Id, TSS_Deep_Finalize) then |
13110 | Extra := First_Formal_Type (Targ_Id); | |
13111 | Kind := Internal_Controlled_Finalization; | |
996ae0b0 | 13112 | |
69e6ee2f | 13113 | -- Internal controlled initialization actions |
996ae0b0 | 13114 | |
69e6ee2f HK |
13115 | elsif Is_TSS (Targ_Id, TSS_Deep_Initialize) then |
13116 | Extra := First_Formal_Type (Targ_Id); | |
13117 | Kind := Internal_Controlled_Initialization; | |
996ae0b0 | 13118 | |
69e6ee2f | 13119 | -- Invariant verification |
996ae0b0 | 13120 | |
69e6ee2f HK |
13121 | elsif Is_Invariant_Proc (Targ_Id) |
13122 | or else Is_Partial_Invariant_Proc (Targ_Id) | |
13123 | then | |
13124 | Extra := First_Formal_Type (Targ_Id); | |
13125 | Kind := Invariant_Verification; | |
996ae0b0 | 13126 | |
69e6ee2f | 13127 | -- Postcondition verification |
996ae0b0 | 13128 | |
69e6ee2f | 13129 | elsif Is_Postconditions_Proc (Targ_Id) then |
9795b203 | 13130 | Extra := Find_Enclosing_Scope (Spec_Decl); |
69e6ee2f | 13131 | Kind := Postcondition_Verification; |
996ae0b0 | 13132 | |
69e6ee2f | 13133 | -- Protected entry call |
996ae0b0 | 13134 | |
69e6ee2f HK |
13135 | elsif Is_Protected_Entry (Targ_Id) then |
13136 | Extra := Empty; | |
13137 | Kind := Protected_Entry_Call; | |
996ae0b0 | 13138 | |
69e6ee2f | 13139 | -- Protected subprogram call |
996ae0b0 | 13140 | |
69e6ee2f HK |
13141 | elsif Is_Protected_Subp (Targ_Id) then |
13142 | Extra := Empty; | |
13143 | Kind := Protected_Subprogram_Call; | |
996ae0b0 | 13144 | |
69e6ee2f | 13145 | -- Task entry call |
996ae0b0 | 13146 | |
69e6ee2f HK |
13147 | elsif Is_Task_Entry (Targ_Id) then |
13148 | Extra := Empty; | |
13149 | Kind := Task_Entry_Call; | |
996ae0b0 | 13150 | |
69e6ee2f HK |
13151 | -- Entry, operator, or subprogram call. This case must come last |
13152 | -- because most invocations above are variations of this case. | |
996ae0b0 | 13153 | |
69e6ee2f HK |
13154 | elsif Ekind_In (Targ_Id, E_Entry, |
13155 | E_Function, | |
13156 | E_Operator, | |
13157 | E_Procedure) | |
13158 | then | |
13159 | Extra := Empty; | |
13160 | Kind := Call; | |
996ae0b0 | 13161 | |
69e6ee2f HK |
13162 | else |
13163 | pragma Assert (False); | |
13164 | Extra := Empty; | |
13165 | Kind := No_Invocation; | |
13166 | end if; | |
13167 | end Get_Invocation_Attributes; | |
996ae0b0 | 13168 | |
69e6ee2f | 13169 | -- Local variables |
996ae0b0 | 13170 | |
69e6ee2f HK |
13171 | Extra : Entity_Id; |
13172 | Extra_Nam : Name_Id; | |
69e6ee2f HK |
13173 | Kind : Invocation_Kind; |
13174 | Rel : Invoker_Target_Relation; | |
996ae0b0 | 13175 | |
69e6ee2f | 13176 | -- Start of processing for Record_Invocation_Relation |
996ae0b0 | 13177 | |
69e6ee2f HK |
13178 | begin |
13179 | Rel.Invoker := Invk_Id; | |
13180 | Rel.Target := Targ_Id; | |
13181 | ||
13182 | -- Nothing to do when the invocation relation has already been | |
13183 | -- recorded in ALI file of the main unit. | |
13184 | ||
13185 | if Is_Saved_Relation (Rel) then | |
13186 | return; | |
90e491a7 | 13187 | end if; |
996ae0b0 | 13188 | |
69e6ee2f | 13189 | -- Mark the relation as recorded in the ALI file |
996ae0b0 | 13190 | |
69e6ee2f | 13191 | Set_Is_Saved_Relation (Rel); |
996ae0b0 | 13192 | |
69e6ee2f | 13193 | -- Declare the invoker in the ALI file |
996ae0b0 | 13194 | |
69e6ee2f HK |
13195 | Declare_Invocation_Construct |
13196 | (Constr_Id => Invk_Id, | |
13197 | In_State => In_State); | |
13198 | ||
13199 | -- Obtain the invocation-specific attributes of the relation | |
90e491a7 | 13200 | |
69e6ee2f HK |
13201 | Get_Invocation_Attributes (Extra, Kind); |
13202 | ||
13203 | -- Certain invocations lack an extra entity used in error diagnostics | |
13204 | ||
13205 | if Present (Extra) then | |
13206 | Extra_Nam := Chars (Extra); | |
90e491a7 | 13207 | else |
69e6ee2f | 13208 | Extra_Nam := No_Name; |
996ae0b0 | 13209 | end if; |
996ae0b0 | 13210 | |
69e6ee2f | 13211 | -- Add the relation in the ALI file |
996ae0b0 | 13212 | |
69e6ee2f | 13213 | Add_Invocation_Relation |
9795b203 HK |
13214 | (Extra => Extra_Nam, |
13215 | Invoker => Signature_Of (Invk_Id), | |
13216 | Kind => Kind, | |
13217 | Target => Signature_Of (Targ_Id), | |
69e6ee2f HK |
13218 | Update_Units => False); |
13219 | end Record_Invocation_Relation; | |
996ae0b0 | 13220 | |
69e6ee2f HK |
13221 | ----------------------------------- |
13222 | -- Record_Simple_Invocation_Path -- | |
13223 | ----------------------------------- | |
996ae0b0 | 13224 | |
69e6ee2f HK |
13225 | procedure Record_Simple_Invocation_Path |
13226 | (In_State : Processing_In_State) | |
13227 | is | |
13228 | package Scenarios renames Active_Scenario_Stack; | |
996ae0b0 | 13229 | |
69e6ee2f HK |
13230 | Last_Targ : constant Entity_Id := |
13231 | Target_Of (Scenarios.Last, In_State); | |
13232 | First_Targ : Entity_Id; | |
996ae0b0 | 13233 | |
90e491a7 | 13234 | begin |
69e6ee2f HK |
13235 | -- The path originates from the elaboration of the body. Add an extra |
13236 | -- relation from the elaboration body procedure to the first active | |
13237 | -- scenario. | |
996ae0b0 | 13238 | |
69e6ee2f HK |
13239 | if In_State.Processing = Invocation_Body_Processing then |
13240 | Build_Elaborate_Body_Procedure; | |
13241 | First_Targ := Elab_Body_Id; | |
996ae0b0 | 13242 | |
69e6ee2f HK |
13243 | -- The path originates from the elaboration of the spec. Add an extra |
13244 | -- relation from the elaboration spec procedure to the first active | |
13245 | -- scenario. | |
65b03d7d | 13246 | |
69e6ee2f HK |
13247 | elsif In_State.Processing = Invocation_Spec_Processing then |
13248 | Build_Elaborate_Spec_Procedure; | |
13249 | First_Targ := Elab_Spec_Id; | |
65b03d7d | 13250 | |
90e491a7 | 13251 | else |
69e6ee2f | 13252 | First_Targ := Target_Of (Scenarios.First, In_State); |
90e491a7 | 13253 | end if; |
996ae0b0 | 13254 | |
69e6ee2f | 13255 | -- Record a single relation from the first to the last scenario |
8dce7371 | 13256 | |
69e6ee2f HK |
13257 | if First_Targ /= Last_Targ then |
13258 | Record_Invocation_Relation | |
13259 | (Invk_Id => First_Targ, | |
13260 | Targ_Id => Last_Targ, | |
13261 | In_State => In_State); | |
13262 | end if; | |
13263 | end Record_Simple_Invocation_Path; | |
8dce7371 | 13264 | |
69e6ee2f HK |
13265 | ---------------------------- |
13266 | -- Set_Is_Saved_Construct -- | |
13267 | ---------------------------- | |
996ae0b0 | 13268 | |
69e6ee2f HK |
13269 | procedure Set_Is_Saved_Construct |
13270 | (Constr : Entity_Id; | |
13271 | Val : Boolean := True) | |
13272 | is | |
13273 | pragma Assert (Present (Constr)); | |
996ae0b0 | 13274 | |
90e491a7 | 13275 | begin |
69e6ee2f HK |
13276 | if Val then |
13277 | NE_Set.Insert (Saved_Constructs_Set, Constr); | |
13278 | else | |
13279 | NE_Set.Delete (Saved_Constructs_Set, Constr); | |
13280 | end if; | |
13281 | end Set_Is_Saved_Construct; | |
de4899bb | 13282 | |
69e6ee2f HK |
13283 | --------------------------- |
13284 | -- Set_Is_Saved_Relation -- | |
13285 | --------------------------- | |
996ae0b0 | 13286 | |
69e6ee2f HK |
13287 | procedure Set_Is_Saved_Relation |
13288 | (Rel : Invoker_Target_Relation; | |
13289 | Val : Boolean := True) | |
13290 | is | |
90e491a7 | 13291 | begin |
69e6ee2f HK |
13292 | if Val then |
13293 | IR_Set.Insert (Saved_Relations_Set, Rel); | |
8dce7371 | 13294 | else |
69e6ee2f | 13295 | IR_Set.Delete (Saved_Relations_Set, Rel); |
daf82dd8 | 13296 | end if; |
69e6ee2f | 13297 | end Set_Is_Saved_Relation; |
996ae0b0 | 13298 | |
69e6ee2f HK |
13299 | ------------------ |
13300 | -- Signature_Of -- | |
13301 | ------------------ | |
715e529d | 13302 | |
69e6ee2f HK |
13303 | function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id is |
13304 | Loc : constant Source_Ptr := Sloc (Id); | |
715e529d | 13305 | |
69e6ee2f HK |
13306 | function Instantiation_Locations return Name_Id; |
13307 | pragma Inline (Instantiation_Locations); | |
13308 | -- Create a concatenation of all lines and colums of each instance | |
13309 | -- where source location Loc appears. Return No_Name if no instances | |
13310 | -- exist. | |
996ae0b0 | 13311 | |
69e6ee2f HK |
13312 | function Qualified_Scope return Name_Id; |
13313 | pragma Inline (Qualified_Scope); | |
13314 | -- Obtain the qualified name of Id's scope | |
6a74a7b0 | 13315 | |
69e6ee2f HK |
13316 | ----------------------------- |
13317 | -- Instantiation_Locations -- | |
13318 | ----------------------------- | |
90e491a7 | 13319 | |
69e6ee2f HK |
13320 | function Instantiation_Locations return Name_Id is |
13321 | Buffer : Bounded_String (2052); | |
13322 | Inst : Source_Ptr; | |
13323 | Loc_Nam : Name_Id; | |
13324 | SFI : Source_File_Index; | |
6a74a7b0 | 13325 | |
69e6ee2f HK |
13326 | begin |
13327 | SFI := Get_Source_File_Index (Loc); | |
13328 | Inst := Instantiation (SFI); | |
996ae0b0 | 13329 | |
69e6ee2f HK |
13330 | -- The location is within an instance. Construct a concatenation |
13331 | -- of all lines and colums of each individual instance using the | |
13332 | -- following format: | |
13333 | -- | |
13334 | -- line1_column1_line2_column2_ ... _lineN_columnN | |
90e491a7 | 13335 | |
69e6ee2f HK |
13336 | if Inst /= No_Location then |
13337 | loop | |
13338 | Append (Buffer, Nat (Get_Logical_Line_Number (Inst))); | |
13339 | Append (Buffer, '_'); | |
13340 | Append (Buffer, Nat (Get_Column_Number (Inst))); | |
90e491a7 | 13341 | |
69e6ee2f HK |
13342 | SFI := Get_Source_File_Index (Inst); |
13343 | Inst := Instantiation (SFI); | |
996ae0b0 | 13344 | |
69e6ee2f | 13345 | exit when Inst = No_Location; |
de4899bb | 13346 | |
69e6ee2f HK |
13347 | Append (Buffer, '_'); |
13348 | end loop; | |
cf427f02 | 13349 | |
69e6ee2f HK |
13350 | Loc_Nam := Name_Find (Buffer); |
13351 | return Loc_Nam; | |
13352 | ||
13353 | -- Otherwise there no instances are involved | |
cf427f02 | 13354 | |
90e491a7 | 13355 | else |
69e6ee2f | 13356 | return No_Name; |
90e491a7 | 13357 | end if; |
69e6ee2f | 13358 | end Instantiation_Locations; |
996ae0b0 | 13359 | |
69e6ee2f HK |
13360 | --------------------- |
13361 | -- Qualified_Scope -- | |
13362 | --------------------- | |
8dce7371 | 13363 | |
69e6ee2f HK |
13364 | function Qualified_Scope return Name_Id is |
13365 | Scop : Entity_Id; | |
8dce7371 | 13366 | |
69e6ee2f HK |
13367 | begin |
13368 | Scop := Scope (Id); | |
996ae0b0 | 13369 | |
69e6ee2f HK |
13370 | -- The entity appears within an anonymous concurrent type created |
13371 | -- for a single protected or task type declaration. Use the entity | |
13372 | -- of the anonymous object as it represents the original scope. | |
6d11af89 | 13373 | |
69e6ee2f HK |
13374 | if Is_Concurrent_Type (Scop) |
13375 | and then Present (Anonymous_Object (Scop)) | |
13376 | then | |
13377 | Scop := Anonymous_Object (Scop); | |
13378 | end if; | |
6d11af89 | 13379 | |
69e6ee2f HK |
13380 | return Get_Qualified_Name (Scop); |
13381 | end Qualified_Scope; | |
6d11af89 | 13382 | |
69e6ee2f | 13383 | -- Start of processing for Signature_Of |
996ae0b0 | 13384 | |
69e6ee2f HK |
13385 | begin |
13386 | return | |
13387 | Invocation_Signature_Of | |
13388 | (Column => Nat (Get_Column_Number (Loc)), | |
13389 | Line => Nat (Get_Logical_Line_Number (Loc)), | |
13390 | Locations => Instantiation_Locations, | |
13391 | Name => Chars (Id), | |
13392 | Scope => Qualified_Scope); | |
13393 | end Signature_Of; | |
996ae0b0 | 13394 | |
69e6ee2f HK |
13395 | --------------- |
13396 | -- Target_Of -- | |
13397 | --------------- | |
996ae0b0 | 13398 | |
69e6ee2f HK |
13399 | function Target_Of |
13400 | (Pos : Active_Scenario_Pos; | |
13401 | In_State : Processing_In_State) return Entity_Id | |
13402 | is | |
13403 | package Scenarios renames Active_Scenario_Stack; | |
8dce7371 | 13404 | |
69e6ee2f HK |
13405 | -- Ensure that the position is within the bounds of the active |
13406 | -- scenario stack. | |
8dce7371 | 13407 | |
69e6ee2f HK |
13408 | pragma Assert (Scenarios.First <= Pos); |
13409 | pragma Assert (Pos <= Scenarios.Last); | |
8dce7371 | 13410 | |
69e6ee2f HK |
13411 | Scen_Rep : constant Scenario_Rep_Id := |
13412 | Scenario_Representation_Of | |
13413 | (Scenarios.Table (Pos), In_State); | |
8dce7371 | 13414 | |
69e6ee2f HK |
13415 | begin |
13416 | -- The true target of an activation call is the current task type | |
13417 | -- rather than routine Activate_Tasks. | |
8dce7371 | 13418 | |
69e6ee2f HK |
13419 | if Kind (Scen_Rep) = Task_Activation_Scenario then |
13420 | return Activated_Task_Type (Scen_Rep); | |
13421 | else | |
13422 | return Target (Scen_Rep); | |
13423 | end if; | |
13424 | end Target_Of; | |
162ed06f | 13425 | |
69e6ee2f HK |
13426 | ------------------------------ |
13427 | -- Traverse_Invocation_Body -- | |
13428 | ------------------------------ | |
13429 | ||
13430 | procedure Traverse_Invocation_Body | |
13431 | (N : Node_Id; | |
13432 | In_State : Processing_In_State) | |
13433 | is | |
8dce7371 | 13434 | begin |
69e6ee2f HK |
13435 | Traverse_Body |
13436 | (N => N, | |
13437 | Requires_Processing => Is_Invocation_Scenario'Access, | |
13438 | Processor => Process_Invocation_Scenario'Access, | |
13439 | In_State => In_State); | |
13440 | end Traverse_Invocation_Body; | |
8dce7371 | 13441 | |
69e6ee2f HK |
13442 | --------------------------- |
13443 | -- Write_Invocation_Path -- | |
13444 | --------------------------- | |
162ed06f | 13445 | |
69e6ee2f HK |
13446 | procedure Write_Invocation_Path (In_State : Processing_In_State) is |
13447 | procedure Write_Target (Targ_Id : Entity_Id; Is_First : Boolean); | |
13448 | pragma Inline (Write_Target); | |
13449 | -- Write out invocation target Targ_Id to standard output. Flag | |
13450 | -- Is_First should be set when the target is first in a path. | |
162ed06f | 13451 | |
69e6ee2f HK |
13452 | ------------- |
13453 | -- Targ_Id -- | |
13454 | ------------- | |
162ed06f | 13455 | |
69e6ee2f HK |
13456 | procedure Write_Target (Targ_Id : Entity_Id; Is_First : Boolean) is |
13457 | begin | |
13458 | if not Is_First then | |
13459 | Write_Str (" --> "); | |
13460 | end if; | |
162ed06f | 13461 | |
69e6ee2f HK |
13462 | Write_Name (Get_Qualified_Name (Targ_Id)); |
13463 | Write_Eol; | |
13464 | end Write_Target; | |
8dce7371 | 13465 | |
69e6ee2f | 13466 | -- Local variables |
8dce7371 | 13467 | |
69e6ee2f | 13468 | package Scenarios renames Active_Scenario_Stack; |
8dce7371 | 13469 | |
69e6ee2f | 13470 | First_Seen : Boolean := False; |
8dce7371 | 13471 | |
69e6ee2f | 13472 | -- Start of processing for Write_Invocation_Path |
162ed06f | 13473 | |
69e6ee2f HK |
13474 | begin |
13475 | -- Nothing to do when flag -gnatd_T (output trace information on | |
13476 | -- invocation path recording) is not in effect. | |
13477 | ||
13478 | if not Debug_Flag_Underscore_TT then | |
13479 | return; | |
8dce7371 | 13480 | end if; |
8dce7371 | 13481 | |
69e6ee2f HK |
13482 | -- The path originates from the elaboration of the body. Write the |
13483 | -- elaboration body procedure. | |
8dce7371 | 13484 | |
69e6ee2f HK |
13485 | if In_State.Processing = Invocation_Body_Processing then |
13486 | Write_Target (Elab_Body_Id, True); | |
13487 | First_Seen := True; | |
8dce7371 | 13488 | |
69e6ee2f HK |
13489 | -- The path originates from the elaboration of the spec. Write the |
13490 | -- elaboration spec procedure. | |
8dce7371 | 13491 | |
69e6ee2f HK |
13492 | elsif In_State.Processing = Invocation_Spec_Processing then |
13493 | Write_Target (Elab_Spec_Id, True); | |
13494 | First_Seen := True; | |
13495 | end if; | |
8dce7371 | 13496 | |
69e6ee2f HK |
13497 | -- Write each individual target invoked by its corresponding scenario |
13498 | -- on the active scenario stack. | |
8dce7371 | 13499 | |
69e6ee2f HK |
13500 | for Index in Scenarios.First .. Scenarios.Last loop |
13501 | Write_Target | |
13502 | (Targ_Id => Target_Of (Index, In_State), | |
13503 | Is_First => Index = Scenarios.First and then not First_Seen); | |
8dce7371 | 13504 | end loop; |
8dce7371 | 13505 | |
69e6ee2f HK |
13506 | Write_Eol; |
13507 | end Write_Invocation_Path; | |
13508 | end Invocation_Graph; | |
8dce7371 | 13509 | |
69e6ee2f HK |
13510 | ------------------------ |
13511 | -- Is_Safe_Activation -- | |
13512 | ------------------------ | |
8dce7371 | 13513 | |
69e6ee2f HK |
13514 | function Is_Safe_Activation |
13515 | (Call : Node_Id; | |
13516 | Task_Rep : Target_Rep_Id) return Boolean | |
13517 | is | |
8dce7371 | 13518 | begin |
69e6ee2f HK |
13519 | -- The activation of a task coming from an external instance cannot |
13520 | -- cause an ABE because the generic was already instantiated. Note | |
13521 | -- that the instantiation itself may lead to an ABE. | |
8dce7371 | 13522 | |
69e6ee2f HK |
13523 | return |
13524 | In_External_Instance | |
13525 | (N => Call, | |
13526 | Target_Decl => Spec_Declaration (Task_Rep)); | |
13527 | end Is_Safe_Activation; | |
13528 | ||
13529 | ------------------ | |
13530 | -- Is_Safe_Call -- | |
13531 | ------------------ | |
13532 | ||
13533 | function Is_Safe_Call | |
13534 | (Call : Node_Id; | |
13535 | Subp_Id : Entity_Id; | |
13536 | Subp_Rep : Target_Rep_Id) return Boolean | |
13537 | is | |
13538 | Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep); | |
13539 | Spec_Decl : constant Node_Id := Spec_Declaration (Subp_Rep); | |
8dce7371 | 13540 | |
69e6ee2f HK |
13541 | begin |
13542 | -- The target is either an abstract subprogram, formal subprogram, or | |
13543 | -- imported, in which case it does not have a body at compile or bind | |
13544 | -- time. Assume that the call is ABE-safe. | |
8dce7371 | 13545 | |
69e6ee2f HK |
13546 | if Is_Bodiless_Subprogram (Subp_Id) then |
13547 | return True; | |
8dce7371 | 13548 | |
69e6ee2f HK |
13549 | -- The target is an instantiation of a generic subprogram. The call |
13550 | -- cannot cause an ABE because the generic was already instantiated. | |
13551 | -- Note that the instantiation itself may lead to an ABE. | |
8dce7371 | 13552 | |
69e6ee2f HK |
13553 | elsif Is_Generic_Instance (Subp_Id) then |
13554 | return True; | |
8dce7371 | 13555 | |
69e6ee2f HK |
13556 | -- The invocation of a target coming from an external instance cannot |
13557 | -- cause an ABE because the generic was already instantiated. Note that | |
13558 | -- the instantiation itself may lead to an ABE. | |
8dce7371 | 13559 | |
69e6ee2f HK |
13560 | elsif In_External_Instance |
13561 | (N => Call, | |
13562 | Target_Decl => Spec_Decl) | |
13563 | then | |
13564 | return True; | |
8dce7371 | 13565 | |
69e6ee2f HK |
13566 | -- The target is a subprogram body without a previous declaration. The |
13567 | -- call cannot cause an ABE because the body has already been seen. | |
8dce7371 | 13568 | |
69e6ee2f HK |
13569 | elsif Nkind (Spec_Decl) = N_Subprogram_Body |
13570 | and then No (Corresponding_Spec (Spec_Decl)) | |
13571 | then | |
13572 | return True; | |
8dce7371 | 13573 | |
69e6ee2f HK |
13574 | -- The target is a subprogram body stub without a prior declaration. |
13575 | -- The call cannot cause an ABE because the proper body substitutes | |
13576 | -- the stub. | |
8dce7371 | 13577 | |
69e6ee2f HK |
13578 | elsif Nkind (Spec_Decl) = N_Subprogram_Body_Stub |
13579 | and then No (Corresponding_Spec_Of_Stub (Spec_Decl)) | |
13580 | then | |
13581 | return True; | |
8dce7371 | 13582 | |
69e6ee2f HK |
13583 | -- Subprogram bodies which wrap attribute references used as actuals |
13584 | -- in instantiations are always ABE-safe. These bodies are artifacts | |
13585 | -- of expansion. | |
8dce7371 | 13586 | |
69e6ee2f HK |
13587 | elsif Present (Body_Decl) |
13588 | and then Nkind (Body_Decl) = N_Subprogram_Body | |
13589 | and then Was_Attribute_Reference (Body_Decl) | |
13590 | then | |
13591 | return True; | |
8dce7371 | 13592 | end if; |
8dce7371 | 13593 | |
69e6ee2f HK |
13594 | return False; |
13595 | end Is_Safe_Call; | |
13596 | ||
13597 | --------------------------- | |
13598 | -- Is_Safe_Instantiation -- | |
13599 | --------------------------- | |
e9daba51 | 13600 | |
69e6ee2f HK |
13601 | function Is_Safe_Instantiation |
13602 | (Inst : Node_Id; | |
13603 | Gen_Id : Entity_Id; | |
13604 | Gen_Rep : Target_Rep_Id) return Boolean | |
e5148da0 | 13605 | is |
69e6ee2f | 13606 | Spec_Decl : constant Node_Id := Spec_Declaration (Gen_Rep); |
996ae0b0 | 13607 | |
69e6ee2f HK |
13608 | begin |
13609 | -- The generic is an intrinsic subprogram in which case it does not | |
13610 | -- have a body at compile or bind time. Assume that the instantiation | |
13611 | -- is ABE-safe. | |
996ae0b0 | 13612 | |
69e6ee2f HK |
13613 | if Is_Bodiless_Subprogram (Gen_Id) then |
13614 | return True; | |
6d158291 | 13615 | |
69e6ee2f HK |
13616 | -- The instantiation of an external nested generic cannot cause an ABE |
13617 | -- if the outer generic was already instantiated. Note that the instance | |
13618 | -- of the outer generic may lead to an ABE. | |
996ae0b0 | 13619 | |
69e6ee2f HK |
13620 | elsif In_External_Instance |
13621 | (N => Inst, | |
13622 | Target_Decl => Spec_Decl) | |
13623 | then | |
13624 | return True; | |
996ae0b0 | 13625 | |
69e6ee2f HK |
13626 | -- The generic is a package. The instantiation cannot cause an ABE when |
13627 | -- the package has no body. | |
996ae0b0 | 13628 | |
69e6ee2f HK |
13629 | elsif Ekind (Gen_Id) = E_Generic_Package |
13630 | and then not Has_Body (Spec_Decl) | |
13631 | then | |
13632 | return True; | |
13633 | end if; | |
996ae0b0 | 13634 | |
69e6ee2f HK |
13635 | return False; |
13636 | end Is_Safe_Instantiation; | |
996ae0b0 | 13637 | |
69e6ee2f HK |
13638 | ------------------ |
13639 | -- Is_Same_Unit -- | |
13640 | ------------------ | |
996ae0b0 | 13641 | |
69e6ee2f HK |
13642 | function Is_Same_Unit |
13643 | (Unit_1 : Entity_Id; | |
13644 | Unit_2 : Entity_Id) return Boolean | |
13645 | is | |
13646 | begin | |
13647 | return Unit_Entity (Unit_1) = Unit_Entity (Unit_2); | |
13648 | end Is_Same_Unit; | |
996ae0b0 | 13649 | |
69e6ee2f HK |
13650 | ------------------------------- |
13651 | -- Kill_Elaboration_Scenario -- | |
13652 | ------------------------------- | |
bde33286 | 13653 | |
69e6ee2f HK |
13654 | procedure Kill_Elaboration_Scenario (N : Node_Id) is |
13655 | begin | |
13656 | -- Nothing to do when switch -gnatH (legacy elaboration checking mode | |
13657 | -- enabled) is in effect because the legacy ABE lechanism does not need | |
13658 | -- to carry out this action. | |
bde33286 | 13659 | |
69e6ee2f HK |
13660 | if Legacy_Elaboration_Checks then |
13661 | return; | |
0839ffce HK |
13662 | |
13663 | -- Nothing to do when the elaboration phase of the compiler is not | |
13664 | -- active. | |
13665 | ||
13666 | elsif not Elaboration_Phase_Active then | |
13667 | return; | |
69e6ee2f | 13668 | end if; |
996ae0b0 | 13669 | |
69e6ee2f HK |
13670 | -- Eliminate a recorded scenario when it appears within dead code |
13671 | -- because it will not be executed at elaboration time. | |
162ed06f | 13672 | |
69e6ee2f HK |
13673 | if Is_Scenario (N) then |
13674 | Delete_Scenario (N); | |
13675 | end if; | |
13676 | end Kill_Elaboration_Scenario; | |
996ae0b0 | 13677 | |
3eb5e54a HK |
13678 | ---------------------- |
13679 | -- Main_Unit_Entity -- | |
13680 | ---------------------- | |
13681 | ||
13682 | function Main_Unit_Entity return Entity_Id is | |
13683 | begin | |
13684 | -- Note that Cunit_Entity (Main_Unit) is not reliable in the presence of | |
13685 | -- generic bodies and may return an outdated entity. | |
13686 | ||
13687 | return Defining_Entity (Unit (Cunit (Main_Unit))); | |
13688 | end Main_Unit_Entity; | |
13689 | ||
69e6ee2f HK |
13690 | ---------------------- |
13691 | -- Non_Private_View -- | |
13692 | ---------------------- | |
996ae0b0 | 13693 | |
69e6ee2f HK |
13694 | function Non_Private_View (Typ : Entity_Id) return Entity_Id is |
13695 | begin | |
13696 | if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then | |
13697 | return Full_View (Typ); | |
13698 | else | |
13699 | return Typ; | |
90e491a7 | 13700 | end if; |
69e6ee2f | 13701 | end Non_Private_View; |
996ae0b0 | 13702 | |
69e6ee2f HK |
13703 | --------------------------------- |
13704 | -- Record_Elaboration_Scenario -- | |
13705 | --------------------------------- | |
162ed06f | 13706 | |
69e6ee2f HK |
13707 | procedure Record_Elaboration_Scenario (N : Node_Id) is |
13708 | procedure Check_Preelaborated_Call | |
13709 | (Call : Node_Id; | |
13710 | Call_Lvl : Enclosing_Level_Kind); | |
13711 | pragma Inline (Check_Preelaborated_Call); | |
13712 | -- Verify that entry, operator, or subprogram call Call with enclosing | |
13713 | -- level Call_Lvl does not appear at the library level of preelaborated | |
13714 | -- unit. | |
162ed06f | 13715 | |
69e6ee2f HK |
13716 | function Find_Code_Unit (Nod : Node_Or_Entity_Id) return Entity_Id; |
13717 | pragma Inline (Find_Code_Unit); | |
13718 | -- Return the code unit which contains arbitrary node or entity Nod. | |
13719 | -- This is the unit of the file which physically contains the related | |
13720 | -- construct denoted by Nod except when Nod is within an instantiation. | |
13721 | -- In that case the unit is that of the top-level instantiation. | |
13722 | ||
13723 | function In_Preelaborated_Context (Nod : Node_Id) return Boolean; | |
13724 | pragma Inline (In_Preelaborated_Context); | |
13725 | -- Determine whether arbitrary node Nod appears within a preelaborated | |
13726 | -- context. | |
13727 | ||
13728 | procedure Record_Access_Taken | |
13729 | (Attr : Node_Id; | |
13730 | Attr_Lvl : Enclosing_Level_Kind); | |
13731 | pragma Inline (Record_Access_Taken); | |
13732 | -- Record 'Access scenario Attr with enclosing level Attr_Lvl | |
13733 | ||
13734 | procedure Record_Call_Or_Task_Activation | |
13735 | (Call : Node_Id; | |
13736 | Call_Lvl : Enclosing_Level_Kind); | |
13737 | pragma Inline (Record_Call_Or_Task_Activation); | |
13738 | -- Record call scenario Call with enclosing level Call_Lvl | |
13739 | ||
13740 | procedure Record_Instantiation | |
13741 | (Inst : Node_Id; | |
13742 | Inst_Lvl : Enclosing_Level_Kind); | |
13743 | pragma Inline (Record_Instantiation); | |
13744 | -- Record instantiation scenario Inst with enclosing level Inst_Lvl | |
13745 | ||
13746 | procedure Record_Variable_Assignment | |
13747 | (Asmt : Node_Id; | |
13748 | Asmt_Lvl : Enclosing_Level_Kind); | |
13749 | pragma Inline (Record_Variable_Assignment); | |
13750 | -- Record variable assignment scenario Asmt with enclosing level | |
13751 | -- Asmt_Lvl. | |
13752 | ||
13753 | procedure Record_Variable_Reference | |
13754 | (Ref : Node_Id; | |
13755 | Ref_Lvl : Enclosing_Level_Kind); | |
13756 | pragma Inline (Record_Variable_Reference); | |
13757 | -- Record variable reference scenario Ref with enclosing level Ref_Lvl | |
162ed06f | 13758 | |
69e6ee2f HK |
13759 | ------------------------------ |
13760 | -- Check_Preelaborated_Call -- | |
13761 | ------------------------------ | |
162ed06f | 13762 | |
69e6ee2f HK |
13763 | procedure Check_Preelaborated_Call |
13764 | (Call : Node_Id; | |
13765 | Call_Lvl : Enclosing_Level_Kind) | |
13766 | is | |
13767 | begin | |
13768 | -- Nothing to do when the call is internally generated because it is | |
13769 | -- assumed that it will never violate preelaboration. | |
996ae0b0 | 13770 | |
69e6ee2f HK |
13771 | if not Is_Source_Call (Call) then |
13772 | return; | |
996ae0b0 | 13773 | |
69e6ee2f HK |
13774 | -- Library-level calls are always considered because they are part of |
13775 | -- the associated unit's elaboration actions. | |
996ae0b0 | 13776 | |
69e6ee2f HK |
13777 | elsif Call_Lvl in Library_Level then |
13778 | null; | |
6c1e24d3 | 13779 | |
69e6ee2f HK |
13780 | -- Calls at the library level of a generic package body have to be |
13781 | -- checked because they would render an instantiation illegal if the | |
13782 | -- template is marked as preelaborated. Note that this does not apply | |
13783 | -- to calls at the library level of a generic package spec. | |
6c1e24d3 | 13784 | |
69e6ee2f HK |
13785 | elsif Call_Lvl = Generic_Body_Level then |
13786 | null; | |
6c1e24d3 | 13787 | |
69e6ee2f HK |
13788 | -- Otherwise the call does not appear at the proper level and must |
13789 | -- not be considered for this check. | |
6c1e24d3 | 13790 | |
69e6ee2f HK |
13791 | else |
13792 | return; | |
13793 | end if; | |
967947ed | 13794 | |
69e6ee2f HK |
13795 | -- The call appears within a preelaborated unit. Emit a warning only |
13796 | -- for internal uses, otherwise this is an error. | |
996ae0b0 | 13797 | |
69e6ee2f HK |
13798 | if In_Preelaborated_Context (Call) then |
13799 | Error_Msg_Warn := GNAT_Mode; | |
13800 | Error_Msg_N | |
13801 | ("<<non-static call not allowed in preelaborated unit", Call); | |
13802 | end if; | |
13803 | end Check_Preelaborated_Call; | |
8dce7371 | 13804 | |
69e6ee2f HK |
13805 | -------------------- |
13806 | -- Find_Code_Unit -- | |
13807 | -------------------- | |
967947ed | 13808 | |
69e6ee2f HK |
13809 | function Find_Code_Unit (Nod : Node_Or_Entity_Id) return Entity_Id is |
13810 | begin | |
13811 | return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (Nod)))); | |
13812 | end Find_Code_Unit; | |
967947ed | 13813 | |
69e6ee2f HK |
13814 | ------------------------------ |
13815 | -- In_Preelaborated_Context -- | |
13816 | ------------------------------ | |
8dce7371 | 13817 | |
69e6ee2f HK |
13818 | function In_Preelaborated_Context (Nod : Node_Id) return Boolean is |
13819 | Body_Id : constant Entity_Id := Find_Code_Unit (Nod); | |
13820 | Spec_Id : constant Entity_Id := Unique_Entity (Body_Id); | |
8dce7371 | 13821 | |
69e6ee2f HK |
13822 | begin |
13823 | -- The node appears within a package body whose corresponding spec is | |
13824 | -- subject to pragma Remote_Call_Interface or Remote_Types. This does | |
13825 | -- not result in a preelaborated context because the package body may | |
13826 | -- be on another machine. | |
8dce7371 | 13827 | |
69e6ee2f | 13828 | if Ekind (Body_Id) = E_Package_Body |
a92db262 | 13829 | and then Is_Package_Or_Generic_Package (Spec_Id) |
69e6ee2f HK |
13830 | and then (Is_Remote_Call_Interface (Spec_Id) |
13831 | or else Is_Remote_Types (Spec_Id)) | |
13832 | then | |
13833 | return False; | |
8dce7371 | 13834 | |
69e6ee2f HK |
13835 | -- Otherwise the node appears within a preelaborated context when the |
13836 | -- associated unit is preelaborated. | |
8dce7371 | 13837 | |
69e6ee2f HK |
13838 | else |
13839 | return Is_Preelaborated_Unit (Spec_Id); | |
13840 | end if; | |
13841 | end In_Preelaborated_Context; | |
8dce7371 | 13842 | |
69e6ee2f HK |
13843 | ------------------------- |
13844 | -- Record_Access_Taken -- | |
13845 | ------------------------- | |
8dce7371 | 13846 | |
69e6ee2f HK |
13847 | procedure Record_Access_Taken |
13848 | (Attr : Node_Id; | |
13849 | Attr_Lvl : Enclosing_Level_Kind) | |
13850 | is | |
13851 | begin | |
13852 | -- Signal any enclosing local exception handlers that the 'Access may | |
13853 | -- raise Program_Error due to a failed ABE check when switch -gnatd.o | |
13854 | -- (conservative elaboration order for indirect calls) is in effect. | |
13855 | -- Marking the exception handlers ensures proper expansion by both | |
13856 | -- the front and back end restriction when No_Exception_Propagation | |
13857 | -- is in effect. | |
8dce7371 | 13858 | |
69e6ee2f HK |
13859 | if Debug_Flag_Dot_O then |
13860 | Possible_Local_Raise (Attr, Standard_Program_Error); | |
13861 | end if; | |
8dce7371 | 13862 | |
69e6ee2f | 13863 | -- Add 'Access to the appropriate set |
8dce7371 | 13864 | |
69e6ee2f HK |
13865 | if Attr_Lvl = Library_Body_Level then |
13866 | Add_Library_Body_Scenario (Attr); | |
8dce7371 | 13867 | |
69e6ee2f HK |
13868 | elsif Attr_Lvl = Library_Spec_Level |
13869 | or else Attr_Lvl = Instantiation_Level | |
13870 | then | |
13871 | Add_Library_Spec_Scenario (Attr); | |
13872 | end if; | |
8dce7371 | 13873 | |
69e6ee2f HK |
13874 | -- 'Access requires a conditional ABE check when the dynamic model is |
13875 | -- in effect. | |
162ed06f | 13876 | |
69e6ee2f HK |
13877 | Add_Dynamic_ABE_Check_Scenario (Attr); |
13878 | end Record_Access_Taken; | |
162ed06f | 13879 | |
69e6ee2f HK |
13880 | ------------------------------------ |
13881 | -- Record_Call_Or_Task_Activation -- | |
13882 | ------------------------------------ | |
8dce7371 | 13883 | |
69e6ee2f HK |
13884 | procedure Record_Call_Or_Task_Activation |
13885 | (Call : Node_Id; | |
13886 | Call_Lvl : Enclosing_Level_Kind) | |
13887 | is | |
13888 | begin | |
13889 | -- Signal any enclosing local exception handlers that the call may | |
13890 | -- raise Program_Error due to failed ABE check. Marking the exception | |
13891 | -- handlers ensures proper expansion by both the front and back end | |
13892 | -- restriction when No_Exception_Propagation is in effect. | |
8dce7371 | 13893 | |
69e6ee2f | 13894 | Possible_Local_Raise (Call, Standard_Program_Error); |
8dce7371 | 13895 | |
69e6ee2f HK |
13896 | -- Perform early detection of guaranteed ABEs in order to suppress |
13897 | -- the instantiation of generic bodies because gigi cannot handle | |
13898 | -- certain types of premature instantiations. | |
8dce7371 | 13899 | |
69e6ee2f HK |
13900 | Process_Guaranteed_ABE |
13901 | (N => Call, | |
13902 | In_State => Guaranteed_ABE_State); | |
8dce7371 | 13903 | |
69e6ee2f | 13904 | -- Add the call or task activation to the appropriate set |
8dce7371 | 13905 | |
69e6ee2f HK |
13906 | if Call_Lvl = Declaration_Level then |
13907 | Add_Declaration_Scenario (Call); | |
967947ed | 13908 | |
69e6ee2f HK |
13909 | elsif Call_Lvl = Library_Body_Level then |
13910 | Add_Library_Body_Scenario (Call); | |
967947ed | 13911 | |
69e6ee2f HK |
13912 | elsif Call_Lvl = Library_Spec_Level |
13913 | or else Call_Lvl = Instantiation_Level | |
13914 | then | |
13915 | Add_Library_Spec_Scenario (Call); | |
8dce7371 PMR |
13916 | end if; |
13917 | ||
69e6ee2f HK |
13918 | -- A call or a task activation requires a conditional ABE check when |
13919 | -- the dynamic model is in effect. | |
8dce7371 | 13920 | |
69e6ee2f HK |
13921 | Add_Dynamic_ABE_Check_Scenario (Call); |
13922 | end Record_Call_Or_Task_Activation; | |
13923 | ||
13924 | -------------------------- | |
13925 | -- Record_Instantiation -- | |
13926 | -------------------------- | |
8dce7371 | 13927 | |
69e6ee2f HK |
13928 | procedure Record_Instantiation |
13929 | (Inst : Node_Id; | |
13930 | Inst_Lvl : Enclosing_Level_Kind) | |
13931 | is | |
13932 | begin | |
13933 | -- Signal enclosing local exception handlers that instantiation may | |
13934 | -- raise Program_Error due to failed ABE check. Marking the exception | |
13935 | -- handlers ensures proper expansion by both the front and back end | |
13936 | -- restriction when No_Exception_Propagation is in effect. | |
8dce7371 | 13937 | |
69e6ee2f | 13938 | Possible_Local_Raise (Inst, Standard_Program_Error); |
8dce7371 | 13939 | |
69e6ee2f HK |
13940 | -- Perform early detection of guaranteed ABEs in order to suppress |
13941 | -- the instantiation of generic bodies because gigi cannot handle | |
13942 | -- certain types of premature instantiations. | |
8dce7371 | 13943 | |
69e6ee2f HK |
13944 | Process_Guaranteed_ABE |
13945 | (N => Inst, | |
13946 | In_State => Guaranteed_ABE_State); | |
8dce7371 | 13947 | |
69e6ee2f | 13948 | -- Add the instantiation to the appropriate set |
8dce7371 | 13949 | |
69e6ee2f HK |
13950 | if Inst_Lvl = Declaration_Level then |
13951 | Add_Declaration_Scenario (Inst); | |
8dce7371 | 13952 | |
69e6ee2f HK |
13953 | elsif Inst_Lvl = Library_Body_Level then |
13954 | Add_Library_Body_Scenario (Inst); | |
8dce7371 | 13955 | |
69e6ee2f HK |
13956 | elsif Inst_Lvl = Library_Spec_Level |
13957 | or else Inst_Lvl = Instantiation_Level | |
13958 | then | |
13959 | Add_Library_Spec_Scenario (Inst); | |
13960 | end if; | |
13961 | ||
13962 | -- Instantiations of generics subject to SPARK_Mode On require | |
13963 | -- elaboration-related checks even though the instantiations may | |
13964 | -- not appear within elaboration code. | |
13965 | ||
13966 | if Is_Suitable_SPARK_Instantiation (Inst) then | |
13967 | Add_SPARK_Scenario (Inst); | |
13968 | end if; | |
13969 | ||
13970 | -- An instantiation requires a conditional ABE check when the dynamic | |
13971 | -- model is in effect. | |
8dce7371 | 13972 | |
69e6ee2f HK |
13973 | Add_Dynamic_ABE_Check_Scenario (Inst); |
13974 | end Record_Instantiation; | |
13975 | ||
13976 | -------------------------------- | |
13977 | -- Record_Variable_Assignment -- | |
13978 | -------------------------------- | |
13979 | ||
13980 | procedure Record_Variable_Assignment | |
13981 | (Asmt : Node_Id; | |
13982 | Asmt_Lvl : Enclosing_Level_Kind) | |
13983 | is | |
13984 | begin | |
13985 | -- Add the variable assignment to the appropriate set | |
13986 | ||
13987 | if Asmt_Lvl = Library_Body_Level then | |
13988 | Add_Library_Body_Scenario (Asmt); | |
13989 | ||
13990 | elsif Asmt_Lvl = Library_Spec_Level | |
13991 | or else Asmt_Lvl = Instantiation_Level | |
13992 | then | |
13993 | Add_Library_Spec_Scenario (Asmt); | |
13994 | end if; | |
13995 | end Record_Variable_Assignment; | |
8dce7371 PMR |
13996 | |
13997 | ------------------------------- | |
69e6ee2f | 13998 | -- Record_Variable_Reference -- |
8dce7371 | 13999 | ------------------------------- |
996ae0b0 | 14000 | |
69e6ee2f HK |
14001 | procedure Record_Variable_Reference |
14002 | (Ref : Node_Id; | |
14003 | Ref_Lvl : Enclosing_Level_Kind) | |
14004 | is | |
90e491a7 | 14005 | begin |
69e6ee2f | 14006 | -- Add the variable reference to the appropriate set |
996ae0b0 | 14007 | |
69e6ee2f HK |
14008 | if Ref_Lvl = Library_Body_Level then |
14009 | Add_Library_Body_Scenario (Ref); | |
a6d25cad | 14010 | |
69e6ee2f HK |
14011 | elsif Ref_Lvl = Library_Spec_Level |
14012 | or else Ref_Lvl = Instantiation_Level | |
14013 | then | |
14014 | Add_Library_Spec_Scenario (Ref); | |
14015 | end if; | |
14016 | end Record_Variable_Reference; | |
996ae0b0 | 14017 | |
69e6ee2f | 14018 | -- Local variables |
996ae0b0 | 14019 | |
69e6ee2f HK |
14020 | Scen : constant Node_Id := Scenario (N); |
14021 | Scen_Lvl : Enclosing_Level_Kind; | |
996ae0b0 | 14022 | |
69e6ee2f | 14023 | -- Start of processing for Record_Elaboration_Scenario |
996ae0b0 | 14024 | |
69e6ee2f HK |
14025 | begin |
14026 | -- Nothing to do when switch -gnatH (legacy elaboration checking mode | |
14027 | -- enabled) is in effect because the legacy ABE mechanism does not need | |
14028 | -- to carry out this action. | |
996ae0b0 | 14029 | |
69e6ee2f HK |
14030 | if Legacy_Elaboration_Checks then |
14031 | return; | |
996ae0b0 | 14032 | |
69e6ee2f HK |
14033 | -- Nothing to do for ASIS because ABE checks and diagnostics are not |
14034 | -- performed in this mode. | |
996ae0b0 | 14035 | |
69e6ee2f HK |
14036 | elsif ASIS_Mode then |
14037 | return; | |
996ae0b0 | 14038 | |
69e6ee2f | 14039 | -- Nothing to do when the scenario is being preanalyzed |
996ae0b0 | 14040 | |
69e6ee2f HK |
14041 | elsif Preanalysis_Active then |
14042 | return; | |
0839ffce HK |
14043 | |
14044 | -- Nothing to do when the elaboration phase of the compiler is not | |
14045 | -- active. | |
14046 | ||
14047 | elsif not Elaboration_Phase_Active then | |
14048 | return; | |
69e6ee2f | 14049 | end if; |
996ae0b0 | 14050 | |
69e6ee2f | 14051 | Scen_Lvl := Find_Enclosing_Level (Scen); |
996ae0b0 | 14052 | |
69e6ee2f HK |
14053 | -- Ensure that a library-level call does not appear in a preelaborated |
14054 | -- unit. The check must come before ignoring scenarios within external | |
14055 | -- units or inside generics because calls in those context must also be | |
14056 | -- verified. | |
fbf5a39b | 14057 | |
69e6ee2f HK |
14058 | if Is_Suitable_Call (Scen) then |
14059 | Check_Preelaborated_Call (Scen, Scen_Lvl); | |
14060 | end if; | |
fbf5a39b | 14061 | |
69e6ee2f HK |
14062 | -- Nothing to do when the scenario does not appear within the main unit |
14063 | ||
14064 | if not In_Main_Context (Scen) then | |
14065 | return; | |
14066 | ||
14067 | -- Nothing to do when the scenario appears within a generic | |
fbf5a39b | 14068 | |
69e6ee2f HK |
14069 | elsif Inside_A_Generic then |
14070 | return; | |
fbf5a39b | 14071 | |
69e6ee2f | 14072 | -- 'Access |
967947ed | 14073 | |
69e6ee2f HK |
14074 | elsif Is_Suitable_Access_Taken (Scen) then |
14075 | Record_Access_Taken | |
14076 | (Attr => Scen, | |
14077 | Attr_Lvl => Scen_Lvl); | |
a5abb241 | 14078 | |
69e6ee2f | 14079 | -- Call or task activation |
fbf5a39b | 14080 | |
69e6ee2f HK |
14081 | elsif Is_Suitable_Call (Scen) then |
14082 | Record_Call_Or_Task_Activation | |
14083 | (Call => Scen, | |
14084 | Call_Lvl => Scen_Lvl); | |
fbf5a39b | 14085 | |
69e6ee2f | 14086 | -- Derived type declaration |
fbf5a39b | 14087 | |
69e6ee2f HK |
14088 | elsif Is_Suitable_SPARK_Derived_Type (Scen) then |
14089 | Add_SPARK_Scenario (Scen); | |
fbf5a39b | 14090 | |
69e6ee2f HK |
14091 | -- Instantiation |
14092 | ||
14093 | elsif Is_Suitable_Instantiation (Scen) then | |
14094 | Record_Instantiation | |
14095 | (Inst => Scen, | |
14096 | Inst_Lvl => Scen_Lvl); | |
14097 | ||
14098 | -- Refined_State pragma | |
14099 | ||
14100 | elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then | |
14101 | Add_SPARK_Scenario (Scen); | |
14102 | ||
14103 | -- Variable assignment | |
14104 | ||
14105 | elsif Is_Suitable_Variable_Assignment (Scen) then | |
14106 | Record_Variable_Assignment | |
14107 | (Asmt => Scen, | |
14108 | Asmt_Lvl => Scen_Lvl); | |
14109 | ||
14110 | -- Variable reference | |
14111 | ||
14112 | elsif Is_Suitable_Variable_Reference (Scen) then | |
14113 | Record_Variable_Reference | |
14114 | (Ref => Scen, | |
14115 | Ref_Lvl => Scen_Lvl); | |
fbf5a39b | 14116 | end if; |
69e6ee2f | 14117 | end Record_Elaboration_Scenario; |
90e491a7 | 14118 | |
69e6ee2f HK |
14119 | -------------- |
14120 | -- Scenario -- | |
14121 | -------------- | |
14122 | ||
14123 | function Scenario (N : Node_Id) return Node_Id is | |
14124 | Orig_N : constant Node_Id := Original_Node (N); | |
90e491a7 | 14125 | |
69e6ee2f HK |
14126 | begin |
14127 | -- An expanded instantiation is rewritten into a spec-body pair where | |
14128 | -- N denotes the spec. In this case the original instantiation is the | |
14129 | -- proper elaboration scenario. | |
a5abb241 | 14130 | |
69e6ee2f HK |
14131 | if Nkind (Orig_N) in N_Generic_Instantiation then |
14132 | return Orig_N; | |
a5abb241 | 14133 | |
69e6ee2f | 14134 | -- Otherwise the scenario is already in its proper form |
a5abb241 | 14135 | |
69e6ee2f HK |
14136 | else |
14137 | return N; | |
a5abb241 | 14138 | end if; |
69e6ee2f | 14139 | end Scenario; |
a5abb241 | 14140 | |
69e6ee2f HK |
14141 | ---------------------- |
14142 | -- Scenario_Storage -- | |
14143 | ---------------------- | |
967947ed | 14144 | |
69e6ee2f | 14145 | package body Scenario_Storage is |
967947ed | 14146 | |
69e6ee2f HK |
14147 | --------------------- |
14148 | -- Data structures -- | |
14149 | --------------------- | |
a5abb241 | 14150 | |
69e6ee2f | 14151 | -- The following sets store all scenarios |
a5abb241 | 14152 | |
0839ffce HK |
14153 | Declaration_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; |
14154 | Dynamic_ABE_Check_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; | |
14155 | Library_Body_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; | |
14156 | Library_Spec_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; | |
14157 | SPARK_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; | |
8dce7371 | 14158 | |
69e6ee2f HK |
14159 | ------------------------------- |
14160 | -- Finalize_Scenario_Storage -- | |
14161 | ------------------------------- | |
8dce7371 | 14162 | |
69e6ee2f HK |
14163 | procedure Finalize_Scenario_Storage is |
14164 | begin | |
14165 | NE_Set.Destroy (Declaration_Scenarios); | |
14166 | NE_Set.Destroy (Dynamic_ABE_Check_Scenarios); | |
14167 | NE_Set.Destroy (Library_Body_Scenarios); | |
14168 | NE_Set.Destroy (Library_Spec_Scenarios); | |
14169 | NE_Set.Destroy (SPARK_Scenarios); | |
14170 | end Finalize_Scenario_Storage; | |
14171 | ||
14172 | --------------------------------- | |
14173 | -- Initialize_Scenario_Storage -- | |
14174 | --------------------------------- | |
14175 | ||
14176 | procedure Initialize_Scenario_Storage is | |
14177 | begin | |
0839ffce HK |
14178 | Declaration_Scenarios := NE_Set.Create (1000); |
14179 | Dynamic_ABE_Check_Scenarios := NE_Set.Create (500); | |
14180 | Library_Body_Scenarios := NE_Set.Create (1000); | |
14181 | Library_Spec_Scenarios := NE_Set.Create (1000); | |
14182 | SPARK_Scenarios := NE_Set.Create (100); | |
69e6ee2f | 14183 | end Initialize_Scenario_Storage; |
967947ed | 14184 | |
69e6ee2f HK |
14185 | ------------------------------ |
14186 | -- Add_Declaration_Scenario -- | |
14187 | ------------------------------ | |
162ed06f | 14188 | |
69e6ee2f HK |
14189 | procedure Add_Declaration_Scenario (N : Node_Id) is |
14190 | pragma Assert (Present (N)); | |
14191 | begin | |
14192 | NE_Set.Insert (Declaration_Scenarios, N); | |
14193 | end Add_Declaration_Scenario; | |
162ed06f | 14194 | |
69e6ee2f HK |
14195 | ------------------------------------ |
14196 | -- Add_Dynamic_ABE_Check_Scenario -- | |
14197 | ------------------------------------ | |
967947ed | 14198 | |
69e6ee2f HK |
14199 | procedure Add_Dynamic_ABE_Check_Scenario (N : Node_Id) is |
14200 | pragma Assert (Present (N)); | |
967947ed | 14201 | |
69e6ee2f HK |
14202 | begin |
14203 | if not Check_Or_Failure_Generation_OK then | |
14204 | return; | |
967947ed | 14205 | |
69e6ee2f | 14206 | -- Nothing to do if the dynamic model is not in effect |
8dce7371 | 14207 | |
69e6ee2f HK |
14208 | elsif not Dynamic_Elaboration_Checks then |
14209 | return; | |
14210 | end if; | |
8dce7371 | 14211 | |
69e6ee2f HK |
14212 | NE_Set.Insert (Dynamic_ABE_Check_Scenarios, N); |
14213 | end Add_Dynamic_ABE_Check_Scenario; | |
8dce7371 | 14214 | |
69e6ee2f HK |
14215 | ------------------------------- |
14216 | -- Add_Library_Body_Scenario -- | |
14217 | ------------------------------- | |
8dce7371 | 14218 | |
69e6ee2f HK |
14219 | procedure Add_Library_Body_Scenario (N : Node_Id) is |
14220 | pragma Assert (Present (N)); | |
14221 | begin | |
14222 | NE_Set.Insert (Library_Body_Scenarios, N); | |
14223 | end Add_Library_Body_Scenario; | |
8dce7371 | 14224 | |
69e6ee2f HK |
14225 | ------------------------------- |
14226 | -- Add_Library_Spec_Scenario -- | |
14227 | ------------------------------- | |
8dce7371 | 14228 | |
69e6ee2f HK |
14229 | procedure Add_Library_Spec_Scenario (N : Node_Id) is |
14230 | pragma Assert (Present (N)); | |
14231 | begin | |
14232 | NE_Set.Insert (Library_Spec_Scenarios, N); | |
14233 | end Add_Library_Spec_Scenario; | |
8dce7371 | 14234 | |
69e6ee2f HK |
14235 | ------------------------ |
14236 | -- Add_SPARK_Scenario -- | |
14237 | ------------------------ | |
8dce7371 | 14238 | |
69e6ee2f HK |
14239 | procedure Add_SPARK_Scenario (N : Node_Id) is |
14240 | pragma Assert (Present (N)); | |
14241 | begin | |
14242 | NE_Set.Insert (SPARK_Scenarios, N); | |
14243 | end Add_SPARK_Scenario; | |
8dce7371 | 14244 | |
69e6ee2f HK |
14245 | --------------------- |
14246 | -- Delete_Scenario -- | |
14247 | --------------------- | |
a5abb241 | 14248 | |
69e6ee2f HK |
14249 | procedure Delete_Scenario (N : Node_Id) is |
14250 | pragma Assert (Present (N)); | |
a5abb241 | 14251 | |
69e6ee2f HK |
14252 | begin |
14253 | -- Delete the scenario from whichever set it belongs to | |
967947ed | 14254 | |
69e6ee2f HK |
14255 | NE_Set.Delete (Declaration_Scenarios, N); |
14256 | NE_Set.Delete (Dynamic_ABE_Check_Scenarios, N); | |
14257 | NE_Set.Delete (Library_Body_Scenarios, N); | |
14258 | NE_Set.Delete (Library_Spec_Scenarios, N); | |
14259 | NE_Set.Delete (SPARK_Scenarios, N); | |
14260 | end Delete_Scenario; | |
a5abb241 | 14261 | |
69e6ee2f HK |
14262 | ----------------------------------- |
14263 | -- Iterate_Declaration_Scenarios -- | |
14264 | ----------------------------------- | |
a5abb241 | 14265 | |
69e6ee2f HK |
14266 | function Iterate_Declaration_Scenarios return NE_Set.Iterator is |
14267 | begin | |
14268 | return NE_Set.Iterate (Declaration_Scenarios); | |
14269 | end Iterate_Declaration_Scenarios; | |
a5abb241 | 14270 | |
69e6ee2f HK |
14271 | ----------------------------------------- |
14272 | -- Iterate_Dynamic_ABE_Check_Scenarios -- | |
14273 | ----------------------------------------- | |
a5abb241 | 14274 | |
69e6ee2f HK |
14275 | function Iterate_Dynamic_ABE_Check_Scenarios return NE_Set.Iterator is |
14276 | begin | |
14277 | return NE_Set.Iterate (Dynamic_ABE_Check_Scenarios); | |
14278 | end Iterate_Dynamic_ABE_Check_Scenarios; | |
a5abb241 | 14279 | |
69e6ee2f HK |
14280 | ------------------------------------ |
14281 | -- Iterate_Library_Body_Scenarios -- | |
14282 | ------------------------------------ | |
a5abb241 | 14283 | |
69e6ee2f HK |
14284 | function Iterate_Library_Body_Scenarios return NE_Set.Iterator is |
14285 | begin | |
14286 | return NE_Set.Iterate (Library_Body_Scenarios); | |
14287 | end Iterate_Library_Body_Scenarios; | |
a5abb241 | 14288 | |
69e6ee2f HK |
14289 | ------------------------------------ |
14290 | -- Iterate_Library_Spec_Scenarios -- | |
14291 | ------------------------------------ | |
162ed06f | 14292 | |
69e6ee2f HK |
14293 | function Iterate_Library_Spec_Scenarios return NE_Set.Iterator is |
14294 | begin | |
14295 | return NE_Set.Iterate (Library_Spec_Scenarios); | |
14296 | end Iterate_Library_Spec_Scenarios; | |
162ed06f | 14297 | |
69e6ee2f HK |
14298 | ----------------------------- |
14299 | -- Iterate_SPARK_Scenarios -- | |
14300 | ----------------------------- | |
e5148da0 | 14301 | |
69e6ee2f HK |
14302 | function Iterate_SPARK_Scenarios return NE_Set.Iterator is |
14303 | begin | |
14304 | return NE_Set.Iterate (SPARK_Scenarios); | |
14305 | end Iterate_SPARK_Scenarios; | |
e5148da0 | 14306 | |
69e6ee2f HK |
14307 | ---------------------- |
14308 | -- Replace_Scenario -- | |
14309 | ---------------------- | |
a5abb241 | 14310 | |
69e6ee2f HK |
14311 | procedure Replace_Scenario (Old_N : Node_Id; New_N : Node_Id) is |
14312 | procedure Replace_Scenario_In (Scenarios : NE_Set.Membership_Set); | |
14313 | -- Determine whether scenario Old_N is present in set Scenarios, and | |
14314 | -- if this is the case it, replace it with New_N. | |
14315 | ||
14316 | ------------------------- | |
14317 | -- Replace_Scenario_In -- | |
14318 | ------------------------- | |
14319 | ||
14320 | procedure Replace_Scenario_In (Scenarios : NE_Set.Membership_Set) is | |
14321 | begin | |
14322 | -- The set is intentionally checked for existance because node | |
14323 | -- rewriting may occur after Sem_Elab has verified all scenarios | |
14324 | -- and data structures have been destroyed. | |
a5abb241 | 14325 | |
69e6ee2f HK |
14326 | if NE_Set.Present (Scenarios) |
14327 | and then NE_Set.Contains (Scenarios, Old_N) | |
14328 | then | |
14329 | NE_Set.Delete (Scenarios, Old_N); | |
14330 | NE_Set.Insert (Scenarios, New_N); | |
90e491a7 | 14331 | end if; |
69e6ee2f | 14332 | end Replace_Scenario_In; |
a5abb241 | 14333 | |
69e6ee2f | 14334 | -- Start of processing for Replace_Scenario |
a5abb241 | 14335 | |
69e6ee2f HK |
14336 | begin |
14337 | Replace_Scenario_In (Declaration_Scenarios); | |
14338 | Replace_Scenario_In (Dynamic_ABE_Check_Scenarios); | |
14339 | Replace_Scenario_In (Library_Body_Scenarios); | |
14340 | Replace_Scenario_In (Library_Spec_Scenarios); | |
14341 | Replace_Scenario_In (SPARK_Scenarios); | |
14342 | end Replace_Scenario; | |
14343 | end Scenario_Storage; | |
967947ed | 14344 | |
69e6ee2f HK |
14345 | --------------- |
14346 | -- Semantics -- | |
14347 | --------------- | |
967947ed | 14348 | |
69e6ee2f | 14349 | package body Semantics is |
a5abb241 | 14350 | |
69e6ee2f HK |
14351 | -------------------------------- |
14352 | -- Is_Accept_Alternative_Proc -- | |
14353 | -------------------------------- | |
a5abb241 | 14354 | |
69e6ee2f HK |
14355 | function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is |
14356 | begin | |
14357 | -- To qualify, the entity must denote a procedure with a receiving | |
14358 | -- entry. | |
a5abb241 | 14359 | |
69e6ee2f HK |
14360 | return |
14361 | Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id)); | |
14362 | end Is_Accept_Alternative_Proc; | |
90e491a7 | 14363 | |
69e6ee2f HK |
14364 | ------------------------ |
14365 | -- Is_Activation_Proc -- | |
14366 | ------------------------ | |
14367 | ||
14368 | function Is_Activation_Proc (Id : Entity_Id) return Boolean is | |
14369 | begin | |
14370 | -- To qualify, the entity must denote one of the runtime procedures | |
14371 | -- in charge of task activation. | |
14372 | ||
14373 | if Ekind (Id) = E_Procedure then | |
14374 | if Restricted_Profile then | |
14375 | return Is_RTE (Id, RE_Activate_Restricted_Tasks); | |
14376 | else | |
14377 | return Is_RTE (Id, RE_Activate_Tasks); | |
14378 | end if; | |
14379 | end if; | |
14380 | ||
14381 | return False; | |
14382 | end Is_Activation_Proc; | |
a5abb241 | 14383 | |
69e6ee2f HK |
14384 | ---------------------------- |
14385 | -- Is_Ada_Semantic_Target -- | |
14386 | ---------------------------- | |
90e491a7 | 14387 | |
69e6ee2f HK |
14388 | function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean is |
14389 | begin | |
14390 | return | |
14391 | Is_Activation_Proc (Id) | |
14392 | or else Is_Controlled_Proc (Id, Name_Adjust) | |
14393 | or else Is_Controlled_Proc (Id, Name_Finalize) | |
14394 | or else Is_Controlled_Proc (Id, Name_Initialize) | |
14395 | or else Is_Init_Proc (Id) | |
14396 | or else Is_Invariant_Proc (Id) | |
14397 | or else Is_Protected_Entry (Id) | |
14398 | or else Is_Protected_Subp (Id) | |
14399 | or else Is_Protected_Body_Subp (Id) | |
14400 | or else Is_Subprogram_Inst (Id) | |
14401 | or else Is_Task_Entry (Id); | |
14402 | end Is_Ada_Semantic_Target; | |
54740d7d | 14403 | |
69e6ee2f HK |
14404 | -------------------------------- |
14405 | -- Is_Assertion_Pragma_Target -- | |
14406 | -------------------------------- | |
b91f986b | 14407 | |
69e6ee2f HK |
14408 | function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean is |
14409 | begin | |
14410 | return | |
14411 | Is_Default_Initial_Condition_Proc (Id) | |
14412 | or else Is_Initial_Condition_Proc (Id) | |
14413 | or else Is_Invariant_Proc (Id) | |
14414 | or else Is_Partial_Invariant_Proc (Id) | |
14415 | or else Is_Postconditions_Proc (Id); | |
14416 | end Is_Assertion_Pragma_Target; | |
b91f986b | 14417 | |
69e6ee2f HK |
14418 | ---------------------------- |
14419 | -- Is_Bodiless_Subprogram -- | |
14420 | ---------------------------- | |
90e491a7 | 14421 | |
69e6ee2f HK |
14422 | function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is |
14423 | begin | |
14424 | -- An abstract subprogram does not have a body | |
996ae0b0 | 14425 | |
69e6ee2f HK |
14426 | if Ekind_In (Subp_Id, E_Function, |
14427 | E_Operator, | |
14428 | E_Procedure) | |
14429 | and then Is_Abstract_Subprogram (Subp_Id) | |
14430 | then | |
14431 | return True; | |
996ae0b0 | 14432 | |
69e6ee2f | 14433 | -- A formal subprogram does not have a body |
162ed06f | 14434 | |
69e6ee2f HK |
14435 | elsif Is_Formal_Subprogram (Subp_Id) then |
14436 | return True; | |
162ed06f | 14437 | |
69e6ee2f HK |
14438 | -- An imported subprogram may have a body, however it is not known at |
14439 | -- compile or bind time where the body resides and whether it will be | |
14440 | -- elaborated on time. | |
90e491a7 | 14441 | |
69e6ee2f HK |
14442 | elsif Is_Imported (Subp_Id) then |
14443 | return True; | |
14444 | end if; | |
e5148da0 | 14445 | |
69e6ee2f HK |
14446 | return False; |
14447 | end Is_Bodiless_Subprogram; | |
e5148da0 | 14448 | |
69e6ee2f HK |
14449 | ---------------------- |
14450 | -- Is_Bridge_Target -- | |
14451 | ---------------------- | |
e5148da0 | 14452 | |
69e6ee2f HK |
14453 | function Is_Bridge_Target (Id : Entity_Id) return Boolean is |
14454 | begin | |
14455 | return | |
14456 | Is_Accept_Alternative_Proc (Id) | |
14457 | or else Is_Finalizer_Proc (Id) | |
14458 | or else Is_Partial_Invariant_Proc (Id) | |
14459 | or else Is_Postconditions_Proc (Id) | |
14460 | or else Is_TSS (Id, TSS_Deep_Adjust) | |
14461 | or else Is_TSS (Id, TSS_Deep_Finalize) | |
14462 | or else Is_TSS (Id, TSS_Deep_Initialize); | |
14463 | end Is_Bridge_Target; | |
e5148da0 | 14464 | |
69e6ee2f HK |
14465 | ------------------------ |
14466 | -- Is_Controlled_Proc -- | |
14467 | ------------------------ | |
e5148da0 | 14468 | |
69e6ee2f HK |
14469 | function Is_Controlled_Proc |
14470 | (Subp_Id : Entity_Id; | |
14471 | Subp_Nam : Name_Id) return Boolean | |
14472 | is | |
14473 | Formal_Id : Entity_Id; | |
e5148da0 | 14474 | |
69e6ee2f HK |
14475 | begin |
14476 | pragma Assert (Nam_In (Subp_Nam, Name_Adjust, | |
14477 | Name_Finalize, | |
14478 | Name_Initialize)); | |
e5148da0 | 14479 | |
69e6ee2f HK |
14480 | -- To qualify, the subprogram must denote a source procedure with |
14481 | -- name Adjust, Finalize, or Initialize where the sole formal is | |
14482 | -- controlled. | |
e5148da0 | 14483 | |
69e6ee2f HK |
14484 | if Comes_From_Source (Subp_Id) |
14485 | and then Ekind (Subp_Id) = E_Procedure | |
14486 | and then Chars (Subp_Id) = Subp_Nam | |
14487 | then | |
14488 | Formal_Id := First_Formal (Subp_Id); | |
e5148da0 | 14489 | |
69e6ee2f HK |
14490 | return |
14491 | Present (Formal_Id) | |
14492 | and then Is_Controlled (Etype (Formal_Id)) | |
14493 | and then No (Next_Formal (Formal_Id)); | |
14494 | end if; | |
e5148da0 | 14495 | |
69e6ee2f HK |
14496 | return False; |
14497 | end Is_Controlled_Proc; | |
e5148da0 | 14498 | |
69e6ee2f HK |
14499 | --------------------------------------- |
14500 | -- Is_Default_Initial_Condition_Proc -- | |
14501 | --------------------------------------- | |
e5148da0 | 14502 | |
69e6ee2f HK |
14503 | function Is_Default_Initial_Condition_Proc |
14504 | (Id : Entity_Id) return Boolean | |
14505 | is | |
14506 | begin | |
14507 | -- To qualify, the entity must denote a Default_Initial_Condition | |
14508 | -- procedure. | |
e5148da0 | 14509 | |
69e6ee2f HK |
14510 | return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id); |
14511 | end Is_Default_Initial_Condition_Proc; | |
e5148da0 | 14512 | |
69e6ee2f HK |
14513 | ----------------------- |
14514 | -- Is_Finalizer_Proc -- | |
14515 | ----------------------- | |
e5148da0 | 14516 | |
69e6ee2f HK |
14517 | function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is |
14518 | begin | |
14519 | -- To qualify, the entity must denote a _Finalizer procedure | |
e5148da0 | 14520 | |
69e6ee2f HK |
14521 | return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer; |
14522 | end Is_Finalizer_Proc; | |
e5148da0 | 14523 | |
69e6ee2f HK |
14524 | ------------------------------- |
14525 | -- Is_Initial_Condition_Proc -- | |
14526 | ------------------------------- | |
e5148da0 | 14527 | |
69e6ee2f HK |
14528 | function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is |
14529 | begin | |
14530 | -- To qualify, the entity must denote an Initial_Condition procedure | |
e5148da0 | 14531 | |
69e6ee2f HK |
14532 | return |
14533 | Ekind (Id) = E_Procedure | |
14534 | and then Is_Initial_Condition_Procedure (Id); | |
14535 | end Is_Initial_Condition_Proc; | |
e5148da0 | 14536 | |
69e6ee2f HK |
14537 | -------------------- |
14538 | -- Is_Initialized -- | |
14539 | -------------------- | |
996ae0b0 | 14540 | |
69e6ee2f HK |
14541 | function Is_Initialized (Obj_Decl : Node_Id) return Boolean is |
14542 | begin | |
14543 | -- To qualify, the object declaration must have an expression | |
e5148da0 | 14544 | |
69e6ee2f HK |
14545 | return |
14546 | Present (Expression (Obj_Decl)) | |
14547 | or else Has_Init_Expression (Obj_Decl); | |
14548 | end Is_Initialized; | |
162ed06f | 14549 | |
69e6ee2f HK |
14550 | ----------------------- |
14551 | -- Is_Invariant_Proc -- | |
14552 | ----------------------- | |
e5148da0 | 14553 | |
69e6ee2f HK |
14554 | function Is_Invariant_Proc (Id : Entity_Id) return Boolean is |
14555 | begin | |
14556 | -- To qualify, the entity must denote the "full" invariant procedure | |
e5148da0 | 14557 | |
69e6ee2f HK |
14558 | return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id); |
14559 | end Is_Invariant_Proc; | |
996ae0b0 | 14560 | |
69e6ee2f HK |
14561 | --------------------------------------- |
14562 | -- Is_Non_Library_Level_Encapsulator -- | |
14563 | --------------------------------------- | |
996ae0b0 | 14564 | |
69e6ee2f HK |
14565 | function Is_Non_Library_Level_Encapsulator |
14566 | (N : Node_Id) return Boolean | |
14567 | is | |
14568 | begin | |
14569 | case Nkind (N) is | |
14570 | when N_Abstract_Subprogram_Declaration | |
14571 | | N_Aspect_Specification | |
14572 | | N_Component_Declaration | |
14573 | | N_Entry_Body | |
14574 | | N_Entry_Declaration | |
14575 | | N_Expression_Function | |
14576 | | N_Formal_Abstract_Subprogram_Declaration | |
14577 | | N_Formal_Concrete_Subprogram_Declaration | |
14578 | | N_Formal_Object_Declaration | |
14579 | | N_Formal_Package_Declaration | |
14580 | | N_Formal_Type_Declaration | |
14581 | | N_Generic_Association | |
14582 | | N_Implicit_Label_Declaration | |
14583 | | N_Incomplete_Type_Declaration | |
14584 | | N_Private_Extension_Declaration | |
14585 | | N_Private_Type_Declaration | |
14586 | | N_Protected_Body | |
14587 | | N_Protected_Type_Declaration | |
14588 | | N_Single_Protected_Declaration | |
14589 | | N_Single_Task_Declaration | |
14590 | | N_Subprogram_Body | |
14591 | | N_Subprogram_Declaration | |
14592 | | N_Task_Body | |
14593 | | N_Task_Type_Declaration | |
14594 | => | |
14595 | return True; | |
996ae0b0 | 14596 | |
69e6ee2f HK |
14597 | when others => |
14598 | return Is_Generic_Declaration_Or_Body (N); | |
14599 | end case; | |
14600 | end Is_Non_Library_Level_Encapsulator; | |
996ae0b0 | 14601 | |
69e6ee2f HK |
14602 | ------------------------------- |
14603 | -- Is_Partial_Invariant_Proc -- | |
14604 | ------------------------------- | |
7ffd9312 | 14605 | |
69e6ee2f HK |
14606 | function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is |
14607 | begin | |
14608 | -- To qualify, the entity must denote the "partial" invariant | |
14609 | -- procedure. | |
7ffd9312 | 14610 | |
69e6ee2f HK |
14611 | return |
14612 | Ekind (Id) = E_Procedure | |
14613 | and then Is_Partial_Invariant_Procedure (Id); | |
14614 | end Is_Partial_Invariant_Proc; | |
996ae0b0 | 14615 | |
69e6ee2f HK |
14616 | ---------------------------- |
14617 | -- Is_Postconditions_Proc -- | |
14618 | ---------------------------- | |
996ae0b0 | 14619 | |
69e6ee2f HK |
14620 | function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is |
14621 | begin | |
14622 | -- To qualify, the entity must denote a _Postconditions procedure | |
162ed06f | 14623 | |
69e6ee2f HK |
14624 | return |
14625 | Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions; | |
14626 | end Is_Postconditions_Proc; | |
162ed06f | 14627 | |
69e6ee2f HK |
14628 | --------------------------- |
14629 | -- Is_Preelaborated_Unit -- | |
14630 | --------------------------- | |
996ae0b0 | 14631 | |
69e6ee2f HK |
14632 | function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean is |
14633 | begin | |
14634 | return | |
14635 | Is_Preelaborated (Id) | |
14636 | or else Is_Pure (Id) | |
14637 | or else Is_Remote_Call_Interface (Id) | |
14638 | or else Is_Remote_Types (Id) | |
14639 | or else Is_Shared_Passive (Id); | |
14640 | end Is_Preelaborated_Unit; | |
14641 | ||
14642 | ------------------------ | |
14643 | -- Is_Protected_Entry -- | |
14644 | ------------------------ | |
14645 | ||
14646 | function Is_Protected_Entry (Id : Entity_Id) return Boolean is | |
14647 | begin | |
14648 | -- To qualify, the entity must denote an entry defined in a protected | |
14649 | -- type. | |
996ae0b0 | 14650 | |
69e6ee2f HK |
14651 | return |
14652 | Is_Entry (Id) | |
14653 | and then Is_Protected_Type (Non_Private_View (Scope (Id))); | |
14654 | end Is_Protected_Entry; | |
996ae0b0 | 14655 | |
69e6ee2f HK |
14656 | ----------------------- |
14657 | -- Is_Protected_Subp -- | |
14658 | ----------------------- | |
996ae0b0 | 14659 | |
69e6ee2f HK |
14660 | function Is_Protected_Subp (Id : Entity_Id) return Boolean is |
14661 | begin | |
14662 | -- To qualify, the entity must denote a subprogram defined within a | |
14663 | -- protected type. | |
996ae0b0 | 14664 | |
69e6ee2f HK |
14665 | return |
14666 | Ekind_In (Id, E_Function, E_Procedure) | |
14667 | and then Is_Protected_Type (Non_Private_View (Scope (Id))); | |
14668 | end Is_Protected_Subp; | |
162ed06f | 14669 | |
69e6ee2f HK |
14670 | ---------------------------- |
14671 | -- Is_Protected_Body_Subp -- | |
14672 | ---------------------------- | |
967947ed | 14673 | |
69e6ee2f HK |
14674 | function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean is |
14675 | begin | |
14676 | -- To qualify, the entity must denote a subprogram with attribute | |
14677 | -- Protected_Subprogram set. | |
996ae0b0 | 14678 | |
69e6ee2f HK |
14679 | return |
14680 | Ekind_In (Id, E_Function, E_Procedure) | |
14681 | and then Present (Protected_Subprogram (Id)); | |
14682 | end Is_Protected_Body_Subp; | |
996ae0b0 | 14683 | |
69e6ee2f HK |
14684 | ----------------- |
14685 | -- Is_Scenario -- | |
14686 | ----------------- | |
996ae0b0 | 14687 | |
69e6ee2f HK |
14688 | function Is_Scenario (N : Node_Id) return Boolean is |
14689 | begin | |
14690 | case Nkind (N) is | |
14691 | when N_Assignment_Statement | |
14692 | | N_Attribute_Reference | |
14693 | | N_Call_Marker | |
14694 | | N_Entry_Call_Statement | |
14695 | | N_Expanded_Name | |
14696 | | N_Function_Call | |
14697 | | N_Function_Instantiation | |
14698 | | N_Identifier | |
14699 | | N_Package_Instantiation | |
14700 | | N_Procedure_Call_Statement | |
14701 | | N_Procedure_Instantiation | |
14702 | | N_Requeue_Statement | |
14703 | => | |
14704 | return True; | |
996ae0b0 | 14705 | |
69e6ee2f HK |
14706 | when others => |
14707 | return False; | |
14708 | end case; | |
14709 | end Is_Scenario; | |
996ae0b0 | 14710 | |
69e6ee2f HK |
14711 | ------------------------------ |
14712 | -- Is_SPARK_Semantic_Target -- | |
14713 | ------------------------------ | |
162ed06f | 14714 | |
69e6ee2f HK |
14715 | function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean is |
14716 | begin | |
14717 | return | |
14718 | Is_Default_Initial_Condition_Proc (Id) | |
14719 | or else Is_Initial_Condition_Proc (Id); | |
14720 | end Is_SPARK_Semantic_Target; | |
162ed06f | 14721 | |
69e6ee2f HK |
14722 | ------------------------ |
14723 | -- Is_Subprogram_Inst -- | |
14724 | ------------------------ | |
1f163ef7 | 14725 | |
69e6ee2f HK |
14726 | function Is_Subprogram_Inst (Id : Entity_Id) return Boolean is |
14727 | begin | |
14728 | -- To qualify, the entity must denote a function or a procedure which | |
14729 | -- is hidden within an anonymous package, and is a generic instance. | |
1f163ef7 | 14730 | |
69e6ee2f HK |
14731 | return |
14732 | Ekind_In (Id, E_Function, E_Procedure) | |
14733 | and then Is_Hidden (Id) | |
14734 | and then Is_Generic_Instance (Id); | |
14735 | end Is_Subprogram_Inst; | |
de4899bb | 14736 | |
69e6ee2f HK |
14737 | ------------------------------ |
14738 | -- Is_Suitable_Access_Taken -- | |
14739 | ------------------------------ | |
de4899bb | 14740 | |
69e6ee2f HK |
14741 | function Is_Suitable_Access_Taken (N : Node_Id) return Boolean is |
14742 | Nam : Name_Id; | |
14743 | Pref : Node_Id; | |
14744 | Subp_Id : Entity_Id; | |
996ae0b0 | 14745 | |
69e6ee2f HK |
14746 | begin |
14747 | -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect | |
996ae0b0 | 14748 | |
69e6ee2f HK |
14749 | if Debug_Flag_Dot_UU then |
14750 | return False; | |
967947ed | 14751 | |
69e6ee2f | 14752 | -- Nothing to do when the scenario is not an attribute reference |
967947ed | 14753 | |
69e6ee2f HK |
14754 | elsif Nkind (N) /= N_Attribute_Reference then |
14755 | return False; | |
996ae0b0 | 14756 | |
69e6ee2f HK |
14757 | -- Nothing to do for internally-generated attributes because they are |
14758 | -- assumed to be ABE safe. | |
996ae0b0 | 14759 | |
69e6ee2f HK |
14760 | elsif not Comes_From_Source (N) then |
14761 | return False; | |
14762 | end if; | |
e5148da0 | 14763 | |
69e6ee2f HK |
14764 | Nam := Attribute_Name (N); |
14765 | Pref := Prefix (N); | |
e5148da0 | 14766 | |
69e6ee2f | 14767 | -- Sanitize the prefix of the attribute |
996ae0b0 | 14768 | |
69e6ee2f HK |
14769 | if not Is_Entity_Name (Pref) then |
14770 | return False; | |
a5abb241 | 14771 | |
69e6ee2f HK |
14772 | elsif No (Entity (Pref)) then |
14773 | return False; | |
14774 | end if; | |
e645cb39 | 14775 | |
69e6ee2f | 14776 | Subp_Id := Entity (Pref); |
b91f986b | 14777 | |
69e6ee2f HK |
14778 | if not Is_Subprogram_Or_Entry (Subp_Id) then |
14779 | return False; | |
14780 | end if; | |
b91f986b | 14781 | |
69e6ee2f HK |
14782 | -- Traverse a possible chain of renamings to obtain the original |
14783 | -- entry or subprogram which the prefix may rename. | |
996ae0b0 | 14784 | |
69e6ee2f | 14785 | Subp_Id := Get_Renamed_Entity (Subp_Id); |
8dce7371 | 14786 | |
69e6ee2f | 14787 | -- To qualify, the attribute must meet the following prerequisites: |
8dce7371 | 14788 | |
69e6ee2f | 14789 | return |
8dce7371 | 14790 | |
69e6ee2f HK |
14791 | -- The prefix must denote a source entry, operator, or subprogram |
14792 | -- which is not imported. | |
8dce7371 | 14793 | |
69e6ee2f HK |
14794 | Comes_From_Source (Subp_Id) |
14795 | and then Is_Subprogram_Or_Entry (Subp_Id) | |
14796 | and then not Is_Bodiless_Subprogram (Subp_Id) | |
996ae0b0 | 14797 | |
69e6ee2f HK |
14798 | -- The attribute name must be one of the 'Access forms. Note that |
14799 | -- 'Unchecked_Access cannot apply to a subprogram. | |
996ae0b0 | 14800 | |
69e6ee2f HK |
14801 | and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access); |
14802 | end Is_Suitable_Access_Taken; | |
8dce7371 | 14803 | |
69e6ee2f HK |
14804 | ---------------------- |
14805 | -- Is_Suitable_Call -- | |
14806 | ---------------------- | |
996ae0b0 | 14807 | |
69e6ee2f HK |
14808 | function Is_Suitable_Call (N : Node_Id) return Boolean is |
14809 | begin | |
14810 | -- Entry and subprogram calls are intentionally ignored because they | |
14811 | -- may undergo expansion depending on the compilation mode, previous | |
14812 | -- errors, generic context, etc. Call markers play the role of calls | |
14813 | -- and provide a uniform foundation for ABE processing. | |
a6d25cad | 14814 | |
69e6ee2f HK |
14815 | return Nkind (N) = N_Call_Marker; |
14816 | end Is_Suitable_Call; | |
a6d25cad | 14817 | |
69e6ee2f HK |
14818 | ------------------------------- |
14819 | -- Is_Suitable_Instantiation -- | |
14820 | ------------------------------- | |
996ae0b0 | 14821 | |
69e6ee2f HK |
14822 | function Is_Suitable_Instantiation (N : Node_Id) return Boolean is |
14823 | Inst : constant Node_Id := Scenario (N); | |
996ae0b0 | 14824 | |
69e6ee2f HK |
14825 | begin |
14826 | -- To qualify, the instantiation must come from source | |
996ae0b0 | 14827 | |
69e6ee2f HK |
14828 | return |
14829 | Comes_From_Source (Inst) | |
14830 | and then Nkind (Inst) in N_Generic_Instantiation; | |
14831 | end Is_Suitable_Instantiation; | |
996ae0b0 | 14832 | |
69e6ee2f HK |
14833 | ------------------------------------ |
14834 | -- Is_Suitable_SPARK_Derived_Type -- | |
14835 | ------------------------------------ | |
996ae0b0 | 14836 | |
69e6ee2f HK |
14837 | function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean is |
14838 | Prag : Node_Id; | |
14839 | Typ : Entity_Id; | |
996ae0b0 | 14840 | |
69e6ee2f HK |
14841 | begin |
14842 | -- To qualify, the type declaration must denote a derived tagged type | |
14843 | -- with primitive operations, subject to pragma SPARK_Mode On. | |
996ae0b0 | 14844 | |
69e6ee2f HK |
14845 | if Nkind (N) = N_Full_Type_Declaration |
14846 | and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition | |
14847 | then | |
14848 | Typ := Defining_Entity (N); | |
14849 | Prag := SPARK_Pragma (Typ); | |
996ae0b0 | 14850 | |
69e6ee2f HK |
14851 | return |
14852 | Is_Tagged_Type (Typ) | |
14853 | and then Has_Primitive_Operations (Typ) | |
14854 | and then Present (Prag) | |
14855 | and then Get_SPARK_Mode_From_Annotation (Prag) = On; | |
14856 | end if; | |
996ae0b0 | 14857 | |
69e6ee2f HK |
14858 | return False; |
14859 | end Is_Suitable_SPARK_Derived_Type; | |
48b08b18 | 14860 | |
69e6ee2f HK |
14861 | ------------------------------------- |
14862 | -- Is_Suitable_SPARK_Instantiation -- | |
14863 | ------------------------------------- | |
48b08b18 | 14864 | |
69e6ee2f HK |
14865 | function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean is |
14866 | Inst : constant Node_Id := Scenario (N); | |
7fb62ca1 | 14867 | |
69e6ee2f HK |
14868 | Gen_Id : Entity_Id; |
14869 | Prag : Node_Id; | |
7fb62ca1 | 14870 | |
69e6ee2f HK |
14871 | begin |
14872 | -- To qualify, both the instantiation and the generic must be subject | |
14873 | -- to SPARK_Mode On. | |
48b08b18 | 14874 | |
69e6ee2f HK |
14875 | if Is_Suitable_Instantiation (N) then |
14876 | Gen_Id := Instantiated_Generic (Inst); | |
14877 | Prag := SPARK_Pragma (Gen_Id); | |
48b08b18 | 14878 | |
69e6ee2f HK |
14879 | return |
14880 | Is_SPARK_Mode_On_Node (Inst) | |
14881 | and then Present (Prag) | |
14882 | and then Get_SPARK_Mode_From_Annotation (Prag) = On; | |
14883 | end if; | |
48b08b18 | 14884 | |
69e6ee2f HK |
14885 | return False; |
14886 | end Is_Suitable_SPARK_Instantiation; | |
b91f986b | 14887 | |
69e6ee2f HK |
14888 | -------------------------------------------- |
14889 | -- Is_Suitable_SPARK_Refined_State_Pragma -- | |
14890 | -------------------------------------------- | |
b91f986b | 14891 | |
69e6ee2f HK |
14892 | function Is_Suitable_SPARK_Refined_State_Pragma |
14893 | (N : Node_Id) return Boolean | |
14894 | is | |
14895 | begin | |
14896 | -- To qualfy, the pragma must denote Refined_State | |
48b08b18 | 14897 | |
69e6ee2f HK |
14898 | return |
14899 | Nkind (N) = N_Pragma | |
14900 | and then Pragma_Name (N) = Name_Refined_State; | |
14901 | end Is_Suitable_SPARK_Refined_State_Pragma; | |
14902 | ||
14903 | ------------------------------------- | |
14904 | -- Is_Suitable_Variable_Assignment -- | |
14905 | ------------------------------------- | |
14906 | ||
14907 | function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean is | |
14908 | N_Unit : Node_Id; | |
14909 | N_Unit_Id : Entity_Id; | |
14910 | Nam : Node_Id; | |
14911 | Var_Decl : Node_Id; | |
14912 | Var_Id : Entity_Id; | |
14913 | Var_Unit : Node_Id; | |
14914 | Var_Unit_Id : Entity_Id; | |
48b08b18 | 14915 | |
69e6ee2f HK |
14916 | begin |
14917 | -- Nothing to do when the scenario is not an assignment | |
48b08b18 | 14918 | |
69e6ee2f HK |
14919 | if Nkind (N) /= N_Assignment_Statement then |
14920 | return False; | |
30168043 | 14921 | |
69e6ee2f HK |
14922 | -- Nothing to do for internally-generated assignments because they |
14923 | -- are assumed to be ABE safe. | |
996ae0b0 | 14924 | |
69e6ee2f HK |
14925 | elsif not Comes_From_Source (N) then |
14926 | return False; | |
8dce7371 | 14927 | |
69e6ee2f HK |
14928 | -- Assignments are ignored in GNAT mode on the assumption that |
14929 | -- they are ABE-safe. This behaviour parallels that of the old | |
14930 | -- ABE mechanism. | |
996ae0b0 | 14931 | |
69e6ee2f HK |
14932 | elsif GNAT_Mode then |
14933 | return False; | |
14934 | end if; | |
4a28b181 | 14935 | |
69e6ee2f | 14936 | Nam := Assignment_Target (N); |
90e491a7 | 14937 | |
69e6ee2f | 14938 | -- Sanitize the left hand side of the assignment |
996ae0b0 | 14939 | |
69e6ee2f HK |
14940 | if not Is_Entity_Name (Nam) then |
14941 | return False; | |
e645cb39 | 14942 | |
69e6ee2f HK |
14943 | elsif No (Entity (Nam)) then |
14944 | return False; | |
14945 | end if; | |
e645cb39 | 14946 | |
69e6ee2f | 14947 | Var_Id := Entity (Nam); |
e645cb39 | 14948 | |
69e6ee2f | 14949 | -- Sanitize the variable |
e645cb39 | 14950 | |
69e6ee2f HK |
14951 | if Var_Id = Any_Id then |
14952 | return False; | |
996ae0b0 | 14953 | |
69e6ee2f HK |
14954 | elsif Ekind (Var_Id) /= E_Variable then |
14955 | return False; | |
14956 | end if; | |
90e491a7 | 14957 | |
69e6ee2f | 14958 | Var_Decl := Declaration_Node (Var_Id); |
996ae0b0 | 14959 | |
69e6ee2f HK |
14960 | if Nkind (Var_Decl) /= N_Object_Declaration then |
14961 | return False; | |
14962 | end if; | |
996ae0b0 | 14963 | |
69e6ee2f HK |
14964 | N_Unit_Id := Find_Top_Unit (N); |
14965 | N_Unit := Unit_Declaration_Node (N_Unit_Id); | |
42f1d661 | 14966 | |
69e6ee2f HK |
14967 | Var_Unit_Id := Find_Top_Unit (Var_Decl); |
14968 | Var_Unit := Unit_Declaration_Node (Var_Unit_Id); | |
8dce7371 | 14969 | |
69e6ee2f | 14970 | -- To qualify, the assignment must meet the following prerequisites: |
42f1d661 | 14971 | |
69e6ee2f HK |
14972 | return |
14973 | Comes_From_Source (Var_Id) | |
4a28b181 | 14974 | |
69e6ee2f HK |
14975 | -- The variable must be declared in the spec of compilation unit |
14976 | -- U. | |
66371f94 | 14977 | |
69e6ee2f HK |
14978 | and then Nkind (Var_Unit) = N_Package_Declaration |
14979 | and then Find_Enclosing_Level (Var_Decl) = Library_Spec_Level | |
66371f94 | 14980 | |
69e6ee2f | 14981 | -- The assignment must occur in the body of compilation unit U |
66371f94 | 14982 | |
69e6ee2f HK |
14983 | and then Nkind (N_Unit) = N_Package_Body |
14984 | and then Present (Corresponding_Body (Var_Unit)) | |
14985 | and then Corresponding_Body (Var_Unit) = N_Unit_Id; | |
14986 | end Is_Suitable_Variable_Assignment; | |
996ae0b0 | 14987 | |
69e6ee2f HK |
14988 | ------------------------------------ |
14989 | -- Is_Suitable_Variable_Reference -- | |
14990 | ------------------------------------ | |
996ae0b0 | 14991 | |
69e6ee2f HK |
14992 | function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean is |
14993 | begin | |
14994 | -- Expanded names and identifiers are intentionally ignored because | |
14995 | -- they be folded, optimized away, etc. Variable references markers | |
14996 | -- play the role of variable references and provide a uniform | |
14997 | -- foundation for ABE processing. | |
ab01e614 | 14998 | |
69e6ee2f HK |
14999 | return Nkind (N) = N_Variable_Reference_Marker; |
15000 | end Is_Suitable_Variable_Reference; | |
66371f94 | 15001 | |
69e6ee2f HK |
15002 | ------------------- |
15003 | -- Is_Task_Entry -- | |
15004 | ------------------- | |
996ae0b0 | 15005 | |
69e6ee2f HK |
15006 | function Is_Task_Entry (Id : Entity_Id) return Boolean is |
15007 | begin | |
15008 | -- To qualify, the entity must denote an entry defined in a task type | |
996ae0b0 | 15009 | |
69e6ee2f HK |
15010 | return |
15011 | Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id))); | |
15012 | end Is_Task_Entry; | |
996ae0b0 | 15013 | |
69e6ee2f HK |
15014 | ------------------------ |
15015 | -- Is_Up_Level_Target -- | |
15016 | ------------------------ | |
996ae0b0 | 15017 | |
69e6ee2f HK |
15018 | function Is_Up_Level_Target |
15019 | (Targ_Decl : Node_Id; | |
15020 | In_State : Processing_In_State) return Boolean | |
15021 | is | |
15022 | Root : constant Node_Id := Root_Scenario; | |
15023 | Root_Rep : constant Scenario_Rep_Id := | |
15024 | Scenario_Representation_Of (Root, In_State); | |
996ae0b0 | 15025 | |
69e6ee2f HK |
15026 | begin |
15027 | -- The root appears within the declaratons of a block statement, | |
15028 | -- entry body, subprogram body, or task body ignoring enclosing | |
15029 | -- packages. The root is always within the main unit. | |
996ae0b0 | 15030 | |
69e6ee2f HK |
15031 | if not In_State.Suppress_Up_Level_Targets |
15032 | and then Level (Root_Rep) = Declaration_Level | |
15033 | then | |
15034 | -- The target is within the main unit. It acts as an up-level | |
15035 | -- target when it appears within a context which encloses the | |
15036 | -- root. | |
15037 | -- | |
15038 | -- package body Main_Unit is | |
15039 | -- function Func ...; -- target | |
15040 | -- | |
15041 | -- procedure Proc is | |
15042 | -- X : ... := Func; -- root scenario | |
996ae0b0 | 15043 | |
69e6ee2f HK |
15044 | if In_Extended_Main_Code_Unit (Targ_Decl) then |
15045 | return not In_Same_Context (Root, Targ_Decl, Nested_OK => True); | |
996ae0b0 | 15046 | |
69e6ee2f HK |
15047 | -- Otherwise the target is external to the main unit which makes |
15048 | -- it an up-level target. | |
996ae0b0 | 15049 | |
69e6ee2f HK |
15050 | else |
15051 | return True; | |
15052 | end if; | |
8dce7371 | 15053 | end if; |
07fc65c4 | 15054 | |
69e6ee2f HK |
15055 | return False; |
15056 | end Is_Up_Level_Target; | |
15057 | end Semantics; | |
07fc65c4 | 15058 | |
0839ffce HK |
15059 | --------------------------- |
15060 | -- Set_Elaboration_Phase -- | |
15061 | --------------------------- | |
15062 | ||
15063 | procedure Set_Elaboration_Phase (Status : Elaboration_Phase_Status) is | |
15064 | begin | |
15065 | Elaboration_Phase := Status; | |
15066 | end Set_Elaboration_Phase; | |
15067 | ||
69e6ee2f HK |
15068 | --------------------- |
15069 | -- SPARK_Processor -- | |
15070 | --------------------- | |
996ae0b0 | 15071 | |
69e6ee2f | 15072 | package body SPARK_Processor is |
8dce7371 | 15073 | |
69e6ee2f HK |
15074 | ----------------------- |
15075 | -- Local subprograms -- | |
15076 | ----------------------- | |
8dce7371 | 15077 | |
69e6ee2f HK |
15078 | procedure Process_SPARK_Derived_Type |
15079 | (Typ_Decl : Node_Id; | |
15080 | Typ_Rep : Scenario_Rep_Id; | |
15081 | In_State : Processing_In_State); | |
15082 | pragma Inline (Process_SPARK_Derived_Type); | |
15083 | -- Verify that the freeze node of a derived type denoted by declaration | |
15084 | -- Typ_Decl is within the early call region of each overriding primitive | |
15085 | -- body that belongs to the derived type (SPARK RM 7.7(8)). Typ_Rep is | |
15086 | -- the representation of the type. In_State denotes the current state of | |
15087 | -- the Processing phase. | |
15088 | ||
15089 | procedure Process_SPARK_Instantiation | |
15090 | (Inst : Node_Id; | |
15091 | Inst_Rep : Scenario_Rep_Id; | |
15092 | In_State : Processing_In_State); | |
15093 | pragma Inline (Process_SPARK_Instantiation); | |
15094 | -- Verify that instanciation Inst does not precede the generic body it | |
15095 | -- instantiates (SPARK RM 7.7(6)). Inst_Rep is the representation of the | |
15096 | -- instantiation. In_State is the current state of the Processing phase. | |
15097 | ||
15098 | procedure Process_SPARK_Refined_State_Pragma | |
15099 | (Prag : Node_Id; | |
15100 | Prag_Rep : Scenario_Rep_Id; | |
15101 | In_State : Processing_In_State); | |
15102 | pragma Inline (Process_SPARK_Refined_State_Pragma); | |
15103 | -- Verify that each constituent of Refined_State pragma Prag which | |
15104 | -- belongs to abstract state mentioned in pragma Initializes has prior | |
15105 | -- elaboration with respect to the main unit (SPARK RM 7.7.1(7)). | |
15106 | -- Prag_Rep is the representation of the pragma. In_State denotes the | |
15107 | -- current state of the Processing phase. | |
15108 | ||
15109 | procedure Process_SPARK_Scenario | |
15110 | (N : Node_Id; | |
15111 | In_State : Processing_In_State); | |
15112 | pragma Inline (Process_SPARK_Scenario); | |
15113 | -- Top-level dispatcher for verifying SPARK scenarios which are not | |
15114 | -- always executable during elaboration but still need elaboration- | |
15115 | -- related checks. In_State is the current state of the Processing | |
15116 | -- phase. | |
15117 | ||
15118 | --------------------------------- | |
15119 | -- Check_SPARK_Model_In_Effect -- | |
15120 | --------------------------------- | |
15121 | ||
15122 | SPARK_Model_Warning_Posted : Boolean := False; | |
15123 | -- This flag prevents the same SPARK model-related warning from being | |
15124 | -- emitted multiple times. | |
15125 | ||
15126 | procedure Check_SPARK_Model_In_Effect is | |
3eb5e54a | 15127 | Spec_Id : constant Entity_Id := Unique_Entity (Main_Unit_Entity); |
8dce7371 | 15128 | |
69e6ee2f HK |
15129 | begin |
15130 | -- Do not emit the warning multiple times as this creates useless | |
15131 | -- noise. | |
996ae0b0 | 15132 | |
69e6ee2f HK |
15133 | if SPARK_Model_Warning_Posted then |
15134 | null; | |
996ae0b0 | 15135 | |
69e6ee2f | 15136 | -- SPARK rule verification requires the "strict" static model |
996ae0b0 | 15137 | |
69e6ee2f HK |
15138 | elsif Static_Elaboration_Checks |
15139 | and not Relaxed_Elaboration_Checks | |
15140 | then | |
15141 | null; | |
996ae0b0 | 15142 | |
69e6ee2f HK |
15143 | -- Any other combination of models does not guarantee the absence of |
15144 | -- ABE problems for SPARK rule verification purposes. Note that there | |
15145 | -- is no need to check for the presence of the legacy ABE mechanism | |
15146 | -- because the legacy code has its own dedicated processing for SPARK | |
15147 | -- rules. | |
8dce7371 | 15148 | |
69e6ee2f HK |
15149 | else |
15150 | SPARK_Model_Warning_Posted := True; | |
8dce7371 | 15151 | |
7fb62ca1 | 15152 | Error_Msg_N |
69e6ee2f HK |
15153 | ("??SPARK elaboration checks require static elaboration model", |
15154 | Spec_Id); | |
90e491a7 | 15155 | |
69e6ee2f HK |
15156 | if Dynamic_Elaboration_Checks then |
15157 | Error_Msg_N | |
15158 | ("\dynamic elaboration model is in effect", Spec_Id); | |
996ae0b0 | 15159 | |
69e6ee2f HK |
15160 | else |
15161 | pragma Assert (Relaxed_Elaboration_Checks); | |
15162 | Error_Msg_N | |
15163 | ("\relaxed elaboration model is in effect", Spec_Id); | |
15164 | end if; | |
8dce7371 | 15165 | end if; |
69e6ee2f | 15166 | end Check_SPARK_Model_In_Effect; |
90e491a7 | 15167 | |
69e6ee2f HK |
15168 | --------------------------- |
15169 | -- Check_SPARK_Scenarios -- | |
15170 | --------------------------- | |
996ae0b0 | 15171 | |
69e6ee2f HK |
15172 | procedure Check_SPARK_Scenarios is |
15173 | Iter : NE_Set.Iterator; | |
15174 | N : Node_Id; | |
996ae0b0 | 15175 | |
69e6ee2f HK |
15176 | begin |
15177 | Iter := Iterate_SPARK_Scenarios; | |
15178 | while NE_Set.Has_Next (Iter) loop | |
15179 | NE_Set.Next (Iter, N); | |
996ae0b0 | 15180 | |
69e6ee2f HK |
15181 | Process_SPARK_Scenario |
15182 | (N => N, | |
15183 | In_State => SPARK_State); | |
15184 | end loop; | |
15185 | end Check_SPARK_Scenarios; | |
8dce7371 | 15186 | |
69e6ee2f HK |
15187 | -------------------------------- |
15188 | -- Process_SPARK_Derived_Type -- | |
15189 | -------------------------------- | |
8dce7371 | 15190 | |
69e6ee2f HK |
15191 | procedure Process_SPARK_Derived_Type |
15192 | (Typ_Decl : Node_Id; | |
15193 | Typ_Rep : Scenario_Rep_Id; | |
15194 | In_State : Processing_In_State) | |
15195 | is | |
15196 | pragma Unreferenced (In_State); | |
15197 | ||
15198 | Typ : constant Entity_Id := Target (Typ_Rep); | |
15199 | ||
15200 | Stop_Check : exception; | |
15201 | -- This exception is raised when the freeze node violates the | |
15202 | -- placement rules. | |
15203 | ||
15204 | procedure Check_Overriding_Primitive | |
15205 | (Prim : Entity_Id; | |
15206 | FNode : Node_Id); | |
15207 | pragma Inline (Check_Overriding_Primitive); | |
15208 | -- Verify that freeze node FNode is within the early call region of | |
15209 | -- overriding primitive Prim's body. | |
15210 | ||
15211 | function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr; | |
15212 | pragma Inline (Freeze_Node_Location); | |
15213 | -- Return a more accurate source location associated with freeze node | |
15214 | -- FNode. | |
15215 | ||
15216 | function Precedes_Source_Construct (N : Node_Id) return Boolean; | |
15217 | pragma Inline (Precedes_Source_Construct); | |
15218 | -- Determine whether arbitrary node N appears prior to some source | |
15219 | -- construct. | |
15220 | ||
15221 | procedure Suggest_Elaborate_Body | |
15222 | (N : Node_Id; | |
15223 | Body_Decl : Node_Id; | |
15224 | Error_Nod : Node_Id); | |
15225 | pragma Inline (Suggest_Elaborate_Body); | |
15226 | -- Suggest the use of pragma Elaborate_Body when the pragma will | |
15227 | -- allow for node N to appear within the early call region of | |
15228 | -- subprogram body Body_Decl. The suggestion is attached to | |
15229 | -- Error_Nod as a continuation error. | |
15230 | ||
15231 | -------------------------------- | |
15232 | -- Check_Overriding_Primitive -- | |
15233 | -------------------------------- | |
15234 | ||
15235 | procedure Check_Overriding_Primitive | |
15236 | (Prim : Entity_Id; | |
15237 | FNode : Node_Id) | |
15238 | is | |
15239 | Prim_Decl : constant Node_Id := Unit_Declaration_Node (Prim); | |
15240 | Body_Decl : Node_Id; | |
15241 | Body_Id : Entity_Id; | |
15242 | Region : Node_Id; | |
996ae0b0 | 15243 | |
69e6ee2f HK |
15244 | begin |
15245 | -- Nothing to do for predefined primitives because they are | |
15246 | -- artifacts of tagged type expansion and cannot override source | |
31fde973 GD |
15247 | -- primitives. Nothing to do as well for inherited primitives, as |
15248 | -- the check concerns overriding ones. | |
996ae0b0 | 15249 | |
bab15911 YM |
15250 | if Is_Predefined_Dispatching_Operation (Prim) |
15251 | or else not Is_Overriding_Subprogram (Prim) | |
15252 | then | |
69e6ee2f HK |
15253 | return; |
15254 | end if; | |
996ae0b0 | 15255 | |
69e6ee2f | 15256 | Body_Id := Corresponding_Body (Prim_Decl); |
8dce7371 | 15257 | |
69e6ee2f HK |
15258 | -- Nothing to do when the primitive does not have a corresponding |
15259 | -- body. This can happen when the unit with the bodies is not the | |
15260 | -- main unit subjected to ABE checks. | |
e5148da0 | 15261 | |
69e6ee2f HK |
15262 | if No (Body_Id) then |
15263 | return; | |
996ae0b0 | 15264 | |
69e6ee2f | 15265 | -- The primitive overrides a parent or progenitor primitive |
996ae0b0 | 15266 | |
69e6ee2f | 15267 | elsif Present (Overridden_Operation (Prim)) then |
996ae0b0 | 15268 | |
69e6ee2f HK |
15269 | -- Nothing to do when overriding an interface primitive happens |
15270 | -- by inheriting a non-interface primitive as the check would | |
15271 | -- be done on the parent primitive. | |
996ae0b0 | 15272 | |
69e6ee2f HK |
15273 | if Present (Alias (Prim)) then |
15274 | return; | |
15275 | end if; | |
996ae0b0 | 15276 | |
69e6ee2f HK |
15277 | -- Nothing to do when the primitive is not overriding. The body of |
15278 | -- such a primitive cannot be targeted by a dispatching call which | |
15279 | -- is executable during elaboration, and cannot cause an ABE. | |
e9daba51 | 15280 | |
69e6ee2f HK |
15281 | else |
15282 | return; | |
15283 | end if; | |
e9daba51 | 15284 | |
69e6ee2f HK |
15285 | Body_Decl := Unit_Declaration_Node (Body_Id); |
15286 | Region := Find_Early_Call_Region (Body_Decl); | |
90e491a7 | 15287 | |
69e6ee2f HK |
15288 | -- The freeze node appears prior to the early call region of the |
15289 | -- primitive body. | |
90e491a7 | 15290 | |
69e6ee2f HK |
15291 | -- IMPORTANT: This check must always be performed even when |
15292 | -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not | |
15293 | -- specified because the static model cannot guarantee the absence | |
15294 | -- of ABEs in the presence of dispatching calls. | |
90e491a7 | 15295 | |
69e6ee2f HK |
15296 | if Earlier_In_Extended_Unit (FNode, Region) then |
15297 | Error_Msg_Node_2 := Prim; | |
15298 | Error_Msg_NE | |
15299 | ("first freezing point of type & must appear within early " | |
15300 | & "call region of primitive body & (SPARK RM 7.7(8))", | |
15301 | Typ_Decl, Typ); | |
90e491a7 | 15302 | |
69e6ee2f HK |
15303 | Error_Msg_Sloc := Sloc (Region); |
15304 | Error_Msg_N ("\region starts #", Typ_Decl); | |
e9daba51 | 15305 | |
69e6ee2f HK |
15306 | Error_Msg_Sloc := Sloc (Body_Decl); |
15307 | Error_Msg_N ("\region ends #", Typ_Decl); | |
7ffd9312 | 15308 | |
69e6ee2f HK |
15309 | Error_Msg_Sloc := Freeze_Node_Location (FNode); |
15310 | Error_Msg_N ("\first freezing point #", Typ_Decl); | |
02217452 | 15311 | |
69e6ee2f HK |
15312 | -- If applicable, suggest the use of pragma Elaborate_Body in |
15313 | -- the associated package spec. | |
7ffd9312 | 15314 | |
69e6ee2f HK |
15315 | Suggest_Elaborate_Body |
15316 | (N => FNode, | |
15317 | Body_Decl => Body_Decl, | |
15318 | Error_Nod => Typ_Decl); | |
7ffd9312 | 15319 | |
69e6ee2f HK |
15320 | raise Stop_Check; |
15321 | end if; | |
15322 | end Check_Overriding_Primitive; | |
7ffd9312 | 15323 | |
69e6ee2f HK |
15324 | -------------------------- |
15325 | -- Freeze_Node_Location -- | |
15326 | -------------------------- | |
2e60feb5 | 15327 | |
69e6ee2f HK |
15328 | function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr is |
15329 | Context : constant Node_Id := Parent (FNode); | |
15330 | Loc : constant Source_Ptr := Sloc (FNode); | |
2e60feb5 | 15331 | |
69e6ee2f HK |
15332 | Prv_Decls : List_Id; |
15333 | Vis_Decls : List_Id; | |
996ae0b0 | 15334 | |
69e6ee2f HK |
15335 | begin |
15336 | -- In general, the source location of the freeze node is as close | |
15337 | -- as possible to the real freeze point, except when the freeze | |
15338 | -- node is at the "bottom" of a package spec. | |
996ae0b0 | 15339 | |
69e6ee2f HK |
15340 | if Nkind (Context) = N_Package_Specification then |
15341 | Prv_Decls := Private_Declarations (Context); | |
15342 | Vis_Decls := Visible_Declarations (Context); | |
996ae0b0 | 15343 | |
69e6ee2f HK |
15344 | -- The freeze node appears in the private declarations of the |
15345 | -- package. | |
996ae0b0 | 15346 | |
69e6ee2f HK |
15347 | if Present (Prv_Decls) |
15348 | and then List_Containing (FNode) = Prv_Decls | |
15349 | then | |
15350 | null; | |
996ae0b0 | 15351 | |
69e6ee2f HK |
15352 | -- The freeze node appears in the visible declarations of the |
15353 | -- package and there are no private declarations. | |
996ae0b0 | 15354 | |
69e6ee2f HK |
15355 | elsif Present (Vis_Decls) |
15356 | and then List_Containing (FNode) = Vis_Decls | |
15357 | and then (No (Prv_Decls) or else Is_Empty_List (Prv_Decls)) | |
15358 | then | |
15359 | null; | |
996ae0b0 | 15360 | |
69e6ee2f HK |
15361 | -- Otherwise the freeze node is not in the "last" declarative |
15362 | -- list of the package. Use the existing source location of the | |
15363 | -- freeze node. | |
996ae0b0 | 15364 | |
69e6ee2f HK |
15365 | else |
15366 | return Loc; | |
15367 | end if; | |
90e491a7 | 15368 | |
69e6ee2f HK |
15369 | -- The freeze node appears at the "bottom" of the package when |
15370 | -- it is in the "last" declarative list and is either the last | |
15371 | -- in the list or is followed by internal constructs only. In | |
15372 | -- that case the more appropriate source location is that of | |
15373 | -- the package end label. | |
996ae0b0 | 15374 | |
69e6ee2f HK |
15375 | if not Precedes_Source_Construct (FNode) then |
15376 | return Sloc (End_Label (Context)); | |
15377 | end if; | |
15378 | end if; | |
996ae0b0 | 15379 | |
69e6ee2f HK |
15380 | return Loc; |
15381 | end Freeze_Node_Location; | |
996ae0b0 | 15382 | |
69e6ee2f HK |
15383 | ------------------------------- |
15384 | -- Precedes_Source_Construct -- | |
15385 | ------------------------------- | |
996ae0b0 | 15386 | |
69e6ee2f HK |
15387 | function Precedes_Source_Construct (N : Node_Id) return Boolean is |
15388 | Decl : Node_Id; | |
8dce7371 | 15389 | |
69e6ee2f HK |
15390 | begin |
15391 | Decl := Next (N); | |
15392 | while Present (Decl) loop | |
15393 | if Comes_From_Source (Decl) then | |
15394 | return True; | |
8dce7371 | 15395 | |
69e6ee2f HK |
15396 | -- A generated body for a source expression function is treated |
15397 | -- as a source construct. | |
996ae0b0 | 15398 | |
69e6ee2f HK |
15399 | elsif Nkind (Decl) = N_Subprogram_Body |
15400 | and then Was_Expression_Function (Decl) | |
15401 | and then Comes_From_Source (Original_Node (Decl)) | |
15402 | then | |
15403 | return True; | |
15404 | end if; | |
996ae0b0 | 15405 | |
69e6ee2f HK |
15406 | Next (Decl); |
15407 | end loop; | |
996ae0b0 | 15408 | |
69e6ee2f HK |
15409 | return False; |
15410 | end Precedes_Source_Construct; | |
8dce7371 | 15411 | |
69e6ee2f HK |
15412 | ---------------------------- |
15413 | -- Suggest_Elaborate_Body -- | |
15414 | ---------------------------- | |
996ae0b0 | 15415 | |
69e6ee2f HK |
15416 | procedure Suggest_Elaborate_Body |
15417 | (N : Node_Id; | |
15418 | Body_Decl : Node_Id; | |
15419 | Error_Nod : Node_Id) | |
15420 | is | |
15421 | Unit_Id : constant Node_Id := Unit (Cunit (Main_Unit)); | |
15422 | Region : Node_Id; | |
8dce7371 | 15423 | |
69e6ee2f HK |
15424 | begin |
15425 | -- The suggestion applies only when the subprogram body resides in | |
15426 | -- a compilation package body, and a pragma Elaborate_Body would | |
15427 | -- allow for the node to appear in the early call region of the | |
15428 | -- subprogram body. This implies that all code from the subprogram | |
15429 | -- body up to the node is preelaborable. | |
996ae0b0 | 15430 | |
69e6ee2f | 15431 | if Nkind (Unit_Id) = N_Package_Body then |
996ae0b0 | 15432 | |
69e6ee2f HK |
15433 | -- Find the start of the early call region again assuming that |
15434 | -- the package spec has pragma Elaborate_Body. Note that the | |
15435 | -- internal data structures are intentionally not updated | |
15436 | -- because this is a speculative search. | |
967947ed | 15437 | |
69e6ee2f HK |
15438 | Region := |
15439 | Find_Early_Call_Region | |
15440 | (Body_Decl => Body_Decl, | |
15441 | Assume_Elab_Body => True, | |
15442 | Skip_Memoization => True); | |
967947ed | 15443 | |
69e6ee2f HK |
15444 | -- If the node appears within the early call region, assuming |
15445 | -- that the package spec carries pragma Elaborate_Body, then it | |
15446 | -- is safe to suggest the pragma. | |
996ae0b0 | 15447 | |
69e6ee2f HK |
15448 | if Earlier_In_Extended_Unit (Region, N) then |
15449 | Error_Msg_Name_1 := Name_Elaborate_Body; | |
15450 | Error_Msg_NE | |
15451 | ("\consider adding pragma % in spec of unit &", | |
15452 | Error_Nod, Defining_Entity (Unit_Id)); | |
15453 | end if; | |
15454 | end if; | |
15455 | end Suggest_Elaborate_Body; | |
2e70d415 | 15456 | |
69e6ee2f | 15457 | -- Local variables |
996ae0b0 | 15458 | |
69e6ee2f HK |
15459 | FNode : constant Node_Id := Freeze_Node (Typ); |
15460 | Prims : constant Elist_Id := Direct_Primitive_Operations (Typ); | |
996ae0b0 | 15461 | |
69e6ee2f | 15462 | Prim_Elmt : Elmt_Id; |
996ae0b0 | 15463 | |
69e6ee2f | 15464 | -- Start of processing for Process_SPARK_Derived_Type |
996ae0b0 | 15465 | |
69e6ee2f HK |
15466 | begin |
15467 | -- A type should have its freeze node set by the time SPARK scenarios | |
15468 | -- are being verified. | |
2e70d415 | 15469 | |
69e6ee2f | 15470 | pragma Assert (Present (FNode)); |
f5f6d8d7 | 15471 | |
69e6ee2f HK |
15472 | -- Verify that the freeze node of the derived type is within the |
15473 | -- early call region of each overriding primitive body | |
15474 | -- (SPARK RM 7.7(8)). | |
2e70d415 | 15475 | |
69e6ee2f HK |
15476 | if Present (Prims) then |
15477 | Prim_Elmt := First_Elmt (Prims); | |
15478 | while Present (Prim_Elmt) loop | |
15479 | Check_Overriding_Primitive | |
15480 | (Prim => Node (Prim_Elmt), | |
15481 | FNode => FNode); | |
996ae0b0 | 15482 | |
69e6ee2f HK |
15483 | Next_Elmt (Prim_Elmt); |
15484 | end loop; | |
15485 | end if; | |
996ae0b0 | 15486 | |
69e6ee2f HK |
15487 | exception |
15488 | when Stop_Check => | |
15489 | null; | |
15490 | end Process_SPARK_Derived_Type; | |
90e491a7 | 15491 | |
69e6ee2f HK |
15492 | --------------------------------- |
15493 | -- Process_SPARK_Instantiation -- | |
15494 | --------------------------------- | |
8ce62196 | 15495 | |
69e6ee2f HK |
15496 | procedure Process_SPARK_Instantiation |
15497 | (Inst : Node_Id; | |
15498 | Inst_Rep : Scenario_Rep_Id; | |
15499 | In_State : Processing_In_State) | |
15500 | is | |
15501 | Gen_Id : constant Entity_Id := Target (Inst_Rep); | |
15502 | Gen_Rep : constant Target_Rep_Id := | |
15503 | Target_Representation_Of (Gen_Id, In_State); | |
15504 | Body_Decl : constant Node_Id := Body_Declaration (Gen_Rep); | |
8f8f531f | 15505 | |
69e6ee2f HK |
15506 | begin |
15507 | -- The instantiation and the generic body are both in the main unit | |
996ae0b0 | 15508 | |
69e6ee2f HK |
15509 | if Present (Body_Decl) |
15510 | and then In_Extended_Main_Code_Unit (Body_Decl) | |
996ae0b0 | 15511 | |
69e6ee2f HK |
15512 | -- If the instantiation appears prior to the generic body, then the |
15513 | -- instantiation is illegal (SPARK RM 7.7(6)). | |
8f8f531f | 15514 | |
69e6ee2f HK |
15515 | -- IMPORTANT: This check must always be performed even when |
15516 | -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not | |
15517 | -- specified because the rule prevents use-before-declaration of | |
15518 | -- objects that may precede the generic body. | |
8f8f531f | 15519 | |
69e6ee2f HK |
15520 | and then Earlier_In_Extended_Unit (Inst, Body_Decl) |
15521 | then | |
15522 | Error_Msg_NE | |
15523 | ("cannot instantiate & before body seen", Inst, Gen_Id); | |
15524 | end if; | |
15525 | end Process_SPARK_Instantiation; | |
8dce7371 | 15526 | |
69e6ee2f HK |
15527 | ---------------------------- |
15528 | -- Process_SPARK_Scenario -- | |
15529 | ---------------------------- | |
8dce7371 | 15530 | |
69e6ee2f HK |
15531 | procedure Process_SPARK_Scenario |
15532 | (N : Node_Id; | |
15533 | In_State : Processing_In_State) | |
15534 | is | |
15535 | Scen : constant Node_Id := Scenario (N); | |
8f8f531f | 15536 | |
69e6ee2f HK |
15537 | begin |
15538 | -- Ensure that a suitable elaboration model is in effect for SPARK | |
15539 | -- rule verification. | |
996ae0b0 | 15540 | |
69e6ee2f | 15541 | Check_SPARK_Model_In_Effect; |
73242473 | 15542 | |
69e6ee2f | 15543 | -- Add the current scenario to the stack of active scenarios |
73242473 | 15544 | |
69e6ee2f | 15545 | Push_Active_Scenario (Scen); |
73242473 | 15546 | |
69e6ee2f | 15547 | -- Derived type |
73242473 | 15548 | |
69e6ee2f HK |
15549 | if Is_Suitable_SPARK_Derived_Type (Scen) then |
15550 | Process_SPARK_Derived_Type | |
15551 | (Typ_Decl => Scen, | |
15552 | Typ_Rep => Scenario_Representation_Of (Scen, In_State), | |
15553 | In_State => In_State); | |
73242473 | 15554 | |
69e6ee2f | 15555 | -- Instantiation |
73242473 | 15556 | |
69e6ee2f HK |
15557 | elsif Is_Suitable_SPARK_Instantiation (Scen) then |
15558 | Process_SPARK_Instantiation | |
15559 | (Inst => Scen, | |
15560 | Inst_Rep => Scenario_Representation_Of (Scen, In_State), | |
15561 | In_State => In_State); | |
73242473 | 15562 | |
69e6ee2f | 15563 | -- Refined_State pragma |
97ed5872 | 15564 | |
69e6ee2f HK |
15565 | elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then |
15566 | Process_SPARK_Refined_State_Pragma | |
15567 | (Prag => Scen, | |
15568 | Prag_Rep => Scenario_Representation_Of (Scen, In_State), | |
15569 | In_State => In_State); | |
15570 | end if; | |
996ae0b0 | 15571 | |
69e6ee2f HK |
15572 | -- Remove the current scenario from the stack of active scenarios |
15573 | -- once all ABE diagnostics and checks have been performed. | |
996ae0b0 | 15574 | |
69e6ee2f HK |
15575 | Pop_Active_Scenario (Scen); |
15576 | end Process_SPARK_Scenario; | |
996ae0b0 | 15577 | |
69e6ee2f HK |
15578 | ---------------------------------------- |
15579 | -- Process_SPARK_Refined_State_Pragma -- | |
15580 | ---------------------------------------- | |
ab01e614 | 15581 | |
69e6ee2f HK |
15582 | procedure Process_SPARK_Refined_State_Pragma |
15583 | (Prag : Node_Id; | |
15584 | Prag_Rep : Scenario_Rep_Id; | |
15585 | In_State : Processing_In_State) | |
15586 | is | |
15587 | pragma Unreferenced (Prag_Rep); | |
8dce7371 | 15588 | |
69e6ee2f HK |
15589 | procedure Check_SPARK_Constituent (Constit_Id : Entity_Id); |
15590 | pragma Inline (Check_SPARK_Constituent); | |
15591 | -- Ensure that a single constituent Constit_Id is elaborated prior to | |
15592 | -- the main unit. | |
996ae0b0 | 15593 | |
69e6ee2f HK |
15594 | procedure Check_SPARK_Constituents (Constits : Elist_Id); |
15595 | pragma Inline (Check_SPARK_Constituents); | |
15596 | -- Ensure that all constituents found in list Constits are elaborated | |
15597 | -- prior to the main unit. | |
8dce7371 | 15598 | |
69e6ee2f HK |
15599 | procedure Check_SPARK_Initialized_State (State : Node_Id); |
15600 | pragma Inline (Check_SPARK_Initialized_State); | |
15601 | -- Ensure that the constituents of single abstract state State are | |
15602 | -- elaborated prior to the main unit. | |
8dce7371 | 15603 | |
69e6ee2f HK |
15604 | procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id); |
15605 | pragma Inline (Check_SPARK_Initialized_States); | |
15606 | -- Ensure that the constituents of all abstract states which appear | |
15607 | -- in the Initializes pragma of package Pack_Id are elaborated prior | |
15608 | -- to the main unit. | |
8dce7371 | 15609 | |
69e6ee2f HK |
15610 | ----------------------------- |
15611 | -- Check_SPARK_Constituent -- | |
15612 | ----------------------------- | |
8dce7371 | 15613 | |
69e6ee2f HK |
15614 | procedure Check_SPARK_Constituent (Constit_Id : Entity_Id) is |
15615 | SM_Prag : Node_Id; | |
8dce7371 | 15616 | |
69e6ee2f HK |
15617 | begin |
15618 | -- Nothing to do for "null" constituents | |
8dce7371 | 15619 | |
69e6ee2f HK |
15620 | if Nkind (Constit_Id) = N_Null then |
15621 | return; | |
8dce7371 | 15622 | |
69e6ee2f | 15623 | -- Nothing to do for illegal constituents |
8dce7371 | 15624 | |
69e6ee2f HK |
15625 | elsif Error_Posted (Constit_Id) then |
15626 | return; | |
15627 | end if; | |
8dce7371 | 15628 | |
69e6ee2f | 15629 | SM_Prag := SPARK_Pragma (Constit_Id); |
8dce7371 | 15630 | |
69e6ee2f HK |
15631 | -- The check applies only when the constituent is subject to |
15632 | -- pragma SPARK_Mode On. | |
8dce7371 | 15633 | |
69e6ee2f HK |
15634 | if Present (SM_Prag) |
15635 | and then Get_SPARK_Mode_From_Annotation (SM_Prag) = On | |
15636 | then | |
15637 | -- An external constituent of an abstract state which appears | |
15638 | -- in the Initializes pragma of a package spec imposes an | |
15639 | -- Elaborate requirement on the context of the main unit. | |
15640 | -- Determine whether the context has a pragma strong enough to | |
15641 | -- meet the requirement. | |
15642 | ||
15643 | -- IMPORTANT: This check is performed only when -gnatd.v | |
15644 | -- (enforce SPARK elaboration rules in SPARK code) is in effect | |
15645 | -- because the static model can ensure the prior elaboration of | |
15646 | -- the unit which contains a constituent by installing implicit | |
15647 | -- Elaborate pragma. | |
15648 | ||
15649 | if Debug_Flag_Dot_V then | |
15650 | Meet_Elaboration_Requirement | |
15651 | (N => Prag, | |
15652 | Targ_Id => Constit_Id, | |
15653 | Req_Nam => Name_Elaborate, | |
15654 | In_State => In_State); | |
15655 | ||
15656 | -- Otherwise ensure that the unit with the external constituent | |
15657 | -- is elaborated prior to the main unit. | |
996ae0b0 | 15658 | |
69e6ee2f HK |
15659 | else |
15660 | Ensure_Prior_Elaboration | |
15661 | (N => Prag, | |
15662 | Unit_Id => Find_Top_Unit (Constit_Id), | |
15663 | Prag_Nam => Name_Elaborate, | |
15664 | In_State => In_State); | |
15665 | end if; | |
15666 | end if; | |
15667 | end Check_SPARK_Constituent; | |
996ae0b0 | 15668 | |
69e6ee2f HK |
15669 | ------------------------------ |
15670 | -- Check_SPARK_Constituents -- | |
15671 | ------------------------------ | |
ab01e614 | 15672 | |
69e6ee2f HK |
15673 | procedure Check_SPARK_Constituents (Constits : Elist_Id) is |
15674 | Constit_Elmt : Elmt_Id; | |
ab01e614 | 15675 | |
69e6ee2f HK |
15676 | begin |
15677 | if Present (Constits) then | |
15678 | Constit_Elmt := First_Elmt (Constits); | |
15679 | while Present (Constit_Elmt) loop | |
15680 | Check_SPARK_Constituent (Node (Constit_Elmt)); | |
15681 | Next_Elmt (Constit_Elmt); | |
15682 | end loop; | |
15683 | end if; | |
15684 | end Check_SPARK_Constituents; | |
8dce7371 | 15685 | |
69e6ee2f HK |
15686 | ----------------------------------- |
15687 | -- Check_SPARK_Initialized_State -- | |
15688 | ----------------------------------- | |
8dce7371 | 15689 | |
69e6ee2f HK |
15690 | procedure Check_SPARK_Initialized_State (State : Node_Id) is |
15691 | SM_Prag : Node_Id; | |
15692 | State_Id : Entity_Id; | |
8dce7371 | 15693 | |
69e6ee2f HK |
15694 | begin |
15695 | -- Nothing to do for "null" initialization items | |
8dce7371 | 15696 | |
69e6ee2f HK |
15697 | if Nkind (State) = N_Null then |
15698 | return; | |
996ae0b0 | 15699 | |
69e6ee2f | 15700 | -- Nothing to do for illegal states |
996ae0b0 | 15701 | |
69e6ee2f HK |
15702 | elsif Error_Posted (State) then |
15703 | return; | |
15704 | end if; | |
8dce7371 | 15705 | |
69e6ee2f | 15706 | State_Id := Entity_Of (State); |
8dce7371 | 15707 | |
69e6ee2f | 15708 | -- Sanitize the state |
996ae0b0 | 15709 | |
69e6ee2f HK |
15710 | if No (State_Id) then |
15711 | return; | |
996ae0b0 | 15712 | |
69e6ee2f HK |
15713 | elsif Error_Posted (State_Id) then |
15714 | return; | |
996ae0b0 | 15715 | |
69e6ee2f HK |
15716 | elsif Ekind (State_Id) /= E_Abstract_State then |
15717 | return; | |
15718 | end if; | |
996ae0b0 | 15719 | |
69e6ee2f HK |
15720 | -- The check is performed only when the abstract state is subject |
15721 | -- to SPARK_Mode On. | |
8dce7371 | 15722 | |
69e6ee2f | 15723 | SM_Prag := SPARK_Pragma (State_Id); |
8dce7371 | 15724 | |
69e6ee2f HK |
15725 | if Present (SM_Prag) |
15726 | and then Get_SPARK_Mode_From_Annotation (SM_Prag) = On | |
15727 | then | |
15728 | Check_SPARK_Constituents (Refinement_Constituents (State_Id)); | |
15729 | end if; | |
15730 | end Check_SPARK_Initialized_State; | |
8dce7371 | 15731 | |
69e6ee2f HK |
15732 | ------------------------------------ |
15733 | -- Check_SPARK_Initialized_States -- | |
15734 | ------------------------------------ | |
8dce7371 | 15735 | |
69e6ee2f HK |
15736 | procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id) is |
15737 | Init_Prag : constant Node_Id := | |
15738 | Get_Pragma (Pack_Id, Pragma_Initializes); | |
c23f55b4 | 15739 | |
69e6ee2f HK |
15740 | Init : Node_Id; |
15741 | Inits : Node_Id; | |
c23f55b4 | 15742 | |
69e6ee2f HK |
15743 | begin |
15744 | if Present (Init_Prag) then | |
15745 | Inits := Expression (Get_Argument (Init_Prag, Pack_Id)); | |
8dce7371 | 15746 | |
69e6ee2f HK |
15747 | -- Avoid processing a "null" initialization list. The only |
15748 | -- other alternative is an aggregate. | |
8dce7371 | 15749 | |
69e6ee2f | 15750 | if Nkind (Inits) = N_Aggregate then |
996ae0b0 | 15751 | |
69e6ee2f HK |
15752 | -- The initialization items appear in list form: |
15753 | -- | |
15754 | -- (state1, state2) | |
996ae0b0 | 15755 | |
69e6ee2f HK |
15756 | if Present (Expressions (Inits)) then |
15757 | Init := First (Expressions (Inits)); | |
15758 | while Present (Init) loop | |
15759 | Check_SPARK_Initialized_State (Init); | |
15760 | Next (Init); | |
15761 | end loop; | |
15762 | end if; | |
996ae0b0 | 15763 | |
69e6ee2f HK |
15764 | -- The initialization items appear in associated form: |
15765 | -- | |
15766 | -- (state1 => item1, | |
15767 | -- state2 => (item2, item3)) | |
15768 | ||
15769 | if Present (Component_Associations (Inits)) then | |
15770 | Init := First (Component_Associations (Inits)); | |
15771 | while Present (Init) loop | |
15772 | Check_SPARK_Initialized_State (Init); | |
15773 | Next (Init); | |
15774 | end loop; | |
15775 | end if; | |
15776 | end if; | |
15777 | end if; | |
15778 | end Check_SPARK_Initialized_States; | |
7cc7f3aa | 15779 | |
69e6ee2f | 15780 | -- Local variables |
7cc7f3aa | 15781 | |
69e6ee2f | 15782 | Pack_Body : constant Node_Id := Find_Related_Package_Or_Body (Prag); |
7cc7f3aa | 15783 | |
69e6ee2f | 15784 | -- Start of processing for Process_SPARK_Refined_State_Pragma |
996ae0b0 | 15785 | |
69e6ee2f HK |
15786 | begin |
15787 | -- Pragma Refined_State must be associated with a package body | |
bde33286 | 15788 | |
69e6ee2f HK |
15789 | pragma Assert |
15790 | (Present (Pack_Body) and then Nkind (Pack_Body) = N_Package_Body); | |
996ae0b0 | 15791 | |
69e6ee2f HK |
15792 | -- Verify that each external contitunent of an abstract state |
15793 | -- mentioned in pragma Initializes is properly elaborated. | |
996ae0b0 | 15794 | |
69e6ee2f HK |
15795 | Check_SPARK_Initialized_States (Unique_Defining_Entity (Pack_Body)); |
15796 | end Process_SPARK_Refined_State_Pragma; | |
15797 | end SPARK_Processor; | |
996ae0b0 | 15798 | |
69e6ee2f HK |
15799 | ------------------------------- |
15800 | -- Spec_And_Body_From_Entity -- | |
15801 | ------------------------------- | |
996ae0b0 | 15802 | |
69e6ee2f HK |
15803 | procedure Spec_And_Body_From_Entity |
15804 | (Id : Node_Id; | |
15805 | Spec_Decl : out Node_Id; | |
15806 | Body_Decl : out Node_Id) | |
15807 | is | |
15808 | begin | |
15809 | Spec_And_Body_From_Node | |
15810 | (N => Unit_Declaration_Node (Id), | |
15811 | Spec_Decl => Spec_Decl, | |
15812 | Body_Decl => Body_Decl); | |
15813 | end Spec_And_Body_From_Entity; | |
0c9849e1 | 15814 | |
69e6ee2f HK |
15815 | ----------------------------- |
15816 | -- Spec_And_Body_From_Node -- | |
15817 | ----------------------------- | |
967947ed | 15818 | |
69e6ee2f HK |
15819 | procedure Spec_And_Body_From_Node |
15820 | (N : Node_Id; | |
15821 | Spec_Decl : out Node_Id; | |
15822 | Body_Decl : out Node_Id) | |
15823 | is | |
15824 | Body_Id : Entity_Id; | |
15825 | Spec_Id : Entity_Id; | |
967947ed | 15826 | |
69e6ee2f HK |
15827 | begin |
15828 | -- Assume that the construct lacks spec and body | |
996ae0b0 | 15829 | |
69e6ee2f HK |
15830 | Body_Decl := Empty; |
15831 | Spec_Decl := Empty; | |
996ae0b0 | 15832 | |
69e6ee2f | 15833 | -- Bodies |
996ae0b0 | 15834 | |
69e6ee2f HK |
15835 | if Nkind_In (N, N_Package_Body, |
15836 | N_Protected_Body, | |
15837 | N_Subprogram_Body, | |
15838 | N_Task_Body) | |
15839 | then | |
15840 | Spec_Id := Corresponding_Spec (N); | |
996ae0b0 | 15841 | |
69e6ee2f | 15842 | -- The body completes a previous declaration |
996ae0b0 | 15843 | |
69e6ee2f HK |
15844 | if Present (Spec_Id) then |
15845 | Spec_Decl := Unit_Declaration_Node (Spec_Id); | |
996ae0b0 | 15846 | |
69e6ee2f HK |
15847 | -- Otherwise the body acts as the initial declaration, and is both a |
15848 | -- spec and body. There is no need to look for an optional body. | |
996ae0b0 | 15849 | |
69e6ee2f HK |
15850 | else |
15851 | Body_Decl := N; | |
15852 | Spec_Decl := N; | |
15853 | return; | |
15854 | end if; | |
2dcf2584 | 15855 | |
69e6ee2f | 15856 | -- Declarations |
2dcf2584 | 15857 | |
69e6ee2f HK |
15858 | elsif Nkind_In (N, N_Entry_Declaration, |
15859 | N_Generic_Package_Declaration, | |
15860 | N_Generic_Subprogram_Declaration, | |
15861 | N_Package_Declaration, | |
15862 | N_Protected_Type_Declaration, | |
15863 | N_Subprogram_Declaration, | |
15864 | N_Task_Type_Declaration) | |
15865 | then | |
15866 | Spec_Decl := N; | |
7cc7f3aa | 15867 | |
69e6ee2f | 15868 | -- Expression function |
7cc7f3aa | 15869 | |
69e6ee2f HK |
15870 | elsif Nkind (N) = N_Expression_Function then |
15871 | Spec_Id := Corresponding_Spec (N); | |
15872 | pragma Assert (Present (Spec_Id)); | |
7cc7f3aa | 15873 | |
69e6ee2f | 15874 | Spec_Decl := Unit_Declaration_Node (Spec_Id); |
996ae0b0 | 15875 | |
69e6ee2f | 15876 | -- Instantiations |
7cc7f3aa | 15877 | |
69e6ee2f HK |
15878 | elsif Nkind (N) in N_Generic_Instantiation then |
15879 | Spec_Decl := Instance_Spec (N); | |
15880 | pragma Assert (Present (Spec_Decl)); | |
7cc7f3aa | 15881 | |
69e6ee2f | 15882 | -- Stubs |
7cc7f3aa | 15883 | |
69e6ee2f HK |
15884 | elsif Nkind (N) in N_Body_Stub then |
15885 | Spec_Id := Corresponding_Spec_Of_Stub (N); | |
7cc7f3aa | 15886 | |
69e6ee2f | 15887 | -- The stub completes a previous declaration |
996ae0b0 | 15888 | |
69e6ee2f HK |
15889 | if Present (Spec_Id) then |
15890 | Spec_Decl := Unit_Declaration_Node (Spec_Id); | |
07fc65c4 | 15891 | |
69e6ee2f | 15892 | -- Otherwise the stub acts as a spec |
fbf5a39b | 15893 | |
69e6ee2f HK |
15894 | else |
15895 | Spec_Decl := N; | |
15896 | end if; | |
90e491a7 | 15897 | end if; |
f691d19f | 15898 | |
69e6ee2f | 15899 | -- Obtain an optional or mandatory body |
f691d19f | 15900 | |
69e6ee2f HK |
15901 | if Present (Spec_Decl) then |
15902 | Body_Id := Corresponding_Body (Spec_Decl); | |
f691d19f | 15903 | |
69e6ee2f HK |
15904 | if Present (Body_Id) then |
15905 | Body_Decl := Unit_Declaration_Node (Body_Id); | |
15906 | end if; | |
90e491a7 | 15907 | end if; |
69e6ee2f | 15908 | end Spec_And_Body_From_Node; |
f691d19f | 15909 | |
69e6ee2f HK |
15910 | ------------------------------- |
15911 | -- Static_Elaboration_Checks -- | |
15912 | ------------------------------- | |
f691d19f | 15913 | |
69e6ee2f HK |
15914 | function Static_Elaboration_Checks return Boolean is |
15915 | begin | |
15916 | return not Dynamic_Elaboration_Checks; | |
15917 | end Static_Elaboration_Checks; | |
f691d19f | 15918 | |
7255f3c3 HK |
15919 | ----------------- |
15920 | -- Unit_Entity -- | |
15921 | ----------------- | |
15922 | ||
15923 | function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id is | |
15924 | function Is_Subunit (Id : Entity_Id) return Boolean; | |
15925 | pragma Inline (Is_Subunit); | |
15926 | -- Determine whether the entity of an initial declaration denotes a | |
15927 | -- subunit. | |
15928 | ||
15929 | ---------------- | |
15930 | -- Is_Subunit -- | |
15931 | ---------------- | |
15932 | ||
15933 | function Is_Subunit (Id : Entity_Id) return Boolean is | |
15934 | Decl : constant Node_Id := Unit_Declaration_Node (Id); | |
15935 | ||
15936 | begin | |
15937 | return | |
15938 | Nkind_In (Decl, N_Generic_Package_Declaration, | |
15939 | N_Generic_Subprogram_Declaration, | |
15940 | N_Package_Declaration, | |
15941 | N_Protected_Type_Declaration, | |
15942 | N_Subprogram_Declaration, | |
15943 | N_Task_Type_Declaration) | |
15944 | and then Present (Corresponding_Body (Decl)) | |
15945 | and then Nkind (Parent (Unit_Declaration_Node | |
15946 | (Corresponding_Body (Decl)))) = N_Subunit; | |
15947 | end Is_Subunit; | |
15948 | ||
15949 | -- Local variables | |
15950 | ||
15951 | Id : Entity_Id; | |
15952 | ||
15953 | -- Start of processing for Unit_Entity | |
15954 | ||
15955 | begin | |
15956 | Id := Unique_Entity (Unit_Id); | |
15957 | ||
15958 | -- Skip all subunits found in the scope chain which ends at the input | |
15959 | -- unit. | |
15960 | ||
15961 | while Is_Subunit (Id) loop | |
15962 | Id := Scope (Id); | |
15963 | end loop; | |
15964 | ||
15965 | return Id; | |
15966 | end Unit_Entity; | |
15967 | ||
90e491a7 PMR |
15968 | --------------------------------- |
15969 | -- Update_Elaboration_Scenario -- | |
15970 | --------------------------------- | |
f691d19f | 15971 | |
90e491a7 | 15972 | procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id) is |
90e491a7 | 15973 | begin |
0839ffce HK |
15974 | -- Nothing to do when the elaboration phase of the compiler is not |
15975 | -- active. | |
15976 | ||
15977 | if not Elaboration_Phase_Active then | |
15978 | return; | |
15979 | ||
c23f55b4 PMR |
15980 | -- Nothing to do when the old and new scenarios are one and the same |
15981 | ||
0839ffce | 15982 | elsif Old_N = New_N then |
c23f55b4 | 15983 | return; |
0839ffce | 15984 | end if; |
c23f55b4 | 15985 | |
90e491a7 PMR |
15986 | -- A scenario is being transformed by Atree.Rewrite. Update all relevant |
15987 | -- internal data structures to reflect this change. This ensures that a | |
15988 | -- potential run-time conditional ABE check or a guaranteed ABE failure | |
15989 | -- is inserted at the proper place in the tree. | |
15990 | ||
0839ffce | 15991 | if Is_Scenario (Old_N) then |
69e6ee2f | 15992 | Replace_Scenario (Old_N, New_N); |
90e491a7 PMR |
15993 | end if; |
15994 | end Update_Elaboration_Scenario; | |
07fc65c4 | 15995 | |
967947ed PMR |
15996 | --------------------------------------------------------------------------- |
15997 | -- -- | |
15998 | -- L E G A C Y A C C E S S B E F O R E E L A B O R A T I O N -- | |
15999 | -- -- | |
16000 | -- M E C H A N I S M -- | |
16001 | -- -- | |
16002 | --------------------------------------------------------------------------- | |
16003 | ||
16004 | -- This section contains the implementation of the pre-18.x legacy ABE | |
16005 | -- mechanism. The mechanism can be activated using switch -gnatH (legacy | |
16006 | -- elaboration checking mode enabled). | |
16007 | ||
16008 | ----------------------------- | |
16009 | -- Description of Approach -- | |
16010 | ----------------------------- | |
16011 | ||
16012 | -- Every non-static call that is encountered by Sem_Res results in a call | |
16013 | -- to Check_Elab_Call, with N being the call node, and Outer set to its | |
16014 | -- default value of True. In addition X'Access is treated like a call | |
16015 | -- for the access-to-procedure case, and in SPARK mode only we also | |
16016 | -- check variable references. | |
16017 | ||
16018 | -- The goal of Check_Elab_Call is to determine whether or not the reference | |
16019 | -- in question can generate an access before elaboration error (raising | |
16020 | -- Program_Error) either by directly calling a subprogram whose body | |
16021 | -- has not yet been elaborated, or indirectly, by calling a subprogram | |
16022 | -- whose body has been elaborated, but which contains a call to such a | |
16023 | -- subprogram. | |
16024 | ||
16025 | -- In addition, in SPARK mode, we are checking for a variable reference in | |
16026 | -- another package, which requires an explicit Elaborate_All pragma. | |
16027 | ||
16028 | -- The only references that we need to look at the outer level are | |
16029 | -- references that occur in elaboration code. There are two cases. The | |
16030 | -- reference can be at the outer level of elaboration code, or it can | |
16031 | -- be within another unit, e.g. the elaboration code of a subprogram. | |
16032 | ||
16033 | -- In the case of an elaboration call at the outer level, we must trace | |
16034 | -- all calls to outer level routines either within the current unit or to | |
16035 | -- other units that are with'ed. For calls within the current unit, we can | |
16036 | -- determine if the body has been elaborated or not, and if it has not, | |
16037 | -- then a warning is generated. | |
16038 | ||
16039 | -- Note that there are two subcases. If the original call directly calls a | |
16040 | -- subprogram whose body has not been elaborated, then we know that an ABE | |
16041 | -- will take place, and we replace the call by a raise of Program_Error. | |
16042 | -- If the call is indirect, then we don't know that the PE will be raised, | |
16043 | -- since the call might be guarded by a conditional. In this case we set | |
16044 | -- Do_Elab_Check on the call so that a dynamic check is generated, and | |
16045 | -- output a warning. | |
16046 | ||
16047 | -- For calls to a subprogram in a with'ed unit or a 'Access or variable | |
16048 | -- reference (SPARK mode case), we require that a pragma Elaborate_All | |
16049 | -- or pragma Elaborate be present, or that the referenced unit have a | |
16050 | -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none | |
16051 | -- of these conditions is met, then a warning is generated that a pragma | |
16052 | -- Elaborate_All may be needed (error in the SPARK case), or an implicit | |
16053 | -- pragma is generated. | |
16054 | ||
16055 | -- For the case of an elaboration call at some inner level, we are | |
16056 | -- interested in tracing only calls to subprograms at the same level, i.e. | |
16057 | -- those that can be called during elaboration. Any calls to outer level | |
16058 | -- routines cannot cause ABE's as a result of the original call (there | |
16059 | -- might be an outer level call to the subprogram from outside that causes | |
16060 | -- the ABE, but that gets analyzed separately). | |
16061 | ||
16062 | -- Note that we never trace calls to inner level subprograms, since these | |
16063 | -- cannot result in ABE's unless there is an elaboration problem at a lower | |
16064 | -- level, which will be separately detected. | |
16065 | ||
16066 | -- Note on pragma Elaborate. The checking here assumes that a pragma | |
16067 | -- Elaborate on a with'ed unit guarantees that subprograms within the unit | |
16068 | -- can be called without causing an ABE. This is not in fact the case since | |
16069 | -- pragma Elaborate does not guarantee the transitive coverage guaranteed | |
16070 | -- by Elaborate_All. However, we decide to trust the user in this case. | |
16071 | ||
16072 | -------------------------------------- | |
16073 | -- Instantiation Elaboration Errors -- | |
16074 | -------------------------------------- | |
16075 | ||
16076 | -- A special case arises when an instantiation appears in a context that is | |
16077 | -- known to be before the body is elaborated, e.g. | |
16078 | ||
16079 | -- generic package x is ... | |
16080 | -- ... | |
16081 | -- package xx is new x; | |
16082 | -- ... | |
16083 | -- package body x is ... | |
16084 | ||
16085 | -- In this situation it is certain that an elaboration error will occur, | |
16086 | -- and an unconditional raise Program_Error statement is inserted before | |
16087 | -- the instantiation, and a warning generated. | |
16088 | ||
16089 | -- The problem is that in this case we have no place to put the body of | |
16090 | -- the instantiation. We can't put it in the normal place, because it is | |
16091 | -- too early, and will cause errors to occur as a result of referencing | |
16092 | -- entities before they are declared. | |
16093 | ||
16094 | -- Our approach in this case is simply to avoid creating the body of the | |
16095 | -- instantiation in such a case. The instantiation spec is modified to | |
16096 | -- include dummy bodies for all subprograms, so that the resulting code | |
16097 | -- does not contain subprogram specs with no corresponding bodies. | |
16098 | ||
16099 | -- The following table records the recursive call chain for output in the | |
16100 | -- Output routine. Each entry records the call node and the entity of the | |
16101 | -- called routine. The number of entries in the table (i.e. the value of | |
16102 | -- Elab_Call.Last) indicates the current depth of recursion and is used to | |
16103 | -- identify the outer level. | |
16104 | ||
16105 | type Elab_Call_Element is record | |
16106 | Cloc : Source_Ptr; | |
16107 | Ent : Entity_Id; | |
16108 | end record; | |
16109 | ||
16110 | package Elab_Call is new Table.Table | |
16111 | (Table_Component_Type => Elab_Call_Element, | |
16112 | Table_Index_Type => Int, | |
16113 | Table_Low_Bound => 1, | |
16114 | Table_Initial => 50, | |
16115 | Table_Increment => 100, | |
16116 | Table_Name => "Elab_Call"); | |
16117 | ||
16118 | -- The following table records all calls that have been processed starting | |
16119 | -- from an outer level call. The table prevents both infinite recursion and | |
16120 | -- useless reanalysis of calls within the same context. The use of context | |
16121 | -- is important because it allows for proper checks in more complex code: | |
16122 | ||
16123 | -- if ... then | |
16124 | -- Call; -- requires a check | |
16125 | -- Call; -- does not need a check thanks to the table | |
16126 | -- elsif ... then | |
16127 | -- Call; -- requires a check, different context | |
16128 | -- end if; | |
16129 | ||
16130 | -- Call; -- requires a check, different context | |
16131 | ||
16132 | type Visited_Element is record | |
16133 | Subp_Id : Entity_Id; | |
16134 | -- The entity of the subprogram being called | |
16135 | ||
16136 | Context : Node_Id; | |
16137 | -- The context where the call to the subprogram occurs | |
16138 | end record; | |
16139 | ||
16140 | package Elab_Visited is new Table.Table | |
16141 | (Table_Component_Type => Visited_Element, | |
16142 | Table_Index_Type => Int, | |
16143 | Table_Low_Bound => 1, | |
16144 | Table_Initial => 200, | |
16145 | Table_Increment => 100, | |
16146 | Table_Name => "Elab_Visited"); | |
16147 | ||
16148 | -- The following table records delayed calls which must be examined after | |
16149 | -- all generic bodies have been instantiated. | |
16150 | ||
16151 | type Delay_Element is record | |
16152 | N : Node_Id; | |
16153 | -- The parameter N from the call to Check_Internal_Call. Note that this | |
16154 | -- node may get rewritten over the delay period by expansion in the call | |
16155 | -- case (but not in the instantiation case). | |
16156 | ||
16157 | E : Entity_Id; | |
16158 | -- The parameter E from the call to Check_Internal_Call | |
16159 | ||
16160 | Orig_Ent : Entity_Id; | |
16161 | -- The parameter Orig_Ent from the call to Check_Internal_Call | |
16162 | ||
16163 | Curscop : Entity_Id; | |
16164 | -- The current scope of the call. This is restored when we complete the | |
16165 | -- delayed call, so that we do this in the right scope. | |
16166 | ||
16167 | Outer_Scope : Entity_Id; | |
16168 | -- Save scope of outer level call | |
16169 | ||
16170 | From_Elab_Code : Boolean; | |
16171 | -- Save indication of whether this call is from elaboration code | |
16172 | ||
16173 | In_Task_Activation : Boolean; | |
16174 | -- Save indication of whether this call is from a task body. Tasks are | |
16175 | -- activated at the "begin", which is after all local procedure bodies, | |
16176 | -- so calls to those procedures can't fail, even if they occur after the | |
16177 | -- task body. | |
16178 | ||
16179 | From_SPARK_Code : Boolean; | |
16180 | -- Save indication of whether this call is under SPARK_Mode => On | |
16181 | end record; | |
16182 | ||
16183 | package Delay_Check is new Table.Table | |
16184 | (Table_Component_Type => Delay_Element, | |
16185 | Table_Index_Type => Int, | |
16186 | Table_Low_Bound => 1, | |
16187 | Table_Initial => 1000, | |
16188 | Table_Increment => 100, | |
16189 | Table_Name => "Delay_Check"); | |
16190 | ||
16191 | C_Scope : Entity_Id; | |
16192 | -- Top-level scope of current scope. Compute this only once at the outer | |
16193 | -- level, i.e. for a call to Check_Elab_Call from outside this unit. | |
16194 | ||
16195 | Outer_Level_Sloc : Source_Ptr; | |
16196 | -- Save Sloc value for outer level call node for comparisons of source | |
16197 | -- locations. A body is too late if it appears after the *outer* level | |
16198 | -- call, not the particular call that is being analyzed. | |
16199 | ||
16200 | From_Elab_Code : Boolean; | |
16201 | -- This flag shows whether the outer level call currently being examined | |
16202 | -- is or is not in elaboration code. We are only interested in calls to | |
16203 | -- routines in other units if this flag is True. | |
16204 | ||
16205 | In_Task_Activation : Boolean := False; | |
16206 | -- This flag indicates whether we are performing elaboration checks on task | |
16207 | -- bodies, at the point of activation. If true, we do not raise | |
16208 | -- Program_Error for calls to local procedures, because all local bodies | |
16209 | -- are known to be elaborated. However, we still need to trace such calls, | |
16210 | -- because a local procedure could call a procedure in another package, | |
16211 | -- so we might need an implicit Elaborate_All. | |
16212 | ||
16213 | Delaying_Elab_Checks : Boolean := True; | |
16214 | -- This is set True till the compilation is complete, including the | |
16215 | -- insertion of all instance bodies. Then when Check_Elab_Calls is called, | |
16216 | -- the delay table is used to make the delayed calls and this flag is reset | |
16217 | -- to False, so that the calls are processed. | |
16218 | ||
16219 | ----------------------- | |
16220 | -- Local Subprograms -- | |
16221 | ----------------------- | |
16222 | ||
16223 | -- Note: Outer_Scope in all following specs represents the scope of | |
16224 | -- interest of the outer level call. If it is set to Standard_Standard, | |
16225 | -- then it means the outer level call was at elaboration level, and that | |
16226 | -- thus all calls are of interest. If it was set to some other scope, | |
16227 | -- then the original call was an inner call, and we are not interested | |
16228 | -- in calls that go outside this scope. | |
16229 | ||
16230 | procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id); | |
16231 | -- Analysis of construct N shows that we should set Elaborate_All_Desirable | |
16232 | -- for the WITH clause for unit U (which will always be present). A special | |
16233 | -- case is when N is a function or procedure instantiation, in which case | |
16234 | -- it is sufficient to set Elaborate_Desirable, since in this case there is | |
16235 | -- no possibility of transitive elaboration issues. | |
16236 | ||
16237 | procedure Check_A_Call | |
16238 | (N : Node_Id; | |
16239 | E : Entity_Id; | |
16240 | Outer_Scope : Entity_Id; | |
16241 | Inter_Unit_Only : Boolean; | |
16242 | Generate_Warnings : Boolean := True; | |
16243 | In_Init_Proc : Boolean := False); | |
16244 | -- This is the internal recursive routine that is called to check for | |
16245 | -- possible elaboration error. The argument N is a subprogram call or | |
16246 | -- generic instantiation, or 'Access attribute reference to be checked, and | |
16247 | -- E is the entity of the called subprogram, or instantiated generic unit, | |
16248 | -- or subprogram referenced by 'Access. | |
16249 | -- | |
16250 | -- In SPARK mode, N can also be a variable reference, since in SPARK this | |
16251 | -- also triggers a requirement for Elaborate_All, and in this case E is the | |
16252 | -- entity being referenced. | |
16253 | -- | |
16254 | -- Outer_Scope is the outer level scope for the original reference. | |
16255 | -- Inter_Unit_Only is set if the call is only to be checked in the | |
16256 | -- case where it is to another unit (and skipped if within a unit). | |
16257 | -- Generate_Warnings is set to False to suppress warning messages about | |
16258 | -- missing pragma Elaborate_All's. These messages are not wanted for | |
16259 | -- inner calls in the dynamic model. Note that an instance of the Access | |
16260 | -- attribute applied to a subprogram also generates a call to this | |
16261 | -- procedure (since the referenced subprogram may be called later | |
16262 | -- indirectly). Flag In_Init_Proc should be set whenever the current | |
16263 | -- context is a type init proc. | |
16264 | -- | |
16265 | -- Note: this might better be called Check_A_Reference to recognize the | |
16266 | -- variable case for SPARK, but we prefer to retain the historical name | |
16267 | -- since in practice this is mostly about checking calls for the possible | |
16268 | -- occurrence of an access-before-elaboration exception. | |
16269 | ||
16270 | procedure Check_Bad_Instantiation (N : Node_Id); | |
16271 | -- N is a node for an instantiation (if called with any other node kind, | |
16272 | -- Check_Bad_Instantiation ignores the call). This subprogram checks for | |
16273 | -- the special case of a generic instantiation of a generic spec in the | |
16274 | -- same declarative part as the instantiation where a body is present and | |
16275 | -- has not yet been seen. This is an obvious error, but needs to be checked | |
16276 | -- specially at the time of the instantiation, since it is a case where we | |
16277 | -- cannot insert the body anywhere. If this case is detected, warnings are | |
16278 | -- generated, and a raise of Program_Error is inserted. In addition any | |
16279 | -- subprograms in the generic spec are stubbed, and the Bad_Instantiation | |
16280 | -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this | |
16281 | -- flag as an indication that no attempt should be made to insert an | |
16282 | -- instance body. | |
16283 | ||
16284 | procedure Check_Internal_Call | |
16285 | (N : Node_Id; | |
16286 | E : Entity_Id; | |
16287 | Outer_Scope : Entity_Id; | |
16288 | Orig_Ent : Entity_Id); | |
16289 | -- N is a function call or procedure statement call node and E is the | |
16290 | -- entity of the called function, which is within the current compilation | |
16291 | -- unit (where subunits count as part of the parent). This call checks if | |
16292 | -- this call, or any call within any accessed body could cause an ABE, and | |
16293 | -- if so, outputs a warning. Orig_Ent differs from E only in the case of | |
16294 | -- renamings, and points to the original name of the entity. This is used | |
16295 | -- for error messages. Outer_Scope is the outer level scope for the | |
16296 | -- original call. | |
16297 | ||
16298 | procedure Check_Internal_Call_Continue | |
16299 | (N : Node_Id; | |
16300 | E : Entity_Id; | |
16301 | Outer_Scope : Entity_Id; | |
16302 | Orig_Ent : Entity_Id); | |
16303 | -- The processing for Check_Internal_Call is divided up into two phases, | |
16304 | -- and this represents the second phase. The second phase is delayed if | |
16305 | -- Delaying_Elab_Checks is set to True. In this delayed case, the first | |
16306 | -- phase makes an entry in the Delay_Check table, which is processed when | |
16307 | -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to | |
16308 | -- Check_Internal_Call. Outer_Scope is the outer level scope for the | |
16309 | -- original call. | |
16310 | ||
16311 | function Get_Referenced_Ent (N : Node_Id) return Entity_Id; | |
16312 | -- N is either a function or procedure call or an access attribute that | |
16313 | -- references a subprogram. This call retrieves the relevant entity. If | |
16314 | -- this is a call to a protected subprogram, the entity is a selected | |
16315 | -- component. The callable entity may be absent, in which case Empty is | |
16316 | -- returned. This happens with non-analyzed calls in nested generics. | |
16317 | -- | |
16318 | -- If SPARK_Mode is On, then N can also be a reference to an E_Variable | |
16319 | -- entity, in which case, the value returned is simply this entity. | |
16320 | ||
16321 | function Has_Generic_Body (N : Node_Id) return Boolean; | |
16322 | -- N is a generic package instantiation node, and this routine determines | |
16323 | -- if this package spec does in fact have a generic body. If so, then | |
16324 | -- True is returned, otherwise False. Note that this is not at all the | |
16325 | -- same as checking if the unit requires a body, since it deals with | |
16326 | -- the case of optional bodies accurately (i.e. if a body is optional, | |
16327 | -- then it looks to see if a body is actually present). Note: this | |
16328 | -- function can only do a fully correct job if in generating code mode | |
16329 | -- where all bodies have to be present. If we are operating in semantics | |
16330 | -- check only mode, then in some cases of optional bodies, a result of | |
16331 | -- False may incorrectly be given. In practice this simply means that | |
16332 | -- some cases of warnings for incorrect order of elaboration will only | |
16333 | -- be given when generating code, which is not a big problem (and is | |
16334 | -- inevitable, given the optional body semantics of Ada). | |
16335 | ||
16336 | procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty); | |
16337 | -- Given code for an elaboration check (or unconditional raise if the check | |
16338 | -- is not needed), inserts the code in the appropriate place. N is the call | |
16339 | -- or instantiation node for which the check code is required. C is the | |
16340 | -- test whose failure triggers the raise. | |
16341 | ||
16342 | function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean; | |
16343 | -- Returns True if node N is a call to a generic formal subprogram | |
16344 | ||
16345 | function Is_Finalization_Procedure (Id : Entity_Id) return Boolean; | |
16346 | -- Determine whether entity Id denotes a [Deep_]Finalize procedure | |
16347 | ||
16348 | procedure Output_Calls | |
16349 | (N : Node_Id; | |
16350 | Check_Elab_Flag : Boolean); | |
16351 | -- Outputs chain of calls stored in the Elab_Call table. The caller has | |
16352 | -- already generated the main warning message, so the warnings generated | |
16353 | -- are all continuation messages. The argument is the call node at which | |
16354 | -- the messages are to be placed. When Check_Elab_Flag is set, calls are | |
16355 | -- enumerated only when flag Elab_Warning is set for the dynamic case or | |
16356 | -- when flag Elab_Info_Messages is set for the static case. | |
16357 | ||
16358 | function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; | |
16359 | -- Given two scopes, determine whether they are the same scope from an | |
16360 | -- elaboration point of view, i.e. packages and blocks are ignored. | |
16361 | ||
16362 | procedure Set_C_Scope; | |
16363 | -- On entry C_Scope is set to some scope. On return, C_Scope is reset | |
16364 | -- to be the enclosing compilation unit of this scope. | |
16365 | ||
16366 | procedure Set_Elaboration_Constraint | |
16367 | (Call : Node_Id; | |
16368 | Subp : Entity_Id; | |
16369 | Scop : Entity_Id); | |
16370 | -- The current unit U may depend semantically on some unit P that is not | |
16371 | -- in the current context. If there is an elaboration call that reaches P, | |
16372 | -- we need to indicate that P requires an Elaborate_All, but this is not | |
16373 | -- effective in U's ali file, if there is no with_clause for P. In this | |
16374 | -- case we add the Elaborate_All on the unit Q that directly or indirectly | |
16375 | -- makes P available. This can happen in two cases: | |
16376 | -- | |
16377 | -- a) Q declares a subtype of a type declared in P, and the call is an | |
16378 | -- initialization call for an object of that subtype. | |
16379 | -- | |
16380 | -- b) Q declares an object of some tagged type whose root type is | |
16381 | -- declared in P, and the initialization call uses object notation on | |
16382 | -- that object to reach a primitive operation or a classwide operation | |
16383 | -- declared in P. | |
16384 | -- | |
16385 | -- If P appears in the context of U, the current processing is correct. | |
16386 | -- Otherwise we must identify these two cases to retrieve Q and place the | |
16387 | -- Elaborate_All_Desirable on it. | |
16388 | ||
16389 | function Spec_Entity (E : Entity_Id) return Entity_Id; | |
16390 | -- Given a compilation unit entity, if it is a spec entity, it is returned | |
16391 | -- unchanged. If it is a body entity, then the spec for the corresponding | |
16392 | -- spec is returned | |
16393 | ||
16394 | function Within (E1, E2 : Entity_Id) return Boolean; | |
16395 | -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one | |
16396 | -- of its contained scopes, False otherwise. | |
16397 | ||
16398 | function Within_Elaborate_All | |
16399 | (Unit : Unit_Number_Type; | |
16400 | E : Entity_Id) return Boolean; | |
16401 | -- Return True if we are within the scope of an Elaborate_All for E, or if | |
16402 | -- we are within the scope of an Elaborate_All for some other unit U, and U | |
16403 | -- with's E. This prevents spurious warnings when the called entity is | |
16404 | -- renamed within U, or in case of generic instances. | |
16405 | ||
16406 | -------------------------------------- | |
16407 | -- Activate_Elaborate_All_Desirable -- | |
16408 | -------------------------------------- | |
16409 | ||
16410 | procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id) is | |
16411 | UN : constant Unit_Number_Type := Get_Code_Unit (N); | |
16412 | CU : constant Node_Id := Cunit (UN); | |
16413 | UE : constant Entity_Id := Cunit_Entity (UN); | |
16414 | Unm : constant Unit_Name_Type := Unit_Name (UN); | |
16415 | CI : constant List_Id := Context_Items (CU); | |
16416 | Itm : Node_Id; | |
16417 | Ent : Entity_Id; | |
16418 | ||
16419 | procedure Add_To_Context_And_Mark (Itm : Node_Id); | |
16420 | -- This procedure is called when the elaborate indication must be | |
16421 | -- applied to a unit not in the context of the referencing unit. The | |
16422 | -- unit gets added to the context as an implicit with. | |
16423 | ||
16424 | function In_Withs_Of (UEs : Entity_Id) return Boolean; | |
16425 | -- UEs is the spec entity of a unit. If the unit to be marked is | |
16426 | -- in the context item list of this unit spec, then the call returns | |
16427 | -- True and Itm is left set to point to the relevant N_With_Clause node. | |
16428 | ||
16429 | procedure Set_Elab_Flag (Itm : Node_Id); | |
16430 | -- Sets Elaborate_[All_]Desirable as appropriate on Itm | |
16431 | ||
16432 | ----------------------------- | |
16433 | -- Add_To_Context_And_Mark -- | |
16434 | ----------------------------- | |
16435 | ||
16436 | procedure Add_To_Context_And_Mark (Itm : Node_Id) is | |
16437 | CW : constant Node_Id := | |
16438 | Make_With_Clause (Sloc (Itm), | |
16439 | Name => Name (Itm)); | |
16440 | ||
16441 | begin | |
16442 | Set_Library_Unit (CW, Library_Unit (Itm)); | |
94ce4941 | 16443 | Set_Implicit_With (CW); |
967947ed PMR |
16444 | |
16445 | -- Set elaborate all desirable on copy and then append the copy to | |
16446 | -- the list of body with's and we are done. | |
16447 | ||
16448 | Set_Elab_Flag (CW); | |
16449 | Append_To (CI, CW); | |
16450 | end Add_To_Context_And_Mark; | |
16451 | ||
16452 | ----------------- | |
16453 | -- In_Withs_Of -- | |
16454 | ----------------- | |
16455 | ||
16456 | function In_Withs_Of (UEs : Entity_Id) return Boolean is | |
16457 | UNs : constant Unit_Number_Type := Get_Source_Unit (UEs); | |
16458 | CUs : constant Node_Id := Cunit (UNs); | |
16459 | CIs : constant List_Id := Context_Items (CUs); | |
16460 | ||
16461 | begin | |
16462 | Itm := First (CIs); | |
16463 | while Present (Itm) loop | |
16464 | if Nkind (Itm) = N_With_Clause then | |
16465 | Ent := | |
16466 | Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); | |
16467 | ||
16468 | if U = Ent then | |
16469 | return True; | |
16470 | end if; | |
16471 | end if; | |
16472 | ||
16473 | Next (Itm); | |
16474 | end loop; | |
16475 | ||
16476 | return False; | |
16477 | end In_Withs_Of; | |
16478 | ||
16479 | ------------------- | |
16480 | -- Set_Elab_Flag -- | |
16481 | ------------------- | |
16482 | ||
16483 | procedure Set_Elab_Flag (Itm : Node_Id) is | |
16484 | begin | |
16485 | if Nkind (N) in N_Subprogram_Instantiation then | |
16486 | Set_Elaborate_Desirable (Itm); | |
16487 | else | |
16488 | Set_Elaborate_All_Desirable (Itm); | |
16489 | end if; | |
16490 | end Set_Elab_Flag; | |
16491 | ||
16492 | -- Start of processing for Activate_Elaborate_All_Desirable | |
16493 | ||
16494 | begin | |
16495 | -- Do not set binder indication if expansion is disabled, as when | |
16496 | -- compiling a generic unit. | |
16497 | ||
16498 | if not Expander_Active then | |
16499 | return; | |
16500 | end if; | |
16501 | ||
16502 | -- If an instance of a generic package contains a controlled object (so | |
16503 | -- we're calling Initialize at elaboration time), and the instance is in | |
16504 | -- a package body P that says "with P;", then we need to return without | |
16505 | -- adding "pragma Elaborate_All (P);" to P. | |
16506 | ||
16507 | if U = Main_Unit_Entity then | |
16508 | return; | |
16509 | end if; | |
16510 | ||
16511 | Itm := First (CI); | |
16512 | while Present (Itm) loop | |
16513 | if Nkind (Itm) = N_With_Clause then | |
16514 | Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); | |
16515 | ||
16516 | -- If we find it, then mark elaborate all desirable and return | |
16517 | ||
16518 | if U = Ent then | |
16519 | Set_Elab_Flag (Itm); | |
16520 | return; | |
16521 | end if; | |
16522 | end if; | |
16523 | ||
16524 | Next (Itm); | |
16525 | end loop; | |
16526 | ||
16527 | -- If we fall through then the with clause is not present in the | |
16528 | -- current unit. One legitimate possibility is that the with clause | |
16529 | -- is present in the spec when we are a body. | |
16530 | ||
16531 | if Is_Body_Name (Unm) | |
16532 | and then In_Withs_Of (Spec_Entity (UE)) | |
16533 | then | |
16534 | Add_To_Context_And_Mark (Itm); | |
16535 | return; | |
16536 | end if; | |
16537 | ||
16538 | -- Similarly, we may be in the spec or body of a child unit, where | |
16539 | -- the unit in question is with'ed by some ancestor of the child unit. | |
16540 | ||
16541 | if Is_Child_Name (Unm) then | |
16542 | declare | |
16543 | Pkg : Entity_Id; | |
16544 | ||
16545 | begin | |
16546 | Pkg := UE; | |
16547 | loop | |
16548 | Pkg := Scope (Pkg); | |
16549 | exit when Pkg = Standard_Standard; | |
16550 | ||
16551 | if In_Withs_Of (Pkg) then | |
16552 | Add_To_Context_And_Mark (Itm); | |
16553 | return; | |
16554 | end if; | |
16555 | end loop; | |
16556 | end; | |
16557 | end if; | |
16558 | ||
16559 | -- Here if we do not find with clause on spec or body. We just ignore | |
16560 | -- this case; it means that the elaboration involves some other unit | |
16561 | -- than the unit being compiled, and will be caught elsewhere. | |
16562 | end Activate_Elaborate_All_Desirable; | |
16563 | ||
16564 | ------------------ | |
16565 | -- Check_A_Call -- | |
16566 | ------------------ | |
16567 | ||
16568 | procedure Check_A_Call | |
16569 | (N : Node_Id; | |
16570 | E : Entity_Id; | |
16571 | Outer_Scope : Entity_Id; | |
16572 | Inter_Unit_Only : Boolean; | |
16573 | Generate_Warnings : Boolean := True; | |
16574 | In_Init_Proc : Boolean := False) | |
16575 | is | |
16576 | Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference; | |
16577 | -- Indicates if we have Access attribute case | |
16578 | ||
16579 | function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean; | |
16580 | -- True if we're calling an instance of a generic subprogram, or a | |
16581 | -- subprogram in an instance of a generic package, and the call is | |
16582 | -- outside that instance. | |
16583 | ||
16584 | procedure Elab_Warning | |
16585 | (Msg_D : String; | |
16586 | Msg_S : String; | |
16587 | Ent : Node_Or_Entity_Id); | |
16588 | -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for | |
16589 | -- dynamic or static elaboration model), N and Ent. Msg_D is a real | |
16590 | -- warning (output if Msg_D is non-null and Elab_Warnings is set), | |
16591 | -- Msg_S is an info message (output if Elab_Info_Messages is set). | |
16592 | ||
16593 | function Find_W_Scope return Entity_Id; | |
16594 | -- Find top-level scope for called entity (not following renamings | |
16595 | -- or derivations). This is where the Elaborate_All will go if it is | |
16596 | -- needed. We start with the called entity, except in the case of an | |
16597 | -- initialization procedure outside the current package, where the init | |
16598 | -- proc is in the root package, and we start from the entity of the name | |
16599 | -- in the call. | |
16600 | ||
16601 | ----------------------------------- | |
16602 | -- Call_To_Instance_From_Outside -- | |
16603 | ----------------------------------- | |
16604 | ||
16605 | function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean is | |
16606 | Scop : Entity_Id := Id; | |
16607 | ||
16608 | begin | |
16609 | loop | |
16610 | if Scop = Standard_Standard then | |
16611 | return False; | |
16612 | end if; | |
16613 | ||
16614 | if Is_Generic_Instance (Scop) then | |
16615 | return not In_Open_Scopes (Scop); | |
16616 | end if; | |
16617 | ||
16618 | Scop := Scope (Scop); | |
16619 | end loop; | |
16620 | end Call_To_Instance_From_Outside; | |
16621 | ||
16622 | ------------------ | |
16623 | -- Elab_Warning -- | |
16624 | ------------------ | |
16625 | ||
16626 | procedure Elab_Warning | |
16627 | (Msg_D : String; | |
16628 | Msg_S : String; | |
16629 | Ent : Node_Or_Entity_Id) | |
16630 | is | |
16631 | begin | |
16632 | -- Dynamic elaboration checks, real warning | |
16633 | ||
16634 | if Dynamic_Elaboration_Checks then | |
16635 | if not Access_Case then | |
16636 | if Msg_D /= "" and then Elab_Warnings then | |
16637 | Error_Msg_NE (Msg_D, N, Ent); | |
16638 | end if; | |
16639 | ||
16640 | -- In the access case emit first warning message as well, | |
16641 | -- otherwise list of calls will appear as errors. | |
16642 | ||
16643 | elsif Elab_Warnings then | |
16644 | Error_Msg_NE (Msg_S, N, Ent); | |
16645 | end if; | |
16646 | ||
16647 | -- Static elaboration checks, info message | |
16648 | ||
16649 | else | |
16650 | if Elab_Info_Messages then | |
16651 | Error_Msg_NE (Msg_S, N, Ent); | |
16652 | end if; | |
16653 | end if; | |
16654 | end Elab_Warning; | |
16655 | ||
16656 | ------------------ | |
16657 | -- Find_W_Scope -- | |
16658 | ------------------ | |
16659 | ||
16660 | function Find_W_Scope return Entity_Id is | |
16661 | Refed_Ent : constant Entity_Id := Get_Referenced_Ent (N); | |
16662 | W_Scope : Entity_Id; | |
16663 | ||
16664 | begin | |
16665 | if Is_Init_Proc (Refed_Ent) | |
16666 | and then not In_Same_Extended_Unit (N, Refed_Ent) | |
16667 | then | |
16668 | W_Scope := Scope (Refed_Ent); | |
16669 | else | |
16670 | W_Scope := E; | |
16671 | end if; | |
16672 | ||
16673 | -- Now loop through scopes to get to the enclosing compilation unit | |
16674 | ||
16675 | while not Is_Compilation_Unit (W_Scope) loop | |
16676 | W_Scope := Scope (W_Scope); | |
16677 | end loop; | |
16678 | ||
16679 | return W_Scope; | |
16680 | end Find_W_Scope; | |
16681 | ||
16682 | -- Local variables | |
16683 | ||
16684 | Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; | |
16685 | -- Indicates if we have instantiation case | |
16686 | ||
16687 | Loc : constant Source_Ptr := Sloc (N); | |
16688 | ||
16689 | Variable_Case : constant Boolean := | |
16690 | Nkind (N) in N_Has_Entity | |
16691 | and then Present (Entity (N)) | |
16692 | and then Ekind (Entity (N)) = E_Variable; | |
16693 | -- Indicates if we have variable reference case | |
16694 | ||
16695 | W_Scope : constant Entity_Id := Find_W_Scope; | |
16696 | -- Top-level scope of directly called entity for subprogram. This | |
16697 | -- differs from E_Scope in the case where renamings or derivations | |
16698 | -- are involved, since it does not follow these links. W_Scope is | |
16699 | -- generally in a visible unit, and it is this scope that may require | |
16700 | -- an Elaborate_All. However, there are some cases (initialization | |
16701 | -- calls and calls involving object notation) where W_Scope might not | |
16702 | -- be in the context of the current unit, and there is an intermediate | |
16703 | -- package that is, in which case the Elaborate_All has to be placed | |
16704 | -- on this intermediate package. These special cases are handled in | |
16705 | -- Set_Elaboration_Constraint. | |
16706 | ||
16707 | Ent : Entity_Id; | |
16708 | Callee_Unit_Internal : Boolean; | |
16709 | Caller_Unit_Internal : Boolean; | |
16710 | Decl : Node_Id; | |
16711 | Inst_Callee : Source_Ptr; | |
16712 | Inst_Caller : Source_Ptr; | |
16713 | Unit_Callee : Unit_Number_Type; | |
16714 | Unit_Caller : Unit_Number_Type; | |
16715 | ||
16716 | Body_Acts_As_Spec : Boolean; | |
16717 | -- Set to true if call is to body acting as spec (no separate spec) | |
16718 | ||
16719 | Cunit_SC : Boolean := False; | |
16720 | -- Set to suppress dynamic elaboration checks where one of the | |
16721 | -- enclosing scopes has Elaboration_Checks_Suppressed set, or else | |
16722 | -- if a pragma Elaborate[_All] applies to that scope, in which case | |
16723 | -- warnings on the scope are also suppressed. For the internal case, | |
16724 | -- we ignore this flag. | |
16725 | ||
16726 | E_Scope : Entity_Id; | |
16727 | -- Top-level scope of entity for called subprogram. This value includes | |
16728 | -- following renamings and derivations, so this scope can be in a | |
16729 | -- non-visible unit. This is the scope that is to be investigated to | |
16730 | -- see whether an elaboration check is required. | |
16731 | ||
16732 | Is_DIC : Boolean; | |
16733 | -- Flag set when the subprogram being invoked is the procedure generated | |
16734 | -- for pragma Default_Initial_Condition. | |
16735 | ||
16736 | SPARK_Elab_Errors : Boolean; | |
16737 | -- Flag set when an entity is called or a variable is read during SPARK | |
16738 | -- dynamic elaboration. | |
16739 | ||
16740 | -- Start of processing for Check_A_Call | |
16741 | ||
16742 | begin | |
16743 | -- If the call is known to be within a local Suppress Elaboration | |
16744 | -- pragma, nothing to check. This can happen in task bodies. But | |
16745 | -- we ignore this for a call to a generic formal. | |
16746 | ||
16747 | if Nkind (N) in N_Subprogram_Call | |
16748 | and then No_Elaboration_Check (N) | |
16749 | and then not Is_Call_Of_Generic_Formal (N) | |
16750 | then | |
16751 | return; | |
16752 | ||
16753 | -- If this is a rewrite of a Valid_Scalars attribute, then nothing to | |
16754 | -- check, we don't mind in this case if the call occurs before the body | |
16755 | -- since this is all generated code. | |
16756 | ||
16757 | elsif Nkind (Original_Node (N)) = N_Attribute_Reference | |
16758 | and then Attribute_Name (Original_Node (N)) = Name_Valid_Scalars | |
16759 | then | |
16760 | return; | |
16761 | ||
16762 | -- Intrinsics such as instances of Unchecked_Deallocation do not have | |
16763 | -- any body, so elaboration checking is not needed, and would be wrong. | |
16764 | ||
16765 | elsif Is_Intrinsic_Subprogram (E) then | |
16766 | return; | |
16767 | ||
16768 | -- Do not consider references to internal variables for SPARK semantics | |
16769 | ||
16770 | elsif Variable_Case and then not Comes_From_Source (E) then | |
16771 | return; | |
16772 | end if; | |
16773 | ||
16774 | -- Proceed with check | |
16775 | ||
16776 | Ent := E; | |
16777 | ||
16778 | -- For a variable reference, just set Body_Acts_As_Spec to False | |
16779 | ||
16780 | if Variable_Case then | |
16781 | Body_Acts_As_Spec := False; | |
16782 | ||
16783 | -- Additional checks for all other cases | |
16784 | ||
16785 | else | |
16786 | -- Go to parent for derived subprogram, or to original subprogram in | |
16787 | -- the case of a renaming (Alias covers both these cases). | |
16788 | ||
16789 | loop | |
16790 | if (Suppress_Elaboration_Warnings (Ent) | |
16791 | or else Elaboration_Checks_Suppressed (Ent)) | |
16792 | and then (Inst_Case or else No (Alias (Ent))) | |
16793 | then | |
16794 | return; | |
16795 | end if; | |
16796 | ||
16797 | -- Nothing to do for imported entities | |
16798 | ||
16799 | if Is_Imported (Ent) then | |
16800 | return; | |
16801 | end if; | |
16802 | ||
16803 | exit when Inst_Case or else No (Alias (Ent)); | |
16804 | Ent := Alias (Ent); | |
16805 | end loop; | |
16806 | ||
16807 | Decl := Unit_Declaration_Node (Ent); | |
16808 | ||
16809 | if Nkind (Decl) = N_Subprogram_Body then | |
16810 | Body_Acts_As_Spec := True; | |
16811 | ||
16812 | elsif Nkind_In (Decl, N_Subprogram_Declaration, | |
16813 | N_Subprogram_Body_Stub) | |
16814 | or else Inst_Case | |
16815 | then | |
16816 | Body_Acts_As_Spec := False; | |
16817 | ||
16818 | -- If we have none of an instantiation, subprogram body or subprogram | |
16819 | -- declaration, or in the SPARK case, a variable reference, then | |
16820 | -- it is not a case that we want to check. (One case is a call to a | |
16821 | -- generic formal subprogram, where we do not want the check in the | |
16822 | -- template). | |
16823 | ||
16824 | else | |
16825 | return; | |
16826 | end if; | |
16827 | end if; | |
16828 | ||
16829 | E_Scope := Ent; | |
16830 | loop | |
16831 | if Elaboration_Checks_Suppressed (E_Scope) | |
16832 | or else Suppress_Elaboration_Warnings (E_Scope) | |
16833 | then | |
16834 | Cunit_SC := True; | |
16835 | end if; | |
16836 | ||
16837 | -- Exit when we get to compilation unit, not counting subunits | |
16838 | ||
16839 | exit when Is_Compilation_Unit (E_Scope) | |
16840 | and then (Is_Child_Unit (E_Scope) | |
16841 | or else Scope (E_Scope) = Standard_Standard); | |
16842 | ||
16843 | pragma Assert (E_Scope /= Standard_Standard); | |
16844 | ||
16845 | -- Move up a scope looking for compilation unit | |
16846 | ||
16847 | E_Scope := Scope (E_Scope); | |
16848 | end loop; | |
16849 | ||
16850 | -- No checks needed for pure or preelaborated compilation units | |
16851 | ||
16852 | if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then | |
16853 | return; | |
16854 | end if; | |
16855 | ||
16856 | -- If the generic entity is within a deeper instance than we are, then | |
16857 | -- either the instantiation to which we refer itself caused an ABE, in | |
16858 | -- which case that will be handled separately, or else we know that the | |
16859 | -- body we need appears as needed at the point of the instantiation. | |
16860 | -- However, this assumption is only valid if we are in static mode. | |
16861 | ||
16862 | if not Dynamic_Elaboration_Checks | |
16863 | and then | |
16864 | Instantiation_Depth (Sloc (Ent)) > Instantiation_Depth (Sloc (N)) | |
16865 | then | |
16866 | return; | |
16867 | end if; | |
16868 | ||
16869 | -- Do not give a warning for a package with no body | |
16870 | ||
16871 | if Ekind (Ent) = E_Generic_Package and then not Has_Generic_Body (N) then | |
16872 | return; | |
16873 | end if; | |
16874 | ||
16875 | -- Case of entity is in same unit as call or instantiation. In the | |
16876 | -- instantiation case, W_Scope may be different from E_Scope; we want | |
16877 | -- the unit in which the instantiation occurs, since we're analyzing | |
16878 | -- based on the expansion. | |
16879 | ||
16880 | if W_Scope = C_Scope then | |
16881 | if not Inter_Unit_Only then | |
16882 | Check_Internal_Call (N, Ent, Outer_Scope, E); | |
16883 | end if; | |
16884 | ||
16885 | return; | |
16886 | end if; | |
16887 | ||
16888 | -- Case of entity is not in current unit (i.e. with'ed unit case) | |
16889 | ||
16890 | -- We are only interested in such calls if the outer call was from | |
16891 | -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode. | |
16892 | ||
16893 | if not From_Elab_Code and then not Dynamic_Elaboration_Checks then | |
16894 | return; | |
16895 | end if; | |
16896 | ||
16897 | -- Nothing to do if some scope said that no checks were required | |
16898 | ||
16899 | if Cunit_SC then | |
16900 | return; | |
16901 | end if; | |
16902 | ||
16903 | -- Nothing to do for a generic instance, because a call to an instance | |
16904 | -- cannot fail the elaboration check, because the body of the instance | |
16905 | -- is always elaborated immediately after the spec. | |
16906 | ||
16907 | if Call_To_Instance_From_Outside (Ent) then | |
16908 | return; | |
16909 | end if; | |
16910 | ||
16911 | -- Nothing to do if subprogram with no separate spec. However, a call | |
16912 | -- to Deep_Initialize may result in a call to a user-defined Initialize | |
16913 | -- procedure, which imposes a body dependency. This happens only if the | |
16914 | -- type is controlled and the Initialize procedure is not inherited. | |
16915 | ||
16916 | if Body_Acts_As_Spec then | |
16917 | if Is_TSS (Ent, TSS_Deep_Initialize) then | |
16918 | declare | |
16919 | Typ : constant Entity_Id := Etype (First_Formal (Ent)); | |
16920 | Init : Entity_Id; | |
16921 | ||
16922 | begin | |
16923 | if not Is_Controlled (Typ) then | |
16924 | return; | |
16925 | else | |
16926 | Init := Find_Prim_Op (Typ, Name_Initialize); | |
16927 | ||
16928 | if Comes_From_Source (Init) then | |
16929 | Ent := Init; | |
16930 | else | |
16931 | return; | |
16932 | end if; | |
16933 | end if; | |
16934 | end; | |
16935 | ||
16936 | else | |
16937 | return; | |
16938 | end if; | |
16939 | end if; | |
16940 | ||
16941 | -- Check cases of internal units | |
16942 | ||
16943 | Callee_Unit_Internal := In_Internal_Unit (E_Scope); | |
16944 | ||
16945 | -- Do not give a warning if the with'ed unit is internal and this is | |
16946 | -- the generic instantiation case (this saves a lot of hassle dealing | |
16947 | -- with the Text_IO special child units) | |
16948 | ||
16949 | if Callee_Unit_Internal and Inst_Case then | |
16950 | return; | |
16951 | end if; | |
16952 | ||
16953 | if C_Scope = Standard_Standard then | |
16954 | Caller_Unit_Internal := False; | |
16955 | else | |
16956 | Caller_Unit_Internal := In_Internal_Unit (C_Scope); | |
16957 | end if; | |
16958 | ||
16959 | -- Do not give a warning if the with'ed unit is internal and the caller | |
16960 | -- is not internal (since the binder always elaborates internal units | |
16961 | -- first). | |
16962 | ||
16963 | if Callee_Unit_Internal and not Caller_Unit_Internal then | |
16964 | return; | |
16965 | end if; | |
16966 | ||
16967 | -- For now, if debug flag -gnatdE is not set, do no checking for one | |
16968 | -- internal unit withing another. This fixes the problem with the sgi | |
16969 | -- build and storage errors. To be resolved later ??? | |
16970 | ||
16971 | if (Callee_Unit_Internal and Caller_Unit_Internal) | |
16972 | and not Debug_Flag_EE | |
16973 | then | |
16974 | return; | |
16975 | end if; | |
16976 | ||
16977 | if Is_TSS (E, TSS_Deep_Initialize) then | |
16978 | Ent := E; | |
16979 | end if; | |
16980 | ||
16981 | -- If the call is in an instance, and the called entity is not | |
16982 | -- defined in the same instance, then the elaboration issue focuses | |
16983 | -- around the unit containing the template, it is this unit that | |
16984 | -- requires an Elaborate_All. | |
16985 | ||
16986 | -- However, if we are doing dynamic elaboration, we need to chase the | |
16987 | -- call in the usual manner. | |
16988 | ||
16989 | -- We also need to chase the call in the usual manner if it is a call | |
16990 | -- to a generic formal parameter, since that case was not handled as | |
16991 | -- part of the processing of the template. | |
16992 | ||
16993 | Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N))); | |
16994 | Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent))); | |
16995 | ||
16996 | if Inst_Caller = No_Location then | |
16997 | Unit_Caller := No_Unit; | |
16998 | else | |
16999 | Unit_Caller := Get_Source_Unit (N); | |
17000 | end if; | |
17001 | ||
17002 | if Inst_Callee = No_Location then | |
17003 | Unit_Callee := No_Unit; | |
17004 | else | |
17005 | Unit_Callee := Get_Source_Unit (Ent); | |
17006 | end if; | |
17007 | ||
17008 | if Unit_Caller /= No_Unit | |
17009 | and then Unit_Callee /= Unit_Caller | |
17010 | and then not Dynamic_Elaboration_Checks | |
17011 | and then not Is_Call_Of_Generic_Formal (N) | |
17012 | then | |
17013 | E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); | |
17014 | ||
17015 | -- If we don't get a spec entity, just ignore call. Not quite | |
17016 | -- clear why this check is necessary. ??? | |
17017 | ||
17018 | if No (E_Scope) then | |
17019 | return; | |
17020 | end if; | |
17021 | ||
17022 | -- Otherwise step to enclosing compilation unit | |
17023 | ||
17024 | while not Is_Compilation_Unit (E_Scope) loop | |
17025 | E_Scope := Scope (E_Scope); | |
17026 | end loop; | |
17027 | ||
17028 | -- For the case where N is not an instance, and is not a call within | |
17029 | -- instance to other than a generic formal, we recompute E_Scope | |
17030 | -- for the error message, since we do NOT want to go to the unit | |
17031 | -- that has the ultimate declaration in the case of renaming and | |
17032 | -- derivation and we also want to go to the generic unit in the | |
17033 | -- case of an instance, and no further. | |
17034 | ||
17035 | else | |
17036 | -- Loop to carefully follow renamings and derivations one step | |
17037 | -- outside the current unit, but not further. | |
17038 | ||
17039 | if not (Inst_Case or Variable_Case) | |
17040 | and then Present (Alias (Ent)) | |
17041 | then | |
17042 | E_Scope := Alias (Ent); | |
17043 | else | |
17044 | E_Scope := Ent; | |
17045 | end if; | |
17046 | ||
17047 | loop | |
17048 | while not Is_Compilation_Unit (E_Scope) loop | |
17049 | E_Scope := Scope (E_Scope); | |
17050 | end loop; | |
17051 | ||
17052 | -- If E_Scope is the same as C_Scope, it means that there | |
17053 | -- definitely was a local renaming or derivation, and we | |
17054 | -- are not yet out of the current unit. | |
17055 | ||
17056 | exit when E_Scope /= C_Scope; | |
17057 | Ent := Alias (Ent); | |
17058 | E_Scope := Ent; | |
17059 | ||
17060 | -- If no alias, there could be a previous error, but not if we've | |
17061 | -- already reached the outermost level (Standard). | |
17062 | ||
17063 | if No (Ent) then | |
17064 | return; | |
17065 | end if; | |
17066 | end loop; | |
17067 | end if; | |
17068 | ||
17069 | if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then | |
17070 | return; | |
17071 | end if; | |
17072 | ||
17073 | -- Determine whether the Default_Initial_Condition procedure of some | |
17074 | -- type is being invoked. | |
17075 | ||
17076 | Is_DIC := Ekind (Ent) = E_Procedure and then Is_DIC_Procedure (Ent); | |
17077 | ||
17078 | -- Checks related to Default_Initial_Condition fall under the SPARK | |
17079 | -- umbrella because this is a SPARK-specific annotation. | |
17080 | ||
17081 | SPARK_Elab_Errors := | |
17082 | SPARK_Mode = On and (Is_DIC or Dynamic_Elaboration_Checks); | |
17083 | ||
17084 | -- Now check if an Elaborate_All (or dynamic check) is needed | |
17085 | ||
17086 | if (Elab_Info_Messages or Elab_Warnings or SPARK_Elab_Errors) | |
17087 | and then Generate_Warnings | |
17088 | and then not Suppress_Elaboration_Warnings (Ent) | |
17089 | and then not Elaboration_Checks_Suppressed (Ent) | |
17090 | and then not Suppress_Elaboration_Warnings (E_Scope) | |
17091 | and then not Elaboration_Checks_Suppressed (E_Scope) | |
17092 | then | |
17093 | -- Instantiation case | |
17094 | ||
17095 | if Inst_Case then | |
17096 | if Comes_From_Source (Ent) and then SPARK_Elab_Errors then | |
17097 | Error_Msg_NE | |
17098 | ("instantiation of & during elaboration in SPARK", N, Ent); | |
17099 | else | |
17100 | Elab_Warning | |
17101 | ("instantiation of & may raise Program_Error?l?", | |
17102 | "info: instantiation of & during elaboration?$?", Ent); | |
17103 | end if; | |
17104 | ||
17105 | -- Indirect call case, info message only in static elaboration | |
17106 | -- case, because the attribute reference itself cannot raise an | |
17107 | -- exception. Note that SPARK does not permit indirect calls. | |
17108 | ||
17109 | elsif Access_Case then | |
17110 | Elab_Warning ("", "info: access to & during elaboration?$?", Ent); | |
17111 | ||
17112 | -- Variable reference in SPARK mode | |
17113 | ||
17114 | elsif Variable_Case then | |
17115 | if Comes_From_Source (Ent) and then SPARK_Elab_Errors then | |
17116 | Error_Msg_NE | |
17117 | ("reference to & during elaboration in SPARK", N, Ent); | |
17118 | end if; | |
17119 | ||
17120 | -- Subprogram call case | |
17121 | ||
17122 | else | |
17123 | if Nkind (Name (N)) in N_Has_Entity | |
17124 | and then Is_Init_Proc (Entity (Name (N))) | |
17125 | and then Comes_From_Source (Ent) | |
17126 | then | |
17127 | Elab_Warning | |
17128 | ("implicit call to & may raise Program_Error?l?", | |
17129 | "info: implicit call to & during elaboration?$?", | |
17130 | Ent); | |
17131 | ||
17132 | elsif SPARK_Elab_Errors then | |
17133 | ||
17134 | -- Emit a specialized error message when the elaboration of an | |
17135 | -- object of a private type evaluates the expression of pragma | |
17136 | -- Default_Initial_Condition. This prevents the internal name | |
17137 | -- of the procedure from appearing in the error message. | |
17138 | ||
17139 | if Is_DIC then | |
17140 | Error_Msg_N | |
17141 | ("call to Default_Initial_Condition during elaboration in " | |
17142 | & "SPARK", N); | |
17143 | else | |
17144 | Error_Msg_NE | |
17145 | ("call to & during elaboration in SPARK", N, Ent); | |
17146 | end if; | |
17147 | ||
17148 | else | |
17149 | Elab_Warning | |
17150 | ("call to & may raise Program_Error?l?", | |
17151 | "info: call to & during elaboration?$?", | |
17152 | Ent); | |
17153 | end if; | |
17154 | end if; | |
17155 | ||
17156 | Error_Msg_Qual_Level := Nat'Last; | |
17157 | ||
17158 | -- Case of Elaborate_All not present and required, for SPARK this | |
17159 | -- is an error, so give an error message. | |
17160 | ||
17161 | if SPARK_Elab_Errors then | |
17162 | Error_Msg_NE -- CODEFIX | |
17163 | ("\Elaborate_All pragma required for&", N, W_Scope); | |
17164 | ||
17165 | -- Otherwise we generate an implicit pragma. For a subprogram | |
17166 | -- instantiation, Elaborate is good enough, since no transitive | |
17167 | -- call is possible at elaboration time in this case. | |
17168 | ||
17169 | elsif Nkind (N) in N_Subprogram_Instantiation then | |
17170 | Elab_Warning | |
17171 | ("\missing pragma Elaborate for&?l?", | |
17172 | "\implicit pragma Elaborate for& generated?$?", | |
17173 | W_Scope); | |
17174 | ||
17175 | -- For all other cases, we need an implicit Elaborate_All | |
17176 | ||
17177 | else | |
17178 | Elab_Warning | |
17179 | ("\missing pragma Elaborate_All for&?l?", | |
17180 | "\implicit pragma Elaborate_All for & generated?$?", | |
17181 | W_Scope); | |
17182 | end if; | |
17183 | ||
17184 | Error_Msg_Qual_Level := 0; | |
17185 | ||
17186 | -- Take into account the flags related to elaboration warning | |
17187 | -- messages when enumerating the various calls involved. This | |
17188 | -- ensures the proper pairing of the main warning and the | |
17189 | -- clarification messages generated by Output_Calls. | |
17190 | ||
17191 | Output_Calls (N, Check_Elab_Flag => True); | |
17192 | ||
17193 | -- Set flag to prevent further warnings for same unit unless in | |
17194 | -- All_Errors_Mode. | |
17195 | ||
17196 | if not All_Errors_Mode and not Dynamic_Elaboration_Checks then | |
17197 | Set_Suppress_Elaboration_Warnings (W_Scope); | |
17198 | end if; | |
17199 | end if; | |
17200 | ||
17201 | -- Check for runtime elaboration check required | |
17202 | ||
17203 | if Dynamic_Elaboration_Checks then | |
17204 | if not Elaboration_Checks_Suppressed (Ent) | |
17205 | and then not Elaboration_Checks_Suppressed (W_Scope) | |
17206 | and then not Elaboration_Checks_Suppressed (E_Scope) | |
17207 | and then not Cunit_SC | |
17208 | then | |
17209 | -- Runtime elaboration check required. Generate check of the | |
17210 | -- elaboration Boolean for the unit containing the entity. | |
17211 | ||
17212 | -- Note that for this case, we do check the real unit (the one | |
17213 | -- from following renamings, since that is the issue). | |
17214 | ||
17215 | -- Could this possibly miss a useless but required PE??? | |
17216 | ||
17217 | Insert_Elab_Check (N, | |
17218 | Make_Attribute_Reference (Loc, | |
17219 | Attribute_Name => Name_Elaborated, | |
17220 | Prefix => | |
17221 | New_Occurrence_Of (Spec_Entity (E_Scope), Loc))); | |
17222 | ||
17223 | -- Prevent duplicate elaboration checks on the same call, which | |
17224 | -- can happen if the body enclosing the call appears itself in a | |
17225 | -- call whose elaboration check is delayed. | |
17226 | ||
17227 | if Nkind (N) in N_Subprogram_Call then | |
17228 | Set_No_Elaboration_Check (N); | |
17229 | end if; | |
17230 | end if; | |
17231 | ||
17232 | -- Case of static elaboration model | |
17233 | ||
17234 | else | |
17235 | -- Do not do anything if elaboration checks suppressed. Note that | |
17236 | -- we check Ent here, not E, since we want the real entity for the | |
17237 | -- body to see if checks are suppressed for it, not the dummy | |
17238 | -- entry for renamings or derivations. | |
17239 | ||
17240 | if Elaboration_Checks_Suppressed (Ent) | |
17241 | or else Elaboration_Checks_Suppressed (E_Scope) | |
17242 | or else Elaboration_Checks_Suppressed (W_Scope) | |
17243 | then | |
17244 | null; | |
17245 | ||
17246 | -- Do not generate an Elaborate_All for finalization routines | |
17247 | -- that perform partial clean up as part of initialization. | |
17248 | ||
17249 | elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then | |
17250 | null; | |
17251 | ||
17252 | -- Here we need to generate an implicit elaborate all | |
17253 | ||
17254 | else | |
17255 | -- Generate Elaborate_All warning unless suppressed | |
17256 | ||
17257 | if (Elab_Info_Messages and Generate_Warnings and not Inst_Case) | |
17258 | and then not Suppress_Elaboration_Warnings (Ent) | |
17259 | and then not Suppress_Elaboration_Warnings (E_Scope) | |
17260 | and then not Suppress_Elaboration_Warnings (W_Scope) | |
17261 | then | |
17262 | Error_Msg_Node_2 := W_Scope; | |
17263 | Error_Msg_NE | |
17264 | ("info: call to& in elaboration code requires pragma " | |
17265 | & "Elaborate_All on&?$?", N, E); | |
17266 | end if; | |
17267 | ||
17268 | -- Set indication for binder to generate Elaborate_All | |
17269 | ||
17270 | Set_Elaboration_Constraint (N, E, W_Scope); | |
17271 | end if; | |
17272 | end if; | |
17273 | end Check_A_Call; | |
17274 | ||
17275 | ----------------------------- | |
17276 | -- Check_Bad_Instantiation -- | |
17277 | ----------------------------- | |
17278 | ||
17279 | procedure Check_Bad_Instantiation (N : Node_Id) is | |
17280 | Ent : Entity_Id; | |
17281 | ||
17282 | begin | |
17283 | -- Nothing to do if we do not have an instantiation (happens in some | |
17284 | -- error cases, and also in the formal package declaration case) | |
17285 | ||
17286 | if Nkind (N) not in N_Generic_Instantiation then | |
17287 | return; | |
17288 | ||
17289 | -- Nothing to do if serious errors detected (avoid cascaded errors) | |
17290 | ||
17291 | elsif Serious_Errors_Detected /= 0 then | |
17292 | return; | |
17293 | ||
17294 | -- Nothing to do if not in full analysis mode | |
17295 | ||
17296 | elsif not Full_Analysis then | |
17297 | return; | |
17298 | ||
17299 | -- Nothing to do if inside a generic template | |
17300 | ||
17301 | elsif Inside_A_Generic then | |
17302 | return; | |
17303 | ||
17304 | -- Nothing to do if a library level instantiation | |
17305 | ||
17306 | elsif Nkind (Parent (N)) = N_Compilation_Unit then | |
17307 | return; | |
17308 | ||
17309 | -- Nothing to do if we are compiling a proper body for semantic | |
17310 | -- purposes only. The generic body may be in another proper body. | |
17311 | ||
17312 | elsif | |
17313 | Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit | |
17314 | then | |
17315 | return; | |
17316 | end if; | |
17317 | ||
17318 | Ent := Get_Generic_Entity (N); | |
17319 | ||
17320 | -- The case we are interested in is when the generic spec is in the | |
17321 | -- current declarative part | |
17322 | ||
17323 | if not Same_Elaboration_Scope (Current_Scope, Scope (Ent)) | |
17324 | or else not In_Same_Extended_Unit (N, Ent) | |
17325 | then | |
17326 | return; | |
17327 | end if; | |
17328 | ||
17329 | -- If the generic entity is within a deeper instance than we are, then | |
17330 | -- either the instantiation to which we refer itself caused an ABE, in | |
17331 | -- which case that will be handled separately. Otherwise, we know that | |
17332 | -- the body we need appears as needed at the point of the instantiation. | |
17333 | -- If they are both at the same level but not within the same instance | |
17334 | -- then the body of the generic will be in the earlier instance. | |
17335 | ||
17336 | declare | |
17337 | D1 : constant Nat := Instantiation_Depth (Sloc (Ent)); | |
17338 | D2 : constant Nat := Instantiation_Depth (Sloc (N)); | |
17339 | ||
17340 | begin | |
17341 | if D1 > D2 then | |
17342 | return; | |
17343 | ||
17344 | elsif D1 = D2 | |
17345 | and then Is_Generic_Instance (Scope (Ent)) | |
17346 | and then not In_Open_Scopes (Scope (Ent)) | |
17347 | then | |
17348 | return; | |
17349 | end if; | |
17350 | end; | |
17351 | ||
17352 | -- Now we can proceed, if the entity being called has a completion, | |
17353 | -- then we are definitely OK, since we have already seen the body. | |
17354 | ||
17355 | if Has_Completion (Ent) then | |
17356 | return; | |
17357 | end if; | |
17358 | ||
17359 | -- If there is no body, then nothing to do | |
17360 | ||
17361 | if not Has_Generic_Body (N) then | |
17362 | return; | |
17363 | end if; | |
17364 | ||
17365 | -- Here we definitely have a bad instantiation | |
17366 | ||
17367 | Error_Msg_Warn := SPARK_Mode /= On; | |
17368 | Error_Msg_NE ("cannot instantiate& before body seen<<", N, Ent); | |
17369 | Error_Msg_N ("\Program_Error [<<", N); | |
17370 | ||
17371 | Insert_Elab_Check (N); | |
17372 | Set_Is_Known_Guaranteed_ABE (N); | |
17373 | end Check_Bad_Instantiation; | |
17374 | ||
17375 | --------------------- | |
17376 | -- Check_Elab_Call -- | |
17377 | --------------------- | |
17378 | ||
17379 | procedure Check_Elab_Call | |
17380 | (N : Node_Id; | |
17381 | Outer_Scope : Entity_Id := Empty; | |
17382 | In_Init_Proc : Boolean := False) | |
17383 | is | |
17384 | Ent : Entity_Id; | |
17385 | P : Node_Id; | |
17386 | ||
17387 | begin | |
17388 | pragma Assert (Legacy_Elaboration_Checks); | |
17389 | ||
17390 | -- If the reference is not in the main unit, there is nothing to check. | |
17391 | -- Elaboration call from units in the context of the main unit will lead | |
17392 | -- to semantic dependencies when those units are compiled. | |
17393 | ||
17394 | if not In_Extended_Main_Code_Unit (N) then | |
17395 | return; | |
17396 | end if; | |
17397 | ||
17398 | -- For an entry call, check relevant restriction | |
17399 | ||
17400 | if Nkind (N) = N_Entry_Call_Statement | |
17401 | and then not In_Subprogram_Or_Concurrent_Unit | |
17402 | then | |
17403 | Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N); | |
17404 | ||
17405 | -- Nothing to do if this is not an expected type of reference (happens | |
17406 | -- in some error conditions, and in some cases where rewriting occurs). | |
17407 | ||
17408 | elsif Nkind (N) not in N_Subprogram_Call | |
17409 | and then Nkind (N) /= N_Attribute_Reference | |
17410 | and then (SPARK_Mode /= On | |
17411 | or else Nkind (N) not in N_Has_Entity | |
17412 | or else No (Entity (N)) | |
17413 | or else Ekind (Entity (N)) /= E_Variable) | |
17414 | then | |
17415 | return; | |
17416 | ||
17417 | -- Nothing to do if this is a call already rewritten for elab checking. | |
17418 | -- Such calls appear as the targets of If_Expressions. | |
17419 | ||
17420 | -- This check MUST be wrong, it catches far too much | |
17421 | ||
17422 | elsif Nkind (Parent (N)) = N_If_Expression then | |
17423 | return; | |
17424 | ||
17425 | -- Nothing to do if inside a generic template | |
17426 | ||
17427 | elsif Inside_A_Generic | |
17428 | and then No (Enclosing_Generic_Body (N)) | |
17429 | then | |
17430 | return; | |
17431 | ||
812e6118 | 17432 | -- Nothing to do if call is being preanalyzed, as when within a |
967947ed PMR |
17433 | -- pre/postcondition, a predicate, or an invariant. |
17434 | ||
17435 | elsif In_Spec_Expression then | |
17436 | return; | |
17437 | end if; | |
17438 | ||
17439 | -- Nothing to do if this is a call to a postcondition, which is always | |
17440 | -- within a subprogram body, even though the current scope may be the | |
17441 | -- enclosing scope of the subprogram. | |
17442 | ||
17443 | if Nkind (N) = N_Procedure_Call_Statement | |
17444 | and then Is_Entity_Name (Name (N)) | |
17445 | and then Chars (Entity (Name (N))) = Name_uPostconditions | |
17446 | then | |
17447 | return; | |
17448 | end if; | |
17449 | ||
17450 | -- Here we have a reference at elaboration time that must be checked | |
17451 | ||
17452 | if Debug_Flag_Underscore_LL then | |
17453 | Write_Str (" Check_Elab_Ref: "); | |
17454 | ||
17455 | if Nkind (N) = N_Attribute_Reference then | |
17456 | if not Is_Entity_Name (Prefix (N)) then | |
17457 | Write_Str ("<<not entity name>>"); | |
17458 | else | |
17459 | Write_Name (Chars (Entity (Prefix (N)))); | |
17460 | end if; | |
17461 | ||
17462 | Write_Str ("'Access"); | |
17463 | ||
17464 | elsif No (Name (N)) or else not Is_Entity_Name (Name (N)) then | |
17465 | Write_Str ("<<not entity name>> "); | |
17466 | ||
17467 | else | |
17468 | Write_Name (Chars (Entity (Name (N)))); | |
17469 | end if; | |
17470 | ||
17471 | Write_Str (" reference at "); | |
17472 | Write_Location (Sloc (N)); | |
17473 | Write_Eol; | |
17474 | end if; | |
17475 | ||
17476 | -- Climb up the tree to make sure we are not inside default expression | |
17477 | -- of a parameter specification or a record component, since in both | |
17478 | -- these cases, we will be doing the actual reference later, not now, | |
17479 | -- and it is at the time of the actual reference (statically speaking) | |
17480 | -- that we must do our static check, not at the time of its initial | |
17481 | -- analysis). | |
17482 | ||
17483 | -- However, we have to check references within component definitions | |
17484 | -- (e.g. a function call that determines an array component bound), | |
17485 | -- so we terminate the loop in that case. | |
17486 | ||
17487 | P := Parent (N); | |
17488 | while Present (P) loop | |
17489 | if Nkind_In (P, N_Parameter_Specification, | |
17490 | N_Component_Declaration) | |
17491 | then | |
17492 | return; | |
17493 | ||
17494 | -- The reference occurs within the constraint of a component, | |
17495 | -- so it must be checked. | |
17496 | ||
17497 | elsif Nkind (P) = N_Component_Definition then | |
17498 | exit; | |
17499 | ||
17500 | else | |
17501 | P := Parent (P); | |
17502 | end if; | |
17503 | end loop; | |
17504 | ||
17505 | -- Stuff that happens only at the outer level | |
17506 | ||
17507 | if No (Outer_Scope) then | |
17508 | Elab_Visited.Set_Last (0); | |
17509 | ||
17510 | -- Nothing to do if current scope is Standard (this is a bit odd, but | |
17511 | -- it happens in the case of generic instantiations). | |
17512 | ||
17513 | C_Scope := Current_Scope; | |
17514 | ||
17515 | if C_Scope = Standard_Standard then | |
17516 | return; | |
17517 | end if; | |
17518 | ||
17519 | -- First case, we are in elaboration code | |
17520 | ||
17521 | From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; | |
17522 | ||
17523 | if From_Elab_Code then | |
17524 | ||
17525 | -- Complain if ref that comes from source in preelaborated unit | |
17526 | -- and we are not inside a subprogram (i.e. we are in elab code). | |
17527 | ||
17528 | if Comes_From_Source (N) | |
17529 | and then In_Preelaborated_Unit | |
17530 | and then not In_Inlined_Body | |
17531 | and then Nkind (N) /= N_Attribute_Reference | |
17532 | then | |
17533 | -- This is a warning in GNAT mode allowing such calls to be | |
17534 | -- used in the predefined library with appropriate care. | |
17535 | ||
17536 | Error_Msg_Warn := GNAT_Mode; | |
17537 | Error_Msg_N | |
17538 | ("<<non-static call not allowed in preelaborated unit", N); | |
17539 | return; | |
17540 | end if; | |
17541 | ||
17542 | -- Second case, we are inside a subprogram or concurrent unit, which | |
17543 | -- means we are not in elaboration code. | |
17544 | ||
17545 | else | |
17546 | -- In this case, the issue is whether we are inside the | |
17547 | -- declarative part of the unit in which we live, or inside its | |
17548 | -- statements. In the latter case, there is no issue of ABE calls | |
17549 | -- at this level (a call from outside to the unit in which we live | |
17550 | -- might cause an ABE, but that will be detected when we analyze | |
17551 | -- that outer level call, as it recurses into the called unit). | |
17552 | ||
17553 | -- Climb up the tree, doing this test, and also testing for being | |
17554 | -- inside a default expression, which, as discussed above, is not | |
17555 | -- checked at this stage. | |
17556 | ||
17557 | declare | |
17558 | P : Node_Id; | |
17559 | L : List_Id; | |
17560 | ||
17561 | begin | |
17562 | P := N; | |
17563 | loop | |
17564 | -- If we find a parentless subtree, it seems safe to assume | |
17565 | -- that we are not in a declarative part and that no | |
17566 | -- checking is required. | |
17567 | ||
17568 | if No (P) then | |
17569 | return; | |
17570 | end if; | |
17571 | ||
17572 | if Is_List_Member (P) then | |
17573 | L := List_Containing (P); | |
17574 | P := Parent (L); | |
17575 | else | |
17576 | L := No_List; | |
17577 | P := Parent (P); | |
17578 | end if; | |
17579 | ||
17580 | exit when Nkind (P) = N_Subunit; | |
17581 | ||
17582 | -- Filter out case of default expressions, where we do not | |
17583 | -- do the check at this stage. | |
17584 | ||
17585 | if Nkind_In (P, N_Parameter_Specification, | |
17586 | N_Component_Declaration) | |
17587 | then | |
17588 | return; | |
17589 | end if; | |
17590 | ||
17591 | -- A protected body has no elaboration code and contains | |
17592 | -- only other bodies. | |
17593 | ||
17594 | if Nkind (P) = N_Protected_Body then | |
17595 | return; | |
17596 | ||
17597 | elsif Nkind_In (P, N_Subprogram_Body, | |
17598 | N_Task_Body, | |
17599 | N_Block_Statement, | |
17600 | N_Entry_Body) | |
17601 | then | |
17602 | if L = Declarations (P) then | |
17603 | exit; | |
17604 | ||
17605 | -- We are not in elaboration code, but we are doing | |
17606 | -- dynamic elaboration checks, in this case, we still | |
17607 | -- need to do the reference, since the subprogram we are | |
17608 | -- in could be called from another unit, also in dynamic | |
17609 | -- elaboration check mode, at elaboration time. | |
17610 | ||
17611 | elsif Dynamic_Elaboration_Checks then | |
17612 | ||
17613 | -- We provide a debug flag to disable this check. That | |
17614 | -- way we have an easy work around for regressions | |
17615 | -- that are caused by this new check. This debug flag | |
17616 | -- can be removed later. | |
17617 | ||
17618 | if Debug_Flag_DD then | |
17619 | return; | |
17620 | end if; | |
17621 | ||
17622 | -- Do the check in this case | |
17623 | ||
17624 | exit; | |
17625 | ||
17626 | elsif Nkind (P) = N_Task_Body then | |
17627 | ||
17628 | -- The check is deferred until Check_Task_Activation | |
17629 | -- but we need to capture local suppress pragmas | |
17630 | -- that may inhibit checks on this call. | |
17631 | ||
17632 | Ent := Get_Referenced_Ent (N); | |
17633 | ||
17634 | if No (Ent) then | |
17635 | return; | |
17636 | ||
17637 | elsif Elaboration_Checks_Suppressed (Current_Scope) | |
17638 | or else Elaboration_Checks_Suppressed (Ent) | |
17639 | or else Elaboration_Checks_Suppressed (Scope (Ent)) | |
17640 | then | |
17641 | if Nkind (N) in N_Subprogram_Call then | |
17642 | Set_No_Elaboration_Check (N); | |
17643 | end if; | |
17644 | end if; | |
17645 | ||
17646 | return; | |
17647 | ||
17648 | -- Static model, call is not in elaboration code, we | |
17649 | -- never need to worry, because in the static model the | |
17650 | -- top-level caller always takes care of things. | |
17651 | ||
17652 | else | |
17653 | return; | |
17654 | end if; | |
17655 | end if; | |
17656 | end loop; | |
17657 | end; | |
17658 | end if; | |
17659 | end if; | |
17660 | ||
17661 | Ent := Get_Referenced_Ent (N); | |
17662 | ||
17663 | if No (Ent) then | |
17664 | return; | |
17665 | end if; | |
17666 | ||
17667 | -- Determine whether a prior call to the same subprogram was already | |
17668 | -- examined within the same context. If this is the case, then there is | |
17669 | -- no need to proceed with the various warnings and checks because the | |
17670 | -- work was already done for the previous call. | |
17671 | ||
17672 | declare | |
17673 | Self : constant Visited_Element := | |
17674 | (Subp_Id => Ent, Context => Parent (N)); | |
17675 | ||
17676 | begin | |
17677 | for Index in 1 .. Elab_Visited.Last loop | |
17678 | if Self = Elab_Visited.Table (Index) then | |
17679 | return; | |
17680 | end if; | |
17681 | end loop; | |
17682 | end; | |
17683 | ||
17684 | -- See if we need to analyze this reference. We analyze it if either of | |
17685 | -- the following conditions is met: | |
17686 | ||
17687 | -- It is an inner level call (since in this case it was triggered | |
17688 | -- by an outer level call from elaboration code), but only if the | |
17689 | -- call is within the scope of the original outer level call. | |
17690 | ||
17691 | -- It is an outer level reference from elaboration code, or a call to | |
17692 | -- an entity is in the same elaboration scope. | |
17693 | ||
17694 | -- And in these cases, we will check both inter-unit calls and | |
17695 | -- intra-unit (within a single unit) calls. | |
17696 | ||
17697 | C_Scope := Current_Scope; | |
17698 | ||
17699 | -- If not outer level reference, then we follow it if it is within the | |
17700 | -- original scope of the outer reference. | |
17701 | ||
17702 | if Present (Outer_Scope) | |
17703 | and then Within (Scope (Ent), Outer_Scope) | |
17704 | then | |
17705 | Set_C_Scope; | |
17706 | Check_A_Call | |
17707 | (N => N, | |
17708 | E => Ent, | |
17709 | Outer_Scope => Outer_Scope, | |
17710 | Inter_Unit_Only => False, | |
17711 | In_Init_Proc => In_Init_Proc); | |
17712 | ||
17713 | -- Nothing to do if elaboration checks suppressed for this scope. | |
17714 | -- However, an interesting exception, the fact that elaboration checks | |
17715 | -- are suppressed within an instance (because we can trace the body when | |
17716 | -- we process the template) does not extend to calls to generic formal | |
17717 | -- subprograms. | |
17718 | ||
17719 | elsif Elaboration_Checks_Suppressed (Current_Scope) | |
17720 | and then not Is_Call_Of_Generic_Formal (N) | |
17721 | then | |
17722 | null; | |
17723 | ||
17724 | elsif From_Elab_Code then | |
17725 | Set_C_Scope; | |
17726 | Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); | |
17727 | ||
17728 | elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then | |
17729 | Set_C_Scope; | |
17730 | Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); | |
17731 | ||
17732 | -- If none of those cases holds, but Dynamic_Elaboration_Checks mode | |
17733 | -- is set, then we will do the check, but only in the inter-unit case | |
17734 | -- (this is to accommodate unguarded elaboration calls from other units | |
17735 | -- in which this same mode is set). We don't want warnings in this case, | |
17736 | -- it would generate warnings having nothing to do with elaboration. | |
17737 | ||
17738 | elsif Dynamic_Elaboration_Checks then | |
17739 | Set_C_Scope; | |
17740 | Check_A_Call | |
17741 | (N, | |
17742 | Ent, | |
17743 | Standard_Standard, | |
17744 | Inter_Unit_Only => True, | |
17745 | Generate_Warnings => False); | |
17746 | ||
17747 | -- Otherwise nothing to do | |
17748 | ||
17749 | else | |
17750 | return; | |
17751 | end if; | |
17752 | ||
17753 | -- A call to an Init_Proc in elaboration code may bring additional | |
17754 | -- dependencies, if some of the record components thereof have | |
17755 | -- initializations that are function calls that come from source. We | |
17756 | -- treat the current node as a call to each of these functions, to check | |
17757 | -- their elaboration impact. | |
17758 | ||
17759 | if Is_Init_Proc (Ent) and then From_Elab_Code then | |
17760 | Process_Init_Proc : declare | |
17761 | Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent); | |
17762 | ||
17763 | function Check_Init_Call (Nod : Node_Id) return Traverse_Result; | |
17764 | -- Find subprogram calls within body of Init_Proc for Traverse | |
17765 | -- instantiation below. | |
17766 | ||
17767 | procedure Traverse_Body is new Traverse_Proc (Check_Init_Call); | |
17768 | -- Traversal procedure to find all calls with body of Init_Proc | |
17769 | ||
17770 | --------------------- | |
17771 | -- Check_Init_Call -- | |
17772 | --------------------- | |
17773 | ||
17774 | function Check_Init_Call (Nod : Node_Id) return Traverse_Result is | |
17775 | Func : Entity_Id; | |
17776 | ||
17777 | begin | |
17778 | if Nkind (Nod) in N_Subprogram_Call | |
17779 | and then Is_Entity_Name (Name (Nod)) | |
17780 | then | |
17781 | Func := Entity (Name (Nod)); | |
17782 | ||
17783 | if Comes_From_Source (Func) then | |
17784 | Check_A_Call | |
17785 | (N, Func, Standard_Standard, Inter_Unit_Only => True); | |
17786 | end if; | |
17787 | ||
17788 | return OK; | |
17789 | ||
17790 | else | |
17791 | return OK; | |
17792 | end if; | |
17793 | end Check_Init_Call; | |
17794 | ||
17795 | -- Start of processing for Process_Init_Proc | |
17796 | ||
17797 | begin | |
17798 | if Nkind (Unit_Decl) = N_Subprogram_Body then | |
17799 | Traverse_Body (Handled_Statement_Sequence (Unit_Decl)); | |
17800 | end if; | |
17801 | end Process_Init_Proc; | |
17802 | end if; | |
17803 | end Check_Elab_Call; | |
17804 | ||
17805 | ----------------------- | |
17806 | -- Check_Elab_Assign -- | |
17807 | ----------------------- | |
17808 | ||
17809 | procedure Check_Elab_Assign (N : Node_Id) is | |
17810 | Ent : Entity_Id; | |
17811 | Scop : Entity_Id; | |
17812 | ||
17813 | Pkg_Spec : Entity_Id; | |
17814 | Pkg_Body : Entity_Id; | |
17815 | ||
17816 | begin | |
17817 | pragma Assert (Legacy_Elaboration_Checks); | |
17818 | ||
17819 | -- For record or array component, check prefix. If it is an access type, | |
17820 | -- then there is nothing to do (we do not know what is being assigned), | |
17821 | -- but otherwise this is an assignment to the prefix. | |
17822 | ||
17823 | if Nkind_In (N, N_Indexed_Component, | |
17824 | N_Selected_Component, | |
17825 | N_Slice) | |
17826 | then | |
17827 | if not Is_Access_Type (Etype (Prefix (N))) then | |
17828 | Check_Elab_Assign (Prefix (N)); | |
17829 | end if; | |
17830 | ||
17831 | return; | |
17832 | end if; | |
17833 | ||
17834 | -- For type conversion, check expression | |
17835 | ||
17836 | if Nkind (N) = N_Type_Conversion then | |
17837 | Check_Elab_Assign (Expression (N)); | |
17838 | return; | |
17839 | end if; | |
17840 | ||
17841 | -- Nothing to do if this is not an entity reference otherwise get entity | |
17842 | ||
17843 | if Is_Entity_Name (N) then | |
17844 | Ent := Entity (N); | |
17845 | else | |
17846 | return; | |
17847 | end if; | |
17848 | ||
17849 | -- What we are looking for is a reference in the body of a package that | |
17850 | -- modifies a variable declared in the visible part of the package spec. | |
17851 | ||
17852 | if Present (Ent) | |
17853 | and then Comes_From_Source (N) | |
17854 | and then not Suppress_Elaboration_Warnings (Ent) | |
17855 | and then Ekind (Ent) = E_Variable | |
17856 | and then not In_Private_Part (Ent) | |
17857 | and then Is_Library_Level_Entity (Ent) | |
17858 | then | |
17859 | Scop := Current_Scope; | |
17860 | loop | |
17861 | if No (Scop) or else Scop = Standard_Standard then | |
17862 | return; | |
17863 | elsif Ekind (Scop) = E_Package | |
17864 | and then Is_Compilation_Unit (Scop) | |
17865 | then | |
17866 | exit; | |
17867 | else | |
17868 | Scop := Scope (Scop); | |
17869 | end if; | |
17870 | end loop; | |
17871 | ||
17872 | -- Here Scop points to the containing library package | |
17873 | ||
17874 | Pkg_Spec := Scop; | |
17875 | Pkg_Body := Body_Entity (Pkg_Spec); | |
17876 | ||
17877 | -- All OK if the package has an Elaborate_Body pragma | |
17878 | ||
17879 | if Has_Pragma_Elaborate_Body (Scop) then | |
17880 | return; | |
17881 | end if; | |
17882 | ||
17883 | -- OK if entity being modified is not in containing package spec | |
17884 | ||
17885 | if not In_Same_Source_Unit (Scop, Ent) then | |
17886 | return; | |
17887 | end if; | |
17888 | ||
17889 | -- All OK if entity appears in generic package or generic instance. | |
17890 | -- We just get too messed up trying to give proper warnings in the | |
17891 | -- presence of generics. Better no message than a junk one. | |
17892 | ||
17893 | Scop := Scope (Ent); | |
17894 | while Present (Scop) and then Scop /= Pkg_Spec loop | |
17895 | if Ekind (Scop) = E_Generic_Package then | |
17896 | return; | |
17897 | elsif Ekind (Scop) = E_Package | |
17898 | and then Is_Generic_Instance (Scop) | |
17899 | then | |
17900 | return; | |
17901 | end if; | |
17902 | ||
17903 | Scop := Scope (Scop); | |
17904 | end loop; | |
17905 | ||
17906 | -- All OK if in task, don't issue warnings there | |
17907 | ||
17908 | if In_Task_Activation then | |
17909 | return; | |
17910 | end if; | |
17911 | ||
17912 | -- OK if no package body | |
17913 | ||
17914 | if No (Pkg_Body) then | |
17915 | return; | |
17916 | end if; | |
17917 | ||
17918 | -- OK if reference is not in package body | |
17919 | ||
17920 | if not In_Same_Source_Unit (Pkg_Body, N) then | |
17921 | return; | |
17922 | end if; | |
17923 | ||
17924 | -- OK if package body has no handled statement sequence | |
17925 | ||
17926 | declare | |
17927 | HSS : constant Node_Id := | |
17928 | Handled_Statement_Sequence (Declaration_Node (Pkg_Body)); | |
17929 | begin | |
17930 | if No (HSS) or else not Comes_From_Source (HSS) then | |
17931 | return; | |
17932 | end if; | |
17933 | end; | |
17934 | ||
17935 | -- We definitely have a case of a modification of an entity in | |
17936 | -- the package spec from the elaboration code of the package body. | |
17937 | -- We may not give the warning (because there are some additional | |
17938 | -- checks to avoid too many false positives), but it would be a good | |
17939 | -- idea for the binder to try to keep the body elaboration close to | |
17940 | -- the spec elaboration. | |
17941 | ||
17942 | Set_Elaborate_Body_Desirable (Pkg_Spec); | |
17943 | ||
17944 | -- All OK in gnat mode (we know what we are doing) | |
17945 | ||
17946 | if GNAT_Mode then | |
17947 | return; | |
17948 | end if; | |
17949 | ||
17950 | -- All OK if all warnings suppressed | |
17951 | ||
17952 | if Warning_Mode = Suppress then | |
17953 | return; | |
17954 | end if; | |
17955 | ||
17956 | -- All OK if elaboration checks suppressed for entity | |
17957 | ||
17958 | if Checks_May_Be_Suppressed (Ent) | |
17959 | and then Is_Check_Suppressed (Ent, Elaboration_Check) | |
17960 | then | |
17961 | return; | |
17962 | end if; | |
17963 | ||
17964 | -- OK if the entity is initialized. Note that the No_Initialization | |
17965 | -- flag usually means that the initialization has been rewritten into | |
17966 | -- assignments, but that still counts for us. | |
17967 | ||
17968 | declare | |
17969 | Decl : constant Node_Id := Declaration_Node (Ent); | |
17970 | begin | |
17971 | if Nkind (Decl) = N_Object_Declaration | |
17972 | and then (Present (Expression (Decl)) | |
17973 | or else No_Initialization (Decl)) | |
17974 | then | |
17975 | return; | |
17976 | end if; | |
17977 | end; | |
17978 | ||
17979 | -- Here is where we give the warning | |
17980 | ||
17981 | -- All OK if warnings suppressed on the entity | |
17982 | ||
17983 | if not Has_Warnings_Off (Ent) then | |
17984 | Error_Msg_Sloc := Sloc (Ent); | |
17985 | ||
17986 | Error_Msg_NE | |
17987 | ("??& can be accessed by clients before this initialization", | |
17988 | N, Ent); | |
17989 | Error_Msg_NE | |
17990 | ("\??add Elaborate_Body to spec to ensure & is initialized", | |
17991 | N, Ent); | |
17992 | end if; | |
17993 | ||
17994 | if not All_Errors_Mode then | |
17995 | Set_Suppress_Elaboration_Warnings (Ent); | |
17996 | end if; | |
17997 | end if; | |
17998 | end Check_Elab_Assign; | |
17999 | ||
18000 | ---------------------- | |
18001 | -- Check_Elab_Calls -- | |
18002 | ---------------------- | |
18003 | ||
18004 | -- WARNING: This routine manages SPARK regions | |
18005 | ||
18006 | procedure Check_Elab_Calls is | |
18007 | Saved_SM : SPARK_Mode_Type; | |
18008 | Saved_SMP : Node_Id; | |
18009 | ||
18010 | begin | |
18011 | pragma Assert (Legacy_Elaboration_Checks); | |
18012 | ||
18013 | -- If expansion is disabled, do not generate any checks, unless we | |
18014 | -- are in GNATprove mode, so that errors are issued in GNATprove for | |
18015 | -- violations of static elaboration rules in SPARK code. Also skip | |
18016 | -- checks if any subunits are missing because in either case we lack the | |
18017 | -- full information that we need, and no object file will be created in | |
18018 | -- any case. | |
18019 | ||
18020 | if (not Expander_Active and not GNATprove_Mode) | |
18021 | or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) | |
18022 | or else Subunits_Missing | |
18023 | then | |
18024 | return; | |
18025 | end if; | |
18026 | ||
18027 | -- Skip delayed calls if we had any errors | |
18028 | ||
18029 | if Serious_Errors_Detected = 0 then | |
18030 | Delaying_Elab_Checks := False; | |
18031 | Expander_Mode_Save_And_Set (True); | |
18032 | ||
18033 | for J in Delay_Check.First .. Delay_Check.Last loop | |
18034 | Push_Scope (Delay_Check.Table (J).Curscop); | |
18035 | From_Elab_Code := Delay_Check.Table (J).From_Elab_Code; | |
18036 | In_Task_Activation := Delay_Check.Table (J).In_Task_Activation; | |
18037 | ||
18038 | Saved_SM := SPARK_Mode; | |
18039 | Saved_SMP := SPARK_Mode_Pragma; | |
18040 | ||
18041 | -- Set appropriate value of SPARK_Mode | |
18042 | ||
18043 | if Delay_Check.Table (J).From_SPARK_Code then | |
18044 | SPARK_Mode := On; | |
18045 | end if; | |
18046 | ||
18047 | Check_Internal_Call_Continue | |
18048 | (N => Delay_Check.Table (J).N, | |
18049 | E => Delay_Check.Table (J).E, | |
18050 | Outer_Scope => Delay_Check.Table (J).Outer_Scope, | |
18051 | Orig_Ent => Delay_Check.Table (J).Orig_Ent); | |
18052 | ||
18053 | Restore_SPARK_Mode (Saved_SM, Saved_SMP); | |
18054 | Pop_Scope; | |
18055 | end loop; | |
18056 | ||
18057 | -- Set Delaying_Elab_Checks back on for next main compilation | |
18058 | ||
18059 | Expander_Mode_Restore; | |
18060 | Delaying_Elab_Checks := True; | |
18061 | end if; | |
18062 | end Check_Elab_Calls; | |
18063 | ||
18064 | ------------------------------ | |
18065 | -- Check_Elab_Instantiation -- | |
18066 | ------------------------------ | |
18067 | ||
18068 | procedure Check_Elab_Instantiation | |
18069 | (N : Node_Id; | |
18070 | Outer_Scope : Entity_Id := Empty) | |
18071 | is | |
18072 | Ent : Entity_Id; | |
18073 | ||
18074 | begin | |
18075 | pragma Assert (Legacy_Elaboration_Checks); | |
18076 | ||
18077 | -- Check for and deal with bad instantiation case. There is some | |
18078 | -- duplicated code here, but we will worry about this later ??? | |
18079 | ||
18080 | Check_Bad_Instantiation (N); | |
18081 | ||
18082 | if Is_Known_Guaranteed_ABE (N) then | |
18083 | return; | |
18084 | end if; | |
18085 | ||
18086 | -- Nothing to do if we do not have an instantiation (happens in some | |
18087 | -- error cases, and also in the formal package declaration case) | |
18088 | ||
18089 | if Nkind (N) not in N_Generic_Instantiation then | |
18090 | return; | |
18091 | end if; | |
18092 | ||
18093 | -- Nothing to do if inside a generic template | |
18094 | ||
18095 | if Inside_A_Generic then | |
18096 | return; | |
18097 | end if; | |
18098 | ||
18099 | -- Nothing to do if the instantiation is not in the main unit | |
18100 | ||
18101 | if not In_Extended_Main_Code_Unit (N) then | |
18102 | return; | |
18103 | end if; | |
18104 | ||
18105 | Ent := Get_Generic_Entity (N); | |
18106 | From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; | |
18107 | ||
18108 | -- See if we need to analyze this instantiation. We analyze it if | |
18109 | -- either of the following conditions is met: | |
18110 | ||
18111 | -- It is an inner level instantiation (since in this case it was | |
18112 | -- triggered by an outer level call from elaboration code), but | |
18113 | -- only if the instantiation is within the scope of the original | |
18114 | -- outer level call. | |
18115 | ||
18116 | -- It is an outer level instantiation from elaboration code, or the | |
18117 | -- instantiated entity is in the same elaboration scope. | |
18118 | ||
18119 | -- And in these cases, we will check both the inter-unit case and | |
18120 | -- the intra-unit (within a single unit) case. | |
18121 | ||
18122 | C_Scope := Current_Scope; | |
18123 | ||
18124 | if Present (Outer_Scope) and then Within (Scope (Ent), Outer_Scope) then | |
18125 | Set_C_Scope; | |
18126 | Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False); | |
18127 | ||
18128 | elsif From_Elab_Code then | |
18129 | Set_C_Scope; | |
18130 | Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False); | |
18131 | ||
18132 | elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then | |
18133 | Set_C_Scope; | |
18134 | Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); | |
18135 | ||
18136 | -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is | |
18137 | -- set, then we will do the check, but only in the inter-unit case (this | |
18138 | -- is to accommodate unguarded elaboration calls from other units in | |
18139 | -- which this same mode is set). We inhibit warnings in this case, since | |
18140 | -- this instantiation is not occurring in elaboration code. | |
18141 | ||
18142 | elsif Dynamic_Elaboration_Checks then | |
18143 | Set_C_Scope; | |
18144 | Check_A_Call | |
18145 | (N, | |
18146 | Ent, | |
18147 | Standard_Standard, | |
18148 | Inter_Unit_Only => True, | |
18149 | Generate_Warnings => False); | |
18150 | ||
18151 | else | |
18152 | return; | |
18153 | end if; | |
18154 | end Check_Elab_Instantiation; | |
18155 | ||
18156 | ------------------------- | |
18157 | -- Check_Internal_Call -- | |
18158 | ------------------------- | |
18159 | ||
18160 | procedure Check_Internal_Call | |
18161 | (N : Node_Id; | |
18162 | E : Entity_Id; | |
18163 | Outer_Scope : Entity_Id; | |
18164 | Orig_Ent : Entity_Id) | |
18165 | is | |
18166 | function Within_Initial_Condition (Call : Node_Id) return Boolean; | |
18167 | -- Determine whether call Call occurs within pragma Initial_Condition or | |
18168 | -- pragma Check with check_kind set to Initial_Condition. | |
18169 | ||
18170 | ------------------------------ | |
18171 | -- Within_Initial_Condition -- | |
18172 | ------------------------------ | |
18173 | ||
18174 | function Within_Initial_Condition (Call : Node_Id) return Boolean is | |
18175 | Args : List_Id; | |
18176 | Nam : Name_Id; | |
18177 | Par : Node_Id; | |
18178 | ||
18179 | begin | |
18180 | -- Traverse the parent chain looking for an enclosing pragma | |
18181 | ||
18182 | Par := Call; | |
18183 | while Present (Par) loop | |
18184 | if Nkind (Par) = N_Pragma then | |
18185 | Nam := Pragma_Name (Par); | |
18186 | ||
18187 | -- Pragma Initial_Condition appears in its alternative from as | |
18188 | -- Check (Initial_Condition, ...). | |
18189 | ||
18190 | if Nam = Name_Check then | |
18191 | Args := Pragma_Argument_Associations (Par); | |
18192 | ||
18193 | -- Pragma Check should have at least two arguments | |
18194 | ||
18195 | pragma Assert (Present (Args)); | |
18196 | ||
18197 | return | |
18198 | Chars (Expression (First (Args))) = Name_Initial_Condition; | |
18199 | ||
18200 | -- Direct match | |
18201 | ||
18202 | elsif Nam = Name_Initial_Condition then | |
18203 | return True; | |
18204 | ||
18205 | -- Since pragmas are never nested within other pragmas, stop | |
18206 | -- the traversal. | |
18207 | ||
18208 | else | |
18209 | return False; | |
18210 | end if; | |
18211 | ||
18212 | -- Prevent the search from going too far | |
18213 | ||
18214 | elsif Is_Body_Or_Package_Declaration (Par) then | |
18215 | exit; | |
18216 | end if; | |
18217 | ||
18218 | Par := Parent (Par); | |
18219 | ||
18220 | -- If assertions are not enabled, the check pragma is rewritten | |
18221 | -- as an if_statement in sem_prag, to generate various warnings | |
18222 | -- on boolean expressions. Retrieve the original pragma. | |
18223 | ||
18224 | if Nkind (Original_Node (Par)) = N_Pragma then | |
18225 | Par := Original_Node (Par); | |
18226 | end if; | |
18227 | end loop; | |
18228 | ||
18229 | return False; | |
18230 | end Within_Initial_Condition; | |
18231 | ||
18232 | -- Local variables | |
18233 | ||
18234 | Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; | |
18235 | ||
18236 | -- Start of processing for Check_Internal_Call | |
18237 | ||
18238 | begin | |
18239 | -- For P'Access, we want to warn if the -gnatw.f switch is set, and the | |
18240 | -- node comes from source. | |
18241 | ||
18242 | if Nkind (N) = N_Attribute_Reference | |
18243 | and then ((not Warn_On_Elab_Access and then not Debug_Flag_Dot_O) | |
18244 | or else not Comes_From_Source (N)) | |
18245 | then | |
18246 | return; | |
18247 | ||
18248 | -- If not function or procedure call, instantiation, or 'Access, then | |
18249 | -- ignore call (this happens in some error cases and rewriting cases). | |
18250 | ||
18251 | elsif not Nkind_In (N, N_Attribute_Reference, | |
18252 | N_Function_Call, | |
18253 | N_Procedure_Call_Statement) | |
18254 | and then not Inst_Case | |
18255 | then | |
18256 | return; | |
18257 | ||
18258 | -- Nothing to do if this is a call or instantiation that has already | |
18259 | -- been found to be a sure ABE. | |
18260 | ||
18261 | elsif Nkind (N) /= N_Attribute_Reference | |
18262 | and then Is_Known_Guaranteed_ABE (N) | |
18263 | then | |
18264 | return; | |
18265 | ||
18266 | -- Nothing to do if errors already detected (avoid cascaded errors) | |
18267 | ||
18268 | elsif Serious_Errors_Detected /= 0 then | |
18269 | return; | |
18270 | ||
18271 | -- Nothing to do if not in full analysis mode | |
18272 | ||
18273 | elsif not Full_Analysis then | |
18274 | return; | |
18275 | ||
18276 | -- Nothing to do if analyzing in special spec-expression mode, since the | |
18277 | -- call is not actually being made at this time. | |
18278 | ||
18279 | elsif In_Spec_Expression then | |
18280 | return; | |
18281 | ||
18282 | -- Nothing to do for call to intrinsic subprogram | |
18283 | ||
18284 | elsif Is_Intrinsic_Subprogram (E) then | |
18285 | return; | |
18286 | ||
18287 | -- Nothing to do if call is within a generic unit | |
18288 | ||
18289 | elsif Inside_A_Generic then | |
18290 | return; | |
18291 | ||
18292 | -- Nothing to do when the call appears within pragma Initial_Condition. | |
18293 | -- The pragma is part of the elaboration statements of a package body | |
18294 | -- and may only call external subprograms or subprograms whose body is | |
18295 | -- already available. | |
18296 | ||
18297 | elsif Within_Initial_Condition (N) then | |
18298 | return; | |
18299 | end if; | |
18300 | ||
18301 | -- Delay this call if we are still delaying calls | |
18302 | ||
18303 | if Delaying_Elab_Checks then | |
18304 | Delay_Check.Append | |
18305 | ((N => N, | |
18306 | E => E, | |
18307 | Orig_Ent => Orig_Ent, | |
18308 | Curscop => Current_Scope, | |
18309 | Outer_Scope => Outer_Scope, | |
18310 | From_Elab_Code => From_Elab_Code, | |
18311 | In_Task_Activation => In_Task_Activation, | |
18312 | From_SPARK_Code => SPARK_Mode = On)); | |
18313 | return; | |
18314 | ||
18315 | -- Otherwise, call phase 2 continuation right now | |
18316 | ||
18317 | else | |
18318 | Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent); | |
18319 | end if; | |
18320 | end Check_Internal_Call; | |
18321 | ||
18322 | ---------------------------------- | |
18323 | -- Check_Internal_Call_Continue -- | |
18324 | ---------------------------------- | |
18325 | ||
18326 | procedure Check_Internal_Call_Continue | |
18327 | (N : Node_Id; | |
18328 | E : Entity_Id; | |
18329 | Outer_Scope : Entity_Id; | |
18330 | Orig_Ent : Entity_Id) | |
18331 | is | |
18332 | function Find_Elab_Reference (N : Node_Id) return Traverse_Result; | |
18333 | -- Function applied to each node as we traverse the body. Checks for | |
18334 | -- call or entity reference that needs checking, and if so checks it. | |
18335 | -- Always returns OK, so entire tree is traversed, except that as | |
18336 | -- described below subprogram bodies are skipped for now. | |
18337 | ||
18338 | procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference); | |
18339 | -- Traverse procedure using above Find_Elab_Reference function | |
18340 | ||
18341 | ------------------------- | |
18342 | -- Find_Elab_Reference -- | |
18343 | ------------------------- | |
18344 | ||
18345 | function Find_Elab_Reference (N : Node_Id) return Traverse_Result is | |
18346 | Actual : Node_Id; | |
18347 | ||
18348 | begin | |
18349 | -- If user has specified that there are no entry calls in elaboration | |
18350 | -- code, do not trace past an accept statement, because the rendez- | |
18351 | -- vous will happen after elaboration. | |
18352 | ||
18353 | if Nkind_In (Original_Node (N), N_Accept_Statement, | |
18354 | N_Selective_Accept) | |
18355 | and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code) | |
18356 | then | |
18357 | return Abandon; | |
18358 | ||
18359 | -- If we have a function call, check it | |
18360 | ||
18361 | elsif Nkind (N) = N_Function_Call then | |
18362 | Check_Elab_Call (N, Outer_Scope); | |
18363 | return OK; | |
18364 | ||
18365 | -- If we have a procedure call, check the call, and also check | |
18366 | -- arguments that are assignments (OUT or IN OUT mode formals). | |
18367 | ||
18368 | elsif Nkind (N) = N_Procedure_Call_Statement then | |
18369 | Check_Elab_Call (N, Outer_Scope, In_Init_Proc => Is_Init_Proc (E)); | |
18370 | ||
18371 | Actual := First_Actual (N); | |
18372 | while Present (Actual) loop | |
18373 | if Known_To_Be_Assigned (Actual) then | |
18374 | Check_Elab_Assign (Actual); | |
18375 | end if; | |
18376 | ||
18377 | Next_Actual (Actual); | |
18378 | end loop; | |
18379 | ||
18380 | return OK; | |
18381 | ||
18382 | -- If we have an access attribute for a subprogram, check it. | |
18383 | -- Suppress this behavior under debug flag. | |
18384 | ||
18385 | elsif not Debug_Flag_Dot_UU | |
18386 | and then Nkind (N) = N_Attribute_Reference | |
18387 | and then Nam_In (Attribute_Name (N), Name_Access, | |
18388 | Name_Unrestricted_Access) | |
18389 | and then Is_Entity_Name (Prefix (N)) | |
18390 | and then Is_Subprogram (Entity (Prefix (N))) | |
18391 | then | |
18392 | Check_Elab_Call (N, Outer_Scope); | |
18393 | return OK; | |
18394 | ||
18395 | -- In SPARK mode, if we have an entity reference to a variable, then | |
18396 | -- check it. For now we consider any reference. | |
18397 | ||
18398 | elsif SPARK_Mode = On | |
18399 | and then Nkind (N) in N_Has_Entity | |
18400 | and then Present (Entity (N)) | |
18401 | and then Ekind (Entity (N)) = E_Variable | |
18402 | then | |
18403 | Check_Elab_Call (N, Outer_Scope); | |
18404 | return OK; | |
18405 | ||
18406 | -- If we have a generic instantiation, check it | |
18407 | ||
18408 | elsif Nkind (N) in N_Generic_Instantiation then | |
18409 | Check_Elab_Instantiation (N, Outer_Scope); | |
18410 | return OK; | |
18411 | ||
18412 | -- Skip subprogram bodies that come from source (wait for call to | |
18413 | -- analyze these). The reason for the come from source test is to | |
18414 | -- avoid catching task bodies. | |
18415 | ||
18416 | -- For task bodies, we should really avoid these too, waiting for the | |
18417 | -- task activation, but that's too much trouble to catch for now, so | |
18418 | -- we go in unconditionally. This is not so terrible, it means the | |
18419 | -- error backtrace is not quite complete, and we are too eager to | |
18420 | -- scan bodies of tasks that are unused, but this is hardly very | |
18421 | -- significant. | |
18422 | ||
18423 | elsif Nkind (N) = N_Subprogram_Body | |
18424 | and then Comes_From_Source (N) | |
18425 | then | |
18426 | return Skip; | |
18427 | ||
18428 | elsif Nkind (N) = N_Assignment_Statement | |
18429 | and then Comes_From_Source (N) | |
18430 | then | |
18431 | Check_Elab_Assign (Name (N)); | |
18432 | return OK; | |
18433 | ||
18434 | else | |
18435 | return OK; | |
18436 | end if; | |
18437 | end Find_Elab_Reference; | |
18438 | ||
18439 | Inst_Case : constant Boolean := Is_Generic_Unit (E); | |
18440 | Loc : constant Source_Ptr := Sloc (N); | |
18441 | ||
18442 | Ebody : Entity_Id; | |
18443 | Sbody : Node_Id; | |
18444 | ||
18445 | -- Start of processing for Check_Internal_Call_Continue | |
18446 | ||
18447 | begin | |
18448 | -- Save outer level call if at outer level | |
18449 | ||
18450 | if Elab_Call.Last = 0 then | |
18451 | Outer_Level_Sloc := Loc; | |
18452 | end if; | |
18453 | ||
18454 | -- If the call is to a function that renames a literal, no check needed | |
18455 | ||
18456 | if Ekind (E) = E_Enumeration_Literal then | |
18457 | return; | |
18458 | end if; | |
18459 | ||
18460 | -- Register the subprogram as examined within this particular context. | |
18461 | -- This ensures that calls to the same subprogram but in different | |
18462 | -- contexts receive warnings and checks of their own since the calls | |
18463 | -- may be reached through different flow paths. | |
18464 | ||
18465 | Elab_Visited.Append ((Subp_Id => E, Context => Parent (N))); | |
18466 | ||
18467 | Sbody := Unit_Declaration_Node (E); | |
18468 | ||
18469 | if not Nkind_In (Sbody, N_Subprogram_Body, N_Package_Body) then | |
18470 | Ebody := Corresponding_Body (Sbody); | |
18471 | ||
18472 | if No (Ebody) then | |
18473 | return; | |
18474 | else | |
18475 | Sbody := Unit_Declaration_Node (Ebody); | |
18476 | end if; | |
18477 | end if; | |
18478 | ||
18479 | -- If the body appears after the outer level call or instantiation then | |
18480 | -- we have an error case handled below. | |
18481 | ||
18482 | if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody)) | |
18483 | and then not In_Task_Activation | |
18484 | then | |
18485 | null; | |
18486 | ||
18487 | -- If we have the instantiation case we are done, since we now know that | |
18488 | -- the body of the generic appeared earlier. | |
18489 | ||
18490 | elsif Inst_Case then | |
18491 | return; | |
18492 | ||
18493 | -- Otherwise we have a call, so we trace through the called body to see | |
18494 | -- if it has any problems. | |
18495 | ||
18496 | else | |
18497 | pragma Assert (Nkind (Sbody) = N_Subprogram_Body); | |
18498 | ||
18499 | Elab_Call.Append ((Cloc => Loc, Ent => E)); | |
18500 | ||
18501 | if Debug_Flag_Underscore_LL then | |
18502 | Write_Str ("Elab_Call.Last = "); | |
18503 | Write_Int (Int (Elab_Call.Last)); | |
18504 | Write_Str (" Ent = "); | |
18505 | Write_Name (Chars (E)); | |
18506 | Write_Str (" at "); | |
18507 | Write_Location (Sloc (N)); | |
18508 | Write_Eol; | |
18509 | end if; | |
18510 | ||
18511 | -- Now traverse declarations and statements of subprogram body. Note | |
18512 | -- that we cannot simply Traverse (Sbody), since traverse does not | |
18513 | -- normally visit subprogram bodies. | |
18514 | ||
18515 | declare | |
18516 | Decl : Node_Id; | |
18517 | begin | |
18518 | Decl := First (Declarations (Sbody)); | |
18519 | while Present (Decl) loop | |
18520 | Traverse (Decl); | |
18521 | Next (Decl); | |
18522 | end loop; | |
18523 | end; | |
18524 | ||
18525 | Traverse (Handled_Statement_Sequence (Sbody)); | |
18526 | ||
18527 | Elab_Call.Decrement_Last; | |
18528 | return; | |
18529 | end if; | |
18530 | ||
18531 | -- Here is the case of calling a subprogram where the body has not yet | |
18532 | -- been encountered. A warning message is needed, except if this is the | |
18533 | -- case of appearing within an aspect specification that results in | |
18534 | -- a check call, we do not really have such a situation, so no warning | |
18535 | -- is needed (e.g. the case of a precondition, where the call appears | |
18536 | -- textually before the body, but in actual fact is moved to the | |
18537 | -- appropriate subprogram body and so does not need a check). | |
18538 | ||
18539 | declare | |
18540 | P : Node_Id; | |
18541 | O : Node_Id; | |
18542 | ||
18543 | begin | |
18544 | P := Parent (N); | |
18545 | loop | |
18546 | -- Keep looking at parents if we are still in the subexpression | |
18547 | ||
18548 | if Nkind (P) in N_Subexpr then | |
18549 | P := Parent (P); | |
18550 | ||
18551 | -- Here P is the parent of the expression, check for special case | |
18552 | ||
18553 | else | |
18554 | O := Original_Node (P); | |
18555 | ||
18556 | -- Definitely not the special case if orig node is not a pragma | |
18557 | ||
18558 | exit when Nkind (O) /= N_Pragma; | |
18559 | ||
18560 | -- Check we have an If statement or a null statement (happens | |
18561 | -- when the If has been expanded to be True). | |
18562 | ||
18563 | exit when not Nkind_In (P, N_If_Statement, N_Null_Statement); | |
18564 | ||
18565 | -- Our special case will be indicated either by the pragma | |
18566 | -- coming from an aspect ... | |
18567 | ||
18568 | if Present (Corresponding_Aspect (O)) then | |
18569 | return; | |
18570 | ||
18571 | -- Or, in the case of an initial condition, specifically by a | |
18572 | -- Check pragma specifying an Initial_Condition check. | |
18573 | ||
18574 | elsif Pragma_Name (O) = Name_Check | |
18575 | and then | |
18576 | Chars | |
18577 | (Expression (First (Pragma_Argument_Associations (O)))) = | |
18578 | Name_Initial_Condition | |
18579 | then | |
18580 | return; | |
18581 | ||
18582 | -- For anything else, we have an error | |
18583 | ||
18584 | else | |
18585 | exit; | |
18586 | end if; | |
18587 | end if; | |
18588 | end loop; | |
18589 | end; | |
18590 | ||
18591 | -- Not that special case, warning and dynamic check is required | |
18592 | ||
18593 | -- If we have nothing in the call stack, then this is at the outer | |
18594 | -- level, and the ABE is bound to occur, unless it's a 'Access, or | |
18595 | -- it's a renaming. | |
18596 | ||
18597 | if Elab_Call.Last = 0 then | |
18598 | Error_Msg_Warn := SPARK_Mode /= On; | |
18599 | ||
18600 | declare | |
18601 | Insert_Check : Boolean := True; | |
18602 | -- This flag is set to True if an elaboration check should be | |
18603 | -- inserted. | |
18604 | ||
18605 | begin | |
18606 | if In_Task_Activation then | |
18607 | Insert_Check := False; | |
18608 | ||
18609 | elsif Inst_Case then | |
18610 | Error_Msg_NE | |
18611 | ("cannot instantiate& before body seen<<", N, Orig_Ent); | |
18612 | ||
18613 | elsif Nkind (N) = N_Attribute_Reference then | |
18614 | Error_Msg_NE | |
18615 | ("Access attribute of & before body seen<<", N, Orig_Ent); | |
18616 | Error_Msg_N ("\possible Program_Error on later references<", N); | |
18617 | Insert_Check := False; | |
18618 | ||
18619 | elsif Nkind (Unit_Declaration_Node (Orig_Ent)) /= | |
18620 | N_Subprogram_Renaming_Declaration | |
18621 | then | |
18622 | Error_Msg_NE | |
18623 | ("cannot call& before body seen<<", N, Orig_Ent); | |
18624 | ||
18625 | elsif not Is_Generic_Actual_Subprogram (Orig_Ent) then | |
18626 | Insert_Check := False; | |
18627 | end if; | |
18628 | ||
18629 | if Insert_Check then | |
18630 | Error_Msg_N ("\Program_Error [<<", N); | |
18631 | Insert_Elab_Check (N); | |
18632 | end if; | |
18633 | end; | |
18634 | ||
18635 | -- Call is not at outer level | |
18636 | ||
18637 | else | |
18638 | -- Do not generate elaboration checks in GNATprove mode because the | |
18639 | -- elaboration counter and the check are both forms of expansion. | |
18640 | ||
18641 | if GNATprove_Mode then | |
18642 | null; | |
18643 | ||
18644 | -- Generate an elaboration check | |
18645 | ||
18646 | elsif not Elaboration_Checks_Suppressed (E) then | |
18647 | Set_Elaboration_Entity_Required (E); | |
18648 | ||
18649 | -- Create a declaration of the elaboration entity, and insert it | |
18650 | -- prior to the subprogram or the generic unit, within the same | |
18651 | -- scope. Since the subprogram may be overloaded, create a unique | |
18652 | -- entity. | |
18653 | ||
18654 | if No (Elaboration_Entity (E)) then | |
18655 | declare | |
18656 | Loce : constant Source_Ptr := Sloc (E); | |
18657 | Ent : constant Entity_Id := | |
18658 | Make_Defining_Identifier (Loc, | |
18659 | New_External_Name (Chars (E), 'E', -1)); | |
18660 | ||
18661 | begin | |
18662 | Set_Elaboration_Entity (E, Ent); | |
18663 | Push_Scope (Scope (E)); | |
18664 | ||
18665 | Insert_Action (Declaration_Node (E), | |
18666 | Make_Object_Declaration (Loce, | |
18667 | Defining_Identifier => Ent, | |
18668 | Object_Definition => | |
18669 | New_Occurrence_Of (Standard_Short_Integer, Loce), | |
18670 | Expression => | |
18671 | Make_Integer_Literal (Loc, Uint_0))); | |
18672 | ||
18673 | -- Set elaboration flag at the point of the body | |
18674 | ||
18675 | Set_Elaboration_Flag (Sbody, E); | |
18676 | ||
18677 | -- Kill current value indication. This is necessary because | |
18678 | -- the tests of this flag are inserted out of sequence and | |
18679 | -- must not pick up bogus indications of the wrong constant | |
18680 | -- value. Also, this is never a true constant, since one way | |
18681 | -- or another, it gets reset. | |
18682 | ||
18683 | Set_Current_Value (Ent, Empty); | |
18684 | Set_Last_Assignment (Ent, Empty); | |
18685 | Set_Is_True_Constant (Ent, False); | |
18686 | Pop_Scope; | |
18687 | end; | |
18688 | end if; | |
18689 | ||
18690 | -- Generate: | |
18691 | -- if Enn = 0 then | |
18692 | -- raise Program_Error with "access before elaboration"; | |
18693 | -- end if; | |
18694 | ||
18695 | Insert_Elab_Check (N, | |
18696 | Make_Attribute_Reference (Loc, | |
18697 | Attribute_Name => Name_Elaborated, | |
18698 | Prefix => New_Occurrence_Of (E, Loc))); | |
18699 | end if; | |
18700 | ||
18701 | -- Generate the warning | |
18702 | ||
18703 | if not Suppress_Elaboration_Warnings (E) | |
18704 | and then not Elaboration_Checks_Suppressed (E) | |
18705 | ||
18706 | -- Suppress this warning if we have a function call that occurred | |
18707 | -- within an assertion expression, since we can get false warnings | |
18708 | -- in this case, due to the out of order handling in this case. | |
18709 | ||
18710 | and then | |
18711 | (Nkind (Original_Node (N)) /= N_Function_Call | |
18712 | or else not In_Assertion_Expression_Pragma (Original_Node (N))) | |
18713 | then | |
18714 | Error_Msg_Warn := SPARK_Mode /= On; | |
18715 | ||
18716 | if Inst_Case then | |
18717 | Error_Msg_NE | |
18718 | ("instantiation of& may occur before body is seen<l<", | |
18719 | N, Orig_Ent); | |
18720 | else | |
18721 | -- A rather specific check. For Finalize/Adjust/Initialize, if | |
18722 | -- the type has Warnings_Off set, suppress the warning. | |
18723 | ||
18724 | if Nam_In (Chars (E), Name_Adjust, | |
18725 | Name_Finalize, | |
18726 | Name_Initialize) | |
18727 | and then Present (First_Formal (E)) | |
18728 | then | |
18729 | declare | |
18730 | T : constant Entity_Id := Etype (First_Formal (E)); | |
18731 | begin | |
18732 | if Is_Controlled (T) then | |
18733 | if Warnings_Off (T) | |
18734 | or else (Ekind (T) = E_Private_Type | |
18735 | and then Warnings_Off (Full_View (T))) | |
18736 | then | |
18737 | goto Output; | |
18738 | end if; | |
18739 | end if; | |
18740 | end; | |
18741 | end if; | |
18742 | ||
18743 | -- Go ahead and give warning if not this special case | |
18744 | ||
18745 | Error_Msg_NE | |
18746 | ("call to& may occur before body is seen<l<", N, Orig_Ent); | |
18747 | end if; | |
18748 | ||
18749 | Error_Msg_N ("\Program_Error ]<l<", N); | |
18750 | ||
18751 | -- There is no need to query the elaboration warning message flags | |
18752 | -- because the main message is an error, not a warning, therefore | |
18753 | -- all the clarification messages produces by Output_Calls must be | |
18754 | -- emitted unconditionally. | |
18755 | ||
18756 | <<Output>> | |
18757 | ||
18758 | Output_Calls (N, Check_Elab_Flag => False); | |
18759 | end if; | |
18760 | end if; | |
18761 | end Check_Internal_Call_Continue; | |
18762 | ||
18763 | --------------------------- | |
18764 | -- Check_Task_Activation -- | |
18765 | --------------------------- | |
18766 | ||
18767 | procedure Check_Task_Activation (N : Node_Id) is | |
18768 | Loc : constant Source_Ptr := Sloc (N); | |
18769 | Inter_Procs : constant Elist_Id := New_Elmt_List; | |
18770 | Intra_Procs : constant Elist_Id := New_Elmt_List; | |
18771 | Ent : Entity_Id; | |
18772 | P : Entity_Id; | |
18773 | Task_Scope : Entity_Id; | |
18774 | Cunit_SC : Boolean := False; | |
18775 | Decl : Node_Id; | |
18776 | Elmt : Elmt_Id; | |
18777 | Enclosing : Entity_Id; | |
18778 | ||
18779 | procedure Add_Task_Proc (Typ : Entity_Id); | |
18780 | -- Add to Task_Procs the task body procedure(s) of task types in Typ. | |
18781 | -- For record types, this procedure recurses over component types. | |
18782 | ||
18783 | procedure Collect_Tasks (Decls : List_Id); | |
18784 | -- Collect the types of the tasks that are to be activated in the given | |
18785 | -- list of declarations, in order to perform elaboration checks on the | |
18786 | -- corresponding task procedures that are called implicitly here. | |
18787 | ||
18788 | function Outer_Unit (E : Entity_Id) return Entity_Id; | |
18789 | -- find enclosing compilation unit of Entity, ignoring subunits, or | |
18790 | -- else enclosing subprogram. If E is not a package, there is no need | |
18791 | -- for inter-unit elaboration checks. | |
18792 | ||
18793 | ------------------- | |
18794 | -- Add_Task_Proc -- | |
18795 | ------------------- | |
18796 | ||
18797 | procedure Add_Task_Proc (Typ : Entity_Id) is | |
18798 | Comp : Entity_Id; | |
18799 | Proc : Entity_Id := Empty; | |
18800 | ||
18801 | begin | |
18802 | if Is_Task_Type (Typ) then | |
18803 | Proc := Get_Task_Body_Procedure (Typ); | |
18804 | ||
18805 | elsif Is_Array_Type (Typ) | |
18806 | and then Has_Task (Base_Type (Typ)) | |
18807 | then | |
18808 | Add_Task_Proc (Component_Type (Typ)); | |
18809 | ||
18810 | elsif Is_Record_Type (Typ) | |
18811 | and then Has_Task (Base_Type (Typ)) | |
18812 | then | |
18813 | Comp := First_Component (Typ); | |
18814 | while Present (Comp) loop | |
18815 | Add_Task_Proc (Etype (Comp)); | |
18816 | Comp := Next_Component (Comp); | |
18817 | end loop; | |
18818 | end if; | |
18819 | ||
18820 | -- If the task type is another unit, we will perform the usual | |
18821 | -- elaboration check on its enclosing unit. If the type is in the | |
18822 | -- same unit, we can trace the task body as for an internal call, | |
18823 | -- but we only need to examine other external calls, because at | |
18824 | -- the point the task is activated, internal subprogram bodies | |
18825 | -- will have been elaborated already. We keep separate lists for | |
18826 | -- each kind of task. | |
18827 | ||
18828 | -- Skip this test if errors have occurred, since in this case | |
18829 | -- we can get false indications. | |
18830 | ||
18831 | if Serious_Errors_Detected /= 0 then | |
18832 | return; | |
18833 | end if; | |
18834 | ||
18835 | if Present (Proc) then | |
18836 | if Outer_Unit (Scope (Proc)) = Enclosing then | |
18837 | ||
18838 | if No (Corresponding_Body (Unit_Declaration_Node (Proc))) | |
18839 | and then | |
18840 | (not Is_Generic_Instance (Scope (Proc)) | |
18841 | or else Scope (Proc) = Scope (Defining_Identifier (Decl))) | |
18842 | then | |
18843 | Error_Msg_Warn := SPARK_Mode /= On; | |
18844 | Error_Msg_N | |
18845 | ("task will be activated before elaboration of its body<<", | |
18846 | Decl); | |
18847 | Error_Msg_N ("\Program_Error [<<", Decl); | |
18848 | ||
18849 | elsif Present | |
18850 | (Corresponding_Body (Unit_Declaration_Node (Proc))) | |
18851 | then | |
18852 | Append_Elmt (Proc, Intra_Procs); | |
18853 | end if; | |
18854 | ||
18855 | else | |
18856 | -- No need for multiple entries of the same type | |
18857 | ||
18858 | Elmt := First_Elmt (Inter_Procs); | |
18859 | while Present (Elmt) loop | |
18860 | if Node (Elmt) = Proc then | |
18861 | return; | |
18862 | end if; | |
18863 | ||
18864 | Next_Elmt (Elmt); | |
18865 | end loop; | |
18866 | ||
18867 | Append_Elmt (Proc, Inter_Procs); | |
18868 | end if; | |
18869 | end if; | |
18870 | end Add_Task_Proc; | |
18871 | ||
18872 | ------------------- | |
18873 | -- Collect_Tasks -- | |
18874 | ------------------- | |
18875 | ||
18876 | procedure Collect_Tasks (Decls : List_Id) is | |
18877 | begin | |
18878 | if Present (Decls) then | |
18879 | Decl := First (Decls); | |
18880 | while Present (Decl) loop | |
18881 | if Nkind (Decl) = N_Object_Declaration | |
18882 | and then Has_Task (Etype (Defining_Identifier (Decl))) | |
18883 | then | |
18884 | Add_Task_Proc (Etype (Defining_Identifier (Decl))); | |
18885 | end if; | |
18886 | ||
18887 | Next (Decl); | |
18888 | end loop; | |
18889 | end if; | |
18890 | end Collect_Tasks; | |
18891 | ||
18892 | ---------------- | |
18893 | -- Outer_Unit -- | |
18894 | ---------------- | |
18895 | ||
18896 | function Outer_Unit (E : Entity_Id) return Entity_Id is | |
18897 | Outer : Entity_Id; | |
18898 | ||
18899 | begin | |
18900 | Outer := E; | |
18901 | while Present (Outer) loop | |
18902 | if Elaboration_Checks_Suppressed (Outer) then | |
18903 | Cunit_SC := True; | |
18904 | end if; | |
18905 | ||
18906 | exit when Is_Child_Unit (Outer) | |
18907 | or else Scope (Outer) = Standard_Standard | |
18908 | or else Ekind (Outer) /= E_Package; | |
18909 | Outer := Scope (Outer); | |
18910 | end loop; | |
18911 | ||
18912 | return Outer; | |
18913 | end Outer_Unit; | |
18914 | ||
18915 | -- Start of processing for Check_Task_Activation | |
18916 | ||
18917 | begin | |
18918 | pragma Assert (Legacy_Elaboration_Checks); | |
18919 | ||
18920 | Enclosing := Outer_Unit (Current_Scope); | |
18921 | ||
18922 | -- Find all tasks declared in the current unit | |
18923 | ||
18924 | if Nkind (N) = N_Package_Body then | |
18925 | P := Unit_Declaration_Node (Corresponding_Spec (N)); | |
18926 | ||
18927 | Collect_Tasks (Declarations (N)); | |
18928 | Collect_Tasks (Visible_Declarations (Specification (P))); | |
18929 | Collect_Tasks (Private_Declarations (Specification (P))); | |
18930 | ||
18931 | elsif Nkind (N) = N_Package_Declaration then | |
18932 | Collect_Tasks (Visible_Declarations (Specification (N))); | |
18933 | Collect_Tasks (Private_Declarations (Specification (N))); | |
18934 | ||
18935 | else | |
18936 | Collect_Tasks (Declarations (N)); | |
18937 | end if; | |
18938 | ||
18939 | -- We only perform detailed checks in all tasks that are library level | |
18940 | -- entities. If the master is a subprogram or task, activation will | |
18941 | -- depend on the activation of the master itself. | |
18942 | ||
18943 | -- Should dynamic checks be added in the more general case??? | |
18944 | ||
18945 | if Ekind (Enclosing) /= E_Package then | |
18946 | return; | |
18947 | end if; | |
18948 | ||
18949 | -- For task types defined in other units, we want the unit containing | |
18950 | -- the task body to be elaborated before the current one. | |
18951 | ||
18952 | Elmt := First_Elmt (Inter_Procs); | |
18953 | while Present (Elmt) loop | |
18954 | Ent := Node (Elmt); | |
18955 | Task_Scope := Outer_Unit (Scope (Ent)); | |
18956 | ||
18957 | if not Is_Compilation_Unit (Task_Scope) then | |
18958 | null; | |
18959 | ||
18960 | elsif Suppress_Elaboration_Warnings (Task_Scope) | |
18961 | or else Elaboration_Checks_Suppressed (Task_Scope) | |
18962 | then | |
18963 | null; | |
18964 | ||
18965 | elsif Dynamic_Elaboration_Checks then | |
18966 | if not Elaboration_Checks_Suppressed (Ent) | |
18967 | and then not Cunit_SC | |
18968 | and then not Restriction_Active | |
18969 | (No_Entry_Calls_In_Elaboration_Code) | |
18970 | then | |
18971 | -- Runtime elaboration check required. Generate check of the | |
18972 | -- elaboration counter for the unit containing the entity. | |
18973 | ||
18974 | Insert_Elab_Check (N, | |
18975 | Make_Attribute_Reference (Loc, | |
18976 | Prefix => | |
18977 | New_Occurrence_Of (Spec_Entity (Task_Scope), Loc), | |
18978 | Attribute_Name => Name_Elaborated)); | |
18979 | end if; | |
18980 | ||
18981 | else | |
18982 | -- Force the binder to elaborate other unit first | |
18983 | ||
18984 | if Elab_Info_Messages | |
18985 | and then not Suppress_Elaboration_Warnings (Ent) | |
18986 | and then not Elaboration_Checks_Suppressed (Ent) | |
18987 | and then not Suppress_Elaboration_Warnings (Task_Scope) | |
18988 | and then not Elaboration_Checks_Suppressed (Task_Scope) | |
18989 | then | |
18990 | Error_Msg_Node_2 := Task_Scope; | |
18991 | Error_Msg_NE | |
18992 | ("info: activation of an instance of task type & requires " | |
18993 | & "pragma Elaborate_All on &?$?", N, Ent); | |
18994 | end if; | |
18995 | ||
18996 | Activate_Elaborate_All_Desirable (N, Task_Scope); | |
18997 | Set_Suppress_Elaboration_Warnings (Task_Scope); | |
18998 | end if; | |
18999 | ||
19000 | Next_Elmt (Elmt); | |
19001 | end loop; | |
19002 | ||
19003 | -- For tasks declared in the current unit, trace other calls within the | |
19004 | -- task procedure bodies, which are available. | |
19005 | ||
19006 | if not Debug_Flag_Dot_Y then | |
19007 | In_Task_Activation := True; | |
19008 | ||
19009 | Elmt := First_Elmt (Intra_Procs); | |
19010 | while Present (Elmt) loop | |
19011 | Ent := Node (Elmt); | |
19012 | Check_Internal_Call_Continue (N, Ent, Enclosing, Ent); | |
19013 | Next_Elmt (Elmt); | |
19014 | end loop; | |
19015 | ||
19016 | In_Task_Activation := False; | |
19017 | end if; | |
19018 | end Check_Task_Activation; | |
19019 | ||
19020 | ------------------------ | |
19021 | -- Get_Referenced_Ent -- | |
19022 | ------------------------ | |
19023 | ||
19024 | function Get_Referenced_Ent (N : Node_Id) return Entity_Id is | |
19025 | Nam : Node_Id; | |
19026 | ||
19027 | begin | |
19028 | if Nkind (N) in N_Has_Entity | |
19029 | and then Present (Entity (N)) | |
19030 | and then Ekind (Entity (N)) = E_Variable | |
19031 | then | |
19032 | return Entity (N); | |
19033 | end if; | |
19034 | ||
19035 | if Nkind (N) = N_Attribute_Reference then | |
19036 | Nam := Prefix (N); | |
19037 | else | |
19038 | Nam := Name (N); | |
19039 | end if; | |
19040 | ||
19041 | if No (Nam) then | |
19042 | return Empty; | |
19043 | elsif Nkind (Nam) = N_Selected_Component then | |
19044 | return Entity (Selector_Name (Nam)); | |
19045 | elsif not Is_Entity_Name (Nam) then | |
19046 | return Empty; | |
19047 | else | |
19048 | return Entity (Nam); | |
19049 | end if; | |
19050 | end Get_Referenced_Ent; | |
19051 | ||
19052 | ---------------------- | |
19053 | -- Has_Generic_Body -- | |
19054 | ---------------------- | |
19055 | ||
19056 | function Has_Generic_Body (N : Node_Id) return Boolean is | |
19057 | Ent : constant Entity_Id := Get_Generic_Entity (N); | |
19058 | Decl : constant Node_Id := Unit_Declaration_Node (Ent); | |
19059 | Scop : Entity_Id; | |
19060 | ||
19061 | function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id; | |
19062 | -- Determine if the list of nodes headed by N and linked by Next | |
19063 | -- contains a package body for the package spec entity E, and if so | |
19064 | -- return the package body. If not, then returns Empty. | |
19065 | ||
19066 | function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id; | |
19067 | -- This procedure is called load the unit whose name is given by Nam. | |
19068 | -- This unit is being loaded to see whether it contains an optional | |
19069 | -- generic body. The returned value is the loaded unit, which is always | |
19070 | -- a package body (only package bodies can contain other entities in the | |
19071 | -- sense in which Has_Generic_Body is interested). We only attempt to | |
19072 | -- load bodies if we are generating code. If we are in semantics check | |
19073 | -- only mode, then it would be wrong to load bodies that are not | |
19074 | -- required from a semantic point of view, so in this case we return | |
19075 | -- Empty. The result is that the caller may incorrectly decide that a | |
19076 | -- generic spec does not have a body when in fact it does, but the only | |
19077 | -- harm in this is that some warnings on elaboration problems may be | |
19078 | -- lost in semantic checks only mode, which is not big loss. We also | |
19079 | -- return Empty if we go for a body and it is not there. | |
19080 | ||
19081 | function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id; | |
19082 | -- PE is the entity for a package spec. This function locates the | |
19083 | -- corresponding package body, returning Empty if none is found. The | |
19084 | -- package body returned is fully parsed but may not yet be analyzed, | |
19085 | -- so only syntactic fields should be referenced. | |
19086 | ||
19087 | ------------------ | |
19088 | -- Find_Body_In -- | |
19089 | ------------------ | |
19090 | ||
19091 | function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is | |
19092 | Nod : Node_Id; | |
19093 | ||
19094 | begin | |
19095 | Nod := N; | |
19096 | while Present (Nod) loop | |
19097 | ||
19098 | -- If we found the package body we are looking for, return it | |
19099 | ||
19100 | if Nkind (Nod) = N_Package_Body | |
19101 | and then Chars (Defining_Unit_Name (Nod)) = Chars (E) | |
19102 | then | |
19103 | return Nod; | |
19104 | ||
19105 | -- If we found the stub for the body, go after the subunit, | |
19106 | -- loading it if necessary. | |
19107 | ||
19108 | elsif Nkind (Nod) = N_Package_Body_Stub | |
19109 | and then Chars (Defining_Identifier (Nod)) = Chars (E) | |
19110 | then | |
19111 | if Present (Library_Unit (Nod)) then | |
19112 | return Unit (Library_Unit (Nod)); | |
19113 | ||
19114 | else | |
19115 | return Load_Package_Body (Get_Unit_Name (Nod)); | |
19116 | end if; | |
19117 | ||
19118 | -- If neither package body nor stub, keep looking on chain | |
19119 | ||
19120 | else | |
19121 | Next (Nod); | |
19122 | end if; | |
19123 | end loop; | |
19124 | ||
19125 | return Empty; | |
19126 | end Find_Body_In; | |
19127 | ||
19128 | ----------------------- | |
19129 | -- Load_Package_Body -- | |
19130 | ----------------------- | |
19131 | ||
19132 | function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is | |
19133 | U : Unit_Number_Type; | |
19134 | ||
19135 | begin | |
19136 | if Operating_Mode /= Generate_Code then | |
19137 | return Empty; | |
19138 | else | |
19139 | U := | |
19140 | Load_Unit | |
19141 | (Load_Name => Nam, | |
19142 | Required => False, | |
19143 | Subunit => False, | |
19144 | Error_Node => N); | |
19145 | ||
19146 | if U = No_Unit then | |
19147 | return Empty; | |
19148 | else | |
19149 | return Unit (Cunit (U)); | |
19150 | end if; | |
19151 | end if; | |
19152 | end Load_Package_Body; | |
19153 | ||
19154 | ------------------------------- | |
19155 | -- Locate_Corresponding_Body -- | |
19156 | ------------------------------- | |
19157 | ||
19158 | function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is | |
19159 | Spec : constant Node_Id := Declaration_Node (PE); | |
19160 | Decl : constant Node_Id := Parent (Spec); | |
19161 | Scop : constant Entity_Id := Scope (PE); | |
19162 | PBody : Node_Id; | |
19163 | ||
19164 | begin | |
19165 | if Is_Library_Level_Entity (PE) then | |
19166 | ||
19167 | -- If package is a library unit that requires a body, we have no | |
19168 | -- choice but to go after that body because it might contain an | |
19169 | -- optional body for the original generic package. | |
19170 | ||
19171 | if Unit_Requires_Body (PE) then | |
19172 | ||
19173 | -- Load the body. Note that we are a little careful here to use | |
19174 | -- Spec to get the unit number, rather than PE or Decl, since | |
19175 | -- in the case where the package is itself a library level | |
19176 | -- instantiation, Spec will properly reference the generic | |
19177 | -- template, which is what we really want. | |
19178 | ||
19179 | return | |
19180 | Load_Package_Body | |
19181 | (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec)))); | |
19182 | ||
19183 | -- But if the package is a library unit that does NOT require | |
19184 | -- a body, then no body is permitted, so we are sure that there | |
19185 | -- is no body for the original generic package. | |
19186 | ||
19187 | else | |
19188 | return Empty; | |
19189 | end if; | |
19190 | ||
19191 | -- Otherwise look and see if we are embedded in a further package | |
19192 | ||
19193 | elsif Is_Package_Or_Generic_Package (Scop) then | |
19194 | ||
19195 | -- If so, get the body of the enclosing package, and look in | |
19196 | -- its package body for the package body we are looking for. | |
19197 | ||
19198 | PBody := Locate_Corresponding_Body (Scop); | |
19199 | ||
19200 | if No (PBody) then | |
19201 | return Empty; | |
19202 | else | |
19203 | return Find_Body_In (PE, First (Declarations (PBody))); | |
19204 | end if; | |
19205 | ||
19206 | -- If we are not embedded in a further package, then the body | |
19207 | -- must be in the same declarative part as we are. | |
19208 | ||
19209 | else | |
19210 | return Find_Body_In (PE, Next (Decl)); | |
19211 | end if; | |
19212 | end Locate_Corresponding_Body; | |
19213 | ||
19214 | -- Start of processing for Has_Generic_Body | |
19215 | ||
19216 | begin | |
19217 | if Present (Corresponding_Body (Decl)) then | |
19218 | return True; | |
19219 | ||
19220 | elsif Unit_Requires_Body (Ent) then | |
19221 | return True; | |
19222 | ||
19223 | -- Compilation units cannot have optional bodies | |
19224 | ||
19225 | elsif Is_Compilation_Unit (Ent) then | |
19226 | return False; | |
19227 | ||
19228 | -- Otherwise look at what scope we are in | |
19229 | ||
19230 | else | |
19231 | Scop := Scope (Ent); | |
19232 | ||
19233 | -- Case of entity is in other than a package spec, in this case | |
19234 | -- the body, if present, must be in the same declarative part. | |
19235 | ||
19236 | if not Is_Package_Or_Generic_Package (Scop) then | |
19237 | declare | |
19238 | P : Node_Id; | |
19239 | ||
19240 | begin | |
19241 | -- Declaration node may get us a spec, so if so, go to | |
19242 | -- the parent declaration. | |
19243 | ||
19244 | P := Declaration_Node (Ent); | |
19245 | while not Is_List_Member (P) loop | |
19246 | P := Parent (P); | |
19247 | end loop; | |
19248 | ||
19249 | return Present (Find_Body_In (Ent, Next (P))); | |
19250 | end; | |
19251 | ||
19252 | -- If the entity is in a package spec, then we have to locate | |
19253 | -- the corresponding package body, and look there. | |
19254 | ||
19255 | else | |
19256 | declare | |
19257 | PBody : constant Node_Id := Locate_Corresponding_Body (Scop); | |
19258 | ||
19259 | begin | |
19260 | if No (PBody) then | |
19261 | return False; | |
19262 | else | |
19263 | return | |
19264 | Present | |
19265 | (Find_Body_In (Ent, (First (Declarations (PBody))))); | |
19266 | end if; | |
19267 | end; | |
19268 | end if; | |
19269 | end if; | |
19270 | end Has_Generic_Body; | |
19271 | ||
19272 | ----------------------- | |
19273 | -- Insert_Elab_Check -- | |
19274 | ----------------------- | |
19275 | ||
19276 | procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is | |
19277 | Nod : Node_Id; | |
19278 | Loc : constant Source_Ptr := Sloc (N); | |
19279 | ||
19280 | Chk : Node_Id; | |
19281 | -- The check (N_Raise_Program_Error) node to be inserted | |
19282 | ||
19283 | begin | |
19284 | -- If expansion is disabled, do not generate any checks. Also | |
19285 | -- skip checks if any subunits are missing because in either | |
19286 | -- case we lack the full information that we need, and no object | |
19287 | -- file will be created in any case. | |
19288 | ||
19289 | if not Expander_Active or else Subunits_Missing then | |
19290 | return; | |
19291 | end if; | |
19292 | ||
19293 | -- If we have a generic instantiation, where Instance_Spec is set, | |
19294 | -- then this field points to a generic instance spec that has | |
19295 | -- been inserted before the instantiation node itself, so that | |
19296 | -- is where we want to insert a check. | |
19297 | ||
19298 | if Nkind (N) in N_Generic_Instantiation | |
19299 | and then Present (Instance_Spec (N)) | |
19300 | then | |
19301 | Nod := Instance_Spec (N); | |
19302 | else | |
19303 | Nod := N; | |
19304 | end if; | |
19305 | ||
19306 | -- Build check node, possibly with condition | |
19307 | ||
19308 | Chk := | |
19309 | Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration); | |
19310 | ||
19311 | if Present (C) then | |
19312 | Set_Condition (Chk, Make_Op_Not (Loc, Right_Opnd => C)); | |
19313 | end if; | |
19314 | ||
19315 | -- If we are inserting at the top level, insert in Aux_Decls | |
19316 | ||
19317 | if Nkind (Parent (Nod)) = N_Compilation_Unit then | |
19318 | declare | |
19319 | ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod)); | |
19320 | ||
19321 | begin | |
19322 | if No (Declarations (ADN)) then | |
19323 | Set_Declarations (ADN, New_List (Chk)); | |
19324 | else | |
19325 | Append_To (Declarations (ADN), Chk); | |
19326 | end if; | |
19327 | ||
19328 | Analyze (Chk); | |
19329 | end; | |
19330 | ||
19331 | -- Otherwise just insert as an action on the node in question | |
19332 | ||
19333 | else | |
19334 | Insert_Action (Nod, Chk); | |
19335 | end if; | |
19336 | end Insert_Elab_Check; | |
19337 | ||
19338 | ------------------------------- | |
19339 | -- Is_Call_Of_Generic_Formal -- | |
19340 | ------------------------------- | |
19341 | ||
19342 | function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean is | |
19343 | begin | |
19344 | return Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) | |
19345 | ||
19346 | -- Always return False if debug flag -gnatd.G is set | |
19347 | ||
19348 | and then not Debug_Flag_Dot_GG | |
19349 | ||
19350 | -- For now, we detect this by looking for the strange identifier | |
19351 | -- node, whose Chars reflect the name of the generic formal, but | |
19352 | -- the Chars of the Entity references the generic actual. | |
19353 | ||
19354 | and then Nkind (Name (N)) = N_Identifier | |
19355 | and then Chars (Name (N)) /= Chars (Entity (Name (N))); | |
19356 | end Is_Call_Of_Generic_Formal; | |
19357 | ||
19358 | ------------------------------- | |
19359 | -- Is_Finalization_Procedure -- | |
19360 | ------------------------------- | |
19361 | ||
19362 | function Is_Finalization_Procedure (Id : Entity_Id) return Boolean is | |
19363 | begin | |
19364 | -- Check whether Id is a procedure with at least one parameter | |
19365 | ||
19366 | if Ekind (Id) = E_Procedure and then Present (First_Formal (Id)) then | |
19367 | declare | |
19368 | Typ : constant Entity_Id := Etype (First_Formal (Id)); | |
19369 | Deep_Fin : Entity_Id := Empty; | |
19370 | Fin : Entity_Id := Empty; | |
19371 | ||
19372 | begin | |
19373 | -- If the type of the first formal does not require finalization | |
19374 | -- actions, then this is definitely not [Deep_]Finalize. | |
19375 | ||
19376 | if not Needs_Finalization (Typ) then | |
19377 | return False; | |
19378 | end if; | |
19379 | ||
19380 | -- At this point we have the following scenario: | |
19381 | ||
19382 | -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]); | |
19383 | ||
19384 | -- Recover the two possible versions of [Deep_]Finalize using the | |
19385 | -- type of the first parameter and compare with the input. | |
19386 | ||
19387 | Deep_Fin := TSS (Typ, TSS_Deep_Finalize); | |
19388 | ||
19389 | if Is_Controlled (Typ) then | |
19390 | Fin := Find_Prim_Op (Typ, Name_Finalize); | |
19391 | end if; | |
19392 | ||
19393 | return (Present (Deep_Fin) and then Id = Deep_Fin) | |
19394 | or else (Present (Fin) and then Id = Fin); | |
19395 | end; | |
19396 | end if; | |
19397 | ||
19398 | return False; | |
19399 | end Is_Finalization_Procedure; | |
19400 | ||
19401 | ------------------ | |
19402 | -- Output_Calls -- | |
19403 | ------------------ | |
19404 | ||
19405 | procedure Output_Calls | |
19406 | (N : Node_Id; | |
19407 | Check_Elab_Flag : Boolean) | |
19408 | is | |
19409 | function Emit (Flag : Boolean) return Boolean; | |
19410 | -- Determine whether to emit an error message based on the combination | |
19411 | -- of flags Check_Elab_Flag and Flag. | |
19412 | ||
19413 | function Is_Printable_Error_Name return Boolean; | |
19414 | -- An internal function, used to determine if a name, stored in the | |
19415 | -- Name_Buffer, is either a non-internal name, or is an internal name | |
19416 | -- that is printable by the error message circuits (i.e. it has a single | |
19417 | -- upper case letter at the end). | |
19418 | ||
19419 | ---------- | |
19420 | -- Emit -- | |
19421 | ---------- | |
19422 | ||
19423 | function Emit (Flag : Boolean) return Boolean is | |
19424 | begin | |
19425 | if Check_Elab_Flag then | |
19426 | return Flag; | |
19427 | else | |
19428 | return True; | |
19429 | end if; | |
19430 | end Emit; | |
19431 | ||
19432 | ----------------------------- | |
19433 | -- Is_Printable_Error_Name -- | |
19434 | ----------------------------- | |
19435 | ||
19436 | function Is_Printable_Error_Name return Boolean is | |
19437 | begin | |
19438 | if not Is_Internal_Name then | |
19439 | return True; | |
19440 | ||
19441 | elsif Name_Len = 1 then | |
19442 | return False; | |
19443 | ||
19444 | else | |
19445 | Name_Len := Name_Len - 1; | |
19446 | return not Is_Internal_Name; | |
19447 | end if; | |
19448 | end Is_Printable_Error_Name; | |
19449 | ||
19450 | -- Local variables | |
19451 | ||
19452 | Ent : Entity_Id; | |
19453 | ||
19454 | -- Start of processing for Output_Calls | |
19455 | ||
19456 | begin | |
19457 | for J in reverse 1 .. Elab_Call.Last loop | |
19458 | Error_Msg_Sloc := Elab_Call.Table (J).Cloc; | |
19459 | ||
19460 | Ent := Elab_Call.Table (J).Ent; | |
19461 | Get_Name_String (Chars (Ent)); | |
19462 | ||
19463 | -- Dynamic elaboration model, warnings controlled by -gnatwl | |
19464 | ||
19465 | if Dynamic_Elaboration_Checks then | |
19466 | if Emit (Elab_Warnings) then | |
19467 | if Is_Generic_Unit (Ent) then | |
19468 | Error_Msg_NE ("\\?l?& instantiated #", N, Ent); | |
19469 | elsif Is_Init_Proc (Ent) then | |
19470 | Error_Msg_N ("\\?l?initialization procedure called #", N); | |
19471 | elsif Is_Printable_Error_Name then | |
19472 | Error_Msg_NE ("\\?l?& called #", N, Ent); | |
19473 | else | |
19474 | Error_Msg_N ("\\?l?called #", N); | |
19475 | end if; | |
19476 | end if; | |
19477 | ||
19478 | -- Static elaboration model, info messages controlled by -gnatel | |
19479 | ||
19480 | else | |
19481 | if Emit (Elab_Info_Messages) then | |
19482 | if Is_Generic_Unit (Ent) then | |
19483 | Error_Msg_NE ("\\?$?& instantiated #", N, Ent); | |
19484 | elsif Is_Init_Proc (Ent) then | |
19485 | Error_Msg_N ("\\?$?initialization procedure called #", N); | |
19486 | elsif Is_Printable_Error_Name then | |
19487 | Error_Msg_NE ("\\?$?& called #", N, Ent); | |
19488 | else | |
19489 | Error_Msg_N ("\\?$?called #", N); | |
19490 | end if; | |
19491 | end if; | |
19492 | end if; | |
19493 | end loop; | |
19494 | end Output_Calls; | |
19495 | ||
19496 | ---------------------------- | |
19497 | -- Same_Elaboration_Scope -- | |
19498 | ---------------------------- | |
19499 | ||
19500 | function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is | |
19501 | S1 : Entity_Id; | |
19502 | S2 : Entity_Id; | |
19503 | ||
19504 | begin | |
19505 | -- Find elaboration scope for Scop1 | |
19506 | -- This is either a subprogram or a compilation unit. | |
19507 | ||
19508 | S1 := Scop1; | |
19509 | while S1 /= Standard_Standard | |
19510 | and then not Is_Compilation_Unit (S1) | |
19511 | and then Ekind_In (S1, E_Package, E_Protected_Type, E_Block) | |
19512 | loop | |
19513 | S1 := Scope (S1); | |
19514 | end loop; | |
19515 | ||
19516 | -- Find elaboration scope for Scop2 | |
19517 | ||
19518 | S2 := Scop2; | |
19519 | while S2 /= Standard_Standard | |
19520 | and then not Is_Compilation_Unit (S2) | |
19521 | and then Ekind_In (S2, E_Package, E_Protected_Type, E_Block) | |
19522 | loop | |
19523 | S2 := Scope (S2); | |
19524 | end loop; | |
19525 | ||
19526 | return S1 = S2; | |
19527 | end Same_Elaboration_Scope; | |
19528 | ||
19529 | ----------------- | |
19530 | -- Set_C_Scope -- | |
19531 | ----------------- | |
19532 | ||
19533 | procedure Set_C_Scope is | |
19534 | begin | |
19535 | while not Is_Compilation_Unit (C_Scope) loop | |
19536 | C_Scope := Scope (C_Scope); | |
19537 | end loop; | |
19538 | end Set_C_Scope; | |
19539 | ||
19540 | -------------------------------- | |
19541 | -- Set_Elaboration_Constraint -- | |
19542 | -------------------------------- | |
19543 | ||
19544 | procedure Set_Elaboration_Constraint | |
19545 | (Call : Node_Id; | |
19546 | Subp : Entity_Id; | |
19547 | Scop : Entity_Id) | |
19548 | is | |
19549 | Elab_Unit : Entity_Id; | |
19550 | ||
19551 | -- Check whether this is a call to an Initialize subprogram for a | |
19552 | -- controlled type. Note that Call can also be a 'Access attribute | |
19553 | -- reference, which now generates an elaboration check. | |
19554 | ||
19555 | Init_Call : constant Boolean := | |
19556 | Nkind (Call) = N_Procedure_Call_Statement | |
19557 | and then Chars (Subp) = Name_Initialize | |
19558 | and then Comes_From_Source (Subp) | |
19559 | and then Present (Parameter_Associations (Call)) | |
19560 | and then Is_Controlled (Etype (First_Actual (Call))); | |
19561 | ||
19562 | begin | |
19563 | -- If the unit is mentioned in a with_clause of the current unit, it is | |
19564 | -- visible, and we can set the elaboration flag. | |
19565 | ||
19566 | if Is_Immediately_Visible (Scop) | |
19567 | or else (Is_Child_Unit (Scop) and then Is_Visible_Lib_Unit (Scop)) | |
19568 | then | |
19569 | Activate_Elaborate_All_Desirable (Call, Scop); | |
19570 | Set_Suppress_Elaboration_Warnings (Scop); | |
19571 | return; | |
19572 | end if; | |
19573 | ||
19574 | -- If this is not an initialization call or a call using object notation | |
19575 | -- we know that the unit of the called entity is in the context, and we | |
19576 | -- can set the flag as well. The unit need not be visible if the call | |
19577 | -- occurs within an instantiation. | |
19578 | ||
19579 | if Is_Init_Proc (Subp) | |
19580 | or else Init_Call | |
19581 | or else Nkind (Original_Node (Call)) = N_Selected_Component | |
19582 | then | |
19583 | null; -- detailed processing follows. | |
19584 | ||
19585 | else | |
19586 | Activate_Elaborate_All_Desirable (Call, Scop); | |
19587 | Set_Suppress_Elaboration_Warnings (Scop); | |
19588 | return; | |
19589 | end if; | |
19590 | ||
19591 | -- If the unit is not in the context, there must be an intermediate unit | |
19592 | -- that is, on which we need to place to elaboration flag. This happens | |
19593 | -- with init proc calls. | |
19594 | ||
19595 | if Is_Init_Proc (Subp) or else Init_Call then | |
19596 | ||
19597 | -- The initialization call is on an object whose type is not declared | |
19598 | -- in the same scope as the subprogram. The type of the object must | |
19599 | -- be a subtype of the type of operation. This object is the first | |
19600 | -- actual in the call. | |
19601 | ||
19602 | declare | |
19603 | Typ : constant Entity_Id := | |
19604 | Etype (First (Parameter_Associations (Call))); | |
19605 | begin | |
19606 | Elab_Unit := Scope (Typ); | |
19607 | while (Present (Elab_Unit)) | |
19608 | and then not Is_Compilation_Unit (Elab_Unit) | |
19609 | loop | |
19610 | Elab_Unit := Scope (Elab_Unit); | |
19611 | end loop; | |
19612 | end; | |
19613 | ||
19614 | -- If original node uses selected component notation, the prefix is | |
19615 | -- visible and determines the scope that must be elaborated. After | |
19616 | -- rewriting, the prefix is the first actual in the call. | |
19617 | ||
19618 | elsif Nkind (Original_Node (Call)) = N_Selected_Component then | |
19619 | Elab_Unit := Scope (Etype (First (Parameter_Associations (Call)))); | |
19620 | ||
19621 | -- Not one of special cases above | |
19622 | ||
19623 | else | |
19624 | -- Using previously computed scope. If the elaboration check is | |
19625 | -- done after analysis, the scope is not visible any longer, but | |
19626 | -- must still be in the context. | |
19627 | ||
19628 | Elab_Unit := Scop; | |
19629 | end if; | |
19630 | ||
19631 | Activate_Elaborate_All_Desirable (Call, Elab_Unit); | |
19632 | Set_Suppress_Elaboration_Warnings (Elab_Unit); | |
19633 | end Set_Elaboration_Constraint; | |
19634 | ||
19635 | ----------------- | |
19636 | -- Spec_Entity -- | |
19637 | ----------------- | |
19638 | ||
19639 | function Spec_Entity (E : Entity_Id) return Entity_Id is | |
19640 | Decl : Node_Id; | |
19641 | ||
19642 | begin | |
19643 | -- Check for case of body entity | |
19644 | -- Why is the check for E_Void needed??? | |
19645 | ||
19646 | if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then | |
19647 | Decl := E; | |
19648 | ||
19649 | loop | |
19650 | Decl := Parent (Decl); | |
19651 | exit when Nkind (Decl) in N_Proper_Body; | |
19652 | end loop; | |
19653 | ||
19654 | return Corresponding_Spec (Decl); | |
19655 | ||
19656 | else | |
19657 | return E; | |
19658 | end if; | |
19659 | end Spec_Entity; | |
19660 | ||
19661 | ------------ | |
19662 | -- Within -- | |
19663 | ------------ | |
19664 | ||
19665 | function Within (E1, E2 : Entity_Id) return Boolean is | |
19666 | Scop : Entity_Id; | |
19667 | begin | |
19668 | Scop := E1; | |
19669 | loop | |
19670 | if Scop = E2 then | |
19671 | return True; | |
19672 | elsif Scop = Standard_Standard then | |
19673 | return False; | |
19674 | else | |
19675 | Scop := Scope (Scop); | |
19676 | end if; | |
19677 | end loop; | |
19678 | end Within; | |
19679 | ||
19680 | -------------------------- | |
19681 | -- Within_Elaborate_All -- | |
19682 | -------------------------- | |
19683 | ||
19684 | function Within_Elaborate_All | |
19685 | (Unit : Unit_Number_Type; | |
19686 | E : Entity_Id) return Boolean | |
19687 | is | |
19688 | type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean; | |
19689 | pragma Pack (Unit_Number_Set); | |
19690 | ||
19691 | Seen : Unit_Number_Set := (others => False); | |
19692 | -- Seen (X) is True after we have seen unit X in the walk. This is used | |
19693 | -- to prevent processing the same unit more than once. | |
19694 | ||
19695 | Result : Boolean := False; | |
19696 | ||
19697 | procedure Helper (Unit : Unit_Number_Type); | |
19698 | -- This helper procedure does all the work for Within_Elaborate_All. It | |
19699 | -- walks the dependency graph, and sets Result to True if it finds an | |
19700 | -- appropriate Elaborate_All. | |
19701 | ||
19702 | ------------ | |
19703 | -- Helper -- | |
19704 | ------------ | |
19705 | ||
19706 | procedure Helper (Unit : Unit_Number_Type) is | |
19707 | CU : constant Node_Id := Cunit (Unit); | |
19708 | ||
19709 | Item : Node_Id; | |
19710 | Item2 : Node_Id; | |
19711 | Elab_Id : Entity_Id; | |
19712 | Par : Node_Id; | |
19713 | ||
19714 | begin | |
19715 | if Seen (Unit) then | |
19716 | return; | |
19717 | else | |
19718 | Seen (Unit) := True; | |
19719 | end if; | |
19720 | ||
19721 | -- First, check for Elaborate_Alls on this unit | |
19722 | ||
19723 | Item := First (Context_Items (CU)); | |
19724 | while Present (Item) loop | |
19725 | if Nkind (Item) = N_Pragma | |
19726 | and then Pragma_Name (Item) = Name_Elaborate_All | |
19727 | then | |
19728 | -- Return if some previous error on the pragma itself. The | |
19729 | -- pragma may be unanalyzed, because of a previous error, or | |
19730 | -- if it is the context of a subunit, inherited by its parent. | |
19731 | ||
19732 | if Error_Posted (Item) or else not Analyzed (Item) then | |
19733 | return; | |
19734 | end if; | |
19735 | ||
19736 | Elab_Id := | |
19737 | Entity | |
19738 | (Expression (First (Pragma_Argument_Associations (Item)))); | |
19739 | ||
19740 | if E = Elab_Id then | |
19741 | Result := True; | |
19742 | return; | |
19743 | end if; | |
19744 | ||
19745 | Par := Parent (Unit_Declaration_Node (Elab_Id)); | |
19746 | ||
19747 | Item2 := First (Context_Items (Par)); | |
19748 | while Present (Item2) loop | |
19749 | if Nkind (Item2) = N_With_Clause | |
19750 | and then Entity (Name (Item2)) = E | |
19751 | and then not Limited_Present (Item2) | |
19752 | then | |
19753 | Result := True; | |
19754 | return; | |
19755 | end if; | |
19756 | ||
19757 | Next (Item2); | |
19758 | end loop; | |
19759 | end if; | |
19760 | ||
19761 | Next (Item); | |
19762 | end loop; | |
19763 | ||
19764 | -- Second, recurse on with's. We could do this as part of the above | |
19765 | -- loop, but it's probably more efficient to have two loops, because | |
19766 | -- the relevant Elaborate_All is likely to be on the initial unit. In | |
19767 | -- other words, we're walking the with's breadth-first. This part is | |
19768 | -- only necessary in the dynamic elaboration model. | |
19769 | ||
19770 | if Dynamic_Elaboration_Checks then | |
19771 | Item := First (Context_Items (CU)); | |
19772 | while Present (Item) loop | |
19773 | if Nkind (Item) = N_With_Clause | |
19774 | and then not Limited_Present (Item) | |
19775 | then | |
19776 | -- Note: the following call to Get_Cunit_Unit_Number does a | |
19777 | -- linear search, which could be slow, but it's OK because | |
19778 | -- we're about to give a warning anyway. Also, there might | |
19779 | -- be hundreds of units, but not millions. If it turns out | |
19780 | -- to be a problem, we could store the Get_Cunit_Unit_Number | |
19781 | -- in each N_Compilation_Unit node, but that would involve | |
19782 | -- rearranging N_Compilation_Unit_Aux to make room. | |
19783 | ||
19784 | Helper (Get_Cunit_Unit_Number (Library_Unit (Item))); | |
19785 | ||
19786 | if Result then | |
19787 | return; | |
19788 | end if; | |
19789 | end if; | |
19790 | ||
19791 | Next (Item); | |
19792 | end loop; | |
19793 | end if; | |
19794 | end Helper; | |
19795 | ||
19796 | -- Start of processing for Within_Elaborate_All | |
19797 | ||
19798 | begin | |
19799 | Helper (Unit); | |
19800 | return Result; | |
19801 | end Within_Elaborate_All; | |
19802 | ||
996ae0b0 | 19803 | end Sem_Elab; |