1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1997-2018, Free Software Foundation, Inc. --
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- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
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 --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Exp_Ch11
; use Exp_Ch11
;
33 with Exp_Tss
; use Exp_Tss
;
34 with Exp_Util
; use Exp_Util
;
35 with Expander
; use Expander
;
37 with Lib
.Load
; use Lib
.Load
;
38 with Namet
; use Namet
;
39 with Nlists
; use Nlists
;
40 with Nmake
; use Nmake
;
42 with Output
; use Output
;
43 with Restrict
; use Restrict
;
44 with Rident
; use Rident
;
45 with Rtsfind
; use Rtsfind
;
47 with Sem_Aux
; use Sem_Aux
;
48 with Sem_Cat
; use Sem_Cat
;
49 with Sem_Ch7
; use Sem_Ch7
;
50 with Sem_Ch8
; use Sem_Ch8
;
51 with Sem_Prag
; use Sem_Prag
;
52 with Sem_Util
; use Sem_Util
;
53 with Sinfo
; use Sinfo
;
54 with Sinput
; use Sinput
;
55 with Snames
; use Snames
;
56 with Stand
; use Stand
;
58 with Tbuild
; use Tbuild
;
59 with Uintp
; use Uintp
;
60 with Uname
; use Uname
;
62 with GNAT
.HTable
; use GNAT
.HTable
;
64 package body Sem_Elab
is
66 -----------------------------------------
67 -- Access-before-elaboration mechanism --
68 -----------------------------------------
70 -- The access-before-elaboration (ABE) mechanism implemented in this unit
71 -- has the following objectives:
73 -- * Diagnose at compile-time or install run-time checks to prevent ABE
74 -- access to data and behaviour.
76 -- The high-level idea is to accurately diagnose ABE issues within a
77 -- single unit because the ABE mechanism can inspect the whole unit.
78 -- As soon as the elaboration graph extends to an external unit, the
79 -- diagnostics stop because the body of the unit may not be available.
80 -- Due to control and data flow, the ABE mechanism cannot accurately
81 -- determine whether a particular scenario will be elaborated or not.
82 -- Conditional ABE checks are therefore used to verify the elaboration
83 -- status of a local and external target at run time.
85 -- * Supply elaboration dependencies for a unit to binde
87 -- The ABE mechanism registers each outgoing elaboration edge for the
88 -- main unit in its ALI file. GNATbind and binde can then reconstruct
89 -- the full elaboration graph and determine the proper elaboration
90 -- order for all units in the compilation.
92 -- The ABE mechanism supports three models of elaboration:
94 -- * Dynamic model - This is the most permissive of the three models.
95 -- When the dynamic model is in effect, the mechanism performs very
96 -- little diagnostics and generates run-time checks to detect ABE
97 -- issues. The behaviour of this model is identical to that specified
98 -- by the Ada RM. This model is enabled with switch -gnatE.
100 -- * Static model - This is the middle ground of the three models. When
101 -- the static model is in effect, the mechanism diagnoses and installs
102 -- run-time checks to detect ABE issues in the main unit. In addition,
103 -- the mechanism generates implicit Elaborate or Elaborate_All pragmas
104 -- to ensure the prior elaboration of withed units. The model employs
105 -- textual order, with clause context, and elaboration-related source
106 -- pragmas. This is the default model.
108 -- * SPARK model - This is the most conservative of the three models and
109 -- impelements the semantics defined in SPARK RM 7.7. The SPARK model
110 -- is in effect only when a context resides in a SPARK_Mode On region,
111 -- otherwise the mechanism falls back to one of the previous models.
113 -- The ABE mechanism consists of a "recording" phase and a "processing"
120 -- * ABE - An attempt to activate, call, or instantiate a scenario which
121 -- has not been fully elaborated.
123 -- * Bridge target - A type of target. A bridge target is a link between
124 -- scenarios. It is usually a byproduct of expansion and does not have
125 -- any direct ABE ramifications.
127 -- * Call marker - A special node used to indicate the presence of a call
128 -- in the tree in case expansion transforms or eliminates the original
129 -- call. N_Call_Marker nodes do not have static and run-time semantics.
131 -- * Conditional ABE - A type of ABE. A conditional ABE occurs when the
132 -- elaboration or invocation of a target by a scenario within the main
133 -- unit causes an ABE, but does not cause an ABE for another scenarios
134 -- within the main unit.
136 -- * Declaration level - A type of enclosing level. A scenario or target is
137 -- at the declaration level when it appears within the declarations of a
138 -- block statement, entry body, subprogram body, or task body, ignoring
139 -- enclosing packages.
141 -- * Early call region - A section of code which ends at a subprogram body
142 -- and starts from the nearest non-preelaborable construct which precedes
143 -- the subprogram body. The early call region extends from a package body
144 -- to a package spec when the spec carries pragma Elaborate_Body.
146 -- * Generic library level - A type of enclosing level. A scenario or
147 -- target is at the generic library level if it appears in a generic
148 -- package library unit, ignoring enclosing packages.
150 -- * Guaranteed ABE - A type of ABE. A guaranteed ABE occurs when the
151 -- elaboration or invocation of a target by all scenarios within the
152 -- main unit causes an ABE.
154 -- * Instantiation library level - A type of enclosing level. A scenario
155 -- or target is at the instantiation library level if it appears in an
156 -- instantiation library unit, ignoring enclosing packages.
158 -- * Library level - A type of enclosing level. A scenario or target is at
159 -- the library level if it appears in a package library unit, ignoring
160 -- enclosng packages.
162 -- * Non-library-level encapsulator - A construct that cannot be elaborated
163 -- on its own and requires elaboration by a top-level scenario.
165 -- * Scenario - A construct or context which may be elaborated or executed
166 -- by elaboration code. The scenarios recognized by the ABE mechanism are
169 -- - '[Unrestricted_]Access of entries, operators, and subprograms
171 -- - Assignments to variables
173 -- - Calls to entries, operators, and subprograms
175 -- - Derived type declarations
179 -- - Pragma Refined_State
181 -- - Reads of variables
185 -- * Target - A construct referenced by a scenario. The targets recognized
186 -- by the ABE mechanism are as follows:
188 -- - For '[Unrestricted_]Access of entries, operators, and subprograms,
189 -- the target is the entry, operator, or subprogram.
191 -- - For assignments to variables, the target is the variable
193 -- - For calls, the target is the entry, operator, or subprogram
195 -- - For derived type declarations, the target is the derived type
197 -- - For instantiations, the target is the generic template
199 -- - For pragma Refined_State, the targets are the constituents
201 -- - For reads of variables, the target is the variable
203 -- - For task activation, the target is the task body
205 -- * Top-level scenario - A scenario which appears in a non-generic main
206 -- unit. Depending on the elaboration model is in effect, the following
207 -- addotional restrictions apply:
209 -- - Dynamic model - No restrictions
211 -- - SPARK model - Falls back to either the dynamic or static model
213 -- - Static model - The scenario must be at the library level
215 ---------------------
216 -- Recording phase --
217 ---------------------
219 -- The Recording phase coincides with the analysis/resolution phase of the
220 -- compiler. It has the following objectives:
222 -- * Record all top-level scenarios for examination by the Processing
225 -- Saving only a certain number of nodes improves the performance of
226 -- the ABE mechanism. This eliminates the need to examine the whole
227 -- tree in a separate pass.
229 -- * Record certain SPARK scenarios which are not necessarily executable
230 -- during elaboration, but still require elaboration-related checks.
232 -- Saving only a certain number of nodes improves the performance of
233 -- the ABE mechanism. This eliminates the need to examine the whole
234 -- tree in a separate pass.
236 -- * Detect and diagnose calls in preelaborable or pure units, including
239 -- This diagnostic is carried out during the Recording phase because it
240 -- does not need the heavy recursive traversal done by the Processing
243 -- * Detect and diagnose guaranteed ABEs caused by instantiations,
244 -- calls, and task activation.
246 -- The issues detected by the ABE mechanism are reported as warnings
247 -- because they do not violate Ada semantics. Forward instantiations
248 -- may thus reach gigi, however gigi cannot handle certain kinds of
249 -- premature instantiations and may crash. To avoid this limitation,
250 -- the ABE mechanism must identify forward instantiations as early as
251 -- possible and suppress their bodies. Calls and task activations are
252 -- included in this category for completeness.
254 ----------------------
255 -- Processing phase --
256 ----------------------
258 -- The Processing phase is a separate pass which starts after instantiating
259 -- and/or inlining of bodies, but before the removal of Ghost code. It has
260 -- the following objectives:
262 -- * Examine all top-level scenarios saved during the Recording phase
264 -- The top-level scenarios act as roots for depth-first traversal of
265 -- the call/instantiation/task activation graph. The traversal stops
266 -- when an outgoing edge leaves the main unit.
268 -- * Examine all SPARK scenarios saved during the Recording phase
270 -- * Depending on the elaboration model in effect, perform the following
273 -- - Dynamic model - Install run-time conditional ABE checks.
275 -- - SPARK model - Enforce the SPARK elaboration rules
277 -- - Static model - Diagnose conditional ABEs, install run-time
278 -- conditional ABE checks, and guarantee the elaboration of
281 -- * Examine nested scenarios
283 -- Nested scenarios discovered during the depth-first traversal are
284 -- in turn subjected to the same actions outlined above and examined
285 -- for the next level of nested scenarios.
291 -- Analysis/Resolution
293 -- +- Build_Call_Marker
295 -- +- Build_Variable_Reference_Marker
297 -- +- | -------------------- Recording phase ---------------------------+
299 -- | Record_Elaboration_Scenario |
301 -- | +--> Check_Preelaborated_Call |
303 -- | +--> Process_Guaranteed_ABE |
305 -- | | +--> Process_Guaranteed_ABE_Activation |
307 -- | | +--> Process_Guaranteed_ABE_Call |
309 -- | | +--> Process_Guaranteed_ABE_Instantiation |
311 -- +- | ----------------------------------------------------------------+
314 -- +--> SPARK_Scenarios
315 -- | +-----------+-----------+ .. +-----------+
316 -- | | Scenario1 | Scenario2 | .. | ScenarioN |
317 -- | +-----------+-----------+ .. +-----------+
319 -- +--> Top_Level_Scenarios
320 -- | +-----------+-----------+ .. +-----------+
321 -- | | Scenario1 | Scenario2 | .. | ScenarioN |
322 -- | +-----------+-----------+ .. +-----------+
324 -- End of Compilation
326 -- +- | --------------------- Processing phase -------------------------+
328 -- | Check_Elaboration_Scenarios |
330 -- | +--> Check_SPARK_Scenario |
332 -- | | +--> Check_SPARK_Derived_Type |
334 -- | | +--> Check_SPARK_Instantiation |
336 -- | | +--> Check_SPARK_Refined_State_Pragma |
338 -- | +--> Process_Conditional_ABE <---------------------------+ |
340 -- | +--> Process_Conditional_ABE_Access Is_Suitable_Scenario |
342 -- | +--> Process_Conditional_ABE_Activation | |
344 -- | | +-----------------------------+ | |
346 -- | +--> Process_Conditional_ABE_Call +--------> Traverse_Body |
348 -- | | +-----------------------------+ |
350 -- | +--> Process_Conditional_ABE_Instantiation |
352 -- | +--> Process_Conditional_ABE_Variable_Assignment |
354 -- | +--> Process_Conditional_ABE_Variable_Reference |
356 -- +--------------------------------------------------------------------+
358 ----------------------
359 -- Important points --
360 ----------------------
362 -- The Processing phase starts after the analysis, resolution, expansion
363 -- phase has completed. As a result, no current semantic information is
364 -- available. The scope stack is empty, global flags such as In_Instance
365 -- or Inside_A_Generic become useless. To remedy this, the ABE mechanism
366 -- must either save or recompute semantic information.
368 -- Expansion heavily transforms calls and to some extent instantiations. To
369 -- remedy this, the ABE mechanism generates N_Call_Marker nodes in order to
370 -- capture the target and relevant attributes of the original call.
372 -- The diagnostics of the ABE mechanism depend on accurate source locations
373 -- to determine the spacial relation of nodes.
375 -----------------------------------------
376 -- Suppression of elaboration warnings --
377 -----------------------------------------
379 -- Elaboration warnings along multiple traversal paths rooted at a scenario
380 -- are suppressed when the scenario has elaboration warnings suppressed.
384 -- +-- Child scenario 1
386 -- | +-- Grandchild scenario 1
388 -- | +-- Grandchild scenario N
390 -- +-- Child scenario N
392 -- If the root scenario has elaboration warnings suppressed, then all its
393 -- child, grandchild, etc. scenarios will have their elaboration warnings
396 -- In addition to switch -gnatwL, pragma Warnings may be used to suppress
397 -- elaboration-related warnings when used in the following manner:
399 -- pragma Warnings ("L");
400 -- <scenario-or-target>
403 -- pragma Warnings (Off, target);
405 -- pragma Warnings (Off);
406 -- <scenario-or-target>
408 -- * To suppress elaboration warnings for '[Unrestricted_]Access of
409 -- entries, operators, and subprograms, either:
411 -- - Suppress the entry, operator, or subprogram, or
412 -- - Suppress the attribute, or
413 -- - Use switch -gnatw.f
415 -- * To suppress elaboration warnings for calls to entries, operators,
416 -- and subprograms, either:
418 -- - Suppress the entry, operator, or subprogram, or
419 -- - Suppress the call
421 -- * To suppress elaboration warnings for instantiations, suppress the
424 -- * To suppress elaboration warnings for task activations, either:
426 -- - Suppress the task object, or
427 -- - Suppress the task type, or
428 -- - Suppress the activation call
434 -- The following switches may be used to control the behavior of the ABE
437 -- -gnatd_a stop elaboration checks on accept or select statement
439 -- The ABE mechanism stops the traversal of a task body when it
440 -- encounters an accept or a select statement. This behavior is
441 -- equivalent to restriction No_Entry_Calls_In_Elaboration_Code,
442 -- but without penalizing actual entry calls during elaboration.
444 -- -gnatd_e ignore entry calls and requeue statements for elaboration
446 -- The ABE mechanism does not generate N_Call_Marker nodes for
447 -- protected or task entry calls as well as requeue statements.
448 -- As a result, the calls and requeues are not recorded or
451 -- -gnatdE elaboration checks on predefined units
453 -- The ABE mechanism considers scenarios which appear in internal
454 -- units (Ada, GNAT, Interfaces, System).
456 -- -gnatd.G ignore calls through generic formal parameters for elaboration
458 -- The ABE mechanism does not generate N_Call_Marker nodes for
459 -- calls which occur in expanded instances, and invoke generic
460 -- actual subprograms through generic formal subprograms. As a
461 -- result, the calls are not recorded or processed.
463 -- -gnatd_i ignore activations and calls to instances for elaboration
465 -- The ABE mechanism ignores calls and task activations when they
466 -- target a subprogram or task type defined an external instance.
467 -- As a result, the calls and task activations are not processed.
469 -- -gnatdL ignore external calls from instances for elaboration
471 -- The ABE mechanism does not generate N_Call_Marker nodes for
472 -- calls which occur in expanded instances, do not invoke generic
473 -- actual subprograms through formal subprograms, and the target
474 -- is external to the instance. As a result, the calls are not
475 -- recorded or processed.
477 -- -gnatd.o conservative elaboration order for indirect calls
479 -- The ABE mechanism treats '[Unrestricted_]Access of an entry,
480 -- operator, or subprogram as an immediate invocation of the
481 -- target. As a result, it performs ABE checks and diagnostics on
482 -- the immediate call.
484 -- -gnatd_p ignore assertion pragmas for elaboration
486 -- The ABE mechanism does not generate N_Call_Marker nodes for
487 -- calls to subprograms which verify the run-time semantics of
488 -- the following assertion pragmas:
490 -- Default_Initial_Condition
498 -- Type_Invariant_Class
500 -- As a result, the assertion expressions of the pragmas are not
503 -- -gnatd_s stop elaboration checks on synchronous suspension
505 -- The ABE mechanism stops the traversal of a task body when it
506 -- encounters a call to one of the following routines:
508 -- Ada.Synchronous_Barriers.Wait_For_Release
509 -- Ada.Synchronous_Task_Control.Suspend_Until_True
511 -- -gnatd.U ignore indirect calls for static elaboration
513 -- The ABE mechanism does not consider '[Unrestricted_]Access of
514 -- entries, operators, and subprograms. As a result, the scenarios
515 -- are not recorder or processed.
517 -- -gnatd.v enforce SPARK elaboration rules in SPARK code
519 -- The ABE mechanism applies some of the SPARK elaboration rules
520 -- defined in the SPARK reference manual, chapter 7.7. Note that
521 -- certain rules are always enforced, regardless of whether the
524 -- -gnatd.y disable implicit pragma Elaborate_All on task bodies
526 -- The ABE mechanism does not generate implicit Elaborate_All when
527 -- the need for the pragma came from a task body.
529 -- -gnatE dynamic elaboration checking mode enabled
531 -- The ABE mechanism assumes that any scenario is elaborated or
532 -- invoked by elaboration code. The ABE mechanism performs very
533 -- little diagnostics and generates condintional ABE checks to
534 -- detect ABE issues at run-time.
536 -- -gnatel turn on info messages on generated Elaborate[_All] pragmas
538 -- The ABE mechanism produces information messages on generated
539 -- implicit Elabote[_All] pragmas along with traceback showing
540 -- why the pragma was generated. In addition, the ABE mechanism
541 -- produces information messages for each scenario elaborated or
542 -- invoked by elaboration code.
544 -- -gnateL turn off info messages on generated Elaborate[_All] pragmas
546 -- The complementary switch for -gnatel.
548 -- -gnatH legacy elaboration checking mode enabled
550 -- When this switch is in effect, the pre-18.x ABE model becomes
551 -- the defacto ABE model. This ammounts to cutting off all entry
552 -- points into the new ABE mechanism, and giving full control to
553 -- the old ABE mechanism.
555 -- -gnatJ permissive elaboration checking mode enabled
557 -- This switch activates the following switches:
569 -- IMPORTANT: The behavior of the ABE mechanism becomes more
570 -- permissive at the cost of accurate diagnostics and runtime
573 -- -gnatw.f turn on warnings for suspicious Subp'Access
575 -- The ABE mechanism treats '[Unrestricted_]Access of an entry,
576 -- operator, or subprogram as a pseudo invocation of the target.
577 -- As a result, it performs ABE diagnostics on the pseudo call.
579 -- -gnatw.F turn off warnings for suspicious Subp'Access
581 -- The complementary switch for -gnatw.f.
583 -- -gnatwl turn on warnings for elaboration problems
585 -- The ABE mechanism produces warnings on detected ABEs along with
586 -- a traceback showing the graph of the ABE.
588 -- -gnatwL turn off warnings for elaboration problems
590 -- The complementary switch for -gnatwl.
592 ---------------------------
593 -- Adding a new scenario --
594 ---------------------------
596 -- The following steps describe how to add a new elaboration scenario and
597 -- preserve the existing architecture. Note that not all of the steps may
598 -- need to be carried out.
600 -- 1) Update predicate Is_Scenario
602 -- 2) Add predicate Is_Suitable_xxx. Include a call to it in predicate
603 -- Is_Suitable_Scenario.
605 -- 3) Update routine Record_Elaboration_Scenario
607 -- 4) Add routine Process_Conditional_ABE_xxx. Include a call to it in
608 -- routine Process_Conditional_ABE.
610 -- 5) Add routine Process_Guaranteed_ABE_xxx. Include a call to it in
611 -- routine Process_Guaranteed_ABE.
613 -- 6) Add routine Check_SPARK_xxx. Include a call to it in routine
614 -- Check_SPARK_Scenario.
616 -- 7) Add routine Info_xxx. Include a call to it in routine
617 -- Process_Conditional_ABE_xxx.
619 -- 8) Add routine Output_xxx. Include a call to it in routine
620 -- Output_Active_Scenarios.
622 -- 9) Add routine Extract_xxx_Attributes
624 -- 10) Update routine Is_Potential_Scenario
626 -------------------------
627 -- Adding a new target --
628 -------------------------
630 -- The following steps describe how to add a new elaboration target and
631 -- preserve the existing architecture. Note that not all of the steps may
632 -- need to be carried out.
634 -- 1) Add predicate Is_xxx.
636 -- 2) Update the following predicates
638 -- Is_Ada_Semantic_Target
639 -- Is_Assertion_Pragma_Target
641 -- Is_SPARK_Semantic_Target
643 -- If necessary, create a new category.
645 -- 3) Update the appropriate Info_xxx routine.
647 -- 4) Update the appropriate Output_xxx routine.
649 -- 5) Update routine Extract_Target_Attributes. If necessary, create a
650 -- new Extract_xxx routine.
652 --------------------------
653 -- Debugging ABE issues --
654 --------------------------
656 -- * If the issue involves a call, ensure that the call is eligible for ABE
657 -- processing and receives a corresponding call marker. The routines of
661 -- Record_Elaboration_Scenario
663 -- * If the issue involves an arbitrary scenario, ensure that the scenario
664 -- is either recorded, or is successfully recognized while traversing a
665 -- body. The routines of interest are
667 -- Record_Elaboration_Scenario
668 -- Process_Conditional_ABE
669 -- Process_Guaranteed_ABE
672 -- * If the issue involves a circularity in the elaboration order, examine
673 -- the ALI files and look for the following encodings next to units:
675 -- E indicates a source Elaborate
677 -- EA indicates a source Elaborate_All
679 -- AD indicates an implicit Elaborate_All
681 -- ED indicates an implicit Elaborate
683 -- If possible, compare these encodings with those generated by the old
684 -- ABE mechanism. The routines of interest are
686 -- Ensure_Prior_Elaboration
692 -- To minimize the amount of code within routines, the ABE mechanism relies
693 -- on "attribute" records to capture relevant information for a scenario or
696 -- The following type captures relevant attributes which pertain to a call
698 type Call_Attributes
is record
699 Elab_Checks_OK
: Boolean;
700 -- This flag is set when the call has elaboration checks enabled
702 Elab_Warnings_OK
: Boolean;
703 -- This flag is set when the call has elaboration warnings elabled
705 From_Source
: Boolean;
706 -- This flag is set when the call comes from source
708 Ghost_Mode_Ignore
: Boolean;
709 -- This flag is set when the call appears in a region subject to pragma
710 -- Ghost with policy Ignore.
712 In_Declarations
: Boolean;
713 -- This flag is set when the call appears at the declaration level
715 Is_Dispatching
: Boolean;
716 -- This flag is set when the call is dispatching
718 SPARK_Mode_On
: Boolean;
719 -- This flag is set when the call appears in a region subject to pragma
720 -- SPARK_Mode with value On.
723 -- The following type captures relevant attributes which pertain to the
724 -- prior elaboration of a unit. This type is coupled together with a unit
725 -- to form a key -> value relationship.
727 type Elaboration_Attributes
is record
728 Source_Pragma
: Node_Id
;
729 -- This attribute denotes a source Elaborate or Elaborate_All pragma
730 -- which guarantees the prior elaboration of some unit with respect
731 -- to the main unit. The pragma may come from the following contexts:
734 -- * The spec of the main unit (if applicable)
735 -- * Any parent spec of the main unit (if applicable)
736 -- * Any parent subunit of the main unit (if applicable)
738 -- The attribute remains Empty if no such pragma is available. Source
739 -- pragmas play a role in satisfying SPARK elaboration requirements.
741 With_Clause
: Node_Id
;
742 -- This attribute denotes an internally generated or source with clause
743 -- for some unit withed by the main unit. With clauses carry flags which
744 -- represent implicit Elaborate or Elaborate_All pragmas. These clauses
745 -- play a role in supplying the elaboration dependencies to binde.
748 No_Elaboration_Attributes
: constant Elaboration_Attributes
:=
749 (Source_Pragma
=> Empty
,
750 With_Clause
=> Empty
);
752 -- The following type captures relevant attributes which pertain to an
755 type Instantiation_Attributes
is record
756 Elab_Checks_OK
: Boolean;
757 -- This flag is set when the instantiation has elaboration checks
760 Elab_Warnings_OK
: Boolean;
761 -- This flag is set when the instantiation has elaboration warnings
764 Ghost_Mode_Ignore
: Boolean;
765 -- This flag is set when the instantiation appears in a region subject
766 -- to pragma Ghost with policy ignore, or starts one such region.
768 In_Declarations
: Boolean;
769 -- This flag is set when the instantiation appears at the declaration
772 SPARK_Mode_On
: Boolean;
773 -- This flag is set when the instantiation appears in a region subject
774 -- to pragma SPARK_Mode with value On, or starts one such region.
777 -- The following type captures relevant attributes which pertain to the
778 -- state of the Processing phase.
780 type Processing_Attributes
is record
781 Suppress_Implicit_Pragmas
: Boolean;
782 -- This flag is set when the Processing phase must not generate any
783 -- implicit Elaborate[_All] pragmas.
785 Suppress_Warnings
: Boolean;
786 -- This flag is set when the Processing phase must not emit any warnings
787 -- on elaboration problems.
789 Within_Initial_Condition
: Boolean;
790 -- This flag is set when the Processing phase is currently examining a
791 -- scenario which was reached from an initial condition procedure.
793 Within_Instance
: Boolean;
794 -- This flag is set when the Processing phase is currently examining a
795 -- scenario which was reached from a scenario defined in an instance.
797 Within_Partial_Finalization
: Boolean;
798 -- This flag is set when the Processing phase is currently examining a
799 -- scenario which was reached from a partial finalization procedure.
801 Within_Task_Body
: Boolean;
802 -- This flag is set when the Processing phase is currently examining a
803 -- scenario which was reached from a task body.
806 Initial_State
: constant Processing_Attributes
:=
807 (Suppress_Implicit_Pragmas
=> False,
808 Suppress_Warnings
=> False,
809 Within_Initial_Condition
=> False,
810 Within_Instance
=> False,
811 Within_Partial_Finalization
=> False,
812 Within_Task_Body
=> False);
814 -- The following type captures relevant attributes which pertain to a
817 type Target_Attributes
is record
818 Elab_Checks_OK
: Boolean;
819 -- This flag is set when the target has elaboration checks enabled
821 Elab_Warnings_OK
: Boolean;
822 -- This flag is set when the target has elaboration warnings enabled
824 From_Source
: Boolean;
825 -- This flag is set when the target comes from source
827 Ghost_Mode_Ignore
: Boolean;
828 -- This flag is set when the target appears in a region subject to
829 -- pragma Ghost with policy ignore, or starts one such region.
831 SPARK_Mode_On
: Boolean;
832 -- This flag is set when the target appears in a region subject to
833 -- pragma SPARK_Mode with value On, or starts one such region.
836 -- This attribute denotes the declaration of Spec_Id
839 -- This attribute denotes the top unit where Spec_Id resides
841 -- The semantics of the following attributes depend on the target
847 -- The target is a generic package or a subprogram
849 -- * Body_Barf - Empty
851 -- * Body_Decl - This attribute denotes the generic or subprogram
854 -- * Spec_Id - This attribute denotes the entity of the generic
855 -- package or subprogram.
857 -- The target is a protected entry
859 -- * Body_Barf - This attribute denotes the body of the barrier
860 -- function if expansion took place, otherwise it is Empty.
862 -- * Body_Decl - This attribute denotes the body of the procedure
863 -- which emulates the entry if expansion took place, otherwise it
864 -- denotes the body of the protected entry.
866 -- * Spec_Id - This attribute denotes the entity of the procedure
867 -- which emulates the entry if expansion took place, otherwise it
868 -- denotes the protected entry.
870 -- The target is a protected subprogram
872 -- * Body_Barf - Empty
874 -- * Body_Decl - This attribute denotes the body of the protected or
875 -- unprotected version of the protected subprogram if expansion took
876 -- place, otherwise it denotes the body of the protected subprogram.
878 -- * Spec_Id - This attribute denotes the entity of the protected or
879 -- unprotected version of the protected subprogram if expansion took
880 -- place, otherwise it is the entity of the protected subprogram.
882 -- The target is a task entry
884 -- * Body_Barf - Empty
886 -- * Body_Decl - This attribute denotes the body of the procedure
887 -- which emulates the task body if expansion took place, otherwise
888 -- it denotes the body of the task type.
890 -- * Spec_Id - This attribute denotes the entity of the procedure
891 -- which emulates the task body if expansion took place, otherwise
892 -- it denotes the entity of the task type.
895 -- The following type captures relevant attributes which pertain to a task
898 type Task_Attributes
is record
900 -- This attribute denotes the declaration of the procedure body which
901 -- emulates the behaviour of the task body.
903 Elab_Checks_OK
: Boolean;
904 -- This flag is set when the task type has elaboration checks enabled
906 Elab_Warnings_OK
: Boolean;
907 -- This flag is set when the task type has elaboration warnings enabled
909 Ghost_Mode_Ignore
: Boolean;
910 -- This flag is set when the task type appears in a region subject to
911 -- pragma Ghost with policy ignore, or starts one such region.
913 SPARK_Mode_On
: Boolean;
914 -- This flag is set when the task type appears in a region subject to
915 -- pragma SPARK_Mode with value On, or starts one such region.
918 -- This attribute denotes the entity of the initial declaration of the
919 -- procedure body which emulates the behaviour of the task body.
922 -- This attribute denotes the declaration of the task type
925 -- This attribute denotes the entity of the compilation unit where the
926 -- task type resides.
929 -- The following type captures relevant attributes which pertain to a
932 type Variable_Attributes
is record
934 -- This attribute denotes the entity of the compilation unit where the
938 ---------------------
939 -- Data structures --
940 ---------------------
942 -- The ABE mechanism employs lists and hash tables to store information
943 -- pertaining to scenarios and targets, as well as the Processing phase.
944 -- The need for data structures comes partly from the size limitation of
945 -- nodes. Note that the use of hash tables is conservative and operations
946 -- are carried out only when a particular hash table has at least one key
947 -- value pair (see xxx_In_Use flags).
949 -- The following table stores the early call regions of subprogram bodies
951 Early_Call_Regions_Max
: constant := 101;
953 type Early_Call_Regions_Index
is range 0 .. Early_Call_Regions_Max
- 1;
955 function Early_Call_Regions_Hash
956 (Key
: Entity_Id
) return Early_Call_Regions_Index
;
957 -- Obtain the hash value of entity Key
959 Early_Call_Regions_In_Use
: Boolean := False;
960 -- This flag determines whether table Early_Call_Regions contains at least
961 -- least one key/value pair.
963 Early_Call_Regions_No_Element
: constant Node_Id
:= Empty
;
965 package Early_Call_Regions
is new Simple_HTable
966 (Header_Num
=> Early_Call_Regions_Index
,
968 No_Element
=> Early_Call_Regions_No_Element
,
970 Hash
=> Early_Call_Regions_Hash
,
973 -- The following table stores the elaboration status of all units withed by
976 Elaboration_Statuses_Max
: constant := 1009;
978 type Elaboration_Statuses_Index
is range 0 .. Elaboration_Statuses_Max
- 1;
980 function Elaboration_Statuses_Hash
981 (Key
: Entity_Id
) return Elaboration_Statuses_Index
;
982 -- Obtain the hash value of entity Key
984 Elaboration_Statuses_In_Use
: Boolean := False;
985 -- This flag flag determines whether table Elaboration_Statuses contains at
986 -- least one key/value pair.
988 Elaboration_Statuses_No_Element
: constant Elaboration_Attributes
:=
989 No_Elaboration_Attributes
;
991 package Elaboration_Statuses
is new Simple_HTable
992 (Header_Num
=> Elaboration_Statuses_Index
,
993 Element
=> Elaboration_Attributes
,
994 No_Element
=> Elaboration_Statuses_No_Element
,
996 Hash
=> Elaboration_Statuses_Hash
,
999 -- The following table stores a status flag for each SPARK scenario saved
1000 -- in table SPARK_Scenarios.
1002 Recorded_SPARK_Scenarios_Max
: constant := 127;
1004 type Recorded_SPARK_Scenarios_Index
is
1005 range 0 .. Recorded_SPARK_Scenarios_Max
- 1;
1007 function Recorded_SPARK_Scenarios_Hash
1008 (Key
: Node_Id
) return Recorded_SPARK_Scenarios_Index
;
1009 -- Obtain the hash value of Key
1011 Recorded_SPARK_Scenarios_In_Use
: Boolean := False;
1012 -- This flag flag determines whether table Recorded_SPARK_Scenarios
1013 -- contains at least one key/value pair.
1015 Recorded_SPARK_Scenarios_No_Element
: constant Boolean := False;
1017 package Recorded_SPARK_Scenarios
is new Simple_HTable
1018 (Header_Num
=> Recorded_SPARK_Scenarios_Index
,
1020 No_Element
=> Recorded_SPARK_Scenarios_No_Element
,
1022 Hash
=> Recorded_SPARK_Scenarios_Hash
,
1025 -- The following table stores a status flag for each top-level scenario
1026 -- recorded in table Top_Level_Scenarios.
1028 Recorded_Top_Level_Scenarios_Max
: constant := 503;
1030 type Recorded_Top_Level_Scenarios_Index
is
1031 range 0 .. Recorded_Top_Level_Scenarios_Max
- 1;
1033 function Recorded_Top_Level_Scenarios_Hash
1034 (Key
: Node_Id
) return Recorded_Top_Level_Scenarios_Index
;
1035 -- Obtain the hash value of entity Key
1037 Recorded_Top_Level_Scenarios_In_Use
: Boolean := False;
1038 -- This flag flag determines whether table Recorded_Top_Level_Scenarios
1039 -- contains at least one key/value pair.
1041 Recorded_Top_Level_Scenarios_No_Element
: constant Boolean := False;
1043 package Recorded_Top_Level_Scenarios
is new Simple_HTable
1044 (Header_Num
=> Recorded_Top_Level_Scenarios_Index
,
1046 No_Element
=> Recorded_Top_Level_Scenarios_No_Element
,
1048 Hash
=> Recorded_Top_Level_Scenarios_Hash
,
1051 -- The following table stores all active scenarios in a recursive traversal
1052 -- starting from a top-level scenario. This table must be maintained in a
1055 package Scenario_Stack
is new Table
.Table
1056 (Table_Component_Type
=> Node_Id
,
1057 Table_Index_Type
=> Int
,
1058 Table_Low_Bound
=> 1,
1059 Table_Initial
=> 50,
1060 Table_Increment
=> 100,
1061 Table_Name
=> "Scenario_Stack");
1063 -- The following table stores SPARK scenarios which are not necessarily
1064 -- executable during elaboration, but still require elaboration-related
1067 package SPARK_Scenarios
is new Table
.Table
1068 (Table_Component_Type
=> Node_Id
,
1069 Table_Index_Type
=> Int
,
1070 Table_Low_Bound
=> 1,
1071 Table_Initial
=> 50,
1072 Table_Increment
=> 100,
1073 Table_Name
=> "SPARK_Scenarios");
1075 -- The following table stores all top-level scenario saved during the
1076 -- Recording phase. The contents of this table act as traversal roots
1077 -- later in the Processing phase. This table must be maintained in a
1080 package Top_Level_Scenarios
is new Table
.Table
1081 (Table_Component_Type
=> Node_Id
,
1082 Table_Index_Type
=> Int
,
1083 Table_Low_Bound
=> 1,
1084 Table_Initial
=> 1000,
1085 Table_Increment
=> 100,
1086 Table_Name
=> "Top_Level_Scenarios");
1088 -- The following table stores the bodies of all eligible scenarios visited
1089 -- during a traversal starting from a top-level scenario. The contents of
1090 -- this table must be reset upon each new traversal.
1092 Visited_Bodies_Max
: constant := 511;
1094 type Visited_Bodies_Index
is range 0 .. Visited_Bodies_Max
- 1;
1096 function Visited_Bodies_Hash
(Key
: Node_Id
) return Visited_Bodies_Index
;
1097 -- Obtain the hash value of node Key
1099 Visited_Bodies_In_Use
: Boolean := False;
1100 -- This flag determines whether table Visited_Bodies contains at least one
1103 Visited_Bodies_No_Element
: constant Boolean := False;
1105 package Visited_Bodies
is new Simple_HTable
1106 (Header_Num
=> Visited_Bodies_Index
,
1108 No_Element
=> Visited_Bodies_No_Element
,
1110 Hash
=> Visited_Bodies_Hash
,
1113 -----------------------
1114 -- Local subprograms --
1115 -----------------------
1117 -- Multiple local subprograms are utilized to lower the semantic complexity
1118 -- of the Recording and Processing phase.
1120 procedure Check_Preelaborated_Call
(Call
: Node_Id
);
1121 pragma Inline
(Check_Preelaborated_Call
);
1122 -- Verify that entry, operator, or subprogram call Call does not appear at
1123 -- the library level of a preelaborated unit.
1125 procedure Check_SPARK_Derived_Type
(Typ_Decl
: Node_Id
);
1126 pragma Inline
(Check_SPARK_Derived_Type
);
1127 -- Verify that the freeze node of a derived type denoted by declaration
1128 -- Typ_Decl is within the early call region of each overriding primitive
1129 -- body that belongs to the derived type (SPARK RM 7.7(8)).
1131 procedure Check_SPARK_Instantiation
(Exp_Inst
: Node_Id
);
1132 pragma Inline
(Check_SPARK_Instantiation
);
1133 -- Verify that expanded instance Exp_Inst does not precede the generic body
1134 -- it instantiates (SPARK RM 7.7(6)).
1136 procedure Check_SPARK_Model_In_Effect
(N
: Node_Id
);
1137 pragma Inline
(Check_SPARK_Model_In_Effect
);
1138 -- Determine whether a suitable elaboration model is currently in effect
1139 -- for verifying the SPARK rules of scenario N. Emit a warning if this is
1142 procedure Check_SPARK_Scenario
(N
: Node_Id
);
1143 pragma Inline
(Check_SPARK_Scenario
);
1144 -- Top-level dispatcher for verifying SPARK scenarios which are not always
1145 -- executable during elaboration but still need elaboration-related checks.
1147 procedure Check_SPARK_Refined_State_Pragma
(N
: Node_Id
);
1148 pragma Inline
(Check_SPARK_Refined_State_Pragma
);
1149 -- Verify that each constituent of Refined_State pragma N which belongs to
1150 -- an abstract state mentioned in pragma Initializes has prior elaboration
1151 -- with respect to the main unit (SPARK RM 7.7.1(7)).
1153 function Compilation_Unit
(Unit_Id
: Entity_Id
) return Node_Id
;
1154 pragma Inline
(Compilation_Unit
);
1155 -- Return the N_Compilation_Unit node of unit Unit_Id
1157 function Early_Call_Region
(Body_Id
: Entity_Id
) return Node_Id
;
1158 pragma Inline
(Early_Call_Region
);
1159 -- Return the early call region associated with entry or subprogram body
1160 -- Body_Id. IMPORTANT: This routine does not find the early call region.
1161 -- To compute it, use routine Find_Early_Call_Region.
1163 procedure Elab_Msg_NE
1168 In_SPARK
: Boolean);
1169 pragma Inline
(Elab_Msg_NE
);
1170 -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary node
1171 -- N and entity. If flag Info_Msg is set, the routine emits an information
1172 -- message, otherwise it emits an error. If flag In_SPARK is set, then
1173 -- string " in SPARK" is added to the end of the message.
1175 function Elaboration_Status
1176 (Unit_Id
: Entity_Id
) return Elaboration_Attributes
;
1177 pragma Inline
(Elaboration_Status
);
1178 -- Return the set of elaboration attributes associated with unit Unit_Id
1180 procedure Ensure_Prior_Elaboration
1182 Unit_Id
: Entity_Id
;
1184 State
: Processing_Attributes
);
1185 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit
1186 -- by installing pragma Elaborate or Elaborate_All denoted by Prag_Nam. N
1187 -- denotes the related scenario. State denotes the current state of the
1188 -- Processing phase.
1190 procedure Ensure_Prior_Elaboration_Dynamic
1192 Unit_Id
: Entity_Id
;
1193 Prag_Nam
: Name_Id
);
1194 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit
1195 -- by suggesting the use of Elaborate[_All] with name Prag_Nam. N denotes
1196 -- the related scenario.
1198 procedure Ensure_Prior_Elaboration_Static
1200 Unit_Id
: Entity_Id
;
1201 Prag_Nam
: Name_Id
);
1202 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit
1203 -- by installing an implicit Elaborate[_All] pragma with name Prag_Nam. N
1204 -- denotes the related scenario.
1206 function Extract_Assignment_Name
(Asmt
: Node_Id
) return Node_Id
;
1207 pragma Inline
(Extract_Assignment_Name
);
1208 -- Obtain the Name attribute of assignment statement Asmt
1210 procedure Extract_Call_Attributes
1212 Target_Id
: out Entity_Id
;
1213 Attrs
: out Call_Attributes
);
1214 pragma Inline
(Extract_Call_Attributes
);
1215 -- Obtain attributes Attrs associated with call Call. Target_Id is the
1216 -- entity of the call target.
1218 function Extract_Call_Name
(Call
: Node_Id
) return Node_Id
;
1219 pragma Inline
(Extract_Call_Name
);
1220 -- Obtain the Name attribute of entry or subprogram call Call
1222 procedure Extract_Instance_Attributes
1223 (Exp_Inst
: Node_Id
;
1224 Inst_Body
: out Node_Id
;
1225 Inst_Decl
: out Node_Id
);
1226 pragma Inline
(Extract_Instance_Attributes
);
1227 -- Obtain body Inst_Body and spec Inst_Decl of expanded instance Exp_Inst
1229 procedure Extract_Instantiation_Attributes
1230 (Exp_Inst
: Node_Id
;
1232 Inst_Id
: out Entity_Id
;
1233 Gen_Id
: out Entity_Id
;
1234 Attrs
: out Instantiation_Attributes
);
1235 pragma Inline
(Extract_Instantiation_Attributes
);
1236 -- Obtain attributes Attrs associated with expanded instantiation Exp_Inst.
1237 -- Inst is the instantiation. Inst_Id is the entity of the instance. Gen_Id
1238 -- is the entity of the generic unit being instantiated.
1240 procedure Extract_Target_Attributes
1241 (Target_Id
: Entity_Id
;
1242 Attrs
: out Target_Attributes
);
1243 -- Obtain attributes Attrs associated with an entry, package, or subprogram
1244 -- denoted by Target_Id.
1246 procedure Extract_Task_Attributes
1248 Attrs
: out Task_Attributes
);
1249 pragma Inline
(Extract_Task_Attributes
);
1250 -- Obtain attributes Attrs associated with task type Typ
1252 procedure Extract_Variable_Reference_Attributes
1254 Var_Id
: out Entity_Id
;
1255 Attrs
: out Variable_Attributes
);
1256 pragma Inline
(Extract_Variable_Reference_Attributes
);
1257 -- Obtain attributes Attrs associated with reference Ref that mentions
1260 function Find_Code_Unit
(N
: Node_Or_Entity_Id
) return Entity_Id
;
1261 pragma Inline
(Find_Code_Unit
);
1262 -- Return the code unit which contains arbitrary node or entity N. This
1263 -- is the unit of the file which physically contains the related construct
1264 -- denoted by N except when N is within an instantiation. In that case the
1265 -- unit is that of the top-level instantiation.
1267 function Find_Early_Call_Region
1268 (Body_Decl
: Node_Id
;
1269 Assume_Elab_Body
: Boolean := False;
1270 Skip_Memoization
: Boolean := False) return Node_Id
;
1271 -- Find the start of the early call region which belongs to subprogram body
1272 -- Body_Decl as defined in SPARK RM 7.7. The behavior of the routine is to
1273 -- find the early call region, memoize it, and return it, but this behavior
1274 -- can be altered. Flag Assume_Elab_Body should be set when a package spec
1275 -- may lack pragma Elaborate_Body, but the routine must still examine that
1276 -- spec. Flag Skip_Memoization should be set when the routine must avoid
1277 -- memoizing the region.
1279 procedure Find_Elaborated_Units
;
1280 -- Populate table Elaboration_Statuses with all units which have prior
1281 -- elaboration with respect to the main unit.
1283 function Find_Enclosing_Instance
(N
: Node_Id
) return Node_Id
;
1284 pragma Inline
(Find_Enclosing_Instance
);
1285 -- Find the declaration or body of the nearest expanded instance which
1286 -- encloses arbitrary node N. Return Empty if no such instance exists.
1288 function Find_Top_Unit
(N
: Node_Or_Entity_Id
) return Entity_Id
;
1289 pragma Inline
(Find_Top_Unit
);
1290 -- Return the top unit which contains arbitrary node or entity N. The unit
1291 -- is obtained by logically unwinding instantiations and subunits when N
1292 -- resides within one.
1294 function Find_Unit_Entity
(N
: Node_Id
) return Entity_Id
;
1295 pragma Inline
(Find_Unit_Entity
);
1296 -- Return the entity of unit N
1298 function First_Formal_Type
(Subp_Id
: Entity_Id
) return Entity_Id
;
1299 pragma Inline
(First_Formal_Type
);
1300 -- Return the type of subprogram Subp_Id's first formal parameter. If the
1301 -- subprogram lacks formal parameters, return Empty.
1303 function Has_Body
(Pack_Decl
: Node_Id
) return Boolean;
1304 -- Determine whether package declaration Pack_Decl has a corresponding body
1305 -- or would eventually have one.
1307 function Has_Prior_Elaboration
1308 (Unit_Id
: Entity_Id
;
1309 Context_OK
: Boolean := False;
1310 Elab_Body_OK
: Boolean := False;
1311 Same_Unit_OK
: Boolean := False) return Boolean;
1312 pragma Inline
(Has_Prior_Elaboration
);
1313 -- Determine whether unit Unit_Id is elaborated prior to the main unit.
1314 -- If flag Context_OK is set, the routine considers the following case
1315 -- as valid prior elaboration:
1317 -- * Unit_Id is in the elaboration context of the main unit
1319 -- If flag Elab_Body_OK is set, the routine considers the following case
1320 -- as valid prior elaboration:
1322 -- * Unit_Id has pragma Elaborate_Body and is not the main unit
1324 -- If flag Same_Unit_OK is set, the routine considers the following cases
1325 -- as valid prior elaboration:
1327 -- * Unit_Id is the main unit
1329 -- * Unit_Id denotes the spec of the main unit body
1331 function In_External_Instance
1333 Target_Decl
: Node_Id
) return Boolean;
1334 pragma Inline
(In_External_Instance
);
1335 -- Determine whether a target desctibed by its declaration Target_Decl
1336 -- resides in a package instance which is external to scenario N.
1338 function In_Main_Context
(N
: Node_Id
) return Boolean;
1339 pragma Inline
(In_Main_Context
);
1340 -- Determine whether arbitrary node N appears within the main compilation
1343 function In_Same_Context
1346 Nested_OK
: Boolean := False) return Boolean;
1347 -- Determine whether two arbitrary nodes N1 and N2 appear within the same
1348 -- context ignoring enclosing library levels. Nested_OK should be set when
1349 -- the context of N1 can enclose that of N2.
1351 function In_Task_Body
(N
: Node_Id
) return Boolean;
1352 pragma Inline
(In_Task_Body
);
1353 -- Determine whether arbitrary node N appears within a task body
1357 Target_Id
: Entity_Id
;
1359 In_SPARK
: Boolean);
1360 -- Output information concerning call Call which invokes target Target_Id.
1361 -- If flag Info_Msg is set, the routine emits an information message,
1362 -- otherwise it emits an error. If flag In_SPARK is set, then the string
1363 -- " in SPARK" is added to the end of the message.
1365 procedure Info_Instantiation
1369 In_SPARK
: Boolean);
1370 pragma Inline
(Info_Instantiation
);
1371 -- Output information concerning instantiation Inst which instantiates
1372 -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an
1373 -- information message, otherwise it emits an error. If flag In_SPARK
1374 -- is set, then string " in SPARK" is added to the end of the message.
1376 procedure Info_Variable_Reference
1380 In_SPARK
: Boolean);
1381 pragma Inline
(Info_Variable_Reference
);
1382 -- Output information concerning reference Ref which mentions variable
1383 -- Var_Id. If flag Info_Msg is set, the routine emits an information
1384 -- message, otherwise it emits an error. If flag In_SPARK is set, then
1385 -- string " in SPARK" is added to the end of the message.
1387 function Insertion_Node
(N
: Node_Id
; Ins_Nod
: Node_Id
) return Node_Id
;
1388 pragma Inline
(Insertion_Node
);
1389 -- Obtain the proper insertion node of an ABE check or failure for scenario
1390 -- N and candidate insertion node Ins_Nod.
1392 procedure Install_ABE_Check
1396 -- Insert a run-time ABE check for elaboration scenario N which verifies
1397 -- whether arbitrary entity Id is elaborated. The check in inserted prior
1400 procedure Install_ABE_Check
1402 Target_Id
: Entity_Id
;
1403 Target_Decl
: Node_Id
;
1404 Target_Body
: Node_Id
;
1406 -- Insert a run-time ABE check for elaboration scenario N which verifies
1407 -- whether target Target_Id with initial declaration Target_Decl and body
1408 -- Target_Body is elaborated. The check is inserted prior to node Ins_Nod.
1410 procedure Install_ABE_Failure
(N
: Node_Id
; Ins_Nod
: Node_Id
);
1411 -- Insert a Program_Error concerning a guaranteed ABE for elaboration
1412 -- scenario N. The failure is inserted prior to node Node_Id.
1414 function Is_Accept_Alternative_Proc
(Id
: Entity_Id
) return Boolean;
1415 pragma Inline
(Is_Accept_Alternative_Proc
);
1416 -- Determine whether arbitrary entity Id denotes an internally generated
1417 -- procedure which encapsulates the statements of an accept alternative.
1419 function Is_Activation_Proc
(Id
: Entity_Id
) return Boolean;
1420 pragma Inline
(Is_Activation_Proc
);
1421 -- Determine whether arbitrary entity Id denotes a runtime procedure in
1422 -- charge with activating tasks.
1424 function Is_Ada_Semantic_Target
(Id
: Entity_Id
) return Boolean;
1425 pragma Inline
(Is_Ada_Semantic_Target
);
1426 -- Determine whether arbitrary entity Id denodes a source or internally
1427 -- generated subprogram which emulates Ada semantics.
1429 function Is_Assertion_Pragma_Target
(Id
: Entity_Id
) return Boolean;
1430 pragma Inline
(Is_Assertion_Pragma_Target
);
1431 -- Determine whether arbitrary entity Id denotes a procedure which varifies
1432 -- the run-time semantics of an assertion pragma.
1434 function Is_Bodiless_Subprogram
(Subp_Id
: Entity_Id
) return Boolean;
1435 pragma Inline
(Is_Bodiless_Subprogram
);
1436 -- Determine whether subprogram Subp_Id will never have a body
1438 function Is_Controlled_Proc
1439 (Subp_Id
: Entity_Id
;
1440 Subp_Nam
: Name_Id
) return Boolean;
1441 pragma Inline
(Is_Controlled_Proc
);
1442 -- Determine whether subprogram Subp_Id denotes controlled type primitives
1443 -- Adjust, Finalize, or Initialize as denoted by name Subp_Nam.
1445 function Is_Default_Initial_Condition_Proc
(Id
: Entity_Id
) return Boolean;
1446 pragma Inline
(Is_Default_Initial_Condition_Proc
);
1447 -- Determine whether arbitrary entity Id denotes internally generated
1448 -- routine Default_Initial_Condition.
1450 function Is_Finalizer_Proc
(Id
: Entity_Id
) return Boolean;
1451 pragma Inline
(Is_Finalizer_Proc
);
1452 -- Determine whether arbitrary entity Id denotes internally generated
1453 -- routine _Finalizer.
1455 function Is_Guaranteed_ABE
1457 Target_Decl
: Node_Id
;
1458 Target_Body
: Node_Id
) return Boolean;
1459 pragma Inline
(Is_Guaranteed_ABE
);
1460 -- Determine whether scenario N with a target described by its initial
1461 -- declaration Target_Decl and body Target_Decl results in a guaranteed
1464 function Is_Initial_Condition_Proc
(Id
: Entity_Id
) return Boolean;
1465 pragma Inline
(Is_Initial_Condition_Proc
);
1466 -- Determine whether arbitrary entity Id denotes internally generated
1467 -- routine Initial_Condition.
1469 function Is_Initialized
(Obj_Decl
: Node_Id
) return Boolean;
1470 pragma Inline
(Is_Initialized
);
1471 -- Determine whether object declaration Obj_Decl is initialized
1473 function Is_Invariant_Proc
(Id
: Entity_Id
) return Boolean;
1474 pragma Inline
(Is_Invariant_Proc
);
1475 -- Determine whether arbitrary entity Id denotes an invariant procedure
1477 function Is_Non_Library_Level_Encapsulator
(N
: Node_Id
) return Boolean;
1478 pragma Inline
(Is_Non_Library_Level_Encapsulator
);
1479 -- Determine whether arbitrary node N is a non-library encapsulator
1481 function Is_Partial_Invariant_Proc
(Id
: Entity_Id
) return Boolean;
1482 pragma Inline
(Is_Partial_Invariant_Proc
);
1483 -- Determine whether arbitrary entity Id denotes a partial invariant
1486 function Is_Postconditions_Proc
(Id
: Entity_Id
) return Boolean;
1487 pragma Inline
(Is_Postconditions_Proc
);
1488 -- Determine whether arbitrary entity Id denotes internally generated
1489 -- routine _Postconditions.
1491 function Is_Preelaborated_Unit
(Id
: Entity_Id
) return Boolean;
1492 pragma Inline
(Is_Preelaborated_Unit
);
1493 -- Determine whether arbitrary entity Id denotes a unit which is subject to
1494 -- one of the following pragmas:
1498 -- * Remote_Call_Interface
1502 function Is_Protected_Entry
(Id
: Entity_Id
) return Boolean;
1503 pragma Inline
(Is_Protected_Entry
);
1504 -- Determine whether arbitrary entity Id denotes a protected entry
1506 function Is_Protected_Subp
(Id
: Entity_Id
) return Boolean;
1507 pragma Inline
(Is_Protected_Subp
);
1508 -- Determine whether entity Id denotes a protected subprogram
1510 function Is_Protected_Body_Subp
(Id
: Entity_Id
) return Boolean;
1511 pragma Inline
(Is_Protected_Body_Subp
);
1512 -- Determine whether entity Id denotes the protected or unprotected version
1513 -- of a protected subprogram.
1515 function Is_Recorded_SPARK_Scenario
(N
: Node_Id
) return Boolean;
1516 pragma Inline
(Is_Recorded_SPARK_Scenario
);
1517 -- Determine whether arbitrary node N is a recorded SPARK scenario which
1518 -- appears in table SPARK_Scenarios.
1520 function Is_Recorded_Top_Level_Scenario
(N
: Node_Id
) return Boolean;
1521 pragma Inline
(Is_Recorded_Top_Level_Scenario
);
1522 -- Determine whether arbitrary node N is a recorded top-level scenario
1523 -- which appears in table Top_Level_Scenarios.
1525 function Is_Safe_Activation
1527 Task_Decl
: Node_Id
) return Boolean;
1528 pragma Inline
(Is_Safe_Activation
);
1529 -- Determine whether call Call which activates a task object described by
1530 -- declaration Task_Decl is always ABE-safe.
1532 function Is_Safe_Call
1534 Target_Attrs
: Target_Attributes
) return Boolean;
1535 pragma Inline
(Is_Safe_Call
);
1536 -- Determine whether call Call which invokes a target described by
1537 -- attributes Target_Attrs is always ABE-safe.
1539 function Is_Safe_Instantiation
1541 Gen_Attrs
: Target_Attributes
) return Boolean;
1542 pragma Inline
(Is_Safe_Instantiation
);
1543 -- Determine whether instance Inst which instantiates a generic unit
1544 -- described by attributes Gen_Attrs is always ABE-safe.
1546 function Is_Same_Unit
1547 (Unit_1
: Entity_Id
;
1548 Unit_2
: Entity_Id
) return Boolean;
1549 pragma Inline
(Is_Same_Unit
);
1550 -- Determine whether entities Unit_1 and Unit_2 denote the same unit
1552 function Is_Scenario
(N
: Node_Id
) return Boolean;
1553 pragma Inline
(Is_Scenario
);
1554 -- Determine whether attribute node N denotes a scenario. The scenario may
1555 -- not necessarily be eligible for ABE processing.
1557 function Is_SPARK_Semantic_Target
(Id
: Entity_Id
) return Boolean;
1558 pragma Inline
(Is_SPARK_Semantic_Target
);
1559 -- Determine whether arbitrary entity Id nodes a source or internally
1560 -- generated subprogram which emulates SPARK semantics.
1562 function Is_Suitable_Access
(N
: Node_Id
) return Boolean;
1563 pragma Inline
(Is_Suitable_Access
);
1564 -- Determine whether arbitrary node N denotes a suitable attribute for ABE
1567 function Is_Suitable_Call
(N
: Node_Id
) return Boolean;
1568 pragma Inline
(Is_Suitable_Call
);
1569 -- Determine whether arbitrary node N denotes a suitable call for ABE
1572 function Is_Suitable_Instantiation
(N
: Node_Id
) return Boolean;
1573 pragma Inline
(Is_Suitable_Instantiation
);
1574 -- Determine whether arbitrary node N is a suitable instantiation for ABE
1577 function Is_Suitable_Scenario
(N
: Node_Id
) return Boolean;
1578 pragma Inline
(Is_Suitable_Scenario
);
1579 -- Determine whether arbitrary node N is a suitable scenario for ABE
1582 function Is_Suitable_SPARK_Derived_Type
(N
: Node_Id
) return Boolean;
1583 pragma Inline
(Is_Suitable_SPARK_Derived_Type
);
1584 -- Determine whether arbitrary node N denotes a suitable derived type
1585 -- declaration for ABE processing using the SPARK rules.
1587 function Is_Suitable_SPARK_Instantiation
(N
: Node_Id
) return Boolean;
1588 pragma Inline
(Is_Suitable_SPARK_Instantiation
);
1589 -- Determine whether arbitrary node N denotes a suitable instantiation for
1590 -- ABE processing using the SPARK rules.
1592 function Is_Suitable_SPARK_Refined_State_Pragma
1593 (N
: Node_Id
) return Boolean;
1594 pragma Inline
(Is_Suitable_SPARK_Refined_State_Pragma
);
1595 -- Determine whether arbitrary node N denotes a suitable Refined_State
1596 -- pragma for ABE processing using the SPARK rules.
1598 function Is_Suitable_Variable_Assignment
(N
: Node_Id
) return Boolean;
1599 pragma Inline
(Is_Suitable_Variable_Assignment
);
1600 -- Determine whether arbitrary node N denotes a suitable assignment for ABE
1603 function Is_Suitable_Variable_Reference
(N
: Node_Id
) return Boolean;
1604 pragma Inline
(Is_Suitable_Variable_Reference
);
1605 -- Determine whether arbitrary node N is a suitable variable reference for
1608 function Is_Synchronous_Suspension_Call
(N
: Node_Id
) return Boolean;
1609 pragma Inline
(Is_Synchronous_Suspension_Call
);
1610 -- Determine whether arbitrary node N denotes a call to one the following
1613 -- Ada.Synchronous_Barriers.Wait_For_Release
1614 -- Ada.Synchronous_Task_Control.Suspend_Until_True
1616 function Is_Task_Entry
(Id
: Entity_Id
) return Boolean;
1617 pragma Inline
(Is_Task_Entry
);
1618 -- Determine whether arbitrary entity Id denotes a task entry
1620 function Is_Up_Level_Target
(Target_Decl
: Node_Id
) return Boolean;
1621 pragma Inline
(Is_Up_Level_Target
);
1622 -- Determine whether the current root resides at the declaration level. If
1623 -- this is the case, determine whether a target described by declaration
1624 -- Target_Decl is within a context which encloses the current root or is in
1625 -- a different unit.
1627 function Is_Visited_Body
(Body_Decl
: Node_Id
) return Boolean;
1628 pragma Inline
(Is_Visited_Body
);
1629 -- Determine whether subprogram body Body_Decl is already visited during a
1630 -- recursive traversal started from a top-level scenario.
1632 procedure Meet_Elaboration_Requirement
1634 Target_Id
: Entity_Id
;
1636 -- Determine whether elaboration requirement Req_Nam for scenario N with
1637 -- target Target_Id is met by the context of the main unit using the SPARK
1638 -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an
1639 -- error if this is not the case.
1641 function Non_Private_View
(Typ
: Entity_Id
) return Entity_Id
;
1642 pragma Inline
(Non_Private_View
);
1643 -- Return the full view of private type Typ if available, otherwise return
1646 procedure Output_Active_Scenarios
(Error_Nod
: Node_Id
);
1647 -- Output the contents of the active scenario stack from earliest to latest
1648 -- to supplement an earlier error emitted for node Error_Nod.
1650 procedure Pop_Active_Scenario
(N
: Node_Id
);
1651 pragma Inline
(Pop_Active_Scenario
);
1652 -- Pop the top of the scenario stack. A check is made to ensure that the
1653 -- scenario being removed is the same as N.
1656 with procedure Process_Single_Activation
1658 Call_Attrs
: Call_Attributes
;
1660 Task_Attrs
: Task_Attributes
;
1661 State
: Processing_Attributes
);
1662 -- Perform ABE checks and diagnostics for task activation call Call
1663 -- which activates task Obj_Id. Call_Attrs are the attributes of the
1664 -- activation call. Task_Attrs are the attributes of the task type.
1665 -- State is the current state of the Processing phase.
1667 procedure Process_Activation_Generic
1669 Call_Attrs
: Call_Attributes
;
1670 State
: Processing_Attributes
);
1671 -- Perform ABE checks and diagnostics for activation call Call by invoking
1672 -- routine Process_Single_Activation on each task object being activated.
1673 -- Call_Attrs are the attributes of the activation call. State is the
1674 -- current state of the Processing phase.
1676 procedure Process_Conditional_ABE
1678 State
: Processing_Attributes
:= Initial_State
);
1679 -- Top-level dispatcher for processing of various elaboration scenarios.
1680 -- Perform conditional ABE checks and diagnostics for scenario N. State
1681 -- is the current state of the Processing phase.
1683 procedure Process_Conditional_ABE_Access
1685 State
: Processing_Attributes
);
1686 -- Perform ABE checks and diagnostics for 'Access to entry, operator, or
1687 -- subprogram denoted by Attr. State is the current state of the Processing
1690 procedure Process_Conditional_ABE_Activation_Impl
1692 Call_Attrs
: Call_Attributes
;
1694 Task_Attrs
: Task_Attributes
;
1695 State
: Processing_Attributes
);
1696 -- Perform common conditional ABE checks and diagnostics for call Call
1697 -- which activates task Obj_Id ignoring the Ada or SPARK rules. Call_Attrs
1698 -- are the attributes of the activation call. Task_Attrs are the attributes
1699 -- of the task type. State is the current state of the Processing phase.
1701 procedure Process_Conditional_ABE_Call
1703 Call_Attrs
: Call_Attributes
;
1704 Target_Id
: Entity_Id
;
1705 State
: Processing_Attributes
);
1706 -- Top-level dispatcher for processing of calls. Perform ABE checks and
1707 -- diagnostics for call Call which invokes target Target_Id. Call_Attrs
1708 -- are the attributes of the call. State is the current state of the
1709 -- Processing phase.
1711 procedure Process_Conditional_ABE_Call_Ada
1713 Call_Attrs
: Call_Attributes
;
1714 Target_Id
: Entity_Id
;
1715 Target_Attrs
: Target_Attributes
;
1716 State
: Processing_Attributes
);
1717 -- Perform ABE checks and diagnostics for call Call which invokes target
1718 -- Target_Id using the Ada rules. Call_Attrs are the attributes of the
1719 -- call. Target_Attrs are attributes of the target. State is the current
1720 -- state of the Processing phase.
1722 procedure Process_Conditional_ABE_Call_SPARK
1724 Target_Id
: Entity_Id
;
1725 Target_Attrs
: Target_Attributes
;
1726 State
: Processing_Attributes
);
1727 -- Perform ABE checks and diagnostics for call Call which invokes target
1728 -- Target_Id using the SPARK rules. Target_Attrs denotes the attributes of
1729 -- the target. State is the current state of the Processing phase.
1731 procedure Process_Conditional_ABE_Instantiation
1732 (Exp_Inst
: Node_Id
;
1733 State
: Processing_Attributes
);
1734 -- Top-level dispatcher for processing of instantiations. Perform ABE
1735 -- checks and diagnostics for expanded instantiation Exp_Inst. State is
1736 -- the current state of the Processing phase.
1738 procedure Process_Conditional_ABE_Instantiation_Ada
1739 (Exp_Inst
: Node_Id
;
1741 Inst_Attrs
: Instantiation_Attributes
;
1743 Gen_Attrs
: Target_Attributes
;
1744 State
: Processing_Attributes
);
1745 -- Perform ABE checks and diagnostics for expanded instantiation Exp_Inst
1746 -- of generic Gen_Id using the Ada rules. Inst is the instantiation node.
1747 -- Inst_Attrs are the attributes of the instance. Gen_Attrs denotes the
1748 -- attributes of the generic. State is the current state of the Processing
1751 procedure Process_Conditional_ABE_Instantiation_SPARK
1754 Gen_Attrs
: Target_Attributes
;
1755 State
: Processing_Attributes
);
1756 -- Perform ABE checks and diagnostics for instantiation Inst of generic
1757 -- Gen_Id using the SPARK rules. Gen_Attrs denotes the attributes of the
1758 -- generic. State is the current state of the Processing phase.
1760 procedure Process_Conditional_ABE_Variable_Assignment
(Asmt
: Node_Id
);
1761 -- Top-level dispatcher for processing of variable assignments. Perform ABE
1762 -- checks and diagnostics for assignment statement Asmt.
1764 procedure Process_Conditional_ABE_Variable_Assignment_Ada
1766 Var_Id
: Entity_Id
);
1767 -- Perform ABE checks and diagnostics for assignment statement Asmt that
1768 -- updates the value of variable Var_Id using the Ada rules.
1770 procedure Process_Conditional_ABE_Variable_Assignment_SPARK
1772 Var_Id
: Entity_Id
);
1773 -- Perform ABE checks and diagnostics for assignment statement Asmt that
1774 -- updates the value of variable Var_Id using the SPARK rules.
1776 procedure Process_Conditional_ABE_Variable_Reference
(Ref
: Node_Id
);
1777 -- Top-level dispatcher for processing of variable references. Perform ABE
1778 -- checks and diagnostics for variable reference Ref.
1780 procedure Process_Conditional_ABE_Variable_Reference_Read
1783 Attrs
: Variable_Attributes
);
1784 -- Perform ABE checks and diagnostics for reference Ref described by its
1785 -- attributes Attrs, that reads variable Var_Id.
1787 procedure Process_Guaranteed_ABE
(N
: Node_Id
);
1788 -- Top-level dispatcher for processing of scenarios which result in a
1791 procedure Process_Guaranteed_ABE_Activation_Impl
1793 Call_Attrs
: Call_Attributes
;
1795 Task_Attrs
: Task_Attributes
;
1796 State
: Processing_Attributes
);
1797 -- Perform common guaranteed ABE checks and diagnostics for call Call which
1798 -- activates task Obj_Id ignoring the Ada or SPARK rules. Call_Attrs are
1799 -- the attributes of the activation call. Task_Attrs are the attributes of
1800 -- the task type. State is provided for compatibility and is not used.
1802 procedure Process_Guaranteed_ABE_Call
1804 Call_Attrs
: Call_Attributes
;
1805 Target_Id
: Entity_Id
);
1806 -- Perform common guaranteed ABE checks and diagnostics for call Call which
1807 -- invokes target Target_Id ignoring the Ada or SPARK rules. Call_Attrs are
1808 -- the attributes of the call.
1810 procedure Process_Guaranteed_ABE_Instantiation
(Exp_Inst
: Node_Id
);
1811 -- Perform common guaranteed ABE checks and diagnostics for expanded
1812 -- instantiation Exp_Inst of generic Gen_Id ignoring the Ada or SPARK
1815 procedure Push_Active_Scenario
(N
: Node_Id
);
1816 pragma Inline
(Push_Active_Scenario
);
1817 -- Push scenario N on top of the scenario stack
1819 procedure Record_SPARK_Elaboration_Scenario
(N
: Node_Id
);
1820 pragma Inline
(Record_SPARK_Elaboration_Scenario
);
1821 -- Save SPARK scenario N in table SPARK_Scenarios for later processing
1823 procedure Reset_Visited_Bodies
;
1824 pragma Inline
(Reset_Visited_Bodies
);
1825 -- Clear the contents of table Visited_Bodies
1827 function Root_Scenario
return Node_Id
;
1828 pragma Inline
(Root_Scenario
);
1829 -- Return the top-level scenario which started a recursive search for other
1830 -- scenarios. It is assumed that there is a valid top-level scenario on the
1831 -- active scenario stack.
1833 procedure Set_Early_Call_Region
(Body_Id
: Entity_Id
; Start
: Node_Id
);
1834 pragma Inline
(Set_Early_Call_Region
);
1835 -- Associate an early call region with begins at construct Start with entry
1836 -- or subprogram body Body_Id.
1838 procedure Set_Elaboration_Status
1839 (Unit_Id
: Entity_Id
;
1840 Val
: Elaboration_Attributes
);
1841 pragma Inline
(Set_Elaboration_Status
);
1842 -- Associate an set of elaboration attributes with unit Unit_Id
1844 procedure Set_Is_Recorded_SPARK_Scenario
1846 Val
: Boolean := True);
1847 pragma Inline
(Set_Is_Recorded_SPARK_Scenario
);
1848 -- Mark scenario N as being recorded in table SPARK_Scenarios
1850 procedure Set_Is_Recorded_Top_Level_Scenario
1852 Val
: Boolean := True);
1853 pragma Inline
(Set_Is_Recorded_Top_Level_Scenario
);
1854 -- Mark scenario N as being recorded in table Top_Level_Scenarios
1856 procedure Set_Is_Visited_Body
(Subp_Body
: Node_Id
);
1857 pragma Inline
(Set_Is_Visited_Body
);
1858 -- Mark subprogram body Subp_Body as being visited during a recursive
1859 -- traversal started from a top-level scenario.
1861 function Static_Elaboration_Checks
return Boolean;
1862 pragma Inline
(Static_Elaboration_Checks
);
1863 -- Determine whether the static model is in effect
1865 procedure Traverse_Body
(N
: Node_Id
; State
: Processing_Attributes
);
1866 -- Inspect the declarative and statement lists of subprogram body N for
1867 -- suitable elaboration scenarios and process them. State is the current
1868 -- state of the Processing phase.
1870 function Unit_Entity
(Unit_Id
: Entity_Id
) return Entity_Id
;
1871 pragma Inline
(Unit_Entity
);
1872 -- Return the entity of the initial declaration for unit Unit_Id
1874 procedure Update_Elaboration_Scenario
(New_N
: Node_Id
; Old_N
: Node_Id
);
1875 pragma Inline
(Update_Elaboration_Scenario
);
1876 -- Update all relevant internal data structures when scenario Old_N is
1877 -- transformed into scenario New_N by Atree.Rewrite.
1879 -----------------------
1880 -- Build_Call_Marker --
1881 -----------------------
1883 procedure Build_Call_Marker
(N
: Node_Id
) is
1884 function In_External_Context
1886 Target_Attrs
: Target_Attributes
) return Boolean;
1887 pragma Inline
(In_External_Context
);
1888 -- Determine whether a target described by attributes Target_Attrs is
1889 -- external to call Call which must reside within an instance.
1891 function In_Premature_Context
(Call
: Node_Id
) return Boolean;
1892 -- Determine whether call Call appears within a premature context
1894 function Is_Bridge_Target
(Id
: Entity_Id
) return Boolean;
1895 pragma Inline
(Is_Bridge_Target
);
1896 -- Determine whether arbitrary entity Id denotes a bridge target
1898 function Is_Default_Expression
(Call
: Node_Id
) return Boolean;
1899 pragma Inline
(Is_Default_Expression
);
1900 -- Determine whether call Call acts as the expression of a defaulted
1901 -- parameter within a source call.
1903 function Is_Generic_Formal_Subp
(Subp_Id
: Entity_Id
) return Boolean;
1904 pragma Inline
(Is_Generic_Formal_Subp
);
1905 -- Determine whether subprogram Subp_Id denotes a generic formal
1906 -- subprogram which appears in the "prologue" of an instantiation.
1908 -------------------------
1909 -- In_External_Context --
1910 -------------------------
1912 function In_External_Context
1914 Target_Attrs
: Target_Attributes
) return Boolean
1917 Inst_Body
: Node_Id
;
1918 Inst_Decl
: Node_Id
;
1921 -- Performance note: parent traversal
1923 Inst
:= Find_Enclosing_Instance
(Call
);
1925 -- The call appears within an instance
1927 if Present
(Inst
) then
1929 -- The call comes from the main unit and the target does not
1931 if In_Extended_Main_Code_Unit
(Call
)
1932 and then not In_Extended_Main_Code_Unit
(Target_Attrs
.Spec_Decl
)
1936 -- Otherwise the target declaration must not appear within the
1937 -- instance spec or body.
1940 Extract_Instance_Attributes
1942 Inst_Decl
=> Inst_Decl
,
1943 Inst_Body
=> Inst_Body
);
1945 -- Performance note: parent traversal
1947 return not In_Subtree
1948 (N
=> Target_Attrs
.Spec_Decl
,
1950 Root2
=> Inst_Body
);
1955 end In_External_Context
;
1957 --------------------------
1958 -- In_Premature_Context --
1959 --------------------------
1961 function In_Premature_Context
(Call
: Node_Id
) return Boolean is
1965 -- Climb the parent chain looking for premature contexts
1967 Par
:= Parent
(Call
);
1968 while Present
(Par
) loop
1970 -- Aspect specifications and generic associations are premature
1971 -- contexts because nested calls has not been relocated to their
1974 if Nkind_In
(Par
, N_Aspect_Specification
,
1975 N_Generic_Association
)
1979 -- Prevent the search from going too far
1981 elsif Is_Body_Or_Package_Declaration
(Par
) then
1985 Par
:= Parent
(Par
);
1989 end In_Premature_Context
;
1991 ----------------------
1992 -- Is_Bridge_Target --
1993 ----------------------
1995 function Is_Bridge_Target
(Id
: Entity_Id
) return Boolean is
1998 Is_Accept_Alternative_Proc
(Id
)
1999 or else Is_Finalizer_Proc
(Id
)
2000 or else Is_Partial_Invariant_Proc
(Id
)
2001 or else Is_Postconditions_Proc
(Id
)
2002 or else Is_TSS
(Id
, TSS_Deep_Adjust
)
2003 or else Is_TSS
(Id
, TSS_Deep_Finalize
)
2004 or else Is_TSS
(Id
, TSS_Deep_Initialize
);
2005 end Is_Bridge_Target
;
2007 ---------------------------
2008 -- Is_Default_Expression --
2009 ---------------------------
2011 function Is_Default_Expression
(Call
: Node_Id
) return Boolean is
2012 Outer_Call
: constant Node_Id
:= Parent
(Call
);
2013 Outer_Nam
: Node_Id
;
2016 -- To qualify, the node must appear immediately within a source call
2017 -- which invokes a source target.
2019 if Nkind_In
(Outer_Call
, N_Entry_Call_Statement
,
2021 N_Procedure_Call_Statement
)
2022 and then Comes_From_Source
(Outer_Call
)
2024 Outer_Nam
:= Extract_Call_Name
(Outer_Call
);
2027 Is_Entity_Name
(Outer_Nam
)
2028 and then Present
(Entity
(Outer_Nam
))
2029 and then Is_Subprogram_Or_Entry
(Entity
(Outer_Nam
))
2030 and then Comes_From_Source
(Entity
(Outer_Nam
));
2034 end Is_Default_Expression
;
2036 ----------------------------
2037 -- Is_Generic_Formal_Subp --
2038 ----------------------------
2040 function Is_Generic_Formal_Subp
(Subp_Id
: Entity_Id
) return Boolean is
2041 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
2042 Context
: constant Node_Id
:= Parent
(Subp_Decl
);
2045 -- To qualify, the subprogram must rename a generic actual subprogram
2046 -- where the enclosing context is an instantiation.
2049 Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
2050 and then not Comes_From_Source
(Subp_Decl
)
2051 and then Nkind_In
(Context
, N_Function_Specification
,
2052 N_Package_Specification
,
2053 N_Procedure_Specification
)
2054 and then Present
(Generic_Parent
(Context
));
2055 end Is_Generic_Formal_Subp
;
2059 Call_Attrs
: Call_Attributes
;
2062 Target_Attrs
: Target_Attributes
;
2063 Target_Id
: Entity_Id
;
2065 -- Start of processing for Build_Call_Marker
2068 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
2069 -- enabled) is in effect because the legacy ABE mechanism does not need
2070 -- to carry out this action.
2072 if Legacy_Elaboration_Checks
then
2075 -- Nothing to do for ASIS. As a result, ABE checks and diagnostics are
2076 -- not performed in this mode.
2078 elsif ASIS_Mode
then
2081 -- Nothing to do when the call is being preanalyzed as the marker will
2082 -- be inserted in the wrong place.
2084 elsif Preanalysis_Active
then
2087 -- Nothing to do when the input does not denote a call or a requeue
2089 elsif not Nkind_In
(N
, N_Entry_Call_Statement
,
2091 N_Procedure_Call_Statement
,
2092 N_Requeue_Statement
)
2096 -- Nothing to do when the input denotes entry call or requeue statement,
2097 -- and switch -gnatd_e (ignore entry calls and requeue statements for
2098 -- elaboration) is in effect.
2100 elsif Debug_Flag_Underscore_E
2101 and then Nkind_In
(N
, N_Entry_Call_Statement
, N_Requeue_Statement
)
2106 Call_Nam
:= Extract_Call_Name
(N
);
2108 -- Nothing to do when the call is erroneous or left in a bad state
2110 if not (Is_Entity_Name
(Call_Nam
)
2111 and then Present
(Entity
(Call_Nam
))
2112 and then Is_Subprogram_Or_Entry
(Entity
(Call_Nam
)))
2116 -- Nothing to do when the call invokes a generic formal subprogram and
2117 -- switch -gnatd.G (ignore calls through generic formal parameters for
2118 -- elaboration) is in effect. This check must be performed with the
2119 -- direct target of the call to avoid the side effects of mapping
2120 -- actuals to formals using renamings.
2122 elsif Debug_Flag_Dot_GG
2123 and then Is_Generic_Formal_Subp
(Entity
(Call_Nam
))
2127 -- Nothing to do when the call is analyzed/resolved too early within an
2128 -- intermediate context. This check is saved for last because it incurs
2129 -- a performance penalty.
2131 -- Performance note: parent traversal
2133 elsif In_Premature_Context
(N
) then
2137 Extract_Call_Attributes
2139 Target_Id
=> Target_Id
,
2140 Attrs
=> Call_Attrs
);
2142 Extract_Target_Attributes
2143 (Target_Id
=> Target_Id
,
2144 Attrs
=> Target_Attrs
);
2146 -- Nothing to do when the call appears within the expanded spec or
2147 -- body of an instantiated generic, the call does not invoke a generic
2148 -- formal subprogram, the target is external to the instance, and switch
2149 -- -gnatdL (ignore external calls from instances for elaboration) is in
2153 and then not Is_Generic_Formal_Subp
(Entity
(Call_Nam
))
2155 -- Performance note: parent traversal
2157 and then In_External_Context
2159 Target_Attrs
=> Target_Attrs
)
2163 -- Nothing to do when the call invokes an assertion pragma procedure
2164 -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is
2167 elsif Debug_Flag_Underscore_P
2168 and then Is_Assertion_Pragma_Target
(Target_Id
)
2172 -- Source calls to source targets are always considered because they
2173 -- reflect the original call graph.
2175 elsif Target_Attrs
.From_Source
and then Call_Attrs
.From_Source
then
2178 -- A call to a source function which acts as the default expression in
2179 -- another call requires special detection.
2181 elsif Target_Attrs
.From_Source
2182 and then Nkind
(N
) = N_Function_Call
2183 and then Is_Default_Expression
(N
)
2187 -- The target emulates Ada semantics
2189 elsif Is_Ada_Semantic_Target
(Target_Id
) then
2192 -- The target acts as a link between scenarios
2194 elsif Is_Bridge_Target
(Target_Id
) then
2197 -- The target emulates SPARK semantics
2199 elsif Is_SPARK_Semantic_Target
(Target_Id
) then
2202 -- Otherwise the call is not suitable for ABE processing. This prevents
2203 -- the generation of call markers which will never play a role in ABE
2210 -- At this point it is known that the call will play some role in ABE
2211 -- checks and diagnostics. Create a corresponding call marker in case
2212 -- the original call is heavily transformed by expansion later on.
2214 Marker
:= Make_Call_Marker
(Sloc
(N
));
2216 -- Inherit the attributes of the original call
2218 Set_Target
(Marker
, Target_Id
);
2219 Set_Is_Declaration_Level_Node
(Marker
, Call_Attrs
.In_Declarations
);
2220 Set_Is_Dispatching_Call
(Marker
, Call_Attrs
.Is_Dispatching
);
2221 Set_Is_Elaboration_Checks_OK_Node
2222 (Marker
, Call_Attrs
.Elab_Checks_OK
);
2223 Set_Is_Elaboration_Warnings_OK_Node
2224 (Marker
, Call_Attrs
.Elab_Warnings_OK
);
2225 Set_Is_Ignored_Ghost_Node
(Marker
, Call_Attrs
.Ghost_Mode_Ignore
);
2226 Set_Is_Source_Call
(Marker
, Call_Attrs
.From_Source
);
2227 Set_Is_SPARK_Mode_On_Node
(Marker
, Call_Attrs
.SPARK_Mode_On
);
2229 -- The marker is inserted prior to the original call. This placement has
2230 -- several desirable effects:
2232 -- 1) The marker appears in the same context, in close proximity to
2238 -- 2) Inserting the marker prior to the call ensures that an ABE check
2239 -- will take effect prior to the call.
2245 -- 3) The above two properties are preserved even when the call is a
2246 -- function which is subsequently relocated in order to capture its
2247 -- result. Note that if the call is relocated to a new context, the
2248 -- relocated call will receive a marker of its own.
2252 -- Temp : ... := Func_Call ...;
2255 -- The insertion must take place even when the call does not occur in
2256 -- the main unit to keep the tree symmetric. This ensures that internal
2257 -- name serialization is consistent in case the call marker causes the
2258 -- tree to transform in some way.
2260 Insert_Action
(N
, Marker
);
2262 -- The marker becomes the "corresponding" scenario for the call. Save
2263 -- the marker for later processing by the ABE phase.
2265 Record_Elaboration_Scenario
(Marker
);
2266 end Build_Call_Marker
;
2268 -------------------------------------
2269 -- Build_Variable_Reference_Marker --
2270 -------------------------------------
2272 procedure Build_Variable_Reference_Marker
2277 function In_Compilation_Instance_Formal_Part
2278 (Nod
: Node_Id
) return Boolean;
2279 -- Determine whether arbitrary node Nod appears within the formal part
2280 -- of an instantiation which acts as a compilation unit.
2282 function In_Pragma
(Nod
: Node_Id
) return Boolean;
2283 -- Determine whether arbitrary node Nod appears within a pragma
2285 -----------------------------------------
2286 -- In_Compilation_Instance_Formal_Part --
2287 -----------------------------------------
2289 function In_Compilation_Instance_Formal_Part
2290 (Nod
: Node_Id
) return Boolean
2296 while Present
(Par
) loop
2297 if Nkind
(Par
) = N_Generic_Association
2298 and then Nkind
(Parent
(Par
)) in N_Generic_Instantiation
2299 and then Nkind
(Parent
(Parent
(Par
))) = N_Compilation_Unit
2303 -- Prevent the search from going too far
2305 elsif Is_Body_Or_Package_Declaration
(Par
) then
2309 Par
:= Parent
(Par
);
2313 end In_Compilation_Instance_Formal_Part
;
2319 function In_Pragma
(Nod
: Node_Id
) return Boolean is
2324 while Present
(Par
) loop
2325 if Nkind
(Par
) = N_Pragma
then
2328 -- Prevent the search from going too far
2330 elsif Is_Body_Or_Package_Declaration
(Par
) then
2334 Par
:= Parent
(Par
);
2344 Var_Attrs
: Variable_Attributes
;
2347 -- Start of processing for Build_Variable_Reference_Marker
2350 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
2351 -- enabled) is in effect because the legacy ABE mechanism does not need
2352 -- to carry out this action.
2354 if Legacy_Elaboration_Checks
then
2357 -- Nothing to do for ASIS. As a result, ABE checks and diagnostics are
2358 -- not performed in this mode.
2360 elsif ASIS_Mode
then
2363 -- Nothing to do when the reference is being preanalyzed as the marker
2364 -- will be inserted in the wrong place.
2366 elsif Preanalysis_Active
then
2369 -- Nothing to do when the input does not denote a reference
2371 elsif not Nkind_In
(N
, N_Expanded_Name
, N_Identifier
) then
2374 -- Nothing to do for internally-generated references
2376 elsif not Comes_From_Source
(N
) then
2379 -- Nothing to do when the reference is erroneous, left in a bad state,
2380 -- or does not denote a variable.
2382 elsif not (Present
(Entity
(N
))
2383 and then Ekind
(Entity
(N
)) = E_Variable
2384 and then Entity
(N
) /= Any_Id
)
2388 -- Nothing to do when the reference appears within the formal part of
2389 -- an instantiation which acts as compilation unit because there is no
2390 -- proper context for the insertion of the marker.
2392 -- Performance note: parent traversal
2394 elsif In_Compilation_Instance_Formal_Part
(N
) then
2398 Extract_Variable_Reference_Attributes
2401 Attrs
=> Var_Attrs
);
2403 Prag
:= SPARK_Pragma
(Var_Id
);
2405 if Comes_From_Source
(Var_Id
)
2407 -- Both the variable and the reference must appear in SPARK_Mode On
2408 -- regions because this scenario falls under the SPARK rules.
2410 and then Present
(Prag
)
2411 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
2412 and then Is_SPARK_Mode_On_Node
(N
)
2414 -- The reference must not be considered when it appears in a pragma.
2415 -- If the pragma has run-time semantics, then the reference will be
2416 -- reconsidered once the pragma is expanded.
2418 -- Performance note: parent traversal
2420 and then not In_Pragma
(N
)
2424 -- Otherwise the reference is not suitable for ABE processing. This
2425 -- prevents the generation of variable markers which will never play
2426 -- a role in ABE diagnostics.
2432 -- At this point it is known that the variable reference will play some
2433 -- role in ABE checks and diagnostics. Create a corresponding variable
2434 -- marker in case the original variable reference is folded or optimized
2437 Marker
:= Make_Variable_Reference_Marker
(Sloc
(N
));
2439 -- Inherit the attributes of the original variable reference
2441 Set_Target
(Marker
, Var_Id
);
2442 Set_Is_Read
(Marker
, Read
);
2443 Set_Is_Write
(Marker
, Write
);
2445 -- The marker is inserted prior to the original variable reference. The
2446 -- insertion must take place even when the reference does not occur in
2447 -- the main unit to keep the tree symmetric. This ensures that internal
2448 -- name serialization is consistent in case the variable marker causes
2449 -- the tree to transform in some way.
2451 Insert_Action
(N
, Marker
);
2453 -- The marker becomes the "corresponding" scenario for the reference.
2454 -- Save the marker for later processing for the ABE phase.
2456 Record_Elaboration_Scenario
(Marker
);
2457 end Build_Variable_Reference_Marker
;
2459 ---------------------------------
2460 -- Check_Elaboration_Scenarios --
2461 ---------------------------------
2463 procedure Check_Elaboration_Scenarios
is
2465 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
2466 -- enabled) is in effect because the legacy ABE mechanism does not need
2467 -- to carry out this action.
2469 if Legacy_Elaboration_Checks
then
2472 -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics
2473 -- are performed in this mode.
2475 elsif ASIS_Mode
then
2479 -- Restore the original elaboration model which was in effect when the
2480 -- scenarios were first recorded. The model may be specified by pragma
2481 -- Elaboration_Checks which appears on the initial declaration of the
2484 Install_Elaboration_Model
(Unit_Entity
(Cunit_Entity
(Main_Unit
)));
2486 -- Examine the context of the main unit and record all units with prior
2487 -- elaboration with respect to it.
2489 Find_Elaborated_Units
;
2491 -- Examine each top-level scenario saved during the Recording phase for
2492 -- conditional ABEs and perform various actions depending on the model
2493 -- in effect. The table of visited bodies is created for each new top-
2496 for Index
in Top_Level_Scenarios
.First
.. Top_Level_Scenarios
.Last
loop
2497 Reset_Visited_Bodies
;
2499 Process_Conditional_ABE
(Top_Level_Scenarios
.Table
(Index
));
2502 -- Examine each SPARK scenario saved during the Recording phase which
2503 -- is not necessarily executable during elaboration, but still requires
2504 -- elaboration-related checks.
2506 for Index
in SPARK_Scenarios
.First
.. SPARK_Scenarios
.Last
loop
2507 Check_SPARK_Scenario
(SPARK_Scenarios
.Table
(Index
));
2509 end Check_Elaboration_Scenarios
;
2511 ------------------------------
2512 -- Check_Preelaborated_Call --
2513 ------------------------------
2515 procedure Check_Preelaborated_Call
(Call
: Node_Id
) is
2516 function In_Preelaborated_Context
(N
: Node_Id
) return Boolean;
2517 -- Determine whether arbitrary node appears in a preelaborated context
2519 ------------------------------
2520 -- In_Preelaborated_Context --
2521 ------------------------------
2523 function In_Preelaborated_Context
(N
: Node_Id
) return Boolean is
2524 Body_Id
: constant Entity_Id
:= Find_Code_Unit
(N
);
2525 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Body_Id
);
2528 -- The node appears within a package body whose corresponding spec is
2529 -- subject to pragma Remote_Call_Interface or Remote_Types. This does
2530 -- not result in a preelaborated context because the package body may
2531 -- be on another machine.
2533 if Ekind
(Body_Id
) = E_Package_Body
2534 and then Ekind_In
(Spec_Id
, E_Generic_Package
, E_Package
)
2535 and then (Is_Remote_Call_Interface
(Spec_Id
)
2536 or else Is_Remote_Types
(Spec_Id
))
2540 -- Otherwise the node appears within a preelaborated context when the
2541 -- associated unit is preelaborated.
2544 return Is_Preelaborated_Unit
(Spec_Id
);
2546 end In_Preelaborated_Context
;
2550 Call_Attrs
: Call_Attributes
;
2551 Level
: Enclosing_Level_Kind
;
2552 Target_Id
: Entity_Id
;
2554 -- Start of processing for Check_Preelaborated_Call
2557 Extract_Call_Attributes
2559 Target_Id
=> Target_Id
,
2560 Attrs
=> Call_Attrs
);
2562 -- Nothing to do when the call is internally generated because it is
2563 -- assumed that it will never violate preelaboration.
2565 if not Call_Attrs
.From_Source
then
2569 -- Performance note: parent traversal
2571 Level
:= Find_Enclosing_Level
(Call
);
2573 -- Library-level calls are always considered because they are part of
2574 -- the associated unit's elaboration actions.
2576 if Level
in Library_Level
then
2579 -- Calls at the library level of a generic package body must be checked
2580 -- because they would render an instantiation illegal if the template is
2581 -- marked as preelaborated. Note that this does not apply to calls at
2582 -- the library level of a generic package spec.
2584 elsif Level
= Generic_Package_Body
then
2587 -- Otherwise the call does not appear at the proper level and must not
2588 -- be considered for this check.
2594 -- The call appears within a preelaborated unit. Emit a warning only for
2595 -- internal uses, otherwise this is an error.
2597 if In_Preelaborated_Context
(Call
) then
2598 Error_Msg_Warn
:= GNAT_Mode
;
2600 ("<<non-static call not allowed in preelaborated unit", Call
);
2602 end Check_Preelaborated_Call
;
2604 ------------------------------
2605 -- Check_SPARK_Derived_Type --
2606 ------------------------------
2608 procedure Check_SPARK_Derived_Type
(Typ_Decl
: Node_Id
) is
2609 Typ
: constant Entity_Id
:= Defining_Entity
(Typ_Decl
);
2611 -- NOTE: The routines within Check_SPARK_Derived_Type are intentionally
2612 -- unnested to avoid deep indentation of code.
2614 Stop_Check
: exception;
2615 -- This exception is raised when the freeze node violates the placement
2618 procedure Check_Overriding_Primitive
2621 pragma Inline
(Check_Overriding_Primitive
);
2622 -- Verify that freeze node FNode is within the early call region of
2623 -- overriding primitive Prim's body.
2625 function Freeze_Node_Location
(FNode
: Node_Id
) return Source_Ptr
;
2626 pragma Inline
(Freeze_Node_Location
);
2627 -- Return a more accurate source location associated with freeze node
2630 function Precedes_Source_Construct
(N
: Node_Id
) return Boolean;
2631 pragma Inline
(Precedes_Source_Construct
);
2632 -- Determine whether arbitrary node N appears prior to some source
2635 procedure Suggest_Elaborate_Body
2637 Body_Decl
: Node_Id
;
2638 Error_Nod
: Node_Id
);
2639 pragma Inline
(Suggest_Elaborate_Body
);
2640 -- Suggest the use of pragma Elaborate_Body when the pragma will allow
2641 -- for node N to appear within the early call region of subprogram body
2642 -- Body_Decl. The suggestion is attached to Error_Nod as a continuation
2645 --------------------------------
2646 -- Check_Overriding_Primitive --
2647 --------------------------------
2649 procedure Check_Overriding_Primitive
2653 Prim_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Prim
);
2654 Body_Decl
: Node_Id
;
2655 Body_Id
: Entity_Id
;
2659 -- Nothing to do for predefined primitives because they are artifacts
2660 -- of tagged type expansion and cannot override source primitives.
2662 if Is_Predefined_Dispatching_Operation
(Prim
) then
2666 Body_Id
:= Corresponding_Body
(Prim_Decl
);
2668 -- Nothing to do when the primitive does not have a corresponding
2669 -- body. This can happen when the unit with the bodies is not the
2670 -- main unit subjected to ABE checks.
2672 if No
(Body_Id
) then
2675 -- The primitive overrides a parent or progenitor primitive
2677 elsif Present
(Overridden_Operation
(Prim
)) then
2679 -- Nothing to do when overriding an interface primitive happens by
2680 -- inheriting a non-interface primitive as the check would be done
2681 -- on the parent primitive.
2683 if Present
(Alias
(Prim
)) then
2687 -- Nothing to do when the primitive is not overriding. The body of
2688 -- such a primitive cannot be targeted by a dispatching call which
2689 -- is executable during elaboration, and cannot cause an ABE.
2695 Body_Decl
:= Unit_Declaration_Node
(Body_Id
);
2696 Region
:= Find_Early_Call_Region
(Body_Decl
);
2698 -- The freeze node appears prior to the early call region of the
2701 -- IMPORTANT: This check must always be performed even when -gnatd.v
2702 -- (enforce SPARK elaboration rules in SPARK code) is not specified
2703 -- because the static model cannot guarantee the absence of ABEs in
2704 -- in the presence of dispatching calls.
2706 if Earlier_In_Extended_Unit
(FNode
, Region
) then
2707 Error_Msg_Node_2
:= Prim
;
2709 ("first freezing point of type & must appear within early call "
2710 & "region of primitive body & (SPARK RM 7.7(8))",
2713 Error_Msg_Sloc
:= Sloc
(Region
);
2714 Error_Msg_N
("\region starts #", Typ_Decl
);
2716 Error_Msg_Sloc
:= Sloc
(Body_Decl
);
2717 Error_Msg_N
("\region ends #", Typ_Decl
);
2719 Error_Msg_Sloc
:= Freeze_Node_Location
(FNode
);
2720 Error_Msg_N
("\first freezing point #", Typ_Decl
);
2722 -- If applicable, suggest the use of pragma Elaborate_Body in the
2723 -- associated package spec.
2725 Suggest_Elaborate_Body
2727 Body_Decl
=> Body_Decl
,
2728 Error_Nod
=> Typ_Decl
);
2732 end Check_Overriding_Primitive
;
2734 --------------------------
2735 -- Freeze_Node_Location --
2736 --------------------------
2738 function Freeze_Node_Location
(FNode
: Node_Id
) return Source_Ptr
is
2739 Context
: constant Node_Id
:= Parent
(FNode
);
2740 Loc
: constant Source_Ptr
:= Sloc
(FNode
);
2742 Prv_Decls
: List_Id
;
2743 Vis_Decls
: List_Id
;
2746 -- In general, the source location of the freeze node is as close as
2747 -- possible to the real freeze point, except when the freeze node is
2748 -- at the "bottom" of a package spec.
2750 if Nkind
(Context
) = N_Package_Specification
then
2751 Prv_Decls
:= Private_Declarations
(Context
);
2752 Vis_Decls
:= Visible_Declarations
(Context
);
2754 -- The freeze node appears in the private declarations of the
2757 if Present
(Prv_Decls
)
2758 and then List_Containing
(FNode
) = Prv_Decls
2762 -- The freeze node appears in the visible declarations of the
2763 -- package and there are no private declarations.
2765 elsif Present
(Vis_Decls
)
2766 and then List_Containing
(FNode
) = Vis_Decls
2767 and then (No
(Prv_Decls
) or else Is_Empty_List
(Prv_Decls
))
2771 -- Otherwise the freeze node is not in the "last" declarative list
2772 -- of the package. Use the existing source location of the freeze
2779 -- The freeze node appears at the "bottom" of the package when it
2780 -- is in the "last" declarative list and is either the last in the
2781 -- list or is followed by internal constructs only. In that case
2782 -- the more appropriate source location is that of the package end
2785 if not Precedes_Source_Construct
(FNode
) then
2786 return Sloc
(End_Label
(Context
));
2791 end Freeze_Node_Location
;
2793 -------------------------------
2794 -- Precedes_Source_Construct --
2795 -------------------------------
2797 function Precedes_Source_Construct
(N
: Node_Id
) return Boolean is
2802 while Present
(Decl
) loop
2803 if Comes_From_Source
(Decl
) then
2806 -- A generated body for a source expression function is treated as
2807 -- a source construct.
2809 elsif Nkind
(Decl
) = N_Subprogram_Body
2810 and then Was_Expression_Function
(Decl
)
2811 and then Comes_From_Source
(Original_Node
(Decl
))
2820 end Precedes_Source_Construct
;
2822 ----------------------------
2823 -- Suggest_Elaborate_Body --
2824 ----------------------------
2826 procedure Suggest_Elaborate_Body
2828 Body_Decl
: Node_Id
;
2829 Error_Nod
: Node_Id
)
2831 Unt
: constant Node_Id
:= Unit
(Cunit
(Main_Unit
));
2835 -- The suggestion applies only when the subprogram body resides in a
2836 -- compilation package body, and a pragma Elaborate_Body would allow
2837 -- for the node to appear in the early call region of the subprogram
2838 -- body. This implies that all code from the subprogram body up to
2839 -- the node is preelaborable.
2841 if Nkind
(Unt
) = N_Package_Body
then
2843 -- Find the start of the early call region again assuming that the
2844 -- package spec has pragma Elaborate_Body. Note that the internal
2845 -- data structures are intentionally not updated because this is a
2846 -- speculative search.
2849 Find_Early_Call_Region
2850 (Body_Decl
=> Body_Decl
,
2851 Assume_Elab_Body
=> True,
2852 Skip_Memoization
=> True);
2854 -- If the node appears within the early call region, assuming that
2855 -- the package spec carries pragma Elaborate_Body, then it is safe
2856 -- to suggest the pragma.
2858 if Earlier_In_Extended_Unit
(Region
, N
) then
2859 Error_Msg_Name_1
:= Name_Elaborate_Body
;
2861 ("\consider adding pragma % in spec of unit &",
2862 Error_Nod
, Defining_Entity
(Unt
));
2865 end Suggest_Elaborate_Body
;
2869 FNode
: constant Node_Id
:= Freeze_Node
(Typ
);
2870 Prims
: constant Elist_Id
:= Direct_Primitive_Operations
(Typ
);
2872 Prim_Elmt
: Elmt_Id
;
2874 -- Start of processing for Check_SPARK_Derived_Type
2877 -- A type should have its freeze node set by the time SPARK scenarios
2878 -- are being verified.
2880 pragma Assert
(Present
(FNode
));
2882 -- Verify that the freeze node of the derived type is within the early
2883 -- call region of each overriding primitive body (SPARK RM 7.7(8)).
2885 if Present
(Prims
) then
2886 Prim_Elmt
:= First_Elmt
(Prims
);
2887 while Present
(Prim_Elmt
) loop
2888 Check_Overriding_Primitive
2889 (Prim
=> Node
(Prim_Elmt
),
2892 Next_Elmt
(Prim_Elmt
);
2899 end Check_SPARK_Derived_Type
;
2901 -------------------------------
2902 -- Check_SPARK_Instantiation --
2903 -------------------------------
2905 procedure Check_SPARK_Instantiation
(Exp_Inst
: Node_Id
) is
2906 Gen_Attrs
: Target_Attributes
;
2909 Inst_Attrs
: Instantiation_Attributes
;
2910 Inst_Id
: Entity_Id
;
2913 Extract_Instantiation_Attributes
2914 (Exp_Inst
=> Exp_Inst
,
2918 Attrs
=> Inst_Attrs
);
2920 Extract_Target_Attributes
(Gen_Id
, Gen_Attrs
);
2922 -- The instantiation and the generic body are both in the main unit
2924 if Present
(Gen_Attrs
.Body_Decl
)
2925 and then In_Extended_Main_Code_Unit
(Gen_Attrs
.Body_Decl
)
2927 -- If the instantiation appears prior to the generic body, then the
2928 -- instantiation is illegal (SPARK RM 7.7(6)).
2930 -- IMPORTANT: This check must always be performed even when -gnatd.v
2931 -- (enforce SPARK elaboration rules in SPARK code) is not specified
2932 -- because the rule prevents use-before-declaration of objects that
2933 -- may precede the generic body.
2935 and then Earlier_In_Extended_Unit
(Inst
, Gen_Attrs
.Body_Decl
)
2937 Error_Msg_NE
("cannot instantiate & before body seen", Inst
, Gen_Id
);
2939 end Check_SPARK_Instantiation
;
2941 ---------------------------------
2942 -- Check_SPARK_Model_In_Effect --
2943 ---------------------------------
2945 SPARK_Model_Warning_Posted
: Boolean := False;
2946 -- This flag prevents the same SPARK model-related warning from being
2947 -- emitted multiple times.
2949 procedure Check_SPARK_Model_In_Effect
(N
: Node_Id
) is
2951 -- Do not emit the warning multiple times as this creates useless noise
2953 if SPARK_Model_Warning_Posted
then
2956 -- SPARK rule verification requires the "strict" static model
2958 elsif Static_Elaboration_Checks
and not Relaxed_Elaboration_Checks
then
2961 -- Any other combination of models does not guarantee the absence of ABE
2962 -- problems for SPARK rule verification purposes. Note that there is no
2963 -- need to check for the legacy ABE mechanism because the legacy code
2964 -- has its own orthogonal processing for SPARK rules.
2967 SPARK_Model_Warning_Posted
:= True;
2970 ("??SPARK elaboration checks require static elaboration model", N
);
2972 if Dynamic_Elaboration_Checks
then
2973 Error_Msg_N
("\dynamic elaboration model is in effect", N
);
2975 pragma Assert
(Relaxed_Elaboration_Checks
);
2976 Error_Msg_N
("\relaxed elaboration model is in effect", N
);
2979 end Check_SPARK_Model_In_Effect
;
2981 --------------------------
2982 -- Check_SPARK_Scenario --
2983 --------------------------
2985 procedure Check_SPARK_Scenario
(N
: Node_Id
) is
2987 -- Ensure that a suitable elaboration model is in effect for SPARK rule
2990 Check_SPARK_Model_In_Effect
(N
);
2992 -- Add the current scenario to the stack of active scenarios
2994 Push_Active_Scenario
(N
);
2996 if Is_Suitable_SPARK_Derived_Type
(N
) then
2997 Check_SPARK_Derived_Type
(N
);
2999 elsif Is_Suitable_SPARK_Instantiation
(N
) then
3000 Check_SPARK_Instantiation
(N
);
3002 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
3003 Check_SPARK_Refined_State_Pragma
(N
);
3006 -- Remove the current scenario from the stack of active scenarios once
3007 -- all ABE diagnostics and checks have been performed.
3009 Pop_Active_Scenario
(N
);
3010 end Check_SPARK_Scenario
;
3012 --------------------------------------
3013 -- Check_SPARK_Refined_State_Pragma --
3014 --------------------------------------
3016 procedure Check_SPARK_Refined_State_Pragma
(N
: Node_Id
) is
3018 -- NOTE: The routines within Check_SPARK_Refined_State_Pragma are
3019 -- intentionally unnested to avoid deep indentation of code.
3021 procedure Check_SPARK_Constituent
(Constit_Id
: Entity_Id
);
3022 pragma Inline
(Check_SPARK_Constituent
);
3023 -- Ensure that a single constituent Constit_Id is elaborated prior to
3026 procedure Check_SPARK_Constituents
(Constits
: Elist_Id
);
3027 pragma Inline
(Check_SPARK_Constituents
);
3028 -- Ensure that all constituents found in list Constits are elaborated
3029 -- prior to the main unit.
3031 procedure Check_SPARK_Initialized_State
(State
: Node_Id
);
3032 pragma Inline
(Check_SPARK_Initialized_State
);
3033 -- Ensure that the constituents of single abstract state State are
3034 -- elaborated prior to the main unit.
3036 procedure Check_SPARK_Initialized_States
(Pack_Id
: Entity_Id
);
3037 pragma Inline
(Check_SPARK_Initialized_States
);
3038 -- Ensure that the constituents of all abstract states which appear in
3039 -- the Initializes pragma of package Pack_Id are elaborated prior to the
3042 -----------------------------
3043 -- Check_SPARK_Constituent --
3044 -----------------------------
3046 procedure Check_SPARK_Constituent
(Constit_Id
: Entity_Id
) is
3050 -- Nothing to do for "null" constituents
3052 if Nkind
(Constit_Id
) = N_Null
then
3055 -- Nothing to do for illegal constituents
3057 elsif Error_Posted
(Constit_Id
) then
3061 Prag
:= SPARK_Pragma
(Constit_Id
);
3063 -- The check applies only when the constituent is subject to pragma
3067 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
3069 -- An external constituent of an abstract state which appears in
3070 -- the Initializes pragma of a package spec imposes an Elaborate
3071 -- requirement on the context of the main unit. Determine whether
3072 -- the context has a pragma strong enough to meet the requirement.
3074 -- IMPORTANT: This check is performed only when -gnatd.v (enforce
3075 -- SPARK elaboration rules in SPARK code) is in effect because the
3076 -- static model can ensure the prior elaboration of the unit which
3077 -- contains a constituent by installing implicit Elaborate pragma.
3079 if Debug_Flag_Dot_V
then
3080 Meet_Elaboration_Requirement
3082 Target_Id
=> Constit_Id
,
3083 Req_Nam
=> Name_Elaborate
);
3085 -- Otherwise ensure that the unit with the external constituent is
3086 -- elaborated prior to the main unit.
3089 Ensure_Prior_Elaboration
3091 Unit_Id
=> Find_Top_Unit
(Constit_Id
),
3092 Prag_Nam
=> Name_Elaborate
,
3093 State
=> Initial_State
);
3096 end Check_SPARK_Constituent
;
3098 ------------------------------
3099 -- Check_SPARK_Constituents --
3100 ------------------------------
3102 procedure Check_SPARK_Constituents
(Constits
: Elist_Id
) is
3103 Constit_Elmt
: Elmt_Id
;
3106 if Present
(Constits
) then
3107 Constit_Elmt
:= First_Elmt
(Constits
);
3108 while Present
(Constit_Elmt
) loop
3109 Check_SPARK_Constituent
(Node
(Constit_Elmt
));
3110 Next_Elmt
(Constit_Elmt
);
3113 end Check_SPARK_Constituents
;
3115 -----------------------------------
3116 -- Check_SPARK_Initialized_State --
3117 -----------------------------------
3119 procedure Check_SPARK_Initialized_State
(State
: Node_Id
) is
3121 State_Id
: Entity_Id
;
3124 -- Nothing to do for "null" initialization items
3126 if Nkind
(State
) = N_Null
then
3129 -- Nothing to do for illegal states
3131 elsif Error_Posted
(State
) then
3135 State_Id
:= Entity_Of
(State
);
3137 -- Sanitize the state
3139 if No
(State_Id
) then
3142 elsif Error_Posted
(State_Id
) then
3145 elsif Ekind
(State_Id
) /= E_Abstract_State
then
3149 -- The check is performed only when the abstract state is subject to
3152 Prag
:= SPARK_Pragma
(State_Id
);
3155 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
3157 Check_SPARK_Constituents
(Refinement_Constituents
(State_Id
));
3159 end Check_SPARK_Initialized_State
;
3161 ------------------------------------
3162 -- Check_SPARK_Initialized_States --
3163 ------------------------------------
3165 procedure Check_SPARK_Initialized_States
(Pack_Id
: Entity_Id
) is
3166 Prag
: constant Node_Id
:= Get_Pragma
(Pack_Id
, Pragma_Initializes
);
3171 if Present
(Prag
) then
3172 Inits
:= Expression
(Get_Argument
(Prag
, Pack_Id
));
3174 -- Avoid processing a "null" initialization list. The only other
3175 -- alternative is an aggregate.
3177 if Nkind
(Inits
) = N_Aggregate
then
3179 -- The initialization items appear in list form:
3183 if Present
(Expressions
(Inits
)) then
3184 Init
:= First
(Expressions
(Inits
));
3185 while Present
(Init
) loop
3186 Check_SPARK_Initialized_State
(Init
);
3191 -- The initialization items appear in associated form:
3193 -- (state1 => item1,
3194 -- state2 => (item2, item3))
3196 if Present
(Component_Associations
(Inits
)) then
3197 Init
:= First
(Component_Associations
(Inits
));
3198 while Present
(Init
) loop
3199 Check_SPARK_Initialized_State
(Init
);
3205 end Check_SPARK_Initialized_States
;
3209 Pack_Body
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
3211 -- Start of processing for Check_SPARK_Refined_State_Pragma
3214 -- Pragma Refined_State must be associated with a package body
3217 (Present
(Pack_Body
) and then Nkind
(Pack_Body
) = N_Package_Body
);
3219 -- Verify that each external contitunent of an abstract state mentioned
3220 -- in pragma Initializes is properly elaborated.
3222 Check_SPARK_Initialized_States
(Unique_Defining_Entity
(Pack_Body
));
3223 end Check_SPARK_Refined_State_Pragma
;
3225 ----------------------
3226 -- Compilation_Unit --
3227 ----------------------
3229 function Compilation_Unit
(Unit_Id
: Entity_Id
) return Node_Id
is
3230 Comp_Unit
: Node_Id
;
3233 Comp_Unit
:= Parent
(Unit_Id
);
3235 -- Handle the case where a concurrent subunit is rewritten as a null
3236 -- statement due to expansion activities.
3238 if Nkind
(Comp_Unit
) = N_Null_Statement
3239 and then Nkind_In
(Original_Node
(Comp_Unit
), N_Protected_Body
,
3242 Comp_Unit
:= Parent
(Comp_Unit
);
3243 pragma Assert
(Nkind
(Comp_Unit
) = N_Subunit
);
3245 -- Otherwise use the declaration node of the unit
3248 Comp_Unit
:= Parent
(Unit_Declaration_Node
(Unit_Id
));
3251 -- Handle the case where a subprogram instantiation which acts as a
3252 -- compilation unit is expanded into an anonymous package that wraps
3253 -- the instantiated subprogram.
3255 if Nkind
(Comp_Unit
) = N_Package_Specification
3256 and then Nkind_In
(Original_Node
(Parent
(Comp_Unit
)),
3257 N_Function_Instantiation
,
3258 N_Procedure_Instantiation
)
3260 Comp_Unit
:= Parent
(Parent
(Comp_Unit
));
3262 -- Handle the case where the compilation unit is a subunit
3264 elsif Nkind
(Comp_Unit
) = N_Subunit
then
3265 Comp_Unit
:= Parent
(Comp_Unit
);
3268 pragma Assert
(Nkind
(Comp_Unit
) = N_Compilation_Unit
);
3271 end Compilation_Unit
;
3273 -----------------------
3274 -- Early_Call_Region --
3275 -----------------------
3277 function Early_Call_Region
(Body_Id
: Entity_Id
) return Node_Id
is
3279 pragma Assert
(Ekind_In
(Body_Id
, E_Entry
,
3283 E_Subprogram_Body
));
3285 if Early_Call_Regions_In_Use
then
3286 return Early_Call_Regions
.Get
(Body_Id
);
3289 return Early_Call_Regions_No_Element
;
3290 end Early_Call_Region
;
3292 -----------------------------
3293 -- Early_Call_Regions_Hash --
3294 -----------------------------
3296 function Early_Call_Regions_Hash
3297 (Key
: Entity_Id
) return Early_Call_Regions_Index
3300 return Early_Call_Regions_Index
(Key
mod Early_Call_Regions_Max
);
3301 end Early_Call_Regions_Hash
;
3307 procedure Elab_Msg_NE
3314 function Prefix
return String;
3315 -- Obtain the prefix of the message
3317 function Suffix
return String;
3318 -- Obtain the suffix of the message
3324 function Prefix
return String is
3337 function Suffix
return String is
3346 -- Start of processing for Elab_Msg_NE
3349 Error_Msg_NE
(Prefix
& Msg
& Suffix
, N
, Id
);
3352 ------------------------
3353 -- Elaboration_Status --
3354 ------------------------
3356 function Elaboration_Status
3357 (Unit_Id
: Entity_Id
) return Elaboration_Attributes
3360 if Elaboration_Statuses_In_Use
then
3361 return Elaboration_Statuses
.Get
(Unit_Id
);
3364 return Elaboration_Statuses_No_Element
;
3365 end Elaboration_Status
;
3367 -------------------------------
3368 -- Elaboration_Statuses_Hash --
3369 -------------------------------
3371 function Elaboration_Statuses_Hash
3372 (Key
: Entity_Id
) return Elaboration_Statuses_Index
3375 return Elaboration_Statuses_Index
(Key
mod Elaboration_Statuses_Max
);
3376 end Elaboration_Statuses_Hash
;
3378 ------------------------------
3379 -- Ensure_Prior_Elaboration --
3380 ------------------------------
3382 procedure Ensure_Prior_Elaboration
3384 Unit_Id
: Entity_Id
;
3386 State
: Processing_Attributes
)
3389 pragma Assert
(Nam_In
(Prag_Nam
, Name_Elaborate
, Name_Elaborate_All
));
3391 -- Nothing to do when the caller has suppressed the generation of
3392 -- implicit Elaborate[_All] pragmas.
3394 if State
.Suppress_Implicit_Pragmas
then
3397 -- Nothing to do when the need for prior elaboration came from a partial
3398 -- finalization routine which occurs in an initialization context. This
3399 -- behaviour parallels that of the old ABE mechanism.
3401 elsif State
.Within_Partial_Finalization
then
3404 -- Nothing to do when the need for prior elaboration came from a task
3405 -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on
3406 -- task bodies) is in effect.
3408 elsif Debug_Flag_Dot_Y
and then State
.Within_Task_Body
then
3411 -- Nothing to do when the unit is elaborated prior to the main unit.
3412 -- This check must also consider the following cases:
3414 -- * No check is made against the context of the main unit because this
3415 -- is specific to the elaboration model in effect and requires custom
3416 -- handling (see Ensure_xxx_Prior_Elaboration).
3418 -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma
3419 -- Elaborate[_All] MUST be generated even though Unit_Id is always
3420 -- elaborated prior to the main unit. This is a conservative strategy
3421 -- which ensures that other units withed by Unit_Id will not lead to
3424 -- package A is package body A is
3425 -- procedure ABE; procedure ABE is ... end ABE;
3429 -- package B is package body B is
3430 -- pragma Elaborate_Body; procedure Proc is
3432 -- procedure Proc; A.ABE;
3433 -- package B; end Proc;
3437 -- package C is package body C is
3443 -- In the example above, the elaboration of C invokes B.Proc. B is
3444 -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] is
3445 -- generated for B in C, then the following elaboratio order will lead
3448 -- spec of A elaborated
3449 -- spec of B elaborated
3450 -- body of B elaborated
3451 -- spec of C elaborated
3452 -- body of C elaborated <-- calls B.Proc which calls A.ABE
3453 -- body of A elaborated <-- problem
3455 -- The generation of an implicit pragma Elaborate_All (B) ensures that
3456 -- the elaboration order mechanism will not pick the above order.
3458 -- An implicit Elaborate is NOT generated when the unit is subject to
3459 -- Elaborate_Body because both pragmas have the exact same effect.
3461 -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] MUST
3462 -- NOT be generated in this case because a unit cannot depend on its
3463 -- own elaboration. This case is therefore treated as valid prior
3466 elsif Has_Prior_Elaboration
3467 (Unit_Id
=> Unit_Id
,
3468 Same_Unit_OK
=> True,
3469 Elab_Body_OK
=> Prag_Nam
= Name_Elaborate
)
3473 -- Suggest the use of pragma Prag_Nam when the dynamic model is in
3476 elsif Dynamic_Elaboration_Checks
then
3477 Ensure_Prior_Elaboration_Dynamic
3480 Prag_Nam
=> Prag_Nam
);
3482 -- Install an implicit pragma Prag_Nam when the static model is in
3486 pragma Assert
(Static_Elaboration_Checks
);
3488 Ensure_Prior_Elaboration_Static
3491 Prag_Nam
=> Prag_Nam
);
3493 end Ensure_Prior_Elaboration
;
3495 --------------------------------------
3496 -- Ensure_Prior_Elaboration_Dynamic --
3497 --------------------------------------
3499 procedure Ensure_Prior_Elaboration_Dynamic
3501 Unit_Id
: Entity_Id
;
3504 procedure Info_Missing_Pragma
;
3505 pragma Inline
(Info_Missing_Pragma
);
3506 -- Output information concerning missing Elaborate or Elaborate_All
3507 -- pragma with name Prag_Nam for scenario N, which would ensure the
3508 -- prior elaboration of Unit_Id.
3510 -------------------------
3511 -- Info_Missing_Pragma --
3512 -------------------------
3514 procedure Info_Missing_Pragma
is
3516 -- Internal units are ignored as they cause unnecessary noise
3518 if not In_Internal_Unit
(Unit_Id
) then
3520 -- The name of the unit subjected to the elaboration pragma is
3521 -- fully qualified to improve the clarity of the info message.
3523 Error_Msg_Name_1
:= Prag_Nam
;
3524 Error_Msg_Qual_Level
:= Nat
'Last;
3526 Error_Msg_NE
("info: missing pragma % for unit &", N
, Unit_Id
);
3527 Error_Msg_Qual_Level
:= 0;
3529 end Info_Missing_Pragma
;
3533 Elab_Attrs
: Elaboration_Attributes
;
3534 Level
: Enclosing_Level_Kind
;
3536 -- Start of processing for Ensure_Prior_Elaboration_Dynamic
3539 Elab_Attrs
:= Elaboration_Status
(Unit_Id
);
3541 -- Nothing to do when the unit is guaranteed prior elaboration by means
3542 -- of a source Elaborate[_All] pragma.
3544 if Present
(Elab_Attrs
.Source_Pragma
) then
3548 -- Output extra information on a missing Elaborate[_All] pragma when
3549 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas
3552 if Elab_Info_Messages
then
3554 -- Performance note: parent traversal
3556 Level
:= Find_Enclosing_Level
(N
);
3558 -- Declaration-level scenario
3560 if (Is_Suitable_Call
(N
) or else Is_Suitable_Instantiation
(N
))
3561 and then Level
= Declaration_Level
3565 -- Library-level scenario
3567 elsif Level
in Library_Level
then
3570 -- Instantiation library-level scenario
3572 elsif Level
= Instantiation
then
3575 -- Otherwise the scenario does not appear at the proper level and
3576 -- cannot possibly act as a top-level scenario.
3582 Info_Missing_Pragma
;
3584 end Ensure_Prior_Elaboration_Dynamic
;
3586 -------------------------------------
3587 -- Ensure_Prior_Elaboration_Static --
3588 -------------------------------------
3590 procedure Ensure_Prior_Elaboration_Static
3592 Unit_Id
: Entity_Id
;
3595 function Find_With_Clause
3597 Withed_Id
: Entity_Id
) return Node_Id
;
3598 pragma Inline
(Find_With_Clause
);
3599 -- Find a nonlimited with clause in the list of context items Items
3600 -- that withs unit Withed_Id. Return Empty if no such clause is found.
3602 procedure Info_Implicit_Pragma
;
3603 pragma Inline
(Info_Implicit_Pragma
);
3604 -- Output information concerning an implicitly generated Elaborate or
3605 -- Elaborate_All pragma with name Prag_Nam for scenario N which ensures
3606 -- the prior elaboration of unit Unit_Id.
3608 ----------------------
3609 -- Find_With_Clause --
3610 ----------------------
3612 function Find_With_Clause
3614 Withed_Id
: Entity_Id
) return Node_Id
3619 -- Examine the context clauses looking for a suitable with. Note that
3620 -- limited clauses do not affect the elaboration order.
3622 Item
:= First
(Items
);
3623 while Present
(Item
) loop
3624 if Nkind
(Item
) = N_With_Clause
3625 and then not Error_Posted
(Item
)
3626 and then not Limited_Present
(Item
)
3627 and then Entity
(Name
(Item
)) = Withed_Id
3636 end Find_With_Clause
;
3638 --------------------------
3639 -- Info_Implicit_Pragma --
3640 --------------------------
3642 procedure Info_Implicit_Pragma
is
3644 -- Internal units are ignored as they cause unnecessary noise
3646 if not In_Internal_Unit
(Unit_Id
) then
3648 -- The name of the unit subjected to the elaboration pragma is
3649 -- fully qualified to improve the clarity of the info message.
3651 Error_Msg_Name_1
:= Prag_Nam
;
3652 Error_Msg_Qual_Level
:= Nat
'Last;
3655 ("info: implicit pragma % generated for unit &", N
, Unit_Id
);
3657 Error_Msg_Qual_Level
:= 0;
3658 Output_Active_Scenarios
(N
);
3660 end Info_Implicit_Pragma
;
3664 Main_Cunit
: constant Node_Id
:= Cunit
(Main_Unit
);
3665 Loc
: constant Source_Ptr
:= Sloc
(Main_Cunit
);
3666 Unit_Cunit
: constant Node_Id
:= Compilation_Unit
(Unit_Id
);
3669 Elab_Attrs
: Elaboration_Attributes
;
3672 -- Start of processing for Ensure_Prior_Elaboration_Static
3675 Elab_Attrs
:= Elaboration_Status
(Unit_Id
);
3677 -- Nothing to do when the unit is guaranteed prior elaboration by means
3678 -- of a source Elaborate[_All] pragma.
3680 if Present
(Elab_Attrs
.Source_Pragma
) then
3683 -- Nothing to do when the unit has an existing implicit Elaborate[_All]
3684 -- pragma installed by a previous scenario.
3686 elsif Present
(Elab_Attrs
.With_Clause
) then
3688 -- The unit is already guaranteed prior elaboration by means of an
3689 -- implicit Elaborate pragma, however the current scenario imposes
3690 -- a stronger requirement of Elaborate_All. "Upgrade" the existing
3691 -- pragma to match this new requirement.
3693 if Elaborate_Desirable
(Elab_Attrs
.With_Clause
)
3694 and then Prag_Nam
= Name_Elaborate_All
3696 Set_Elaborate_All_Desirable
(Elab_Attrs
.With_Clause
);
3697 Set_Elaborate_Desirable
(Elab_Attrs
.With_Clause
, False);
3703 -- At this point it is known that the unit has no prior elaboration
3704 -- according to pragmas and hierarchical relationships.
3706 Items
:= Context_Items
(Main_Cunit
);
3710 Set_Context_Items
(Main_Cunit
, Items
);
3713 -- Locate the with clause for the unit. Note that there may not be a
3714 -- clause if the unit is visible through a subunit-body, body-spec, or
3715 -- spec-parent relationship.
3720 Withed_Id
=> Unit_Id
);
3725 -- Note that adding implicit with clauses is safe because analysis,
3726 -- resolution, and expansion have already taken place and it is not
3727 -- possible to interfere with visibility.
3731 Make_With_Clause
(Loc
,
3732 Name
=> New_Occurrence_Of
(Unit_Id
, Loc
));
3734 Set_Implicit_With
(Clause
);
3735 Set_Library_Unit
(Clause
, Unit_Cunit
);
3737 Append_To
(Items
, Clause
);
3740 -- Mark the with clause depending on the pragma required
3742 if Prag_Nam
= Name_Elaborate
then
3743 Set_Elaborate_Desirable
(Clause
);
3745 Set_Elaborate_All_Desirable
(Clause
);
3748 -- The implicit Elaborate[_All] ensures the prior elaboration of the
3749 -- unit. Include the unit in the elaboration context of the main unit.
3751 Set_Elaboration_Status
3752 (Unit_Id
=> Unit_Id
,
3753 Val
=> Elaboration_Attributes
'(Source_Pragma => Empty,
3754 With_Clause => Clause));
3756 -- Output extra information on an implicit Elaborate[_All] pragma when
3757 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas is
3760 if Elab_Info_Messages then
3761 Info_Implicit_Pragma;
3763 end Ensure_Prior_Elaboration_Static;
3765 -----------------------------
3766 -- Extract_Assignment_Name --
3767 -----------------------------
3769 function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id is
3775 -- When the name denotes an array or record component, find the whole
3778 while Nkind_In (Nam, N_Explicit_Dereference,
3779 N_Indexed_Component,
3780 N_Selected_Component,
3783 Nam := Prefix (Nam);
3787 end Extract_Assignment_Name;
3789 -----------------------------
3790 -- Extract_Call_Attributes --
3791 -----------------------------
3793 procedure Extract_Call_Attributes
3795 Target_Id : out Entity_Id;
3796 Attrs : out Call_Attributes)
3798 From_Source : Boolean;
3799 In_Declarations : Boolean;
3800 Is_Dispatching : Boolean;
3803 -- Extraction for call markers
3805 if Nkind (Call) = N_Call_Marker then
3806 Target_Id := Target (Call);
3807 From_Source := Is_Source_Call (Call);
3808 In_Declarations := Is_Declaration_Level_Node (Call);
3809 Is_Dispatching := Is_Dispatching_Call (Call);
3811 -- Extraction for entry calls, requeue, and subprogram calls
3814 pragma Assert (Nkind_In (Call, N_Entry_Call_Statement,
3816 N_Procedure_Call_Statement,
3817 N_Requeue_Statement));
3819 Target_Id := Entity (Extract_Call_Name (Call));
3820 From_Source := Comes_From_Source (Call);
3822 -- Performance note: parent traversal
3824 In_Declarations := Find_Enclosing_Level (Call) = Declaration_Level;
3826 Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement)
3827 and then Present (Controlling_Argument (Call));
3830 -- Obtain the original entry or subprogram which the target may rename
3831 -- except when the target is an instantiation. In this case the alias
3832 -- is the internally generated subprogram which appears within the the
3833 -- anonymous package created for the instantiation. Such an alias is not
3834 -- a suitable target.
3836 if not (Is_Subprogram (Target_Id)
3837 and then Is_Generic_Instance (Target_Id))
3839 Target_Id := Get_Renamed_Entity (Target_Id);
3842 -- Set all attributes
3844 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call);
3845 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call);
3846 Attrs.From_Source := From_Source;
3847 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Call);
3848 Attrs.In_Declarations := In_Declarations;
3849 Attrs.Is_Dispatching := Is_Dispatching;
3850 Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Call);
3851 end Extract_Call_Attributes;
3853 -----------------------
3854 -- Extract_Call_Name --
3855 -----------------------
3857 function Extract_Call_Name (Call : Node_Id) return Node_Id is
3863 -- When the call invokes an entry family, the name appears as an indexed
3866 if Nkind (Nam) = N_Indexed_Component then
3867 Nam := Prefix (Nam);
3870 -- When the call employs the object.operation form, the name appears as
3871 -- a selected component.
3873 if Nkind (Nam) = N_Selected_Component then
3874 Nam := Selector_Name (Nam);
3878 end Extract_Call_Name;
3880 ---------------------------------
3881 -- Extract_Instance_Attributes --
3882 ---------------------------------
3884 procedure Extract_Instance_Attributes
3885 (Exp_Inst : Node_Id;
3886 Inst_Body : out Node_Id;
3887 Inst_Decl : out Node_Id)
3889 Body_Id : Entity_Id;
3892 -- Assume that the attributes are unavailable
3897 -- Generic package or subprogram spec
3899 if Nkind_In (Exp_Inst, N_Package_Declaration,
3900 N_Subprogram_Declaration)
3902 Inst_Decl := Exp_Inst;
3903 Body_Id := Corresponding_Body (Inst_Decl);
3905 if Present (Body_Id) then
3906 Inst_Body := Unit_Declaration_Node (Body_Id);
3909 -- Generic package or subprogram body
3913 (Nkind_In (Exp_Inst, N_Package_Body, N_Subprogram_Body));
3915 Inst_Body := Exp_Inst;
3916 Inst_Decl := Unit_Declaration_Node (Corresponding_Spec (Inst_Body));
3918 end Extract_Instance_Attributes;
3920 --------------------------------------
3921 -- Extract_Instantiation_Attributes --
3922 --------------------------------------
3924 procedure Extract_Instantiation_Attributes
3925 (Exp_Inst : Node_Id;
3927 Inst_Id : out Entity_Id;
3928 Gen_Id : out Entity_Id;
3929 Attrs : out Instantiation_Attributes)
3932 Inst := Original_Node (Exp_Inst);
3933 Inst_Id := Defining_Entity (Inst);
3935 -- Traverse a possible chain of renamings to obtain the original generic
3936 -- being instantiatied.
3938 Gen_Id := Get_Renamed_Entity (Entity (Name (Inst)));
3940 -- Set all attributes
3942 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst);
3943 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Inst);
3944 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Inst);
3945 Attrs.In_Declarations := Is_Declaration_Level_Node (Inst);
3946 Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Inst);
3947 end Extract_Instantiation_Attributes;
3949 -------------------------------
3950 -- Extract_Target_Attributes --
3951 -------------------------------
3953 procedure Extract_Target_Attributes
3954 (Target_Id : Entity_Id;
3955 Attrs : out Target_Attributes)
3957 procedure Extract_Package_Or_Subprogram_Attributes
3958 (Spec_Id : out Entity_Id;
3959 Body_Decl : out Node_Id);
3960 -- Obtain the attributes associated with a package or a subprogram.
3961 -- Spec_Id is the package or subprogram. Body_Decl is the declaration
3962 -- of the corresponding package or subprogram body.
3964 procedure Extract_Protected_Entry_Attributes
3965 (Spec_Id : out Entity_Id;
3966 Body_Decl : out Node_Id;
3967 Body_Barf : out Node_Id);
3968 -- Obtain the attributes associated with a protected entry [family].
3969 -- Spec_Id is the entity of the protected body subprogram. Body_Decl
3970 -- is the declaration of Spec_Id's corresponding body. Body_Barf is
3971 -- the declaration of the barrier function body.
3973 procedure Extract_Protected_Subprogram_Attributes
3974 (Spec_Id : out Entity_Id;
3975 Body_Decl : out Node_Id);
3976 -- Obtain the attributes associated with a protected subprogram. Formal
3977 -- Spec_Id is the entity of the protected body subprogram. Body_Decl is
3978 -- the declaration of Spec_Id's corresponding body.
3980 procedure Extract_Task_Entry_Attributes
3981 (Spec_Id : out Entity_Id;
3982 Body_Decl : out Node_Id);
3983 -- Obtain the attributes associated with a task entry [family]. Formal
3984 -- Spec_Id is the entity of the task body procedure. Body_Decl is the
3985 -- declaration of Spec_Id's corresponding body.
3987 ----------------------------------------------
3988 -- Extract_Package_Or_Subprogram_Attributes --
3989 ----------------------------------------------
3991 procedure Extract_Package_Or_Subprogram_Attributes
3992 (Spec_Id : out Entity_Id;
3993 Body_Decl : out Node_Id)
3995 Body_Id : Entity_Id;
3996 Init_Id : Entity_Id;
3997 Spec_Decl : Node_Id;
4000 -- Assume that the body is not available
4003 Spec_Id := Target_Id;
4005 -- For body retrieval purposes, the entity of the initial declaration
4006 -- is that of the spec.
4010 -- The only exception to the above is a function which returns a
4011 -- constrained array type in a SPARK-to-C compilation. In this case
4012 -- the function receives a corresponding procedure which has an out
4013 -- parameter. The proper body for ABE checks and diagnostics is that
4014 -- of the procedure.
4016 if Ekind (Init_Id) = E_Function
4017 and then Rewritten_For_C (Init_Id)
4019 Init_Id := Corresponding_Procedure (Init_Id);
4022 -- Extract the attributes of the body
4024 Spec_Decl := Unit_Declaration_Node (Init_Id);
4026 -- The initial declaration is a stand alone subprogram body
4028 if Nkind (Spec_Decl) = N_Subprogram_Body then
4029 Body_Decl := Spec_Decl;
4031 -- Otherwise the package or subprogram has a spec and a completing
4034 elsif Nkind_In (Spec_Decl, N_Generic_Package_Declaration,
4035 N_Generic_Subprogram_Declaration,
4036 N_Package_Declaration,
4037 N_Subprogram_Body_Stub,
4038 N_Subprogram_Declaration)
4040 Body_Id := Corresponding_Body (Spec_Decl);
4042 if Present (Body_Id) then
4043 Body_Decl := Unit_Declaration_Node (Body_Id);
4046 end Extract_Package_Or_Subprogram_Attributes;
4048 ----------------------------------------
4049 -- Extract_Protected_Entry_Attributes --
4050 ----------------------------------------
4052 procedure Extract_Protected_Entry_Attributes
4053 (Spec_Id : out Entity_Id;
4054 Body_Decl : out Node_Id;
4055 Body_Barf : out Node_Id)
4057 Barf_Id : Entity_Id;
4058 Body_Id : Entity_Id;
4061 -- Assume that the bodies are not available
4066 -- When the entry [family] has already been expanded, it carries both
4067 -- the procedure which emulates the behavior of the entry [family] as
4068 -- well as the barrier function.
4070 if Present (Protected_Body_Subprogram (Target_Id)) then
4071 Spec_Id := Protected_Body_Subprogram (Target_Id);
4073 -- Extract the attributes of the barrier function
4077 (Unit_Declaration_Node (Barrier_Function (Target_Id)));
4079 if Present (Barf_Id) then
4080 Body_Barf := Unit_Declaration_Node (Barf_Id);
4083 -- Otherwise no expansion took place
4086 Spec_Id := Target_Id;
4089 -- Extract the attributes of the entry body
4091 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
4093 if Present (Body_Id) then
4094 Body_Decl := Unit_Declaration_Node (Body_Id);
4096 end Extract_Protected_Entry_Attributes;
4098 ---------------------------------------------
4099 -- Extract_Protected_Subprogram_Attributes --
4100 ---------------------------------------------
4102 procedure Extract_Protected_Subprogram_Attributes
4103 (Spec_Id : out Entity_Id;
4104 Body_Decl : out Node_Id)
4106 Body_Id : Entity_Id;
4109 -- Assume that the body is not available
4113 -- When the protected subprogram has already been expanded, it
4114 -- carries the subprogram which seizes the lock and invokes the
4115 -- original statements.
4117 if Present (Protected_Subprogram (Target_Id)) then
4119 Protected_Body_Subprogram (Protected_Subprogram (Target_Id));
4121 -- Otherwise no expansion took place
4124 Spec_Id := Target_Id;
4127 -- Extract the attributes of the body
4129 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
4131 if Present (Body_Id) then
4132 Body_Decl := Unit_Declaration_Node (Body_Id);
4134 end Extract_Protected_Subprogram_Attributes;
4136 -----------------------------------
4137 -- Extract_Task_Entry_Attributes --
4138 -----------------------------------
4140 procedure Extract_Task_Entry_Attributes
4141 (Spec_Id : out Entity_Id;
4142 Body_Decl : out Node_Id)
4144 Task_Typ : constant Entity_Id := Non_Private_View (Scope (Target_Id));
4145 Body_Id : Entity_Id;
4148 -- Assume that the body is not available
4152 -- The the task type has already been expanded, it carries the
4153 -- procedure which emulates the behavior of the task body.
4155 if Present (Task_Body_Procedure (Task_Typ)) then
4156 Spec_Id := Task_Body_Procedure (Task_Typ);
4158 -- Otherwise no expansion took place
4161 Spec_Id := Task_Typ;
4164 -- Extract the attributes of the body
4166 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
4168 if Present (Body_Id) then
4169 Body_Decl := Unit_Declaration_Node (Body_Id);
4171 end Extract_Task_Entry_Attributes;
4175 Prag : constant Node_Id := SPARK_Pragma (Target_Id);
4176 Body_Barf : Node_Id;
4177 Body_Decl : Node_Id;
4178 Spec_Id : Entity_Id;
4180 -- Start of processing for Extract_Target_Attributes
4183 -- Assume that the body of the barrier function is not available
4187 -- The target is a protected entry [family]
4189 if Is_Protected_Entry (Target_Id) then
4190 Extract_Protected_Entry_Attributes
4191 (Spec_Id => Spec_Id,
4192 Body_Decl => Body_Decl,
4193 Body_Barf => Body_Barf);
4195 -- The target is a protected subprogram
4197 elsif Is_Protected_Subp (Target_Id)
4198 or else Is_Protected_Body_Subp (Target_Id)
4200 Extract_Protected_Subprogram_Attributes
4201 (Spec_Id => Spec_Id,
4202 Body_Decl => Body_Decl);
4204 -- The target is a task entry [family]
4206 elsif Is_Task_Entry (Target_Id) then
4207 Extract_Task_Entry_Attributes
4208 (Spec_Id => Spec_Id,
4209 Body_Decl => Body_Decl);
4211 -- Otherwise the target is a package or a subprogram
4214 Extract_Package_Or_Subprogram_Attributes
4215 (Spec_Id => Spec_Id,
4216 Body_Decl => Body_Decl);
4219 -- Set all attributes
4221 Attrs.Body_Barf := Body_Barf;
4222 Attrs.Body_Decl := Body_Decl;
4223 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Target_Id);
4224 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Target_Id);
4225 Attrs.From_Source := Comes_From_Source (Target_Id);
4226 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Target_Id);
4227 Attrs.SPARK_Mode_On :=
4228 Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On;
4229 Attrs.Spec_Decl := Unit_Declaration_Node (Spec_Id);
4230 Attrs.Spec_Id := Spec_Id;
4231 Attrs.Unit_Id := Find_Top_Unit (Target_Id);
4233 -- At this point certain attributes should always be available
4235 pragma Assert (Present (Attrs.Spec_Decl));
4236 pragma Assert (Present (Attrs.Spec_Id));
4237 pragma Assert (Present (Attrs.Unit_Id));
4238 end Extract_Target_Attributes;
4240 -----------------------------
4241 -- Extract_Task_Attributes --
4242 -----------------------------
4244 procedure Extract_Task_Attributes
4246 Attrs : out Task_Attributes)
4248 Task_Typ : constant Entity_Id := Non_Private_View (Typ);
4250 Body_Decl : Node_Id;
4251 Body_Id : Entity_Id;
4253 Spec_Id : Entity_Id;
4256 -- Assume that the body of the task procedure is not available
4260 -- The initial declaration is that of the task body procedure
4262 Spec_Id := Get_Task_Body_Procedure (Task_Typ);
4263 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
4265 if Present (Body_Id) then
4266 Body_Decl := Unit_Declaration_Node (Body_Id);
4269 Prag := SPARK_Pragma (Task_Typ);
4271 -- Set all attributes
4273 Attrs.Body_Decl := Body_Decl;
4274 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Task_Typ);
4275 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Task_Typ);
4276 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Task_Typ);
4277 Attrs.SPARK_Mode_On :=
4278 Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On;
4279 Attrs.Spec_Id := Spec_Id;
4280 Attrs.Task_Decl := Declaration_Node (Task_Typ);
4281 Attrs.Unit_Id := Find_Top_Unit (Task_Typ);
4283 -- At this point certain attributes should always be available
4285 pragma Assert (Present (Attrs.Spec_Id));
4286 pragma Assert (Present (Attrs.Task_Decl));
4287 pragma Assert (Present (Attrs.Unit_Id));
4288 end Extract_Task_Attributes;
4290 -------------------------------------------
4291 -- Extract_Variable_Reference_Attributes --
4292 -------------------------------------------
4294 procedure Extract_Variable_Reference_Attributes
4296 Var_Id : out Entity_Id;
4297 Attrs : out Variable_Attributes)
4299 function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id;
4300 -- Obtain the ultimate renamed variable of variable Id
4302 --------------------------
4303 -- Get_Renamed_Variable --
4304 --------------------------
4306 function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id is
4311 while Present (Renamed_Entity (Ren_Id))
4312 and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity
4314 Ren_Id := Renamed_Entity (Ren_Id);
4318 end Get_Renamed_Variable;
4320 -- Start of processing for Extract_Variable_Reference_Attributes
4323 -- Extraction for variable reference markers
4325 if Nkind (Ref) = N_Variable_Reference_Marker then
4326 Var_Id := Target (Ref);
4328 -- Extraction for expanded names and identifiers
4331 Var_Id := Entity (Ref);
4334 -- Obtain the original variable which the reference mentions
4336 Var_Id := Get_Renamed_Variable (Var_Id);
4337 Attrs.Unit_Id := Find_Top_Unit (Var_Id);
4339 -- At this point certain attributes should always be available
4341 pragma Assert (Present (Attrs.Unit_Id));
4342 end Extract_Variable_Reference_Attributes;
4344 --------------------
4345 -- Find_Code_Unit --
4346 --------------------
4348 function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id is
4350 return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (N))));
4353 ----------------------------
4354 -- Find_Early_Call_Region --
4355 ----------------------------
4357 function Find_Early_Call_Region
4358 (Body_Decl : Node_Id;
4359 Assume_Elab_Body : Boolean := False;
4360 Skip_Memoization : Boolean := False) return Node_Id
4362 -- NOTE: The routines within Find_Early_Call_Region are intentionally
4363 -- unnested to avoid deep indentation of code.
4365 ECR_Found : exception;
4366 -- This exception is raised when the early call region has been found
4368 Start : Node_Id := Empty;
4369 -- The start of the early call region. This variable is updated by the
4370 -- various nested routines. Due to the use of exceptions, the variable
4371 -- must be global to the nested routines.
4373 -- The algorithm implemented in this routine attempts to find the early
4374 -- call region of a subprogram body by inspecting constructs in reverse
4375 -- declarative order, while navigating the tree. The algorithm consists
4376 -- of an Inspection phase and an Advancement phase. The pseudocode is as
4381 -- advancement phase
4384 -- The infinite loop is terminated by raising exception ECR_Found. The
4385 -- algorithm utilizes two pointers, Curr and Start, to represent the
4386 -- current construct to inspect and the start of the early call region.
4388 -- IMPORTANT: The algorithm must maintain the following invariant at all
4389 -- time for it to function properly - a nested construct is entered only
4390 -- when it contains suitable constructs. This guarantees that leaving a
4391 -- nested or encapsulating construct functions properly.
4393 -- The Inspection phase determines whether the current construct is non-
4394 -- preelaborable, and if it is, the algorithm terminates.
4396 -- The Advancement phase walks the tree in reverse declarative order,
4397 -- while entering and leaving nested and encapsulating constructs. It
4398 -- may also terminate the elaborithm. There are several special cases
4405 -- <construct N-1> <- Curr
4406 -- <construct N> <- Start
4407 -- <subprogram body>
4409 -- In the general case, a declarative or statement list is traversed in
4410 -- reverse order where Curr is the lead pointer, and Start indicates the
4411 -- last preelaborable construct.
4413 -- 2) Entering handled bodies
4415 -- package body Nested is <- Curr (2.3)
4416 -- <declarations> <- Curr (2.2)
4418 -- <statements> <- Curr (2.1)
4420 -- <construct> <- Start
4422 -- In this case, the algorithm enters a handled body by starting from
4423 -- the last statement (2.1), or the last declaration (2.2), or the body
4424 -- is consumed (2.3) because it is empty and thus preelaborable.
4426 -- 3) Entering package declarations
4428 -- package Nested is <- Curr (2.3)
4429 -- <visible declarations> <- Curr (2.2)
4431 -- <private declarations> <- Curr (2.1)
4433 -- <construct> <- Start
4435 -- In this case, the algorithm enters a package declaration by starting
4436 -- from the last private declaration (2.1), the last visible declaration
4437 -- (2.2), or the package is consumed (2.3) because it is empty and thus
4440 -- 4) Transitioning from list to list of the same construct
4442 -- Certain constructs have two eligible lists. The algorithm must thus
4443 -- transition from the second to the first list when the second list is
4446 -- declare <- Curr (4.2)
4447 -- <declarations> <- Curr (4.1)
4449 -- <statements> <- Start
4452 -- In this case, the algorithm has exhausted the second list (statements
4453 -- in the example), and continues with the last declaration (4.1) or the
4454 -- construct is consumed (4.2) because it contains only preelaborable
4457 -- 5) Transitioning from list to construct
4459 -- tack body Task is <- Curr (5.1)
4461 -- <construct 1> <- Start
4463 -- In this case, the algorithm has exhausted a list, Curr is Empty, and
4464 -- the owner of the list is consumed (5.1).
4466 -- 6) Transitioning from unit to unit
4468 -- A package body with a spec subject to pragma Elaborate_Body extends
4469 -- the possible range of the early call region to the package spec.
4471 -- package Pack is <- Curr (6.3)
4472 -- pragma Elaborate_Body; <- Curr (6.2)
4473 -- <visible declarations> <- Curr (6.2)
4475 -- <private declarations> <- Curr (6.1)
4478 -- package body Pack is <- Curr, Start
4480 -- In this case, the algorithm has reached a package body compilation
4481 -- unit whose spec is subject to pragma Elaborate_Body, or the caller
4482 -- of the algorithm has specified this behavior. This transition is
4483 -- equivalent to 3).
4485 -- 7) Transitioning from unit to termination
4487 -- Reaching a compilation unit always terminates the algorithm as there
4488 -- are no more lists to examine. This must take 6) into account.
4490 -- 8) Transitioning from subunit to stub
4492 -- package body Pack is separate; <- Curr (8.1)
4495 -- package body Pack is <- Curr, Start
4497 -- Reaching a subunit continues the search from the corresponding stub
4500 procedure Advance (Curr : in out Node_Id);
4501 pragma Inline (Advance);
4502 -- Update the Curr and Start pointers depending on their location in the
4503 -- tree to the next eligible construct. This routine raises ECR_Found.
4505 procedure Enter_Handled_Body (Curr : in out Node_Id);
4506 pragma Inline (Enter_Handled_Body);
4507 -- Update the Curr and Start pointers to enter a nested handled body if
4508 -- applicable. This routine raises ECR_Found.
4510 procedure Enter_Package_Declaration (Curr : in out Node_Id);
4511 pragma Inline (Enter_Package_Declaration);
4512 -- Update the Curr and Start pointers to enter a nested package spec if
4513 -- applicable. This routine raises ECR_Found.
4515 function Find_ECR (N : Node_Id) return Node_Id;
4516 pragma Inline (Find_ECR);
4517 -- Find an early call region starting from arbitrary node N
4519 function Has_Suitable_Construct (List : List_Id) return Boolean;
4520 pragma Inline (Has_Suitable_Construct);
4521 -- Determine whether list List contains at least one suitable construct
4522 -- for inclusion into an early call region.
4524 procedure Include (N : Node_Id; Curr : out Node_Id);
4525 pragma Inline (Include);
4526 -- Update the Curr and Start pointers to include arbitrary construct N
4527 -- in the early call region. This routine raises ECR_Found.
4529 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean;
4530 pragma Inline (Is_OK_Preelaborable_Construct);
4531 -- Determine whether arbitrary node N denotes a preelaboration-safe
4534 function Is_Suitable_Construct (N : Node_Id) return Boolean;
4535 pragma Inline (Is_Suitable_Construct);
4536 -- Determine whether arbitrary node N denotes a suitable construct for
4537 -- inclusion into the early call region.
4539 procedure Transition_Body_Declarations
4541 Curr : out Node_Id);
4542 pragma Inline (Transition_Body_Declarations);
4543 -- Update the Curr and Start pointers when construct Bod denotes a block
4544 -- statement or a suitable body. This routine raises ECR_Found.
4546 procedure Transition_Handled_Statements
4548 Curr : out Node_Id);
4549 pragma Inline (Transition_Handled_Statements);
4550 -- Update the Curr and Start pointers when node HSS denotes a handled
4551 -- sequence of statements. This routine raises ECR_Found.
4553 procedure Transition_Spec_Declarations
4555 Curr : out Node_Id);
4556 pragma Inline (Transition_Spec_Declarations);
4557 -- Update the Curr and Start pointers when construct Spec denotes
4558 -- a concurrent definition or a package spec. This routine raises
4561 procedure Transition_Unit (Unit : Node_Id; Curr : out Node_Id);
4562 pragma Inline (Transition_Unit);
4563 -- Update the Curr and Start pointers when node Unit denotes a potential
4564 -- compilation unit. This routine raises ECR_Found.
4570 procedure Advance (Curr : in out Node_Id) is
4574 -- Curr denotes one of the following cases upon entry into this
4577 -- * Empty - There is no current construct when a declarative or a
4578 -- statement list has been exhausted. This does not necessarily
4579 -- indicate that the early call region has been computed as it
4580 -- may still be possible to transition to another list.
4582 -- * Encapsulator - The current construct encapsulates declarations
4583 -- and/or statements. This indicates that the early call region
4584 -- may extend within the nested construct.
4586 -- * Preelaborable - The current construct is always preelaborable
4587 -- because Find_ECR would not invoke Advance if this was not the
4590 -- The current construct is an encapsulator or is preelaborable
4592 if Present (Curr) then
4594 -- Enter encapsulators by inspecting their declarations and/or
4597 if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then
4598 Enter_Handled_Body (Curr);
4600 elsif Nkind (Curr) = N_Package_Declaration then
4601 Enter_Package_Declaration (Curr);
4603 -- Early call regions have a property which can be exploited to
4604 -- optimize the algorithm.
4606 -- <preceding subprogram body>
4607 -- <preelaborable construct 1>
4609 -- <preelaborable construct N>
4610 -- <initiating subprogram body>
4612 -- If a traversal initiated from a subprogram body reaches a
4613 -- preceding subprogram body, then both bodies share the same
4614 -- early call region.
4616 -- The property results in the following desirable effects:
4618 -- * If the preceding body already has an early call region, then
4619 -- the initiating body can reuse it. This minimizes the amount
4620 -- of processing performed by the algorithm.
4622 -- * If the preceding body lack an early call region, then the
4623 -- algorithm can compute the early call region, and reuse it
4624 -- for the initiating body. This processing performs the same
4625 -- amount of work, but has the beneficial effect of computing
4626 -- the early call regions of all preceding bodies.
4628 elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then
4630 Find_Early_Call_Region
4632 Assume_Elab_Body => Assume_Elab_Body,
4633 Skip_Memoization => Skip_Memoization);
4637 -- Otherwise current construct is preelaborable. Unpdate the early
4638 -- call region to include it.
4641 Include (Curr, Curr);
4644 -- Otherwise the current construct is missing, indicating that the
4645 -- current list has been exhausted. Depending on the context of the
4646 -- list, several transitions are possible.
4649 -- The invariant of the algorithm ensures that Curr and Start are
4650 -- at the same level of nesting at the point of a transition. The
4651 -- algorithm can determine which list the traversal came from by
4654 Context := Parent (Start);
4656 -- Attempt the following transitions:
4658 -- private declarations -> visible declarations
4659 -- private declarations -> upper level
4660 -- private declarations -> terminate
4661 -- visible declarations -> upper level
4662 -- visible declarations -> terminate
4664 if Nkind_In (Context, N_Package_Specification,
4665 N_Protected_Definition,
4668 Transition_Spec_Declarations (Context, Curr);
4670 -- Attempt the following transitions:
4672 -- statements -> declarations
4673 -- statements -> upper level
4674 -- statements -> corresponding package spec (Elab_Body)
4675 -- statements -> terminate
4677 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
4678 Transition_Handled_Statements (Context, Curr);
4680 -- Attempt the following transitions:
4682 -- declarations -> upper level
4683 -- declarations -> corresponding package spec (Elab_Body)
4684 -- declarations -> terminate
4686 elsif Nkind_In (Context, N_Block_Statement,
4693 Transition_Body_Declarations (Context, Curr);
4695 -- Otherwise it is not possible to transition. Stop the search
4696 -- because there are no more declarations or statements to check.
4704 --------------------------
4705 -- Enter_Handled_Body --
4706 --------------------------
4708 procedure Enter_Handled_Body (Curr : in out Node_Id) is
4709 Decls : constant List_Id := Declarations (Curr);
4710 HSS : constant Node_Id := Handled_Statement_Sequence (Curr);
4711 Stmts : List_Id := No_List;
4714 if Present (HSS) then
4715 Stmts := Statements (HSS);
4718 -- The handled body has a non-empty statement sequence. The construct
4719 -- to inspect is the last statement.
4721 if Has_Suitable_Construct (Stmts) then
4722 Curr := Last (Stmts);
4724 -- The handled body lacks statements, but has non-empty declarations.
4725 -- The construct to inspect is the last declaration.
4727 elsif Has_Suitable_Construct (Decls) then
4728 Curr := Last (Decls);
4730 -- Otherwise the handled body lacks both declarations and statements.
4731 -- The construct to inspect is the node which precedes the handled
4732 -- body. Update the early call region to include the handled body.
4735 Include (Curr, Curr);
4737 end Enter_Handled_Body;
4739 -------------------------------
4740 -- Enter_Package_Declaration --
4741 -------------------------------
4743 procedure Enter_Package_Declaration (Curr : in out Node_Id) is
4744 Pack_Spec : constant Node_Id := Specification (Curr);
4745 Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec);
4746 Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec);
4749 -- The package has a non-empty private declarations. The construct to
4750 -- inspect is the last private declaration.
4752 if Has_Suitable_Construct (Prv_Decls) then
4753 Curr := Last (Prv_Decls);
4755 -- The package lacks private declarations, but has non-empty visible
4756 -- declarations. In this case the construct to inspect is the last
4757 -- visible declaration.
4759 elsif Has_Suitable_Construct (Vis_Decls) then
4760 Curr := Last (Vis_Decls);
4762 -- Otherwise the package lacks any declarations. The construct to
4763 -- inspect is the node which precedes the package. Update the early
4764 -- call region to include the package declaration.
4767 Include (Curr, Curr);
4769 end Enter_Package_Declaration;
4775 function Find_ECR (N : Node_Id) return Node_Id is
4779 -- The early call region starts at N
4784 -- Inspect each node in reverse declarative order while going in and
4785 -- out of nested and enclosing constructs. Note that the only way to
4786 -- terminate this infinite loop is to raise exception ECR_Found.
4789 -- The current construct is not preelaboration-safe. Terminate the
4793 and then not Is_OK_Preelaborable_Construct (Curr)
4798 -- Advance to the next suitable construct. This may terminate the
4799 -- traversal by raising ECR_Found.
4809 ----------------------------
4810 -- Has_Suitable_Construct --
4811 ----------------------------
4813 function Has_Suitable_Construct (List : List_Id) return Boolean is
4817 -- Examine the list in reverse declarative order, looking for a
4818 -- suitable construct.
4820 if Present (List) then
4821 Item := Last (List);
4822 while Present (Item) loop
4823 if Is_Suitable_Construct (Item) then
4832 end Has_Suitable_Construct;
4838 procedure Include (N : Node_Id; Curr : out Node_Id) is
4842 -- The input node is a compilation unit. This terminates the search
4843 -- because there are no more lists to inspect and there are no more
4844 -- enclosing constructs to climb up to. The transitions are:
4846 -- private declarations -> terminate
4847 -- visible declarations -> terminate
4848 -- statements -> terminate
4849 -- declarations -> terminate
4851 if Nkind (Parent (Start)) = N_Compilation_Unit then
4854 -- Otherwise the input node is still within some list
4857 Curr := Prev (Start);
4861 -----------------------------------
4862 -- Is_OK_Preelaborable_Construct --
4863 -----------------------------------
4865 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is
4867 -- Assignment statements are acceptable as long as they were produced
4868 -- by the ABE mechanism to update elaboration flags.
4870 if Nkind (N) = N_Assignment_Statement then
4871 return Is_Elaboration_Code (N);
4873 -- Block statements are acceptable even though they directly violate
4874 -- preelaborability. The intention is not to penalize the early call
4875 -- region when a block contains only preelaborable constructs.
4878 -- Val : constant Integer := 1;
4880 -- pragma Assert (Val = 1);
4884 -- Note that the Advancement phase does enter blocks, and will detect
4885 -- any non-preelaborable declarations or statements within.
4887 elsif Nkind (N) = N_Block_Statement then
4891 -- Otherwise the construct must be preelaborable. The check must take
4892 -- the syntactic and semantic structure of the construct. DO NOT use
4893 -- Is_Preelaborable_Construct here.
4895 return not Is_Non_Preelaborable_Construct (N);
4896 end Is_OK_Preelaborable_Construct;
4898 ---------------------------
4899 -- Is_Suitable_Construct --
4900 ---------------------------
4902 function Is_Suitable_Construct (N : Node_Id) return Boolean is
4903 Context : constant Node_Id := Parent (N);
4906 -- An internally-generated statement sequence which contains only a
4907 -- single null statement is not a suitable construct because it is a
4908 -- byproduct of the parser. Such a null statement should be excluded
4909 -- from the early call region because it carries the source location
4910 -- of the "end" keyword, and may lead to confusing diagnistics.
4912 if Nkind (N) = N_Null_Statement
4913 and then not Comes_From_Source (N)
4914 and then Present (Context)
4915 and then Nkind (Context) = N_Handled_Sequence_Of_Statements
4916 and then not Comes_From_Source (N)
4921 -- Otherwise only constructs which correspond to pure Ada constructs
4922 -- are considered suitable.
4927 | N_Freeze_Generic_Entity
4928 | N_Implicit_Label_Declaration
4930 | N_Pop_Constraint_Error_Label
4931 | N_Pop_Program_Error_Label
4932 | N_Pop_Storage_Error_Label
4933 | N_Push_Constraint_Error_Label
4934 | N_Push_Program_Error_Label
4935 | N_Push_Storage_Error_Label
4936 | N_SCIL_Dispatch_Table_Tag_Init
4937 | N_SCIL_Dispatching_Call
4938 | N_SCIL_Membership_Test
4939 | N_Variable_Reference_Marker
4946 end Is_Suitable_Construct;
4948 ----------------------------------
4949 -- Transition_Body_Declarations --
4950 ----------------------------------
4952 procedure Transition_Body_Declarations
4956 Decls : constant List_Id := Declarations (Bod);
4959 -- The search must come from the declarations of the body
4962 (Is_Non_Empty_List (Decls)
4963 and then List_Containing (Start) = Decls);
4965 -- The search finished inspecting the declarations. The construct
4966 -- to inspect is the node which precedes the handled body, unless
4967 -- the body is a compilation unit. The transitions are:
4969 -- declarations -> upper level
4970 -- declarations -> corresponding package spec (Elab_Body)
4971 -- declarations -> terminate
4973 Transition_Unit (Bod, Curr);
4974 end Transition_Body_Declarations;
4976 -----------------------------------
4977 -- Transition_Handled_Statements --
4978 -----------------------------------
4980 procedure Transition_Handled_Statements
4984 Bod : constant Node_Id := Parent (HSS);
4985 Decls : constant List_Id := Declarations (Bod);
4986 Stmts : constant List_Id := Statements (HSS);
4989 -- The search must come from the statements of certain bodies or
4992 pragma Assert (Nkind_In (Bod, N_Block_Statement,
4999 -- The search must come from the statements of the handled sequence
5002 (Is_Non_Empty_List (Stmts)
5003 and then List_Containing (Start) = Stmts);
5005 -- The search finished inspecting the statements. The handled body
5006 -- has non-empty declarations. The construct to inspect is the last
5007 -- declaration. The transitions are:
5009 -- statements -> declarations
5011 if Has_Suitable_Construct (Decls) then
5012 Curr := Last (Decls);
5014 -- Otherwise the handled body lacks declarations. The construct to
5015 -- inspect is the node which precedes the handled body, unless the
5016 -- body is a compilation unit. The transitions are:
5018 -- statements -> upper level
5019 -- statements -> corresponding package spec (Elab_Body)
5020 -- statements -> terminate
5023 Transition_Unit (Bod, Curr);
5025 end Transition_Handled_Statements;
5027 ----------------------------------
5028 -- Transition_Spec_Declarations --
5029 ----------------------------------
5031 procedure Transition_Spec_Declarations
5035 Prv_Decls : constant List_Id := Private_Declarations (Spec);
5036 Vis_Decls : constant List_Id := Visible_Declarations (Spec);
5039 pragma Assert (Present (Start) and then Is_List_Member (Start));
5041 -- The search came from the private declarations and finished their
5044 if Has_Suitable_Construct (Prv_Decls)
5045 and then List_Containing (Start) = Prv_Decls
5047 -- The context has non-empty visible declarations. The node to
5048 -- inspect is the last visible declaration. The transitions are:
5050 -- private declarations -> visible declarations
5052 if Has_Suitable_Construct (Vis_Decls) then
5053 Curr := Last (Vis_Decls);
5055 -- Otherwise the context lacks visible declarations. The construct
5056 -- to inspect is the node which precedes the context unless the
5057 -- context is a compilation unit. The transitions are:
5059 -- private declarations -> upper level
5060 -- private declarations -> terminate
5063 Transition_Unit (Parent (Spec), Curr);
5066 -- The search came from the visible declarations and finished their
5067 -- inspections. The construct to inspect is the node which precedes
5068 -- the context, unless the context is a compilaton unit. The
5071 -- visible declarations -> upper level
5072 -- visible declarations -> terminate
5074 elsif Has_Suitable_Construct (Vis_Decls)
5075 and then List_Containing (Start) = Vis_Decls
5077 Transition_Unit (Parent (Spec), Curr);
5079 -- At this point both declarative lists are empty, but the traversal
5080 -- still came from within the spec. This indicates that the invariant
5081 -- of the algorithm has been violated.
5084 pragma Assert (False);
5087 end Transition_Spec_Declarations;
5089 ---------------------
5090 -- Transition_Unit --
5091 ---------------------
5093 procedure Transition_Unit
5097 Context : constant Node_Id := Parent (Unit);
5100 -- The unit is a compilation unit. This terminates the search because
5101 -- there are no more lists to inspect and there are no more enclosing
5102 -- constructs to climb up to.
5104 if Nkind (Context) = N_Compilation_Unit then
5106 -- A package body with a corresponding spec subject to pragma
5107 -- Elaborate_Body is an exception to the above. The annotation
5108 -- allows the search to continue into the package declaration.
5109 -- The transitions are:
5111 -- statements -> corresponding package spec (Elab_Body)
5112 -- declarations -> corresponding package spec (Elab_Body)
5114 if Nkind (Unit) = N_Package_Body
5115 and then (Assume_Elab_Body
5116 or else Has_Pragma_Elaborate_Body
5117 (Corresponding_Spec (Unit)))
5119 Curr := Unit_Declaration_Node (Corresponding_Spec (Unit));
5120 Enter_Package_Declaration (Curr);
5122 -- Otherwise terminate the search. The transitions are:
5124 -- private declarations -> terminate
5125 -- visible declarations -> terminate
5126 -- statements -> terminate
5127 -- declarations -> terminate
5133 -- The unit is a subunit. The construct to inspect is the node which
5134 -- precedes the corresponding stub. Update the early call region to
5135 -- include the unit.
5137 elsif Nkind (Context) = N_Subunit then
5139 Curr := Corresponding_Stub (Context);
5141 -- Otherwise the unit is nested. The construct to inspect is the node
5142 -- which precedes the unit. Update the early call region to include
5146 Include (Unit, Curr);
5148 end Transition_Unit;
5152 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
5155 -- Start of processing for Find_Early_Call_Region
5158 -- The caller demands the start of the early call region without saving
5159 -- or retrieving it to/from internal data structures.
5161 if Skip_Memoization then
5162 Region := Find_ECR (Body_Decl);
5167 -- Check whether the early call region of the subprogram body is
5170 Region := Early_Call_Region (Body_Id);
5174 -- Traverse the declarations in reverse order, starting from the
5175 -- subprogram body, searching for the nearest non-preelaborable
5176 -- construct. The early call region starts after this construct
5177 -- and ends at the subprogram body.
5179 Region := Find_ECR (Body_Decl);
5181 -- Associate the early call region with the subprogram body in
5182 -- case other scenarios need it.
5184 Set_Early_Call_Region (Body_Id, Region);
5188 -- A subprogram body must always have an early call region
5190 pragma Assert (Present (Region));
5193 end Find_Early_Call_Region;
5195 ---------------------------
5196 -- Find_Elaborated_Units --
5197 ---------------------------
5199 procedure Find_Elaborated_Units is
5200 procedure Add_Pragma (Prag : Node_Id);
5201 -- Determine whether pragma Prag denotes a legal Elaborate[_All] pragma.
5202 -- If this is the case, add the related unit to the elaboration context.
5203 -- For pragma Elaborate_All, include recursively all units withed by the
5207 (Unit_Id : Entity_Id;
5209 Full_Context : Boolean);
5210 -- Add unit Unit_Id to the elaboration context. Prag denotes the pragma
5211 -- which prompted the inclusion of the unit to the elaboration context.
5212 -- If flag Full_Context is set, examine the nonlimited clauses of unit
5213 -- Unit_Id and add each withed unit to the context.
5215 procedure Find_Elaboration_Context (Comp_Unit : Node_Id);
5216 -- Examine the context items of compilation unit Comp_Unit for suitable
5217 -- elaboration-related pragmas and add all related units to the context.
5223 procedure Add_Pragma (Prag : Node_Id) is
5224 Prag_Args : constant List_Id := Pragma_Argument_Associations (Prag);
5225 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
5229 -- Nothing to do if the pragma is not related to elaboration
5231 if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then
5234 -- Nothing to do when the pragma is illegal
5236 elsif Error_Posted (Prag) then
5240 Unit_Arg := Get_Pragma_Arg (First (Prag_Args));
5242 -- The argument of the pragma may appear in package.package form
5244 if Nkind (Unit_Arg) = N_Selected_Component then
5245 Unit_Arg := Selector_Name (Unit_Arg);
5249 (Unit_Id => Entity (Unit_Arg),
5251 Full_Context => Prag_Nam = Name_Elaborate_All);
5259 (Unit_Id : Entity_Id;
5261 Full_Context : Boolean)
5264 Elab_Attrs : Elaboration_Attributes;
5267 -- Nothing to do when some previous error left a with clause or a
5268 -- pragma in a bad state.
5270 if No (Unit_Id) then
5274 Elab_Attrs := Elaboration_Status (Unit_Id);
5276 -- The unit is already included in the context by means of pragma
5279 if Present (Elab_Attrs.Source_Pragma) then
5281 -- Upgrade an existing pragma Elaborate when the unit is subject
5282 -- to Elaborate_All because the new pragma covers a larger set of
5285 if Pragma_Name (Elab_Attrs.Source_Pragma) = Name_Elaborate
5286 and then Pragma_Name (Prag) = Name_Elaborate_All
5288 Elab_Attrs.Source_Pragma := Prag;
5290 -- Otherwise the unit retains its existing pragma and does not
5291 -- need to be included in the context again.
5297 -- The current unit is not part of the context. Prepare a new set of
5302 Elaboration_Attributes'(Source_Pragma
=> Prag
,
5303 With_Clause
=> Empty
);
5306 -- Add or update the attributes of the unit
5308 Set_Elaboration_Status
(Unit_Id
, Elab_Attrs
);
5310 -- Includes all units withed by the current one when computing the
5313 if Full_Context
then
5315 -- Process all nonlimited with clauses found in the context of
5316 -- the current unit. Note that limited clauses do not impose an
5317 -- elaboration order.
5319 Clause
:= First
(Context_Items
(Compilation_Unit
(Unit_Id
)));
5320 while Present
(Clause
) loop
5321 if Nkind
(Clause
) = N_With_Clause
5322 and then not Error_Posted
(Clause
)
5323 and then not Limited_Present
(Clause
)
5326 (Unit_Id
=> Entity
(Name
(Clause
)),
5328 Full_Context
=> Full_Context
);
5336 ------------------------------
5337 -- Find_Elaboration_Context --
5338 ------------------------------
5340 procedure Find_Elaboration_Context
(Comp_Unit
: Node_Id
) is
5344 pragma Assert
(Nkind
(Comp_Unit
) = N_Compilation_Unit
);
5346 -- Process all elaboration-related pragmas found in the context of
5347 -- the compilation unit.
5349 Prag
:= First
(Context_Items
(Comp_Unit
));
5350 while Present
(Prag
) loop
5351 if Nkind
(Prag
) = N_Pragma
then
5357 end Find_Elaboration_Context
;
5364 -- Start of processing for Find_Elaborated_Units
5367 -- Perform a traversal which examines the context of the main unit and
5368 -- populates the Elaboration_Context table with all units elaborated
5369 -- prior to the main unit. The traversal performs the following jumps:
5371 -- subunit -> parent subunit
5372 -- parent subunit -> body
5374 -- spec -> parent spec
5375 -- parent spec -> grandparent spec and so on
5377 -- The traversal relies on units rather than scopes because the scope of
5378 -- a subunit is some spec, while this traversal must process the body as
5379 -- well. Given that protected and task bodies can also be subunits, this
5380 -- complicates the scope approach even further.
5382 Unt
:= Unit
(Cunit
(Main_Unit
));
5384 -- Perform the following traversals when the main unit is a subunit
5386 -- subunit -> parent subunit
5387 -- parent subunit -> body
5389 while Present
(Unt
) and then Nkind
(Unt
) = N_Subunit
loop
5390 Find_Elaboration_Context
(Parent
(Unt
));
5392 -- Continue the traversal by going to the unit which contains the
5393 -- corresponding stub.
5395 if Present
(Corresponding_Stub
(Unt
)) then
5396 Unt
:= Unit
(Cunit
(Get_Source_Unit
(Corresponding_Stub
(Unt
))));
5398 -- Otherwise the subunit may be erroneous or left in a bad state
5405 -- Perform the following traversal now that subunits have been taken
5406 -- care of, or the main unit is a body.
5411 and then Nkind_In
(Unt
, N_Package_Body
, N_Subprogram_Body
)
5413 Find_Elaboration_Context
(Parent
(Unt
));
5415 -- Continue the traversal by going to the unit which contains the
5416 -- corresponding spec.
5418 if Present
(Corresponding_Spec
(Unt
)) then
5419 Unt
:= Unit
(Cunit
(Get_Source_Unit
(Corresponding_Spec
(Unt
))));
5423 -- Perform the following traversals now that the body has been taken
5424 -- care of, or the main unit is a spec.
5426 -- spec -> parent spec
5427 -- parent spec -> grandparent spec and so on
5430 and then Nkind_In
(Unt
, N_Generic_Package_Declaration
,
5431 N_Generic_Subprogram_Declaration
,
5432 N_Package_Declaration
,
5433 N_Subprogram_Declaration
)
5435 Find_Elaboration_Context
(Parent
(Unt
));
5437 -- Process a potential chain of parent units which ends with the
5438 -- main unit spec. The traversal can now safely rely on the scope
5441 Par_Id
:= Scope
(Defining_Entity
(Unt
));
5442 while Present
(Par_Id
) and then Par_Id
/= Standard_Standard
loop
5443 Find_Elaboration_Context
(Compilation_Unit
(Par_Id
));
5445 Par_Id
:= Scope
(Par_Id
);
5448 end Find_Elaborated_Units
;
5450 -----------------------------
5451 -- Find_Enclosing_Instance --
5452 -----------------------------
5454 function Find_Enclosing_Instance
(N
: Node_Id
) return Node_Id
is
5456 Spec_Id
: Entity_Id
;
5459 -- Climb the parent chain looking for an enclosing instance spec or body
5462 while Present
(Par
) loop
5464 -- Generic package or subprogram spec
5466 if Nkind_In
(Par
, N_Package_Declaration
,
5467 N_Subprogram_Declaration
)
5468 and then Is_Generic_Instance
(Defining_Entity
(Par
))
5472 -- Generic package or subprogram body
5474 elsif Nkind_In
(Par
, N_Package_Body
, N_Subprogram_Body
) then
5475 Spec_Id
:= Corresponding_Spec
(Par
);
5477 if Present
(Spec_Id
) and then Is_Generic_Instance
(Spec_Id
) then
5482 Par
:= Parent
(Par
);
5486 end Find_Enclosing_Instance
;
5488 --------------------------
5489 -- Find_Enclosing_Level --
5490 --------------------------
5492 function Find_Enclosing_Level
(N
: Node_Id
) return Enclosing_Level_Kind
is
5493 function Level_Of
(Unit
: Node_Id
) return Enclosing_Level_Kind
;
5494 -- Obtain the corresponding level of unit Unit
5500 function Level_Of
(Unit
: Node_Id
) return Enclosing_Level_Kind
is
5501 Spec_Id
: Entity_Id
;
5504 if Nkind
(Unit
) in N_Generic_Instantiation
then
5505 return Instantiation
;
5507 elsif Nkind
(Unit
) = N_Generic_Package_Declaration
then
5508 return Generic_Package_Spec
;
5510 elsif Nkind
(Unit
) = N_Package_Declaration
then
5511 return Package_Spec
;
5513 elsif Nkind
(Unit
) = N_Package_Body
then
5514 Spec_Id
:= Corresponding_Spec
(Unit
);
5516 -- The body belongs to a generic package
5518 if Present
(Spec_Id
)
5519 and then Ekind
(Spec_Id
) = E_Generic_Package
5521 return Generic_Package_Body
;
5523 -- Otherwise the body belongs to a non-generic package. This also
5524 -- treats an illegal package body without a corresponding spec as
5525 -- a non-generic package body.
5528 return Package_Body
;
5541 -- Start of processing for Find_Enclosing_Level
5544 -- Call markers and instantiations which appear at the declaration level
5545 -- but are later relocated in a different context retain their original
5546 -- declaration level.
5548 if Nkind_In
(N
, N_Call_Marker
,
5549 N_Function_Instantiation
,
5550 N_Package_Instantiation
,
5551 N_Procedure_Instantiation
)
5552 and then Is_Declaration_Level_Node
(N
)
5554 return Declaration_Level
;
5557 -- Climb the parent chain looking at the enclosing levels
5560 Curr
:= Parent
(Prev
);
5561 while Present
(Curr
) loop
5563 -- A traversal from a subunit continues via the corresponding stub
5565 if Nkind
(Curr
) = N_Subunit
then
5566 Curr
:= Corresponding_Stub
(Curr
);
5568 -- The current construct is a package. Packages are ignored because
5569 -- they are always elaborated when the enclosing context is invoked
5572 elsif Nkind_In
(Curr
, N_Package_Body
, N_Package_Declaration
) then
5575 -- The current construct is a block statement
5577 elsif Nkind
(Curr
) = N_Block_Statement
then
5579 -- Ignore internally generated blocks created by the expander for
5580 -- various purposes such as abort defer/undefer.
5582 if not Comes_From_Source
(Curr
) then
5585 -- If the traversal came from the handled sequence of statments,
5586 -- then the node appears at the level of the enclosing construct.
5587 -- This is a more reliable test because transients scopes within
5588 -- the declarative region of the encapsulator are hard to detect.
5590 elsif Nkind
(Prev
) = N_Handled_Sequence_Of_Statements
5591 and then Handled_Statement_Sequence
(Curr
) = Prev
5593 return Find_Enclosing_Level
(Parent
(Curr
));
5595 -- Otherwise the traversal came from the declarations, the node is
5596 -- at the declaration level.
5599 return Declaration_Level
;
5602 -- The current construct is a declaration-level encapsulator
5604 elsif Nkind_In
(Curr
, N_Entry_Body
,
5608 -- If the traversal came from the handled sequence of statments,
5609 -- then the node cannot possibly appear at any level. This is
5610 -- a more reliable test because transients scopes within the
5611 -- declarative region of the encapsulator are hard to detect.
5613 if Nkind
(Prev
) = N_Handled_Sequence_Of_Statements
5614 and then Handled_Statement_Sequence
(Curr
) = Prev
5618 -- Otherwise the traversal came from the declarations, the node is
5619 -- at the declaration level.
5622 return Declaration_Level
;
5625 -- The current construct is a non-library-level encapsulator which
5626 -- indicates that the node cannot possibly appear at any level.
5627 -- Note that this check must come after the declaration-level check
5628 -- because both predicates share certain nodes.
5630 elsif Is_Non_Library_Level_Encapsulator
(Curr
) then
5631 Context
:= Parent
(Curr
);
5633 -- The sole exception is when the encapsulator is the compilation
5634 -- utit itself because the compilation unit node requires special
5635 -- processing (see below).
5637 if Present
(Context
)
5638 and then Nkind
(Context
) = N_Compilation_Unit
5642 -- Otherwise the node is not at any level
5648 -- The current construct is a compilation unit. The node appears at
5649 -- the [generic] library level when the unit is a [generic] package.
5651 elsif Nkind
(Curr
) = N_Compilation_Unit
then
5652 return Level_Of
(Unit
(Curr
));
5656 Curr
:= Parent
(Prev
);
5660 end Find_Enclosing_Level
;
5666 function Find_Top_Unit
(N
: Node_Or_Entity_Id
) return Entity_Id
is
5668 return Find_Unit_Entity
(Unit
(Cunit
(Get_Top_Level_Code_Unit
(N
))));
5671 ----------------------
5672 -- Find_Unit_Entity --
5673 ----------------------
5675 function Find_Unit_Entity
(N
: Node_Id
) return Entity_Id
is
5676 Context
: constant Node_Id
:= Parent
(N
);
5677 Orig_N
: constant Node_Id
:= Original_Node
(N
);
5680 -- The unit denotes a package body of an instantiation which acts as
5681 -- a compilation unit. The proper entity is that of the package spec.
5683 if Nkind
(N
) = N_Package_Body
5684 and then Nkind
(Orig_N
) = N_Package_Instantiation
5685 and then Nkind
(Context
) = N_Compilation_Unit
5687 return Corresponding_Spec
(N
);
5689 -- The unit denotes an anonymous package created to wrap a subprogram
5690 -- instantiation which acts as a compilation unit. The proper entity is
5691 -- that of the "related instance".
5693 elsif Nkind
(N
) = N_Package_Declaration
5694 and then Nkind_In
(Orig_N
, N_Function_Instantiation
,
5695 N_Procedure_Instantiation
)
5696 and then Nkind
(Context
) = N_Compilation_Unit
5699 Related_Instance
(Defining_Entity
(N
, Concurrent_Subunit
=> True));
5701 -- Otherwise the proper entity is the defining entity
5704 return Defining_Entity
(N
, Concurrent_Subunit
=> True);
5706 end Find_Unit_Entity
;
5708 -----------------------
5709 -- First_Formal_Type --
5710 -----------------------
5712 function First_Formal_Type
(Subp_Id
: Entity_Id
) return Entity_Id
is
5713 Formal_Id
: constant Entity_Id
:= First_Formal
(Subp_Id
);
5717 if Present
(Formal_Id
) then
5718 Typ
:= Etype
(Formal_Id
);
5720 -- Handle various combinations of concurrent and private types
5723 if Ekind_In
(Typ
, E_Protected_Type
, E_Task_Type
)
5724 and then Present
(Anonymous_Object
(Typ
))
5726 Typ
:= Anonymous_Object
(Typ
);
5728 elsif Is_Concurrent_Record_Type
(Typ
) then
5729 Typ
:= Corresponding_Concurrent_Type
(Typ
);
5731 elsif Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
5732 Typ
:= Full_View
(Typ
);
5743 end First_Formal_Type
;
5749 function Has_Body
(Pack_Decl
: Node_Id
) return Boolean is
5750 function Find_Corresponding_Body
(Spec_Id
: Entity_Id
) return Node_Id
;
5751 -- Try to locate the corresponding body of spec Spec_Id. If no body is
5752 -- found, return Empty.
5755 (Spec_Id
: Entity_Id
;
5756 From
: Node_Id
) return Node_Id
;
5757 -- Try to locate the corresponding body of spec Spec_Id in the node list
5758 -- which follows arbitrary node From. If no body is found, return Empty.
5760 function Load_Package_Body
(Unit_Nam
: Unit_Name_Type
) return Node_Id
;
5761 -- Attempt to load the body of unit Unit_Nam. If the load failed, return
5762 -- Empty. If the compilation will not generate code, return Empty.
5764 -----------------------------
5765 -- Find_Corresponding_Body --
5766 -----------------------------
5768 function Find_Corresponding_Body
(Spec_Id
: Entity_Id
) return Node_Id
is
5769 Context
: constant Entity_Id
:= Scope
(Spec_Id
);
5770 Spec_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
5771 Body_Decl
: Node_Id
;
5772 Body_Id
: Entity_Id
;
5775 if Is_Compilation_Unit
(Spec_Id
) then
5776 Body_Id
:= Corresponding_Body
(Spec_Decl
);
5778 if Present
(Body_Id
) then
5779 return Unit_Declaration_Node
(Body_Id
);
5781 -- The package is at the library and requires a body. Load the
5782 -- corresponding body because the optional body may be declared
5785 elsif Unit_Requires_Body
(Spec_Id
) then
5788 (Get_Body_Name
(Unit_Name
(Get_Source_Unit
(Spec_Decl
))));
5790 -- Otherwise there is no optional body
5796 -- The immediate context is a package. The optional body may be
5797 -- within the body of that package.
5799 -- procedure Proc is
5800 -- package Nested_1 is
5801 -- package Nested_2 is
5808 -- package body Nested_1 is
5809 -- package body Nested_2 is separate;
5812 -- separate (Proc.Nested_1.Nested_2)
5813 -- package body Nested_2 is
5814 -- package body Pack is -- optional body
5819 elsif Is_Package_Or_Generic_Package
(Context
) then
5820 Body_Decl
:= Find_Corresponding_Body
(Context
);
5822 -- The optional body is within the body of the enclosing package
5824 if Present
(Body_Decl
) then
5827 (Spec_Id
=> Spec_Id
,
5828 From
=> First
(Declarations
(Body_Decl
)));
5830 -- Otherwise the enclosing package does not have a body. This may
5831 -- be the result of an error or a genuine lack of a body.
5837 -- Otherwise the immediate context is a body. The optional body may
5838 -- be within the same list as the spec.
5840 -- procedure Proc is
5845 -- package body Pack is -- optional body
5852 (Spec_Id
=> Spec_Id
,
5853 From
=> Next
(Spec_Decl
));
5855 end Find_Corresponding_Body
;
5862 (Spec_Id
: Entity_Id
;
5863 From
: Node_Id
) return Node_Id
5865 Spec_Nam
: constant Name_Id
:= Chars
(Spec_Id
);
5871 while Present
(Item
) loop
5873 -- The current item denotes the optional body
5875 if Nkind
(Item
) = N_Package_Body
5876 and then Chars
(Defining_Entity
(Item
)) = Spec_Nam
5880 -- The current item denotes a stub, the optional body may be in
5883 elsif Nkind
(Item
) = N_Package_Body_Stub
5884 and then Chars
(Defining_Entity
(Item
)) = Spec_Nam
5886 Lib_Unit
:= Library_Unit
(Item
);
5888 -- The corresponding subunit was previously loaded
5890 if Present
(Lib_Unit
) then
5893 -- Otherwise attempt to load the corresponding subunit
5896 return Load_Package_Body
(Get_Unit_Name
(Item
));
5906 -----------------------
5907 -- Load_Package_Body --
5908 -----------------------
5910 function Load_Package_Body
(Unit_Nam
: Unit_Name_Type
) return Node_Id
is
5911 Body_Decl
: Node_Id
;
5912 Unit_Num
: Unit_Number_Type
;
5915 -- The load is performed only when the compilation will generate code
5917 if Operating_Mode
= Generate_Code
then
5920 (Load_Name
=> Unit_Nam
,
5923 Error_Node
=> Pack_Decl
);
5925 -- The load failed most likely because the physical file is
5928 if Unit_Num
= No_Unit
then
5931 -- Otherwise the load was successful, return the body of the unit
5934 Body_Decl
:= Unit
(Cunit
(Unit_Num
));
5936 -- If the unit is a subunit with an available proper body,
5937 -- return the proper body.
5939 if Nkind
(Body_Decl
) = N_Subunit
5940 and then Present
(Proper_Body
(Body_Decl
))
5942 Body_Decl
:= Proper_Body
(Body_Decl
);
5950 end Load_Package_Body
;
5954 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
5956 -- Start of processing for Has_Body
5959 -- The body is available
5961 if Present
(Corresponding_Body
(Pack_Decl
)) then
5964 -- The body is required if the package spec contains a construct which
5965 -- requires a completion in a body.
5967 elsif Unit_Requires_Body
(Pack_Id
) then
5970 -- The body may be optional
5973 return Present
(Find_Corresponding_Body
(Pack_Id
));
5977 ---------------------------
5978 -- Has_Prior_Elaboration --
5979 ---------------------------
5981 function Has_Prior_Elaboration
5982 (Unit_Id
: Entity_Id
;
5983 Context_OK
: Boolean := False;
5984 Elab_Body_OK
: Boolean := False;
5985 Same_Unit_OK
: Boolean := False) return Boolean
5987 Main_Id
: constant Entity_Id
:= Cunit_Entity
(Main_Unit
);
5990 -- A preelaborated unit is always elaborated prior to the main unit
5992 if Is_Preelaborated_Unit
(Unit_Id
) then
5995 -- An internal unit is always elaborated prior to a non-internal main
5998 elsif In_Internal_Unit
(Unit_Id
)
5999 and then not In_Internal_Unit
(Main_Id
)
6003 -- A unit has prior elaboration if it appears within the context of the
6004 -- main unit. Consider this case only when requested by the caller.
6007 and then Elaboration_Status
(Unit_Id
) /= No_Elaboration_Attributes
6011 -- A unit whose body is elaborated together with its spec has prior
6012 -- elaboration except with respect to itself. Consider this case only
6013 -- when requested by the caller.
6016 and then Has_Pragma_Elaborate_Body
(Unit_Id
)
6017 and then not Is_Same_Unit
(Unit_Id
, Main_Id
)
6021 -- A unit has no prior elaboration with respect to itself, but does not
6022 -- require any means of ensuring its own elaboration either. Treat this
6023 -- case as valid prior elaboration only when requested by the caller.
6025 elsif Same_Unit_OK
and then Is_Same_Unit
(Unit_Id
, Main_Id
) then
6030 end Has_Prior_Elaboration
;
6032 --------------------------
6033 -- In_External_Instance --
6034 --------------------------
6036 function In_External_Instance
6038 Target_Decl
: Node_Id
) return Boolean
6041 Inst_Body
: Node_Id
;
6042 Inst_Decl
: Node_Id
;
6045 -- Performance note: parent traversal
6047 Inst_Decl
:= Find_Enclosing_Instance
(Target_Decl
);
6049 -- The target declaration appears within an instance spec. Visibility is
6050 -- ignored because internally generated primitives for private types may
6051 -- reside in the private declarations and still be invoked from outside.
6053 if Present
(Inst_Decl
)
6054 and then Nkind
(Inst_Decl
) = N_Package_Declaration
6056 -- The scenario comes from the main unit and the instance does not
6058 if In_Extended_Main_Code_Unit
(N
)
6059 and then not In_Extended_Main_Code_Unit
(Inst_Decl
)
6063 -- Otherwise the scenario must not appear within the instance spec or
6067 Extract_Instance_Attributes
6068 (Exp_Inst
=> Inst_Decl
,
6069 Inst_Body
=> Inst_Body
,
6070 Inst_Decl
=> Dummy
);
6072 -- Performance note: parent traversal
6074 return not In_Subtree
6077 Root2
=> Inst_Body
);
6082 end In_External_Instance
;
6084 ---------------------
6085 -- In_Main_Context --
6086 ---------------------
6088 function In_Main_Context
(N
: Node_Id
) return Boolean is
6090 -- Scenarios outside the main unit are not considered because the ALI
6091 -- information supplied to binde is for the main unit only.
6093 if not In_Extended_Main_Code_Unit
(N
) then
6096 -- Scenarios within internal units are not considered unless switch
6097 -- -gnatdE (elaboration checks on predefined units) is in effect.
6099 elsif not Debug_Flag_EE
and then In_Internal_Unit
(N
) then
6104 end In_Main_Context
;
6106 ---------------------
6107 -- In_Same_Context --
6108 ---------------------
6110 function In_Same_Context
6113 Nested_OK
: Boolean := False) return Boolean
6115 function Find_Enclosing_Context
(N
: Node_Id
) return Node_Id
;
6116 -- Return the nearest enclosing non-library-level or compilation unit
6117 -- node which which encapsulates arbitrary node N. Return Empty is no
6118 -- such context is available.
6120 function In_Nested_Context
6122 Inner
: Node_Id
) return Boolean;
6123 -- Determine whether arbitrary node Outer encapsulates arbitrary node
6126 ----------------------------
6127 -- Find_Enclosing_Context --
6128 ----------------------------
6130 function Find_Enclosing_Context
(N
: Node_Id
) return Node_Id
is
6136 while Present
(Par
) loop
6138 -- A traversal from a subunit continues via the corresponding stub
6140 if Nkind
(Par
) = N_Subunit
then
6141 Par
:= Corresponding_Stub
(Par
);
6143 -- Stop the traversal when the nearest enclosing non-library-level
6144 -- encapsulator has been reached.
6146 elsif Is_Non_Library_Level_Encapsulator
(Par
) then
6147 Context
:= Parent
(Par
);
6149 -- The sole exception is when the encapsulator is the unit of
6150 -- compilation because this case requires special processing
6153 if Present
(Context
)
6154 and then Nkind
(Context
) = N_Compilation_Unit
6162 -- Reaching a compilation unit node without hitting a non-library-
6163 -- level encapsulator indicates that N is at the library level in
6164 -- which case the compilation unit is the context.
6166 elsif Nkind
(Par
) = N_Compilation_Unit
then
6170 Par
:= Parent
(Par
);
6174 end Find_Enclosing_Context
;
6176 -----------------------
6177 -- In_Nested_Context --
6178 -----------------------
6180 function In_Nested_Context
6182 Inner
: Node_Id
) return Boolean
6188 while Present
(Par
) loop
6190 -- A traversal from a subunit continues via the corresponding stub
6192 if Nkind
(Par
) = N_Subunit
then
6193 Par
:= Corresponding_Stub
(Par
);
6195 elsif Par
= Outer
then
6199 Par
:= Parent
(Par
);
6203 end In_Nested_Context
;
6207 Context_1
: constant Node_Id
:= Find_Enclosing_Context
(N1
);
6208 Context_2
: constant Node_Id
:= Find_Enclosing_Context
(N2
);
6210 -- Start of processing for In_Same_Context
6213 -- Both nodes appear within the same context
6215 if Context_1
= Context_2
then
6218 -- Both nodes appear in compilation units. Determine whether one unit
6219 -- is the body of the other.
6221 elsif Nkind
(Context_1
) = N_Compilation_Unit
6222 and then Nkind
(Context_2
) = N_Compilation_Unit
6226 (Unit_1
=> Defining_Entity
(Unit
(Context_1
)),
6227 Unit_2
=> Defining_Entity
(Unit
(Context_2
)));
6229 -- The context of N1 encloses the context of N2
6231 elsif Nested_OK
and then In_Nested_Context
(Context_1
, Context_2
) then
6236 end In_Same_Context
;
6242 function In_Task_Body
(N
: Node_Id
) return Boolean is
6246 -- Climb the parent chain looking for a task body [procedure]
6249 while Present
(Par
) loop
6250 if Nkind
(Par
) = N_Task_Body
then
6253 elsif Nkind
(Par
) = N_Subprogram_Body
6254 and then Is_Task_Body_Procedure
(Par
)
6258 -- Prevent the search from going too far. Note that this predicate
6259 -- shares nodes with the two cases above, and must come last.
6261 elsif Is_Body_Or_Package_Declaration
(Par
) then
6265 Par
:= Parent
(Par
);
6275 procedure Initialize
is
6277 -- Set the soft link which enables Atree.Rewrite to update a top-level
6278 -- scenario each time it is transformed into another node.
6280 Set_Rewriting_Proc
(Update_Elaboration_Scenario
'Access);
6289 Target_Id
: Entity_Id
;
6293 procedure Info_Accept_Alternative
;
6294 pragma Inline
(Info_Accept_Alternative
);
6295 -- Output information concerning an accept alternative
6297 procedure Info_Simple_Call
;
6298 pragma Inline
(Info_Simple_Call
);
6299 -- Output information concerning the call
6301 procedure Info_Type_Actions
(Action
: String);
6302 pragma Inline
(Info_Type_Actions
);
6303 -- Output information concerning action Action of a type
6305 procedure Info_Verification_Call
6309 pragma Inline
(Info_Verification_Call
);
6310 -- Output information concerning the verification of predicate Pred
6311 -- applied to related entity Id with kind Id_Kind.
6313 -----------------------------
6314 -- Info_Accept_Alternative --
6315 -----------------------------
6317 procedure Info_Accept_Alternative
is
6318 Entry_Id
: constant Entity_Id
:= Receiving_Entry
(Target_Id
);
6321 pragma Assert
(Present
(Entry_Id
));
6324 (Msg
=> "accept for entry & during elaboration",
6327 Info_Msg
=> Info_Msg
,
6328 In_SPARK
=> In_SPARK
);
6329 end Info_Accept_Alternative
;
6331 ----------------------
6332 -- Info_Simple_Call --
6333 ----------------------
6335 procedure Info_Simple_Call
is
6338 (Msg
=> "call to & during elaboration",
6341 Info_Msg
=> Info_Msg
,
6342 In_SPARK
=> In_SPARK
);
6343 end Info_Simple_Call
;
6345 -----------------------
6346 -- Info_Type_Actions --
6347 -----------------------
6349 procedure Info_Type_Actions
(Action
: String) is
6350 Typ
: constant Entity_Id
:= First_Formal_Type
(Target_Id
);
6353 pragma Assert
(Present
(Typ
));
6356 (Msg
=> Action
& " actions for type & during elaboration",
6359 Info_Msg
=> Info_Msg
,
6360 In_SPARK
=> In_SPARK
);
6361 end Info_Type_Actions
;
6363 ----------------------------
6364 -- Info_Verification_Call --
6365 ----------------------------
6367 procedure Info_Verification_Call
6373 pragma Assert
(Present
(Id
));
6377 "verification of " & Pred
& " of " & Id_Kind
& " & during "
6381 Info_Msg
=> Info_Msg
,
6382 In_SPARK
=> In_SPARK
);
6383 end Info_Verification_Call
;
6385 -- Start of processing for Info_Call
6388 -- Do not output anything for targets defined in internal units because
6389 -- this creates noise.
6391 if not In_Internal_Unit
(Target_Id
) then
6393 -- Accept alternative
6395 if Is_Accept_Alternative_Proc
(Target_Id
) then
6396 Info_Accept_Alternative
;
6400 elsif Is_TSS
(Target_Id
, TSS_Deep_Adjust
) then
6401 Info_Type_Actions
("adjustment");
6403 -- Default_Initial_Condition
6405 elsif Is_Default_Initial_Condition_Proc
(Target_Id
) then
6406 Info_Verification_Call
6407 (Pred
=> "Default_Initial_Condition",
6408 Id
=> First_Formal_Type
(Target_Id
),
6413 elsif Is_Protected_Entry
(Target_Id
) then
6416 -- Task entry calls are never processed because the entry being
6417 -- invoked does not have a corresponding "body", it has a select.
6419 elsif Is_Task_Entry
(Target_Id
) then
6424 elsif Is_TSS
(Target_Id
, TSS_Deep_Finalize
) then
6425 Info_Type_Actions
("finalization");
6427 -- Calls to _Finalizer procedures must not appear in the output
6428 -- because this creates confusing noise.
6430 elsif Is_Finalizer_Proc
(Target_Id
) then
6433 -- Initial_Condition
6435 elsif Is_Initial_Condition_Proc
(Target_Id
) then
6436 Info_Verification_Call
6437 (Pred
=> "Initial_Condition",
6438 Id
=> Find_Enclosing_Scope
(Call
),
6439 Id_Kind
=> "package");
6443 elsif Is_Init_Proc
(Target_Id
)
6444 or else Is_TSS
(Target_Id
, TSS_Deep_Initialize
)
6446 Info_Type_Actions
("initialization");
6450 elsif Is_Invariant_Proc
(Target_Id
) then
6451 Info_Verification_Call
6452 (Pred
=> "invariants",
6453 Id
=> First_Formal_Type
(Target_Id
),
6456 -- Partial invariant calls must not appear in the output because this
6457 -- creates confusing noise.
6459 elsif Is_Partial_Invariant_Proc
(Target_Id
) then
6464 elsif Is_Postconditions_Proc
(Target_Id
) then
6465 Info_Verification_Call
6466 (Pred
=> "postconditions",
6467 Id
=> Find_Enclosing_Scope
(Call
),
6468 Id_Kind
=> "subprogram");
6470 -- Subprograms must come last because some of the previous cases fall
6471 -- under this category.
6473 elsif Ekind
(Target_Id
) = E_Function
then
6476 elsif Ekind
(Target_Id
) = E_Procedure
then
6480 pragma Assert
(False);
6486 ------------------------
6487 -- Info_Instantiation --
6488 ------------------------
6490 procedure Info_Instantiation
6498 (Msg
=> "instantiation of & during elaboration",
6501 Info_Msg
=> Info_Msg
,
6502 In_SPARK
=> In_SPARK
);
6503 end Info_Instantiation
;
6505 -----------------------------
6506 -- Info_Variable_Reference --
6507 -----------------------------
6509 procedure Info_Variable_Reference
6516 if Is_Read
(Ref
) then
6518 (Msg
=> "read of variable & during elaboration",
6521 Info_Msg
=> Info_Msg
,
6522 In_SPARK
=> In_SPARK
);
6524 end Info_Variable_Reference
;
6526 --------------------
6527 -- Insertion_Node --
6528 --------------------
6530 function Insertion_Node
(N
: Node_Id
; Ins_Nod
: Node_Id
) return Node_Id
is
6532 -- When the scenario denotes an instantiation, the proper insertion node
6533 -- is the instance spec. This ensures that the generic actuals will not
6534 -- be evaluated prior to a potential ABE.
6536 if Nkind
(N
) in N_Generic_Instantiation
6537 and then Present
(Instance_Spec
(N
))
6539 return Instance_Spec
(N
);
6541 -- Otherwise the proper insertion node is the candidate insertion node
6548 -----------------------
6549 -- Install_ABE_Check --
6550 -----------------------
6552 procedure Install_ABE_Check
6557 Check_Ins_Nod
: constant Node_Id
:= Insertion_Node
(N
, Ins_Nod
);
6558 -- Insert the check prior to this node
6560 Loc
: constant Source_Ptr
:= Sloc
(N
);
6561 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Id
);
6562 Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(Id
);
6563 Scop_Id
: Entity_Id
;
6566 -- Nothing to do when compiling for GNATprove because raise statements
6567 -- are not supported.
6569 if GNATprove_Mode
then
6572 -- Nothing to do when the compilation will not produce an executable
6574 elsif Serious_Errors_Detected
> 0 then
6577 -- Nothing to do for a compilation unit because there is no executable
6578 -- environment at that level.
6580 elsif Nkind
(Parent
(Check_Ins_Nod
)) = N_Compilation_Unit
then
6583 -- Nothing to do when the unit is elaborated prior to the main unit.
6584 -- This check must also consider the following cases:
6586 -- * Id's unit appears in the context of the main unit
6588 -- * Id's unit is subject to pragma Elaborate_Body. An ABE check MUST
6589 -- NOT be generated because Id's unit is always elaborated prior to
6592 -- * Id's unit is the main unit. An ABE check MUST be generated in this
6593 -- case because a conditional ABE may be raised depending on the flow
6594 -- of execution within the main unit (flag Same_Unit_OK is False).
6596 elsif Has_Prior_Elaboration
6597 (Unit_Id
=> Unit_Id
,
6599 Elab_Body_OK
=> True)
6604 -- Prevent multiple scenarios from installing the same ABE check
6606 Set_Is_Elaboration_Checks_OK_Node
(N
, False);
6608 -- Install the nearest enclosing scope of the scenario as there must be
6609 -- something on the scope stack.
6611 -- Performance note: parent traversal
6613 Scop_Id
:= Find_Enclosing_Scope
(Check_Ins_Nod
);
6614 pragma Assert
(Present
(Scop_Id
));
6616 Push_Scope
(Scop_Id
);
6619 -- if not Spec_Id'Elaborated then
6620 -- raise Program_Error with "access before elaboration";
6623 Insert_Action
(Check_Ins_Nod
,
6624 Make_Raise_Program_Error
(Loc
,
6628 Make_Attribute_Reference
(Loc
,
6629 Prefix
=> New_Occurrence_Of
(Spec_Id
, Loc
),
6630 Attribute_Name
=> Name_Elaborated
)),
6631 Reason
=> PE_Access_Before_Elaboration
));
6634 end Install_ABE_Check
;
6636 -----------------------
6637 -- Install_ABE_Check --
6638 -----------------------
6640 procedure Install_ABE_Check
6642 Target_Id
: Entity_Id
;
6643 Target_Decl
: Node_Id
;
6644 Target_Body
: Node_Id
;
6647 procedure Build_Elaboration_Entity
;
6648 pragma Inline
(Build_Elaboration_Entity
);
6649 -- Create a new elaboration flag for Target_Id, insert it prior to
6650 -- Target_Decl, and set it after Body_Decl.
6652 ------------------------------
6653 -- Build_Elaboration_Entity --
6654 ------------------------------
6656 procedure Build_Elaboration_Entity
is
6657 Loc
: constant Source_Ptr
:= Sloc
(Target_Id
);
6658 Flag_Id
: Entity_Id
;
6661 -- Create the declaration of the elaboration flag. The name carries a
6662 -- unique counter in case of name overloading.
6665 Make_Defining_Identifier
(Loc
,
6666 Chars
=> New_External_Name
(Chars
(Target_Id
), 'E', -1));
6668 Set_Elaboration_Entity
(Target_Id
, Flag_Id
);
6669 Set_Elaboration_Entity_Required
(Target_Id
);
6671 Push_Scope
(Scope
(Target_Id
));
6674 -- Enn : Short_Integer := 0;
6676 Insert_Action
(Target_Decl
,
6677 Make_Object_Declaration
(Loc
,
6678 Defining_Identifier
=> Flag_Id
,
6679 Object_Definition
=>
6680 New_Occurrence_Of
(Standard_Short_Integer
, Loc
),
6681 Expression
=> Make_Integer_Literal
(Loc
, Uint_0
)));
6686 Set_Elaboration_Flag
(Target_Body
, Target_Id
);
6689 end Build_Elaboration_Entity
;
6693 Target_Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(Target_Id
);
6695 -- Start for processing for Install_ABE_Check
6698 -- Nothing to do when compiling for GNATprove because raise statements
6699 -- are not supported.
6701 if GNATprove_Mode
then
6704 -- Nothing to do when the compilation will not produce an executable
6706 elsif Serious_Errors_Detected
> 0 then
6709 -- Nothing to do when the target is a protected subprogram because the
6710 -- check is associated with the protected body subprogram.
6712 elsif Is_Protected_Subp
(Target_Id
) then
6715 -- Nothing to do when the target is elaborated prior to the main unit.
6716 -- This check must also consider the following cases:
6718 -- * The unit of the target appears in the context of the main unit
6720 -- * The unit of the target is subject to pragma Elaborate_Body. An ABE
6721 -- check MUST NOT be generated because the unit is always elaborated
6722 -- prior to the main unit.
6724 -- * The unit of the target is the main unit. An ABE check MUST be added
6725 -- in this case because a conditional ABE may be raised depending on
6726 -- the flow of execution within the main unit (flag Same_Unit_OK is
6729 elsif Has_Prior_Elaboration
6730 (Unit_Id
=> Target_Unit_Id
,
6732 Elab_Body_OK
=> True)
6736 -- Create an elaboration flag for the target when it does not have one
6738 elsif No
(Elaboration_Entity
(Target_Id
)) then
6739 Build_Elaboration_Entity
;
6746 end Install_ABE_Check
;
6748 -------------------------
6749 -- Install_ABE_Failure --
6750 -------------------------
6752 procedure Install_ABE_Failure
(N
: Node_Id
; Ins_Nod
: Node_Id
) is
6753 Fail_Ins_Nod
: constant Node_Id
:= Insertion_Node
(N
, Ins_Nod
);
6754 -- Insert the failure prior to this node
6756 Loc
: constant Source_Ptr
:= Sloc
(N
);
6757 Scop_Id
: Entity_Id
;
6760 -- Nothing to do when compiling for GNATprove because raise statements
6761 -- are not supported.
6763 if GNATprove_Mode
then
6766 -- Nothing to do when the compilation will not produce an executable
6768 elsif Serious_Errors_Detected
> 0 then
6771 -- Do not install an ABE check for a compilation unit because there is
6772 -- no executable environment at that level.
6774 elsif Nkind
(Parent
(Fail_Ins_Nod
)) = N_Compilation_Unit
then
6778 -- Prevent multiple scenarios from installing the same ABE failure
6780 Set_Is_Elaboration_Checks_OK_Node
(N
, False);
6782 -- Install the nearest enclosing scope of the scenario as there must be
6783 -- something on the scope stack.
6785 -- Performance note: parent traversal
6787 Scop_Id
:= Find_Enclosing_Scope
(Fail_Ins_Nod
);
6788 pragma Assert
(Present
(Scop_Id
));
6790 Push_Scope
(Scop_Id
);
6793 -- raise Program_Error with "access before elaboration";
6795 Insert_Action
(Fail_Ins_Nod
,
6796 Make_Raise_Program_Error
(Loc
,
6797 Reason
=> PE_Access_Before_Elaboration
));
6800 end Install_ABE_Failure
;
6802 --------------------------------
6803 -- Is_Accept_Alternative_Proc --
6804 --------------------------------
6806 function Is_Accept_Alternative_Proc
(Id
: Entity_Id
) return Boolean is
6808 -- To qualify, the entity must denote a procedure with a receiving entry
6810 return Ekind
(Id
) = E_Procedure
and then Present
(Receiving_Entry
(Id
));
6811 end Is_Accept_Alternative_Proc
;
6813 ------------------------
6814 -- Is_Activation_Proc --
6815 ------------------------
6817 function Is_Activation_Proc
(Id
: Entity_Id
) return Boolean is
6819 -- To qualify, the entity must denote one of the runtime procedures in
6820 -- charge of task activation.
6822 if Ekind
(Id
) = E_Procedure
then
6823 if Restricted_Profile
then
6824 return Is_RTE
(Id
, RE_Activate_Restricted_Tasks
);
6826 return Is_RTE
(Id
, RE_Activate_Tasks
);
6831 end Is_Activation_Proc
;
6833 ----------------------------
6834 -- Is_Ada_Semantic_Target --
6835 ----------------------------
6837 function Is_Ada_Semantic_Target
(Id
: Entity_Id
) return Boolean is
6840 Is_Activation_Proc
(Id
)
6841 or else Is_Controlled_Proc
(Id
, Name_Adjust
)
6842 or else Is_Controlled_Proc
(Id
, Name_Finalize
)
6843 or else Is_Controlled_Proc
(Id
, Name_Initialize
)
6844 or else Is_Init_Proc
(Id
)
6845 or else Is_Invariant_Proc
(Id
)
6846 or else Is_Protected_Entry
(Id
)
6847 or else Is_Protected_Subp
(Id
)
6848 or else Is_Protected_Body_Subp
(Id
)
6849 or else Is_Task_Entry
(Id
);
6850 end Is_Ada_Semantic_Target
;
6852 --------------------------------
6853 -- Is_Assertion_Pragma_Target --
6854 --------------------------------
6856 function Is_Assertion_Pragma_Target
(Id
: Entity_Id
) return Boolean is
6859 Is_Default_Initial_Condition_Proc
(Id
)
6860 or else Is_Initial_Condition_Proc
(Id
)
6861 or else Is_Invariant_Proc
(Id
)
6862 or else Is_Partial_Invariant_Proc
(Id
)
6863 or else Is_Postconditions_Proc
(Id
);
6864 end Is_Assertion_Pragma_Target
;
6866 ----------------------------
6867 -- Is_Bodiless_Subprogram --
6868 ----------------------------
6870 function Is_Bodiless_Subprogram
(Subp_Id
: Entity_Id
) return Boolean is
6872 -- An abstract subprogram does not have a body
6874 if Ekind_In
(Subp_Id
, E_Function
,
6877 and then Is_Abstract_Subprogram
(Subp_Id
)
6881 -- A formal subprogram does not have a body
6883 elsif Is_Formal_Subprogram
(Subp_Id
) then
6886 -- An imported subprogram may have a body, however it is not known at
6887 -- compile or bind time where the body resides and whether it will be
6888 -- elaborated on time.
6890 elsif Is_Imported
(Subp_Id
) then
6895 end Is_Bodiless_Subprogram
;
6897 ------------------------
6898 -- Is_Controlled_Proc --
6899 ------------------------
6901 function Is_Controlled_Proc
6902 (Subp_Id
: Entity_Id
;
6903 Subp_Nam
: Name_Id
) return Boolean
6905 Formal_Id
: Entity_Id
;
6908 pragma Assert
(Nam_In
(Subp_Nam
, Name_Adjust
,
6912 -- To qualify, the subprogram must denote a source procedure with name
6913 -- Adjust, Finalize, or Initialize where the sole formal is controlled.
6915 if Comes_From_Source
(Subp_Id
)
6916 and then Ekind
(Subp_Id
) = E_Procedure
6917 and then Chars
(Subp_Id
) = Subp_Nam
6919 Formal_Id
:= First_Formal
(Subp_Id
);
6923 and then Is_Controlled
(Etype
(Formal_Id
))
6924 and then No
(Next_Formal
(Formal_Id
));
6928 end Is_Controlled_Proc
;
6930 ---------------------------------------
6931 -- Is_Default_Initial_Condition_Proc --
6932 ---------------------------------------
6934 function Is_Default_Initial_Condition_Proc
6935 (Id
: Entity_Id
) return Boolean
6938 -- To qualify, the entity must denote a Default_Initial_Condition
6941 return Ekind
(Id
) = E_Procedure
and then Is_DIC_Procedure
(Id
);
6942 end Is_Default_Initial_Condition_Proc
;
6944 -----------------------
6945 -- Is_Finalizer_Proc --
6946 -----------------------
6948 function Is_Finalizer_Proc
(Id
: Entity_Id
) return Boolean is
6950 -- To qualify, the entity must denote a _Finalizer procedure
6952 return Ekind
(Id
) = E_Procedure
and then Chars
(Id
) = Name_uFinalizer
;
6953 end Is_Finalizer_Proc
;
6955 -----------------------
6956 -- Is_Guaranteed_ABE --
6957 -----------------------
6959 function Is_Guaranteed_ABE
6961 Target_Decl
: Node_Id
;
6962 Target_Body
: Node_Id
) return Boolean
6965 -- Avoid cascaded errors if there were previous serious infractions.
6966 -- As a result the scenario will not be treated as a guaranteed ABE.
6967 -- This behaviour parallels that of the old ABE mechanism.
6969 if Serious_Errors_Detected
> 0 then
6972 -- The scenario and the target appear within the same context ignoring
6973 -- enclosing library levels.
6975 -- Performance note: parent traversal
6977 elsif In_Same_Context
(N
, Target_Decl
) then
6979 -- The target body has already been encountered. The scenario results
6980 -- in a guaranteed ABE if it appears prior to the body.
6982 if Present
(Target_Body
) then
6983 return Earlier_In_Extended_Unit
(N
, Target_Body
);
6985 -- Otherwise the body has not been encountered yet. The scenario is
6986 -- a guaranteed ABE since the body will appear later. It is assumed
6987 -- that the caller has already checked whether the scenario is ABE-
6988 -- safe as optional bodies are not considered here.
6996 end Is_Guaranteed_ABE
;
6998 -------------------------------
6999 -- Is_Initial_Condition_Proc --
7000 -------------------------------
7002 function Is_Initial_Condition_Proc
(Id
: Entity_Id
) return Boolean is
7004 -- To qualify, the entity must denote an Initial_Condition procedure
7007 Ekind
(Id
) = E_Procedure
and then Is_Initial_Condition_Procedure
(Id
);
7008 end Is_Initial_Condition_Proc
;
7010 --------------------
7011 -- Is_Initialized --
7012 --------------------
7014 function Is_Initialized
(Obj_Decl
: Node_Id
) return Boolean is
7016 -- To qualify, the object declaration must have an expression
7019 Present
(Expression
(Obj_Decl
)) or else Has_Init_Expression
(Obj_Decl
);
7022 -----------------------
7023 -- Is_Invariant_Proc --
7024 -----------------------
7026 function Is_Invariant_Proc
(Id
: Entity_Id
) return Boolean is
7028 -- To qualify, the entity must denote the "full" invariant procedure
7030 return Ekind
(Id
) = E_Procedure
and then Is_Invariant_Procedure
(Id
);
7031 end Is_Invariant_Proc
;
7033 ---------------------------------------
7034 -- Is_Non_Library_Level_Encapsulator --
7035 ---------------------------------------
7037 function Is_Non_Library_Level_Encapsulator
(N
: Node_Id
) return Boolean is
7040 when N_Abstract_Subprogram_Declaration
7041 | N_Aspect_Specification
7042 | N_Component_Declaration
7044 | N_Entry_Declaration
7045 | N_Expression_Function
7046 | N_Formal_Abstract_Subprogram_Declaration
7047 | N_Formal_Concrete_Subprogram_Declaration
7048 | N_Formal_Object_Declaration
7049 | N_Formal_Package_Declaration
7050 | N_Formal_Type_Declaration
7051 | N_Generic_Association
7052 | N_Implicit_Label_Declaration
7053 | N_Incomplete_Type_Declaration
7054 | N_Private_Extension_Declaration
7055 | N_Private_Type_Declaration
7057 | N_Protected_Type_Declaration
7058 | N_Single_Protected_Declaration
7059 | N_Single_Task_Declaration
7061 | N_Subprogram_Declaration
7063 | N_Task_Type_Declaration
7068 return Is_Generic_Declaration_Or_Body
(N
);
7070 end Is_Non_Library_Level_Encapsulator
;
7072 -------------------------------
7073 -- Is_Partial_Invariant_Proc --
7074 -------------------------------
7076 function Is_Partial_Invariant_Proc
(Id
: Entity_Id
) return Boolean is
7078 -- To qualify, the entity must denote the "partial" invariant procedure
7081 Ekind
(Id
) = E_Procedure
and then Is_Partial_Invariant_Procedure
(Id
);
7082 end Is_Partial_Invariant_Proc
;
7084 ----------------------------
7085 -- Is_Postconditions_Proc --
7086 ----------------------------
7088 function Is_Postconditions_Proc
(Id
: Entity_Id
) return Boolean is
7090 -- To qualify, the entity must denote a _Postconditions procedure
7093 Ekind
(Id
) = E_Procedure
and then Chars
(Id
) = Name_uPostconditions
;
7094 end Is_Postconditions_Proc
;
7096 ---------------------------
7097 -- Is_Preelaborated_Unit --
7098 ---------------------------
7100 function Is_Preelaborated_Unit
(Id
: Entity_Id
) return Boolean is
7103 Is_Preelaborated
(Id
)
7104 or else Is_Pure
(Id
)
7105 or else Is_Remote_Call_Interface
(Id
)
7106 or else Is_Remote_Types
(Id
)
7107 or else Is_Shared_Passive
(Id
);
7108 end Is_Preelaborated_Unit
;
7110 ------------------------
7111 -- Is_Protected_Entry --
7112 ------------------------
7114 function Is_Protected_Entry
(Id
: Entity_Id
) return Boolean is
7116 -- To qualify, the entity must denote an entry defined in a protected
7121 and then Is_Protected_Type
(Non_Private_View
(Scope
(Id
)));
7122 end Is_Protected_Entry
;
7124 -----------------------
7125 -- Is_Protected_Subp --
7126 -----------------------
7128 function Is_Protected_Subp
(Id
: Entity_Id
) return Boolean is
7130 -- To qualify, the entity must denote a subprogram defined within a
7134 Ekind_In
(Id
, E_Function
, E_Procedure
)
7135 and then Is_Protected_Type
(Non_Private_View
(Scope
(Id
)));
7136 end Is_Protected_Subp
;
7138 ----------------------------
7139 -- Is_Protected_Body_Subp --
7140 ----------------------------
7142 function Is_Protected_Body_Subp
(Id
: Entity_Id
) return Boolean is
7144 -- To qualify, the entity must denote a subprogram with attribute
7145 -- Protected_Subprogram set.
7148 Ekind_In
(Id
, E_Function
, E_Procedure
)
7149 and then Present
(Protected_Subprogram
(Id
));
7150 end Is_Protected_Body_Subp
;
7152 --------------------------------
7153 -- Is_Recorded_SPARK_Scenario --
7154 --------------------------------
7156 function Is_Recorded_SPARK_Scenario
(N
: Node_Id
) return Boolean is
7158 if Recorded_SPARK_Scenarios_In_Use
then
7159 return Recorded_SPARK_Scenarios
.Get
(N
);
7162 return Recorded_SPARK_Scenarios_No_Element
;
7163 end Is_Recorded_SPARK_Scenario
;
7165 ------------------------------------
7166 -- Is_Recorded_Top_Level_Scenario --
7167 ------------------------------------
7169 function Is_Recorded_Top_Level_Scenario
(N
: Node_Id
) return Boolean is
7171 if Recorded_Top_Level_Scenarios_In_Use
then
7172 return Recorded_Top_Level_Scenarios
.Get
(N
);
7175 return Recorded_Top_Level_Scenarios_No_Element
;
7176 end Is_Recorded_Top_Level_Scenario
;
7178 ------------------------
7179 -- Is_Safe_Activation --
7180 ------------------------
7182 function Is_Safe_Activation
7184 Task_Decl
: Node_Id
) return Boolean
7187 -- The activation of a task coming from an external instance cannot
7188 -- cause an ABE because the generic was already instantiated. Note
7189 -- that the instantiation itself may lead to an ABE.
7192 In_External_Instance
7194 Target_Decl
=> Task_Decl
);
7195 end Is_Safe_Activation
;
7201 function Is_Safe_Call
7203 Target_Attrs
: Target_Attributes
) return Boolean
7206 -- The target is either an abstract subprogram, formal subprogram, or
7207 -- imported, in which case it does not have a body at compile or bind
7208 -- time. Assume that the call is ABE-safe.
7210 if Is_Bodiless_Subprogram
(Target_Attrs
.Spec_Id
) then
7213 -- The target is an instantiation of a generic subprogram. The call
7214 -- cannot cause an ABE because the generic was already instantiated.
7215 -- Note that the instantiation itself may lead to an ABE.
7217 elsif Is_Generic_Instance
(Target_Attrs
.Spec_Id
) then
7220 -- The invocation of a target coming from an external instance cannot
7221 -- cause an ABE because the generic was already instantiated. Note that
7222 -- the instantiation itself may lead to an ABE.
7224 elsif In_External_Instance
7226 Target_Decl
=> Target_Attrs
.Spec_Decl
)
7230 -- The target is a subprogram body without a previous declaration. The
7231 -- call cannot cause an ABE because the body has already been seen.
7233 elsif Nkind
(Target_Attrs
.Spec_Decl
) = N_Subprogram_Body
7234 and then No
(Corresponding_Spec
(Target_Attrs
.Spec_Decl
))
7238 -- The target is a subprogram body stub without a prior declaration.
7239 -- The call cannot cause an ABE because the proper body substitutes
7242 elsif Nkind
(Target_Attrs
.Spec_Decl
) = N_Subprogram_Body_Stub
7243 and then No
(Corresponding_Spec_Of_Stub
(Target_Attrs
.Spec_Decl
))
7247 -- Subprogram bodies which wrap attribute references used as actuals
7248 -- in instantiations are always ABE-safe. These bodies are artifacts
7251 elsif Present
(Target_Attrs
.Body_Decl
)
7252 and then Nkind
(Target_Attrs
.Body_Decl
) = N_Subprogram_Body
7253 and then Was_Attribute_Reference
(Target_Attrs
.Body_Decl
)
7261 ---------------------------
7262 -- Is_Safe_Instantiation --
7263 ---------------------------
7265 function Is_Safe_Instantiation
7267 Gen_Attrs
: Target_Attributes
) return Boolean
7270 -- The generic is an intrinsic subprogram in which case it does not
7271 -- have a body at compile or bind time. Assume that the instantiation
7274 if Is_Bodiless_Subprogram
(Gen_Attrs
.Spec_Id
) then
7277 -- The instantiation of an external nested generic cannot cause an ABE
7278 -- if the outer generic was already instantiated. Note that the instance
7279 -- of the outer generic may lead to an ABE.
7281 elsif In_External_Instance
7283 Target_Decl
=> Gen_Attrs
.Spec_Decl
)
7287 -- The generic is a package. The instantiation cannot cause an ABE when
7288 -- the package has no body.
7290 elsif Ekind
(Gen_Attrs
.Spec_Id
) = E_Generic_Package
7291 and then not Has_Body
(Gen_Attrs
.Spec_Decl
)
7297 end Is_Safe_Instantiation
;
7303 function Is_Same_Unit
7304 (Unit_1
: Entity_Id
;
7305 Unit_2
: Entity_Id
) return Boolean
7308 return Unit_Entity
(Unit_1
) = Unit_Entity
(Unit_2
);
7315 function Is_Scenario
(N
: Node_Id
) return Boolean is
7318 when N_Assignment_Statement
7319 | N_Attribute_Reference
7321 | N_Entry_Call_Statement
7324 | N_Function_Instantiation
7326 | N_Package_Instantiation
7327 | N_Procedure_Call_Statement
7328 | N_Procedure_Instantiation
7329 | N_Requeue_Statement
7338 ------------------------------
7339 -- Is_SPARK_Semantic_Target --
7340 ------------------------------
7342 function Is_SPARK_Semantic_Target
(Id
: Entity_Id
) return Boolean is
7345 Is_Default_Initial_Condition_Proc
(Id
)
7346 or else Is_Initial_Condition_Proc
(Id
);
7347 end Is_SPARK_Semantic_Target
;
7349 ------------------------
7350 -- Is_Suitable_Access --
7351 ------------------------
7353 function Is_Suitable_Access
(N
: Node_Id
) return Boolean is
7356 Subp_Id
: Entity_Id
;
7359 -- This scenario is relevant only when the static model is in effect
7360 -- because it is graph-dependent and does not involve any run-time
7361 -- checks. Allowing it in the dynamic model would create confusing
7364 if not Static_Elaboration_Checks
then
7367 -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect
7369 elsif Debug_Flag_Dot_UU
then
7372 -- Nothing to do when the scenario is not an attribute reference
7374 elsif Nkind
(N
) /= N_Attribute_Reference
then
7377 -- Nothing to do for internally-generated attributes because they are
7378 -- assumed to be ABE safe.
7380 elsif not Comes_From_Source
(N
) then
7384 Nam
:= Attribute_Name
(N
);
7387 -- Sanitize the prefix of the attribute
7389 if not Is_Entity_Name
(Pref
) then
7392 elsif No
(Entity
(Pref
)) then
7396 Subp_Id
:= Entity
(Pref
);
7398 if not Is_Subprogram_Or_Entry
(Subp_Id
) then
7402 -- Traverse a possible chain of renamings to obtain the original entry
7403 -- or subprogram which the prefix may rename.
7405 Subp_Id
:= Get_Renamed_Entity
(Subp_Id
);
7407 -- To qualify, the attribute must meet the following prerequisites:
7411 -- The prefix must denote a source entry, operator, or subprogram
7412 -- which is not imported.
7414 Comes_From_Source
(Subp_Id
)
7415 and then Is_Subprogram_Or_Entry
(Subp_Id
)
7416 and then not Is_Bodiless_Subprogram
(Subp_Id
)
7418 -- The attribute name must be one of the 'Access forms. Note that
7419 -- 'Unchecked_Access cannot apply to a subprogram.
7421 and then Nam_In
(Nam
, Name_Access
, Name_Unrestricted_Access
);
7422 end Is_Suitable_Access
;
7424 ----------------------
7425 -- Is_Suitable_Call --
7426 ----------------------
7428 function Is_Suitable_Call
(N
: Node_Id
) return Boolean is
7430 -- Entry and subprogram calls are intentionally ignored because they
7431 -- may undergo expansion depending on the compilation mode, previous
7432 -- errors, generic context, etc. Call markers play the role of calls
7433 -- and provide a uniform foundation for ABE processing.
7435 return Nkind
(N
) = N_Call_Marker
;
7436 end Is_Suitable_Call
;
7438 -------------------------------
7439 -- Is_Suitable_Instantiation --
7440 -------------------------------
7442 function Is_Suitable_Instantiation
(N
: Node_Id
) return Boolean is
7443 Orig_N
: constant Node_Id
:= Original_Node
(N
);
7444 -- Use the original node in case an instantiation library unit is
7445 -- rewritten as a package or subprogram.
7448 -- To qualify, the instantiation must come from source
7451 Comes_From_Source
(Orig_N
)
7452 and then Nkind
(Orig_N
) in N_Generic_Instantiation
;
7453 end Is_Suitable_Instantiation
;
7455 --------------------------
7456 -- Is_Suitable_Scenario --
7457 --------------------------
7459 function Is_Suitable_Scenario
(N
: Node_Id
) return Boolean is
7461 -- NOTE: Derived types and pragma Refined_State are intentionally left
7462 -- out because they are not executable during elaboration.
7465 Is_Suitable_Access
(N
)
7466 or else Is_Suitable_Call
(N
)
7467 or else Is_Suitable_Instantiation
(N
)
7468 or else Is_Suitable_Variable_Assignment
(N
)
7469 or else Is_Suitable_Variable_Reference
(N
);
7470 end Is_Suitable_Scenario
;
7472 ------------------------------------
7473 -- Is_Suitable_SPARK_Derived_Type --
7474 ------------------------------------
7476 function Is_Suitable_SPARK_Derived_Type
(N
: Node_Id
) return Boolean is
7481 -- To qualify, the type declaration must denote a derived tagged type
7482 -- with primitive operations, subject to pragma SPARK_Mode On.
7484 if Nkind
(N
) = N_Full_Type_Declaration
7485 and then Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
7487 Typ
:= Defining_Entity
(N
);
7488 Prag
:= SPARK_Pragma
(Typ
);
7491 Is_Tagged_Type
(Typ
)
7492 and then Has_Primitive_Operations
(Typ
)
7493 and then Present
(Prag
)
7494 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
;
7498 end Is_Suitable_SPARK_Derived_Type
;
7500 -------------------------------------
7501 -- Is_Suitable_SPARK_Instantiation --
7502 -------------------------------------
7504 function Is_Suitable_SPARK_Instantiation
(N
: Node_Id
) return Boolean is
7505 Gen_Attrs
: Target_Attributes
;
7508 Inst_Attrs
: Instantiation_Attributes
;
7509 Inst_Id
: Entity_Id
;
7512 -- To qualify, both the instantiation and the generic must be subject to
7515 if Is_Suitable_Instantiation
(N
) then
7516 Extract_Instantiation_Attributes
7521 Attrs
=> Inst_Attrs
);
7523 Extract_Target_Attributes
(Gen_Id
, Gen_Attrs
);
7525 return Inst_Attrs
.SPARK_Mode_On
and Gen_Attrs
.SPARK_Mode_On
;
7529 end Is_Suitable_SPARK_Instantiation
;
7531 --------------------------------------------
7532 -- Is_Suitable_SPARK_Refined_State_Pragma --
7533 --------------------------------------------
7535 function Is_Suitable_SPARK_Refined_State_Pragma
7536 (N
: Node_Id
) return Boolean
7539 -- To qualfy, the pragma must denote Refined_State
7542 Nkind
(N
) = N_Pragma
7543 and then Pragma_Name
(N
) = Name_Refined_State
;
7544 end Is_Suitable_SPARK_Refined_State_Pragma
;
7546 -------------------------------------
7547 -- Is_Suitable_Variable_Assignment --
7548 -------------------------------------
7550 function Is_Suitable_Variable_Assignment
(N
: Node_Id
) return Boolean is
7552 N_Unit_Id
: Entity_Id
;
7557 Var_Unit_Id
: Entity_Id
;
7560 -- This scenario is relevant only when the static model is in effect
7561 -- because it is graph-dependent and does not involve any run-time
7562 -- checks. Allowing it in the dynamic model would create confusing
7565 if not Static_Elaboration_Checks
then
7568 -- Nothing to do when the scenario is not an assignment
7570 elsif Nkind
(N
) /= N_Assignment_Statement
then
7573 -- Nothing to do for internally-generated assignments because they are
7574 -- assumed to be ABE safe.
7576 elsif not Comes_From_Source
(N
) then
7579 -- Assignments are ignored in GNAT mode on the assumption that they are
7580 -- ABE-safe. This behaviour parallels that of the old ABE mechanism.
7582 elsif GNAT_Mode
then
7586 Nam
:= Extract_Assignment_Name
(N
);
7588 -- Sanitize the left hand side of the assignment
7590 if not Is_Entity_Name
(Nam
) then
7593 elsif No
(Entity
(Nam
)) then
7597 Var_Id
:= Entity
(Nam
);
7599 -- Sanitize the variable
7601 if Var_Id
= Any_Id
then
7604 elsif Ekind
(Var_Id
) /= E_Variable
then
7608 Var_Decl
:= Declaration_Node
(Var_Id
);
7610 if Nkind
(Var_Decl
) /= N_Object_Declaration
then
7614 N_Unit_Id
:= Find_Top_Unit
(N
);
7615 N_Unit
:= Unit_Declaration_Node
(N_Unit_Id
);
7617 Var_Unit_Id
:= Find_Top_Unit
(Var_Decl
);
7618 Var_Unit
:= Unit_Declaration_Node
(Var_Unit_Id
);
7620 -- To qualify, the assignment must meet the following prerequisites:
7623 Comes_From_Source
(Var_Id
)
7625 -- The variable must be declared in the spec of compilation unit U
7627 and then Nkind
(Var_Unit
) = N_Package_Declaration
7629 -- Performance note: parent traversal
7631 and then Find_Enclosing_Level
(Var_Decl
) = Package_Spec
7633 -- The assignment must occur in the body of compilation unit U
7635 and then Nkind
(N_Unit
) = N_Package_Body
7636 and then Present
(Corresponding_Body
(Var_Unit
))
7637 and then Corresponding_Body
(Var_Unit
) = N_Unit_Id
;
7638 end Is_Suitable_Variable_Assignment
;
7640 ------------------------------------
7641 -- Is_Suitable_Variable_Reference --
7642 ------------------------------------
7644 function Is_Suitable_Variable_Reference
(N
: Node_Id
) return Boolean is
7646 -- Expanded names and identifiers are intentionally ignored because they
7647 -- be folded, optimized away, etc. Variable references markers play the
7648 -- role of variable references and provide a uniform foundation for ABE
7651 return Nkind
(N
) = N_Variable_Reference_Marker
;
7652 end Is_Suitable_Variable_Reference
;
7654 ------------------------------------
7655 -- Is_Synchronous_Suspension_Call --
7656 ------------------------------------
7658 function Is_Synchronous_Suspension_Call
(N
: Node_Id
) return Boolean is
7659 Call_Attrs
: Call_Attributes
;
7660 Target_Id
: Entity_Id
;
7663 -- To qualify, the call must invoke one of the runtime routines which
7664 -- perform synchronous suspension.
7666 if Is_Suitable_Call
(N
) then
7667 Extract_Call_Attributes
7669 Target_Id
=> Target_Id
,
7670 Attrs
=> Call_Attrs
);
7673 Is_RTE
(Target_Id
, RE_Suspend_Until_True
)
7675 Is_RTE
(Target_Id
, RE_Wait_For_Release
);
7679 end Is_Synchronous_Suspension_Call
;
7685 function Is_Task_Entry
(Id
: Entity_Id
) return Boolean is
7687 -- To qualify, the entity must denote an entry defined in a task type
7690 Is_Entry
(Id
) and then Is_Task_Type
(Non_Private_View
(Scope
(Id
)));
7693 ------------------------
7694 -- Is_Up_Level_Target --
7695 ------------------------
7697 function Is_Up_Level_Target
(Target_Decl
: Node_Id
) return Boolean is
7698 Root
: constant Node_Id
:= Root_Scenario
;
7701 -- The root appears within the declaratons of a block statement, entry
7702 -- body, subprogram body, or task body ignoring enclosing packages. The
7703 -- root is always within the main unit. An up-level target is a notion
7704 -- applicable only to the static model because scenarios are reached by
7705 -- means of graph traversal started from a fixed declarative or library
7708 -- Performance note: parent traversal
7710 if Static_Elaboration_Checks
7711 and then Find_Enclosing_Level
(Root
) = Declaration_Level
7713 -- The target is within the main unit. It acts as an up-level target
7714 -- when it appears within a context which encloses the root.
7716 -- package body Main_Unit is
7717 -- function Func ...; -- target
7719 -- procedure Proc is
7720 -- X : ... := Func; -- root scenario
7722 if In_Extended_Main_Code_Unit
(Target_Decl
) then
7724 -- Performance note: parent traversal
7726 return not In_Same_Context
(Root
, Target_Decl
, Nested_OK
=> True);
7728 -- Otherwise the target is external to the main unit which makes it
7729 -- an up-level target.
7737 end Is_Up_Level_Target
;
7739 ---------------------
7740 -- Is_Visited_Body --
7741 ---------------------
7743 function Is_Visited_Body
(Body_Decl
: Node_Id
) return Boolean is
7745 if Visited_Bodies_In_Use
then
7746 return Visited_Bodies
.Get
(Body_Decl
);
7749 return Visited_Bodies_No_Element
;
7750 end Is_Visited_Body
;
7752 -------------------------------
7753 -- Kill_Elaboration_Scenario --
7754 -------------------------------
7756 procedure Kill_Elaboration_Scenario
(N
: Node_Id
) is
7757 procedure Kill_SPARK_Scenario
;
7758 pragma Inline
(Kill_SPARK_Scenario
);
7759 -- Eliminate scenario N from table SPARK_Scenarios if it is recorded
7762 procedure Kill_Top_Level_Scenario
;
7763 pragma Inline
(Kill_Top_Level_Scenario
);
7764 -- Eliminate scenario N from table Top_Level_Scenarios if it is recorded
7767 -------------------------
7768 -- Kill_SPARK_Scenario --
7769 -------------------------
7771 procedure Kill_SPARK_Scenario
is
7772 package Scenarios
renames SPARK_Scenarios
;
7775 if Is_Recorded_SPARK_Scenario
(N
) then
7777 -- Performance note: list traversal
7779 for Index
in Scenarios
.First
.. Scenarios
.Last
loop
7780 if Scenarios
.Table
(Index
) = N
then
7781 Scenarios
.Table
(Index
) := Empty
;
7783 -- The SPARK scenario is no longer recorded
7785 Set_Is_Recorded_SPARK_Scenario
(N
, False);
7790 -- A recorded SPARK scenario must be in the table of recorded
7793 pragma Assert
(False);
7795 end Kill_SPARK_Scenario
;
7797 -----------------------------
7798 -- Kill_Top_Level_Scenario --
7799 -----------------------------
7801 procedure Kill_Top_Level_Scenario
is
7802 package Scenarios
renames Top_Level_Scenarios
;
7805 if Is_Recorded_Top_Level_Scenario
(N
) then
7807 -- Performance node: list traversal
7809 for Index
in Scenarios
.First
.. Scenarios
.Last
loop
7810 if Scenarios
.Table
(Index
) = N
then
7811 Scenarios
.Table
(Index
) := Empty
;
7813 -- The top-level scenario is no longer recorded
7815 Set_Is_Recorded_Top_Level_Scenario
(N
, False);
7820 -- A recorded top-level scenario must be in the table of recorded
7821 -- top-level scenarios.
7823 pragma Assert
(False);
7825 end Kill_Top_Level_Scenario
;
7827 -- Start of processing for Kill_Elaboration_Scenario
7830 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
7831 -- enabled) is in effect because the legacy ABE lechanism does not need
7832 -- to carry out this action.
7834 if Legacy_Elaboration_Checks
then
7838 -- Eliminate a recorded scenario when it appears within dead code
7839 -- because it will not be executed at elaboration time.
7841 if Is_Scenario
(N
) then
7842 Kill_SPARK_Scenario
;
7843 Kill_Top_Level_Scenario
;
7845 end Kill_Elaboration_Scenario
;
7847 ----------------------------------
7848 -- Meet_Elaboration_Requirement --
7849 ----------------------------------
7851 procedure Meet_Elaboration_Requirement
7853 Target_Id
: Entity_Id
;
7856 Main_Id
: constant Entity_Id
:= Cunit_Entity
(Main_Unit
);
7857 Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(Target_Id
);
7859 function Find_Preelaboration_Pragma
7860 (Prag_Nam
: Name_Id
) return Node_Id
;
7861 pragma Inline
(Find_Preelaboration_Pragma
);
7862 -- Traverse the visible declarations of unit Unit_Id and locate a source
7863 -- preelaboration-related pragma with name Prag_Nam.
7865 procedure Info_Requirement_Met
(Prag
: Node_Id
);
7866 pragma Inline
(Info_Requirement_Met
);
7867 -- Output information concerning pragma Prag which meets requirement
7870 procedure Info_Scenario
;
7871 pragma Inline
(Info_Scenario
);
7872 -- Output information concerning scenario N
7874 --------------------------------
7875 -- Find_Preelaboration_Pragma --
7876 --------------------------------
7878 function Find_Preelaboration_Pragma
7879 (Prag_Nam
: Name_Id
) return Node_Id
7881 Spec
: constant Node_Id
:= Parent
(Unit_Id
);
7885 -- A preelaboration-related pragma comes from source and appears at
7886 -- the top of the visible declarations of a package.
7888 if Nkind
(Spec
) = N_Package_Specification
then
7889 Decl
:= First
(Visible_Declarations
(Spec
));
7890 while Present
(Decl
) loop
7891 if Comes_From_Source
(Decl
) then
7892 if Nkind
(Decl
) = N_Pragma
7893 and then Pragma_Name
(Decl
) = Prag_Nam
7897 -- Otherwise the construct terminates the region where the
7898 -- preelaboration-related pragma may appear.
7910 end Find_Preelaboration_Pragma
;
7912 --------------------------
7913 -- Info_Requirement_Met --
7914 --------------------------
7916 procedure Info_Requirement_Met
(Prag
: Node_Id
) is
7918 pragma Assert
(Present
(Prag
));
7920 Error_Msg_Name_1
:= Req_Nam
;
7921 Error_Msg_Sloc
:= Sloc
(Prag
);
7923 ("\\% requirement for unit & met by pragma #", N
, Unit_Id
);
7924 end Info_Requirement_Met
;
7930 procedure Info_Scenario
is
7932 if Is_Suitable_Call
(N
) then
7935 Target_Id
=> Target_Id
,
7939 elsif Is_Suitable_Instantiation
(N
) then
7942 Gen_Id
=> Target_Id
,
7946 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
7948 ("read of refinement constituents during elaboration in SPARK",
7951 elsif Is_Suitable_Variable_Reference
(N
) then
7952 Info_Variable_Reference
7954 Var_Id
=> Target_Id
,
7958 -- No other scenario may impose a requirement on the context of the
7962 pragma Assert
(False);
7969 Elab_Attrs
: Elaboration_Attributes
;
7973 -- Start of processing for Meet_Elaboration_Requirement
7976 pragma Assert
(Nam_In
(Req_Nam
, Name_Elaborate
, Name_Elaborate_All
));
7978 -- Assume that the requirement has not been met
7982 -- Elaboration requirements are verified only when the static model is
7983 -- in effect because this diagnostic is graph-dependent.
7985 if not Static_Elaboration_Checks
then
7988 -- If the target is within the main unit, either at the source level or
7989 -- through an instantiation, then there is no real requirement to meet
7990 -- because the main unit cannot force its own elaboration by means of an
7991 -- Elaborate[_All] pragma. Treat this case as valid coverage.
7993 elsif In_Extended_Main_Code_Unit
(Target_Id
) then
7996 -- Otherwise the target resides in an external unit
7998 -- The requirement is met when the target comes from an internal unit
7999 -- because such a unit is elaborated prior to a non-internal unit.
8001 elsif In_Internal_Unit
(Unit_Id
)
8002 and then not In_Internal_Unit
(Main_Id
)
8006 -- The requirement is met when the target comes from a preelaborated
8007 -- unit. This portion must parallel predicate Is_Preelaborated_Unit.
8009 elsif Is_Preelaborated_Unit
(Unit_Id
) then
8012 -- Output extra information when switch -gnatel (info messages on
8013 -- implicit Elaborate[_All] pragmas.
8015 if Elab_Info_Messages
then
8016 if Is_Preelaborated
(Unit_Id
) then
8017 Elab_Nam
:= Name_Preelaborate
;
8019 elsif Is_Pure
(Unit_Id
) then
8020 Elab_Nam
:= Name_Pure
;
8022 elsif Is_Remote_Call_Interface
(Unit_Id
) then
8023 Elab_Nam
:= Name_Remote_Call_Interface
;
8025 elsif Is_Remote_Types
(Unit_Id
) then
8026 Elab_Nam
:= Name_Remote_Types
;
8029 pragma Assert
(Is_Shared_Passive
(Unit_Id
));
8030 Elab_Nam
:= Name_Shared_Passive
;
8033 Info_Requirement_Met
(Find_Preelaboration_Pragma
(Elab_Nam
));
8036 -- Determine whether the context of the main unit has a pragma strong
8037 -- enough to meet the requirement.
8040 Elab_Attrs
:= Elaboration_Status
(Unit_Id
);
8042 -- The pragma must be either Elaborate_All or be as strong as the
8045 if Present
(Elab_Attrs
.Source_Pragma
)
8046 and then Nam_In
(Pragma_Name
(Elab_Attrs
.Source_Pragma
),
8052 -- Output extra information when switch -gnatel (info messages on
8053 -- implicit Elaborate[_All] pragmas.
8055 if Elab_Info_Messages
then
8056 Info_Requirement_Met
(Elab_Attrs
.Source_Pragma
);
8061 -- The requirement was not met by the context of the main unit, issue an
8067 Error_Msg_Name_1
:= Req_Nam
;
8068 Error_Msg_Node_2
:= Unit_Id
;
8069 Error_Msg_NE
("\\unit & requires pragma % for &", N
, Main_Id
);
8071 Output_Active_Scenarios
(N
);
8073 end Meet_Elaboration_Requirement
;
8075 ----------------------
8076 -- Non_Private_View --
8077 ----------------------
8079 function Non_Private_View
(Typ
: Entity_Id
) return Entity_Id
is
8081 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
8082 return Full_View
(Typ
);
8086 end Non_Private_View
;
8088 -----------------------------
8089 -- Output_Active_Scenarios --
8090 -----------------------------
8092 procedure Output_Active_Scenarios
(Error_Nod
: Node_Id
) is
8093 procedure Output_Access
(N
: Node_Id
);
8094 -- Emit a specific diagnostic message for 'Access denote by N
8096 procedure Output_Activation_Call
(N
: Node_Id
);
8097 -- Emit a specific diagnostic message for task activation N
8099 procedure Output_Call
(N
: Node_Id
; Target_Id
: Entity_Id
);
8100 -- Emit a specific diagnostic message for call N which invokes target
8103 procedure Output_Header
;
8104 -- Emit a specific diagnostic message for the unit of the root scenario
8106 procedure Output_Instantiation
(N
: Node_Id
);
8107 -- Emit a specific diagnostic message for instantiation N
8109 procedure Output_SPARK_Refined_State_Pragma
(N
: Node_Id
);
8110 -- Emit a specific diagnostic message for Refined_State pragma N
8112 procedure Output_Variable_Assignment
(N
: Node_Id
);
8113 -- Emit a specific diagnostic message for assignment statement N
8115 procedure Output_Variable_Reference
(N
: Node_Id
);
8116 -- Emit a specific diagnostic message for reference N which mentions a
8123 procedure Output_Access
(N
: Node_Id
) is
8124 Subp_Id
: constant Entity_Id
:= Entity
(Prefix
(N
));
8127 Error_Msg_Name_1
:= Attribute_Name
(N
);
8128 Error_Msg_Sloc
:= Sloc
(N
);
8129 Error_Msg_NE
("\\ % of & taken #", Error_Nod
, Subp_Id
);
8132 ----------------------------
8133 -- Output_Activation_Call --
8134 ----------------------------
8136 procedure Output_Activation_Call
(N
: Node_Id
) is
8137 function Find_Activator
(Call
: Node_Id
) return Entity_Id
;
8138 -- Find the nearest enclosing construct which houses call Call
8140 --------------------
8141 -- Find_Activator --
8142 --------------------
8144 function Find_Activator
(Call
: Node_Id
) return Entity_Id
is
8148 -- Climb the parent chain looking for a package [body] or a
8149 -- construct with a statement sequence.
8151 Par
:= Parent
(Call
);
8152 while Present
(Par
) loop
8153 if Nkind_In
(Par
, N_Package_Body
, N_Package_Declaration
) then
8154 return Defining_Entity
(Par
);
8156 elsif Nkind
(Par
) = N_Handled_Sequence_Of_Statements
then
8157 return Defining_Entity
(Parent
(Par
));
8160 Par
:= Parent
(Par
);
8168 Activator
: constant Entity_Id
:= Find_Activator
(N
);
8170 -- Start of processing for Output_Activation_Call
8173 pragma Assert
(Present
(Activator
));
8175 Error_Msg_NE
("\\ local tasks of & activated", Error_Nod
, Activator
);
8176 end Output_Activation_Call
;
8182 procedure Output_Call
(N
: Node_Id
; Target_Id
: Entity_Id
) is
8183 procedure Output_Accept_Alternative
;
8184 pragma Inline
(Output_Accept_Alternative
);
8185 -- Emit a specific diagnostic message concerning an accept
8188 procedure Output_Call
(Kind
: String);
8189 pragma Inline
(Output_Call
);
8190 -- Emit a specific diagnostic message concerning a call of kind Kind
8192 procedure Output_Type_Actions
(Action
: String);
8193 pragma Inline
(Output_Type_Actions
);
8194 -- Emit a specific diagnostic message concerning action Action of a
8197 procedure Output_Verification_Call
8201 pragma Inline
(Output_Verification_Call
);
8202 -- Emit a specific diagnostic message concerning the verification of
8203 -- predicate Pred applied to related entity Id with kind Id_Kind.
8205 -------------------------------
8206 -- Output_Accept_Alternative --
8207 -------------------------------
8209 procedure Output_Accept_Alternative
is
8210 Entry_Id
: constant Entity_Id
:= Receiving_Entry
(Target_Id
);
8213 pragma Assert
(Present
(Entry_Id
));
8215 Error_Msg_NE
("\\ entry & selected #", Error_Nod
, Entry_Id
);
8216 end Output_Accept_Alternative
;
8222 procedure Output_Call
(Kind
: String) is
8224 Error_Msg_NE
("\\ " & Kind
& " & called #", Error_Nod
, Target_Id
);
8227 -------------------------
8228 -- Output_Type_Actions --
8229 -------------------------
8231 procedure Output_Type_Actions
(Action
: String) is
8232 Typ
: constant Entity_Id
:= First_Formal_Type
(Target_Id
);
8235 pragma Assert
(Present
(Typ
));
8238 ("\\ " & Action
& " actions for type & #", Error_Nod
, Typ
);
8239 end Output_Type_Actions
;
8241 ------------------------------
8242 -- Output_Verification_Call --
8243 ------------------------------
8245 procedure Output_Verification_Call
8251 pragma Assert
(Present
(Id
));
8254 ("\\ " & Pred
& " of " & Id_Kind
& " & verified #",
8256 end Output_Verification_Call
;
8258 -- Start of processing for Output_Call
8261 Error_Msg_Sloc
:= Sloc
(N
);
8263 -- Accept alternative
8265 if Is_Accept_Alternative_Proc
(Target_Id
) then
8266 Output_Accept_Alternative
;
8270 elsif Is_TSS
(Target_Id
, TSS_Deep_Adjust
) then
8271 Output_Type_Actions
("adjustment");
8273 -- Default_Initial_Condition
8275 elsif Is_Default_Initial_Condition_Proc
(Target_Id
) then
8276 Output_Verification_Call
8277 (Pred
=> "Default_Initial_Condition",
8278 Id
=> First_Formal_Type
(Target_Id
),
8283 elsif Is_Protected_Entry
(Target_Id
) then
8284 Output_Call
("entry");
8286 -- Task entry calls are never processed because the entry being
8287 -- invoked does not have a corresponding "body", it has a select. A
8288 -- task entry call appears in the stack of active scenarios for the
8289 -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and
8292 elsif Is_Task_Entry
(Target_Id
) then
8297 elsif Is_TSS
(Target_Id
, TSS_Deep_Finalize
) then
8298 Output_Type_Actions
("finalization");
8300 -- Calls to _Finalizer procedures must not appear in the output
8301 -- because this creates confusing noise.
8303 elsif Is_Finalizer_Proc
(Target_Id
) then
8306 -- Initial_Condition
8308 elsif Is_Initial_Condition_Proc
(Target_Id
) then
8309 Output_Verification_Call
8310 (Pred
=> "Initial_Condition",
8311 Id
=> Find_Enclosing_Scope
(N
),
8312 Id_Kind
=> "package");
8316 elsif Is_Init_Proc
(Target_Id
)
8317 or else Is_TSS
(Target_Id
, TSS_Deep_Initialize
)
8319 Output_Type_Actions
("initialization");
8323 elsif Is_Invariant_Proc
(Target_Id
) then
8324 Output_Verification_Call
8325 (Pred
=> "invariants",
8326 Id
=> First_Formal_Type
(Target_Id
),
8329 -- Partial invariant calls must not appear in the output because this
8330 -- creates confusing noise. Note that a partial invariant is always
8331 -- invoked by the "full" invariant which is already placed on the
8334 elsif Is_Partial_Invariant_Proc
(Target_Id
) then
8339 elsif Is_Postconditions_Proc
(Target_Id
) then
8340 Output_Verification_Call
8341 (Pred
=> "postconditions",
8342 Id
=> Find_Enclosing_Scope
(N
),
8343 Id_Kind
=> "subprogram");
8345 -- Subprograms must come last because some of the previous cases fall
8346 -- under this category.
8348 elsif Ekind
(Target_Id
) = E_Function
then
8349 Output_Call
("function");
8351 elsif Ekind
(Target_Id
) = E_Procedure
then
8352 Output_Call
("procedure");
8355 pragma Assert
(False);
8364 procedure Output_Header
is
8365 Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(Root_Scenario
);
8368 if Ekind
(Unit_Id
) = E_Package
then
8369 Error_Msg_NE
("\\ spec of unit & elaborated", Error_Nod
, Unit_Id
);
8371 elsif Ekind
(Unit_Id
) = E_Package_Body
then
8372 Error_Msg_NE
("\\ body of unit & elaborated", Error_Nod
, Unit_Id
);
8375 Error_Msg_NE
("\\ in body of unit &", Error_Nod
, Unit_Id
);
8379 --------------------------
8380 -- Output_Instantiation --
8381 --------------------------
8383 procedure Output_Instantiation
(N
: Node_Id
) is
8384 procedure Output_Instantiation
(Gen_Id
: Entity_Id
; Kind
: String);
8385 pragma Inline
(Output_Instantiation
);
8386 -- Emit a specific diagnostic message concerning an instantiation of
8387 -- generic unit Gen_Id. Kind denotes the kind of the instantiation.
8389 --------------------------
8390 -- Output_Instantiation --
8391 --------------------------
8393 procedure Output_Instantiation
(Gen_Id
: Entity_Id
; Kind
: String) is
8396 ("\\ " & Kind
& " & instantiated as & #", Error_Nod
, Gen_Id
);
8397 end Output_Instantiation
;
8402 Inst_Attrs
: Instantiation_Attributes
;
8403 Inst_Id
: Entity_Id
;
8406 -- Start of processing for Output_Instantiation
8409 Extract_Instantiation_Attributes
8414 Attrs
=> Inst_Attrs
);
8416 Error_Msg_Node_2
:= Inst_Id
;
8417 Error_Msg_Sloc
:= Sloc
(Inst
);
8419 if Nkind
(Inst
) = N_Function_Instantiation
then
8420 Output_Instantiation
(Gen_Id
, "function");
8422 elsif Nkind
(Inst
) = N_Package_Instantiation
then
8423 Output_Instantiation
(Gen_Id
, "package");
8425 elsif Nkind
(Inst
) = N_Procedure_Instantiation
then
8426 Output_Instantiation
(Gen_Id
, "procedure");
8429 pragma Assert
(False);
8432 end Output_Instantiation
;
8434 ---------------------------------------
8435 -- Output_SPARK_Refined_State_Pragma --
8436 ---------------------------------------
8438 procedure Output_SPARK_Refined_State_Pragma
(N
: Node_Id
) is
8440 Error_Msg_Sloc
:= Sloc
(N
);
8441 Error_Msg_N
("\\ refinement constituents read #", Error_Nod
);
8442 end Output_SPARK_Refined_State_Pragma
;
8444 --------------------------------
8445 -- Output_Variable_Assignment --
8446 --------------------------------
8448 procedure Output_Variable_Assignment
(N
: Node_Id
) is
8449 Var_Id
: constant Entity_Id
:= Entity
(Extract_Assignment_Name
(N
));
8452 Error_Msg_Sloc
:= Sloc
(N
);
8453 Error_Msg_NE
("\\ variable & assigned #", Error_Nod
, Var_Id
);
8454 end Output_Variable_Assignment
;
8456 -------------------------------
8457 -- Output_Variable_Reference --
8458 -------------------------------
8460 procedure Output_Variable_Reference
(N
: Node_Id
) is
8461 Dummy
: Variable_Attributes
;
8465 Extract_Variable_Reference_Attributes
8470 Error_Msg_Sloc
:= Sloc
(N
);
8473 Error_Msg_NE
("\\ variable & read #", Error_Nod
, Var_Id
);
8476 pragma Assert
(False);
8479 end Output_Variable_Reference
;
8483 package Stack
renames Scenario_Stack
;
8485 Dummy
: Call_Attributes
;
8488 Target_Id
: Entity_Id
;
8490 -- Start of processing for Output_Active_Scenarios
8493 -- Active scenarios are emitted only when the static model is in effect
8494 -- because there is an inherent order by which all these scenarios were
8495 -- reached from the declaration or library level.
8497 if not Static_Elaboration_Checks
then
8503 for Index
in Stack
.First
.. Stack
.Last
loop
8504 N
:= Stack
.Table
(Index
);
8513 if Nkind
(N
) = N_Attribute_Reference
then
8518 elsif Is_Suitable_Call
(N
) then
8519 Extract_Call_Attributes
8521 Target_Id
=> Target_Id
,
8524 if Is_Activation_Proc
(Target_Id
) then
8525 Output_Activation_Call
(N
);
8527 Output_Call
(N
, Target_Id
);
8532 elsif Is_Suitable_Instantiation
(N
) then
8533 Output_Instantiation
(N
);
8535 -- Pragma Refined_State
8537 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
8538 Output_SPARK_Refined_State_Pragma
(N
);
8540 -- Variable assignments
8542 elsif Nkind
(N
) = N_Assignment_Statement
then
8543 Output_Variable_Assignment
(N
);
8545 -- Variable references
8547 elsif Is_Suitable_Variable_Reference
(N
) then
8548 Output_Variable_Reference
(N
);
8551 pragma Assert
(False);
8555 end Output_Active_Scenarios
;
8557 -------------------------
8558 -- Pop_Active_Scenario --
8559 -------------------------
8561 procedure Pop_Active_Scenario
(N
: Node_Id
) is
8562 Top
: Node_Id
renames Scenario_Stack
.Table
(Scenario_Stack
.Last
);
8565 pragma Assert
(Top
= N
);
8566 Scenario_Stack
.Decrement_Last
;
8567 end Pop_Active_Scenario
;
8569 --------------------------------
8570 -- Process_Activation_Generic --
8571 --------------------------------
8573 procedure Process_Activation_Generic
8575 Call_Attrs
: Call_Attributes
;
8576 State
: Processing_Attributes
)
8578 procedure Process_Task_Object
(Obj_Id
: Entity_Id
; Typ
: Entity_Id
);
8579 -- Perform ABE checks and diagnostics for object Obj_Id with type Typ.
8580 -- Typ may be a task type or a composite type with at least one task
8583 procedure Process_Task_Objects
(List
: List_Id
);
8584 -- Perform ABE checks and diagnostics for all task objects found in the
8587 -------------------------
8588 -- Process_Task_Object --
8589 -------------------------
8591 procedure Process_Task_Object
(Obj_Id
: Entity_Id
; Typ
: Entity_Id
) is
8592 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
8594 Comp_Id
: Entity_Id
;
8595 Task_Attrs
: Task_Attributes
;
8597 New_State
: Processing_Attributes
:= State
;
8598 -- Each step of the Processing phase constitutes a new state
8601 if Is_Task_Type
(Typ
) then
8602 Extract_Task_Attributes
8604 Attrs
=> Task_Attrs
);
8606 -- Warnings are suppressed when a prior scenario is already in
8607 -- that mode, or when the object, activation call, or task type
8608 -- have warnings suppressed. Update the state of the Processing
8609 -- phase to reflect this.
8611 New_State
.Suppress_Warnings
:=
8612 New_State
.Suppress_Warnings
8613 or else not Is_Elaboration_Warnings_OK_Id
(Obj_Id
)
8614 or else not Call_Attrs
.Elab_Warnings_OK
8615 or else not Task_Attrs
.Elab_Warnings_OK
;
8617 -- Update the state of the Processing phase to indicate that any
8618 -- further traversal is now within a task body.
8620 New_State
.Within_Task_Body
:= True;
8622 Process_Single_Activation
8624 Call_Attrs
=> Call_Attrs
,
8626 Task_Attrs
=> Task_Attrs
,
8627 State
=> New_State
);
8629 -- Examine the component type when the object is an array
8631 elsif Is_Array_Type
(Typ
) and then Has_Task
(Base_Typ
) then
8634 Typ
=> Component_Type
(Typ
));
8636 -- Examine individual component types when the object is a record
8638 elsif Is_Record_Type
(Typ
) and then Has_Task
(Base_Typ
) then
8639 Comp_Id
:= First_Component
(Typ
);
8640 while Present
(Comp_Id
) loop
8643 Typ
=> Etype
(Comp_Id
));
8645 Next_Component
(Comp_Id
);
8648 end Process_Task_Object
;
8650 --------------------------
8651 -- Process_Task_Objects --
8652 --------------------------
8654 procedure Process_Task_Objects
(List
: List_Id
) is
8656 Item_Id
: Entity_Id
;
8657 Item_Typ
: Entity_Id
;
8660 -- Examine the contents of the list looking for an object declaration
8661 -- of a task type or one that contains a task within.
8663 Item
:= First
(List
);
8664 while Present
(Item
) loop
8665 if Nkind
(Item
) = N_Object_Declaration
then
8666 Item_Id
:= Defining_Entity
(Item
);
8667 Item_Typ
:= Etype
(Item_Id
);
8669 if Has_Task
(Item_Typ
) then
8678 end Process_Task_Objects
;
8685 -- Start of processing for Process_Activation_Generic
8688 -- Nothing to do when the activation is a guaranteed ABE
8690 if Is_Known_Guaranteed_ABE
(Call
) then
8694 -- Find the proper context of the activation call where all task objects
8695 -- being activated are declared. This is usually the immediate parent of
8698 Context
:= Parent
(Call
);
8700 -- In the case of package bodies, the activation call is in the handled
8701 -- sequence of statements, but the task objects are in the declaration
8702 -- list of the body.
8704 if Nkind
(Context
) = N_Handled_Sequence_Of_Statements
8705 and then Nkind
(Parent
(Context
)) = N_Package_Body
8707 Context
:= Parent
(Context
);
8710 -- Process all task objects defined in both the spec and body when the
8711 -- activation call precedes the "begin" of a package body.
8713 if Nkind
(Context
) = N_Package_Body
then
8716 (Unit_Declaration_Node
(Corresponding_Spec
(Context
)));
8718 Process_Task_Objects
(Visible_Declarations
(Spec
));
8719 Process_Task_Objects
(Private_Declarations
(Spec
));
8720 Process_Task_Objects
(Declarations
(Context
));
8722 -- Process all task objects defined in the spec when the activation call
8723 -- appears at the end of a package spec.
8725 elsif Nkind
(Context
) = N_Package_Specification
then
8726 Process_Task_Objects
(Visible_Declarations
(Context
));
8727 Process_Task_Objects
(Private_Declarations
(Context
));
8729 -- Otherwise the context of the activation is some construct with a
8730 -- declarative part. Note that the corresponding record type of a task
8731 -- type is controlled. Because of this, the finalization machinery must
8732 -- relocate the task object to the handled statements of the construct
8733 -- to perform proper finalization in case of an exception. Examine the
8734 -- statements of the construct rather than the declarations.
8737 pragma Assert
(Nkind
(Context
) = N_Handled_Sequence_Of_Statements
);
8739 Process_Task_Objects
(Statements
(Context
));
8741 end Process_Activation_Generic
;
8743 ------------------------------------
8744 -- Process_Conditional_ABE_Access --
8745 ------------------------------------
8747 procedure Process_Conditional_ABE_Access
8749 State
: Processing_Attributes
)
8751 function Build_Access_Marker
(Target_Id
: Entity_Id
) return Node_Id
;
8752 pragma Inline
(Build_Access_Marker
);
8753 -- Create a suitable call marker which invokes target Target_Id
8755 -------------------------
8756 -- Build_Access_Marker --
8757 -------------------------
8759 function Build_Access_Marker
(Target_Id
: Entity_Id
) return Node_Id
is
8763 Marker
:= Make_Call_Marker
(Sloc
(Attr
));
8765 -- Inherit relevant attributes from the attribute
8767 -- Performance note: parent traversal
8769 Set_Target
(Marker
, Target_Id
);
8770 Set_Is_Declaration_Level_Node
8771 (Marker
, Find_Enclosing_Level
(Attr
) = Declaration_Level
);
8772 Set_Is_Dispatching_Call
8774 Set_Is_Elaboration_Checks_OK_Node
8775 (Marker
, Is_Elaboration_Checks_OK_Node
(Attr
));
8776 Set_Is_Elaboration_Warnings_OK_Node
8777 (Marker
, Is_Elaboration_Warnings_OK_Node
(Attr
));
8779 (Marker
, Comes_From_Source
(Attr
));
8780 Set_Is_SPARK_Mode_On_Node
8781 (Marker
, Is_SPARK_Mode_On_Node
(Attr
));
8783 -- Partially insert the call marker into the tree by setting its
8786 Set_Parent
(Marker
, Attr
);
8789 end Build_Access_Marker
;
8793 Root
: constant Node_Id
:= Root_Scenario
;
8794 Target_Id
: constant Entity_Id
:= Entity
(Prefix
(Attr
));
8796 Target_Attrs
: Target_Attributes
;
8798 New_State
: Processing_Attributes
:= State
;
8799 -- Each step of the Processing phase constitutes a new state
8801 -- Start of processing for Process_Conditional_ABE_Access
8804 -- Output relevant information when switch -gnatel (info messages on
8805 -- implicit Elaborate[_All] pragmas) is in effect.
8807 if Elab_Info_Messages
then
8809 ("info: access to & during elaboration", Attr
, Target_Id
);
8812 Extract_Target_Attributes
8813 (Target_Id
=> Target_Id
,
8814 Attrs
=> Target_Attrs
);
8816 -- Warnings are suppressed when a prior scenario is already in that
8817 -- mode, or when the attribute or the target have warnings suppressed.
8818 -- Update the state of the Processing phase to reflect this.
8820 New_State
.Suppress_Warnings
:=
8821 New_State
.Suppress_Warnings
8822 or else not Is_Elaboration_Warnings_OK_Node
(Attr
)
8823 or else not Target_Attrs
.Elab_Warnings_OK
;
8825 -- Do not emit any ABE diagnostics when the current or previous scenario
8826 -- in this traversal has suppressed elaboration warnings.
8828 if New_State
.Suppress_Warnings
then
8831 -- Both the attribute and the corresponding body are in the same unit.
8832 -- The corresponding body must appear prior to the root scenario which
8833 -- started the recursive search. If this is not the case, then there is
8834 -- a potential ABE if the access value is used to call the subprogram.
8835 -- Emit a warning only when switch -gnatw.f (warnings on suspucious
8836 -- 'Access) is in effect.
8838 elsif Warn_On_Elab_Access
8839 and then Present
(Target_Attrs
.Body_Decl
)
8840 and then In_Extended_Main_Code_Unit
(Target_Attrs
.Body_Decl
)
8841 and then Earlier_In_Extended_Unit
(Root
, Target_Attrs
.Body_Decl
)
8843 Error_Msg_Name_1
:= Attribute_Name
(Attr
);
8844 Error_Msg_NE
("??% attribute of & before body seen", Attr
, Target_Id
);
8845 Error_Msg_N
("\possible Program_Error on later references", Attr
);
8847 Output_Active_Scenarios
(Attr
);
8850 -- Treat the attribute as an immediate invocation of the target when
8851 -- switch -gnatd.o (conservative elaboration order for indirect calls)
8852 -- is in effect. Note that the prior elaboration of the unit containing
8853 -- the target is ensured processing the corresponding call marker.
8855 if Debug_Flag_Dot_O
then
8856 Process_Conditional_ABE
8857 (N
=> Build_Access_Marker
(Target_Id
),
8858 State
=> New_State
);
8860 -- Otherwise ensure that the unit with the corresponding body is
8861 -- elaborated prior to the main unit.
8864 Ensure_Prior_Elaboration
8866 Unit_Id
=> Target_Attrs
.Unit_Id
,
8867 Prag_Nam
=> Name_Elaborate_All
,
8868 State
=> New_State
);
8870 end Process_Conditional_ABE_Access
;
8872 ---------------------------------------------
8873 -- Process_Conditional_ABE_Activation_Impl --
8874 ---------------------------------------------
8876 procedure Process_Conditional_ABE_Activation_Impl
8878 Call_Attrs
: Call_Attributes
;
8880 Task_Attrs
: Task_Attributes
;
8881 State
: Processing_Attributes
)
8883 Check_OK
: constant Boolean :=
8884 not Is_Ignored_Ghost_Entity
(Obj_Id
)
8885 and then not Task_Attrs
.Ghost_Mode_Ignore
8886 and then Is_Elaboration_Checks_OK_Id
(Obj_Id
)
8887 and then Task_Attrs
.Elab_Checks_OK
;
8888 -- A run-time ABE check may be installed only when the object and the
8889 -- task type have active elaboration checks, and both are not ignored
8890 -- Ghost constructs.
8892 Root
: constant Node_Id
:= Root_Scenario
;
8894 New_State
: Processing_Attributes
:= State
;
8895 -- Each step of the Processing phase constitutes a new state
8898 -- Output relevant information when switch -gnatel (info messages on
8899 -- implicit Elaborate[_All] pragmas) is in effect.
8901 if Elab_Info_Messages
then
8903 ("info: activation of & during elaboration", Call
, Obj_Id
);
8906 -- Nothing to do when the call activates a task whose type is defined
8907 -- within an instance and switch -gnatd_i (ignore activations and calls
8908 -- to instances for elaboration) is in effect.
8910 if Debug_Flag_Underscore_I
8911 and then In_External_Instance
8913 Target_Decl
=> Task_Attrs
.Task_Decl
)
8917 -- Nothing to do when the activation is a guaranteed ABE
8919 elsif Is_Known_Guaranteed_ABE
(Call
) then
8922 -- Nothing to do when the root scenario appears at the declaration
8923 -- level and the task is in the same unit, but outside this context.
8925 -- task type Task_Typ; -- task declaration
8927 -- procedure Proc is
8928 -- function A ... is
8930 -- if Some_Condition then
8934 -- <activation call> -- activation site
8939 -- X : ... := A; -- root scenario
8942 -- task body Task_Typ is
8946 -- In the example above, the context of X is the declarative list of
8947 -- Proc. The "elaboration" of X may reach the activation of T whose body
8948 -- is defined outside of X's context. The task body is relevant only
8949 -- when Proc is invoked, but this happens only in "normal" elaboration,
8950 -- therefore the task body must not be considered if this is not the
8953 -- Performance note: parent traversal
8955 elsif Is_Up_Level_Target
(Task_Attrs
.Task_Decl
) then
8958 -- Nothing to do when the activation is ABE-safe
8962 -- task type Task_Typ;
8965 -- package body Gen is
8966 -- task body Task_Typ is
8973 -- procedure Main is
8974 -- package Nested is
8975 -- package Inst is new Gen;
8976 -- T : Inst.Task_Typ;
8977 -- <activation call> -- safe activation
8981 elsif Is_Safe_Activation
(Call
, Task_Attrs
.Task_Decl
) then
8983 -- Note that the task body must still be examined for any nested
8988 -- The activation call and the task body are both in the main unit
8990 elsif Present
(Task_Attrs
.Body_Decl
)
8991 and then In_Extended_Main_Code_Unit
(Task_Attrs
.Body_Decl
)
8993 -- If the root scenario appears prior to the task body, then this is
8994 -- a possible ABE with respect to the root scenario.
8996 -- task type Task_Typ;
8998 -- function A ... is
9000 -- if Some_Condition then
9004 -- end Pack; -- activation of T
9008 -- X : ... := A; -- root scenario
9010 -- task body Task_Typ is -- task body
9014 -- Y : ... := A; -- root scenario
9016 -- IMPORTANT: The activation of T is a possible ABE for X, but
9017 -- not for Y. Intalling an unconditional ABE raise prior to the
9018 -- activation call would be wrong as it will fail for Y as well
9019 -- but in Y's case the activation of T is never an ABE.
9021 if Earlier_In_Extended_Unit
(Root
, Task_Attrs
.Body_Decl
) then
9023 -- Do not emit any ABE diagnostics when a previous scenario in
9024 -- this traversal has suppressed elaboration warnings.
9026 if State
.Suppress_Warnings
then
9029 -- Do not emit any ABE diagnostics when the activation occurs in
9030 -- a partial finalization context because this leads to confusing
9033 elsif State
.Within_Partial_Finalization
then
9036 -- ABE diagnostics are emitted only in the static model because
9037 -- there is a well-defined order to visiting scenarios. Without
9038 -- this order diagnostics appear jumbled and result in unwanted
9041 elsif Static_Elaboration_Checks
then
9042 Error_Msg_Sloc
:= Sloc
(Call
);
9044 ("??task & will be activated # before elaboration of its "
9047 ("\Program_Error may be raised at run time", Obj_Id
);
9049 Output_Active_Scenarios
(Obj_Id
);
9052 -- Install a conditional run-time ABE check to verify that the
9053 -- task body has been elaborated prior to the activation call.
9059 Target_Id
=> Task_Attrs
.Spec_Id
,
9060 Target_Decl
=> Task_Attrs
.Task_Decl
,
9061 Target_Body
=> Task_Attrs
.Body_Decl
);
9063 -- Update the state of the Processing phase to indicate that
9064 -- no implicit Elaborate[_All] pragmas must be generated from
9067 -- task type Task_Typ;
9069 -- function A ... is
9071 -- if Some_Condition then
9076 -- end Pack; -- activation of T
9082 -- task body Task_Typ is
9084 -- External.Subp; -- imparts Elaborate_All
9087 -- If Some_Condition is True, then the ABE check will fail at
9088 -- runtime and the call to External.Subp will never take place,
9089 -- rendering the implicit Elaborate_All useless.
9091 -- If Some_Condition is False, then the call to External.Subp
9092 -- will never take place, rendering the implicit Elaborate_All
9095 New_State
.Suppress_Implicit_Pragmas
:= True;
9099 -- Otherwise the task body is not available in this compilation or it
9100 -- resides in an external unit. Install a run-time ABE check to verify
9101 -- that the task body has been elaborated prior to the activation call
9102 -- when the dynamic model is in effect.
9104 elsif Dynamic_Elaboration_Checks
and then Check_OK
then
9108 Id
=> Task_Attrs
.Unit_Id
);
9111 -- Both the activation call and task type are subject to SPARK_Mode
9112 -- On, this triggers the SPARK rules for task activation. Compared to
9113 -- calls and instantiations, task activation in SPARK does not require
9114 -- the presence of Elaborate[_All] pragmas in case the task type is
9115 -- defined outside the main unit. This is because SPARK utilizes a
9116 -- special policy which activates all tasks after the main unit has
9117 -- finished its elaboration.
9119 if Call_Attrs
.SPARK_Mode_On
and Task_Attrs
.SPARK_Mode_On
then
9122 -- Otherwise the Ada rules are in effect. Ensure that the unit with the
9123 -- task body is elaborated prior to the main unit.
9126 Ensure_Prior_Elaboration
9128 Unit_Id
=> Task_Attrs
.Unit_Id
,
9129 Prag_Nam
=> Name_Elaborate_All
,
9130 State
=> New_State
);
9134 (N
=> Task_Attrs
.Body_Decl
,
9135 State
=> New_State
);
9136 end Process_Conditional_ABE_Activation_Impl
;
9138 procedure Process_Conditional_ABE_Activation
is
9139 new Process_Activation_Generic
(Process_Conditional_ABE_Activation_Impl
);
9141 ----------------------------------
9142 -- Process_Conditional_ABE_Call --
9143 ----------------------------------
9145 procedure Process_Conditional_ABE_Call
9147 Call_Attrs
: Call_Attributes
;
9148 Target_Id
: Entity_Id
;
9149 State
: Processing_Attributes
)
9151 function In_Initialization_Context
(N
: Node_Id
) return Boolean;
9152 -- Determine whether arbitrary node N appears within a type init proc,
9153 -- primitive [Deep_]Initialize, or a block created for initialization
9156 function Is_Partial_Finalization_Proc
return Boolean;
9157 pragma Inline
(Is_Partial_Finalization_Proc
);
9158 -- Determine whether call Call with target Target_Id invokes a partial
9159 -- finalization procedure.
9161 -------------------------------
9162 -- In_Initialization_Context --
9163 -------------------------------
9165 function In_Initialization_Context
(N
: Node_Id
) return Boolean is
9167 Spec_Id
: Entity_Id
;
9170 -- Climb the parent chain looking for initialization actions
9173 while Present
(Par
) loop
9175 -- A block may be part of the initialization actions of a default
9176 -- initialized object.
9178 if Nkind
(Par
) = N_Block_Statement
9179 and then Is_Initialization_Block
(Par
)
9183 -- A subprogram body may denote an initialization routine
9185 elsif Nkind
(Par
) = N_Subprogram_Body
then
9186 Spec_Id
:= Unique_Defining_Entity
(Par
);
9188 -- The current subprogram body denotes a type init proc or
9189 -- primitive [Deep_]Initialize.
9191 if Is_Init_Proc
(Spec_Id
)
9192 or else Is_Controlled_Proc
(Spec_Id
, Name_Initialize
)
9193 or else Is_TSS
(Spec_Id
, TSS_Deep_Initialize
)
9198 -- Prevent the search from going too far
9200 elsif Is_Body_Or_Package_Declaration
(Par
) then
9204 Par
:= Parent
(Par
);
9208 end In_Initialization_Context
;
9210 ----------------------------------
9211 -- Is_Partial_Finalization_Proc --
9212 ----------------------------------
9214 function Is_Partial_Finalization_Proc
return Boolean is
9216 -- To qualify, the target must denote primitive [Deep_]Finalize or a
9217 -- finalizer procedure, and the call must appear in an initialization
9221 (Is_Controlled_Proc
(Target_Id
, Name_Finalize
)
9222 or else Is_Finalizer_Proc
(Target_Id
)
9223 or else Is_TSS
(Target_Id
, TSS_Deep_Finalize
))
9224 and then In_Initialization_Context
(Call
);
9225 end Is_Partial_Finalization_Proc
;
9229 SPARK_Rules_On
: Boolean;
9230 Target_Attrs
: Target_Attributes
;
9232 New_State
: Processing_Attributes
:= State
;
9233 -- Each step of the Processing phase constitutes a new state
9235 -- Start of processing for Process_Conditional_ABE_Call
9238 Extract_Target_Attributes
9239 (Target_Id
=> Target_Id
,
9240 Attrs
=> Target_Attrs
);
9242 -- The SPARK rules are in effect when both the call and target are
9243 -- subject to SPARK_Mode On.
9246 Call_Attrs
.SPARK_Mode_On
and Target_Attrs
.SPARK_Mode_On
;
9248 -- Output relevant information when switch -gnatel (info messages on
9249 -- implicit Elaborate[_All] pragmas) is in effect.
9251 if Elab_Info_Messages
then
9254 Target_Id
=> Target_Id
,
9256 In_SPARK
=> SPARK_Rules_On
);
9259 -- Check whether the invocation of an entry clashes with an existing
9262 if Is_Protected_Entry
(Target_Id
) then
9263 Check_Restriction
(No_Entry_Calls_In_Elaboration_Code
, Call
);
9265 elsif Is_Task_Entry
(Target_Id
) then
9266 Check_Restriction
(No_Entry_Calls_In_Elaboration_Code
, Call
);
9268 -- Task entry calls are never processed because the entry being
9269 -- invoked does not have a corresponding "body", it has a select.
9274 -- Nothing to do when the call invokes a target defined within an
9275 -- instance and switch -gnatd_i (ignore activations and calls to
9276 -- instances for elaboration) is in effect.
9278 if Debug_Flag_Underscore_I
9279 and then In_External_Instance
9281 Target_Decl
=> Target_Attrs
.Spec_Decl
)
9285 -- Nothing to do when the call is a guaranteed ABE
9287 elsif Is_Known_Guaranteed_ABE
(Call
) then
9290 -- Nothing to do when the root scenario appears at the declaration level
9291 -- and the target is in the same unit, but outside this context.
9293 -- function B ...; -- target declaration
9295 -- procedure Proc is
9296 -- function A ... is
9298 -- if Some_Condition then
9299 -- return B; -- call site
9303 -- X : ... := A; -- root scenario
9306 -- function B ... is
9310 -- In the example above, the context of X is the declarative region of
9311 -- Proc. The "elaboration" of X may eventually reach B which is defined
9312 -- outside of X's context. B is relevant only when Proc is invoked, but
9313 -- this happens only by means of "normal" elaboration, therefore B must
9314 -- not be considered if this is not the case.
9316 -- Performance note: parent traversal
9318 elsif Is_Up_Level_Target
(Target_Attrs
.Spec_Decl
) then
9322 -- Warnings are suppressed when a prior scenario is already in that
9323 -- mode, or the call or target have warnings suppressed. Update the
9324 -- state of the Processing phase to reflect this.
9326 New_State
.Suppress_Warnings
:=
9327 New_State
.Suppress_Warnings
9328 or else not Call_Attrs
.Elab_Warnings_OK
9329 or else not Target_Attrs
.Elab_Warnings_OK
;
9331 -- The call occurs in an initial condition context when a prior scenario
9332 -- is already in that mode, or when the target is an Initial_Condition
9333 -- procedure. Update the state of the Processing phase to reflect this.
9335 New_State
.Within_Initial_Condition
:=
9336 New_State
.Within_Initial_Condition
9337 or else Is_Initial_Condition_Proc
(Target_Id
);
9339 -- The call occurs in a partial finalization context when a prior
9340 -- scenario is already in that mode, or when the target denotes a
9341 -- [Deep_]Finalize primitive or a finalizer within an initialization
9342 -- context. Update the state of the Processing phase to reflect this.
9344 New_State
.Within_Partial_Finalization
:=
9345 New_State
.Within_Partial_Finalization
9346 or else Is_Partial_Finalization_Proc
;
9348 -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK
9349 -- elaboration rules in SPARK code) is intentionally not taken into
9350 -- account here because Process_Conditional_ABE_Call_SPARK has two
9351 -- separate modes of operation.
9353 if SPARK_Rules_On
then
9354 Process_Conditional_ABE_Call_SPARK
9356 Target_Id
=> Target_Id
,
9357 Target_Attrs
=> Target_Attrs
,
9358 State
=> New_State
);
9360 -- Otherwise the Ada rules are in effect
9363 Process_Conditional_ABE_Call_Ada
9365 Call_Attrs
=> Call_Attrs
,
9366 Target_Id
=> Target_Id
,
9367 Target_Attrs
=> Target_Attrs
,
9368 State
=> New_State
);
9371 -- Inspect the target body (and barried function) for other suitable
9372 -- elaboration scenarios.
9375 (N
=> Target_Attrs
.Body_Barf
,
9376 State
=> New_State
);
9379 (N
=> Target_Attrs
.Body_Decl
,
9380 State
=> New_State
);
9381 end Process_Conditional_ABE_Call
;
9383 --------------------------------------
9384 -- Process_Conditional_ABE_Call_Ada --
9385 --------------------------------------
9387 procedure Process_Conditional_ABE_Call_Ada
9389 Call_Attrs
: Call_Attributes
;
9390 Target_Id
: Entity_Id
;
9391 Target_Attrs
: Target_Attributes
;
9392 State
: Processing_Attributes
)
9394 Check_OK
: constant Boolean :=
9395 not Call_Attrs
.Ghost_Mode_Ignore
9396 and then not Target_Attrs
.Ghost_Mode_Ignore
9397 and then Call_Attrs
.Elab_Checks_OK
9398 and then Target_Attrs
.Elab_Checks_OK
;
9399 -- A run-time ABE check may be installed only when both the call and the
9400 -- target have active elaboration checks, and both are not ignored Ghost
9403 Root
: constant Node_Id
:= Root_Scenario
;
9405 New_State
: Processing_Attributes
:= State
;
9406 -- Each step of the Processing phase constitutes a new state
9409 -- Nothing to do for an Ada dispatching call because there are no ABE
9410 -- diagnostics for either models. ABE checks for the dynamic model are
9411 -- handled by Install_Primitive_Elaboration_Check.
9413 if Call_Attrs
.Is_Dispatching
then
9416 -- Nothing to do when the call is ABE-safe
9419 -- function Gen ...;
9421 -- function Gen ... is
9427 -- procedure Main is
9428 -- function Inst is new Gen;
9429 -- X : ... := Inst; -- safe call
9432 elsif Is_Safe_Call
(Call
, Target_Attrs
) then
9435 -- The call and the target body are both in the main unit
9437 elsif Present
(Target_Attrs
.Body_Decl
)
9438 and then In_Extended_Main_Code_Unit
(Target_Attrs
.Body_Decl
)
9440 -- If the root scenario appears prior to the target body, then this
9441 -- is a possible ABE with respect to the root scenario.
9445 -- function A ... is
9447 -- if Some_Condition then
9448 -- return B; -- call site
9452 -- X : ... := A; -- root scenario
9454 -- function B ... is -- target body
9458 -- Y : ... := A; -- root scenario
9460 -- IMPORTANT: The call to B from A is a possible ABE for X, but not
9461 -- for Y. Installing an unconditional ABE raise prior to the call to
9462 -- B would be wrong as it will fail for Y as well, but in Y's case
9463 -- the call to B is never an ABE.
9465 if Earlier_In_Extended_Unit
(Root
, Target_Attrs
.Body_Decl
) then
9467 -- Do not emit any ABE diagnostics when a previous scenario in
9468 -- this traversal has suppressed elaboration warnings.
9470 if State
.Suppress_Warnings
then
9473 -- Do not emit any ABE diagnostics when the call occurs in a
9474 -- partial finalization context because this leads to confusing
9477 elsif State
.Within_Partial_Finalization
then
9480 -- ABE diagnostics are emitted only in the static model because
9481 -- there is a well-defined order to visiting scenarios. Without
9482 -- this order diagnostics appear jumbled and result in unwanted
9485 elsif Static_Elaboration_Checks
then
9487 ("??cannot call & before body seen", Call
, Target_Id
);
9488 Error_Msg_N
("\Program_Error may be raised at run time", Call
);
9490 Output_Active_Scenarios
(Call
);
9493 -- Install a conditional run-time ABE check to verify that the
9494 -- target body has been elaborated prior to the call.
9500 Target_Id
=> Target_Attrs
.Spec_Id
,
9501 Target_Decl
=> Target_Attrs
.Spec_Decl
,
9502 Target_Body
=> Target_Attrs
.Body_Decl
);
9504 -- Update the state of the Processing phase to indicate that
9505 -- no implicit Elaborate[_All] pragmas must be generated from
9510 -- function A ... is
9512 -- if Some_Condition then
9520 -- function B ... is
9521 -- External.Subp; -- imparts Elaborate_All
9524 -- If Some_Condition is True, then the ABE check will fail at
9525 -- runtime and the call to External.Subp will never take place,
9526 -- rendering the implicit Elaborate_All useless.
9528 -- If Some_Condition is False, then the call to External.Subp
9529 -- will never take place, rendering the implicit Elaborate_All
9532 New_State
.Suppress_Implicit_Pragmas
:= True;
9536 -- Otherwise the target body is not available in this compilation or it
9537 -- resides in an external unit. Install a run-time ABE check to verify
9538 -- that the target body has been elaborated prior to the call site when
9539 -- the dynamic model is in effect.
9541 elsif Dynamic_Elaboration_Checks
and then Check_OK
then
9545 Id
=> Target_Attrs
.Unit_Id
);
9548 -- Ensure that the unit with the target body is elaborated prior to the
9549 -- main unit. The implicit Elaborate[_All] is generated only when the
9550 -- call has elaboration checks enabled. This behaviour parallels that of
9551 -- the old ABE mechanism.
9553 if Call_Attrs
.Elab_Checks_OK
then
9554 Ensure_Prior_Elaboration
9556 Unit_Id
=> Target_Attrs
.Unit_Id
,
9557 Prag_Nam
=> Name_Elaborate_All
,
9558 State
=> New_State
);
9560 end Process_Conditional_ABE_Call_Ada
;
9562 ----------------------------------------
9563 -- Process_Conditional_ABE_Call_SPARK --
9564 ----------------------------------------
9566 procedure Process_Conditional_ABE_Call_SPARK
9568 Target_Id
: Entity_Id
;
9569 Target_Attrs
: Target_Attributes
;
9570 State
: Processing_Attributes
)
9575 -- Ensure that a suitable elaboration model is in effect for SPARK rule
9578 Check_SPARK_Model_In_Effect
(Call
);
9580 -- The call and the target body are both in the main unit
9582 if Present
(Target_Attrs
.Body_Decl
)
9583 and then In_Extended_Main_Code_Unit
(Target_Attrs
.Body_Decl
)
9585 -- If the call appears prior to the target body, then the call must
9586 -- appear within the early call region of the target body.
9590 -- X : ... := B; -- call site
9592 -- <preelaborable construct 1> --+
9593 -- ... | early call region
9594 -- <preelaborable construct N> --+
9596 -- function B ... is -- target body
9600 -- When the call to B is not nested within some other scenario, the
9601 -- call is automatically illegal because it can never appear in the
9602 -- early call region of B's body. This is equivalent to a guaranteed
9605 -- <preelaborable construct 1> --+
9607 -- function B ...; |
9609 -- function A ... is |
9610 -- begin | early call region
9611 -- if Some_Condition then
9612 -- return B; -- call site
9616 -- <preelaborable construct N> --+
9618 -- function B ... is -- target body
9622 -- When the call to B is nested within some other scenario, the call
9623 -- is always ABE-safe. It is not immediately obvious why this is the
9624 -- case. The elaboration safety follows from the early call region
9625 -- rule being applied to ALL calls preceding their associated bodies.
9627 -- In the example above, the call to B is safe as long as the call to
9628 -- A is safe. There are several cases to consider:
9634 -- function A ... is
9636 -- if Some_Condition then
9642 -- function B ... is
9646 -- * Call 1 - This call is either nested within some scenario or not,
9647 -- which falls under the two general cases outlined above.
9649 -- * Call 2 - This is the same case as Call 1.
9651 -- * Call 3 - The placement of this call limits the range of B's
9652 -- early call region unto call 3, therefore the call to B is no
9653 -- longer within the early call region of B's body, making it ABE-
9654 -- unsafe and therefore illegal.
9656 if Earlier_In_Extended_Unit
(Call
, Target_Attrs
.Body_Decl
) then
9658 -- Do not emit any ABE diagnostics when a previous scenario in
9659 -- this traversal has suppressed elaboration warnings.
9661 if State
.Suppress_Warnings
then
9664 -- Do not emit any ABE diagnostics when the call occurs in an
9665 -- initial condition context because this leads to incorrect
9668 elsif State
.Within_Initial_Condition
then
9671 -- Do not emit any ABE diagnostics when the call occurs in a
9672 -- partial finalization context because this leads to confusing
9675 elsif State
.Within_Partial_Finalization
then
9678 -- ABE diagnostics are emitted only in the static model because
9679 -- there is a well-defined order to visiting scenarios. Without
9680 -- this order diagnostics appear jumbled and result in unwanted
9683 elsif Static_Elaboration_Checks
then
9685 -- Ensure that a call which textually precedes the subprogram
9686 -- body it invokes appears within the early call region of the
9689 -- IMPORTANT: This check must always be performed even when
9690 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is
9691 -- not specified because the static model cannot guarantee the
9692 -- absence of elaboration issues in the presence of dispatching
9695 Region
:= Find_Early_Call_Region
(Target_Attrs
.Body_Decl
);
9697 if Earlier_In_Extended_Unit
(Call
, Region
) then
9699 ("call must appear within early call region of subprogram "
9700 & "body & (SPARK RM 7.7(3))", Call
, Target_Id
);
9702 Error_Msg_Sloc
:= Sloc
(Region
);
9703 Error_Msg_N
("\region starts #", Call
);
9705 Error_Msg_Sloc
:= Sloc
(Target_Attrs
.Body_Decl
);
9706 Error_Msg_N
("\region ends #", Call
);
9708 Output_Active_Scenarios
(Call
);
9712 -- Otherwise the call appears after the target body. The call is
9713 -- ABE-safe as a consequence of applying the early call region rule
9714 -- to ALL calls preceding their associated bodies.
9721 -- A call to a source target or to a target which emulates Ada or SPARK
9722 -- semantics imposes an Elaborate_All requirement on the context of the
9723 -- main unit. Determine whether the context has a pragma strong enough
9724 -- to meet the requirement.
9726 -- IMPORTANT: This check must be performed only when -gnatd.v (enforce
9727 -- SPARK elaboration rules in SPARK code) is active because the static
9728 -- model can ensure the prior elaboration of the unit which contains a
9729 -- body by installing an implicit Elaborate[_All] pragma.
9731 if Debug_Flag_Dot_V
then
9732 if Target_Attrs
.From_Source
9733 or else Is_Ada_Semantic_Target
(Target_Id
)
9734 or else Is_SPARK_Semantic_Target
(Target_Id
)
9736 Meet_Elaboration_Requirement
9738 Target_Id
=> Target_Id
,
9739 Req_Nam
=> Name_Elaborate_All
);
9742 -- Otherwise ensure that the unit with the target body is elaborated
9743 -- prior to the main unit.
9746 Ensure_Prior_Elaboration
9748 Unit_Id
=> Target_Attrs
.Unit_Id
,
9749 Prag_Nam
=> Name_Elaborate_All
,
9752 end Process_Conditional_ABE_Call_SPARK
;
9754 -------------------------------------------
9755 -- Process_Conditional_ABE_Instantiation --
9756 -------------------------------------------
9758 procedure Process_Conditional_ABE_Instantiation
9759 (Exp_Inst
: Node_Id
;
9760 State
: Processing_Attributes
)
9762 Gen_Attrs
: Target_Attributes
;
9765 Inst_Attrs
: Instantiation_Attributes
;
9766 Inst_Id
: Entity_Id
;
9768 SPARK_Rules_On
: Boolean;
9769 -- This flag is set when the SPARK rules are in effect
9771 New_State
: Processing_Attributes
:= State
;
9772 -- Each step of the Processing phase constitutes a new state
9775 Extract_Instantiation_Attributes
9776 (Exp_Inst
=> Exp_Inst
,
9780 Attrs
=> Inst_Attrs
);
9782 Extract_Target_Attributes
(Gen_Id
, Gen_Attrs
);
9784 -- The SPARK rules are in effect when both the instantiation and generic
9785 -- are subject to SPARK_Mode On.
9787 SPARK_Rules_On
:= Inst_Attrs
.SPARK_Mode_On
and Gen_Attrs
.SPARK_Mode_On
;
9789 -- Output relevant information when switch -gnatel (info messages on
9790 -- implicit Elaborate[_All] pragmas) is in effect.
9792 if Elab_Info_Messages
then
9797 In_SPARK
=> SPARK_Rules_On
);
9800 -- Nothing to do when the instantiation is a guaranteed ABE
9802 if Is_Known_Guaranteed_ABE
(Inst
) then
9805 -- Nothing to do when the root scenario appears at the declaration level
9806 -- and the generic is in the same unit, but outside this context.
9809 -- procedure Gen is ...; -- generic declaration
9811 -- procedure Proc is
9812 -- function A ... is
9814 -- if Some_Condition then
9816 -- procedure I is new Gen; -- instantiation site
9821 -- X : ... := A; -- root scenario
9828 -- In the example above, the context of X is the declarative region of
9829 -- Proc. The "elaboration" of X may eventually reach Gen which appears
9830 -- outside of X's context. Gen is relevant only when Proc is invoked,
9831 -- but this happens only by means of "normal" elaboration, therefore
9832 -- Gen must not be considered if this is not the case.
9834 -- Performance note: parent traversal
9836 elsif Is_Up_Level_Target
(Gen_Attrs
.Spec_Decl
) then
9840 -- Warnings are suppressed when a prior scenario is already in that
9841 -- mode, or when the instantiation has warnings suppressed. Update
9842 -- the state of the processing phase to reflect this.
9844 New_State
.Suppress_Warnings
:=
9845 New_State
.Suppress_Warnings
or else not Inst_Attrs
.Elab_Warnings_OK
;
9847 -- The SPARK rules are in effect
9849 if SPARK_Rules_On
then
9850 Process_Conditional_ABE_Instantiation_SPARK
9853 Gen_Attrs
=> Gen_Attrs
,
9854 State
=> New_State
);
9856 -- Otherwise the Ada rules are in effect, or SPARK code is allowed to
9857 -- violate the SPARK rules.
9860 Process_Conditional_ABE_Instantiation_Ada
9861 (Exp_Inst
=> Exp_Inst
,
9863 Inst_Attrs
=> Inst_Attrs
,
9865 Gen_Attrs
=> Gen_Attrs
,
9866 State
=> New_State
);
9868 end Process_Conditional_ABE_Instantiation
;
9870 -----------------------------------------------
9871 -- Process_Conditional_ABE_Instantiation_Ada --
9872 -----------------------------------------------
9874 procedure Process_Conditional_ABE_Instantiation_Ada
9875 (Exp_Inst
: Node_Id
;
9877 Inst_Attrs
: Instantiation_Attributes
;
9879 Gen_Attrs
: Target_Attributes
;
9880 State
: Processing_Attributes
)
9882 Check_OK
: constant Boolean :=
9883 not Inst_Attrs
.Ghost_Mode_Ignore
9884 and then not Gen_Attrs
.Ghost_Mode_Ignore
9885 and then Inst_Attrs
.Elab_Checks_OK
9886 and then Gen_Attrs
.Elab_Checks_OK
;
9887 -- A run-time ABE check may be installed only when both the instance and
9888 -- the generic have active elaboration checks and both are not ignored
9889 -- Ghost constructs.
9891 Root
: constant Node_Id
:= Root_Scenario
;
9893 New_State
: Processing_Attributes
:= State
;
9894 -- Each step of the Processing phase constitutes a new state
9897 -- Nothing to do when the instantiation is ABE-safe
9904 -- package body Gen is
9909 -- procedure Main is
9910 -- package Inst is new Gen (ABE); -- safe instantiation
9913 if Is_Safe_Instantiation
(Inst
, Gen_Attrs
) then
9916 -- The instantiation and the generic body are both in the main unit
9918 elsif Present
(Gen_Attrs
.Body_Decl
)
9919 and then In_Extended_Main_Code_Unit
(Gen_Attrs
.Body_Decl
)
9921 -- If the root scenario appears prior to the generic body, then this
9922 -- is a possible ABE with respect to the root scenario.
9929 -- function A ... is
9931 -- if Some_Condition then
9933 -- package Inst is new Gen; -- instantiation site
9937 -- X : ... := A; -- root scenario
9939 -- package body Gen is -- generic body
9943 -- Y : ... := A; -- root scenario
9945 -- IMPORTANT: The instantiation of Gen is a possible ABE for X, but
9946 -- not for Y. Installing an unconditional ABE raise prior to the
9947 -- instance site would be wrong as it will fail for Y as well, but in
9948 -- Y's case the instantiation of Gen is never an ABE.
9950 if Earlier_In_Extended_Unit
(Root
, Gen_Attrs
.Body_Decl
) then
9952 -- Do not emit any ABE diagnostics when a previous scenario in
9953 -- this traversal has suppressed elaboration warnings.
9955 if State
.Suppress_Warnings
then
9958 -- Do not emit any ABE diagnostics when the instantiation occurs
9959 -- in partial finalization context because this leads to unwanted
9962 elsif State
.Within_Partial_Finalization
then
9965 -- ABE diagnostics are emitted only in the static model because
9966 -- there is a well-defined order to visiting scenarios. Without
9967 -- this order diagnostics appear jumbled and result in unwanted
9970 elsif Static_Elaboration_Checks
then
9972 ("??cannot instantiate & before body seen", Inst
, Gen_Id
);
9973 Error_Msg_N
("\Program_Error may be raised at run time", Inst
);
9975 Output_Active_Scenarios
(Inst
);
9978 -- Install a conditional run-time ABE check to verify that the
9979 -- generic body has been elaborated prior to the instantiation.
9984 Ins_Nod
=> Exp_Inst
,
9985 Target_Id
=> Gen_Attrs
.Spec_Id
,
9986 Target_Decl
=> Gen_Attrs
.Spec_Decl
,
9987 Target_Body
=> Gen_Attrs
.Body_Decl
);
9989 -- Update the state of the Processing phase to indicate that
9990 -- no implicit Elaborate[_All] pragmas must be generated from
9998 -- function A ... is
10000 -- if Some_Condition then
10002 -- declare Inst is new Gen;
10008 -- package body Gen is
10010 -- External.Subp; -- imparts Elaborate_All
10013 -- If Some_Condition is True, then the ABE check will fail at
10014 -- runtime and the call to External.Subp will never take place,
10015 -- rendering the implicit Elaborate_All useless.
10017 -- If Some_Condition is False, then the call to External.Subp
10018 -- will never take place, rendering the implicit Elaborate_All
10021 New_State
.Suppress_Implicit_Pragmas
:= True;
10025 -- Otherwise the generic body is not available in this compilation or it
10026 -- resides in an external unit. Install a run-time ABE check to verify
10027 -- that the generic body has been elaborated prior to the instantiation
10028 -- when the dynamic model is in effect.
10030 elsif Dynamic_Elaboration_Checks
and then Check_OK
then
10033 Ins_Nod
=> Exp_Inst
,
10034 Id
=> Gen_Attrs
.Unit_Id
);
10037 -- Ensure that the unit with the generic body is elaborated prior to
10038 -- the main unit. No implicit pragma is generated if the instantiation
10039 -- has elaboration checks suppressed. This behaviour parallels that of
10040 -- the old ABE mechanism.
10042 if Inst_Attrs
.Elab_Checks_OK
then
10043 Ensure_Prior_Elaboration
10045 Unit_Id
=> Gen_Attrs
.Unit_Id
,
10046 Prag_Nam
=> Name_Elaborate
,
10047 State
=> New_State
);
10049 end Process_Conditional_ABE_Instantiation_Ada
;
10051 -------------------------------------------------
10052 -- Process_Conditional_ABE_Instantiation_SPARK --
10053 -------------------------------------------------
10055 procedure Process_Conditional_ABE_Instantiation_SPARK
10057 Gen_Id
: Entity_Id
;
10058 Gen_Attrs
: Target_Attributes
;
10059 State
: Processing_Attributes
)
10064 -- Ensure that a suitable elaboration model is in effect for SPARK rule
10067 Check_SPARK_Model_In_Effect
(Inst
);
10069 -- A source instantiation imposes an Elaborate[_All] requirement on the
10070 -- context of the main unit. Determine whether the context has a pragma
10071 -- strong enough to meet the requirement. The check is orthogonal to the
10072 -- ABE ramifications of the instantiation.
10074 -- IMPORTANT: This check must be performed only when -gnatd.v (enforce
10075 -- SPARK elaboration rules in SPARK code) is active because the static
10076 -- model can ensure the prior elaboration of the unit which contains a
10077 -- body by installing an implicit Elaborate[_All] pragma.
10079 if Debug_Flag_Dot_V
then
10080 if Nkind
(Inst
) = N_Package_Instantiation
then
10081 Req_Nam
:= Name_Elaborate_All
;
10083 Req_Nam
:= Name_Elaborate
;
10086 Meet_Elaboration_Requirement
10088 Target_Id
=> Gen_Id
,
10089 Req_Nam
=> Req_Nam
);
10091 -- Otherwise ensure that the unit with the target body is elaborated
10092 -- prior to the main unit.
10095 Ensure_Prior_Elaboration
10097 Unit_Id
=> Gen_Attrs
.Unit_Id
,
10098 Prag_Nam
=> Name_Elaborate
,
10101 end Process_Conditional_ABE_Instantiation_SPARK
;
10103 -------------------------------------------------
10104 -- Process_Conditional_ABE_Variable_Assignment --
10105 -------------------------------------------------
10107 procedure Process_Conditional_ABE_Variable_Assignment
(Asmt
: Node_Id
) is
10108 Var_Id
: constant Entity_Id
:= Entity
(Extract_Assignment_Name
(Asmt
));
10109 Prag
: constant Node_Id
:= SPARK_Pragma
(Var_Id
);
10111 SPARK_Rules_On
: Boolean;
10112 -- This flag is set when the SPARK rules are in effect
10115 -- The SPARK rules are in effect when both the assignment and the
10116 -- variable are subject to SPARK_Mode On.
10120 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
10121 and then Is_SPARK_Mode_On_Node
(Asmt
);
10123 -- Output relevant information when switch -gnatel (info messages on
10124 -- implicit Elaborate[_All] pragmas) is in effect.
10126 if Elab_Info_Messages
then
10128 (Msg
=> "assignment to & during elaboration",
10132 In_SPARK
=> SPARK_Rules_On
);
10135 -- The SPARK rules are in effect. These rules are applied regardless of
10136 -- whether -gnatd.v (enforce SPARK elaboration rules in SPARK code) is
10137 -- in effect because the static model cannot ensure safe assignment of
10140 if SPARK_Rules_On
then
10141 Process_Conditional_ABE_Variable_Assignment_SPARK
10145 -- Otherwise the Ada rules are in effect
10148 Process_Conditional_ABE_Variable_Assignment_Ada
10152 end Process_Conditional_ABE_Variable_Assignment
;
10154 -----------------------------------------------------
10155 -- Process_Conditional_ABE_Variable_Assignment_Ada --
10156 -----------------------------------------------------
10158 procedure Process_Conditional_ABE_Variable_Assignment_Ada
10160 Var_Id
: Entity_Id
)
10162 Var_Decl
: constant Node_Id
:= Declaration_Node
(Var_Id
);
10163 Spec_Id
: constant Entity_Id
:= Find_Top_Unit
(Var_Decl
);
10166 -- Emit a warning when an uninitialized variable declared in a package
10167 -- spec without a pragma Elaborate_Body is initialized by elaboration
10168 -- code within the corresponding body.
10170 if Is_Elaboration_Warnings_OK_Id
(Var_Id
)
10171 and then not Is_Initialized
(Var_Decl
)
10172 and then not Has_Pragma_Elaborate_Body
(Spec_Id
)
10175 ("??variable & can be accessed by clients before this "
10176 & "initialization", Asmt
, Var_Id
);
10179 ("\add pragma ""Elaborate_Body"" to spec & to ensure proper "
10180 & "initialization", Asmt
, Spec_Id
);
10182 Output_Active_Scenarios
(Asmt
);
10184 -- Generate an implicit Elaborate_Body in the spec
10186 Set_Elaborate_Body_Desirable
(Spec_Id
);
10188 end Process_Conditional_ABE_Variable_Assignment_Ada
;
10190 -------------------------------------------------------
10191 -- Process_Conditional_ABE_Variable_Assignment_SPARK --
10192 -------------------------------------------------------
10194 procedure Process_Conditional_ABE_Variable_Assignment_SPARK
10196 Var_Id
: Entity_Id
)
10198 Var_Decl
: constant Node_Id
:= Declaration_Node
(Var_Id
);
10199 Spec_Id
: constant Entity_Id
:= Find_Top_Unit
(Var_Decl
);
10202 -- Ensure that a suitable elaboration model is in effect for SPARK rule
10205 Check_SPARK_Model_In_Effect
(Asmt
);
10207 -- Emit an error when an initialized variable declared in a package spec
10208 -- without pragma Elaborate_Body is further modified by elaboration code
10209 -- within the corresponding body.
10211 if Is_Elaboration_Warnings_OK_Id
(Var_Id
)
10212 and then Is_Initialized
(Var_Decl
)
10213 and then not Has_Pragma_Elaborate_Body
(Spec_Id
)
10216 ("variable & modified by elaboration code in package body",
10220 ("\add pragma ""Elaborate_Body"" to spec & to ensure full "
10221 & "initialization", Asmt
, Spec_Id
);
10223 Output_Active_Scenarios
(Asmt
);
10225 end Process_Conditional_ABE_Variable_Assignment_SPARK
;
10227 ------------------------------------------------
10228 -- Process_Conditional_ABE_Variable_Reference --
10229 ------------------------------------------------
10231 procedure Process_Conditional_ABE_Variable_Reference
(Ref
: Node_Id
) is
10232 Var_Attrs
: Variable_Attributes
;
10233 Var_Id
: Entity_Id
;
10236 Extract_Variable_Reference_Attributes
10239 Attrs
=> Var_Attrs
);
10241 if Is_Read
(Ref
) then
10242 Process_Conditional_ABE_Variable_Reference_Read
10245 Attrs
=> Var_Attrs
);
10247 end Process_Conditional_ABE_Variable_Reference
;
10249 -----------------------------------------------------
10250 -- Process_Conditional_ABE_Variable_Reference_Read --
10251 -----------------------------------------------------
10253 procedure Process_Conditional_ABE_Variable_Reference_Read
10255 Var_Id
: Entity_Id
;
10256 Attrs
: Variable_Attributes
)
10259 -- Output relevant information when switch -gnatel (info messages on
10260 -- implicit Elaborate[_All] pragmas) is in effect.
10262 if Elab_Info_Messages
then
10264 (Msg
=> "read of variable & during elaboration",
10271 -- Nothing to do when the variable appears within the main unit because
10272 -- diagnostics on reads are relevant only for external variables.
10274 if Is_Same_Unit
(Attrs
.Unit_Id
, Cunit_Entity
(Main_Unit
)) then
10277 -- Nothing to do when the variable is already initialized. Note that the
10278 -- variable may be further modified by the external unit.
10280 elsif Is_Initialized
(Declaration_Node
(Var_Id
)) then
10283 -- Nothing to do when the external unit guarantees the initialization of
10284 -- the variable by means of pragma Elaborate_Body.
10286 elsif Has_Pragma_Elaborate_Body
(Attrs
.Unit_Id
) then
10289 -- A variable read imposes an Elaborate requirement on the context of
10290 -- the main unit. Determine whether the context has a pragma strong
10291 -- enough to meet the requirement.
10294 Meet_Elaboration_Requirement
10296 Target_Id
=> Var_Id
,
10297 Req_Nam
=> Name_Elaborate
);
10299 end Process_Conditional_ABE_Variable_Reference_Read
;
10301 -----------------------------
10302 -- Process_Conditional_ABE --
10303 -----------------------------
10305 -- NOTE: The body of this routine is intentionally out of order because it
10306 -- invokes an instantiated subprogram (Process_Conditional_ABE_Activation).
10307 -- Placing the body in alphabetical order will result in a guaranteed ABE.
10309 procedure Process_Conditional_ABE
10311 State
: Processing_Attributes
:= Initial_State
)
10313 Call_Attrs
: Call_Attributes
;
10314 Target_Id
: Entity_Id
;
10317 -- Add the current scenario to the stack of active scenarios
10319 Push_Active_Scenario
(N
);
10323 if Is_Suitable_Access
(N
) then
10324 Process_Conditional_ABE_Access
10328 -- Activations and calls
10330 elsif Is_Suitable_Call
(N
) then
10332 -- In general, only calls found within the main unit are processed
10333 -- because the ALI information supplied to binde is for the main
10334 -- unit only. However, to preserve the consistency of the tree and
10335 -- ensure proper serialization of internal names, external calls
10336 -- also receive corresponding call markers (see Build_Call_Marker).
10337 -- Regardless of the reason, external calls must not be processed.
10339 if In_Main_Context
(N
) then
10340 Extract_Call_Attributes
10342 Target_Id
=> Target_Id
,
10343 Attrs
=> Call_Attrs
);
10345 if Is_Activation_Proc
(Target_Id
) then
10346 Process_Conditional_ABE_Activation
10348 Call_Attrs
=> Call_Attrs
,
10352 Process_Conditional_ABE_Call
10354 Call_Attrs
=> Call_Attrs
,
10355 Target_Id
=> Target_Id
,
10362 elsif Is_Suitable_Instantiation
(N
) then
10363 Process_Conditional_ABE_Instantiation
10367 -- Variable assignments
10369 elsif Is_Suitable_Variable_Assignment
(N
) then
10370 Process_Conditional_ABE_Variable_Assignment
(N
);
10372 -- Variable references
10374 elsif Is_Suitable_Variable_Reference
(N
) then
10376 -- In general, only variable references found within the main unit
10377 -- are processed because the ALI information supplied to binde is for
10378 -- the main unit only. However, to preserve the consistency of the
10379 -- tree and ensure proper serialization of internal names, external
10380 -- variable references also receive corresponding variable reference
10381 -- markers (see Build_Varaible_Reference_Marker). Regardless of the
10382 -- reason, external variable references must not be processed.
10384 if In_Main_Context
(N
) then
10385 Process_Conditional_ABE_Variable_Reference
(N
);
10389 -- Remove the current scenario from the stack of active scenarios once
10390 -- all ABE diagnostics and checks have been performed.
10392 Pop_Active_Scenario
(N
);
10393 end Process_Conditional_ABE
;
10395 --------------------------------------------
10396 -- Process_Guaranteed_ABE_Activation_Impl --
10397 --------------------------------------------
10399 procedure Process_Guaranteed_ABE_Activation_Impl
10401 Call_Attrs
: Call_Attributes
;
10402 Obj_Id
: Entity_Id
;
10403 Task_Attrs
: Task_Attributes
;
10404 State
: Processing_Attributes
)
10406 pragma Unreferenced
(State
);
10408 Check_OK
: constant Boolean :=
10409 not Is_Ignored_Ghost_Entity
(Obj_Id
)
10410 and then not Task_Attrs
.Ghost_Mode_Ignore
10411 and then Is_Elaboration_Checks_OK_Id
(Obj_Id
)
10412 and then Task_Attrs
.Elab_Checks_OK
;
10413 -- A run-time ABE check may be installed only when the object and the
10414 -- task type have active elaboration checks, and both are not ignored
10415 -- Ghost constructs.
10418 -- Nothing to do when the root scenario appears at the declaration
10419 -- level and the task is in the same unit, but outside this context.
10421 -- task type Task_Typ; -- task declaration
10423 -- procedure Proc is
10424 -- function A ... is
10426 -- if Some_Condition then
10430 -- <activation call> -- activation site
10435 -- X : ... := A; -- root scenario
10438 -- task body Task_Typ is
10442 -- In the example above, the context of X is the declarative list of
10443 -- Proc. The "elaboration" of X may reach the activation of T whose body
10444 -- is defined outside of X's context. The task body is relevant only
10445 -- when Proc is invoked, but this happens only in "normal" elaboration,
10446 -- therefore the task body must not be considered if this is not the
10449 -- Performance note: parent traversal
10451 if Is_Up_Level_Target
(Task_Attrs
.Task_Decl
) then
10454 -- Nothing to do when the activation is ABE-safe
10458 -- task type Task_Typ;
10461 -- package body Gen is
10462 -- task body Task_Typ is
10469 -- procedure Main is
10470 -- package Nested is
10471 -- package Inst is new Gen;
10472 -- T : Inst.Task_Typ;
10473 -- end Nested; -- safe activation
10476 elsif Is_Safe_Activation
(Call
, Task_Attrs
.Task_Decl
) then
10479 -- An activation call leads to a guaranteed ABE when the activation
10480 -- call and the task appear within the same context ignoring library
10481 -- levels, and the body of the task has not been seen yet or appears
10482 -- after the activation call.
10484 -- procedure Guaranteed_ABE is
10485 -- task type Task_Typ;
10487 -- package Nested is
10489 -- <activation call> -- guaranteed ABE
10492 -- task body Task_Typ is
10497 -- Performance note: parent traversal
10499 elsif Is_Guaranteed_ABE
10501 Target_Decl
=> Task_Attrs
.Task_Decl
,
10502 Target_Body
=> Task_Attrs
.Body_Decl
)
10504 if Call_Attrs
.Elab_Warnings_OK
then
10505 Error_Msg_Sloc
:= Sloc
(Call
);
10507 ("??task & will be activated # before elaboration of its body",
10509 Error_Msg_N
("\Program_Error will be raised at run time", Obj_Id
);
10512 -- Mark the activation call as a guaranteed ABE
10514 Set_Is_Known_Guaranteed_ABE
(Call
);
10516 -- Install a run-time ABE failue because this activation call will
10517 -- always result in an ABE.
10520 Install_ABE_Failure
10525 end Process_Guaranteed_ABE_Activation_Impl
;
10527 procedure Process_Guaranteed_ABE_Activation
is
10528 new Process_Activation_Generic
(Process_Guaranteed_ABE_Activation_Impl
);
10530 ---------------------------------
10531 -- Process_Guaranteed_ABE_Call --
10532 ---------------------------------
10534 procedure Process_Guaranteed_ABE_Call
10536 Call_Attrs
: Call_Attributes
;
10537 Target_Id
: Entity_Id
)
10539 Target_Attrs
: Target_Attributes
;
10542 Extract_Target_Attributes
10543 (Target_Id
=> Target_Id
,
10544 Attrs
=> Target_Attrs
);
10546 -- Nothing to do when the root scenario appears at the declaration level
10547 -- and the target is in the same unit, but outside this context.
10549 -- function B ...; -- target declaration
10551 -- procedure Proc is
10552 -- function A ... is
10554 -- if Some_Condition then
10555 -- return B; -- call site
10559 -- X : ... := A; -- root scenario
10562 -- function B ... is
10566 -- In the example above, the context of X is the declarative region of
10567 -- Proc. The "elaboration" of X may eventually reach B which is defined
10568 -- outside of X's context. B is relevant only when Proc is invoked, but
10569 -- this happens only by means of "normal" elaboration, therefore B must
10570 -- not be considered if this is not the case.
10572 -- Performance note: parent traversal
10574 if Is_Up_Level_Target
(Target_Attrs
.Spec_Decl
) then
10577 -- Nothing to do when the call is ABE-safe
10580 -- function Gen ...;
10582 -- function Gen ... is
10588 -- procedure Main is
10589 -- function Inst is new Gen;
10590 -- X : ... := Inst; -- safe call
10593 elsif Is_Safe_Call
(Call
, Target_Attrs
) then
10596 -- A call leads to a guaranteed ABE when the call and the target appear
10597 -- within the same context ignoring library levels, and the body of the
10598 -- target has not been seen yet or appears after the call.
10600 -- procedure Guaranteed_ABE is
10601 -- function Func ...;
10603 -- package Nested is
10604 -- Obj : ... := Func; -- guaranteed ABE
10607 -- function Func ... is
10612 -- Performance note: parent traversal
10614 elsif Is_Guaranteed_ABE
10616 Target_Decl
=> Target_Attrs
.Spec_Decl
,
10617 Target_Body
=> Target_Attrs
.Body_Decl
)
10619 if Call_Attrs
.Elab_Warnings_OK
then
10620 Error_Msg_NE
("??cannot call & before body seen", Call
, Target_Id
);
10621 Error_Msg_N
("\Program_Error will be raised at run time", Call
);
10624 -- Mark the call as a guarnateed ABE
10626 Set_Is_Known_Guaranteed_ABE
(Call
);
10628 -- Install a run-time ABE failure because the call will always result
10629 -- in an ABE. The failure is installed when both the call and target
10630 -- have enabled elaboration checks, and both are not ignored Ghost
10633 if Call_Attrs
.Elab_Checks_OK
10634 and then Target_Attrs
.Elab_Checks_OK
10635 and then not Call_Attrs
.Ghost_Mode_Ignore
10636 and then not Target_Attrs
.Ghost_Mode_Ignore
10638 Install_ABE_Failure
10643 end Process_Guaranteed_ABE_Call
;
10645 ------------------------------------------
10646 -- Process_Guaranteed_ABE_Instantiation --
10647 ------------------------------------------
10649 procedure Process_Guaranteed_ABE_Instantiation
(Exp_Inst
: Node_Id
) is
10650 Gen_Attrs
: Target_Attributes
;
10651 Gen_Id
: Entity_Id
;
10653 Inst_Attrs
: Instantiation_Attributes
;
10654 Inst_Id
: Entity_Id
;
10657 Extract_Instantiation_Attributes
10658 (Exp_Inst
=> Exp_Inst
,
10660 Inst_Id
=> Inst_Id
,
10662 Attrs
=> Inst_Attrs
);
10664 Extract_Target_Attributes
(Gen_Id
, Gen_Attrs
);
10666 -- Nothing to do when the root scenario appears at the declaration level
10667 -- and the generic is in the same unit, but outside this context.
10670 -- procedure Gen is ...; -- generic declaration
10672 -- procedure Proc is
10673 -- function A ... is
10675 -- if Some_Condition then
10677 -- procedure I is new Gen; -- instantiation site
10682 -- X : ... := A; -- root scenario
10685 -- procedure Gen is
10689 -- In the example above, the context of X is the declarative region of
10690 -- Proc. The "elaboration" of X may eventually reach Gen which appears
10691 -- outside of X's context. Gen is relevant only when Proc is invoked,
10692 -- but this happens only by means of "normal" elaboration, therefore
10693 -- Gen must not be considered if this is not the case.
10695 -- Performance note: parent traversal
10697 if Is_Up_Level_Target
(Gen_Attrs
.Spec_Decl
) then
10700 -- Nothing to do when the instantiation is ABE-safe
10707 -- package body Gen is
10712 -- procedure Main is
10713 -- package Inst is new Gen (ABE); -- safe instantiation
10716 elsif Is_Safe_Instantiation
(Inst
, Gen_Attrs
) then
10719 -- An instantiation leads to a guaranteed ABE when the instantiation and
10720 -- the generic appear within the same context ignoring library levels,
10721 -- and the body of the generic has not been seen yet or appears after
10722 -- the instantiation.
10724 -- procedure Guaranteed_ABE is
10728 -- package Nested is
10729 -- procedure Inst is new Gen; -- guaranteed ABE
10732 -- procedure Gen is
10737 -- Performance note: parent traversal
10739 elsif Is_Guaranteed_ABE
10741 Target_Decl
=> Gen_Attrs
.Spec_Decl
,
10742 Target_Body
=> Gen_Attrs
.Body_Decl
)
10744 if Inst_Attrs
.Elab_Warnings_OK
then
10746 ("??cannot instantiate & before body seen", Inst
, Gen_Id
);
10747 Error_Msg_N
("\Program_Error will be raised at run time", Inst
);
10750 -- Mark the instantiation as a guarantee ABE. This automatically
10751 -- suppresses the instantiation of the generic body.
10753 Set_Is_Known_Guaranteed_ABE
(Inst
);
10755 -- Install a run-time ABE failure because the instantiation will
10756 -- always result in an ABE. The failure is installed when both the
10757 -- instance and the generic have enabled elaboration checks, and both
10758 -- are not ignored Ghost constructs.
10760 if Inst_Attrs
.Elab_Checks_OK
10761 and then Gen_Attrs
.Elab_Checks_OK
10762 and then not Inst_Attrs
.Ghost_Mode_Ignore
10763 and then not Gen_Attrs
.Ghost_Mode_Ignore
10765 Install_ABE_Failure
10767 Ins_Nod
=> Exp_Inst
);
10770 end Process_Guaranteed_ABE_Instantiation
;
10772 ----------------------------
10773 -- Process_Guaranteed_ABE --
10774 ----------------------------
10776 -- NOTE: The body of this routine is intentionally out of order because it
10777 -- invokes an instantiated subprogram (Process_Guaranteed_ABE_Activation).
10778 -- Placing the body in alphabetical order will result in a guaranteed ABE.
10780 procedure Process_Guaranteed_ABE
(N
: Node_Id
) is
10781 Call_Attrs
: Call_Attributes
;
10782 Target_Id
: Entity_Id
;
10785 -- Add the current scenario to the stack of active scenarios
10787 Push_Active_Scenario
(N
);
10789 -- Only calls, instantiations, and task activations may result in a
10792 if Is_Suitable_Call
(N
) then
10793 Extract_Call_Attributes
10795 Target_Id
=> Target_Id
,
10796 Attrs
=> Call_Attrs
);
10798 if Is_Activation_Proc
(Target_Id
) then
10799 Process_Guaranteed_ABE_Activation
10801 Call_Attrs
=> Call_Attrs
,
10802 State
=> Initial_State
);
10805 Process_Guaranteed_ABE_Call
10807 Call_Attrs
=> Call_Attrs
,
10808 Target_Id
=> Target_Id
);
10811 elsif Is_Suitable_Instantiation
(N
) then
10812 Process_Guaranteed_ABE_Instantiation
(N
);
10815 -- Remove the current scenario from the stack of active scenarios once
10816 -- all ABE diagnostics and checks have been performed.
10818 Pop_Active_Scenario
(N
);
10819 end Process_Guaranteed_ABE
;
10821 --------------------------
10822 -- Push_Active_Scenario --
10823 --------------------------
10825 procedure Push_Active_Scenario
(N
: Node_Id
) is
10827 Scenario_Stack
.Append
(N
);
10828 end Push_Active_Scenario
;
10830 ---------------------------------
10831 -- Record_Elaboration_Scenario --
10832 ---------------------------------
10834 procedure Record_Elaboration_Scenario
(N
: Node_Id
) is
10835 Level
: Enclosing_Level_Kind
;
10837 Any_Level_OK
: Boolean;
10838 -- This flag is set when a particular scenario is allowed to appear at
10841 Declaration_Level_OK
: Boolean;
10842 -- This flag is set when a particular scenario is allowed to appear at
10843 -- the declaration level.
10845 Library_Level_OK
: Boolean;
10846 -- This flag is set when a particular scenario is allowed to appear at
10847 -- the library level.
10850 -- Assume that the scenario cannot appear on any level
10852 Any_Level_OK
:= False;
10853 Declaration_Level_OK
:= False;
10854 Library_Level_OK
:= False;
10856 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
10857 -- enabled) is in effect because the legacy ABE mechanism does not need
10858 -- to carry out this action.
10860 if Legacy_Elaboration_Checks
then
10863 -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics
10864 -- are performed in this mode.
10866 elsif ASIS_Mode
then
10869 -- Nothing to do when the scenario is being preanalyzed
10871 elsif Preanalysis_Active
then
10875 -- Ensure that a library-level call does not appear in a preelaborated
10876 -- unit. The check must come before ignoring scenarios within external
10877 -- units or inside generics because calls in those context must also be
10880 if Is_Suitable_Call
(N
) then
10881 Check_Preelaborated_Call
(N
);
10884 -- Nothing to do when the scenario does not appear within the main unit
10886 if not In_Main_Context
(N
) then
10889 -- Scenarios within a generic unit are never considered because generics
10890 -- cannot be elaborated.
10892 elsif Inside_A_Generic
then
10895 -- Scenarios which do not fall in one of the elaboration categories
10896 -- listed below are not considered. The categories are:
10898 -- 'Access for entries, operators, and subprograms
10899 -- Assignments to variables
10900 -- Calls (includes task activation)
10903 -- Pragma Refined_State
10904 -- Reads of variables
10906 elsif Is_Suitable_Access
(N
) then
10907 Library_Level_OK
:= True;
10909 -- Signal any enclosing local exception handlers that the 'Access may
10910 -- raise Program_Error due to a failed ABE check when switch -gnatd.o
10911 -- (conservative elaboration order for indirect calls) is in effect.
10912 -- Marking the exception handlers ensures proper expansion by both
10913 -- the front and back end restriction when No_Exception_Propagation
10916 if Debug_Flag_Dot_O
then
10917 Possible_Local_Raise
(N
, Standard_Program_Error
);
10920 elsif Is_Suitable_Call
(N
) or else Is_Suitable_Instantiation
(N
) then
10921 Declaration_Level_OK
:= True;
10922 Library_Level_OK
:= True;
10924 -- Signal any enclosing local exception handlers that the call or
10925 -- instantiation may raise Program_Error due to a failed ABE check.
10926 -- Marking the exception handlers ensures proper expansion by both
10927 -- the front and back end restriction when No_Exception_Propagation
10930 Possible_Local_Raise
(N
, Standard_Program_Error
);
10932 elsif Is_Suitable_SPARK_Derived_Type
(N
) then
10933 Any_Level_OK
:= True;
10935 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
10936 Library_Level_OK
:= True;
10938 elsif Is_Suitable_Variable_Assignment
(N
)
10939 or else Is_Suitable_Variable_Reference
(N
)
10941 Library_Level_OK
:= True;
10943 -- Otherwise the input does not denote a suitable scenario
10949 -- The static model imposes additional restrictions on the placement of
10950 -- scenarios. In contrast, the dynamic model assumes that every scenario
10951 -- will be elaborated or invoked at some point.
10953 if Static_Elaboration_Checks
then
10955 -- Certain scenarios are allowed to appear at any level. This check
10956 -- is performed here in order to save on a parent traversal.
10958 if Any_Level_OK
then
10961 -- Otherwise the scenario must appear at a specific level
10964 -- Performance note: parent traversal
10966 Level
:= Find_Enclosing_Level
(N
);
10968 -- Declaration-level scenario
10970 if Declaration_Level_OK
and then Level
= Declaration_Level
then
10973 -- Library-level or instantiation scenario
10975 elsif Library_Level_OK
10976 and then Level
in Library_Or_Instantiation_Level
10980 -- Otherwise the scenario does not appear at the proper level and
10981 -- cannot possibly act as a top-level scenario.
10989 -- Derived types subject to SPARK_Mode On require elaboration-related
10990 -- checks even though the type may not be declared within elaboration
10991 -- code. The types are recorded in a separate table which is examined
10992 -- during the Processing phase. Note that the checks must be delayed
10993 -- because the bodies of overriding primitives are not available yet.
10995 if Is_Suitable_SPARK_Derived_Type
(N
) then
10996 Record_SPARK_Elaboration_Scenario
(N
);
10998 -- Nothing left to do for derived types
11002 -- Instantiations of generics both subject to SPARK_Mode On require
11003 -- elaboration-related checks even though the instantiations may not
11004 -- appear within elaboration code. The instantiations are recored in
11005 -- a separate table which is examined during the Procesing phase. Note
11006 -- that the checks must be delayed because it is not known yet whether
11007 -- the generic unit has a body or not.
11009 -- IMPORTANT: A SPARK instantiation is also a normal instantiation which
11010 -- is subject to common conditional and guaranteed ABE checks.
11012 elsif Is_Suitable_SPARK_Instantiation
(N
) then
11013 Record_SPARK_Elaboration_Scenario
(N
);
11015 -- External constituents that refine abstract states which appear in
11016 -- pragma Initializes require elaboration-related checks even though
11017 -- a Refined_State pragma lacks any elaboration semantic.
11019 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
11020 Record_SPARK_Elaboration_Scenario
(N
);
11022 -- Nothing left to do for pragma Refined_State
11027 -- Perform early detection of guaranteed ABEs in order to suppress the
11028 -- instantiation of generic bodies as gigi cannot handle certain types
11029 -- of premature instantiations.
11031 Process_Guaranteed_ABE
(N
);
11033 -- At this point all checks have been performed. Record the scenario for
11034 -- later processing by the ABE phase.
11036 Top_Level_Scenarios
.Append
(N
);
11037 Set_Is_Recorded_Top_Level_Scenario
(N
);
11038 end Record_Elaboration_Scenario
;
11040 ---------------------------------------
11041 -- Record_SPARK_Elaboration_Scenario --
11042 ---------------------------------------
11044 procedure Record_SPARK_Elaboration_Scenario
(N
: Node_Id
) is
11046 SPARK_Scenarios
.Append
(N
);
11047 Set_Is_Recorded_SPARK_Scenario
(N
);
11048 end Record_SPARK_Elaboration_Scenario
;
11050 -----------------------------------
11051 -- Recorded_SPARK_Scenarios_Hash --
11052 -----------------------------------
11054 function Recorded_SPARK_Scenarios_Hash
11055 (Key
: Node_Id
) return Recorded_SPARK_Scenarios_Index
11059 Recorded_SPARK_Scenarios_Index
(Key
mod Recorded_SPARK_Scenarios_Max
);
11060 end Recorded_SPARK_Scenarios_Hash
;
11062 ---------------------------------------
11063 -- Recorded_Top_Level_Scenarios_Hash --
11064 ---------------------------------------
11066 function Recorded_Top_Level_Scenarios_Hash
11067 (Key
: Node_Id
) return Recorded_Top_Level_Scenarios_Index
11071 Recorded_Top_Level_Scenarios_Index
11072 (Key
mod Recorded_Top_Level_Scenarios_Max
);
11073 end Recorded_Top_Level_Scenarios_Hash
;
11075 --------------------------
11076 -- Reset_Visited_Bodies --
11077 --------------------------
11079 procedure Reset_Visited_Bodies
is
11081 if Visited_Bodies_In_Use
then
11082 Visited_Bodies_In_Use
:= False;
11083 Visited_Bodies
.Reset
;
11085 end Reset_Visited_Bodies
;
11087 -------------------
11088 -- Root_Scenario --
11089 -------------------
11091 function Root_Scenario
return Node_Id
is
11092 package Stack
renames Scenario_Stack
;
11095 -- Ensure that the scenario stack has at least one active scenario in
11096 -- it. The one at the bottom (index First) is the root scenario.
11098 pragma Assert
(Stack
.Last
>= Stack
.First
);
11099 return Stack
.Table
(Stack
.First
);
11102 ---------------------------
11103 -- Set_Early_Call_Region --
11104 ---------------------------
11106 procedure Set_Early_Call_Region
(Body_Id
: Entity_Id
; Start
: Node_Id
) is
11108 pragma Assert
(Ekind_In
(Body_Id
, E_Entry
,
11112 E_Subprogram_Body
));
11114 Early_Call_Regions_In_Use
:= True;
11115 Early_Call_Regions
.Set
(Body_Id
, Start
);
11116 end Set_Early_Call_Region
;
11118 ----------------------------
11119 -- Set_Elaboration_Status --
11120 ----------------------------
11122 procedure Set_Elaboration_Status
11123 (Unit_Id
: Entity_Id
;
11124 Val
: Elaboration_Attributes
)
11127 Elaboration_Statuses_In_Use
:= True;
11128 Elaboration_Statuses
.Set
(Unit_Id
, Val
);
11129 end Set_Elaboration_Status
;
11131 ------------------------------------
11132 -- Set_Is_Recorded_SPARK_Scenario --
11133 ------------------------------------
11135 procedure Set_Is_Recorded_SPARK_Scenario
11137 Val
: Boolean := True)
11140 Recorded_SPARK_Scenarios_In_Use
:= True;
11141 Recorded_SPARK_Scenarios
.Set
(N
, Val
);
11142 end Set_Is_Recorded_SPARK_Scenario
;
11144 ----------------------------------------
11145 -- Set_Is_Recorded_Top_Level_Scenario --
11146 ----------------------------------------
11148 procedure Set_Is_Recorded_Top_Level_Scenario
11150 Val
: Boolean := True)
11153 Recorded_Top_Level_Scenarios_In_Use
:= True;
11154 Recorded_Top_Level_Scenarios
.Set
(N
, Val
);
11155 end Set_Is_Recorded_Top_Level_Scenario
;
11157 -------------------------
11158 -- Set_Is_Visited_Body --
11159 -------------------------
11161 procedure Set_Is_Visited_Body
(Subp_Body
: Node_Id
) is
11163 Visited_Bodies_In_Use
:= True;
11164 Visited_Bodies
.Set
(Subp_Body
, True);
11165 end Set_Is_Visited_Body
;
11167 -------------------------------
11168 -- Static_Elaboration_Checks --
11169 -------------------------------
11171 function Static_Elaboration_Checks
return Boolean is
11173 return not Dynamic_Elaboration_Checks
;
11174 end Static_Elaboration_Checks
;
11176 -------------------
11177 -- Traverse_Body --
11178 -------------------
11180 procedure Traverse_Body
(N
: Node_Id
; State
: Processing_Attributes
) is
11181 procedure Find_And_Process_Nested_Scenarios
;
11182 pragma Inline
(Find_And_Process_Nested_Scenarios
);
11183 -- Examine the declarations and statements of subprogram body N for
11184 -- suitable scenarios.
11186 ---------------------------------------
11187 -- Find_And_Process_Nested_Scenarios --
11188 ---------------------------------------
11190 procedure Find_And_Process_Nested_Scenarios
is
11191 function Is_Potential_Scenario
11192 (Nod
: Node_Id
) return Traverse_Result
;
11193 -- Determine whether arbitrary node Nod denotes a suitable scenario.
11194 -- If it does, save it in the Nested_Scenarios list of the subprogram
11195 -- body, and process it.
11197 procedure Traverse_List
(List
: List_Id
);
11198 pragma Inline
(Traverse_List
);
11199 -- Invoke Traverse_Potential_Scenarios on each node in list List
11201 procedure Traverse_Potential_Scenarios
is
11202 new Traverse_Proc
(Is_Potential_Scenario
);
11204 ---------------------------
11205 -- Is_Potential_Scenario --
11206 ---------------------------
11208 function Is_Potential_Scenario
11209 (Nod
: Node_Id
) return Traverse_Result
11214 -- Skip constructs which do not have elaboration of their own and
11215 -- need to be elaborated by other means such as invocation, task
11216 -- activation, etc.
11218 if Is_Non_Library_Level_Encapsulator
(Nod
) then
11221 -- Terminate the traversal of a task body when encountering an
11222 -- accept or select statement, and
11224 -- * Entry calls during elaboration are not allowed. In this
11225 -- case the accept or select statement will cause the task
11226 -- to block at elaboration time because there are no entry
11227 -- calls to unblock it.
11231 -- * Switch -gnatd_a (stop elaboration checks on accept or
11232 -- select statement) is in effect.
11234 elsif (Debug_Flag_Underscore_A
11235 or else Restriction_Active
11236 (No_Entry_Calls_In_Elaboration_Code
))
11237 and then Nkind_In
(Original_Node
(Nod
), N_Accept_Statement
,
11238 N_Selective_Accept
)
11242 -- Terminate the traversal of a task body when encountering a
11243 -- suspension call, and
11245 -- * Entry calls during elaboration are not allowed. In this
11246 -- case the suspension call emulates an entry call and will
11247 -- cause the task to block at elaboration time.
11251 -- * Switch -gnatd_s (stop elaboration checks on synchronous
11252 -- suspension) is in effect.
11254 -- Note that the guard should not be checking the state of flag
11255 -- Within_Task_Body because only suspension calls which appear
11256 -- immediately within the statements of the task are supported.
11257 -- Flag Within_Task_Body carries over to deeper levels of the
11260 elsif (Debug_Flag_Underscore_S
11261 or else Restriction_Active
11262 (No_Entry_Calls_In_Elaboration_Code
))
11263 and then Is_Synchronous_Suspension_Call
(Nod
)
11264 and then In_Task_Body
(Nod
)
11268 -- Certain nodes carry semantic lists which act as repositories
11269 -- until expansion transforms the node and relocates the contents.
11270 -- Examine these lists in case expansion is disabled.
11272 elsif Nkind_In
(Nod
, N_And_Then
, N_Or_Else
) then
11273 Traverse_List
(Actions
(Nod
));
11275 elsif Nkind_In
(Nod
, N_Elsif_Part
, N_Iteration_Scheme
) then
11276 Traverse_List
(Condition_Actions
(Nod
));
11278 elsif Nkind
(Nod
) = N_If_Expression
then
11279 Traverse_List
(Then_Actions
(Nod
));
11280 Traverse_List
(Else_Actions
(Nod
));
11282 elsif Nkind_In
(Nod
, N_Component_Association
,
11283 N_Iterated_Component_Association
)
11285 Traverse_List
(Loop_Actions
(Nod
));
11289 elsif Is_Suitable_Scenario
(Nod
) then
11290 Process_Conditional_ABE
11296 end Is_Potential_Scenario
;
11298 -------------------
11299 -- Traverse_List --
11300 -------------------
11302 procedure Traverse_List
(List
: List_Id
) is
11306 Item
:= First
(List
);
11307 while Present
(Item
) loop
11308 Traverse_Potential_Scenarios
(Item
);
11313 -- Start of processing for Find_And_Process_Nested_Scenarios
11316 -- Examine the declarations for suitable scenarios
11318 Traverse_List
(Declarations
(N
));
11320 -- Examine the handled sequence of statements. This also includes any
11321 -- exceptions handlers.
11323 Traverse_Potential_Scenarios
(Handled_Statement_Sequence
(N
));
11324 end Find_And_Process_Nested_Scenarios
;
11326 -- Start of processing for Traverse_Body
11329 -- Nothing to do when there is no body
11334 elsif Nkind
(N
) /= N_Subprogram_Body
then
11338 -- Nothing to do if the body was already traversed during the processing
11339 -- of the same top-level scenario.
11341 if Is_Visited_Body
(N
) then
11344 -- Otherwise mark the body as traversed
11347 Set_Is_Visited_Body
(N
);
11350 -- Examine the declarations and statements of the subprogram body for
11351 -- suitable scenarios, save and process them accordingly.
11353 Find_And_Process_Nested_Scenarios
;
11360 function Unit_Entity
(Unit_Id
: Entity_Id
) return Entity_Id
is
11361 function Is_Subunit
(Id
: Entity_Id
) return Boolean;
11362 pragma Inline
(Is_Subunit
);
11363 -- Determine whether the entity of an initial declaration denotes a
11370 function Is_Subunit
(Id
: Entity_Id
) return Boolean is
11371 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Id
);
11375 Nkind_In
(Decl
, N_Generic_Package_Declaration
,
11376 N_Generic_Subprogram_Declaration
,
11377 N_Package_Declaration
,
11378 N_Protected_Type_Declaration
,
11379 N_Subprogram_Declaration
,
11380 N_Task_Type_Declaration
)
11381 and then Present
(Corresponding_Body
(Decl
))
11382 and then Nkind
(Parent
(Unit_Declaration_Node
11383 (Corresponding_Body
(Decl
)))) = N_Subunit
;
11390 -- Start of processing for Unit_Entity
11393 Id
:= Unique_Entity
(Unit_Id
);
11395 -- Skip all subunits found in the scope chain which ends at the input
11398 while Is_Subunit
(Id
) loop
11405 ---------------------------------
11406 -- Update_Elaboration_Scenario --
11407 ---------------------------------
11409 procedure Update_Elaboration_Scenario
(New_N
: Node_Id
; Old_N
: Node_Id
) is
11410 procedure Update_SPARK_Scenario
;
11411 pragma Inline
(Update_SPARK_Scenario
);
11412 -- Update the contents of table SPARK_Scenarios if Old_N is recorded
11415 procedure Update_Top_Level_Scenario
;
11416 pragma Inline
(Update_Top_Level_Scenario
);
11417 -- Update the contexts of table Top_Level_Scenarios if Old_N is recorded
11420 ---------------------------
11421 -- Update_SPARK_Scenario --
11422 ---------------------------
11424 procedure Update_SPARK_Scenario
is
11425 package Scenarios
renames SPARK_Scenarios
;
11428 if Is_Recorded_SPARK_Scenario
(Old_N
) then
11430 -- Performance note: list traversal
11432 for Index
in Scenarios
.First
.. Scenarios
.Last
loop
11433 if Scenarios
.Table
(Index
) = Old_N
then
11434 Scenarios
.Table
(Index
) := New_N
;
11436 -- The old SPARK scenario is no longer recorded, but the new
11439 Set_Is_Recorded_Top_Level_Scenario
(Old_N
, False);
11440 Set_Is_Recorded_Top_Level_Scenario
(New_N
);
11445 -- A recorded SPARK scenario must be in the table of recorded
11446 -- SPARK scenarios.
11448 pragma Assert
(False);
11450 end Update_SPARK_Scenario
;
11452 -------------------------------
11453 -- Update_Top_Level_Scenario --
11454 -------------------------------
11456 procedure Update_Top_Level_Scenario
is
11457 package Scenarios
renames Top_Level_Scenarios
;
11460 if Is_Recorded_Top_Level_Scenario
(Old_N
) then
11462 -- Performance note: list traversal
11464 for Index
in Scenarios
.First
.. Scenarios
.Last
loop
11465 if Scenarios
.Table
(Index
) = Old_N
then
11466 Scenarios
.Table
(Index
) := New_N
;
11468 -- The old top-level scenario is no longer recorded, but the
11471 Set_Is_Recorded_Top_Level_Scenario
(Old_N
, False);
11472 Set_Is_Recorded_Top_Level_Scenario
(New_N
);
11477 -- A recorded top-level scenario must be in the table of recorded
11478 -- top-level scenarios.
11480 pragma Assert
(False);
11482 end Update_Top_Level_Scenario
;
11484 -- Start of processing for Update_Elaboration_Requirement
11487 -- Nothing to do when the old and new scenarios are one and the same
11489 if Old_N
= New_N
then
11492 -- A scenario is being transformed by Atree.Rewrite. Update all relevant
11493 -- internal data structures to reflect this change. This ensures that a
11494 -- potential run-time conditional ABE check or a guaranteed ABE failure
11495 -- is inserted at the proper place in the tree.
11497 elsif Is_Scenario
(Old_N
) then
11498 Update_SPARK_Scenario
;
11499 Update_Top_Level_Scenario
;
11501 end Update_Elaboration_Scenario
;
11503 -------------------------
11504 -- Visited_Bodies_Hash --
11505 -------------------------
11507 function Visited_Bodies_Hash
(Key
: Node_Id
) return Visited_Bodies_Index
is
11509 return Visited_Bodies_Index
(Key
mod Visited_Bodies_Max
);
11510 end Visited_Bodies_Hash
;
11512 ---------------------------------------------------------------------------
11514 -- 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 --
11516 -- M E C H A N I S M --
11518 ---------------------------------------------------------------------------
11520 -- This section contains the implementation of the pre-18.x legacy ABE
11521 -- mechanism. The mechanism can be activated using switch -gnatH (legacy
11522 -- elaboration checking mode enabled).
11524 -----------------------------
11525 -- Description of Approach --
11526 -----------------------------
11528 -- Every non-static call that is encountered by Sem_Res results in a call
11529 -- to Check_Elab_Call, with N being the call node, and Outer set to its
11530 -- default value of True. In addition X'Access is treated like a call
11531 -- for the access-to-procedure case, and in SPARK mode only we also
11532 -- check variable references.
11534 -- The goal of Check_Elab_Call is to determine whether or not the reference
11535 -- in question can generate an access before elaboration error (raising
11536 -- Program_Error) either by directly calling a subprogram whose body
11537 -- has not yet been elaborated, or indirectly, by calling a subprogram
11538 -- whose body has been elaborated, but which contains a call to such a
11541 -- In addition, in SPARK mode, we are checking for a variable reference in
11542 -- another package, which requires an explicit Elaborate_All pragma.
11544 -- The only references that we need to look at the outer level are
11545 -- references that occur in elaboration code. There are two cases. The
11546 -- reference can be at the outer level of elaboration code, or it can
11547 -- be within another unit, e.g. the elaboration code of a subprogram.
11549 -- In the case of an elaboration call at the outer level, we must trace
11550 -- all calls to outer level routines either within the current unit or to
11551 -- other units that are with'ed. For calls within the current unit, we can
11552 -- determine if the body has been elaborated or not, and if it has not,
11553 -- then a warning is generated.
11555 -- Note that there are two subcases. If the original call directly calls a
11556 -- subprogram whose body has not been elaborated, then we know that an ABE
11557 -- will take place, and we replace the call by a raise of Program_Error.
11558 -- If the call is indirect, then we don't know that the PE will be raised,
11559 -- since the call might be guarded by a conditional. In this case we set
11560 -- Do_Elab_Check on the call so that a dynamic check is generated, and
11561 -- output a warning.
11563 -- For calls to a subprogram in a with'ed unit or a 'Access or variable
11564 -- reference (SPARK mode case), we require that a pragma Elaborate_All
11565 -- or pragma Elaborate be present, or that the referenced unit have a
11566 -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none
11567 -- of these conditions is met, then a warning is generated that a pragma
11568 -- Elaborate_All may be needed (error in the SPARK case), or an implicit
11569 -- pragma is generated.
11571 -- For the case of an elaboration call at some inner level, we are
11572 -- interested in tracing only calls to subprograms at the same level, i.e.
11573 -- those that can be called during elaboration. Any calls to outer level
11574 -- routines cannot cause ABE's as a result of the original call (there
11575 -- might be an outer level call to the subprogram from outside that causes
11576 -- the ABE, but that gets analyzed separately).
11578 -- Note that we never trace calls to inner level subprograms, since these
11579 -- cannot result in ABE's unless there is an elaboration problem at a lower
11580 -- level, which will be separately detected.
11582 -- Note on pragma Elaborate. The checking here assumes that a pragma
11583 -- Elaborate on a with'ed unit guarantees that subprograms within the unit
11584 -- can be called without causing an ABE. This is not in fact the case since
11585 -- pragma Elaborate does not guarantee the transitive coverage guaranteed
11586 -- by Elaborate_All. However, we decide to trust the user in this case.
11588 --------------------------------------
11589 -- Instantiation Elaboration Errors --
11590 --------------------------------------
11592 -- A special case arises when an instantiation appears in a context that is
11593 -- known to be before the body is elaborated, e.g.
11595 -- generic package x is ...
11597 -- package xx is new x;
11599 -- package body x is ...
11601 -- In this situation it is certain that an elaboration error will occur,
11602 -- and an unconditional raise Program_Error statement is inserted before
11603 -- the instantiation, and a warning generated.
11605 -- The problem is that in this case we have no place to put the body of
11606 -- the instantiation. We can't put it in the normal place, because it is
11607 -- too early, and will cause errors to occur as a result of referencing
11608 -- entities before they are declared.
11610 -- Our approach in this case is simply to avoid creating the body of the
11611 -- instantiation in such a case. The instantiation spec is modified to
11612 -- include dummy bodies for all subprograms, so that the resulting code
11613 -- does not contain subprogram specs with no corresponding bodies.
11615 -- The following table records the recursive call chain for output in the
11616 -- Output routine. Each entry records the call node and the entity of the
11617 -- called routine. The number of entries in the table (i.e. the value of
11618 -- Elab_Call.Last) indicates the current depth of recursion and is used to
11619 -- identify the outer level.
11621 type Elab_Call_Element
is record
11626 package Elab_Call
is new Table
.Table
11627 (Table_Component_Type
=> Elab_Call_Element
,
11628 Table_Index_Type
=> Int
,
11629 Table_Low_Bound
=> 1,
11630 Table_Initial
=> 50,
11631 Table_Increment
=> 100,
11632 Table_Name
=> "Elab_Call");
11634 -- The following table records all calls that have been processed starting
11635 -- from an outer level call. The table prevents both infinite recursion and
11636 -- useless reanalysis of calls within the same context. The use of context
11637 -- is important because it allows for proper checks in more complex code:
11640 -- Call; -- requires a check
11641 -- Call; -- does not need a check thanks to the table
11643 -- Call; -- requires a check, different context
11646 -- Call; -- requires a check, different context
11648 type Visited_Element
is record
11649 Subp_Id
: Entity_Id
;
11650 -- The entity of the subprogram being called
11653 -- The context where the call to the subprogram occurs
11656 package Elab_Visited
is new Table
.Table
11657 (Table_Component_Type
=> Visited_Element
,
11658 Table_Index_Type
=> Int
,
11659 Table_Low_Bound
=> 1,
11660 Table_Initial
=> 200,
11661 Table_Increment
=> 100,
11662 Table_Name
=> "Elab_Visited");
11664 -- The following table records delayed calls which must be examined after
11665 -- all generic bodies have been instantiated.
11667 type Delay_Element
is record
11669 -- The parameter N from the call to Check_Internal_Call. Note that this
11670 -- node may get rewritten over the delay period by expansion in the call
11671 -- case (but not in the instantiation case).
11674 -- The parameter E from the call to Check_Internal_Call
11676 Orig_Ent
: Entity_Id
;
11677 -- The parameter Orig_Ent from the call to Check_Internal_Call
11679 Curscop
: Entity_Id
;
11680 -- The current scope of the call. This is restored when we complete the
11681 -- delayed call, so that we do this in the right scope.
11683 Outer_Scope
: Entity_Id
;
11684 -- Save scope of outer level call
11686 From_Elab_Code
: Boolean;
11687 -- Save indication of whether this call is from elaboration code
11689 In_Task_Activation
: Boolean;
11690 -- Save indication of whether this call is from a task body. Tasks are
11691 -- activated at the "begin", which is after all local procedure bodies,
11692 -- so calls to those procedures can't fail, even if they occur after the
11695 From_SPARK_Code
: Boolean;
11696 -- Save indication of whether this call is under SPARK_Mode => On
11699 package Delay_Check
is new Table
.Table
11700 (Table_Component_Type
=> Delay_Element
,
11701 Table_Index_Type
=> Int
,
11702 Table_Low_Bound
=> 1,
11703 Table_Initial
=> 1000,
11704 Table_Increment
=> 100,
11705 Table_Name
=> "Delay_Check");
11707 C_Scope
: Entity_Id
;
11708 -- Top-level scope of current scope. Compute this only once at the outer
11709 -- level, i.e. for a call to Check_Elab_Call from outside this unit.
11711 Outer_Level_Sloc
: Source_Ptr
;
11712 -- Save Sloc value for outer level call node for comparisons of source
11713 -- locations. A body is too late if it appears after the *outer* level
11714 -- call, not the particular call that is being analyzed.
11716 From_Elab_Code
: Boolean;
11717 -- This flag shows whether the outer level call currently being examined
11718 -- is or is not in elaboration code. We are only interested in calls to
11719 -- routines in other units if this flag is True.
11721 In_Task_Activation
: Boolean := False;
11722 -- This flag indicates whether we are performing elaboration checks on task
11723 -- bodies, at the point of activation. If true, we do not raise
11724 -- Program_Error for calls to local procedures, because all local bodies
11725 -- are known to be elaborated. However, we still need to trace such calls,
11726 -- because a local procedure could call a procedure in another package,
11727 -- so we might need an implicit Elaborate_All.
11729 Delaying_Elab_Checks
: Boolean := True;
11730 -- This is set True till the compilation is complete, including the
11731 -- insertion of all instance bodies. Then when Check_Elab_Calls is called,
11732 -- the delay table is used to make the delayed calls and this flag is reset
11733 -- to False, so that the calls are processed.
11735 -----------------------
11736 -- Local Subprograms --
11737 -----------------------
11739 -- Note: Outer_Scope in all following specs represents the scope of
11740 -- interest of the outer level call. If it is set to Standard_Standard,
11741 -- then it means the outer level call was at elaboration level, and that
11742 -- thus all calls are of interest. If it was set to some other scope,
11743 -- then the original call was an inner call, and we are not interested
11744 -- in calls that go outside this scope.
11746 procedure Activate_Elaborate_All_Desirable
(N
: Node_Id
; U
: Entity_Id
);
11747 -- Analysis of construct N shows that we should set Elaborate_All_Desirable
11748 -- for the WITH clause for unit U (which will always be present). A special
11749 -- case is when N is a function or procedure instantiation, in which case
11750 -- it is sufficient to set Elaborate_Desirable, since in this case there is
11751 -- no possibility of transitive elaboration issues.
11753 procedure Check_A_Call
11756 Outer_Scope
: Entity_Id
;
11757 Inter_Unit_Only
: Boolean;
11758 Generate_Warnings
: Boolean := True;
11759 In_Init_Proc
: Boolean := False);
11760 -- This is the internal recursive routine that is called to check for
11761 -- possible elaboration error. The argument N is a subprogram call or
11762 -- generic instantiation, or 'Access attribute reference to be checked, and
11763 -- E is the entity of the called subprogram, or instantiated generic unit,
11764 -- or subprogram referenced by 'Access.
11766 -- In SPARK mode, N can also be a variable reference, since in SPARK this
11767 -- also triggers a requirement for Elaborate_All, and in this case E is the
11768 -- entity being referenced.
11770 -- Outer_Scope is the outer level scope for the original reference.
11771 -- Inter_Unit_Only is set if the call is only to be checked in the
11772 -- case where it is to another unit (and skipped if within a unit).
11773 -- Generate_Warnings is set to False to suppress warning messages about
11774 -- missing pragma Elaborate_All's. These messages are not wanted for
11775 -- inner calls in the dynamic model. Note that an instance of the Access
11776 -- attribute applied to a subprogram also generates a call to this
11777 -- procedure (since the referenced subprogram may be called later
11778 -- indirectly). Flag In_Init_Proc should be set whenever the current
11779 -- context is a type init proc.
11781 -- Note: this might better be called Check_A_Reference to recognize the
11782 -- variable case for SPARK, but we prefer to retain the historical name
11783 -- since in practice this is mostly about checking calls for the possible
11784 -- occurrence of an access-before-elaboration exception.
11786 procedure Check_Bad_Instantiation
(N
: Node_Id
);
11787 -- N is a node for an instantiation (if called with any other node kind,
11788 -- Check_Bad_Instantiation ignores the call). This subprogram checks for
11789 -- the special case of a generic instantiation of a generic spec in the
11790 -- same declarative part as the instantiation where a body is present and
11791 -- has not yet been seen. This is an obvious error, but needs to be checked
11792 -- specially at the time of the instantiation, since it is a case where we
11793 -- cannot insert the body anywhere. If this case is detected, warnings are
11794 -- generated, and a raise of Program_Error is inserted. In addition any
11795 -- subprograms in the generic spec are stubbed, and the Bad_Instantiation
11796 -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this
11797 -- flag as an indication that no attempt should be made to insert an
11800 procedure Check_Internal_Call
11803 Outer_Scope
: Entity_Id
;
11804 Orig_Ent
: Entity_Id
);
11805 -- N is a function call or procedure statement call node and E is the
11806 -- entity of the called function, which is within the current compilation
11807 -- unit (where subunits count as part of the parent). This call checks if
11808 -- this call, or any call within any accessed body could cause an ABE, and
11809 -- if so, outputs a warning. Orig_Ent differs from E only in the case of
11810 -- renamings, and points to the original name of the entity. This is used
11811 -- for error messages. Outer_Scope is the outer level scope for the
11814 procedure Check_Internal_Call_Continue
11817 Outer_Scope
: Entity_Id
;
11818 Orig_Ent
: Entity_Id
);
11819 -- The processing for Check_Internal_Call is divided up into two phases,
11820 -- and this represents the second phase. The second phase is delayed if
11821 -- Delaying_Elab_Checks is set to True. In this delayed case, the first
11822 -- phase makes an entry in the Delay_Check table, which is processed when
11823 -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to
11824 -- Check_Internal_Call. Outer_Scope is the outer level scope for the
11827 function Get_Referenced_Ent
(N
: Node_Id
) return Entity_Id
;
11828 -- N is either a function or procedure call or an access attribute that
11829 -- references a subprogram. This call retrieves the relevant entity. If
11830 -- this is a call to a protected subprogram, the entity is a selected
11831 -- component. The callable entity may be absent, in which case Empty is
11832 -- returned. This happens with non-analyzed calls in nested generics.
11834 -- If SPARK_Mode is On, then N can also be a reference to an E_Variable
11835 -- entity, in which case, the value returned is simply this entity.
11837 function Has_Generic_Body
(N
: Node_Id
) return Boolean;
11838 -- N is a generic package instantiation node, and this routine determines
11839 -- if this package spec does in fact have a generic body. If so, then
11840 -- True is returned, otherwise False. Note that this is not at all the
11841 -- same as checking if the unit requires a body, since it deals with
11842 -- the case of optional bodies accurately (i.e. if a body is optional,
11843 -- then it looks to see if a body is actually present). Note: this
11844 -- function can only do a fully correct job if in generating code mode
11845 -- where all bodies have to be present. If we are operating in semantics
11846 -- check only mode, then in some cases of optional bodies, a result of
11847 -- False may incorrectly be given. In practice this simply means that
11848 -- some cases of warnings for incorrect order of elaboration will only
11849 -- be given when generating code, which is not a big problem (and is
11850 -- inevitable, given the optional body semantics of Ada).
11852 procedure Insert_Elab_Check
(N
: Node_Id
; C
: Node_Id
:= Empty
);
11853 -- Given code for an elaboration check (or unconditional raise if the check
11854 -- is not needed), inserts the code in the appropriate place. N is the call
11855 -- or instantiation node for which the check code is required. C is the
11856 -- test whose failure triggers the raise.
11858 function Is_Call_Of_Generic_Formal
(N
: Node_Id
) return Boolean;
11859 -- Returns True if node N is a call to a generic formal subprogram
11861 function Is_Finalization_Procedure
(Id
: Entity_Id
) return Boolean;
11862 -- Determine whether entity Id denotes a [Deep_]Finalize procedure
11864 procedure Output_Calls
11866 Check_Elab_Flag
: Boolean);
11867 -- Outputs chain of calls stored in the Elab_Call table. The caller has
11868 -- already generated the main warning message, so the warnings generated
11869 -- are all continuation messages. The argument is the call node at which
11870 -- the messages are to be placed. When Check_Elab_Flag is set, calls are
11871 -- enumerated only when flag Elab_Warning is set for the dynamic case or
11872 -- when flag Elab_Info_Messages is set for the static case.
11874 function Same_Elaboration_Scope
(Scop1
, Scop2
: Entity_Id
) return Boolean;
11875 -- Given two scopes, determine whether they are the same scope from an
11876 -- elaboration point of view, i.e. packages and blocks are ignored.
11878 procedure Set_C_Scope
;
11879 -- On entry C_Scope is set to some scope. On return, C_Scope is reset
11880 -- to be the enclosing compilation unit of this scope.
11882 procedure Set_Elaboration_Constraint
11886 -- The current unit U may depend semantically on some unit P that is not
11887 -- in the current context. If there is an elaboration call that reaches P,
11888 -- we need to indicate that P requires an Elaborate_All, but this is not
11889 -- effective in U's ali file, if there is no with_clause for P. In this
11890 -- case we add the Elaborate_All on the unit Q that directly or indirectly
11891 -- makes P available. This can happen in two cases:
11893 -- a) Q declares a subtype of a type declared in P, and the call is an
11894 -- initialization call for an object of that subtype.
11896 -- b) Q declares an object of some tagged type whose root type is
11897 -- declared in P, and the initialization call uses object notation on
11898 -- that object to reach a primitive operation or a classwide operation
11901 -- If P appears in the context of U, the current processing is correct.
11902 -- Otherwise we must identify these two cases to retrieve Q and place the
11903 -- Elaborate_All_Desirable on it.
11905 function Spec_Entity
(E
: Entity_Id
) return Entity_Id
;
11906 -- Given a compilation unit entity, if it is a spec entity, it is returned
11907 -- unchanged. If it is a body entity, then the spec for the corresponding
11908 -- spec is returned
11910 function Within
(E1
, E2
: Entity_Id
) return Boolean;
11911 -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one
11912 -- of its contained scopes, False otherwise.
11914 function Within_Elaborate_All
11915 (Unit
: Unit_Number_Type
;
11916 E
: Entity_Id
) return Boolean;
11917 -- Return True if we are within the scope of an Elaborate_All for E, or if
11918 -- we are within the scope of an Elaborate_All for some other unit U, and U
11919 -- with's E. This prevents spurious warnings when the called entity is
11920 -- renamed within U, or in case of generic instances.
11922 --------------------------------------
11923 -- Activate_Elaborate_All_Desirable --
11924 --------------------------------------
11926 procedure Activate_Elaborate_All_Desirable
(N
: Node_Id
; U
: Entity_Id
) is
11927 UN
: constant Unit_Number_Type
:= Get_Code_Unit
(N
);
11928 CU
: constant Node_Id
:= Cunit
(UN
);
11929 UE
: constant Entity_Id
:= Cunit_Entity
(UN
);
11930 Unm
: constant Unit_Name_Type
:= Unit_Name
(UN
);
11931 CI
: constant List_Id
:= Context_Items
(CU
);
11935 procedure Add_To_Context_And_Mark
(Itm
: Node_Id
);
11936 -- This procedure is called when the elaborate indication must be
11937 -- applied to a unit not in the context of the referencing unit. The
11938 -- unit gets added to the context as an implicit with.
11940 function In_Withs_Of
(UEs
: Entity_Id
) return Boolean;
11941 -- UEs is the spec entity of a unit. If the unit to be marked is
11942 -- in the context item list of this unit spec, then the call returns
11943 -- True and Itm is left set to point to the relevant N_With_Clause node.
11945 procedure Set_Elab_Flag
(Itm
: Node_Id
);
11946 -- Sets Elaborate_[All_]Desirable as appropriate on Itm
11948 -----------------------------
11949 -- Add_To_Context_And_Mark --
11950 -----------------------------
11952 procedure Add_To_Context_And_Mark
(Itm
: Node_Id
) is
11953 CW
: constant Node_Id
:=
11954 Make_With_Clause
(Sloc
(Itm
),
11955 Name
=> Name
(Itm
));
11958 Set_Library_Unit
(CW
, Library_Unit
(Itm
));
11959 Set_Implicit_With
(CW
);
11961 -- Set elaborate all desirable on copy and then append the copy to
11962 -- the list of body with's and we are done.
11964 Set_Elab_Flag
(CW
);
11965 Append_To
(CI
, CW
);
11966 end Add_To_Context_And_Mark
;
11972 function In_Withs_Of
(UEs
: Entity_Id
) return Boolean is
11973 UNs
: constant Unit_Number_Type
:= Get_Source_Unit
(UEs
);
11974 CUs
: constant Node_Id
:= Cunit
(UNs
);
11975 CIs
: constant List_Id
:= Context_Items
(CUs
);
11978 Itm
:= First
(CIs
);
11979 while Present
(Itm
) loop
11980 if Nkind
(Itm
) = N_With_Clause
then
11982 Cunit_Entity
(Get_Cunit_Unit_Number
(Library_Unit
(Itm
)));
11995 -------------------
11996 -- Set_Elab_Flag --
11997 -------------------
11999 procedure Set_Elab_Flag
(Itm
: Node_Id
) is
12001 if Nkind
(N
) in N_Subprogram_Instantiation
then
12002 Set_Elaborate_Desirable
(Itm
);
12004 Set_Elaborate_All_Desirable
(Itm
);
12008 -- Start of processing for Activate_Elaborate_All_Desirable
12011 -- Do not set binder indication if expansion is disabled, as when
12012 -- compiling a generic unit.
12014 if not Expander_Active
then
12018 -- If an instance of a generic package contains a controlled object (so
12019 -- we're calling Initialize at elaboration time), and the instance is in
12020 -- a package body P that says "with P;", then we need to return without
12021 -- adding "pragma Elaborate_All (P);" to P.
12023 if U
= Main_Unit_Entity
then
12028 while Present
(Itm
) loop
12029 if Nkind
(Itm
) = N_With_Clause
then
12030 Ent
:= Cunit_Entity
(Get_Cunit_Unit_Number
(Library_Unit
(Itm
)));
12032 -- If we find it, then mark elaborate all desirable and return
12035 Set_Elab_Flag
(Itm
);
12043 -- If we fall through then the with clause is not present in the
12044 -- current unit. One legitimate possibility is that the with clause
12045 -- is present in the spec when we are a body.
12047 if Is_Body_Name
(Unm
)
12048 and then In_Withs_Of
(Spec_Entity
(UE
))
12050 Add_To_Context_And_Mark
(Itm
);
12054 -- Similarly, we may be in the spec or body of a child unit, where
12055 -- the unit in question is with'ed by some ancestor of the child unit.
12057 if Is_Child_Name
(Unm
) then
12064 Pkg
:= Scope
(Pkg
);
12065 exit when Pkg
= Standard_Standard
;
12067 if In_Withs_Of
(Pkg
) then
12068 Add_To_Context_And_Mark
(Itm
);
12075 -- Here if we do not find with clause on spec or body. We just ignore
12076 -- this case; it means that the elaboration involves some other unit
12077 -- than the unit being compiled, and will be caught elsewhere.
12078 end Activate_Elaborate_All_Desirable
;
12084 procedure Check_A_Call
12087 Outer_Scope
: Entity_Id
;
12088 Inter_Unit_Only
: Boolean;
12089 Generate_Warnings
: Boolean := True;
12090 In_Init_Proc
: Boolean := False)
12092 Access_Case
: constant Boolean := Nkind
(N
) = N_Attribute_Reference
;
12093 -- Indicates if we have Access attribute case
12095 function Call_To_Instance_From_Outside
(Id
: Entity_Id
) return Boolean;
12096 -- True if we're calling an instance of a generic subprogram, or a
12097 -- subprogram in an instance of a generic package, and the call is
12098 -- outside that instance.
12100 procedure Elab_Warning
12103 Ent
: Node_Or_Entity_Id
);
12104 -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for
12105 -- dynamic or static elaboration model), N and Ent. Msg_D is a real
12106 -- warning (output if Msg_D is non-null and Elab_Warnings is set),
12107 -- Msg_S is an info message (output if Elab_Info_Messages is set).
12109 function Find_W_Scope
return Entity_Id
;
12110 -- Find top-level scope for called entity (not following renamings
12111 -- or derivations). This is where the Elaborate_All will go if it is
12112 -- needed. We start with the called entity, except in the case of an
12113 -- initialization procedure outside the current package, where the init
12114 -- proc is in the root package, and we start from the entity of the name
12117 -----------------------------------
12118 -- Call_To_Instance_From_Outside --
12119 -----------------------------------
12121 function Call_To_Instance_From_Outside
(Id
: Entity_Id
) return Boolean is
12122 Scop
: Entity_Id
:= Id
;
12126 if Scop
= Standard_Standard
then
12130 if Is_Generic_Instance
(Scop
) then
12131 return not In_Open_Scopes
(Scop
);
12134 Scop
:= Scope
(Scop
);
12136 end Call_To_Instance_From_Outside
;
12142 procedure Elab_Warning
12145 Ent
: Node_Or_Entity_Id
)
12148 -- Dynamic elaboration checks, real warning
12150 if Dynamic_Elaboration_Checks
then
12151 if not Access_Case
then
12152 if Msg_D
/= "" and then Elab_Warnings
then
12153 Error_Msg_NE
(Msg_D
, N
, Ent
);
12156 -- In the access case emit first warning message as well,
12157 -- otherwise list of calls will appear as errors.
12159 elsif Elab_Warnings
then
12160 Error_Msg_NE
(Msg_S
, N
, Ent
);
12163 -- Static elaboration checks, info message
12166 if Elab_Info_Messages
then
12167 Error_Msg_NE
(Msg_S
, N
, Ent
);
12176 function Find_W_Scope
return Entity_Id
is
12177 Refed_Ent
: constant Entity_Id
:= Get_Referenced_Ent
(N
);
12178 W_Scope
: Entity_Id
;
12181 if Is_Init_Proc
(Refed_Ent
)
12182 and then not In_Same_Extended_Unit
(N
, Refed_Ent
)
12184 W_Scope
:= Scope
(Refed_Ent
);
12189 -- Now loop through scopes to get to the enclosing compilation unit
12191 while not Is_Compilation_Unit
(W_Scope
) loop
12192 W_Scope
:= Scope
(W_Scope
);
12200 Inst_Case
: constant Boolean := Nkind
(N
) in N_Generic_Instantiation
;
12201 -- Indicates if we have instantiation case
12203 Loc
: constant Source_Ptr
:= Sloc
(N
);
12205 Variable_Case
: constant Boolean :=
12206 Nkind
(N
) in N_Has_Entity
12207 and then Present
(Entity
(N
))
12208 and then Ekind
(Entity
(N
)) = E_Variable
;
12209 -- Indicates if we have variable reference case
12211 W_Scope
: constant Entity_Id
:= Find_W_Scope
;
12212 -- Top-level scope of directly called entity for subprogram. This
12213 -- differs from E_Scope in the case where renamings or derivations
12214 -- are involved, since it does not follow these links. W_Scope is
12215 -- generally in a visible unit, and it is this scope that may require
12216 -- an Elaborate_All. However, there are some cases (initialization
12217 -- calls and calls involving object notation) where W_Scope might not
12218 -- be in the context of the current unit, and there is an intermediate
12219 -- package that is, in which case the Elaborate_All has to be placed
12220 -- on this intermediate package. These special cases are handled in
12221 -- Set_Elaboration_Constraint.
12224 Callee_Unit_Internal
: Boolean;
12225 Caller_Unit_Internal
: Boolean;
12227 Inst_Callee
: Source_Ptr
;
12228 Inst_Caller
: Source_Ptr
;
12229 Unit_Callee
: Unit_Number_Type
;
12230 Unit_Caller
: Unit_Number_Type
;
12232 Body_Acts_As_Spec
: Boolean;
12233 -- Set to true if call is to body acting as spec (no separate spec)
12235 Cunit_SC
: Boolean := False;
12236 -- Set to suppress dynamic elaboration checks where one of the
12237 -- enclosing scopes has Elaboration_Checks_Suppressed set, or else
12238 -- if a pragma Elaborate[_All] applies to that scope, in which case
12239 -- warnings on the scope are also suppressed. For the internal case,
12240 -- we ignore this flag.
12242 E_Scope
: Entity_Id
;
12243 -- Top-level scope of entity for called subprogram. This value includes
12244 -- following renamings and derivations, so this scope can be in a
12245 -- non-visible unit. This is the scope that is to be investigated to
12246 -- see whether an elaboration check is required.
12249 -- Flag set when the subprogram being invoked is the procedure generated
12250 -- for pragma Default_Initial_Condition.
12252 SPARK_Elab_Errors
: Boolean;
12253 -- Flag set when an entity is called or a variable is read during SPARK
12254 -- dynamic elaboration.
12256 -- Start of processing for Check_A_Call
12259 -- If the call is known to be within a local Suppress Elaboration
12260 -- pragma, nothing to check. This can happen in task bodies. But
12261 -- we ignore this for a call to a generic formal.
12263 if Nkind
(N
) in N_Subprogram_Call
12264 and then No_Elaboration_Check
(N
)
12265 and then not Is_Call_Of_Generic_Formal
(N
)
12269 -- If this is a rewrite of a Valid_Scalars attribute, then nothing to
12270 -- check, we don't mind in this case if the call occurs before the body
12271 -- since this is all generated code.
12273 elsif Nkind
(Original_Node
(N
)) = N_Attribute_Reference
12274 and then Attribute_Name
(Original_Node
(N
)) = Name_Valid_Scalars
12278 -- Intrinsics such as instances of Unchecked_Deallocation do not have
12279 -- any body, so elaboration checking is not needed, and would be wrong.
12281 elsif Is_Intrinsic_Subprogram
(E
) then
12284 -- Do not consider references to internal variables for SPARK semantics
12286 elsif Variable_Case
and then not Comes_From_Source
(E
) then
12290 -- Proceed with check
12294 -- For a variable reference, just set Body_Acts_As_Spec to False
12296 if Variable_Case
then
12297 Body_Acts_As_Spec
:= False;
12299 -- Additional checks for all other cases
12302 -- Go to parent for derived subprogram, or to original subprogram in
12303 -- the case of a renaming (Alias covers both these cases).
12306 if (Suppress_Elaboration_Warnings
(Ent
)
12307 or else Elaboration_Checks_Suppressed
(Ent
))
12308 and then (Inst_Case
or else No
(Alias
(Ent
)))
12313 -- Nothing to do for imported entities
12315 if Is_Imported
(Ent
) then
12319 exit when Inst_Case
or else No
(Alias
(Ent
));
12320 Ent
:= Alias
(Ent
);
12323 Decl
:= Unit_Declaration_Node
(Ent
);
12325 if Nkind
(Decl
) = N_Subprogram_Body
then
12326 Body_Acts_As_Spec
:= True;
12328 elsif Nkind_In
(Decl
, N_Subprogram_Declaration
,
12329 N_Subprogram_Body_Stub
)
12332 Body_Acts_As_Spec
:= False;
12334 -- If we have none of an instantiation, subprogram body or subprogram
12335 -- declaration, or in the SPARK case, a variable reference, then
12336 -- it is not a case that we want to check. (One case is a call to a
12337 -- generic formal subprogram, where we do not want the check in the
12347 if Elaboration_Checks_Suppressed
(E_Scope
)
12348 or else Suppress_Elaboration_Warnings
(E_Scope
)
12353 -- Exit when we get to compilation unit, not counting subunits
12355 exit when Is_Compilation_Unit
(E_Scope
)
12356 and then (Is_Child_Unit
(E_Scope
)
12357 or else Scope
(E_Scope
) = Standard_Standard
);
12359 pragma Assert
(E_Scope
/= Standard_Standard
);
12361 -- Move up a scope looking for compilation unit
12363 E_Scope
:= Scope
(E_Scope
);
12366 -- No checks needed for pure or preelaborated compilation units
12368 if Is_Pure
(E_Scope
) or else Is_Preelaborated
(E_Scope
) then
12372 -- If the generic entity is within a deeper instance than we are, then
12373 -- either the instantiation to which we refer itself caused an ABE, in
12374 -- which case that will be handled separately, or else we know that the
12375 -- body we need appears as needed at the point of the instantiation.
12376 -- However, this assumption is only valid if we are in static mode.
12378 if not Dynamic_Elaboration_Checks
12380 Instantiation_Depth
(Sloc
(Ent
)) > Instantiation_Depth
(Sloc
(N
))
12385 -- Do not give a warning for a package with no body
12387 if Ekind
(Ent
) = E_Generic_Package
and then not Has_Generic_Body
(N
) then
12391 -- Case of entity is in same unit as call or instantiation. In the
12392 -- instantiation case, W_Scope may be different from E_Scope; we want
12393 -- the unit in which the instantiation occurs, since we're analyzing
12394 -- based on the expansion.
12396 if W_Scope
= C_Scope
then
12397 if not Inter_Unit_Only
then
12398 Check_Internal_Call
(N
, Ent
, Outer_Scope
, E
);
12404 -- Case of entity is not in current unit (i.e. with'ed unit case)
12406 -- We are only interested in such calls if the outer call was from
12407 -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode.
12409 if not From_Elab_Code
and then not Dynamic_Elaboration_Checks
then
12413 -- Nothing to do if some scope said that no checks were required
12419 -- Nothing to do for a generic instance, because a call to an instance
12420 -- cannot fail the elaboration check, because the body of the instance
12421 -- is always elaborated immediately after the spec.
12423 if Call_To_Instance_From_Outside
(Ent
) then
12427 -- Nothing to do if subprogram with no separate spec. However, a call
12428 -- to Deep_Initialize may result in a call to a user-defined Initialize
12429 -- procedure, which imposes a body dependency. This happens only if the
12430 -- type is controlled and the Initialize procedure is not inherited.
12432 if Body_Acts_As_Spec
then
12433 if Is_TSS
(Ent
, TSS_Deep_Initialize
) then
12435 Typ
: constant Entity_Id
:= Etype
(First_Formal
(Ent
));
12439 if not Is_Controlled
(Typ
) then
12442 Init
:= Find_Prim_Op
(Typ
, Name_Initialize
);
12444 if Comes_From_Source
(Init
) then
12457 -- Check cases of internal units
12459 Callee_Unit_Internal
:= In_Internal_Unit
(E_Scope
);
12461 -- Do not give a warning if the with'ed unit is internal and this is
12462 -- the generic instantiation case (this saves a lot of hassle dealing
12463 -- with the Text_IO special child units)
12465 if Callee_Unit_Internal
and Inst_Case
then
12469 if C_Scope
= Standard_Standard
then
12470 Caller_Unit_Internal
:= False;
12472 Caller_Unit_Internal
:= In_Internal_Unit
(C_Scope
);
12475 -- Do not give a warning if the with'ed unit is internal and the caller
12476 -- is not internal (since the binder always elaborates internal units
12479 if Callee_Unit_Internal
and not Caller_Unit_Internal
then
12483 -- For now, if debug flag -gnatdE is not set, do no checking for one
12484 -- internal unit withing another. This fixes the problem with the sgi
12485 -- build and storage errors. To be resolved later ???
12487 if (Callee_Unit_Internal
and Caller_Unit_Internal
)
12488 and not Debug_Flag_EE
12493 if Is_TSS
(E
, TSS_Deep_Initialize
) then
12497 -- If the call is in an instance, and the called entity is not
12498 -- defined in the same instance, then the elaboration issue focuses
12499 -- around the unit containing the template, it is this unit that
12500 -- requires an Elaborate_All.
12502 -- However, if we are doing dynamic elaboration, we need to chase the
12503 -- call in the usual manner.
12505 -- We also need to chase the call in the usual manner if it is a call
12506 -- to a generic formal parameter, since that case was not handled as
12507 -- part of the processing of the template.
12509 Inst_Caller
:= Instantiation
(Get_Source_File_Index
(Sloc
(N
)));
12510 Inst_Callee
:= Instantiation
(Get_Source_File_Index
(Sloc
(Ent
)));
12512 if Inst_Caller
= No_Location
then
12513 Unit_Caller
:= No_Unit
;
12515 Unit_Caller
:= Get_Source_Unit
(N
);
12518 if Inst_Callee
= No_Location
then
12519 Unit_Callee
:= No_Unit
;
12521 Unit_Callee
:= Get_Source_Unit
(Ent
);
12524 if Unit_Caller
/= No_Unit
12525 and then Unit_Callee
/= Unit_Caller
12526 and then not Dynamic_Elaboration_Checks
12527 and then not Is_Call_Of_Generic_Formal
(N
)
12529 E_Scope
:= Spec_Entity
(Cunit_Entity
(Unit_Caller
));
12531 -- If we don't get a spec entity, just ignore call. Not quite
12532 -- clear why this check is necessary. ???
12534 if No
(E_Scope
) then
12538 -- Otherwise step to enclosing compilation unit
12540 while not Is_Compilation_Unit
(E_Scope
) loop
12541 E_Scope
:= Scope
(E_Scope
);
12544 -- For the case where N is not an instance, and is not a call within
12545 -- instance to other than a generic formal, we recompute E_Scope
12546 -- for the error message, since we do NOT want to go to the unit
12547 -- that has the ultimate declaration in the case of renaming and
12548 -- derivation and we also want to go to the generic unit in the
12549 -- case of an instance, and no further.
12552 -- Loop to carefully follow renamings and derivations one step
12553 -- outside the current unit, but not further.
12555 if not (Inst_Case
or Variable_Case
)
12556 and then Present
(Alias
(Ent
))
12558 E_Scope
:= Alias
(Ent
);
12564 while not Is_Compilation_Unit
(E_Scope
) loop
12565 E_Scope
:= Scope
(E_Scope
);
12568 -- If E_Scope is the same as C_Scope, it means that there
12569 -- definitely was a local renaming or derivation, and we
12570 -- are not yet out of the current unit.
12572 exit when E_Scope
/= C_Scope
;
12573 Ent
:= Alias
(Ent
);
12576 -- If no alias, there could be a previous error, but not if we've
12577 -- already reached the outermost level (Standard).
12585 if Within_Elaborate_All
(Current_Sem_Unit
, E_Scope
) then
12589 -- Determine whether the Default_Initial_Condition procedure of some
12590 -- type is being invoked.
12592 Is_DIC
:= Ekind
(Ent
) = E_Procedure
and then Is_DIC_Procedure
(Ent
);
12594 -- Checks related to Default_Initial_Condition fall under the SPARK
12595 -- umbrella because this is a SPARK-specific annotation.
12597 SPARK_Elab_Errors
:=
12598 SPARK_Mode
= On
and (Is_DIC
or Dynamic_Elaboration_Checks
);
12600 -- Now check if an Elaborate_All (or dynamic check) is needed
12602 if (Elab_Info_Messages
or Elab_Warnings
or SPARK_Elab_Errors
)
12603 and then Generate_Warnings
12604 and then not Suppress_Elaboration_Warnings
(Ent
)
12605 and then not Elaboration_Checks_Suppressed
(Ent
)
12606 and then not Suppress_Elaboration_Warnings
(E_Scope
)
12607 and then not Elaboration_Checks_Suppressed
(E_Scope
)
12609 -- Instantiation case
12612 if Comes_From_Source
(Ent
) and then SPARK_Elab_Errors
then
12614 ("instantiation of & during elaboration in SPARK", N
, Ent
);
12617 ("instantiation of & may raise Program_Error?l?",
12618 "info: instantiation of & during elaboration?$?", Ent
);
12621 -- Indirect call case, info message only in static elaboration
12622 -- case, because the attribute reference itself cannot raise an
12623 -- exception. Note that SPARK does not permit indirect calls.
12625 elsif Access_Case
then
12626 Elab_Warning
("", "info: access to & during elaboration?$?", Ent
);
12628 -- Variable reference in SPARK mode
12630 elsif Variable_Case
then
12631 if Comes_From_Source
(Ent
) and then SPARK_Elab_Errors
then
12633 ("reference to & during elaboration in SPARK", N
, Ent
);
12636 -- Subprogram call case
12639 if Nkind
(Name
(N
)) in N_Has_Entity
12640 and then Is_Init_Proc
(Entity
(Name
(N
)))
12641 and then Comes_From_Source
(Ent
)
12644 ("implicit call to & may raise Program_Error?l?",
12645 "info: implicit call to & during elaboration?$?",
12648 elsif SPARK_Elab_Errors
then
12650 -- Emit a specialized error message when the elaboration of an
12651 -- object of a private type evaluates the expression of pragma
12652 -- Default_Initial_Condition. This prevents the internal name
12653 -- of the procedure from appearing in the error message.
12657 ("call to Default_Initial_Condition during elaboration in "
12661 ("call to & during elaboration in SPARK", N
, Ent
);
12666 ("call to & may raise Program_Error?l?",
12667 "info: call to & during elaboration?$?",
12672 Error_Msg_Qual_Level
:= Nat
'Last;
12674 -- Case of Elaborate_All not present and required, for SPARK this
12675 -- is an error, so give an error message.
12677 if SPARK_Elab_Errors
then
12678 Error_Msg_NE
-- CODEFIX
12679 ("\Elaborate_All pragma required for&", N
, W_Scope
);
12681 -- Otherwise we generate an implicit pragma. For a subprogram
12682 -- instantiation, Elaborate is good enough, since no transitive
12683 -- call is possible at elaboration time in this case.
12685 elsif Nkind
(N
) in N_Subprogram_Instantiation
then
12687 ("\missing pragma Elaborate for&?l?",
12688 "\implicit pragma Elaborate for& generated?$?",
12691 -- For all other cases, we need an implicit Elaborate_All
12695 ("\missing pragma Elaborate_All for&?l?",
12696 "\implicit pragma Elaborate_All for & generated?$?",
12700 Error_Msg_Qual_Level
:= 0;
12702 -- Take into account the flags related to elaboration warning
12703 -- messages when enumerating the various calls involved. This
12704 -- ensures the proper pairing of the main warning and the
12705 -- clarification messages generated by Output_Calls.
12707 Output_Calls
(N
, Check_Elab_Flag
=> True);
12709 -- Set flag to prevent further warnings for same unit unless in
12710 -- All_Errors_Mode.
12712 if not All_Errors_Mode
and not Dynamic_Elaboration_Checks
then
12713 Set_Suppress_Elaboration_Warnings
(W_Scope
);
12717 -- Check for runtime elaboration check required
12719 if Dynamic_Elaboration_Checks
then
12720 if not Elaboration_Checks_Suppressed
(Ent
)
12721 and then not Elaboration_Checks_Suppressed
(W_Scope
)
12722 and then not Elaboration_Checks_Suppressed
(E_Scope
)
12723 and then not Cunit_SC
12725 -- Runtime elaboration check required. Generate check of the
12726 -- elaboration Boolean for the unit containing the entity.
12728 -- Note that for this case, we do check the real unit (the one
12729 -- from following renamings, since that is the issue).
12731 -- Could this possibly miss a useless but required PE???
12733 Insert_Elab_Check
(N
,
12734 Make_Attribute_Reference
(Loc
,
12735 Attribute_Name
=> Name_Elaborated
,
12737 New_Occurrence_Of
(Spec_Entity
(E_Scope
), Loc
)));
12739 -- Prevent duplicate elaboration checks on the same call, which
12740 -- can happen if the body enclosing the call appears itself in a
12741 -- call whose elaboration check is delayed.
12743 if Nkind
(N
) in N_Subprogram_Call
then
12744 Set_No_Elaboration_Check
(N
);
12748 -- Case of static elaboration model
12751 -- Do not do anything if elaboration checks suppressed. Note that
12752 -- we check Ent here, not E, since we want the real entity for the
12753 -- body to see if checks are suppressed for it, not the dummy
12754 -- entry for renamings or derivations.
12756 if Elaboration_Checks_Suppressed
(Ent
)
12757 or else Elaboration_Checks_Suppressed
(E_Scope
)
12758 or else Elaboration_Checks_Suppressed
(W_Scope
)
12762 -- Do not generate an Elaborate_All for finalization routines
12763 -- that perform partial clean up as part of initialization.
12765 elsif In_Init_Proc
and then Is_Finalization_Procedure
(Ent
) then
12768 -- Here we need to generate an implicit elaborate all
12771 -- Generate Elaborate_All warning unless suppressed
12773 if (Elab_Info_Messages
and Generate_Warnings
and not Inst_Case
)
12774 and then not Suppress_Elaboration_Warnings
(Ent
)
12775 and then not Suppress_Elaboration_Warnings
(E_Scope
)
12776 and then not Suppress_Elaboration_Warnings
(W_Scope
)
12778 Error_Msg_Node_2
:= W_Scope
;
12780 ("info: call to& in elaboration code requires pragma "
12781 & "Elaborate_All on&?$?", N
, E
);
12784 -- Set indication for binder to generate Elaborate_All
12786 Set_Elaboration_Constraint
(N
, E
, W_Scope
);
12791 -----------------------------
12792 -- Check_Bad_Instantiation --
12793 -----------------------------
12795 procedure Check_Bad_Instantiation
(N
: Node_Id
) is
12799 -- Nothing to do if we do not have an instantiation (happens in some
12800 -- error cases, and also in the formal package declaration case)
12802 if Nkind
(N
) not in N_Generic_Instantiation
then
12805 -- Nothing to do if serious errors detected (avoid cascaded errors)
12807 elsif Serious_Errors_Detected
/= 0 then
12810 -- Nothing to do if not in full analysis mode
12812 elsif not Full_Analysis
then
12815 -- Nothing to do if inside a generic template
12817 elsif Inside_A_Generic
then
12820 -- Nothing to do if a library level instantiation
12822 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
12825 -- Nothing to do if we are compiling a proper body for semantic
12826 -- purposes only. The generic body may be in another proper body.
12829 Nkind
(Parent
(Unit_Declaration_Node
(Main_Unit_Entity
))) = N_Subunit
12834 Ent
:= Get_Generic_Entity
(N
);
12836 -- The case we are interested in is when the generic spec is in the
12837 -- current declarative part
12839 if not Same_Elaboration_Scope
(Current_Scope
, Scope
(Ent
))
12840 or else not In_Same_Extended_Unit
(N
, Ent
)
12845 -- If the generic entity is within a deeper instance than we are, then
12846 -- either the instantiation to which we refer itself caused an ABE, in
12847 -- which case that will be handled separately. Otherwise, we know that
12848 -- the body we need appears as needed at the point of the instantiation.
12849 -- If they are both at the same level but not within the same instance
12850 -- then the body of the generic will be in the earlier instance.
12853 D1
: constant Nat
:= Instantiation_Depth
(Sloc
(Ent
));
12854 D2
: constant Nat
:= Instantiation_Depth
(Sloc
(N
));
12861 and then Is_Generic_Instance
(Scope
(Ent
))
12862 and then not In_Open_Scopes
(Scope
(Ent
))
12868 -- Now we can proceed, if the entity being called has a completion,
12869 -- then we are definitely OK, since we have already seen the body.
12871 if Has_Completion
(Ent
) then
12875 -- If there is no body, then nothing to do
12877 if not Has_Generic_Body
(N
) then
12881 -- Here we definitely have a bad instantiation
12883 Error_Msg_Warn
:= SPARK_Mode
/= On
;
12884 Error_Msg_NE
("cannot instantiate& before body seen<<", N
, Ent
);
12885 Error_Msg_N
("\Program_Error [<<", N
);
12887 Insert_Elab_Check
(N
);
12888 Set_Is_Known_Guaranteed_ABE
(N
);
12889 end Check_Bad_Instantiation
;
12891 ---------------------
12892 -- Check_Elab_Call --
12893 ---------------------
12895 procedure Check_Elab_Call
12897 Outer_Scope
: Entity_Id
:= Empty
;
12898 In_Init_Proc
: Boolean := False)
12904 pragma Assert
(Legacy_Elaboration_Checks
);
12906 -- If the reference is not in the main unit, there is nothing to check.
12907 -- Elaboration call from units in the context of the main unit will lead
12908 -- to semantic dependencies when those units are compiled.
12910 if not In_Extended_Main_Code_Unit
(N
) then
12914 -- For an entry call, check relevant restriction
12916 if Nkind
(N
) = N_Entry_Call_Statement
12917 and then not In_Subprogram_Or_Concurrent_Unit
12919 Check_Restriction
(No_Entry_Calls_In_Elaboration_Code
, N
);
12921 -- Nothing to do if this is not an expected type of reference (happens
12922 -- in some error conditions, and in some cases where rewriting occurs).
12924 elsif Nkind
(N
) not in N_Subprogram_Call
12925 and then Nkind
(N
) /= N_Attribute_Reference
12926 and then (SPARK_Mode
/= On
12927 or else Nkind
(N
) not in N_Has_Entity
12928 or else No
(Entity
(N
))
12929 or else Ekind
(Entity
(N
)) /= E_Variable
)
12933 -- Nothing to do if this is a call already rewritten for elab checking.
12934 -- Such calls appear as the targets of If_Expressions.
12936 -- This check MUST be wrong, it catches far too much
12938 elsif Nkind
(Parent
(N
)) = N_If_Expression
then
12941 -- Nothing to do if inside a generic template
12943 elsif Inside_A_Generic
12944 and then No
(Enclosing_Generic_Body
(N
))
12948 -- Nothing to do if call is being pre-analyzed, as when within a
12949 -- pre/postcondition, a predicate, or an invariant.
12951 elsif In_Spec_Expression
then
12955 -- Nothing to do if this is a call to a postcondition, which is always
12956 -- within a subprogram body, even though the current scope may be the
12957 -- enclosing scope of the subprogram.
12959 if Nkind
(N
) = N_Procedure_Call_Statement
12960 and then Is_Entity_Name
(Name
(N
))
12961 and then Chars
(Entity
(Name
(N
))) = Name_uPostconditions
12966 -- Here we have a reference at elaboration time that must be checked
12968 if Debug_Flag_Underscore_LL
then
12969 Write_Str
(" Check_Elab_Ref: ");
12971 if Nkind
(N
) = N_Attribute_Reference
then
12972 if not Is_Entity_Name
(Prefix
(N
)) then
12973 Write_Str
("<<not entity name>>");
12975 Write_Name
(Chars
(Entity
(Prefix
(N
))));
12978 Write_Str
("'Access");
12980 elsif No
(Name
(N
)) or else not Is_Entity_Name
(Name
(N
)) then
12981 Write_Str
("<<not entity name>> ");
12984 Write_Name
(Chars
(Entity
(Name
(N
))));
12987 Write_Str
(" reference at ");
12988 Write_Location
(Sloc
(N
));
12992 -- Climb up the tree to make sure we are not inside default expression
12993 -- of a parameter specification or a record component, since in both
12994 -- these cases, we will be doing the actual reference later, not now,
12995 -- and it is at the time of the actual reference (statically speaking)
12996 -- that we must do our static check, not at the time of its initial
12999 -- However, we have to check references within component definitions
13000 -- (e.g. a function call that determines an array component bound),
13001 -- so we terminate the loop in that case.
13004 while Present
(P
) loop
13005 if Nkind_In
(P
, N_Parameter_Specification
,
13006 N_Component_Declaration
)
13010 -- The reference occurs within the constraint of a component,
13011 -- so it must be checked.
13013 elsif Nkind
(P
) = N_Component_Definition
then
13021 -- Stuff that happens only at the outer level
13023 if No
(Outer_Scope
) then
13024 Elab_Visited
.Set_Last
(0);
13026 -- Nothing to do if current scope is Standard (this is a bit odd, but
13027 -- it happens in the case of generic instantiations).
13029 C_Scope
:= Current_Scope
;
13031 if C_Scope
= Standard_Standard
then
13035 -- First case, we are in elaboration code
13037 From_Elab_Code
:= not In_Subprogram_Or_Concurrent_Unit
;
13039 if From_Elab_Code
then
13041 -- Complain if ref that comes from source in preelaborated unit
13042 -- and we are not inside a subprogram (i.e. we are in elab code).
13044 if Comes_From_Source
(N
)
13045 and then In_Preelaborated_Unit
13046 and then not In_Inlined_Body
13047 and then Nkind
(N
) /= N_Attribute_Reference
13049 -- This is a warning in GNAT mode allowing such calls to be
13050 -- used in the predefined library with appropriate care.
13052 Error_Msg_Warn
:= GNAT_Mode
;
13054 ("<<non-static call not allowed in preelaborated unit", N
);
13058 -- Second case, we are inside a subprogram or concurrent unit, which
13059 -- means we are not in elaboration code.
13062 -- In this case, the issue is whether we are inside the
13063 -- declarative part of the unit in which we live, or inside its
13064 -- statements. In the latter case, there is no issue of ABE calls
13065 -- at this level (a call from outside to the unit in which we live
13066 -- might cause an ABE, but that will be detected when we analyze
13067 -- that outer level call, as it recurses into the called unit).
13069 -- Climb up the tree, doing this test, and also testing for being
13070 -- inside a default expression, which, as discussed above, is not
13071 -- checked at this stage.
13080 -- If we find a parentless subtree, it seems safe to assume
13081 -- that we are not in a declarative part and that no
13082 -- checking is required.
13088 if Is_List_Member
(P
) then
13089 L
:= List_Containing
(P
);
13096 exit when Nkind
(P
) = N_Subunit
;
13098 -- Filter out case of default expressions, where we do not
13099 -- do the check at this stage.
13101 if Nkind_In
(P
, N_Parameter_Specification
,
13102 N_Component_Declaration
)
13107 -- A protected body has no elaboration code and contains
13108 -- only other bodies.
13110 if Nkind
(P
) = N_Protected_Body
then
13113 elsif Nkind_In
(P
, N_Subprogram_Body
,
13118 if L
= Declarations
(P
) then
13121 -- We are not in elaboration code, but we are doing
13122 -- dynamic elaboration checks, in this case, we still
13123 -- need to do the reference, since the subprogram we are
13124 -- in could be called from another unit, also in dynamic
13125 -- elaboration check mode, at elaboration time.
13127 elsif Dynamic_Elaboration_Checks
then
13129 -- We provide a debug flag to disable this check. That
13130 -- way we have an easy work around for regressions
13131 -- that are caused by this new check. This debug flag
13132 -- can be removed later.
13134 if Debug_Flag_DD
then
13138 -- Do the check in this case
13142 elsif Nkind
(P
) = N_Task_Body
then
13144 -- The check is deferred until Check_Task_Activation
13145 -- but we need to capture local suppress pragmas
13146 -- that may inhibit checks on this call.
13148 Ent
:= Get_Referenced_Ent
(N
);
13153 elsif Elaboration_Checks_Suppressed
(Current_Scope
)
13154 or else Elaboration_Checks_Suppressed
(Ent
)
13155 or else Elaboration_Checks_Suppressed
(Scope
(Ent
))
13157 if Nkind
(N
) in N_Subprogram_Call
then
13158 Set_No_Elaboration_Check
(N
);
13164 -- Static model, call is not in elaboration code, we
13165 -- never need to worry, because in the static model the
13166 -- top-level caller always takes care of things.
13177 Ent
:= Get_Referenced_Ent
(N
);
13183 -- Determine whether a prior call to the same subprogram was already
13184 -- examined within the same context. If this is the case, then there is
13185 -- no need to proceed with the various warnings and checks because the
13186 -- work was already done for the previous call.
13189 Self
: constant Visited_Element
:=
13190 (Subp_Id
=> Ent
, Context
=> Parent
(N
));
13193 for Index
in 1 .. Elab_Visited
.Last
loop
13194 if Self
= Elab_Visited
.Table
(Index
) then
13200 -- See if we need to analyze this reference. We analyze it if either of
13201 -- the following conditions is met:
13203 -- It is an inner level call (since in this case it was triggered
13204 -- by an outer level call from elaboration code), but only if the
13205 -- call is within the scope of the original outer level call.
13207 -- It is an outer level reference from elaboration code, or a call to
13208 -- an entity is in the same elaboration scope.
13210 -- And in these cases, we will check both inter-unit calls and
13211 -- intra-unit (within a single unit) calls.
13213 C_Scope
:= Current_Scope
;
13215 -- If not outer level reference, then we follow it if it is within the
13216 -- original scope of the outer reference.
13218 if Present
(Outer_Scope
)
13219 and then Within
(Scope
(Ent
), Outer_Scope
)
13225 Outer_Scope
=> Outer_Scope
,
13226 Inter_Unit_Only
=> False,
13227 In_Init_Proc
=> In_Init_Proc
);
13229 -- Nothing to do if elaboration checks suppressed for this scope.
13230 -- However, an interesting exception, the fact that elaboration checks
13231 -- are suppressed within an instance (because we can trace the body when
13232 -- we process the template) does not extend to calls to generic formal
13235 elsif Elaboration_Checks_Suppressed
(Current_Scope
)
13236 and then not Is_Call_Of_Generic_Formal
(N
)
13240 elsif From_Elab_Code
then
13242 Check_A_Call
(N
, Ent
, Standard_Standard
, Inter_Unit_Only
=> False);
13244 elsif Same_Elaboration_Scope
(C_Scope
, Scope
(Ent
)) then
13246 Check_A_Call
(N
, Ent
, Scope
(Ent
), Inter_Unit_Only
=> False);
13248 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode
13249 -- is set, then we will do the check, but only in the inter-unit case
13250 -- (this is to accommodate unguarded elaboration calls from other units
13251 -- in which this same mode is set). We don't want warnings in this case,
13252 -- it would generate warnings having nothing to do with elaboration.
13254 elsif Dynamic_Elaboration_Checks
then
13260 Inter_Unit_Only
=> True,
13261 Generate_Warnings
=> False);
13263 -- Otherwise nothing to do
13269 -- A call to an Init_Proc in elaboration code may bring additional
13270 -- dependencies, if some of the record components thereof have
13271 -- initializations that are function calls that come from source. We
13272 -- treat the current node as a call to each of these functions, to check
13273 -- their elaboration impact.
13275 if Is_Init_Proc
(Ent
) and then From_Elab_Code
then
13276 Process_Init_Proc
: declare
13277 Unit_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
13279 function Check_Init_Call
(Nod
: Node_Id
) return Traverse_Result
;
13280 -- Find subprogram calls within body of Init_Proc for Traverse
13281 -- instantiation below.
13283 procedure Traverse_Body
is new Traverse_Proc
(Check_Init_Call
);
13284 -- Traversal procedure to find all calls with body of Init_Proc
13286 ---------------------
13287 -- Check_Init_Call --
13288 ---------------------
13290 function Check_Init_Call
(Nod
: Node_Id
) return Traverse_Result
is
13294 if Nkind
(Nod
) in N_Subprogram_Call
13295 and then Is_Entity_Name
(Name
(Nod
))
13297 Func
:= Entity
(Name
(Nod
));
13299 if Comes_From_Source
(Func
) then
13301 (N
, Func
, Standard_Standard
, Inter_Unit_Only
=> True);
13309 end Check_Init_Call
;
13311 -- Start of processing for Process_Init_Proc
13314 if Nkind
(Unit_Decl
) = N_Subprogram_Body
then
13315 Traverse_Body
(Handled_Statement_Sequence
(Unit_Decl
));
13317 end Process_Init_Proc
;
13319 end Check_Elab_Call
;
13321 -----------------------
13322 -- Check_Elab_Assign --
13323 -----------------------
13325 procedure Check_Elab_Assign
(N
: Node_Id
) is
13329 Pkg_Spec
: Entity_Id
;
13330 Pkg_Body
: Entity_Id
;
13333 pragma Assert
(Legacy_Elaboration_Checks
);
13335 -- For record or array component, check prefix. If it is an access type,
13336 -- then there is nothing to do (we do not know what is being assigned),
13337 -- but otherwise this is an assignment to the prefix.
13339 if Nkind_In
(N
, N_Indexed_Component
,
13340 N_Selected_Component
,
13343 if not Is_Access_Type
(Etype
(Prefix
(N
))) then
13344 Check_Elab_Assign
(Prefix
(N
));
13350 -- For type conversion, check expression
13352 if Nkind
(N
) = N_Type_Conversion
then
13353 Check_Elab_Assign
(Expression
(N
));
13357 -- Nothing to do if this is not an entity reference otherwise get entity
13359 if Is_Entity_Name
(N
) then
13365 -- What we are looking for is a reference in the body of a package that
13366 -- modifies a variable declared in the visible part of the package spec.
13369 and then Comes_From_Source
(N
)
13370 and then not Suppress_Elaboration_Warnings
(Ent
)
13371 and then Ekind
(Ent
) = E_Variable
13372 and then not In_Private_Part
(Ent
)
13373 and then Is_Library_Level_Entity
(Ent
)
13375 Scop
:= Current_Scope
;
13377 if No
(Scop
) or else Scop
= Standard_Standard
then
13379 elsif Ekind
(Scop
) = E_Package
13380 and then Is_Compilation_Unit
(Scop
)
13384 Scop
:= Scope
(Scop
);
13388 -- Here Scop points to the containing library package
13391 Pkg_Body
:= Body_Entity
(Pkg_Spec
);
13393 -- All OK if the package has an Elaborate_Body pragma
13395 if Has_Pragma_Elaborate_Body
(Scop
) then
13399 -- OK if entity being modified is not in containing package spec
13401 if not In_Same_Source_Unit
(Scop
, Ent
) then
13405 -- All OK if entity appears in generic package or generic instance.
13406 -- We just get too messed up trying to give proper warnings in the
13407 -- presence of generics. Better no message than a junk one.
13409 Scop
:= Scope
(Ent
);
13410 while Present
(Scop
) and then Scop
/= Pkg_Spec
loop
13411 if Ekind
(Scop
) = E_Generic_Package
then
13413 elsif Ekind
(Scop
) = E_Package
13414 and then Is_Generic_Instance
(Scop
)
13419 Scop
:= Scope
(Scop
);
13422 -- All OK if in task, don't issue warnings there
13424 if In_Task_Activation
then
13428 -- OK if no package body
13430 if No
(Pkg_Body
) then
13434 -- OK if reference is not in package body
13436 if not In_Same_Source_Unit
(Pkg_Body
, N
) then
13440 -- OK if package body has no handled statement sequence
13443 HSS
: constant Node_Id
:=
13444 Handled_Statement_Sequence
(Declaration_Node
(Pkg_Body
));
13446 if No
(HSS
) or else not Comes_From_Source
(HSS
) then
13451 -- We definitely have a case of a modification of an entity in
13452 -- the package spec from the elaboration code of the package body.
13453 -- We may not give the warning (because there are some additional
13454 -- checks to avoid too many false positives), but it would be a good
13455 -- idea for the binder to try to keep the body elaboration close to
13456 -- the spec elaboration.
13458 Set_Elaborate_Body_Desirable
(Pkg_Spec
);
13460 -- All OK in gnat mode (we know what we are doing)
13466 -- All OK if all warnings suppressed
13468 if Warning_Mode
= Suppress
then
13472 -- All OK if elaboration checks suppressed for entity
13474 if Checks_May_Be_Suppressed
(Ent
)
13475 and then Is_Check_Suppressed
(Ent
, Elaboration_Check
)
13480 -- OK if the entity is initialized. Note that the No_Initialization
13481 -- flag usually means that the initialization has been rewritten into
13482 -- assignments, but that still counts for us.
13485 Decl
: constant Node_Id
:= Declaration_Node
(Ent
);
13487 if Nkind
(Decl
) = N_Object_Declaration
13488 and then (Present
(Expression
(Decl
))
13489 or else No_Initialization
(Decl
))
13495 -- Here is where we give the warning
13497 -- All OK if warnings suppressed on the entity
13499 if not Has_Warnings_Off
(Ent
) then
13500 Error_Msg_Sloc
:= Sloc
(Ent
);
13503 ("??& can be accessed by clients before this initialization",
13506 ("\??add Elaborate_Body to spec to ensure & is initialized",
13510 if not All_Errors_Mode
then
13511 Set_Suppress_Elaboration_Warnings
(Ent
);
13514 end Check_Elab_Assign
;
13516 ----------------------
13517 -- Check_Elab_Calls --
13518 ----------------------
13520 -- WARNING: This routine manages SPARK regions
13522 procedure Check_Elab_Calls
is
13523 Saved_SM
: SPARK_Mode_Type
;
13524 Saved_SMP
: Node_Id
;
13527 pragma Assert
(Legacy_Elaboration_Checks
);
13529 -- If expansion is disabled, do not generate any checks, unless we
13530 -- are in GNATprove mode, so that errors are issued in GNATprove for
13531 -- violations of static elaboration rules in SPARK code. Also skip
13532 -- checks if any subunits are missing because in either case we lack the
13533 -- full information that we need, and no object file will be created in
13536 if (not Expander_Active
and not GNATprove_Mode
)
13537 or else Is_Generic_Unit
(Cunit_Entity
(Main_Unit
))
13538 or else Subunits_Missing
13543 -- Skip delayed calls if we had any errors
13545 if Serious_Errors_Detected
= 0 then
13546 Delaying_Elab_Checks
:= False;
13547 Expander_Mode_Save_And_Set
(True);
13549 for J
in Delay_Check
.First
.. Delay_Check
.Last
loop
13550 Push_Scope
(Delay_Check
.Table
(J
).Curscop
);
13551 From_Elab_Code
:= Delay_Check
.Table
(J
).From_Elab_Code
;
13552 In_Task_Activation
:= Delay_Check
.Table
(J
).In_Task_Activation
;
13554 Saved_SM
:= SPARK_Mode
;
13555 Saved_SMP
:= SPARK_Mode_Pragma
;
13557 -- Set appropriate value of SPARK_Mode
13559 if Delay_Check
.Table
(J
).From_SPARK_Code
then
13563 Check_Internal_Call_Continue
13564 (N
=> Delay_Check
.Table
(J
).N
,
13565 E
=> Delay_Check
.Table
(J
).E
,
13566 Outer_Scope
=> Delay_Check
.Table
(J
).Outer_Scope
,
13567 Orig_Ent
=> Delay_Check
.Table
(J
).Orig_Ent
);
13569 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
13573 -- Set Delaying_Elab_Checks back on for next main compilation
13575 Expander_Mode_Restore
;
13576 Delaying_Elab_Checks
:= True;
13578 end Check_Elab_Calls
;
13580 ------------------------------
13581 -- Check_Elab_Instantiation --
13582 ------------------------------
13584 procedure Check_Elab_Instantiation
13586 Outer_Scope
: Entity_Id
:= Empty
)
13591 pragma Assert
(Legacy_Elaboration_Checks
);
13593 -- Check for and deal with bad instantiation case. There is some
13594 -- duplicated code here, but we will worry about this later ???
13596 Check_Bad_Instantiation
(N
);
13598 if Is_Known_Guaranteed_ABE
(N
) then
13602 -- Nothing to do if we do not have an instantiation (happens in some
13603 -- error cases, and also in the formal package declaration case)
13605 if Nkind
(N
) not in N_Generic_Instantiation
then
13609 -- Nothing to do if inside a generic template
13611 if Inside_A_Generic
then
13615 -- Nothing to do if the instantiation is not in the main unit
13617 if not In_Extended_Main_Code_Unit
(N
) then
13621 Ent
:= Get_Generic_Entity
(N
);
13622 From_Elab_Code
:= not In_Subprogram_Or_Concurrent_Unit
;
13624 -- See if we need to analyze this instantiation. We analyze it if
13625 -- either of the following conditions is met:
13627 -- It is an inner level instantiation (since in this case it was
13628 -- triggered by an outer level call from elaboration code), but
13629 -- only if the instantiation is within the scope of the original
13630 -- outer level call.
13632 -- It is an outer level instantiation from elaboration code, or the
13633 -- instantiated entity is in the same elaboration scope.
13635 -- And in these cases, we will check both the inter-unit case and
13636 -- the intra-unit (within a single unit) case.
13638 C_Scope
:= Current_Scope
;
13640 if Present
(Outer_Scope
) and then Within
(Scope
(Ent
), Outer_Scope
) then
13642 Check_A_Call
(N
, Ent
, Outer_Scope
, Inter_Unit_Only
=> False);
13644 elsif From_Elab_Code
then
13646 Check_A_Call
(N
, Ent
, Standard_Standard
, Inter_Unit_Only
=> False);
13648 elsif Same_Elaboration_Scope
(C_Scope
, Scope
(Ent
)) then
13650 Check_A_Call
(N
, Ent
, Scope
(Ent
), Inter_Unit_Only
=> False);
13652 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is
13653 -- set, then we will do the check, but only in the inter-unit case (this
13654 -- is to accommodate unguarded elaboration calls from other units in
13655 -- which this same mode is set). We inhibit warnings in this case, since
13656 -- this instantiation is not occurring in elaboration code.
13658 elsif Dynamic_Elaboration_Checks
then
13664 Inter_Unit_Only
=> True,
13665 Generate_Warnings
=> False);
13670 end Check_Elab_Instantiation
;
13672 -------------------------
13673 -- Check_Internal_Call --
13674 -------------------------
13676 procedure Check_Internal_Call
13679 Outer_Scope
: Entity_Id
;
13680 Orig_Ent
: Entity_Id
)
13682 function Within_Initial_Condition
(Call
: Node_Id
) return Boolean;
13683 -- Determine whether call Call occurs within pragma Initial_Condition or
13684 -- pragma Check with check_kind set to Initial_Condition.
13686 ------------------------------
13687 -- Within_Initial_Condition --
13688 ------------------------------
13690 function Within_Initial_Condition
(Call
: Node_Id
) return Boolean is
13696 -- Traverse the parent chain looking for an enclosing pragma
13699 while Present
(Par
) loop
13700 if Nkind
(Par
) = N_Pragma
then
13701 Nam
:= Pragma_Name
(Par
);
13703 -- Pragma Initial_Condition appears in its alternative from as
13704 -- Check (Initial_Condition, ...).
13706 if Nam
= Name_Check
then
13707 Args
:= Pragma_Argument_Associations
(Par
);
13709 -- Pragma Check should have at least two arguments
13711 pragma Assert
(Present
(Args
));
13714 Chars
(Expression
(First
(Args
))) = Name_Initial_Condition
;
13718 elsif Nam
= Name_Initial_Condition
then
13721 -- Since pragmas are never nested within other pragmas, stop
13728 -- Prevent the search from going too far
13730 elsif Is_Body_Or_Package_Declaration
(Par
) then
13734 Par
:= Parent
(Par
);
13736 -- If assertions are not enabled, the check pragma is rewritten
13737 -- as an if_statement in sem_prag, to generate various warnings
13738 -- on boolean expressions. Retrieve the original pragma.
13740 if Nkind
(Original_Node
(Par
)) = N_Pragma
then
13741 Par
:= Original_Node
(Par
);
13746 end Within_Initial_Condition
;
13750 Inst_Case
: constant Boolean := Nkind
(N
) in N_Generic_Instantiation
;
13752 -- Start of processing for Check_Internal_Call
13755 -- For P'Access, we want to warn if the -gnatw.f switch is set, and the
13756 -- node comes from source.
13758 if Nkind
(N
) = N_Attribute_Reference
13759 and then ((not Warn_On_Elab_Access
and then not Debug_Flag_Dot_O
)
13760 or else not Comes_From_Source
(N
))
13764 -- If not function or procedure call, instantiation, or 'Access, then
13765 -- ignore call (this happens in some error cases and rewriting cases).
13767 elsif not Nkind_In
(N
, N_Attribute_Reference
,
13769 N_Procedure_Call_Statement
)
13770 and then not Inst_Case
13774 -- Nothing to do if this is a call or instantiation that has already
13775 -- been found to be a sure ABE.
13777 elsif Nkind
(N
) /= N_Attribute_Reference
13778 and then Is_Known_Guaranteed_ABE
(N
)
13782 -- Nothing to do if errors already detected (avoid cascaded errors)
13784 elsif Serious_Errors_Detected
/= 0 then
13787 -- Nothing to do if not in full analysis mode
13789 elsif not Full_Analysis
then
13792 -- Nothing to do if analyzing in special spec-expression mode, since the
13793 -- call is not actually being made at this time.
13795 elsif In_Spec_Expression
then
13798 -- Nothing to do for call to intrinsic subprogram
13800 elsif Is_Intrinsic_Subprogram
(E
) then
13803 -- Nothing to do if call is within a generic unit
13805 elsif Inside_A_Generic
then
13808 -- Nothing to do when the call appears within pragma Initial_Condition.
13809 -- The pragma is part of the elaboration statements of a package body
13810 -- and may only call external subprograms or subprograms whose body is
13811 -- already available.
13813 elsif Within_Initial_Condition
(N
) then
13817 -- Delay this call if we are still delaying calls
13819 if Delaying_Elab_Checks
then
13823 Orig_Ent
=> Orig_Ent
,
13824 Curscop
=> Current_Scope
,
13825 Outer_Scope
=> Outer_Scope
,
13826 From_Elab_Code
=> From_Elab_Code
,
13827 In_Task_Activation
=> In_Task_Activation
,
13828 From_SPARK_Code
=> SPARK_Mode
= On
));
13831 -- Otherwise, call phase 2 continuation right now
13834 Check_Internal_Call_Continue
(N
, E
, Outer_Scope
, Orig_Ent
);
13836 end Check_Internal_Call
;
13838 ----------------------------------
13839 -- Check_Internal_Call_Continue --
13840 ----------------------------------
13842 procedure Check_Internal_Call_Continue
13845 Outer_Scope
: Entity_Id
;
13846 Orig_Ent
: Entity_Id
)
13848 function Find_Elab_Reference
(N
: Node_Id
) return Traverse_Result
;
13849 -- Function applied to each node as we traverse the body. Checks for
13850 -- call or entity reference that needs checking, and if so checks it.
13851 -- Always returns OK, so entire tree is traversed, except that as
13852 -- described below subprogram bodies are skipped for now.
13854 procedure Traverse
is new Atree
.Traverse_Proc
(Find_Elab_Reference
);
13855 -- Traverse procedure using above Find_Elab_Reference function
13857 -------------------------
13858 -- Find_Elab_Reference --
13859 -------------------------
13861 function Find_Elab_Reference
(N
: Node_Id
) return Traverse_Result
is
13865 -- If user has specified that there are no entry calls in elaboration
13866 -- code, do not trace past an accept statement, because the rendez-
13867 -- vous will happen after elaboration.
13869 if Nkind_In
(Original_Node
(N
), N_Accept_Statement
,
13870 N_Selective_Accept
)
13871 and then Restriction_Active
(No_Entry_Calls_In_Elaboration_Code
)
13875 -- If we have a function call, check it
13877 elsif Nkind
(N
) = N_Function_Call
then
13878 Check_Elab_Call
(N
, Outer_Scope
);
13881 -- If we have a procedure call, check the call, and also check
13882 -- arguments that are assignments (OUT or IN OUT mode formals).
13884 elsif Nkind
(N
) = N_Procedure_Call_Statement
then
13885 Check_Elab_Call
(N
, Outer_Scope
, In_Init_Proc
=> Is_Init_Proc
(E
));
13887 Actual
:= First_Actual
(N
);
13888 while Present
(Actual
) loop
13889 if Known_To_Be_Assigned
(Actual
) then
13890 Check_Elab_Assign
(Actual
);
13893 Next_Actual
(Actual
);
13898 -- If we have an access attribute for a subprogram, check it.
13899 -- Suppress this behavior under debug flag.
13901 elsif not Debug_Flag_Dot_UU
13902 and then Nkind
(N
) = N_Attribute_Reference
13903 and then Nam_In
(Attribute_Name
(N
), Name_Access
,
13904 Name_Unrestricted_Access
)
13905 and then Is_Entity_Name
(Prefix
(N
))
13906 and then Is_Subprogram
(Entity
(Prefix
(N
)))
13908 Check_Elab_Call
(N
, Outer_Scope
);
13911 -- In SPARK mode, if we have an entity reference to a variable, then
13912 -- check it. For now we consider any reference.
13914 elsif SPARK_Mode
= On
13915 and then Nkind
(N
) in N_Has_Entity
13916 and then Present
(Entity
(N
))
13917 and then Ekind
(Entity
(N
)) = E_Variable
13919 Check_Elab_Call
(N
, Outer_Scope
);
13922 -- If we have a generic instantiation, check it
13924 elsif Nkind
(N
) in N_Generic_Instantiation
then
13925 Check_Elab_Instantiation
(N
, Outer_Scope
);
13928 -- Skip subprogram bodies that come from source (wait for call to
13929 -- analyze these). The reason for the come from source test is to
13930 -- avoid catching task bodies.
13932 -- For task bodies, we should really avoid these too, waiting for the
13933 -- task activation, but that's too much trouble to catch for now, so
13934 -- we go in unconditionally. This is not so terrible, it means the
13935 -- error backtrace is not quite complete, and we are too eager to
13936 -- scan bodies of tasks that are unused, but this is hardly very
13939 elsif Nkind
(N
) = N_Subprogram_Body
13940 and then Comes_From_Source
(N
)
13944 elsif Nkind
(N
) = N_Assignment_Statement
13945 and then Comes_From_Source
(N
)
13947 Check_Elab_Assign
(Name
(N
));
13953 end Find_Elab_Reference
;
13955 Inst_Case
: constant Boolean := Is_Generic_Unit
(E
);
13956 Loc
: constant Source_Ptr
:= Sloc
(N
);
13961 -- Start of processing for Check_Internal_Call_Continue
13964 -- Save outer level call if at outer level
13966 if Elab_Call
.Last
= 0 then
13967 Outer_Level_Sloc
:= Loc
;
13970 -- If the call is to a function that renames a literal, no check needed
13972 if Ekind
(E
) = E_Enumeration_Literal
then
13976 -- Register the subprogram as examined within this particular context.
13977 -- This ensures that calls to the same subprogram but in different
13978 -- contexts receive warnings and checks of their own since the calls
13979 -- may be reached through different flow paths.
13981 Elab_Visited
.Append
((Subp_Id
=> E
, Context
=> Parent
(N
)));
13983 Sbody
:= Unit_Declaration_Node
(E
);
13985 if not Nkind_In
(Sbody
, N_Subprogram_Body
, N_Package_Body
) then
13986 Ebody
:= Corresponding_Body
(Sbody
);
13991 Sbody
:= Unit_Declaration_Node
(Ebody
);
13995 -- If the body appears after the outer level call or instantiation then
13996 -- we have an error case handled below.
13998 if Earlier_In_Extended_Unit
(Outer_Level_Sloc
, Sloc
(Sbody
))
13999 and then not In_Task_Activation
14003 -- If we have the instantiation case we are done, since we now know that
14004 -- the body of the generic appeared earlier.
14006 elsif Inst_Case
then
14009 -- Otherwise we have a call, so we trace through the called body to see
14010 -- if it has any problems.
14013 pragma Assert
(Nkind
(Sbody
) = N_Subprogram_Body
);
14015 Elab_Call
.Append
((Cloc
=> Loc
, Ent
=> E
));
14017 if Debug_Flag_Underscore_LL
then
14018 Write_Str
("Elab_Call.Last = ");
14019 Write_Int
(Int
(Elab_Call
.Last
));
14020 Write_Str
(" Ent = ");
14021 Write_Name
(Chars
(E
));
14022 Write_Str
(" at ");
14023 Write_Location
(Sloc
(N
));
14027 -- Now traverse declarations and statements of subprogram body. Note
14028 -- that we cannot simply Traverse (Sbody), since traverse does not
14029 -- normally visit subprogram bodies.
14034 Decl
:= First
(Declarations
(Sbody
));
14035 while Present
(Decl
) loop
14041 Traverse
(Handled_Statement_Sequence
(Sbody
));
14043 Elab_Call
.Decrement_Last
;
14047 -- Here is the case of calling a subprogram where the body has not yet
14048 -- been encountered. A warning message is needed, except if this is the
14049 -- case of appearing within an aspect specification that results in
14050 -- a check call, we do not really have such a situation, so no warning
14051 -- is needed (e.g. the case of a precondition, where the call appears
14052 -- textually before the body, but in actual fact is moved to the
14053 -- appropriate subprogram body and so does not need a check).
14062 -- Keep looking at parents if we are still in the subexpression
14064 if Nkind
(P
) in N_Subexpr
then
14067 -- Here P is the parent of the expression, check for special case
14070 O
:= Original_Node
(P
);
14072 -- Definitely not the special case if orig node is not a pragma
14074 exit when Nkind
(O
) /= N_Pragma
;
14076 -- Check we have an If statement or a null statement (happens
14077 -- when the If has been expanded to be True).
14079 exit when not Nkind_In
(P
, N_If_Statement
, N_Null_Statement
);
14081 -- Our special case will be indicated either by the pragma
14082 -- coming from an aspect ...
14084 if Present
(Corresponding_Aspect
(O
)) then
14087 -- Or, in the case of an initial condition, specifically by a
14088 -- Check pragma specifying an Initial_Condition check.
14090 elsif Pragma_Name
(O
) = Name_Check
14093 (Expression
(First
(Pragma_Argument_Associations
(O
)))) =
14094 Name_Initial_Condition
14098 -- For anything else, we have an error
14107 -- Not that special case, warning and dynamic check is required
14109 -- If we have nothing in the call stack, then this is at the outer
14110 -- level, and the ABE is bound to occur, unless it's a 'Access, or
14111 -- it's a renaming.
14113 if Elab_Call
.Last
= 0 then
14114 Error_Msg_Warn
:= SPARK_Mode
/= On
;
14117 Insert_Check
: Boolean := True;
14118 -- This flag is set to True if an elaboration check should be
14122 if In_Task_Activation
then
14123 Insert_Check
:= False;
14125 elsif Inst_Case
then
14127 ("cannot instantiate& before body seen<<", N
, Orig_Ent
);
14129 elsif Nkind
(N
) = N_Attribute_Reference
then
14131 ("Access attribute of & before body seen<<", N
, Orig_Ent
);
14132 Error_Msg_N
("\possible Program_Error on later references<", N
);
14133 Insert_Check
:= False;
14135 elsif Nkind
(Unit_Declaration_Node
(Orig_Ent
)) /=
14136 N_Subprogram_Renaming_Declaration
14139 ("cannot call& before body seen<<", N
, Orig_Ent
);
14141 elsif not Is_Generic_Actual_Subprogram
(Orig_Ent
) then
14142 Insert_Check
:= False;
14145 if Insert_Check
then
14146 Error_Msg_N
("\Program_Error [<<", N
);
14147 Insert_Elab_Check
(N
);
14151 -- Call is not at outer level
14154 -- Do not generate elaboration checks in GNATprove mode because the
14155 -- elaboration counter and the check are both forms of expansion.
14157 if GNATprove_Mode
then
14160 -- Generate an elaboration check
14162 elsif not Elaboration_Checks_Suppressed
(E
) then
14163 Set_Elaboration_Entity_Required
(E
);
14165 -- Create a declaration of the elaboration entity, and insert it
14166 -- prior to the subprogram or the generic unit, within the same
14167 -- scope. Since the subprogram may be overloaded, create a unique
14170 if No
(Elaboration_Entity
(E
)) then
14172 Loce
: constant Source_Ptr
:= Sloc
(E
);
14173 Ent
: constant Entity_Id
:=
14174 Make_Defining_Identifier
(Loc
,
14175 New_External_Name
(Chars
(E
), 'E', -1));
14178 Set_Elaboration_Entity
(E
, Ent
);
14179 Push_Scope
(Scope
(E
));
14181 Insert_Action
(Declaration_Node
(E
),
14182 Make_Object_Declaration
(Loce
,
14183 Defining_Identifier
=> Ent
,
14184 Object_Definition
=>
14185 New_Occurrence_Of
(Standard_Short_Integer
, Loce
),
14187 Make_Integer_Literal
(Loc
, Uint_0
)));
14189 -- Set elaboration flag at the point of the body
14191 Set_Elaboration_Flag
(Sbody
, E
);
14193 -- Kill current value indication. This is necessary because
14194 -- the tests of this flag are inserted out of sequence and
14195 -- must not pick up bogus indications of the wrong constant
14196 -- value. Also, this is never a true constant, since one way
14197 -- or another, it gets reset.
14199 Set_Current_Value
(Ent
, Empty
);
14200 Set_Last_Assignment
(Ent
, Empty
);
14201 Set_Is_True_Constant
(Ent
, False);
14208 -- raise Program_Error with "access before elaboration";
14211 Insert_Elab_Check
(N
,
14212 Make_Attribute_Reference
(Loc
,
14213 Attribute_Name
=> Name_Elaborated
,
14214 Prefix
=> New_Occurrence_Of
(E
, Loc
)));
14217 -- Generate the warning
14219 if not Suppress_Elaboration_Warnings
(E
)
14220 and then not Elaboration_Checks_Suppressed
(E
)
14222 -- Suppress this warning if we have a function call that occurred
14223 -- within an assertion expression, since we can get false warnings
14224 -- in this case, due to the out of order handling in this case.
14227 (Nkind
(Original_Node
(N
)) /= N_Function_Call
14228 or else not In_Assertion_Expression_Pragma
(Original_Node
(N
)))
14230 Error_Msg_Warn
:= SPARK_Mode
/= On
;
14234 ("instantiation of& may occur before body is seen<l<",
14237 -- A rather specific check. For Finalize/Adjust/Initialize, if
14238 -- the type has Warnings_Off set, suppress the warning.
14240 if Nam_In
(Chars
(E
), Name_Adjust
,
14243 and then Present
(First_Formal
(E
))
14246 T
: constant Entity_Id
:= Etype
(First_Formal
(E
));
14248 if Is_Controlled
(T
) then
14249 if Warnings_Off
(T
)
14250 or else (Ekind
(T
) = E_Private_Type
14251 and then Warnings_Off
(Full_View
(T
)))
14259 -- Go ahead and give warning if not this special case
14262 ("call to& may occur before body is seen<l<", N
, Orig_Ent
);
14265 Error_Msg_N
("\Program_Error ]<l<", N
);
14267 -- There is no need to query the elaboration warning message flags
14268 -- because the main message is an error, not a warning, therefore
14269 -- all the clarification messages produces by Output_Calls must be
14270 -- emitted unconditionally.
14274 Output_Calls
(N
, Check_Elab_Flag
=> False);
14277 end Check_Internal_Call_Continue
;
14279 ---------------------------
14280 -- Check_Task_Activation --
14281 ---------------------------
14283 procedure Check_Task_Activation
(N
: Node_Id
) is
14284 Loc
: constant Source_Ptr
:= Sloc
(N
);
14285 Inter_Procs
: constant Elist_Id
:= New_Elmt_List
;
14286 Intra_Procs
: constant Elist_Id
:= New_Elmt_List
;
14289 Task_Scope
: Entity_Id
;
14290 Cunit_SC
: Boolean := False;
14293 Enclosing
: Entity_Id
;
14295 procedure Add_Task_Proc
(Typ
: Entity_Id
);
14296 -- Add to Task_Procs the task body procedure(s) of task types in Typ.
14297 -- For record types, this procedure recurses over component types.
14299 procedure Collect_Tasks
(Decls
: List_Id
);
14300 -- Collect the types of the tasks that are to be activated in the given
14301 -- list of declarations, in order to perform elaboration checks on the
14302 -- corresponding task procedures that are called implicitly here.
14304 function Outer_Unit
(E
: Entity_Id
) return Entity_Id
;
14305 -- find enclosing compilation unit of Entity, ignoring subunits, or
14306 -- else enclosing subprogram. If E is not a package, there is no need
14307 -- for inter-unit elaboration checks.
14309 -------------------
14310 -- Add_Task_Proc --
14311 -------------------
14313 procedure Add_Task_Proc
(Typ
: Entity_Id
) is
14315 Proc
: Entity_Id
:= Empty
;
14318 if Is_Task_Type
(Typ
) then
14319 Proc
:= Get_Task_Body_Procedure
(Typ
);
14321 elsif Is_Array_Type
(Typ
)
14322 and then Has_Task
(Base_Type
(Typ
))
14324 Add_Task_Proc
(Component_Type
(Typ
));
14326 elsif Is_Record_Type
(Typ
)
14327 and then Has_Task
(Base_Type
(Typ
))
14329 Comp
:= First_Component
(Typ
);
14330 while Present
(Comp
) loop
14331 Add_Task_Proc
(Etype
(Comp
));
14332 Comp
:= Next_Component
(Comp
);
14336 -- If the task type is another unit, we will perform the usual
14337 -- elaboration check on its enclosing unit. If the type is in the
14338 -- same unit, we can trace the task body as for an internal call,
14339 -- but we only need to examine other external calls, because at
14340 -- the point the task is activated, internal subprogram bodies
14341 -- will have been elaborated already. We keep separate lists for
14342 -- each kind of task.
14344 -- Skip this test if errors have occurred, since in this case
14345 -- we can get false indications.
14347 if Serious_Errors_Detected
/= 0 then
14351 if Present
(Proc
) then
14352 if Outer_Unit
(Scope
(Proc
)) = Enclosing
then
14354 if No
(Corresponding_Body
(Unit_Declaration_Node
(Proc
)))
14356 (not Is_Generic_Instance
(Scope
(Proc
))
14357 or else Scope
(Proc
) = Scope
(Defining_Identifier
(Decl
)))
14359 Error_Msg_Warn
:= SPARK_Mode
/= On
;
14361 ("task will be activated before elaboration of its body<<",
14363 Error_Msg_N
("\Program_Error [<<", Decl
);
14366 (Corresponding_Body
(Unit_Declaration_Node
(Proc
)))
14368 Append_Elmt
(Proc
, Intra_Procs
);
14372 -- No need for multiple entries of the same type
14374 Elmt
:= First_Elmt
(Inter_Procs
);
14375 while Present
(Elmt
) loop
14376 if Node
(Elmt
) = Proc
then
14383 Append_Elmt
(Proc
, Inter_Procs
);
14388 -------------------
14389 -- Collect_Tasks --
14390 -------------------
14392 procedure Collect_Tasks
(Decls
: List_Id
) is
14394 if Present
(Decls
) then
14395 Decl
:= First
(Decls
);
14396 while Present
(Decl
) loop
14397 if Nkind
(Decl
) = N_Object_Declaration
14398 and then Has_Task
(Etype
(Defining_Identifier
(Decl
)))
14400 Add_Task_Proc
(Etype
(Defining_Identifier
(Decl
)));
14412 function Outer_Unit
(E
: Entity_Id
) return Entity_Id
is
14417 while Present
(Outer
) loop
14418 if Elaboration_Checks_Suppressed
(Outer
) then
14422 exit when Is_Child_Unit
(Outer
)
14423 or else Scope
(Outer
) = Standard_Standard
14424 or else Ekind
(Outer
) /= E_Package
;
14425 Outer
:= Scope
(Outer
);
14431 -- Start of processing for Check_Task_Activation
14434 pragma Assert
(Legacy_Elaboration_Checks
);
14436 Enclosing
:= Outer_Unit
(Current_Scope
);
14438 -- Find all tasks declared in the current unit
14440 if Nkind
(N
) = N_Package_Body
then
14441 P
:= Unit_Declaration_Node
(Corresponding_Spec
(N
));
14443 Collect_Tasks
(Declarations
(N
));
14444 Collect_Tasks
(Visible_Declarations
(Specification
(P
)));
14445 Collect_Tasks
(Private_Declarations
(Specification
(P
)));
14447 elsif Nkind
(N
) = N_Package_Declaration
then
14448 Collect_Tasks
(Visible_Declarations
(Specification
(N
)));
14449 Collect_Tasks
(Private_Declarations
(Specification
(N
)));
14452 Collect_Tasks
(Declarations
(N
));
14455 -- We only perform detailed checks in all tasks that are library level
14456 -- entities. If the master is a subprogram or task, activation will
14457 -- depend on the activation of the master itself.
14459 -- Should dynamic checks be added in the more general case???
14461 if Ekind
(Enclosing
) /= E_Package
then
14465 -- For task types defined in other units, we want the unit containing
14466 -- the task body to be elaborated before the current one.
14468 Elmt
:= First_Elmt
(Inter_Procs
);
14469 while Present
(Elmt
) loop
14470 Ent
:= Node
(Elmt
);
14471 Task_Scope
:= Outer_Unit
(Scope
(Ent
));
14473 if not Is_Compilation_Unit
(Task_Scope
) then
14476 elsif Suppress_Elaboration_Warnings
(Task_Scope
)
14477 or else Elaboration_Checks_Suppressed
(Task_Scope
)
14481 elsif Dynamic_Elaboration_Checks
then
14482 if not Elaboration_Checks_Suppressed
(Ent
)
14483 and then not Cunit_SC
14484 and then not Restriction_Active
14485 (No_Entry_Calls_In_Elaboration_Code
)
14487 -- Runtime elaboration check required. Generate check of the
14488 -- elaboration counter for the unit containing the entity.
14490 Insert_Elab_Check
(N
,
14491 Make_Attribute_Reference
(Loc
,
14493 New_Occurrence_Of
(Spec_Entity
(Task_Scope
), Loc
),
14494 Attribute_Name
=> Name_Elaborated
));
14498 -- Force the binder to elaborate other unit first
14500 if Elab_Info_Messages
14501 and then not Suppress_Elaboration_Warnings
(Ent
)
14502 and then not Elaboration_Checks_Suppressed
(Ent
)
14503 and then not Suppress_Elaboration_Warnings
(Task_Scope
)
14504 and then not Elaboration_Checks_Suppressed
(Task_Scope
)
14506 Error_Msg_Node_2
:= Task_Scope
;
14508 ("info: activation of an instance of task type & requires "
14509 & "pragma Elaborate_All on &?$?", N
, Ent
);
14512 Activate_Elaborate_All_Desirable
(N
, Task_Scope
);
14513 Set_Suppress_Elaboration_Warnings
(Task_Scope
);
14519 -- For tasks declared in the current unit, trace other calls within the
14520 -- task procedure bodies, which are available.
14522 if not Debug_Flag_Dot_Y
then
14523 In_Task_Activation
:= True;
14525 Elmt
:= First_Elmt
(Intra_Procs
);
14526 while Present
(Elmt
) loop
14527 Ent
:= Node
(Elmt
);
14528 Check_Internal_Call_Continue
(N
, Ent
, Enclosing
, Ent
);
14532 In_Task_Activation
:= False;
14534 end Check_Task_Activation
;
14536 ------------------------
14537 -- Get_Referenced_Ent --
14538 ------------------------
14540 function Get_Referenced_Ent
(N
: Node_Id
) return Entity_Id
is
14544 if Nkind
(N
) in N_Has_Entity
14545 and then Present
(Entity
(N
))
14546 and then Ekind
(Entity
(N
)) = E_Variable
14551 if Nkind
(N
) = N_Attribute_Reference
then
14559 elsif Nkind
(Nam
) = N_Selected_Component
then
14560 return Entity
(Selector_Name
(Nam
));
14561 elsif not Is_Entity_Name
(Nam
) then
14564 return Entity
(Nam
);
14566 end Get_Referenced_Ent
;
14568 ----------------------
14569 -- Has_Generic_Body --
14570 ----------------------
14572 function Has_Generic_Body
(N
: Node_Id
) return Boolean is
14573 Ent
: constant Entity_Id
:= Get_Generic_Entity
(N
);
14574 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
14577 function Find_Body_In
(E
: Entity_Id
; N
: Node_Id
) return Node_Id
;
14578 -- Determine if the list of nodes headed by N and linked by Next
14579 -- contains a package body for the package spec entity E, and if so
14580 -- return the package body. If not, then returns Empty.
14582 function Load_Package_Body
(Nam
: Unit_Name_Type
) return Node_Id
;
14583 -- This procedure is called load the unit whose name is given by Nam.
14584 -- This unit is being loaded to see whether it contains an optional
14585 -- generic body. The returned value is the loaded unit, which is always
14586 -- a package body (only package bodies can contain other entities in the
14587 -- sense in which Has_Generic_Body is interested). We only attempt to
14588 -- load bodies if we are generating code. If we are in semantics check
14589 -- only mode, then it would be wrong to load bodies that are not
14590 -- required from a semantic point of view, so in this case we return
14591 -- Empty. The result is that the caller may incorrectly decide that a
14592 -- generic spec does not have a body when in fact it does, but the only
14593 -- harm in this is that some warnings on elaboration problems may be
14594 -- lost in semantic checks only mode, which is not big loss. We also
14595 -- return Empty if we go for a body and it is not there.
14597 function Locate_Corresponding_Body
(PE
: Entity_Id
) return Node_Id
;
14598 -- PE is the entity for a package spec. This function locates the
14599 -- corresponding package body, returning Empty if none is found. The
14600 -- package body returned is fully parsed but may not yet be analyzed,
14601 -- so only syntactic fields should be referenced.
14607 function Find_Body_In
(E
: Entity_Id
; N
: Node_Id
) return Node_Id
is
14612 while Present
(Nod
) loop
14614 -- If we found the package body we are looking for, return it
14616 if Nkind
(Nod
) = N_Package_Body
14617 and then Chars
(Defining_Unit_Name
(Nod
)) = Chars
(E
)
14621 -- If we found the stub for the body, go after the subunit,
14622 -- loading it if necessary.
14624 elsif Nkind
(Nod
) = N_Package_Body_Stub
14625 and then Chars
(Defining_Identifier
(Nod
)) = Chars
(E
)
14627 if Present
(Library_Unit
(Nod
)) then
14628 return Unit
(Library_Unit
(Nod
));
14631 return Load_Package_Body
(Get_Unit_Name
(Nod
));
14634 -- If neither package body nor stub, keep looking on chain
14644 -----------------------
14645 -- Load_Package_Body --
14646 -----------------------
14648 function Load_Package_Body
(Nam
: Unit_Name_Type
) return Node_Id
is
14649 U
: Unit_Number_Type
;
14652 if Operating_Mode
/= Generate_Code
then
14662 if U
= No_Unit
then
14665 return Unit
(Cunit
(U
));
14668 end Load_Package_Body
;
14670 -------------------------------
14671 -- Locate_Corresponding_Body --
14672 -------------------------------
14674 function Locate_Corresponding_Body
(PE
: Entity_Id
) return Node_Id
is
14675 Spec
: constant Node_Id
:= Declaration_Node
(PE
);
14676 Decl
: constant Node_Id
:= Parent
(Spec
);
14677 Scop
: constant Entity_Id
:= Scope
(PE
);
14681 if Is_Library_Level_Entity
(PE
) then
14683 -- If package is a library unit that requires a body, we have no
14684 -- choice but to go after that body because it might contain an
14685 -- optional body for the original generic package.
14687 if Unit_Requires_Body
(PE
) then
14689 -- Load the body. Note that we are a little careful here to use
14690 -- Spec to get the unit number, rather than PE or Decl, since
14691 -- in the case where the package is itself a library level
14692 -- instantiation, Spec will properly reference the generic
14693 -- template, which is what we really want.
14697 (Get_Body_Name
(Unit_Name
(Get_Source_Unit
(Spec
))));
14699 -- But if the package is a library unit that does NOT require
14700 -- a body, then no body is permitted, so we are sure that there
14701 -- is no body for the original generic package.
14707 -- Otherwise look and see if we are embedded in a further package
14709 elsif Is_Package_Or_Generic_Package
(Scop
) then
14711 -- If so, get the body of the enclosing package, and look in
14712 -- its package body for the package body we are looking for.
14714 PBody
:= Locate_Corresponding_Body
(Scop
);
14719 return Find_Body_In
(PE
, First
(Declarations
(PBody
)));
14722 -- If we are not embedded in a further package, then the body
14723 -- must be in the same declarative part as we are.
14726 return Find_Body_In
(PE
, Next
(Decl
));
14728 end Locate_Corresponding_Body
;
14730 -- Start of processing for Has_Generic_Body
14733 if Present
(Corresponding_Body
(Decl
)) then
14736 elsif Unit_Requires_Body
(Ent
) then
14739 -- Compilation units cannot have optional bodies
14741 elsif Is_Compilation_Unit
(Ent
) then
14744 -- Otherwise look at what scope we are in
14747 Scop
:= Scope
(Ent
);
14749 -- Case of entity is in other than a package spec, in this case
14750 -- the body, if present, must be in the same declarative part.
14752 if not Is_Package_Or_Generic_Package
(Scop
) then
14757 -- Declaration node may get us a spec, so if so, go to
14758 -- the parent declaration.
14760 P
:= Declaration_Node
(Ent
);
14761 while not Is_List_Member
(P
) loop
14765 return Present
(Find_Body_In
(Ent
, Next
(P
)));
14768 -- If the entity is in a package spec, then we have to locate
14769 -- the corresponding package body, and look there.
14773 PBody
: constant Node_Id
:= Locate_Corresponding_Body
(Scop
);
14781 (Find_Body_In
(Ent
, (First
(Declarations
(PBody
)))));
14786 end Has_Generic_Body
;
14788 -----------------------
14789 -- Insert_Elab_Check --
14790 -----------------------
14792 procedure Insert_Elab_Check
(N
: Node_Id
; C
: Node_Id
:= Empty
) is
14794 Loc
: constant Source_Ptr
:= Sloc
(N
);
14797 -- The check (N_Raise_Program_Error) node to be inserted
14800 -- If expansion is disabled, do not generate any checks. Also
14801 -- skip checks if any subunits are missing because in either
14802 -- case we lack the full information that we need, and no object
14803 -- file will be created in any case.
14805 if not Expander_Active
or else Subunits_Missing
then
14809 -- If we have a generic instantiation, where Instance_Spec is set,
14810 -- then this field points to a generic instance spec that has
14811 -- been inserted before the instantiation node itself, so that
14812 -- is where we want to insert a check.
14814 if Nkind
(N
) in N_Generic_Instantiation
14815 and then Present
(Instance_Spec
(N
))
14817 Nod
:= Instance_Spec
(N
);
14822 -- Build check node, possibly with condition
14825 Make_Raise_Program_Error
(Loc
, Reason
=> PE_Access_Before_Elaboration
);
14827 if Present
(C
) then
14828 Set_Condition
(Chk
, Make_Op_Not
(Loc
, Right_Opnd
=> C
));
14831 -- If we are inserting at the top level, insert in Aux_Decls
14833 if Nkind
(Parent
(Nod
)) = N_Compilation_Unit
then
14835 ADN
: constant Node_Id
:= Aux_Decls_Node
(Parent
(Nod
));
14838 if No
(Declarations
(ADN
)) then
14839 Set_Declarations
(ADN
, New_List
(Chk
));
14841 Append_To
(Declarations
(ADN
), Chk
);
14847 -- Otherwise just insert as an action on the node in question
14850 Insert_Action
(Nod
, Chk
);
14852 end Insert_Elab_Check
;
14854 -------------------------------
14855 -- Is_Call_Of_Generic_Formal --
14856 -------------------------------
14858 function Is_Call_Of_Generic_Formal
(N
: Node_Id
) return Boolean is
14860 return Nkind_In
(N
, N_Function_Call
, N_Procedure_Call_Statement
)
14862 -- Always return False if debug flag -gnatd.G is set
14864 and then not Debug_Flag_Dot_GG
14866 -- For now, we detect this by looking for the strange identifier
14867 -- node, whose Chars reflect the name of the generic formal, but
14868 -- the Chars of the Entity references the generic actual.
14870 and then Nkind
(Name
(N
)) = N_Identifier
14871 and then Chars
(Name
(N
)) /= Chars
(Entity
(Name
(N
)));
14872 end Is_Call_Of_Generic_Formal
;
14874 -------------------------------
14875 -- Is_Finalization_Procedure --
14876 -------------------------------
14878 function Is_Finalization_Procedure
(Id
: Entity_Id
) return Boolean is
14880 -- Check whether Id is a procedure with at least one parameter
14882 if Ekind
(Id
) = E_Procedure
and then Present
(First_Formal
(Id
)) then
14884 Typ
: constant Entity_Id
:= Etype
(First_Formal
(Id
));
14885 Deep_Fin
: Entity_Id
:= Empty
;
14886 Fin
: Entity_Id
:= Empty
;
14889 -- If the type of the first formal does not require finalization
14890 -- actions, then this is definitely not [Deep_]Finalize.
14892 if not Needs_Finalization
(Typ
) then
14896 -- At this point we have the following scenario:
14898 -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]);
14900 -- Recover the two possible versions of [Deep_]Finalize using the
14901 -- type of the first parameter and compare with the input.
14903 Deep_Fin
:= TSS
(Typ
, TSS_Deep_Finalize
);
14905 if Is_Controlled
(Typ
) then
14906 Fin
:= Find_Prim_Op
(Typ
, Name_Finalize
);
14909 return (Present
(Deep_Fin
) and then Id
= Deep_Fin
)
14910 or else (Present
(Fin
) and then Id
= Fin
);
14915 end Is_Finalization_Procedure
;
14921 procedure Output_Calls
14923 Check_Elab_Flag
: Boolean)
14925 function Emit
(Flag
: Boolean) return Boolean;
14926 -- Determine whether to emit an error message based on the combination
14927 -- of flags Check_Elab_Flag and Flag.
14929 function Is_Printable_Error_Name
return Boolean;
14930 -- An internal function, used to determine if a name, stored in the
14931 -- Name_Buffer, is either a non-internal name, or is an internal name
14932 -- that is printable by the error message circuits (i.e. it has a single
14933 -- upper case letter at the end).
14939 function Emit
(Flag
: Boolean) return Boolean is
14941 if Check_Elab_Flag
then
14948 -----------------------------
14949 -- Is_Printable_Error_Name --
14950 -----------------------------
14952 function Is_Printable_Error_Name
return Boolean is
14954 if not Is_Internal_Name
then
14957 elsif Name_Len
= 1 then
14961 Name_Len
:= Name_Len
- 1;
14962 return not Is_Internal_Name
;
14964 end Is_Printable_Error_Name
;
14970 -- Start of processing for Output_Calls
14973 for J
in reverse 1 .. Elab_Call
.Last
loop
14974 Error_Msg_Sloc
:= Elab_Call
.Table
(J
).Cloc
;
14976 Ent
:= Elab_Call
.Table
(J
).Ent
;
14977 Get_Name_String
(Chars
(Ent
));
14979 -- Dynamic elaboration model, warnings controlled by -gnatwl
14981 if Dynamic_Elaboration_Checks
then
14982 if Emit
(Elab_Warnings
) then
14983 if Is_Generic_Unit
(Ent
) then
14984 Error_Msg_NE
("\\?l?& instantiated #", N
, Ent
);
14985 elsif Is_Init_Proc
(Ent
) then
14986 Error_Msg_N
("\\?l?initialization procedure called #", N
);
14987 elsif Is_Printable_Error_Name
then
14988 Error_Msg_NE
("\\?l?& called #", N
, Ent
);
14990 Error_Msg_N
("\\?l?called #", N
);
14994 -- Static elaboration model, info messages controlled by -gnatel
14997 if Emit
(Elab_Info_Messages
) then
14998 if Is_Generic_Unit
(Ent
) then
14999 Error_Msg_NE
("\\?$?& instantiated #", N
, Ent
);
15000 elsif Is_Init_Proc
(Ent
) then
15001 Error_Msg_N
("\\?$?initialization procedure called #", N
);
15002 elsif Is_Printable_Error_Name
then
15003 Error_Msg_NE
("\\?$?& called #", N
, Ent
);
15005 Error_Msg_N
("\\?$?called #", N
);
15012 ----------------------------
15013 -- Same_Elaboration_Scope --
15014 ----------------------------
15016 function Same_Elaboration_Scope
(Scop1
, Scop2
: Entity_Id
) return Boolean is
15021 -- Find elaboration scope for Scop1
15022 -- This is either a subprogram or a compilation unit.
15025 while S1
/= Standard_Standard
15026 and then not Is_Compilation_Unit
(S1
)
15027 and then Ekind_In
(S1
, E_Package
, E_Protected_Type
, E_Block
)
15032 -- Find elaboration scope for Scop2
15035 while S2
/= Standard_Standard
15036 and then not Is_Compilation_Unit
(S2
)
15037 and then Ekind_In
(S2
, E_Package
, E_Protected_Type
, E_Block
)
15043 end Same_Elaboration_Scope
;
15049 procedure Set_C_Scope
is
15051 while not Is_Compilation_Unit
(C_Scope
) loop
15052 C_Scope
:= Scope
(C_Scope
);
15056 --------------------------------
15057 -- Set_Elaboration_Constraint --
15058 --------------------------------
15060 procedure Set_Elaboration_Constraint
15065 Elab_Unit
: Entity_Id
;
15067 -- Check whether this is a call to an Initialize subprogram for a
15068 -- controlled type. Note that Call can also be a 'Access attribute
15069 -- reference, which now generates an elaboration check.
15071 Init_Call
: constant Boolean :=
15072 Nkind
(Call
) = N_Procedure_Call_Statement
15073 and then Chars
(Subp
) = Name_Initialize
15074 and then Comes_From_Source
(Subp
)
15075 and then Present
(Parameter_Associations
(Call
))
15076 and then Is_Controlled
(Etype
(First_Actual
(Call
)));
15079 -- If the unit is mentioned in a with_clause of the current unit, it is
15080 -- visible, and we can set the elaboration flag.
15082 if Is_Immediately_Visible
(Scop
)
15083 or else (Is_Child_Unit
(Scop
) and then Is_Visible_Lib_Unit
(Scop
))
15085 Activate_Elaborate_All_Desirable
(Call
, Scop
);
15086 Set_Suppress_Elaboration_Warnings
(Scop
);
15090 -- If this is not an initialization call or a call using object notation
15091 -- we know that the unit of the called entity is in the context, and we
15092 -- can set the flag as well. The unit need not be visible if the call
15093 -- occurs within an instantiation.
15095 if Is_Init_Proc
(Subp
)
15097 or else Nkind
(Original_Node
(Call
)) = N_Selected_Component
15099 null; -- detailed processing follows.
15102 Activate_Elaborate_All_Desirable
(Call
, Scop
);
15103 Set_Suppress_Elaboration_Warnings
(Scop
);
15107 -- If the unit is not in the context, there must be an intermediate unit
15108 -- that is, on which we need to place to elaboration flag. This happens
15109 -- with init proc calls.
15111 if Is_Init_Proc
(Subp
) or else Init_Call
then
15113 -- The initialization call is on an object whose type is not declared
15114 -- in the same scope as the subprogram. The type of the object must
15115 -- be a subtype of the type of operation. This object is the first
15116 -- actual in the call.
15119 Typ
: constant Entity_Id
:=
15120 Etype
(First
(Parameter_Associations
(Call
)));
15122 Elab_Unit
:= Scope
(Typ
);
15123 while (Present
(Elab_Unit
))
15124 and then not Is_Compilation_Unit
(Elab_Unit
)
15126 Elab_Unit
:= Scope
(Elab_Unit
);
15130 -- If original node uses selected component notation, the prefix is
15131 -- visible and determines the scope that must be elaborated. After
15132 -- rewriting, the prefix is the first actual in the call.
15134 elsif Nkind
(Original_Node
(Call
)) = N_Selected_Component
then
15135 Elab_Unit
:= Scope
(Etype
(First
(Parameter_Associations
(Call
))));
15137 -- Not one of special cases above
15140 -- Using previously computed scope. If the elaboration check is
15141 -- done after analysis, the scope is not visible any longer, but
15142 -- must still be in the context.
15147 Activate_Elaborate_All_Desirable
(Call
, Elab_Unit
);
15148 Set_Suppress_Elaboration_Warnings
(Elab_Unit
);
15149 end Set_Elaboration_Constraint
;
15155 function Spec_Entity
(E
: Entity_Id
) return Entity_Id
is
15159 -- Check for case of body entity
15160 -- Why is the check for E_Void needed???
15162 if Ekind_In
(E
, E_Void
, E_Subprogram_Body
, E_Package_Body
) then
15166 Decl
:= Parent
(Decl
);
15167 exit when Nkind
(Decl
) in N_Proper_Body
;
15170 return Corresponding_Spec
(Decl
);
15181 function Within
(E1
, E2
: Entity_Id
) return Boolean is
15188 elsif Scop
= Standard_Standard
then
15191 Scop
:= Scope
(Scop
);
15196 --------------------------
15197 -- Within_Elaborate_All --
15198 --------------------------
15200 function Within_Elaborate_All
15201 (Unit
: Unit_Number_Type
;
15202 E
: Entity_Id
) return Boolean
15204 type Unit_Number_Set
is array (Main_Unit
.. Last_Unit
) of Boolean;
15205 pragma Pack
(Unit_Number_Set
);
15207 Seen
: Unit_Number_Set
:= (others => False);
15208 -- Seen (X) is True after we have seen unit X in the walk. This is used
15209 -- to prevent processing the same unit more than once.
15211 Result
: Boolean := False;
15213 procedure Helper
(Unit
: Unit_Number_Type
);
15214 -- This helper procedure does all the work for Within_Elaborate_All. It
15215 -- walks the dependency graph, and sets Result to True if it finds an
15216 -- appropriate Elaborate_All.
15222 procedure Helper
(Unit
: Unit_Number_Type
) is
15223 CU
: constant Node_Id
:= Cunit
(Unit
);
15227 Elab_Id
: Entity_Id
;
15231 if Seen
(Unit
) then
15234 Seen
(Unit
) := True;
15237 -- First, check for Elaborate_Alls on this unit
15239 Item
:= First
(Context_Items
(CU
));
15240 while Present
(Item
) loop
15241 if Nkind
(Item
) = N_Pragma
15242 and then Pragma_Name
(Item
) = Name_Elaborate_All
15244 -- Return if some previous error on the pragma itself. The
15245 -- pragma may be unanalyzed, because of a previous error, or
15246 -- if it is the context of a subunit, inherited by its parent.
15248 if Error_Posted
(Item
) or else not Analyzed
(Item
) then
15254 (Expression
(First
(Pragma_Argument_Associations
(Item
))));
15256 if E
= Elab_Id
then
15261 Par
:= Parent
(Unit_Declaration_Node
(Elab_Id
));
15263 Item2
:= First
(Context_Items
(Par
));
15264 while Present
(Item2
) loop
15265 if Nkind
(Item2
) = N_With_Clause
15266 and then Entity
(Name
(Item2
)) = E
15267 and then not Limited_Present
(Item2
)
15280 -- Second, recurse on with's. We could do this as part of the above
15281 -- loop, but it's probably more efficient to have two loops, because
15282 -- the relevant Elaborate_All is likely to be on the initial unit. In
15283 -- other words, we're walking the with's breadth-first. This part is
15284 -- only necessary in the dynamic elaboration model.
15286 if Dynamic_Elaboration_Checks
then
15287 Item
:= First
(Context_Items
(CU
));
15288 while Present
(Item
) loop
15289 if Nkind
(Item
) = N_With_Clause
15290 and then not Limited_Present
(Item
)
15292 -- Note: the following call to Get_Cunit_Unit_Number does a
15293 -- linear search, which could be slow, but it's OK because
15294 -- we're about to give a warning anyway. Also, there might
15295 -- be hundreds of units, but not millions. If it turns out
15296 -- to be a problem, we could store the Get_Cunit_Unit_Number
15297 -- in each N_Compilation_Unit node, but that would involve
15298 -- rearranging N_Compilation_Unit_Aux to make room.
15300 Helper
(Get_Cunit_Unit_Number
(Library_Unit
(Item
)));
15312 -- Start of processing for Within_Elaborate_All
15317 end Within_Elaborate_All
;