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_Pragma (Nod : Node_Id) return Boolean;
2278 -- Determine whether arbitrary node Nod appears within a pragma
2284 function In_Pragma (Nod : Node_Id) return Boolean is
2289 while Present (Par) loop
2290 if Nkind (Par) = N_Pragma then
2293 -- Prevent the search from going too far
2295 elsif Is_Body_Or_Package_Declaration (Par) then
2299 Par := Parent (Par);
2309 Var_Attrs : Variable_Attributes;
2312 -- Start of processing for Build_Variable_Reference_Marker
2315 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
2316 -- enabled) is in effect because the legacy ABE mechanism does not need
2317 -- to carry out this action.
2319 if Legacy_Elaboration_Checks then
2322 -- Nothing to do for ASIS. As a result, ABE checks and diagnostics are
2323 -- not performed in this mode.
2325 elsif ASIS_Mode then
2328 -- Nothing to do when the reference is being preanalyzed as the marker
2329 -- will be inserted in the wrong place.
2331 elsif Preanalysis_Active then
2334 -- Nothing to do when the input does not denote a reference
2336 elsif not Nkind_In (N, N_Expanded_Name, N_Identifier) then
2339 -- Nothing to do for internally-generated references
2341 elsif not Comes_From_Source (N) then
2344 -- Nothing to do when the reference is erroneous, left in a bad state,
2345 -- or does not denote a variable.
2347 elsif not (Present (Entity (N))
2348 and then Ekind (Entity (N)) = E_Variable
2349 and then Entity (N) /= Any_Id)
2354 Extract_Variable_Reference_Attributes
2357 Attrs => Var_Attrs);
2359 Prag := SPARK_Pragma (Var_Id);
2361 if Comes_From_Source (Var_Id)
2363 -- Both the variable and the reference must appear in SPARK_Mode On
2364 -- regions because this scenario falls under the SPARK rules.
2366 and then Present (Prag)
2367 and then Get_SPARK_Mode_From_Annotation (Prag) = On
2368 and then Is_SPARK_Mode_On_Node (N)
2370 -- The reference must not be considered when it appears in a pragma.
2371 -- If the pragma has run-time semantics, then the reference will be
2372 -- reconsidered once the pragma is expanded.
2374 -- Performance note: parent traversal
2376 and then not In_Pragma (N)
2380 -- Otherwise the reference is not suitable for ABE processing. This
2381 -- prevents the generation of variable markers which will never play
2382 -- a role in ABE diagnostics.
2388 -- At this point it is known that the variable reference will play some
2389 -- role in ABE checks and diagnostics. Create a corresponding variable
2390 -- marker in case the original variable reference is folded or optimized
2393 Marker := Make_Variable_Reference_Marker (Sloc (N));
2395 -- Inherit the attributes of the original variable reference
2397 Set_Target (Marker, Var_Id);
2398 Set_Is_Read (Marker, Read);
2399 Set_Is_Write (Marker, Write);
2401 -- The marker is inserted prior to the original variable reference. The
2402 -- insertion must take place even when the reference does not occur in
2403 -- the main unit to keep the tree symmetric. This ensures that internal
2404 -- name serialization is consistent in case the variable marker causes
2405 -- the tree to transform in some way.
2407 Insert_Action (N, Marker);
2409 -- The marker becomes the "corresponding" scenario for the reference.
2410 -- Save the marker for later processing for the ABE phase.
2412 Record_Elaboration_Scenario (Marker);
2413 end Build_Variable_Reference_Marker;
2415 ---------------------------------
2416 -- Check_Elaboration_Scenarios --
2417 ---------------------------------
2419 procedure Check_Elaboration_Scenarios is
2421 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
2422 -- enabled) is in effect because the legacy ABE mechanism does not need
2423 -- to carry out this action.
2425 if Legacy_Elaboration_Checks then
2428 -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics
2429 -- are performed in this mode.
2431 elsif ASIS_Mode then
2435 -- Restore the original elaboration model which was in effect when the
2436 -- scenarios were first recorded. The model may be specified by pragma
2437 -- Elaboration_Checks which appears on the initial declaration of the
2440 Install_Elaboration_Model (Unit_Entity (Cunit_Entity (Main_Unit)));
2442 -- Examine the context of the main unit and record all units with prior
2443 -- elaboration with respect to it.
2445 Find_Elaborated_Units;
2447 -- Examine each top-level scenario saved during the Recording phase for
2448 -- conditional ABEs and perform various actions depending on the model
2449 -- in effect. The table of visited bodies is created for each new top-
2452 for Index in Top_Level_Scenarios.First .. Top_Level_Scenarios.Last loop
2453 Reset_Visited_Bodies;
2455 Process_Conditional_ABE (Top_Level_Scenarios.Table (Index));
2458 -- Examine each SPARK scenario saved during the Recording phase which
2459 -- is not necessarily executable during elaboration, but still requires
2460 -- elaboration-related checks.
2462 for Index in SPARK_Scenarios.First .. SPARK_Scenarios.Last loop
2463 Check_SPARK_Scenario (SPARK_Scenarios.Table (Index));
2465 end Check_Elaboration_Scenarios;
2467 ------------------------------
2468 -- Check_Preelaborated_Call --
2469 ------------------------------
2471 procedure Check_Preelaborated_Call (Call : Node_Id) is
2472 function In_Preelaborated_Context (N : Node_Id) return Boolean;
2473 -- Determine whether arbitrary node appears in a preelaborated context
2475 ------------------------------
2476 -- In_Preelaborated_Context --
2477 ------------------------------
2479 function In_Preelaborated_Context (N : Node_Id) return Boolean is
2480 Body_Id : constant Entity_Id := Find_Code_Unit (N);
2481 Spec_Id : constant Entity_Id := Unique_Entity (Body_Id);
2484 -- The node appears within a package body whose corresponding spec is
2485 -- subject to pragma Remote_Call_Interface or Remote_Types. This does
2486 -- not result in a preelaborated context because the package body may
2487 -- be on another machine.
2489 if Ekind (Body_Id) = E_Package_Body
2490 and then Ekind_In (Spec_Id, E_Generic_Package, E_Package)
2491 and then (Is_Remote_Call_Interface (Spec_Id)
2492 or else Is_Remote_Types (Spec_Id))
2496 -- Otherwise the node appears within a preelaborated context when the
2497 -- associated unit is preelaborated.
2500 return Is_Preelaborated_Unit (Spec_Id);
2502 end In_Preelaborated_Context;
2506 Call_Attrs : Call_Attributes;
2507 Level : Enclosing_Level_Kind;
2508 Target_Id : Entity_Id;
2510 -- Start of processing for Check_Preelaborated_Call
2513 Extract_Call_Attributes
2515 Target_Id => Target_Id,
2516 Attrs => Call_Attrs);
2518 -- Nothing to do when the call is internally generated because it is
2519 -- assumed that it will never violate preelaboration.
2521 if not Call_Attrs.From_Source then
2525 -- Performance note: parent traversal
2527 Level := Find_Enclosing_Level (Call);
2529 -- Library-level calls are always considered because they are part of
2530 -- the associated unit's elaboration actions.
2532 if Level in Library_Level then
2535 -- Calls at the library level of a generic package body must be checked
2536 -- because they would render an instantiation illegal if the template is
2537 -- marked as preelaborated. Note that this does not apply to calls at
2538 -- the library level of a generic package spec.
2540 elsif Level = Generic_Package_Body then
2543 -- Otherwise the call does not appear at the proper level and must not
2544 -- be considered for this check.
2550 -- The call appears within a preelaborated unit. Emit a warning only for
2551 -- internal uses, otherwise this is an error.
2553 if In_Preelaborated_Context (Call) then
2554 Error_Msg_Warn := GNAT_Mode;
2556 ("<<non-static call not allowed in preelaborated unit", Call);
2558 end Check_Preelaborated_Call;
2560 ------------------------------
2561 -- Check_SPARK_Derived_Type --
2562 ------------------------------
2564 procedure Check_SPARK_Derived_Type (Typ_Decl : Node_Id) is
2565 Typ : constant Entity_Id := Defining_Entity (Typ_Decl);
2567 -- NOTE: The routines within Check_SPARK_Derived_Type are intentionally
2568 -- unnested to avoid deep indentation of code.
2570 Stop_Check : exception;
2571 -- This exception is raised when the freeze node violates the placement
2574 procedure Check_Overriding_Primitive
2577 pragma Inline (Check_Overriding_Primitive);
2578 -- Verify that freeze node FNode is within the early call region of
2579 -- overriding primitive Prim's body.
2581 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr;
2582 pragma Inline (Freeze_Node_Location);
2583 -- Return a more accurate source location associated with freeze node
2586 function Precedes_Source_Construct (N : Node_Id) return Boolean;
2587 pragma Inline (Precedes_Source_Construct);
2588 -- Determine whether arbitrary node N appears prior to some source
2591 procedure Suggest_Elaborate_Body
2593 Body_Decl : Node_Id;
2594 Error_Nod : Node_Id);
2595 pragma Inline (Suggest_Elaborate_Body);
2596 -- Suggest the use of pragma Elaborate_Body when the pragma will allow
2597 -- for node N to appear within the early call region of subprogram body
2598 -- Body_Decl. The suggestion is attached to Error_Nod as a continuation
2601 --------------------------------
2602 -- Check_Overriding_Primitive --
2603 --------------------------------
2605 procedure Check_Overriding_Primitive
2609 Prim_Decl : constant Node_Id := Unit_Declaration_Node (Prim);
2610 Body_Decl : Node_Id;
2611 Body_Id : Entity_Id;
2615 -- Nothing to do for predefined primitives because they are artifacts
2616 -- of tagged type expansion and cannot override source primitives.
2618 if Is_Predefined_Dispatching_Operation (Prim) then
2622 Body_Id := Corresponding_Body (Prim_Decl);
2624 -- Nothing to do when the primitive does not have a corresponding
2625 -- body. This can happen when the unit with the bodies is not the
2626 -- main unit subjected to ABE checks.
2628 if No (Body_Id) then
2631 -- The primitive overrides a parent or progenitor primitive
2633 elsif Present (Overridden_Operation (Prim)) then
2635 -- Nothing to do when overriding an interface primitive happens by
2636 -- inheriting a non-interface primitive as the check would be done
2637 -- on the parent primitive.
2639 if Present (Alias (Prim)) then
2643 -- Nothing to do when the primitive is not overriding. The body of
2644 -- such a primitive cannot be targeted by a dispatching call which
2645 -- is executable during elaboration, and cannot cause an ABE.
2651 Body_Decl := Unit_Declaration_Node (Body_Id);
2652 Region := Find_Early_Call_Region (Body_Decl);
2654 -- The freeze node appears prior to the early call region of the
2657 -- IMPORTANT: This check must always be performed even when -gnatd.v
2658 -- (enforce SPARK elaboration rules in SPARK code) is not specified
2659 -- because the static model cannot guarantee the absence of ABEs in
2660 -- in the presence of dispatching calls.
2662 if Earlier_In_Extended_Unit (FNode, Region) then
2663 Error_Msg_Node_2 := Prim;
2665 ("first freezing point of type & must appear within early call "
2666 & "region of primitive body & (SPARK RM 7.7(8))",
2669 Error_Msg_Sloc := Sloc (Region);
2670 Error_Msg_N ("\region starts #", Typ_Decl);
2672 Error_Msg_Sloc := Sloc (Body_Decl);
2673 Error_Msg_N ("\region ends #", Typ_Decl);
2675 Error_Msg_Sloc := Freeze_Node_Location (FNode);
2676 Error_Msg_N ("\first freezing point #", Typ_Decl);
2678 -- If applicable, suggest the use of pragma Elaborate_Body in the
2679 -- associated package spec.
2681 Suggest_Elaborate_Body
2683 Body_Decl => Body_Decl,
2684 Error_Nod => Typ_Decl);
2688 end Check_Overriding_Primitive;
2690 --------------------------
2691 -- Freeze_Node_Location --
2692 --------------------------
2694 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr is
2695 Context : constant Node_Id := Parent (FNode);
2696 Loc : constant Source_Ptr := Sloc (FNode);
2698 Prv_Decls : List_Id;
2699 Vis_Decls : List_Id;
2702 -- In general, the source location of the freeze node is as close as
2703 -- possible to the real freeze point, except when the freeze node is
2704 -- at the "bottom" of a package spec.
2706 if Nkind (Context) = N_Package_Specification then
2707 Prv_Decls := Private_Declarations (Context);
2708 Vis_Decls := Visible_Declarations (Context);
2710 -- The freeze node appears in the private declarations of the
2713 if Present (Prv_Decls)
2714 and then List_Containing (FNode) = Prv_Decls
2718 -- The freeze node appears in the visible declarations of the
2719 -- package and there are no private declarations.
2721 elsif Present (Vis_Decls)
2722 and then List_Containing (FNode) = Vis_Decls
2723 and then (No (Prv_Decls) or else Is_Empty_List (Prv_Decls))
2727 -- Otherwise the freeze node is not in the "last" declarative list
2728 -- of the package. Use the existing source location of the freeze
2735 -- The freeze node appears at the "bottom" of the package when it
2736 -- is in the "last" declarative list and is either the last in the
2737 -- list or is followed by internal constructs only. In that case
2738 -- the more appropriate source location is that of the package end
2741 if not Precedes_Source_Construct (FNode) then
2742 return Sloc (End_Label (Context));
2747 end Freeze_Node_Location;
2749 -------------------------------
2750 -- Precedes_Source_Construct --
2751 -------------------------------
2753 function Precedes_Source_Construct (N : Node_Id) return Boolean is
2758 while Present (Decl) loop
2759 if Comes_From_Source (Decl) then
2762 -- A generated body for a source expression function is treated as
2763 -- a source construct.
2765 elsif Nkind (Decl) = N_Subprogram_Body
2766 and then Was_Expression_Function (Decl)
2767 and then Comes_From_Source (Original_Node (Decl))
2776 end Precedes_Source_Construct;
2778 ----------------------------
2779 -- Suggest_Elaborate_Body --
2780 ----------------------------
2782 procedure Suggest_Elaborate_Body
2784 Body_Decl : Node_Id;
2785 Error_Nod : Node_Id)
2787 Unt : constant Node_Id := Unit (Cunit (Main_Unit));
2791 -- The suggestion applies only when the subprogram body resides in a
2792 -- compilation package body, and a pragma Elaborate_Body would allow
2793 -- for the node to appear in the early call region of the subprogram
2794 -- body. This implies that all code from the subprogram body up to
2795 -- the node is preelaborable.
2797 if Nkind (Unt) = N_Package_Body then
2799 -- Find the start of the early call region again assuming that the
2800 -- package spec has pragma Elaborate_Body. Note that the internal
2801 -- data structures are intentionally not updated because this is a
2802 -- speculative search.
2805 Find_Early_Call_Region
2806 (Body_Decl => Body_Decl,
2807 Assume_Elab_Body => True,
2808 Skip_Memoization => True);
2810 -- If the node appears within the early call region, assuming that
2811 -- the package spec carries pragma Elaborate_Body, then it is safe
2812 -- to suggest the pragma.
2814 if Earlier_In_Extended_Unit (Region, N) then
2815 Error_Msg_Name_1 := Name_Elaborate_Body;
2817 ("\consider adding pragma % in spec of unit &",
2818 Error_Nod, Defining_Entity (Unt));
2821 end Suggest_Elaborate_Body;
2825 FNode : constant Node_Id := Freeze_Node (Typ);
2826 Prims : constant Elist_Id := Direct_Primitive_Operations (Typ);
2828 Prim_Elmt : Elmt_Id;
2830 -- Start of processing for Check_SPARK_Derived_Type
2833 -- A type should have its freeze node set by the time SPARK scenarios
2834 -- are being verified.
2836 pragma Assert (Present (FNode));
2838 -- Verify that the freeze node of the derived type is within the early
2839 -- call region of each overriding primitive body (SPARK RM 7.7(8)).
2841 if Present (Prims) then
2842 Prim_Elmt := First_Elmt (Prims);
2843 while Present (Prim_Elmt) loop
2844 Check_Overriding_Primitive
2845 (Prim => Node (Prim_Elmt),
2848 Next_Elmt (Prim_Elmt);
2855 end Check_SPARK_Derived_Type;
2857 -------------------------------
2858 -- Check_SPARK_Instantiation --
2859 -------------------------------
2861 procedure Check_SPARK_Instantiation (Exp_Inst : Node_Id) is
2862 Gen_Attrs : Target_Attributes;
2865 Inst_Attrs : Instantiation_Attributes;
2866 Inst_Id : Entity_Id;
2869 Extract_Instantiation_Attributes
2870 (Exp_Inst => Exp_Inst,
2874 Attrs => Inst_Attrs);
2876 Extract_Target_Attributes (Gen_Id, Gen_Attrs);
2878 -- The instantiation and the generic body are both in the main unit
2880 if Present (Gen_Attrs.Body_Decl)
2881 and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl)
2883 -- If the instantiation appears prior to the generic body, then the
2884 -- instantiation is illegal (SPARK RM 7.7(6)).
2886 -- IMPORTANT: This check must always be performed even when -gnatd.v
2887 -- (enforce SPARK elaboration rules in SPARK code) is not specified
2888 -- because the rule prevents use-before-declaration of objects that
2889 -- may precede the generic body.
2891 and then Earlier_In_Extended_Unit (Inst, Gen_Attrs.Body_Decl)
2893 Error_Msg_NE ("cannot instantiate & before body seen", Inst, Gen_Id);
2895 end Check_SPARK_Instantiation;
2897 ---------------------------------
2898 -- Check_SPARK_Model_In_Effect --
2899 ---------------------------------
2901 SPARK_Model_Warning_Posted : Boolean := False;
2902 -- This flag prevents the same SPARK model-related warning from being
2903 -- emitted multiple times.
2905 procedure Check_SPARK_Model_In_Effect (N : Node_Id) is
2907 -- Do not emit the warning multiple times as this creates useless noise
2909 if SPARK_Model_Warning_Posted then
2912 -- SPARK rule verification requires the "strict" static model
2914 elsif Static_Elaboration_Checks and not Relaxed_Elaboration_Checks then
2917 -- Any other combination of models does not guarantee the absence of ABE
2918 -- problems for SPARK rule verification purposes. Note that there is no
2919 -- need to check for the legacy ABE mechanism because the legacy code
2920 -- has its own orthogonal processing for SPARK rules.
2923 SPARK_Model_Warning_Posted := True;
2926 ("??SPARK elaboration checks require static elaboration model", N);
2928 if Dynamic_Elaboration_Checks then
2929 Error_Msg_N ("\dynamic elaboration model is in effect", N);
2931 pragma Assert (Relaxed_Elaboration_Checks);
2932 Error_Msg_N ("\relaxed elaboration model is in effect", N);
2935 end Check_SPARK_Model_In_Effect;
2937 --------------------------
2938 -- Check_SPARK_Scenario --
2939 --------------------------
2941 procedure Check_SPARK_Scenario (N : Node_Id) is
2943 -- Ensure that a suitable elaboration model is in effect for SPARK rule
2946 Check_SPARK_Model_In_Effect (N);
2948 -- Add the current scenario to the stack of active scenarios
2950 Push_Active_Scenario (N);
2952 if Is_Suitable_SPARK_Derived_Type (N) then
2953 Check_SPARK_Derived_Type (N);
2955 elsif Is_Suitable_SPARK_Instantiation (N) then
2956 Check_SPARK_Instantiation (N);
2958 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then
2959 Check_SPARK_Refined_State_Pragma (N);
2962 -- Remove the current scenario from the stack of active scenarios once
2963 -- all ABE diagnostics and checks have been performed.
2965 Pop_Active_Scenario (N);
2966 end Check_SPARK_Scenario;
2968 --------------------------------------
2969 -- Check_SPARK_Refined_State_Pragma --
2970 --------------------------------------
2972 procedure Check_SPARK_Refined_State_Pragma (N : Node_Id) is
2974 -- NOTE: The routines within Check_SPARK_Refined_State_Pragma are
2975 -- intentionally unnested to avoid deep indentation of code.
2977 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id);
2978 pragma Inline (Check_SPARK_Constituent);
2979 -- Ensure that a single constituent Constit_Id is elaborated prior to
2982 procedure Check_SPARK_Constituents (Constits : Elist_Id);
2983 pragma Inline (Check_SPARK_Constituents);
2984 -- Ensure that all constituents found in list Constits are elaborated
2985 -- prior to the main unit.
2987 procedure Check_SPARK_Initialized_State (State : Node_Id);
2988 pragma Inline (Check_SPARK_Initialized_State);
2989 -- Ensure that the constituents of single abstract state State are
2990 -- elaborated prior to the main unit.
2992 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id);
2993 pragma Inline (Check_SPARK_Initialized_States);
2994 -- Ensure that the constituents of all abstract states which appear in
2995 -- the Initializes pragma of package Pack_Id are elaborated prior to the
2998 -----------------------------
2999 -- Check_SPARK_Constituent --
3000 -----------------------------
3002 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id) is
3006 -- Nothing to do for "null" constituents
3008 if Nkind (Constit_Id) = N_Null then
3011 -- Nothing to do for illegal constituents
3013 elsif Error_Posted (Constit_Id) then
3017 Prag := SPARK_Pragma (Constit_Id);
3019 -- The check applies only when the constituent is subject to pragma
3023 and then Get_SPARK_Mode_From_Annotation (Prag) = On
3025 -- An external constituent of an abstract state which appears in
3026 -- the Initializes pragma of a package spec imposes an Elaborate
3027 -- requirement on the context of the main unit. Determine whether
3028 -- the context has a pragma strong enough to meet the requirement.
3030 -- IMPORTANT: This check is performed only when -gnatd.v (enforce
3031 -- SPARK elaboration rules in SPARK code) is in effect because the
3032 -- static model can ensure the prior elaboration of the unit which
3033 -- contains a constituent by installing implicit Elaborate pragma.
3035 if Debug_Flag_Dot_V then
3036 Meet_Elaboration_Requirement
3038 Target_Id => Constit_Id,
3039 Req_Nam => Name_Elaborate);
3041 -- Otherwise ensure that the unit with the external constituent is
3042 -- elaborated prior to the main unit.
3045 Ensure_Prior_Elaboration
3047 Unit_Id => Find_Top_Unit (Constit_Id),
3048 Prag_Nam => Name_Elaborate,
3049 State => Initial_State);
3052 end Check_SPARK_Constituent;
3054 ------------------------------
3055 -- Check_SPARK_Constituents --
3056 ------------------------------
3058 procedure Check_SPARK_Constituents (Constits : Elist_Id) is
3059 Constit_Elmt : Elmt_Id;
3062 if Present (Constits) then
3063 Constit_Elmt := First_Elmt (Constits);
3064 while Present (Constit_Elmt) loop
3065 Check_SPARK_Constituent (Node (Constit_Elmt));
3066 Next_Elmt (Constit_Elmt);
3069 end Check_SPARK_Constituents;
3071 -----------------------------------
3072 -- Check_SPARK_Initialized_State --
3073 -----------------------------------
3075 procedure Check_SPARK_Initialized_State (State : Node_Id) is
3077 State_Id : Entity_Id;
3080 -- Nothing to do for "null" initialization items
3082 if Nkind (State) = N_Null then
3085 -- Nothing to do for illegal states
3087 elsif Error_Posted (State) then
3091 State_Id := Entity_Of (State);
3093 -- Sanitize the state
3095 if No (State_Id) then
3098 elsif Error_Posted (State_Id) then
3101 elsif Ekind (State_Id) /= E_Abstract_State then
3105 -- The check is performed only when the abstract state is subject to
3108 Prag := SPARK_Pragma (State_Id);
3111 and then Get_SPARK_Mode_From_Annotation (Prag) = On
3113 Check_SPARK_Constituents (Refinement_Constituents (State_Id));
3115 end Check_SPARK_Initialized_State;
3117 ------------------------------------
3118 -- Check_SPARK_Initialized_States --
3119 ------------------------------------
3121 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id) is
3122 Prag : constant Node_Id := Get_Pragma (Pack_Id, Pragma_Initializes);
3127 if Present (Prag) then
3128 Inits := Expression (Get_Argument (Prag, Pack_Id));
3130 -- Avoid processing a "null" initialization list. The only other
3131 -- alternative is an aggregate.
3133 if Nkind (Inits) = N_Aggregate then
3135 -- The initialization items appear in list form:
3139 if Present (Expressions (Inits)) then
3140 Init := First (Expressions (Inits));
3141 while Present (Init) loop
3142 Check_SPARK_Initialized_State (Init);
3147 -- The initialization items appear in associated form:
3149 -- (state1 => item1,
3150 -- state2 => (item2, item3))
3152 if Present (Component_Associations (Inits)) then
3153 Init := First (Component_Associations (Inits));
3154 while Present (Init) loop
3155 Check_SPARK_Initialized_State (Init);
3161 end Check_SPARK_Initialized_States;
3165 Pack_Body : constant Node_Id := Find_Related_Package_Or_Body (N);
3167 -- Start of processing for Check_SPARK_Refined_State_Pragma
3170 -- Pragma Refined_State must be associated with a package body
3173 (Present (Pack_Body) and then Nkind (Pack_Body) = N_Package_Body);
3175 -- Verify that each external contitunent of an abstract state mentioned
3176 -- in pragma Initializes is properly elaborated.
3178 Check_SPARK_Initialized_States (Unique_Defining_Entity (Pack_Body));
3179 end Check_SPARK_Refined_State_Pragma;
3181 ----------------------
3182 -- Compilation_Unit --
3183 ----------------------
3185 function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is
3186 Comp_Unit : Node_Id;
3189 Comp_Unit := Parent (Unit_Id);
3191 -- Handle the case where a concurrent subunit is rewritten as a null
3192 -- statement due to expansion activities.
3194 if Nkind (Comp_Unit) = N_Null_Statement
3195 and then Nkind_In (Original_Node (Comp_Unit), N_Protected_Body,
3198 Comp_Unit := Parent (Comp_Unit);
3199 pragma Assert (Nkind (Comp_Unit) = N_Subunit);
3201 -- Otherwise use the declaration node of the unit
3204 Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id));
3207 -- Handle the case where a subprogram instantiation which acts as a
3208 -- compilation unit is expanded into an anonymous package that wraps
3209 -- the instantiated subprogram.
3211 if Nkind (Comp_Unit) = N_Package_Specification
3212 and then Nkind_In (Original_Node (Parent (Comp_Unit)),
3213 N_Function_Instantiation,
3214 N_Procedure_Instantiation)
3216 Comp_Unit := Parent (Parent (Comp_Unit));
3218 -- Handle the case where the compilation unit is a subunit
3220 elsif Nkind (Comp_Unit) = N_Subunit then
3221 Comp_Unit := Parent (Comp_Unit);
3224 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit);
3227 end Compilation_Unit;
3229 -----------------------
3230 -- Early_Call_Region --
3231 -----------------------
3233 function Early_Call_Region (Body_Id : Entity_Id) return Node_Id is
3235 pragma Assert (Ekind_In (Body_Id, E_Entry,
3239 E_Subprogram_Body));
3241 if Early_Call_Regions_In_Use then
3242 return Early_Call_Regions.Get (Body_Id);
3245 return Early_Call_Regions_No_Element;
3246 end Early_Call_Region;
3248 -----------------------------
3249 -- Early_Call_Regions_Hash --
3250 -----------------------------
3252 function Early_Call_Regions_Hash
3253 (Key : Entity_Id) return Early_Call_Regions_Index
3256 return Early_Call_Regions_Index (Key mod Early_Call_Regions_Max);
3257 end Early_Call_Regions_Hash;
3263 procedure Elab_Msg_NE
3270 function Prefix return String;
3271 -- Obtain the prefix of the message
3273 function Suffix return String;
3274 -- Obtain the suffix of the message
3280 function Prefix return String is
3293 function Suffix return String is
3302 -- Start of processing for Elab_Msg_NE
3305 Error_Msg_NE (Prefix & Msg & Suffix, N, Id);
3308 ------------------------
3309 -- Elaboration_Status --
3310 ------------------------
3312 function Elaboration_Status
3313 (Unit_Id : Entity_Id) return Elaboration_Attributes
3316 if Elaboration_Statuses_In_Use then
3317 return Elaboration_Statuses.Get (Unit_Id);
3320 return Elaboration_Statuses_No_Element;
3321 end Elaboration_Status;
3323 -------------------------------
3324 -- Elaboration_Statuses_Hash --
3325 -------------------------------
3327 function Elaboration_Statuses_Hash
3328 (Key : Entity_Id) return Elaboration_Statuses_Index
3331 return Elaboration_Statuses_Index (Key mod Elaboration_Statuses_Max);
3332 end Elaboration_Statuses_Hash;
3334 ------------------------------
3335 -- Ensure_Prior_Elaboration --
3336 ------------------------------
3338 procedure Ensure_Prior_Elaboration
3340 Unit_Id : Entity_Id;
3342 State : Processing_Attributes)
3345 pragma Assert (Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All));
3347 -- Nothing to do when the caller has suppressed the generation of
3348 -- implicit Elaborate[_All] pragmas.
3350 if State.Suppress_Implicit_Pragmas then
3353 -- Nothing to do when the need for prior elaboration came from a partial
3354 -- finalization routine which occurs in an initialization context. This
3355 -- behaviour parallels that of the old ABE mechanism.
3357 elsif State.Within_Partial_Finalization then
3360 -- Nothing to do when the need for prior elaboration came from a task
3361 -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on
3362 -- task bodies) is in effect.
3364 elsif Debug_Flag_Dot_Y and then State.Within_Task_Body then
3367 -- Nothing to do when the unit is elaborated prior to the main unit.
3368 -- This check must also consider the following cases:
3370 -- * No check is made against the context of the main unit because this
3371 -- is specific to the elaboration model in effect and requires custom
3372 -- handling (see Ensure_xxx_Prior_Elaboration).
3374 -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma
3375 -- Elaborate[_All] MUST be generated even though Unit_Id is always
3376 -- elaborated prior to the main unit. This is a conservative strategy
3377 -- which ensures that other units withed by Unit_Id will not lead to
3380 -- package A is package body A is
3381 -- procedure ABE; procedure ABE is ... end ABE;
3385 -- package B is package body B is
3386 -- pragma Elaborate_Body; procedure Proc is
3388 -- procedure Proc; A.ABE;
3389 -- package B; end Proc;
3393 -- package C is package body C is
3399 -- In the example above, the elaboration of C invokes B.Proc. B is
3400 -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] is
3401 -- generated for B in C, then the following elaboratio order will lead
3404 -- spec of A elaborated
3405 -- spec of B elaborated
3406 -- body of B elaborated
3407 -- spec of C elaborated
3408 -- body of C elaborated <-- calls B.Proc which calls A.ABE
3409 -- body of A elaborated <-- problem
3411 -- The generation of an implicit pragma Elaborate_All (B) ensures that
3412 -- the elaboration order mechanism will not pick the above order.
3414 -- An implicit Elaborate is NOT generated when the unit is subject to
3415 -- Elaborate_Body because both pragmas have the exact same effect.
3417 -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] MUST
3418 -- NOT be generated in this case because a unit cannot depend on its
3419 -- own elaboration. This case is therefore treated as valid prior
3422 elsif Has_Prior_Elaboration
3423 (Unit_Id => Unit_Id,
3424 Same_Unit_OK => True,
3425 Elab_Body_OK => Prag_Nam = Name_Elaborate)
3429 -- Suggest the use of pragma Prag_Nam when the dynamic model is in
3432 elsif Dynamic_Elaboration_Checks then
3433 Ensure_Prior_Elaboration_Dynamic
3436 Prag_Nam => Prag_Nam);
3438 -- Install an implicit pragma Prag_Nam when the static model is in
3442 pragma Assert (Static_Elaboration_Checks);
3444 Ensure_Prior_Elaboration_Static
3447 Prag_Nam => Prag_Nam);
3449 end Ensure_Prior_Elaboration;
3451 --------------------------------------
3452 -- Ensure_Prior_Elaboration_Dynamic --
3453 --------------------------------------
3455 procedure Ensure_Prior_Elaboration_Dynamic
3457 Unit_Id : Entity_Id;
3460 procedure Info_Missing_Pragma;
3461 pragma Inline (Info_Missing_Pragma);
3462 -- Output information concerning missing Elaborate or Elaborate_All
3463 -- pragma with name Prag_Nam for scenario N, which would ensure the
3464 -- prior elaboration of Unit_Id.
3466 -------------------------
3467 -- Info_Missing_Pragma --
3468 -------------------------
3470 procedure Info_Missing_Pragma is
3472 -- Internal units are ignored as they cause unnecessary noise
3474 if not In_Internal_Unit (Unit_Id) then
3476 -- The name of the unit subjected to the elaboration pragma is
3477 -- fully qualified to improve the clarity of the info message.
3479 Error_Msg_Name_1 := Prag_Nam;
3480 Error_Msg_Qual_Level := Nat'Last;
3482 Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id);
3483 Error_Msg_Qual_Level := 0;
3485 end Info_Missing_Pragma;
3489 Elab_Attrs : Elaboration_Attributes;
3490 Level : Enclosing_Level_Kind;
3492 -- Start of processing for Ensure_Prior_Elaboration_Dynamic
3495 Elab_Attrs := Elaboration_Status (Unit_Id);
3497 -- Nothing to do when the unit is guaranteed prior elaboration by means
3498 -- of a source Elaborate[_All] pragma.
3500 if Present (Elab_Attrs.Source_Pragma) then
3504 -- Output extra information on a missing Elaborate[_All] pragma when
3505 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas
3508 if Elab_Info_Messages then
3510 -- Performance note: parent traversal
3512 Level := Find_Enclosing_Level (N);
3514 -- Declaration-level scenario
3516 if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N))
3517 and then Level = Declaration_Level
3521 -- Library-level scenario
3523 elsif Level in Library_Level then
3526 -- Instantiation library-level scenario
3528 elsif Level = Instantiation then
3531 -- Otherwise the scenario does not appear at the proper level and
3532 -- cannot possibly act as a top-level scenario.
3538 Info_Missing_Pragma;
3540 end Ensure_Prior_Elaboration_Dynamic;
3542 -------------------------------------
3543 -- Ensure_Prior_Elaboration_Static --
3544 -------------------------------------
3546 procedure Ensure_Prior_Elaboration_Static
3548 Unit_Id : Entity_Id;
3551 function Find_With_Clause
3553 Withed_Id : Entity_Id) return Node_Id;
3554 pragma Inline (Find_With_Clause);
3555 -- Find a nonlimited with clause in the list of context items Items
3556 -- that withs unit Withed_Id. Return Empty if no such clause is found.
3558 procedure Info_Implicit_Pragma;
3559 pragma Inline (Info_Implicit_Pragma);
3560 -- Output information concerning an implicitly generated Elaborate or
3561 -- Elaborate_All pragma with name Prag_Nam for scenario N which ensures
3562 -- the prior elaboration of unit Unit_Id.
3564 ----------------------
3565 -- Find_With_Clause --
3566 ----------------------
3568 function Find_With_Clause
3570 Withed_Id : Entity_Id) return Node_Id
3575 -- Examine the context clauses looking for a suitable with. Note that
3576 -- limited clauses do not affect the elaboration order.
3578 Item := First (Items);
3579 while Present (Item) loop
3580 if Nkind (Item) = N_With_Clause
3581 and then not Error_Posted (Item)
3582 and then not Limited_Present (Item)
3583 and then Entity (Name (Item)) = Withed_Id
3592 end Find_With_Clause;
3594 --------------------------
3595 -- Info_Implicit_Pragma --
3596 --------------------------
3598 procedure Info_Implicit_Pragma is
3600 -- Internal units are ignored as they cause unnecessary noise
3602 if not In_Internal_Unit (Unit_Id) then
3604 -- The name of the unit subjected to the elaboration pragma is
3605 -- fully qualified to improve the clarity of the info message.
3607 Error_Msg_Name_1 := Prag_Nam;
3608 Error_Msg_Qual_Level := Nat'Last;
3611 ("info: implicit pragma % generated for unit &", N, Unit_Id);
3613 Error_Msg_Qual_Level := 0;
3614 Output_Active_Scenarios (N);
3616 end Info_Implicit_Pragma;
3620 Main_Cunit : constant Node_Id := Cunit (Main_Unit);
3621 Loc : constant Source_Ptr := Sloc (Main_Cunit);
3622 Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id);
3625 Elab_Attrs : Elaboration_Attributes;
3628 -- Start of processing for Ensure_Prior_Elaboration_Static
3631 Elab_Attrs := Elaboration_Status (Unit_Id);
3633 -- Nothing to do when the unit is guaranteed prior elaboration by means
3634 -- of a source Elaborate[_All] pragma.
3636 if Present (Elab_Attrs.Source_Pragma) then
3639 -- Nothing to do when the unit has an existing implicit Elaborate[_All]
3640 -- pragma installed by a previous scenario.
3642 elsif Present (Elab_Attrs.With_Clause) then
3644 -- The unit is already guaranteed prior elaboration by means of an
3645 -- implicit Elaborate pragma, however the current scenario imposes
3646 -- a stronger requirement of Elaborate_All. "Upgrade" the existing
3647 -- pragma to match this new requirement.
3649 if Elaborate_Desirable (Elab_Attrs.With_Clause)
3650 and then Prag_Nam = Name_Elaborate_All
3652 Set_Elaborate_All_Desirable (Elab_Attrs.With_Clause);
3653 Set_Elaborate_Desirable (Elab_Attrs.With_Clause, False);
3659 -- At this point it is known that the unit has no prior elaboration
3660 -- according to pragmas and hierarchical relationships.
3662 Items := Context_Items (Main_Cunit);
3666 Set_Context_Items (Main_Cunit, Items);
3669 -- Locate the with clause for the unit. Note that there may not be a
3670 -- clause if the unit is visible through a subunit-body, body-spec, or
3671 -- spec-parent relationship.
3676 Withed_Id => Unit_Id);
3681 -- Note that adding implicit with clauses is safe because analysis,
3682 -- resolution, and expansion have already taken place and it is not
3683 -- possible to interfere with visibility.
3687 Make_With_Clause (Loc,
3688 Name => New_Occurrence_Of (Unit_Id, Loc));
3690 Set_Implicit_With (Clause);
3691 Set_Library_Unit (Clause, Unit_Cunit);
3693 Append_To (Items, Clause);
3696 -- Mark the with clause depending on the pragma required
3698 if Prag_Nam = Name_Elaborate then
3699 Set_Elaborate_Desirable (Clause);
3701 Set_Elaborate_All_Desirable (Clause);
3704 -- The implicit Elaborate[_All] ensures the prior elaboration of the
3705 -- unit. Include the unit in the elaboration context of the main unit.
3707 Set_Elaboration_Status
3708 (Unit_Id => Unit_Id,
3709 Val => Elaboration_Attributes'(Source_Pragma => Empty,
3710 With_Clause => Clause));
3712 -- Output extra information on an implicit Elaborate[_All] pragma when
3713 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas is
3716 if Elab_Info_Messages then
3717 Info_Implicit_Pragma;
3719 end Ensure_Prior_Elaboration_Static;
3721 -----------------------------
3722 -- Extract_Assignment_Name --
3723 -----------------------------
3725 function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id is
3731 -- When the name denotes an array or record component, find the whole
3734 while Nkind_In (Nam, N_Explicit_Dereference,
3735 N_Indexed_Component,
3736 N_Selected_Component,
3739 Nam := Prefix (Nam);
3743 end Extract_Assignment_Name;
3745 -----------------------------
3746 -- Extract_Call_Attributes --
3747 -----------------------------
3749 procedure Extract_Call_Attributes
3751 Target_Id : out Entity_Id;
3752 Attrs : out Call_Attributes)
3754 From_Source : Boolean;
3755 In_Declarations : Boolean;
3756 Is_Dispatching : Boolean;
3759 -- Extraction for call markers
3761 if Nkind (Call) = N_Call_Marker then
3762 Target_Id := Target (Call);
3763 From_Source := Is_Source_Call (Call);
3764 In_Declarations := Is_Declaration_Level_Node (Call);
3765 Is_Dispatching := Is_Dispatching_Call (Call);
3767 -- Extraction for entry calls, requeue, and subprogram calls
3770 pragma Assert (Nkind_In (Call, N_Entry_Call_Statement,
3772 N_Procedure_Call_Statement,
3773 N_Requeue_Statement));
3775 Target_Id := Entity (Extract_Call_Name (Call));
3776 From_Source := Comes_From_Source (Call);
3778 -- Performance note: parent traversal
3780 In_Declarations := Find_Enclosing_Level (Call) = Declaration_Level;
3782 Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement)
3783 and then Present (Controlling_Argument (Call));
3786 -- Obtain the original entry or subprogram which the target may rename
3787 -- except when the target is an instantiation. In this case the alias
3788 -- is the internally generated subprogram which appears within the the
3789 -- anonymous package created for the instantiation. Such an alias is not
3790 -- a suitable target.
3792 if not (Is_Subprogram (Target_Id)
3793 and then Is_Generic_Instance (Target_Id))
3795 Target_Id := Get_Renamed_Entity (Target_Id);
3798 -- Set all attributes
3800 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call);
3801 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call);
3802 Attrs.From_Source := From_Source;
3803 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Call);
3804 Attrs.In_Declarations := In_Declarations;
3805 Attrs.Is_Dispatching := Is_Dispatching;
3806 Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Call);
3807 end Extract_Call_Attributes;
3809 -----------------------
3810 -- Extract_Call_Name --
3811 -----------------------
3813 function Extract_Call_Name (Call : Node_Id) return Node_Id is
3819 -- When the call invokes an entry family, the name appears as an indexed
3822 if Nkind (Nam) = N_Indexed_Component then
3823 Nam := Prefix (Nam);
3826 -- When the call employs the object.operation form, the name appears as
3827 -- a selected component.
3829 if Nkind (Nam) = N_Selected_Component then
3830 Nam := Selector_Name (Nam);
3834 end Extract_Call_Name;
3836 ---------------------------------
3837 -- Extract_Instance_Attributes --
3838 ---------------------------------
3840 procedure Extract_Instance_Attributes
3841 (Exp_Inst : Node_Id;
3842 Inst_Body : out Node_Id;
3843 Inst_Decl : out Node_Id)
3845 Body_Id : Entity_Id;
3848 -- Assume that the attributes are unavailable
3853 -- Generic package or subprogram spec
3855 if Nkind_In (Exp_Inst, N_Package_Declaration,
3856 N_Subprogram_Declaration)
3858 Inst_Decl := Exp_Inst;
3859 Body_Id := Corresponding_Body (Inst_Decl);
3861 if Present (Body_Id) then
3862 Inst_Body := Unit_Declaration_Node (Body_Id);
3865 -- Generic package or subprogram body
3869 (Nkind_In (Exp_Inst, N_Package_Body, N_Subprogram_Body));
3871 Inst_Body := Exp_Inst;
3872 Inst_Decl := Unit_Declaration_Node (Corresponding_Spec (Inst_Body));
3874 end Extract_Instance_Attributes;
3876 --------------------------------------
3877 -- Extract_Instantiation_Attributes --
3878 --------------------------------------
3880 procedure Extract_Instantiation_Attributes
3881 (Exp_Inst : Node_Id;
3883 Inst_Id : out Entity_Id;
3884 Gen_Id : out Entity_Id;
3885 Attrs : out Instantiation_Attributes)
3888 Inst := Original_Node (Exp_Inst);
3889 Inst_Id := Defining_Entity (Inst);
3891 -- Traverse a possible chain of renamings to obtain the original generic
3892 -- being instantiatied.
3894 Gen_Id := Get_Renamed_Entity (Entity (Name (Inst)));
3896 -- Set all attributes
3898 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst);
3899 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Inst);
3900 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Inst);
3901 Attrs.In_Declarations := Is_Declaration_Level_Node (Inst);
3902 Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Inst);
3903 end Extract_Instantiation_Attributes;
3905 -------------------------------
3906 -- Extract_Target_Attributes --
3907 -------------------------------
3909 procedure Extract_Target_Attributes
3910 (Target_Id : Entity_Id;
3911 Attrs : out Target_Attributes)
3913 procedure Extract_Package_Or_Subprogram_Attributes
3914 (Spec_Id : out Entity_Id;
3915 Body_Decl : out Node_Id);
3916 -- Obtain the attributes associated with a package or a subprogram.
3917 -- Spec_Id is the package or subprogram. Body_Decl is the declaration
3918 -- of the corresponding package or subprogram body.
3920 procedure Extract_Protected_Entry_Attributes
3921 (Spec_Id : out Entity_Id;
3922 Body_Decl : out Node_Id;
3923 Body_Barf : out Node_Id);
3924 -- Obtain the attributes associated with a protected entry [family].
3925 -- Spec_Id is the entity of the protected body subprogram. Body_Decl
3926 -- is the declaration of Spec_Id's corresponding body. Body_Barf is
3927 -- the declaration of the barrier function body.
3929 procedure Extract_Protected_Subprogram_Attributes
3930 (Spec_Id : out Entity_Id;
3931 Body_Decl : out Node_Id);
3932 -- Obtain the attributes associated with a protected subprogram. Formal
3933 -- Spec_Id is the entity of the protected body subprogram. Body_Decl is
3934 -- the declaration of Spec_Id's corresponding body.
3936 procedure Extract_Task_Entry_Attributes
3937 (Spec_Id : out Entity_Id;
3938 Body_Decl : out Node_Id);
3939 -- Obtain the attributes associated with a task entry [family]. Formal
3940 -- Spec_Id is the entity of the task body procedure. Body_Decl is the
3941 -- declaration of Spec_Id's corresponding body.
3943 ----------------------------------------------
3944 -- Extract_Package_Or_Subprogram_Attributes --
3945 ----------------------------------------------
3947 procedure Extract_Package_Or_Subprogram_Attributes
3948 (Spec_Id : out Entity_Id;
3949 Body_Decl : out Node_Id)
3951 Body_Id : Entity_Id;
3952 Init_Id : Entity_Id;
3953 Spec_Decl : Node_Id;
3956 -- Assume that the body is not available
3959 Spec_Id := Target_Id;
3961 -- For body retrieval purposes, the entity of the initial declaration
3962 -- is that of the spec.
3966 -- The only exception to the above is a function which returns a
3967 -- constrained array type in a SPARK-to-C compilation. In this case
3968 -- the function receives a corresponding procedure which has an out
3969 -- parameter. The proper body for ABE checks and diagnostics is that
3970 -- of the procedure.
3972 if Ekind (Init_Id) = E_Function
3973 and then Rewritten_For_C (Init_Id)
3975 Init_Id := Corresponding_Procedure (Init_Id);
3978 -- Extract the attributes of the body
3980 Spec_Decl := Unit_Declaration_Node (Init_Id);
3982 -- The initial declaration is a stand alone subprogram body
3984 if Nkind (Spec_Decl) = N_Subprogram_Body then
3985 Body_Decl := Spec_Decl;
3987 -- Otherwise the package or subprogram has a spec and a completing
3990 elsif Nkind_In (Spec_Decl, N_Generic_Package_Declaration,
3991 N_Generic_Subprogram_Declaration,
3992 N_Package_Declaration,
3993 N_Subprogram_Body_Stub,
3994 N_Subprogram_Declaration)
3996 Body_Id := Corresponding_Body (Spec_Decl);
3998 if Present (Body_Id) then
3999 Body_Decl := Unit_Declaration_Node (Body_Id);
4002 end Extract_Package_Or_Subprogram_Attributes;
4004 ----------------------------------------
4005 -- Extract_Protected_Entry_Attributes --
4006 ----------------------------------------
4008 procedure Extract_Protected_Entry_Attributes
4009 (Spec_Id : out Entity_Id;
4010 Body_Decl : out Node_Id;
4011 Body_Barf : out Node_Id)
4013 Barf_Id : Entity_Id;
4014 Body_Id : Entity_Id;
4017 -- Assume that the bodies are not available
4022 -- When the entry [family] has already been expanded, it carries both
4023 -- the procedure which emulates the behavior of the entry [family] as
4024 -- well as the barrier function.
4026 if Present (Protected_Body_Subprogram (Target_Id)) then
4027 Spec_Id := Protected_Body_Subprogram (Target_Id);
4029 -- Extract the attributes of the barrier function
4033 (Unit_Declaration_Node (Barrier_Function (Target_Id)));
4035 if Present (Barf_Id) then
4036 Body_Barf := Unit_Declaration_Node (Barf_Id);
4039 -- Otherwise no expansion took place
4042 Spec_Id := Target_Id;
4045 -- Extract the attributes of the entry body
4047 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
4049 if Present (Body_Id) then
4050 Body_Decl := Unit_Declaration_Node (Body_Id);
4052 end Extract_Protected_Entry_Attributes;
4054 ---------------------------------------------
4055 -- Extract_Protected_Subprogram_Attributes --
4056 ---------------------------------------------
4058 procedure Extract_Protected_Subprogram_Attributes
4059 (Spec_Id : out Entity_Id;
4060 Body_Decl : out Node_Id)
4062 Body_Id : Entity_Id;
4065 -- Assume that the body is not available
4069 -- When the protected subprogram has already been expanded, it
4070 -- carries the subprogram which seizes the lock and invokes the
4071 -- original statements.
4073 if Present (Protected_Subprogram (Target_Id)) then
4075 Protected_Body_Subprogram (Protected_Subprogram (Target_Id));
4077 -- Otherwise no expansion took place
4080 Spec_Id := Target_Id;
4083 -- Extract the attributes of the body
4085 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
4087 if Present (Body_Id) then
4088 Body_Decl := Unit_Declaration_Node (Body_Id);
4090 end Extract_Protected_Subprogram_Attributes;
4092 -----------------------------------
4093 -- Extract_Task_Entry_Attributes --
4094 -----------------------------------
4096 procedure Extract_Task_Entry_Attributes
4097 (Spec_Id : out Entity_Id;
4098 Body_Decl : out Node_Id)
4100 Task_Typ : constant Entity_Id := Non_Private_View (Scope (Target_Id));
4101 Body_Id : Entity_Id;
4104 -- Assume that the body is not available
4108 -- The the task type has already been expanded, it carries the
4109 -- procedure which emulates the behavior of the task body.
4111 if Present (Task_Body_Procedure (Task_Typ)) then
4112 Spec_Id := Task_Body_Procedure (Task_Typ);
4114 -- Otherwise no expansion took place
4117 Spec_Id := Task_Typ;
4120 -- Extract the attributes of the body
4122 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
4124 if Present (Body_Id) then
4125 Body_Decl := Unit_Declaration_Node (Body_Id);
4127 end Extract_Task_Entry_Attributes;
4131 Prag : constant Node_Id := SPARK_Pragma (Target_Id);
4132 Body_Barf : Node_Id;
4133 Body_Decl : Node_Id;
4134 Spec_Id : Entity_Id;
4136 -- Start of processing for Extract_Target_Attributes
4139 -- Assume that the body of the barrier function is not available
4143 -- The target is a protected entry [family]
4145 if Is_Protected_Entry (Target_Id) then
4146 Extract_Protected_Entry_Attributes
4147 (Spec_Id => Spec_Id,
4148 Body_Decl => Body_Decl,
4149 Body_Barf => Body_Barf);
4151 -- The target is a protected subprogram
4153 elsif Is_Protected_Subp (Target_Id)
4154 or else Is_Protected_Body_Subp (Target_Id)
4156 Extract_Protected_Subprogram_Attributes
4157 (Spec_Id => Spec_Id,
4158 Body_Decl => Body_Decl);
4160 -- The target is a task entry [family]
4162 elsif Is_Task_Entry (Target_Id) then
4163 Extract_Task_Entry_Attributes
4164 (Spec_Id => Spec_Id,
4165 Body_Decl => Body_Decl);
4167 -- Otherwise the target is a package or a subprogram
4170 Extract_Package_Or_Subprogram_Attributes
4171 (Spec_Id => Spec_Id,
4172 Body_Decl => Body_Decl);
4175 -- Set all attributes
4177 Attrs.Body_Barf := Body_Barf;
4178 Attrs.Body_Decl := Body_Decl;
4179 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Target_Id);
4180 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Target_Id);
4181 Attrs.From_Source := Comes_From_Source (Target_Id);
4182 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Target_Id);
4183 Attrs.SPARK_Mode_On :=
4184 Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On;
4185 Attrs.Spec_Decl := Unit_Declaration_Node (Spec_Id);
4186 Attrs.Spec_Id := Spec_Id;
4187 Attrs.Unit_Id := Find_Top_Unit (Target_Id);
4189 -- At this point certain attributes should always be available
4191 pragma Assert (Present (Attrs.Spec_Decl));
4192 pragma Assert (Present (Attrs.Spec_Id));
4193 pragma Assert (Present (Attrs.Unit_Id));
4194 end Extract_Target_Attributes;
4196 -----------------------------
4197 -- Extract_Task_Attributes --
4198 -----------------------------
4200 procedure Extract_Task_Attributes
4202 Attrs : out Task_Attributes)
4204 Task_Typ : constant Entity_Id := Non_Private_View (Typ);
4206 Body_Decl : Node_Id;
4207 Body_Id : Entity_Id;
4209 Spec_Id : Entity_Id;
4212 -- Assume that the body of the task procedure is not available
4216 -- The initial declaration is that of the task body procedure
4218 Spec_Id := Get_Task_Body_Procedure (Task_Typ);
4219 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
4221 if Present (Body_Id) then
4222 Body_Decl := Unit_Declaration_Node (Body_Id);
4225 Prag := SPARK_Pragma (Task_Typ);
4227 -- Set all attributes
4229 Attrs.Body_Decl := Body_Decl;
4230 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Task_Typ);
4231 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Task_Typ);
4232 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Task_Typ);
4233 Attrs.SPARK_Mode_On :=
4234 Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On;
4235 Attrs.Spec_Id := Spec_Id;
4236 Attrs.Task_Decl := Declaration_Node (Task_Typ);
4237 Attrs.Unit_Id := Find_Top_Unit (Task_Typ);
4239 -- At this point certain attributes should always be available
4241 pragma Assert (Present (Attrs.Spec_Id));
4242 pragma Assert (Present (Attrs.Task_Decl));
4243 pragma Assert (Present (Attrs.Unit_Id));
4244 end Extract_Task_Attributes;
4246 -------------------------------------------
4247 -- Extract_Variable_Reference_Attributes --
4248 -------------------------------------------
4250 procedure Extract_Variable_Reference_Attributes
4252 Var_Id : out Entity_Id;
4253 Attrs : out Variable_Attributes)
4255 function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id;
4256 -- Obtain the ultimate renamed variable of variable Id
4258 --------------------------
4259 -- Get_Renamed_Variable --
4260 --------------------------
4262 function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id is
4267 while Present (Renamed_Entity (Ren_Id))
4268 and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity
4270 Ren_Id := Renamed_Entity (Ren_Id);
4274 end Get_Renamed_Variable;
4276 -- Start of processing for Extract_Variable_Reference_Attributes
4279 -- Extraction for variable reference markers
4281 if Nkind (Ref) = N_Variable_Reference_Marker then
4282 Var_Id := Target (Ref);
4284 -- Extraction for expanded names and identifiers
4287 Var_Id := Entity (Ref);
4290 -- Obtain the original variable which the reference mentions
4292 Var_Id := Get_Renamed_Variable (Var_Id);
4293 Attrs.Unit_Id := Find_Top_Unit (Var_Id);
4295 -- At this point certain attributes should always be available
4297 pragma Assert (Present (Attrs.Unit_Id));
4298 end Extract_Variable_Reference_Attributes;
4300 --------------------
4301 -- Find_Code_Unit --
4302 --------------------
4304 function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id is
4306 return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (N))));
4309 ----------------------------
4310 -- Find_Early_Call_Region --
4311 ----------------------------
4313 function Find_Early_Call_Region
4314 (Body_Decl : Node_Id;
4315 Assume_Elab_Body : Boolean := False;
4316 Skip_Memoization : Boolean := False) return Node_Id
4318 -- NOTE: The routines within Find_Early_Call_Region are intentionally
4319 -- unnested to avoid deep indentation of code.
4321 ECR_Found : exception;
4322 -- This exception is raised when the early call region has been found
4324 Start : Node_Id := Empty;
4325 -- The start of the early call region. This variable is updated by the
4326 -- various nested routines. Due to the use of exceptions, the variable
4327 -- must be global to the nested routines.
4329 -- The algorithm implemented in this routine attempts to find the early
4330 -- call region of a subprogram body by inspecting constructs in reverse
4331 -- declarative order, while navigating the tree. The algorithm consists
4332 -- of an Inspection phase and an Advancement phase. The pseudocode is as
4337 -- advancement phase
4340 -- The infinite loop is terminated by raising exception ECR_Found. The
4341 -- algorithm utilizes two pointers, Curr and Start, to represent the
4342 -- current construct to inspect and the start of the early call region.
4344 -- IMPORTANT: The algorithm must maintain the following invariant at all
4345 -- time for it to function properly - a nested construct is entered only
4346 -- when it contains suitable constructs. This guarantees that leaving a
4347 -- nested or encapsulating construct functions properly.
4349 -- The Inspection phase determines whether the current construct is non-
4350 -- preelaborable, and if it is, the algorithm terminates.
4352 -- The Advancement phase walks the tree in reverse declarative order,
4353 -- while entering and leaving nested and encapsulating constructs. It
4354 -- may also terminate the elaborithm. There are several special cases
4361 -- <construct N-1> <- Curr
4362 -- <construct N> <- Start
4363 -- <subprogram body>
4365 -- In the general case, a declarative or statement list is traversed in
4366 -- reverse order where Curr is the lead pointer, and Start indicates the
4367 -- last preelaborable construct.
4369 -- 2) Entering handled bodies
4371 -- package body Nested is <- Curr (2.3)
4372 -- <declarations> <- Curr (2.2)
4374 -- <statements> <- Curr (2.1)
4376 -- <construct> <- Start
4378 -- In this case, the algorithm enters a handled body by starting from
4379 -- the last statement (2.1), or the last declaration (2.2), or the body
4380 -- is consumed (2.3) because it is empty and thus preelaborable.
4382 -- 3) Entering package declarations
4384 -- package Nested is <- Curr (2.3)
4385 -- <visible declarations> <- Curr (2.2)
4387 -- <private declarations> <- Curr (2.1)
4389 -- <construct> <- Start
4391 -- In this case, the algorithm enters a package declaration by starting
4392 -- from the last private declaration (2.1), the last visible declaration
4393 -- (2.2), or the package is consumed (2.3) because it is empty and thus
4396 -- 4) Transitioning from list to list of the same construct
4398 -- Certain constructs have two eligible lists. The algorithm must thus
4399 -- transition from the second to the first list when the second list is
4402 -- declare <- Curr (4.2)
4403 -- <declarations> <- Curr (4.1)
4405 -- <statements> <- Start
4408 -- In this case, the algorithm has exhausted the second list (statements
4409 -- in the example), and continues with the last declaration (4.1) or the
4410 -- construct is consumed (4.2) because it contains only preelaborable
4413 -- 5) Transitioning from list to construct
4415 -- tack body Task is <- Curr (5.1)
4417 -- <construct 1> <- Start
4419 -- In this case, the algorithm has exhausted a list, Curr is Empty, and
4420 -- the owner of the list is consumed (5.1).
4422 -- 6) Transitioning from unit to unit
4424 -- A package body with a spec subject to pragma Elaborate_Body extends
4425 -- the possible range of the early call region to the package spec.
4427 -- package Pack is <- Curr (6.3)
4428 -- pragma Elaborate_Body; <- Curr (6.2)
4429 -- <visible declarations> <- Curr (6.2)
4431 -- <private declarations> <- Curr (6.1)
4434 -- package body Pack is <- Curr, Start
4436 -- In this case, the algorithm has reached a package body compilation
4437 -- unit whose spec is subject to pragma Elaborate_Body, or the caller
4438 -- of the algorithm has specified this behavior. This transition is
4439 -- equivalent to 3).
4441 -- 7) Transitioning from unit to termination
4443 -- Reaching a compilation unit always terminates the algorithm as there
4444 -- are no more lists to examine. This must take 6) into account.
4446 -- 8) Transitioning from subunit to stub
4448 -- package body Pack is separate; <- Curr (8.1)
4451 -- package body Pack is <- Curr, Start
4453 -- Reaching a subunit continues the search from the corresponding stub
4456 procedure Advance (Curr : in out Node_Id);
4457 pragma Inline (Advance);
4458 -- Update the Curr and Start pointers depending on their location in the
4459 -- tree to the next eligible construct. This routine raises ECR_Found.
4461 procedure Enter_Handled_Body (Curr : in out Node_Id);
4462 pragma Inline (Enter_Handled_Body);
4463 -- Update the Curr and Start pointers to enter a nested handled body if
4464 -- applicable. This routine raises ECR_Found.
4466 procedure Enter_Package_Declaration (Curr : in out Node_Id);
4467 pragma Inline (Enter_Package_Declaration);
4468 -- Update the Curr and Start pointers to enter a nested package spec if
4469 -- applicable. This routine raises ECR_Found.
4471 function Find_ECR (N : Node_Id) return Node_Id;
4472 pragma Inline (Find_ECR);
4473 -- Find an early call region starting from arbitrary node N
4475 function Has_Suitable_Construct (List : List_Id) return Boolean;
4476 pragma Inline (Has_Suitable_Construct);
4477 -- Determine whether list List contains at least one suitable construct
4478 -- for inclusion into an early call region.
4480 procedure Include (N : Node_Id; Curr : out Node_Id);
4481 pragma Inline (Include);
4482 -- Update the Curr and Start pointers to include arbitrary construct N
4483 -- in the early call region. This routine raises ECR_Found.
4485 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean;
4486 pragma Inline (Is_OK_Preelaborable_Construct);
4487 -- Determine whether arbitrary node N denotes a preelaboration-safe
4490 function Is_Suitable_Construct (N : Node_Id) return Boolean;
4491 pragma Inline (Is_Suitable_Construct);
4492 -- Determine whether arbitrary node N denotes a suitable construct for
4493 -- inclusion into the early call region.
4495 procedure Transition_Body_Declarations
4497 Curr : out Node_Id);
4498 pragma Inline (Transition_Body_Declarations);
4499 -- Update the Curr and Start pointers when construct Bod denotes a block
4500 -- statement or a suitable body. This routine raises ECR_Found.
4502 procedure Transition_Handled_Statements
4504 Curr : out Node_Id);
4505 pragma Inline (Transition_Handled_Statements);
4506 -- Update the Curr and Start pointers when node HSS denotes a handled
4507 -- sequence of statements. This routine raises ECR_Found.
4509 procedure Transition_Spec_Declarations
4511 Curr : out Node_Id);
4512 pragma Inline (Transition_Spec_Declarations);
4513 -- Update the Curr and Start pointers when construct Spec denotes
4514 -- a concurrent definition or a package spec. This routine raises
4517 procedure Transition_Unit (Unit : Node_Id; Curr : out Node_Id);
4518 pragma Inline (Transition_Unit);
4519 -- Update the Curr and Start pointers when node Unit denotes a potential
4520 -- compilation unit. This routine raises ECR_Found.
4526 procedure Advance (Curr : in out Node_Id) is
4530 -- Curr denotes one of the following cases upon entry into this
4533 -- * Empty - There is no current construct when a declarative or a
4534 -- statement list has been exhausted. This does not necessarily
4535 -- indicate that the early call region has been computed as it
4536 -- may still be possible to transition to another list.
4538 -- * Encapsulator - The current construct encapsulates declarations
4539 -- and/or statements. This indicates that the early call region
4540 -- may extend within the nested construct.
4542 -- * Preelaborable - The current construct is always preelaborable
4543 -- because Find_ECR would not invoke Advance if this was not the
4546 -- The current construct is an encapsulator or is preelaborable
4548 if Present (Curr) then
4550 -- Enter encapsulators by inspecting their declarations and/or
4553 if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then
4554 Enter_Handled_Body (Curr);
4556 elsif Nkind (Curr) = N_Package_Declaration then
4557 Enter_Package_Declaration (Curr);
4559 -- Early call regions have a property which can be exploited to
4560 -- optimize the algorithm.
4562 -- <preceding subprogram body>
4563 -- <preelaborable construct 1>
4565 -- <preelaborable construct N>
4566 -- <initiating subprogram body>
4568 -- If a traversal initiated from a subprogram body reaches a
4569 -- preceding subprogram body, then both bodies share the same
4570 -- early call region.
4572 -- The property results in the following desirable effects:
4574 -- * If the preceding body already has an early call region, then
4575 -- the initiating body can reuse it. This minimizes the amount
4576 -- of processing performed by the algorithm.
4578 -- * If the preceding body lack an early call region, then the
4579 -- algorithm can compute the early call region, and reuse it
4580 -- for the initiating body. This processing performs the same
4581 -- amount of work, but has the beneficial effect of computing
4582 -- the early call regions of all preceding bodies.
4584 elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then
4586 Find_Early_Call_Region
4588 Assume_Elab_Body => Assume_Elab_Body,
4589 Skip_Memoization => Skip_Memoization);
4593 -- Otherwise current construct is preelaborable. Unpdate the early
4594 -- call region to include it.
4597 Include (Curr, Curr);
4600 -- Otherwise the current construct is missing, indicating that the
4601 -- current list has been exhausted. Depending on the context of the
4602 -- list, several transitions are possible.
4605 -- The invariant of the algorithm ensures that Curr and Start are
4606 -- at the same level of nesting at the point of a transition. The
4607 -- algorithm can determine which list the traversal came from by
4610 Context := Parent (Start);
4612 -- Attempt the following transitions:
4614 -- private declarations -> visible declarations
4615 -- private declarations -> upper level
4616 -- private declarations -> terminate
4617 -- visible declarations -> upper level
4618 -- visible declarations -> terminate
4620 if Nkind_In (Context, N_Package_Specification,
4621 N_Protected_Definition,
4624 Transition_Spec_Declarations (Context, Curr);
4626 -- Attempt the following transitions:
4628 -- statements -> declarations
4629 -- statements -> upper level
4630 -- statements -> corresponding package spec (Elab_Body)
4631 -- statements -> terminate
4633 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
4634 Transition_Handled_Statements (Context, Curr);
4636 -- Attempt the following transitions:
4638 -- declarations -> upper level
4639 -- declarations -> corresponding package spec (Elab_Body)
4640 -- declarations -> terminate
4642 elsif Nkind_In (Context, N_Block_Statement,
4649 Transition_Body_Declarations (Context, Curr);
4651 -- Otherwise it is not possible to transition. Stop the search
4652 -- because there are no more declarations or statements to check.
4660 --------------------------
4661 -- Enter_Handled_Body --
4662 --------------------------
4664 procedure Enter_Handled_Body (Curr : in out Node_Id) is
4665 Decls : constant List_Id := Declarations (Curr);
4666 HSS : constant Node_Id := Handled_Statement_Sequence (Curr);
4667 Stmts : List_Id := No_List;
4670 if Present (HSS) then
4671 Stmts := Statements (HSS);
4674 -- The handled body has a non-empty statement sequence. The construct
4675 -- to inspect is the last statement.
4677 if Has_Suitable_Construct (Stmts) then
4678 Curr := Last (Stmts);
4680 -- The handled body lacks statements, but has non-empty declarations.
4681 -- The construct to inspect is the last declaration.
4683 elsif Has_Suitable_Construct (Decls) then
4684 Curr := Last (Decls);
4686 -- Otherwise the handled body lacks both declarations and statements.
4687 -- The construct to inspect is the node which precedes the handled
4688 -- body. Update the early call region to include the handled body.
4691 Include (Curr, Curr);
4693 end Enter_Handled_Body;
4695 -------------------------------
4696 -- Enter_Package_Declaration --
4697 -------------------------------
4699 procedure Enter_Package_Declaration (Curr : in out Node_Id) is
4700 Pack_Spec : constant Node_Id := Specification (Curr);
4701 Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec);
4702 Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec);
4705 -- The package has a non-empty private declarations. The construct to
4706 -- inspect is the last private declaration.
4708 if Has_Suitable_Construct (Prv_Decls) then
4709 Curr := Last (Prv_Decls);
4711 -- The package lacks private declarations, but has non-empty visible
4712 -- declarations. In this case the construct to inspect is the last
4713 -- visible declaration.
4715 elsif Has_Suitable_Construct (Vis_Decls) then
4716 Curr := Last (Vis_Decls);
4718 -- Otherwise the package lacks any declarations. The construct to
4719 -- inspect is the node which precedes the package. Update the early
4720 -- call region to include the package declaration.
4723 Include (Curr, Curr);
4725 end Enter_Package_Declaration;
4731 function Find_ECR (N : Node_Id) return Node_Id is
4735 -- The early call region starts at N
4740 -- Inspect each node in reverse declarative order while going in and
4741 -- out of nested and enclosing constructs. Note that the only way to
4742 -- terminate this infinite loop is to raise exception ECR_Found.
4745 -- The current construct is not preelaboration-safe. Terminate the
4749 and then not Is_OK_Preelaborable_Construct (Curr)
4754 -- Advance to the next suitable construct. This may terminate the
4755 -- traversal by raising ECR_Found.
4765 ----------------------------
4766 -- Has_Suitable_Construct --
4767 ----------------------------
4769 function Has_Suitable_Construct (List : List_Id) return Boolean is
4773 -- Examine the list in reverse declarative order, looking for a
4774 -- suitable construct.
4776 if Present (List) then
4777 Item := Last (List);
4778 while Present (Item) loop
4779 if Is_Suitable_Construct (Item) then
4788 end Has_Suitable_Construct;
4794 procedure Include (N : Node_Id; Curr : out Node_Id) is
4798 -- The input node is a compilation unit. This terminates the search
4799 -- because there are no more lists to inspect and there are no more
4800 -- enclosing constructs to climb up to. The transitions are:
4802 -- private declarations -> terminate
4803 -- visible declarations -> terminate
4804 -- statements -> terminate
4805 -- declarations -> terminate
4807 if Nkind (Parent (Start)) = N_Compilation_Unit then
4810 -- Otherwise the input node is still within some list
4813 Curr := Prev (Start);
4817 -----------------------------------
4818 -- Is_OK_Preelaborable_Construct --
4819 -----------------------------------
4821 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is
4823 -- Assignment statements are acceptable as long as they were produced
4824 -- by the ABE mechanism to update elaboration flags.
4826 if Nkind (N) = N_Assignment_Statement then
4827 return Is_Elaboration_Code (N);
4829 -- Block statements are acceptable even though they directly violate
4830 -- preelaborability. The intention is not to penalize the early call
4831 -- region when a block contains only preelaborable constructs.
4834 -- Val : constant Integer := 1;
4836 -- pragma Assert (Val = 1);
4840 -- Note that the Advancement phase does enter blocks, and will detect
4841 -- any non-preelaborable declarations or statements within.
4843 elsif Nkind (N) = N_Block_Statement then
4847 -- Otherwise the construct must be preelaborable. The check must take
4848 -- the syntactic and semantic structure of the construct. DO NOT use
4849 -- Is_Preelaborable_Construct here.
4851 return not Is_Non_Preelaborable_Construct (N);
4852 end Is_OK_Preelaborable_Construct;
4854 ---------------------------
4855 -- Is_Suitable_Construct --
4856 ---------------------------
4858 function Is_Suitable_Construct (N : Node_Id) return Boolean is
4859 Context : constant Node_Id := Parent (N);
4862 -- An internally-generated statement sequence which contains only a
4863 -- single null statement is not a suitable construct because it is a
4864 -- byproduct of the parser. Such a null statement should be excluded
4865 -- from the early call region because it carries the source location
4866 -- of the "end" keyword, and may lead to confusing diagnistics.
4868 if Nkind (N) = N_Null_Statement
4869 and then not Comes_From_Source (N)
4870 and then Present (Context)
4871 and then Nkind (Context) = N_Handled_Sequence_Of_Statements
4872 and then not Comes_From_Source (N)
4877 -- Otherwise only constructs which correspond to pure Ada constructs
4878 -- are considered suitable.
4883 | N_Freeze_Generic_Entity
4884 | N_Implicit_Label_Declaration
4886 | N_Pop_Constraint_Error_Label
4887 | N_Pop_Program_Error_Label
4888 | N_Pop_Storage_Error_Label
4889 | N_Push_Constraint_Error_Label
4890 | N_Push_Program_Error_Label
4891 | N_Push_Storage_Error_Label
4892 | N_SCIL_Dispatch_Table_Tag_Init
4893 | N_SCIL_Dispatching_Call
4894 | N_SCIL_Membership_Test
4895 | N_Variable_Reference_Marker
4902 end Is_Suitable_Construct;
4904 ----------------------------------
4905 -- Transition_Body_Declarations --
4906 ----------------------------------
4908 procedure Transition_Body_Declarations
4912 Decls : constant List_Id := Declarations (Bod);
4915 -- The search must come from the declarations of the body
4918 (Is_Non_Empty_List (Decls)
4919 and then List_Containing (Start) = Decls);
4921 -- The search finished inspecting the declarations. The construct
4922 -- to inspect is the node which precedes the handled body, unless
4923 -- the body is a compilation unit. The transitions are:
4925 -- declarations -> upper level
4926 -- declarations -> corresponding package spec (Elab_Body)
4927 -- declarations -> terminate
4929 Transition_Unit (Bod, Curr);
4930 end Transition_Body_Declarations;
4932 -----------------------------------
4933 -- Transition_Handled_Statements --
4934 -----------------------------------
4936 procedure Transition_Handled_Statements
4940 Bod : constant Node_Id := Parent (HSS);
4941 Decls : constant List_Id := Declarations (Bod);
4942 Stmts : constant List_Id := Statements (HSS);
4945 -- The search must come from the statements of certain bodies or
4948 pragma Assert (Nkind_In (Bod, N_Block_Statement,
4955 -- The search must come from the statements of the handled sequence
4958 (Is_Non_Empty_List (Stmts)
4959 and then List_Containing (Start) = Stmts);
4961 -- The search finished inspecting the statements. The handled body
4962 -- has non-empty declarations. The construct to inspect is the last
4963 -- declaration. The transitions are:
4965 -- statements -> declarations
4967 if Has_Suitable_Construct (Decls) then
4968 Curr := Last (Decls);
4970 -- Otherwise the handled body lacks declarations. The construct to
4971 -- inspect is the node which precedes the handled body, unless the
4972 -- body is a compilation unit. The transitions are:
4974 -- statements -> upper level
4975 -- statements -> corresponding package spec (Elab_Body)
4976 -- statements -> terminate
4979 Transition_Unit (Bod, Curr);
4981 end Transition_Handled_Statements;
4983 ----------------------------------
4984 -- Transition_Spec_Declarations --
4985 ----------------------------------
4987 procedure Transition_Spec_Declarations
4991 Prv_Decls : constant List_Id := Private_Declarations (Spec);
4992 Vis_Decls : constant List_Id := Visible_Declarations (Spec);
4995 pragma Assert (Present (Start) and then Is_List_Member (Start));
4997 -- The search came from the private declarations and finished their
5000 if Has_Suitable_Construct (Prv_Decls)
5001 and then List_Containing (Start) = Prv_Decls
5003 -- The context has non-empty visible declarations. The node to
5004 -- inspect is the last visible declaration. The transitions are:
5006 -- private declarations -> visible declarations
5008 if Has_Suitable_Construct (Vis_Decls) then
5009 Curr := Last (Vis_Decls);
5011 -- Otherwise the context lacks visible declarations. The construct
5012 -- to inspect is the node which precedes the context unless the
5013 -- context is a compilation unit. The transitions are:
5015 -- private declarations -> upper level
5016 -- private declarations -> terminate
5019 Transition_Unit (Parent (Spec), Curr);
5022 -- The search came from the visible declarations and finished their
5023 -- inspections. The construct to inspect is the node which precedes
5024 -- the context, unless the context is a compilaton unit. The
5027 -- visible declarations -> upper level
5028 -- visible declarations -> terminate
5030 elsif Has_Suitable_Construct (Vis_Decls)
5031 and then List_Containing (Start) = Vis_Decls
5033 Transition_Unit (Parent (Spec), Curr);
5035 -- At this point both declarative lists are empty, but the traversal
5036 -- still came from within the spec. This indicates that the invariant
5037 -- of the algorithm has been violated.
5040 pragma Assert (False);
5043 end Transition_Spec_Declarations;
5045 ---------------------
5046 -- Transition_Unit --
5047 ---------------------
5049 procedure Transition_Unit
5053 Context : constant Node_Id := Parent (Unit);
5056 -- The unit is a compilation unit. This terminates the search because
5057 -- there are no more lists to inspect and there are no more enclosing
5058 -- constructs to climb up to.
5060 if Nkind (Context) = N_Compilation_Unit then
5062 -- A package body with a corresponding spec subject to pragma
5063 -- Elaborate_Body is an exception to the above. The annotation
5064 -- allows the search to continue into the package declaration.
5065 -- The transitions are:
5067 -- statements -> corresponding package spec (Elab_Body)
5068 -- declarations -> corresponding package spec (Elab_Body)
5070 if Nkind (Unit) = N_Package_Body
5071 and then (Assume_Elab_Body
5072 or else Has_Pragma_Elaborate_Body
5073 (Corresponding_Spec (Unit)))
5075 Curr := Unit_Declaration_Node (Corresponding_Spec (Unit));
5076 Enter_Package_Declaration (Curr);
5078 -- Otherwise terminate the search. The transitions are:
5080 -- private declarations -> terminate
5081 -- visible declarations -> terminate
5082 -- statements -> terminate
5083 -- declarations -> terminate
5089 -- The unit is a subunit. The construct to inspect is the node which
5090 -- precedes the corresponding stub. Update the early call region to
5091 -- include the unit.
5093 elsif Nkind (Context) = N_Subunit then
5095 Curr := Corresponding_Stub (Context);
5097 -- Otherwise the unit is nested. The construct to inspect is the node
5098 -- which precedes the unit. Update the early call region to include
5102 Include (Unit, Curr);
5104 end Transition_Unit;
5108 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
5111 -- Start of processing for Find_Early_Call_Region
5114 -- The caller demands the start of the early call region without saving
5115 -- or retrieving it to/from internal data structures.
5117 if Skip_Memoization then
5118 Region := Find_ECR (Body_Decl);
5123 -- Check whether the early call region of the subprogram body is
5126 Region := Early_Call_Region (Body_Id);
5130 -- Traverse the declarations in reverse order, starting from the
5131 -- subprogram body, searching for the nearest non-preelaborable
5132 -- construct. The early call region starts after this construct
5133 -- and ends at the subprogram body.
5135 Region := Find_ECR (Body_Decl);
5137 -- Associate the early call region with the subprogram body in
5138 -- case other scenarios need it.
5140 Set_Early_Call_Region (Body_Id, Region);
5144 -- A subprogram body must always have an early call region
5146 pragma Assert (Present (Region));
5149 end Find_Early_Call_Region;
5151 ---------------------------
5152 -- Find_Elaborated_Units --
5153 ---------------------------
5155 procedure Find_Elaborated_Units is
5156 procedure Add_Pragma (Prag : Node_Id);
5157 -- Determine whether pragma Prag denotes a legal Elaborate[_All] pragma.
5158 -- If this is the case, add the related unit to the elaboration context.
5159 -- For pragma Elaborate_All, include recursively all units withed by the
5163 (Unit_Id : Entity_Id;
5165 Full_Context : Boolean);
5166 -- Add unit Unit_Id to the elaboration context. Prag denotes the pragma
5167 -- which prompted the inclusion of the unit to the elaboration context.
5168 -- If flag Full_Context is set, examine the nonlimited clauses of unit
5169 -- Unit_Id and add each withed unit to the context.
5171 procedure Find_Elaboration_Context (Comp_Unit : Node_Id);
5172 -- Examine the context items of compilation unit Comp_Unit for suitable
5173 -- elaboration-related pragmas and add all related units to the context.
5179 procedure Add_Pragma (Prag : Node_Id) is
5180 Prag_Args : constant List_Id := Pragma_Argument_Associations (Prag);
5181 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
5185 -- Nothing to do if the pragma is not related to elaboration
5187 if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then
5190 -- Nothing to do when the pragma is illegal
5192 elsif Error_Posted (Prag) then
5196 Unit_Arg := Get_Pragma_Arg (First (Prag_Args));
5198 -- The argument of the pragma may appear in package.package form
5200 if Nkind (Unit_Arg) = N_Selected_Component then
5201 Unit_Arg := Selector_Name (Unit_Arg);
5205 (Unit_Id => Entity (Unit_Arg),
5207 Full_Context => Prag_Nam = Name_Elaborate_All);
5215 (Unit_Id : Entity_Id;
5217 Full_Context : Boolean)
5220 Elab_Attrs : Elaboration_Attributes;
5223 -- Nothing to do when some previous error left a with clause or a
5224 -- pragma in a bad state.
5226 if No (Unit_Id) then
5230 Elab_Attrs := Elaboration_Status (Unit_Id);
5232 -- The unit is already included in the context by means of pragma
5235 if Present (Elab_Attrs.Source_Pragma) then
5237 -- Upgrade an existing pragma Elaborate when the unit is subject
5238 -- to Elaborate_All because the new pragma covers a larger set of
5241 if Pragma_Name (Elab_Attrs.Source_Pragma) = Name_Elaborate
5242 and then Pragma_Name (Prag) = Name_Elaborate_All
5244 Elab_Attrs.Source_Pragma := Prag;
5246 -- Otherwise the unit retains its existing pragma and does not
5247 -- need to be included in the context again.
5253 -- The current unit is not part of the context. Prepare a new set of
5258 Elaboration_Attributes'(Source_Pragma => Prag,
5259 With_Clause => Empty);
5262 -- Add or update the attributes of the unit
5264 Set_Elaboration_Status (Unit_Id, Elab_Attrs);
5266 -- Includes all units withed by the current one when computing the
5269 if Full_Context then
5271 -- Process all nonlimited with clauses found in the context of
5272 -- the current unit. Note that limited clauses do not impose an
5273 -- elaboration order.
5275 Clause := First (Context_Items (Compilation_Unit (Unit_Id)));
5276 while Present (Clause) loop
5277 if Nkind (Clause) = N_With_Clause
5278 and then not Error_Posted (Clause)
5279 and then not Limited_Present (Clause)
5282 (Unit_Id => Entity (Name (Clause)),
5284 Full_Context => Full_Context);
5292 ------------------------------
5293 -- Find_Elaboration_Context --
5294 ------------------------------
5296 procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is
5300 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit);
5302 -- Process all elaboration-related pragmas found in the context of
5303 -- the compilation unit.
5305 Prag := First (Context_Items (Comp_Unit));
5306 while Present (Prag) loop
5307 if Nkind (Prag) = N_Pragma then
5313 end Find_Elaboration_Context;
5320 -- Start of processing for Find_Elaborated_Units
5323 -- Perform a traversal which examines the context of the main unit and
5324 -- populates the Elaboration_Context table with all units elaborated
5325 -- prior to the main unit. The traversal performs the following jumps:
5327 -- subunit -> parent subunit
5328 -- parent subunit -> body
5330 -- spec -> parent spec
5331 -- parent spec -> grandparent spec and so on
5333 -- The traversal relies on units rather than scopes because the scope of
5334 -- a subunit is some spec, while this traversal must process the body as
5335 -- well. Given that protected and task bodies can also be subunits, this
5336 -- complicates the scope approach even further.
5338 Unt := Unit (Cunit (Main_Unit));
5340 -- Perform the following traversals when the main unit is a subunit
5342 -- subunit -> parent subunit
5343 -- parent subunit -> body
5345 while Present (Unt) and then Nkind (Unt) = N_Subunit loop
5346 Find_Elaboration_Context (Parent (Unt));
5348 -- Continue the traversal by going to the unit which contains the
5349 -- corresponding stub.
5351 if Present (Corresponding_Stub (Unt)) then
5352 Unt := Unit (Cunit (Get_Source_Unit (Corresponding_Stub (Unt))));
5354 -- Otherwise the subunit may be erroneous or left in a bad state
5361 -- Perform the following traversal now that subunits have been taken
5362 -- care of, or the main unit is a body.
5367 and then Nkind_In (Unt, N_Package_Body, N_Subprogram_Body)
5369 Find_Elaboration_Context (Parent (Unt));
5371 -- Continue the traversal by going to the unit which contains the
5372 -- corresponding spec.
5374 if Present (Corresponding_Spec (Unt)) then
5375 Unt := Unit (Cunit (Get_Source_Unit (Corresponding_Spec (Unt))));
5379 -- Perform the following traversals now that the body has been taken
5380 -- care of, or the main unit is a spec.
5382 -- spec -> parent spec
5383 -- parent spec -> grandparent spec and so on
5386 and then Nkind_In (Unt, N_Generic_Package_Declaration,
5387 N_Generic_Subprogram_Declaration,
5388 N_Package_Declaration,
5389 N_Subprogram_Declaration)
5391 Find_Elaboration_Context (Parent (Unt));
5393 -- Process a potential chain of parent units which ends with the
5394 -- main unit spec. The traversal can now safely rely on the scope
5397 Par_Id := Scope (Defining_Entity (Unt));
5398 while Present (Par_Id) and then Par_Id /= Standard_Standard loop
5399 Find_Elaboration_Context (Compilation_Unit (Par_Id));
5401 Par_Id := Scope (Par_Id);
5404 end Find_Elaborated_Units;
5406 -----------------------------
5407 -- Find_Enclosing_Instance --
5408 -----------------------------
5410 function Find_Enclosing_Instance (N : Node_Id) return Node_Id is
5412 Spec_Id : Entity_Id;
5415 -- Climb the parent chain looking for an enclosing instance spec or body
5418 while Present (Par) loop
5420 -- Generic package or subprogram spec
5422 if Nkind_In (Par, N_Package_Declaration,
5423 N_Subprogram_Declaration)
5424 and then Is_Generic_Instance (Defining_Entity (Par))
5428 -- Generic package or subprogram body
5430 elsif Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then
5431 Spec_Id := Corresponding_Spec (Par);
5433 if Present (Spec_Id) and then Is_Generic_Instance (Spec_Id) then
5438 Par := Parent (Par);
5442 end Find_Enclosing_Instance;
5444 --------------------------
5445 -- Find_Enclosing_Level --
5446 --------------------------
5448 function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind is
5449 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind;
5450 -- Obtain the corresponding level of unit Unit
5456 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind is
5457 Spec_Id : Entity_Id;
5460 if Nkind (Unit) in N_Generic_Instantiation then
5461 return Instantiation;
5463 elsif Nkind (Unit) = N_Generic_Package_Declaration then
5464 return Generic_Package_Spec;
5466 elsif Nkind (Unit) = N_Package_Declaration then
5467 return Package_Spec;
5469 elsif Nkind (Unit) = N_Package_Body then
5470 Spec_Id := Corresponding_Spec (Unit);
5472 -- The body belongs to a generic package
5474 if Present (Spec_Id)
5475 and then Ekind (Spec_Id) = E_Generic_Package
5477 return Generic_Package_Body;
5479 -- Otherwise the body belongs to a non-generic package. This also
5480 -- treats an illegal package body without a corresponding spec as
5481 -- a non-generic package body.
5484 return Package_Body;
5497 -- Start of processing for Find_Enclosing_Level
5500 -- Call markers and instantiations which appear at the declaration level
5501 -- but are later relocated in a different context retain their original
5502 -- declaration level.
5504 if Nkind_In (N, N_Call_Marker,
5505 N_Function_Instantiation,
5506 N_Package_Instantiation,
5507 N_Procedure_Instantiation)
5508 and then Is_Declaration_Level_Node (N)
5510 return Declaration_Level;
5513 -- Climb the parent chain looking at the enclosing levels
5516 Curr := Parent (Prev);
5517 while Present (Curr) loop
5519 -- A traversal from a subunit continues via the corresponding stub
5521 if Nkind (Curr) = N_Subunit then
5522 Curr := Corresponding_Stub (Curr);
5524 -- The current construct is a package. Packages are ignored because
5525 -- they are always elaborated when the enclosing context is invoked
5528 elsif Nkind_In (Curr, N_Package_Body, N_Package_Declaration) then
5531 -- The current construct is a block statement
5533 elsif Nkind (Curr) = N_Block_Statement then
5535 -- Ignore internally generated blocks created by the expander for
5536 -- various purposes such as abort defer/undefer.
5538 if not Comes_From_Source (Curr) then
5541 -- If the traversal came from the handled sequence of statments,
5542 -- then the node appears at the level of the enclosing construct.
5543 -- This is a more reliable test because transients scopes within
5544 -- the declarative region of the encapsulator are hard to detect.
5546 elsif Nkind (Prev) = N_Handled_Sequence_Of_Statements
5547 and then Handled_Statement_Sequence (Curr) = Prev
5549 return Find_Enclosing_Level (Parent (Curr));
5551 -- Otherwise the traversal came from the declarations, the node is
5552 -- at the declaration level.
5555 return Declaration_Level;
5558 -- The current construct is a declaration-level encapsulator
5560 elsif Nkind_In (Curr, N_Entry_Body,
5564 -- If the traversal came from the handled sequence of statments,
5565 -- then the node cannot possibly appear at any level. This is
5566 -- a more reliable test because transients scopes within the
5567 -- declarative region of the encapsulator are hard to detect.
5569 if Nkind (Prev) = N_Handled_Sequence_Of_Statements
5570 and then Handled_Statement_Sequence (Curr) = Prev
5574 -- Otherwise the traversal came from the declarations, the node is
5575 -- at the declaration level.
5578 return Declaration_Level;
5581 -- The current construct is a non-library-level encapsulator which
5582 -- indicates that the node cannot possibly appear at any level.
5583 -- Note that this check must come after the declaration-level check
5584 -- because both predicates share certain nodes.
5586 elsif Is_Non_Library_Level_Encapsulator (Curr) then
5587 Context := Parent (Curr);
5589 -- The sole exception is when the encapsulator is the compilation
5590 -- utit itself because the compilation unit node requires special
5591 -- processing (see below).
5593 if Present (Context)
5594 and then Nkind (Context) = N_Compilation_Unit
5598 -- Otherwise the node is not at any level
5604 -- The current construct is a compilation unit. The node appears at
5605 -- the [generic] library level when the unit is a [generic] package.
5607 elsif Nkind (Curr) = N_Compilation_Unit then
5608 return Level_Of (Unit (Curr));
5612 Curr := Parent (Prev);
5616 end Find_Enclosing_Level;
5622 function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id is
5624 return Find_Unit_Entity (Unit (Cunit (Get_Top_Level_Code_Unit (N))));
5627 ----------------------
5628 -- Find_Unit_Entity --
5629 ----------------------
5631 function Find_Unit_Entity (N : Node_Id) return Entity_Id is
5632 Context : constant Node_Id := Parent (N);
5633 Orig_N : constant Node_Id := Original_Node (N);
5636 -- The unit denotes a package body of an instantiation which acts as
5637 -- a compilation unit. The proper entity is that of the package spec.
5639 if Nkind (N) = N_Package_Body
5640 and then Nkind (Orig_N) = N_Package_Instantiation
5641 and then Nkind (Context) = N_Compilation_Unit
5643 return Corresponding_Spec (N);
5645 -- The unit denotes an anonymous package created to wrap a subprogram
5646 -- instantiation which acts as a compilation unit. The proper entity is
5647 -- that of the "related instance".
5649 elsif Nkind (N) = N_Package_Declaration
5650 and then Nkind_In (Orig_N, N_Function_Instantiation,
5651 N_Procedure_Instantiation)
5652 and then Nkind (Context) = N_Compilation_Unit
5655 Related_Instance (Defining_Entity (N, Concurrent_Subunit => True));
5657 -- Otherwise the proper entity is the defining entity
5660 return Defining_Entity (N, Concurrent_Subunit => True);
5662 end Find_Unit_Entity;
5664 -----------------------
5665 -- First_Formal_Type --
5666 -----------------------
5668 function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id is
5669 Formal_Id : constant Entity_Id := First_Formal (Subp_Id);
5673 if Present (Formal_Id) then
5674 Typ := Etype (Formal_Id);
5676 -- Handle various combinations of concurrent and private types
5679 if Ekind_In (Typ, E_Protected_Type, E_Task_Type)
5680 and then Present (Anonymous_Object (Typ))
5682 Typ := Anonymous_Object (Typ);
5684 elsif Is_Concurrent_Record_Type (Typ) then
5685 Typ := Corresponding_Concurrent_Type (Typ);
5687 elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
5688 Typ := Full_View (Typ);
5699 end First_Formal_Type;
5705 function Has_Body (Pack_Decl : Node_Id) return Boolean is
5706 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id;
5707 -- Try to locate the corresponding body of spec Spec_Id. If no body is
5708 -- found, return Empty.
5711 (Spec_Id : Entity_Id;
5712 From : Node_Id) return Node_Id;
5713 -- Try to locate the corresponding body of spec Spec_Id in the node list
5714 -- which follows arbitrary node From. If no body is found, return Empty.
5716 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id;
5717 -- Attempt to load the body of unit Unit_Nam. If the load failed, return
5718 -- Empty. If the compilation will not generate code, return Empty.
5720 -----------------------------
5721 -- Find_Corresponding_Body --
5722 -----------------------------
5724 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id is
5725 Context : constant Entity_Id := Scope (Spec_Id);
5726 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
5727 Body_Decl : Node_Id;
5728 Body_Id : Entity_Id;
5731 if Is_Compilation_Unit (Spec_Id) then
5732 Body_Id := Corresponding_Body (Spec_Decl);
5734 if Present (Body_Id) then
5735 return Unit_Declaration_Node (Body_Id);
5737 -- The package is at the library and requires a body. Load the
5738 -- corresponding body because the optional body may be declared
5741 elsif Unit_Requires_Body (Spec_Id) then
5744 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec_Decl))));
5746 -- Otherwise there is no optional body
5752 -- The immediate context is a package. The optional body may be
5753 -- within the body of that package.
5755 -- procedure Proc is
5756 -- package Nested_1 is
5757 -- package Nested_2 is
5764 -- package body Nested_1 is
5765 -- package body Nested_2 is separate;
5768 -- separate (Proc.Nested_1.Nested_2)
5769 -- package body Nested_2 is
5770 -- package body Pack is -- optional body
5775 elsif Is_Package_Or_Generic_Package (Context) then
5776 Body_Decl := Find_Corresponding_Body (Context);
5778 -- The optional body is within the body of the enclosing package
5780 if Present (Body_Decl) then
5783 (Spec_Id => Spec_Id,
5784 From => First (Declarations (Body_Decl)));
5786 -- Otherwise the enclosing package does not have a body. This may
5787 -- be the result of an error or a genuine lack of a body.
5793 -- Otherwise the immediate context is a body. The optional body may
5794 -- be within the same list as the spec.
5796 -- procedure Proc is
5801 -- package body Pack is -- optional body
5808 (Spec_Id => Spec_Id,
5809 From => Next (Spec_Decl));
5811 end Find_Corresponding_Body;
5818 (Spec_Id : Entity_Id;
5819 From : Node_Id) return Node_Id
5821 Spec_Nam : constant Name_Id := Chars (Spec_Id);
5827 while Present (Item) loop
5829 -- The current item denotes the optional body
5831 if Nkind (Item) = N_Package_Body
5832 and then Chars (Defining_Entity (Item)) = Spec_Nam
5836 -- The current item denotes a stub, the optional body may be in
5839 elsif Nkind (Item) = N_Package_Body_Stub
5840 and then Chars (Defining_Entity (Item)) = Spec_Nam
5842 Lib_Unit := Library_Unit (Item);
5844 -- The corresponding subunit was previously loaded
5846 if Present (Lib_Unit) then
5849 -- Otherwise attempt to load the corresponding subunit
5852 return Load_Package_Body (Get_Unit_Name (Item));
5862 -----------------------
5863 -- Load_Package_Body --
5864 -----------------------
5866 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id is
5867 Body_Decl : Node_Id;
5868 Unit_Num : Unit_Number_Type;
5871 -- The load is performed only when the compilation will generate code
5873 if Operating_Mode = Generate_Code then
5876 (Load_Name => Unit_Nam,
5879 Error_Node => Pack_Decl);
5881 -- The load failed most likely because the physical file is
5884 if Unit_Num = No_Unit then
5887 -- Otherwise the load was successful, return the body of the unit
5890 Body_Decl := Unit (Cunit (Unit_Num));
5892 -- If the unit is a subunit with an available proper body,
5893 -- return the proper body.
5895 if Nkind (Body_Decl) = N_Subunit
5896 and then Present (Proper_Body (Body_Decl))
5898 Body_Decl := Proper_Body (Body_Decl);
5906 end Load_Package_Body;
5910 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
5912 -- Start of processing for Has_Body
5915 -- The body is available
5917 if Present (Corresponding_Body (Pack_Decl)) then
5920 -- The body is required if the package spec contains a construct which
5921 -- requires a completion in a body.
5923 elsif Unit_Requires_Body (Pack_Id) then
5926 -- The body may be optional
5929 return Present (Find_Corresponding_Body (Pack_Id));
5933 ---------------------------
5934 -- Has_Prior_Elaboration --
5935 ---------------------------
5937 function Has_Prior_Elaboration
5938 (Unit_Id : Entity_Id;
5939 Context_OK : Boolean := False;
5940 Elab_Body_OK : Boolean := False;
5941 Same_Unit_OK : Boolean := False) return Boolean
5943 Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit);
5946 -- A preelaborated unit is always elaborated prior to the main unit
5948 if Is_Preelaborated_Unit (Unit_Id) then
5951 -- An internal unit is always elaborated prior to a non-internal main
5954 elsif In_Internal_Unit (Unit_Id)
5955 and then not In_Internal_Unit (Main_Id)
5959 -- A unit has prior elaboration if it appears within the context of the
5960 -- main unit. Consider this case only when requested by the caller.
5963 and then Elaboration_Status (Unit_Id) /= No_Elaboration_Attributes
5967 -- A unit whose body is elaborated together with its spec has prior
5968 -- elaboration except with respect to itself. Consider this case only
5969 -- when requested by the caller.
5972 and then Has_Pragma_Elaborate_Body (Unit_Id)
5973 and then not Is_Same_Unit (Unit_Id, Main_Id)
5977 -- A unit has no prior elaboration with respect to itself, but does not
5978 -- require any means of ensuring its own elaboration either. Treat this
5979 -- case as valid prior elaboration only when requested by the caller.
5981 elsif Same_Unit_OK and then Is_Same_Unit (Unit_Id, Main_Id) then
5986 end Has_Prior_Elaboration;
5988 --------------------------
5989 -- In_External_Instance --
5990 --------------------------
5992 function In_External_Instance
5994 Target_Decl : Node_Id) return Boolean
5997 Inst_Body : Node_Id;
5998 Inst_Decl : Node_Id;
6001 -- Performance note: parent traversal
6003 Inst_Decl := Find_Enclosing_Instance (Target_Decl);
6005 -- The target declaration appears within an instance spec. Visibility is
6006 -- ignored because internally generated primitives for private types may
6007 -- reside in the private declarations and still be invoked from outside.
6009 if Present (Inst_Decl)
6010 and then Nkind (Inst_Decl) = N_Package_Declaration
6012 -- The scenario comes from the main unit and the instance does not
6014 if In_Extended_Main_Code_Unit (N)
6015 and then not In_Extended_Main_Code_Unit (Inst_Decl)
6019 -- Otherwise the scenario must not appear within the instance spec or
6023 Extract_Instance_Attributes
6024 (Exp_Inst => Inst_Decl,
6025 Inst_Body => Inst_Body,
6026 Inst_Decl => Dummy);
6028 -- Performance note: parent traversal
6030 return not In_Subtree
6033 Root2 => Inst_Body);
6038 end In_External_Instance;
6040 ---------------------
6041 -- In_Main_Context --
6042 ---------------------
6044 function In_Main_Context (N : Node_Id) return Boolean is
6046 -- Scenarios outside the main unit are not considered because the ALI
6047 -- information supplied to binde is for the main unit only.
6049 if not In_Extended_Main_Code_Unit (N) then
6052 -- Scenarios within internal units are not considered unless switch
6053 -- -gnatdE (elaboration checks on predefined units) is in effect.
6055 elsif not Debug_Flag_EE and then In_Internal_Unit (N) then
6060 end In_Main_Context;
6062 ---------------------
6063 -- In_Same_Context --
6064 ---------------------
6066 function In_Same_Context
6069 Nested_OK : Boolean := False) return Boolean
6071 function Find_Enclosing_Context (N : Node_Id) return Node_Id;
6072 -- Return the nearest enclosing non-library-level or compilation unit
6073 -- node which which encapsulates arbitrary node N. Return Empty is no
6074 -- such context is available.
6076 function In_Nested_Context
6078 Inner : Node_Id) return Boolean;
6079 -- Determine whether arbitrary node Outer encapsulates arbitrary node
6082 ----------------------------
6083 -- Find_Enclosing_Context --
6084 ----------------------------
6086 function Find_Enclosing_Context (N : Node_Id) return Node_Id is
6092 while Present (Par) loop
6094 -- A traversal from a subunit continues via the corresponding stub
6096 if Nkind (Par) = N_Subunit then
6097 Par := Corresponding_Stub (Par);
6099 -- Stop the traversal when the nearest enclosing non-library-level
6100 -- encapsulator has been reached.
6102 elsif Is_Non_Library_Level_Encapsulator (Par) then
6103 Context := Parent (Par);
6105 -- The sole exception is when the encapsulator is the unit of
6106 -- compilation because this case requires special processing
6109 if Present (Context)
6110 and then Nkind (Context) = N_Compilation_Unit
6118 -- Reaching a compilation unit node without hitting a non-library-
6119 -- level encapsulator indicates that N is at the library level in
6120 -- which case the compilation unit is the context.
6122 elsif Nkind (Par) = N_Compilation_Unit then
6126 Par := Parent (Par);
6130 end Find_Enclosing_Context;
6132 -----------------------
6133 -- In_Nested_Context --
6134 -----------------------
6136 function In_Nested_Context
6138 Inner : Node_Id) return Boolean
6144 while Present (Par) loop
6146 -- A traversal from a subunit continues via the corresponding stub
6148 if Nkind (Par) = N_Subunit then
6149 Par := Corresponding_Stub (Par);
6151 elsif Par = Outer then
6155 Par := Parent (Par);
6159 end In_Nested_Context;
6163 Context_1 : constant Node_Id := Find_Enclosing_Context (N1);
6164 Context_2 : constant Node_Id := Find_Enclosing_Context (N2);
6166 -- Start of processing for In_Same_Context
6169 -- Both nodes appear within the same context
6171 if Context_1 = Context_2 then
6174 -- Both nodes appear in compilation units. Determine whether one unit
6175 -- is the body of the other.
6177 elsif Nkind (Context_1) = N_Compilation_Unit
6178 and then Nkind (Context_2) = N_Compilation_Unit
6182 (Unit_1 => Defining_Entity (Unit (Context_1)),
6183 Unit_2 => Defining_Entity (Unit (Context_2)));
6185 -- The context of N1 encloses the context of N2
6187 elsif Nested_OK and then In_Nested_Context (Context_1, Context_2) then
6192 end In_Same_Context;
6198 function In_Task_Body (N : Node_Id) return Boolean is
6202 -- Climb the parent chain looking for a task body [procedure]
6205 while Present (Par) loop
6206 if Nkind (Par) = N_Task_Body then
6209 elsif Nkind (Par) = N_Subprogram_Body
6210 and then Is_Task_Body_Procedure (Par)
6214 -- Prevent the search from going too far. Note that this predicate
6215 -- shares nodes with the two cases above, and must come last.
6217 elsif Is_Body_Or_Package_Declaration (Par) then
6221 Par := Parent (Par);
6231 procedure Initialize is
6233 -- Set the soft link which enables Atree.Rewrite to update a top-level
6234 -- scenario each time it is transformed into another node.
6236 Set_Rewriting_Proc (Update_Elaboration_Scenario'Access);
6245 Target_Id : Entity_Id;
6249 procedure Info_Accept_Alternative;
6250 pragma Inline (Info_Accept_Alternative);
6251 -- Output information concerning an accept alternative
6253 procedure Info_Simple_Call;
6254 pragma Inline (Info_Simple_Call);
6255 -- Output information concerning the call
6257 procedure Info_Type_Actions (Action : String);
6258 pragma Inline (Info_Type_Actions);
6259 -- Output information concerning action Action of a type
6261 procedure Info_Verification_Call
6265 pragma Inline (Info_Verification_Call);
6266 -- Output information concerning the verification of predicate Pred
6267 -- applied to related entity Id with kind Id_Kind.
6269 -----------------------------
6270 -- Info_Accept_Alternative --
6271 -----------------------------
6273 procedure Info_Accept_Alternative is
6274 Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id);
6277 pragma Assert (Present (Entry_Id));
6280 (Msg => "accept for entry & during elaboration",
6283 Info_Msg => Info_Msg,
6284 In_SPARK => In_SPARK);
6285 end Info_Accept_Alternative;
6287 ----------------------
6288 -- Info_Simple_Call --
6289 ----------------------
6291 procedure Info_Simple_Call is
6294 (Msg => "call to & during elaboration",
6297 Info_Msg => Info_Msg,
6298 In_SPARK => In_SPARK);
6299 end Info_Simple_Call;
6301 -----------------------
6302 -- Info_Type_Actions --
6303 -----------------------
6305 procedure Info_Type_Actions (Action : String) is
6306 Typ : constant Entity_Id := First_Formal_Type (Target_Id);
6309 pragma Assert (Present (Typ));
6312 (Msg => Action & " actions for type & during elaboration",
6315 Info_Msg => Info_Msg,
6316 In_SPARK => In_SPARK);
6317 end Info_Type_Actions;
6319 ----------------------------
6320 -- Info_Verification_Call --
6321 ----------------------------
6323 procedure Info_Verification_Call
6329 pragma Assert (Present (Id));
6333 "verification of " & Pred & " of " & Id_Kind & " & during "
6337 Info_Msg => Info_Msg,
6338 In_SPARK => In_SPARK);
6339 end Info_Verification_Call;
6341 -- Start of processing for Info_Call
6344 -- Do not output anything for targets defined in internal units because
6345 -- this creates noise.
6347 if not In_Internal_Unit (Target_Id) then
6349 -- Accept alternative
6351 if Is_Accept_Alternative_Proc (Target_Id) then
6352 Info_Accept_Alternative;
6356 elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then
6357 Info_Type_Actions ("adjustment");
6359 -- Default_Initial_Condition
6361 elsif Is_Default_Initial_Condition_Proc (Target_Id) then
6362 Info_Verification_Call
6363 (Pred => "Default_Initial_Condition",
6364 Id => First_Formal_Type (Target_Id),
6369 elsif Is_Protected_Entry (Target_Id) then
6372 -- Task entry calls are never processed because the entry being
6373 -- invoked does not have a corresponding "body", it has a select.
6375 elsif Is_Task_Entry (Target_Id) then
6380 elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then
6381 Info_Type_Actions ("finalization");
6383 -- Calls to _Finalizer procedures must not appear in the output
6384 -- because this creates confusing noise.
6386 elsif Is_Finalizer_Proc (Target_Id) then
6389 -- Initial_Condition
6391 elsif Is_Initial_Condition_Proc (Target_Id) then
6392 Info_Verification_Call
6393 (Pred => "Initial_Condition",
6394 Id => Find_Enclosing_Scope (Call),
6395 Id_Kind => "package");
6399 elsif Is_Init_Proc (Target_Id)
6400 or else Is_TSS (Target_Id, TSS_Deep_Initialize)
6402 Info_Type_Actions ("initialization");
6406 elsif Is_Invariant_Proc (Target_Id) then
6407 Info_Verification_Call
6408 (Pred => "invariants",
6409 Id => First_Formal_Type (Target_Id),
6412 -- Partial invariant calls must not appear in the output because this
6413 -- creates confusing noise.
6415 elsif Is_Partial_Invariant_Proc (Target_Id) then
6420 elsif Is_Postconditions_Proc (Target_Id) then
6421 Info_Verification_Call
6422 (Pred => "postconditions",
6423 Id => Find_Enclosing_Scope (Call),
6424 Id_Kind => "subprogram");
6426 -- Subprograms must come last because some of the previous cases fall
6427 -- under this category.
6429 elsif Ekind (Target_Id) = E_Function then
6432 elsif Ekind (Target_Id) = E_Procedure then
6436 pragma Assert (False);
6442 ------------------------
6443 -- Info_Instantiation --
6444 ------------------------
6446 procedure Info_Instantiation
6454 (Msg => "instantiation of & during elaboration",
6457 Info_Msg => Info_Msg,
6458 In_SPARK => In_SPARK);
6459 end Info_Instantiation;
6461 -----------------------------
6462 -- Info_Variable_Reference --
6463 -----------------------------
6465 procedure Info_Variable_Reference
6472 if Is_Read (Ref) then
6474 (Msg => "read of variable & during elaboration",
6477 Info_Msg => Info_Msg,
6478 In_SPARK => In_SPARK);
6480 end Info_Variable_Reference;
6482 --------------------
6483 -- Insertion_Node --
6484 --------------------
6486 function Insertion_Node (N : Node_Id; Ins_Nod : Node_Id) return Node_Id is
6488 -- When the scenario denotes an instantiation, the proper insertion node
6489 -- is the instance spec. This ensures that the generic actuals will not
6490 -- be evaluated prior to a potential ABE.
6492 if Nkind (N) in N_Generic_Instantiation
6493 and then Present (Instance_Spec (N))
6495 return Instance_Spec (N);
6497 -- Otherwise the proper insertion node is the candidate insertion node
6504 -----------------------
6505 -- Install_ABE_Check --
6506 -----------------------
6508 procedure Install_ABE_Check
6513 Check_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod);
6514 -- Insert the check prior to this node
6516 Loc : constant Source_Ptr := Sloc (N);
6517 Spec_Id : constant Entity_Id := Unique_Entity (Id);
6518 Unit_Id : constant Entity_Id := Find_Top_Unit (Id);
6519 Scop_Id : Entity_Id;
6522 -- Nothing to do when compiling for GNATprove because raise statements
6523 -- are not supported.
6525 if GNATprove_Mode then
6528 -- Nothing to do when the compilation will not produce an executable
6530 elsif Serious_Errors_Detected > 0 then
6533 -- Nothing to do for a compilation unit because there is no executable
6534 -- environment at that level.
6536 elsif Nkind (Parent (Check_Ins_Nod)) = N_Compilation_Unit then
6539 -- Nothing to do when the unit is elaborated prior to the main unit.
6540 -- This check must also consider the following cases:
6542 -- * Id's unit appears in the context of the main unit
6544 -- * Id's unit is subject to pragma Elaborate_Body. An ABE check MUST
6545 -- NOT be generated because Id's unit is always elaborated prior to
6548 -- * Id's unit is the main unit. An ABE check MUST be generated in this
6549 -- case because a conditional ABE may be raised depending on the flow
6550 -- of execution within the main unit (flag Same_Unit_OK is False).
6552 elsif Has_Prior_Elaboration
6553 (Unit_Id => Unit_Id,
6555 Elab_Body_OK => True)
6560 -- Prevent multiple scenarios from installing the same ABE check
6562 Set_Is_Elaboration_Checks_OK_Node (N, False);
6564 -- Install the nearest enclosing scope of the scenario as there must be
6565 -- something on the scope stack.
6567 -- Performance note: parent traversal
6569 Scop_Id := Find_Enclosing_Scope (Check_Ins_Nod);
6570 pragma Assert (Present (Scop_Id));
6572 Push_Scope (Scop_Id);
6575 -- if not Spec_Id'Elaborated then
6576 -- raise Program_Error with "access before elaboration";
6579 Insert_Action (Check_Ins_Nod,
6580 Make_Raise_Program_Error (Loc,
6584 Make_Attribute_Reference (Loc,
6585 Prefix => New_Occurrence_Of (Spec_Id, Loc),
6586 Attribute_Name => Name_Elaborated)),
6587 Reason => PE_Access_Before_Elaboration));
6590 end Install_ABE_Check;
6592 -----------------------
6593 -- Install_ABE_Check --
6594 -----------------------
6596 procedure Install_ABE_Check
6598 Target_Id : Entity_Id;
6599 Target_Decl : Node_Id;
6600 Target_Body : Node_Id;
6603 procedure Build_Elaboration_Entity;
6604 pragma Inline (Build_Elaboration_Entity);
6605 -- Create a new elaboration flag for Target_Id, insert it prior to
6606 -- Target_Decl, and set it after Body_Decl.
6608 ------------------------------
6609 -- Build_Elaboration_Entity --
6610 ------------------------------
6612 procedure Build_Elaboration_Entity is
6613 Loc : constant Source_Ptr := Sloc (Target_Id);
6614 Flag_Id : Entity_Id;
6617 -- Create the declaration of the elaboration flag. The name carries a
6618 -- unique counter in case of name overloading.
6621 Make_Defining_Identifier (Loc,
6622 Chars => New_External_Name (Chars (Target_Id), 'E', -1));
6624 Set_Elaboration_Entity (Target_Id, Flag_Id);
6625 Set_Elaboration_Entity_Required (Target_Id);
6627 Push_Scope (Scope (Target_Id));
6630 -- Enn : Short_Integer := 0;
6632 Insert_Action (Target_Decl,
6633 Make_Object_Declaration (Loc,
6634 Defining_Identifier => Flag_Id,
6635 Object_Definition =>
6636 New_Occurrence_Of (Standard_Short_Integer, Loc),
6637 Expression => Make_Integer_Literal (Loc, Uint_0)));
6642 Set_Elaboration_Flag (Target_Body, Target_Id);
6645 end Build_Elaboration_Entity;
6649 Target_Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id);
6651 -- Start for processing for Install_ABE_Check
6654 -- Nothing to do when compiling for GNATprove because raise statements
6655 -- are not supported.
6657 if GNATprove_Mode then
6660 -- Nothing to do when the compilation will not produce an executable
6662 elsif Serious_Errors_Detected > 0 then
6665 -- Nothing to do when the target is a protected subprogram because the
6666 -- check is associated with the protected body subprogram.
6668 elsif Is_Protected_Subp (Target_Id) then
6671 -- Nothing to do when the target is elaborated prior to the main unit.
6672 -- This check must also consider the following cases:
6674 -- * The unit of the target appears in the context of the main unit
6676 -- * The unit of the target is subject to pragma Elaborate_Body. An ABE
6677 -- check MUST NOT be generated because the unit is always elaborated
6678 -- prior to the main unit.
6680 -- * The unit of the target is the main unit. An ABE check MUST be added
6681 -- in this case because a conditional ABE may be raised depending on
6682 -- the flow of execution within the main unit (flag Same_Unit_OK is
6685 elsif Has_Prior_Elaboration
6686 (Unit_Id => Target_Unit_Id,
6688 Elab_Body_OK => True)
6692 -- Create an elaboration flag for the target when it does not have one
6694 elsif No (Elaboration_Entity (Target_Id)) then
6695 Build_Elaboration_Entity;
6702 end Install_ABE_Check;
6704 -------------------------
6705 -- Install_ABE_Failure --
6706 -------------------------
6708 procedure Install_ABE_Failure (N : Node_Id; Ins_Nod : Node_Id) is
6709 Fail_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod);
6710 -- Insert the failure prior to this node
6712 Loc : constant Source_Ptr := Sloc (N);
6713 Scop_Id : Entity_Id;
6716 -- Nothing to do when compiling for GNATprove because raise statements
6717 -- are not supported.
6719 if GNATprove_Mode then
6722 -- Nothing to do when the compilation will not produce an executable
6724 elsif Serious_Errors_Detected > 0 then
6727 -- Do not install an ABE check for a compilation unit because there is
6728 -- no executable environment at that level.
6730 elsif Nkind (Parent (Fail_Ins_Nod)) = N_Compilation_Unit then
6734 -- Prevent multiple scenarios from installing the same ABE failure
6736 Set_Is_Elaboration_Checks_OK_Node (N, False);
6738 -- Install the nearest enclosing scope of the scenario as there must be
6739 -- something on the scope stack.
6741 -- Performance note: parent traversal
6743 Scop_Id := Find_Enclosing_Scope (Fail_Ins_Nod);
6744 pragma Assert (Present (Scop_Id));
6746 Push_Scope (Scop_Id);
6749 -- raise Program_Error with "access before elaboration";
6751 Insert_Action (Fail_Ins_Nod,
6752 Make_Raise_Program_Error (Loc,
6753 Reason => PE_Access_Before_Elaboration));
6756 end Install_ABE_Failure;
6758 --------------------------------
6759 -- Is_Accept_Alternative_Proc --
6760 --------------------------------
6762 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is
6764 -- To qualify, the entity must denote a procedure with a receiving entry
6766 return Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id));
6767 end Is_Accept_Alternative_Proc;
6769 ------------------------
6770 -- Is_Activation_Proc --
6771 ------------------------
6773 function Is_Activation_Proc (Id : Entity_Id) return Boolean is
6775 -- To qualify, the entity must denote one of the runtime procedures in
6776 -- charge of task activation.
6778 if Ekind (Id) = E_Procedure then
6779 if Restricted_Profile then
6780 return Is_RTE (Id, RE_Activate_Restricted_Tasks);
6782 return Is_RTE (Id, RE_Activate_Tasks);
6787 end Is_Activation_Proc;
6789 ----------------------------
6790 -- Is_Ada_Semantic_Target --
6791 ----------------------------
6793 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean is
6796 Is_Activation_Proc (Id)
6797 or else Is_Controlled_Proc (Id, Name_Adjust)
6798 or else Is_Controlled_Proc (Id, Name_Finalize)
6799 or else Is_Controlled_Proc (Id, Name_Initialize)
6800 or else Is_Init_Proc (Id)
6801 or else Is_Invariant_Proc (Id)
6802 or else Is_Protected_Entry (Id)
6803 or else Is_Protected_Subp (Id)
6804 or else Is_Protected_Body_Subp (Id)
6805 or else Is_Task_Entry (Id);
6806 end Is_Ada_Semantic_Target;
6808 --------------------------------
6809 -- Is_Assertion_Pragma_Target --
6810 --------------------------------
6812 function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean is
6815 Is_Default_Initial_Condition_Proc (Id)
6816 or else Is_Initial_Condition_Proc (Id)
6817 or else Is_Invariant_Proc (Id)
6818 or else Is_Partial_Invariant_Proc (Id)
6819 or else Is_Postconditions_Proc (Id);
6820 end Is_Assertion_Pragma_Target;
6822 ----------------------------
6823 -- Is_Bodiless_Subprogram --
6824 ----------------------------
6826 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is
6828 -- An abstract subprogram does not have a body
6830 if Ekind_In (Subp_Id, E_Function,
6833 and then Is_Abstract_Subprogram (Subp_Id)
6837 -- A formal subprogram does not have a body
6839 elsif Is_Formal_Subprogram (Subp_Id) then
6842 -- An imported subprogram may have a body, however it is not known at
6843 -- compile or bind time where the body resides and whether it will be
6844 -- elaborated on time.
6846 elsif Is_Imported (Subp_Id) then
6851 end Is_Bodiless_Subprogram;
6853 ------------------------
6854 -- Is_Controlled_Proc --
6855 ------------------------
6857 function Is_Controlled_Proc
6858 (Subp_Id : Entity_Id;
6859 Subp_Nam : Name_Id) return Boolean
6861 Formal_Id : Entity_Id;
6864 pragma Assert (Nam_In (Subp_Nam, Name_Adjust,
6868 -- To qualify, the subprogram must denote a source procedure with name
6869 -- Adjust, Finalize, or Initialize where the sole formal is controlled.
6871 if Comes_From_Source (Subp_Id)
6872 and then Ekind (Subp_Id) = E_Procedure
6873 and then Chars (Subp_Id) = Subp_Nam
6875 Formal_Id := First_Formal (Subp_Id);
6879 and then Is_Controlled (Etype (Formal_Id))
6880 and then No (Next_Formal (Formal_Id));
6884 end Is_Controlled_Proc;
6886 ---------------------------------------
6887 -- Is_Default_Initial_Condition_Proc --
6888 ---------------------------------------
6890 function Is_Default_Initial_Condition_Proc
6891 (Id : Entity_Id) return Boolean
6894 -- To qualify, the entity must denote a Default_Initial_Condition
6897 return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id);
6898 end Is_Default_Initial_Condition_Proc;
6900 -----------------------
6901 -- Is_Finalizer_Proc --
6902 -----------------------
6904 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is
6906 -- To qualify, the entity must denote a _Finalizer procedure
6908 return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer;
6909 end Is_Finalizer_Proc;
6911 -----------------------
6912 -- Is_Guaranteed_ABE --
6913 -----------------------
6915 function Is_Guaranteed_ABE
6917 Target_Decl : Node_Id;
6918 Target_Body : Node_Id) return Boolean
6921 -- Avoid cascaded errors if there were previous serious infractions.
6922 -- As a result the scenario will not be treated as a guaranteed ABE.
6923 -- This behaviour parallels that of the old ABE mechanism.
6925 if Serious_Errors_Detected > 0 then
6928 -- The scenario and the target appear within the same context ignoring
6929 -- enclosing library levels.
6931 -- Performance note: parent traversal
6933 elsif In_Same_Context (N, Target_Decl) then
6935 -- The target body has already been encountered. The scenario results
6936 -- in a guaranteed ABE if it appears prior to the body.
6938 if Present (Target_Body) then
6939 return Earlier_In_Extended_Unit (N, Target_Body);
6941 -- Otherwise the body has not been encountered yet. The scenario is
6942 -- a guaranteed ABE since the body will appear later. It is assumed
6943 -- that the caller has already checked whether the scenario is ABE-
6944 -- safe as optional bodies are not considered here.
6952 end Is_Guaranteed_ABE;
6954 -------------------------------
6955 -- Is_Initial_Condition_Proc --
6956 -------------------------------
6958 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is
6960 -- To qualify, the entity must denote an Initial_Condition procedure
6963 Ekind (Id) = E_Procedure and then Is_Initial_Condition_Procedure (Id);
6964 end Is_Initial_Condition_Proc;
6966 --------------------
6967 -- Is_Initialized --
6968 --------------------
6970 function Is_Initialized (Obj_Decl : Node_Id) return Boolean is
6972 -- To qualify, the object declaration must have an expression
6975 Present (Expression (Obj_Decl)) or else Has_Init_Expression (Obj_Decl);
6978 -----------------------
6979 -- Is_Invariant_Proc --
6980 -----------------------
6982 function Is_Invariant_Proc (Id : Entity_Id) return Boolean is
6984 -- To qualify, the entity must denote the "full" invariant procedure
6986 return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id);
6987 end Is_Invariant_Proc;
6989 ---------------------------------------
6990 -- Is_Non_Library_Level_Encapsulator --
6991 ---------------------------------------
6993 function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean is
6996 when N_Abstract_Subprogram_Declaration
6997 | N_Aspect_Specification
6998 | N_Component_Declaration
7000 | N_Entry_Declaration
7001 | N_Expression_Function
7002 | N_Formal_Abstract_Subprogram_Declaration
7003 | N_Formal_Concrete_Subprogram_Declaration
7004 | N_Formal_Object_Declaration
7005 | N_Formal_Package_Declaration
7006 | N_Formal_Type_Declaration
7007 | N_Generic_Association
7008 | N_Implicit_Label_Declaration
7009 | N_Incomplete_Type_Declaration
7010 | N_Private_Extension_Declaration
7011 | N_Private_Type_Declaration
7013 | N_Protected_Type_Declaration
7014 | N_Single_Protected_Declaration
7015 | N_Single_Task_Declaration
7017 | N_Subprogram_Declaration
7019 | N_Task_Type_Declaration
7024 return Is_Generic_Declaration_Or_Body (N);
7026 end Is_Non_Library_Level_Encapsulator;
7028 -------------------------------
7029 -- Is_Partial_Invariant_Proc --
7030 -------------------------------
7032 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is
7034 -- To qualify, the entity must denote the "partial" invariant procedure
7037 Ekind (Id) = E_Procedure and then Is_Partial_Invariant_Procedure (Id);
7038 end Is_Partial_Invariant_Proc;
7040 ----------------------------
7041 -- Is_Postconditions_Proc --
7042 ----------------------------
7044 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is
7046 -- To qualify, the entity must denote a _Postconditions procedure
7049 Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions;
7050 end Is_Postconditions_Proc;
7052 ---------------------------
7053 -- Is_Preelaborated_Unit --
7054 ---------------------------
7056 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean is
7059 Is_Preelaborated (Id)
7060 or else Is_Pure (Id)
7061 or else Is_Remote_Call_Interface (Id)
7062 or else Is_Remote_Types (Id)
7063 or else Is_Shared_Passive (Id);
7064 end Is_Preelaborated_Unit;
7066 ------------------------
7067 -- Is_Protected_Entry --
7068 ------------------------
7070 function Is_Protected_Entry (Id : Entity_Id) return Boolean is
7072 -- To qualify, the entity must denote an entry defined in a protected
7077 and then Is_Protected_Type (Non_Private_View (Scope (Id)));
7078 end Is_Protected_Entry;
7080 -----------------------
7081 -- Is_Protected_Subp --
7082 -----------------------
7084 function Is_Protected_Subp (Id : Entity_Id) return Boolean is
7086 -- To qualify, the entity must denote a subprogram defined within a
7090 Ekind_In (Id, E_Function, E_Procedure)
7091 and then Is_Protected_Type (Non_Private_View (Scope (Id)));
7092 end Is_Protected_Subp;
7094 ----------------------------
7095 -- Is_Protected_Body_Subp --
7096 ----------------------------
7098 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean is
7100 -- To qualify, the entity must denote a subprogram with attribute
7101 -- Protected_Subprogram set.
7104 Ekind_In (Id, E_Function, E_Procedure)
7105 and then Present (Protected_Subprogram (Id));
7106 end Is_Protected_Body_Subp;
7108 --------------------------------
7109 -- Is_Recorded_SPARK_Scenario --
7110 --------------------------------
7112 function Is_Recorded_SPARK_Scenario (N : Node_Id) return Boolean is
7114 if Recorded_SPARK_Scenarios_In_Use then
7115 return Recorded_SPARK_Scenarios.Get (N);
7118 return Recorded_SPARK_Scenarios_No_Element;
7119 end Is_Recorded_SPARK_Scenario;
7121 ------------------------------------
7122 -- Is_Recorded_Top_Level_Scenario --
7123 ------------------------------------
7125 function Is_Recorded_Top_Level_Scenario (N : Node_Id) return Boolean is
7127 if Recorded_Top_Level_Scenarios_In_Use then
7128 return Recorded_Top_Level_Scenarios.Get (N);
7131 return Recorded_Top_Level_Scenarios_No_Element;
7132 end Is_Recorded_Top_Level_Scenario;
7134 ------------------------
7135 -- Is_Safe_Activation --
7136 ------------------------
7138 function Is_Safe_Activation
7140 Task_Decl : Node_Id) return Boolean
7143 -- The activation of a task coming from an external instance cannot
7144 -- cause an ABE because the generic was already instantiated. Note
7145 -- that the instantiation itself may lead to an ABE.
7148 In_External_Instance
7150 Target_Decl => Task_Decl);
7151 end Is_Safe_Activation;
7157 function Is_Safe_Call
7159 Target_Attrs : Target_Attributes) return Boolean
7162 -- The target is either an abstract subprogram, formal subprogram, or
7163 -- imported, in which case it does not have a body at compile or bind
7164 -- time. Assume that the call is ABE-safe.
7166 if Is_Bodiless_Subprogram (Target_Attrs.Spec_Id) then
7169 -- The target is an instantiation of a generic subprogram. The call
7170 -- cannot cause an ABE because the generic was already instantiated.
7171 -- Note that the instantiation itself may lead to an ABE.
7173 elsif Is_Generic_Instance (Target_Attrs.Spec_Id) then
7176 -- The invocation of a target coming from an external instance cannot
7177 -- cause an ABE because the generic was already instantiated. Note that
7178 -- the instantiation itself may lead to an ABE.
7180 elsif In_External_Instance
7182 Target_Decl => Target_Attrs.Spec_Decl)
7186 -- The target is a subprogram body without a previous declaration. The
7187 -- call cannot cause an ABE because the body has already been seen.
7189 elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body
7190 and then No (Corresponding_Spec (Target_Attrs.Spec_Decl))
7194 -- The target is a subprogram body stub without a prior declaration.
7195 -- The call cannot cause an ABE because the proper body substitutes
7198 elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body_Stub
7199 and then No (Corresponding_Spec_Of_Stub (Target_Attrs.Spec_Decl))
7203 -- Subprogram bodies which wrap attribute references used as actuals
7204 -- in instantiations are always ABE-safe. These bodies are artifacts
7207 elsif Present (Target_Attrs.Body_Decl)
7208 and then Nkind (Target_Attrs.Body_Decl) = N_Subprogram_Body
7209 and then Was_Attribute_Reference (Target_Attrs.Body_Decl)
7217 ---------------------------
7218 -- Is_Safe_Instantiation --
7219 ---------------------------
7221 function Is_Safe_Instantiation
7223 Gen_Attrs : Target_Attributes) return Boolean
7226 -- The generic is an intrinsic subprogram in which case it does not
7227 -- have a body at compile or bind time. Assume that the instantiation
7230 if Is_Bodiless_Subprogram (Gen_Attrs.Spec_Id) then
7233 -- The instantiation of an external nested generic cannot cause an ABE
7234 -- if the outer generic was already instantiated. Note that the instance
7235 -- of the outer generic may lead to an ABE.
7237 elsif In_External_Instance
7239 Target_Decl => Gen_Attrs.Spec_Decl)
7243 -- The generic is a package. The instantiation cannot cause an ABE when
7244 -- the package has no body.
7246 elsif Ekind (Gen_Attrs.Spec_Id) = E_Generic_Package
7247 and then not Has_Body (Gen_Attrs.Spec_Decl)
7253 end Is_Safe_Instantiation;
7259 function Is_Same_Unit
7260 (Unit_1 : Entity_Id;
7261 Unit_2 : Entity_Id) return Boolean
7264 return Unit_Entity (Unit_1) = Unit_Entity (Unit_2);
7271 function Is_Scenario (N : Node_Id) return Boolean is
7274 when N_Assignment_Statement
7275 | N_Attribute_Reference
7277 | N_Entry_Call_Statement
7280 | N_Function_Instantiation
7282 | N_Package_Instantiation
7283 | N_Procedure_Call_Statement
7284 | N_Procedure_Instantiation
7285 | N_Requeue_Statement
7294 ------------------------------
7295 -- Is_SPARK_Semantic_Target --
7296 ------------------------------
7298 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean is
7301 Is_Default_Initial_Condition_Proc (Id)
7302 or else Is_Initial_Condition_Proc (Id);
7303 end Is_SPARK_Semantic_Target;
7305 ------------------------
7306 -- Is_Suitable_Access --
7307 ------------------------
7309 function Is_Suitable_Access (N : Node_Id) return Boolean is
7312 Subp_Id : Entity_Id;
7315 -- This scenario is relevant only when the static model is in effect
7316 -- because it is graph-dependent and does not involve any run-time
7317 -- checks. Allowing it in the dynamic model would create confusing
7320 if not Static_Elaboration_Checks then
7323 -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect
7325 elsif Debug_Flag_Dot_UU then
7328 -- Nothing to do when the scenario is not an attribute reference
7330 elsif Nkind (N) /= N_Attribute_Reference then
7333 -- Nothing to do for internally-generated attributes because they are
7334 -- assumed to be ABE safe.
7336 elsif not Comes_From_Source (N) then
7340 Nam := Attribute_Name (N);
7343 -- Sanitize the prefix of the attribute
7345 if not Is_Entity_Name (Pref) then
7348 elsif No (Entity (Pref)) then
7352 Subp_Id := Entity (Pref);
7354 if not Is_Subprogram_Or_Entry (Subp_Id) then
7358 -- Traverse a possible chain of renamings to obtain the original entry
7359 -- or subprogram which the prefix may rename.
7361 Subp_Id := Get_Renamed_Entity (Subp_Id);
7363 -- To qualify, the attribute must meet the following prerequisites:
7367 -- The prefix must denote a source entry, operator, or subprogram
7368 -- which is not imported.
7370 Comes_From_Source (Subp_Id)
7371 and then Is_Subprogram_Or_Entry (Subp_Id)
7372 and then not Is_Bodiless_Subprogram (Subp_Id)
7374 -- The attribute name must be one of the 'Access forms. Note that
7375 -- 'Unchecked_Access cannot apply to a subprogram.
7377 and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access);
7378 end Is_Suitable_Access;
7380 ----------------------
7381 -- Is_Suitable_Call --
7382 ----------------------
7384 function Is_Suitable_Call (N : Node_Id) return Boolean is
7386 -- Entry and subprogram calls are intentionally ignored because they
7387 -- may undergo expansion depending on the compilation mode, previous
7388 -- errors, generic context, etc. Call markers play the role of calls
7389 -- and provide a uniform foundation for ABE processing.
7391 return Nkind (N) = N_Call_Marker;
7392 end Is_Suitable_Call;
7394 -------------------------------
7395 -- Is_Suitable_Instantiation --
7396 -------------------------------
7398 function Is_Suitable_Instantiation (N : Node_Id) return Boolean is
7399 Orig_N : constant Node_Id := Original_Node (N);
7400 -- Use the original node in case an instantiation library unit is
7401 -- rewritten as a package or subprogram.
7404 -- To qualify, the instantiation must come from source
7407 Comes_From_Source (Orig_N)
7408 and then Nkind (Orig_N) in N_Generic_Instantiation;
7409 end Is_Suitable_Instantiation;
7411 --------------------------
7412 -- Is_Suitable_Scenario --
7413 --------------------------
7415 function Is_Suitable_Scenario (N : Node_Id) return Boolean is
7417 -- NOTE: Derived types and pragma Refined_State are intentionally left
7418 -- out because they are not executable during elaboration.
7421 Is_Suitable_Access (N)
7422 or else Is_Suitable_Call (N)
7423 or else Is_Suitable_Instantiation (N)
7424 or else Is_Suitable_Variable_Assignment (N)
7425 or else Is_Suitable_Variable_Reference (N);
7426 end Is_Suitable_Scenario;
7428 ------------------------------------
7429 -- Is_Suitable_SPARK_Derived_Type --
7430 ------------------------------------
7432 function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean is
7437 -- To qualify, the type declaration must denote a derived tagged type
7438 -- with primitive operations, subject to pragma SPARK_Mode On.
7440 if Nkind (N) = N_Full_Type_Declaration
7441 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition
7443 Typ := Defining_Entity (N);
7444 Prag := SPARK_Pragma (Typ);
7447 Is_Tagged_Type (Typ)
7448 and then Has_Primitive_Operations (Typ)
7449 and then Present (Prag)
7450 and then Get_SPARK_Mode_From_Annotation (Prag) = On;
7454 end Is_Suitable_SPARK_Derived_Type;
7456 -------------------------------------
7457 -- Is_Suitable_SPARK_Instantiation --
7458 -------------------------------------
7460 function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean is
7461 Gen_Attrs : Target_Attributes;
7464 Inst_Attrs : Instantiation_Attributes;
7465 Inst_Id : Entity_Id;
7468 -- To qualify, both the instantiation and the generic must be subject to
7471 if Is_Suitable_Instantiation (N) then
7472 Extract_Instantiation_Attributes
7477 Attrs => Inst_Attrs);
7479 Extract_Target_Attributes (Gen_Id, Gen_Attrs);
7481 return Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On;
7485 end Is_Suitable_SPARK_Instantiation;
7487 --------------------------------------------
7488 -- Is_Suitable_SPARK_Refined_State_Pragma --
7489 --------------------------------------------
7491 function Is_Suitable_SPARK_Refined_State_Pragma
7492 (N : Node_Id) return Boolean
7495 -- To qualfy, the pragma must denote Refined_State
7498 Nkind (N) = N_Pragma
7499 and then Pragma_Name (N) = Name_Refined_State;
7500 end Is_Suitable_SPARK_Refined_State_Pragma;
7502 -------------------------------------
7503 -- Is_Suitable_Variable_Assignment --
7504 -------------------------------------
7506 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean is
7508 N_Unit_Id : Entity_Id;
7513 Var_Unit_Id : Entity_Id;
7516 -- This scenario is relevant only when the static model is in effect
7517 -- because it is graph-dependent and does not involve any run-time
7518 -- checks. Allowing it in the dynamic model would create confusing
7521 if not Static_Elaboration_Checks then
7524 -- Nothing to do when the scenario is not an assignment
7526 elsif Nkind (N) /= N_Assignment_Statement then
7529 -- Nothing to do for internally-generated assignments because they are
7530 -- assumed to be ABE safe.
7532 elsif not Comes_From_Source (N) then
7535 -- Assignments are ignored in GNAT mode on the assumption that they are
7536 -- ABE-safe. This behaviour parallels that of the old ABE mechanism.
7538 elsif GNAT_Mode then
7542 Nam := Extract_Assignment_Name (N);
7544 -- Sanitize the left hand side of the assignment
7546 if not Is_Entity_Name (Nam) then
7549 elsif No (Entity (Nam)) then
7553 Var_Id := Entity (Nam);
7555 -- Sanitize the variable
7557 if Var_Id = Any_Id then
7560 elsif Ekind (Var_Id) /= E_Variable then
7564 Var_Decl := Declaration_Node (Var_Id);
7566 if Nkind (Var_Decl) /= N_Object_Declaration then
7570 N_Unit_Id := Find_Top_Unit (N);
7571 N_Unit := Unit_Declaration_Node (N_Unit_Id);
7573 Var_Unit_Id := Find_Top_Unit (Var_Decl);
7574 Var_Unit := Unit_Declaration_Node (Var_Unit_Id);
7576 -- To qualify, the assignment must meet the following prerequisites:
7579 Comes_From_Source (Var_Id)
7581 -- The variable must be declared in the spec of compilation unit U
7583 and then Nkind (Var_Unit) = N_Package_Declaration
7585 -- Performance note: parent traversal
7587 and then Find_Enclosing_Level (Var_Decl) = Package_Spec
7589 -- The assignment must occur in the body of compilation unit U
7591 and then Nkind (N_Unit) = N_Package_Body
7592 and then Present (Corresponding_Body (Var_Unit))
7593 and then Corresponding_Body (Var_Unit) = N_Unit_Id;
7594 end Is_Suitable_Variable_Assignment;
7596 ------------------------------------
7597 -- Is_Suitable_Variable_Reference --
7598 ------------------------------------
7600 function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean is
7602 -- Expanded names and identifiers are intentionally ignored because they
7603 -- be folded, optimized away, etc. Variable references markers play the
7604 -- role of variable references and provide a uniform foundation for ABE
7607 return Nkind (N) = N_Variable_Reference_Marker;
7608 end Is_Suitable_Variable_Reference;
7610 ------------------------------------
7611 -- Is_Synchronous_Suspension_Call --
7612 ------------------------------------
7614 function Is_Synchronous_Suspension_Call (N : Node_Id) return Boolean is
7615 Call_Attrs : Call_Attributes;
7616 Target_Id : Entity_Id;
7619 -- To qualify, the call must invoke one of the runtime routines which
7620 -- perform synchronous suspension.
7622 if Is_Suitable_Call (N) then
7623 Extract_Call_Attributes
7625 Target_Id => Target_Id,
7626 Attrs => Call_Attrs);
7629 Is_RTE (Target_Id, RE_Suspend_Until_True)
7631 Is_RTE (Target_Id, RE_Wait_For_Release);
7635 end Is_Synchronous_Suspension_Call;
7641 function Is_Task_Entry (Id : Entity_Id) return Boolean is
7643 -- To qualify, the entity must denote an entry defined in a task type
7646 Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id)));
7649 ------------------------
7650 -- Is_Up_Level_Target --
7651 ------------------------
7653 function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean is
7654 Root : constant Node_Id := Root_Scenario;
7657 -- The root appears within the declaratons of a block statement, entry
7658 -- body, subprogram body, or task body ignoring enclosing packages. The
7659 -- root is always within the main unit. An up-level target is a notion
7660 -- applicable only to the static model because scenarios are reached by
7661 -- means of graph traversal started from a fixed declarative or library
7664 -- Performance note: parent traversal
7666 if Static_Elaboration_Checks
7667 and then Find_Enclosing_Level (Root) = Declaration_Level
7669 -- The target is within the main unit. It acts as an up-level target
7670 -- when it appears within a context which encloses the root.
7672 -- package body Main_Unit is
7673 -- function Func ...; -- target
7675 -- procedure Proc is
7676 -- X : ... := Func; -- root scenario
7678 if In_Extended_Main_Code_Unit (Target_Decl) then
7680 -- Performance note: parent traversal
7682 return not In_Same_Context (Root, Target_Decl, Nested_OK => True);
7684 -- Otherwise the target is external to the main unit which makes it
7685 -- an up-level target.
7693 end Is_Up_Level_Target;
7695 ---------------------
7696 -- Is_Visited_Body --
7697 ---------------------
7699 function Is_Visited_Body (Body_Decl : Node_Id) return Boolean is
7701 if Visited_Bodies_In_Use then
7702 return Visited_Bodies.Get (Body_Decl);
7705 return Visited_Bodies_No_Element;
7706 end Is_Visited_Body;
7708 -------------------------------
7709 -- Kill_Elaboration_Scenario --
7710 -------------------------------
7712 procedure Kill_Elaboration_Scenario (N : Node_Id) is
7713 procedure Kill_SPARK_Scenario;
7714 pragma Inline (Kill_SPARK_Scenario);
7715 -- Eliminate scenario N from table SPARK_Scenarios if it is recorded
7718 procedure Kill_Top_Level_Scenario;
7719 pragma Inline (Kill_Top_Level_Scenario);
7720 -- Eliminate scenario N from table Top_Level_Scenarios if it is recorded
7723 -------------------------
7724 -- Kill_SPARK_Scenario --
7725 -------------------------
7727 procedure Kill_SPARK_Scenario is
7728 package Scenarios renames SPARK_Scenarios;
7731 if Is_Recorded_SPARK_Scenario (N) then
7733 -- Performance note: list traversal
7735 for Index in Scenarios.First .. Scenarios.Last loop
7736 if Scenarios.Table (Index) = N then
7737 Scenarios.Table (Index) := Empty;
7739 -- The SPARK scenario is no longer recorded
7741 Set_Is_Recorded_SPARK_Scenario (N, False);
7746 -- A recorded SPARK scenario must be in the table of recorded
7749 pragma Assert (False);
7751 end Kill_SPARK_Scenario;
7753 -----------------------------
7754 -- Kill_Top_Level_Scenario --
7755 -----------------------------
7757 procedure Kill_Top_Level_Scenario is
7758 package Scenarios renames Top_Level_Scenarios;
7761 if Is_Recorded_Top_Level_Scenario (N) then
7763 -- Performance node: list traversal
7765 for Index in Scenarios.First .. Scenarios.Last loop
7766 if Scenarios.Table (Index) = N then
7767 Scenarios.Table (Index) := Empty;
7769 -- The top-level scenario is no longer recorded
7771 Set_Is_Recorded_Top_Level_Scenario (N, False);
7776 -- A recorded top-level scenario must be in the table of recorded
7777 -- top-level scenarios.
7779 pragma Assert (False);
7781 end Kill_Top_Level_Scenario;
7783 -- Start of processing for Kill_Elaboration_Scenario
7786 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
7787 -- enabled) is in effect because the legacy ABE lechanism does not need
7788 -- to carry out this action.
7790 if Legacy_Elaboration_Checks then
7794 -- Eliminate a recorded scenario when it appears within dead code
7795 -- because it will not be executed at elaboration time.
7797 if Is_Scenario (N) then
7798 Kill_SPARK_Scenario;
7799 Kill_Top_Level_Scenario;
7801 end Kill_Elaboration_Scenario;
7803 ----------------------------------
7804 -- Meet_Elaboration_Requirement --
7805 ----------------------------------
7807 procedure Meet_Elaboration_Requirement
7809 Target_Id : Entity_Id;
7812 Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit);
7813 Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id);
7815 function Find_Preelaboration_Pragma
7816 (Prag_Nam : Name_Id) return Node_Id;
7817 pragma Inline (Find_Preelaboration_Pragma);
7818 -- Traverse the visible declarations of unit Unit_Id and locate a source
7819 -- preelaboration-related pragma with name Prag_Nam.
7821 procedure Info_Requirement_Met (Prag : Node_Id);
7822 pragma Inline (Info_Requirement_Met);
7823 -- Output information concerning pragma Prag which meets requirement
7826 procedure Info_Scenario;
7827 pragma Inline (Info_Scenario);
7828 -- Output information concerning scenario N
7830 --------------------------------
7831 -- Find_Preelaboration_Pragma --
7832 --------------------------------
7834 function Find_Preelaboration_Pragma
7835 (Prag_Nam : Name_Id) return Node_Id
7837 Spec : constant Node_Id := Parent (Unit_Id);
7841 -- A preelaboration-related pragma comes from source and appears at
7842 -- the top of the visible declarations of a package.
7844 if Nkind (Spec) = N_Package_Specification then
7845 Decl := First (Visible_Declarations (Spec));
7846 while Present (Decl) loop
7847 if Comes_From_Source (Decl) then
7848 if Nkind (Decl) = N_Pragma
7849 and then Pragma_Name (Decl) = Prag_Nam
7853 -- Otherwise the construct terminates the region where the
7854 -- preelaboration-related pragma may appear.
7866 end Find_Preelaboration_Pragma;
7868 --------------------------
7869 -- Info_Requirement_Met --
7870 --------------------------
7872 procedure Info_Requirement_Met (Prag : Node_Id) is
7874 pragma Assert (Present (Prag));
7876 Error_Msg_Name_1 := Req_Nam;
7877 Error_Msg_Sloc := Sloc (Prag);
7879 ("\\% requirement for unit & met by pragma #", N, Unit_Id);
7880 end Info_Requirement_Met;
7886 procedure Info_Scenario is
7888 if Is_Suitable_Call (N) then
7891 Target_Id => Target_Id,
7895 elsif Is_Suitable_Instantiation (N) then
7898 Gen_Id => Target_Id,
7902 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then
7904 ("read of refinement constituents during elaboration in SPARK",
7907 elsif Is_Suitable_Variable_Reference (N) then
7908 Info_Variable_Reference
7910 Var_Id => Target_Id,
7914 -- No other scenario may impose a requirement on the context of the
7918 pragma Assert (False);
7925 Elab_Attrs : Elaboration_Attributes;
7929 -- Start of processing for Meet_Elaboration_Requirement
7932 pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All));
7934 -- Assume that the requirement has not been met
7938 -- Elaboration requirements are verified only when the static model is
7939 -- in effect because this diagnostic is graph-dependent.
7941 if not Static_Elaboration_Checks then
7944 -- If the target is within the main unit, either at the source level or
7945 -- through an instantiation, then there is no real requirement to meet
7946 -- because the main unit cannot force its own elaboration by means of an
7947 -- Elaborate[_All] pragma. Treat this case as valid coverage.
7949 elsif In_Extended_Main_Code_Unit (Target_Id) then
7952 -- Otherwise the target resides in an external unit
7954 -- The requirement is met when the target comes from an internal unit
7955 -- because such a unit is elaborated prior to a non-internal unit.
7957 elsif In_Internal_Unit (Unit_Id)
7958 and then not In_Internal_Unit (Main_Id)
7962 -- The requirement is met when the target comes from a preelaborated
7963 -- unit. This portion must parallel predicate Is_Preelaborated_Unit.
7965 elsif Is_Preelaborated_Unit (Unit_Id) then
7968 -- Output extra information when switch -gnatel (info messages on
7969 -- implicit Elaborate[_All] pragmas.
7971 if Elab_Info_Messages then
7972 if Is_Preelaborated (Unit_Id) then
7973 Elab_Nam := Name_Preelaborate;
7975 elsif Is_Pure (Unit_Id) then
7976 Elab_Nam := Name_Pure;
7978 elsif Is_Remote_Call_Interface (Unit_Id) then
7979 Elab_Nam := Name_Remote_Call_Interface;
7981 elsif Is_Remote_Types (Unit_Id) then
7982 Elab_Nam := Name_Remote_Types;
7985 pragma Assert (Is_Shared_Passive (Unit_Id));
7986 Elab_Nam := Name_Shared_Passive;
7989 Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam));
7992 -- Determine whether the context of the main unit has a pragma strong
7993 -- enough to meet the requirement.
7996 Elab_Attrs := Elaboration_Status (Unit_Id);
7998 -- The pragma must be either Elaborate_All or be as strong as the
8001 if Present (Elab_Attrs.Source_Pragma)
8002 and then Nam_In (Pragma_Name (Elab_Attrs.Source_Pragma),
8008 -- Output extra information when switch -gnatel (info messages on
8009 -- implicit Elaborate[_All] pragmas.
8011 if Elab_Info_Messages then
8012 Info_Requirement_Met (Elab_Attrs.Source_Pragma);
8017 -- The requirement was not met by the context of the main unit, issue an
8023 Error_Msg_Name_1 := Req_Nam;
8024 Error_Msg_Node_2 := Unit_Id;
8025 Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id);
8027 Output_Active_Scenarios (N);
8029 end Meet_Elaboration_Requirement;
8031 ----------------------
8032 -- Non_Private_View --
8033 ----------------------
8035 function Non_Private_View (Typ : Entity_Id) return Entity_Id is
8041 if Is_Private_Type (Result) and then Present (Full_View (Result)) then
8042 Result := Full_View (Result);
8046 end Non_Private_View;
8048 -----------------------------
8049 -- Output_Active_Scenarios --
8050 -----------------------------
8052 procedure Output_Active_Scenarios (Error_Nod : Node_Id) is
8053 procedure Output_Access (N : Node_Id);
8054 -- Emit a specific diagnostic message for 'Access denote by N
8056 procedure Output_Activation_Call (N : Node_Id);
8057 -- Emit a specific diagnostic message for task activation N
8059 procedure Output_Call (N : Node_Id; Target_Id : Entity_Id);
8060 -- Emit a specific diagnostic message for call N which invokes target
8063 procedure Output_Header;
8064 -- Emit a specific diagnostic message for the unit of the root scenario
8066 procedure Output_Instantiation (N : Node_Id);
8067 -- Emit a specific diagnostic message for instantiation N
8069 procedure Output_SPARK_Refined_State_Pragma (N : Node_Id);
8070 -- Emit a specific diagnostic message for Refined_State pragma N
8072 procedure Output_Variable_Assignment (N : Node_Id);
8073 -- Emit a specific diagnostic message for assignment statement N
8075 procedure Output_Variable_Reference (N : Node_Id);
8076 -- Emit a specific diagnostic message for reference N which mentions a
8083 procedure Output_Access (N : Node_Id) is
8084 Subp_Id : constant Entity_Id := Entity (Prefix (N));
8087 Error_Msg_Name_1 := Attribute_Name (N);
8088 Error_Msg_Sloc := Sloc (N);
8089 Error_Msg_NE ("\\ % of & taken #", Error_Nod, Subp_Id);
8092 ----------------------------
8093 -- Output_Activation_Call --
8094 ----------------------------
8096 procedure Output_Activation_Call (N : Node_Id) is
8097 function Find_Activator (Call : Node_Id) return Entity_Id;
8098 -- Find the nearest enclosing construct which houses call Call
8100 --------------------
8101 -- Find_Activator --
8102 --------------------
8104 function Find_Activator (Call : Node_Id) return Entity_Id is
8108 -- Climb the parent chain looking for a package [body] or a
8109 -- construct with a statement sequence.
8111 Par := Parent (Call);
8112 while Present (Par) loop
8113 if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then
8114 return Defining_Entity (Par);
8116 elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then
8117 return Defining_Entity (Parent (Par));
8120 Par := Parent (Par);
8128 Activator : constant Entity_Id := Find_Activator (N);
8130 -- Start of processing for Output_Activation_Call
8133 pragma Assert (Present (Activator));
8135 Error_Msg_NE ("\\ local tasks of & activated", Error_Nod, Activator);
8136 end Output_Activation_Call;
8142 procedure Output_Call (N : Node_Id; Target_Id : Entity_Id) is
8143 procedure Output_Accept_Alternative;
8144 pragma Inline (Output_Accept_Alternative);
8145 -- Emit a specific diagnostic message concerning an accept
8148 procedure Output_Call (Kind : String);
8149 pragma Inline (Output_Call);
8150 -- Emit a specific diagnostic message concerning a call of kind Kind
8152 procedure Output_Type_Actions (Action : String);
8153 pragma Inline (Output_Type_Actions);
8154 -- Emit a specific diagnostic message concerning action Action of a
8157 procedure Output_Verification_Call
8161 pragma Inline (Output_Verification_Call);
8162 -- Emit a specific diagnostic message concerning the verification of
8163 -- predicate Pred applied to related entity Id with kind Id_Kind.
8165 -------------------------------
8166 -- Output_Accept_Alternative --
8167 -------------------------------
8169 procedure Output_Accept_Alternative is
8170 Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id);
8173 pragma Assert (Present (Entry_Id));
8175 Error_Msg_NE ("\\ entry & selected #", Error_Nod, Entry_Id);
8176 end Output_Accept_Alternative;
8182 procedure Output_Call (Kind : String) is
8184 Error_Msg_NE ("\\ " & Kind & " & called #", Error_Nod, Target_Id);
8187 -------------------------
8188 -- Output_Type_Actions --
8189 -------------------------
8191 procedure Output_Type_Actions (Action : String) is
8192 Typ : constant Entity_Id := First_Formal_Type (Target_Id);
8195 pragma Assert (Present (Typ));
8198 ("\\ " & Action & " actions for type & #", Error_Nod, Typ);
8199 end Output_Type_Actions;
8201 ------------------------------
8202 -- Output_Verification_Call --
8203 ------------------------------
8205 procedure Output_Verification_Call
8211 pragma Assert (Present (Id));
8214 ("\\ " & Pred & " of " & Id_Kind & " & verified #",
8216 end Output_Verification_Call;
8218 -- Start of processing for Output_Call
8221 Error_Msg_Sloc := Sloc (N);
8223 -- Accept alternative
8225 if Is_Accept_Alternative_Proc (Target_Id) then
8226 Output_Accept_Alternative;
8230 elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then
8231 Output_Type_Actions ("adjustment");
8233 -- Default_Initial_Condition
8235 elsif Is_Default_Initial_Condition_Proc (Target_Id) then
8236 Output_Verification_Call
8237 (Pred => "Default_Initial_Condition",
8238 Id => First_Formal_Type (Target_Id),
8243 elsif Is_Protected_Entry (Target_Id) then
8244 Output_Call ("entry");
8246 -- Task entry calls are never processed because the entry being
8247 -- invoked does not have a corresponding "body", it has a select. A
8248 -- task entry call appears in the stack of active scenarios for the
8249 -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and
8252 elsif Is_Task_Entry (Target_Id) then
8257 elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then
8258 Output_Type_Actions ("finalization");
8260 -- Calls to _Finalizer procedures must not appear in the output
8261 -- because this creates confusing noise.
8263 elsif Is_Finalizer_Proc (Target_Id) then
8266 -- Initial_Condition
8268 elsif Is_Initial_Condition_Proc (Target_Id) then
8269 Output_Verification_Call
8270 (Pred => "Initial_Condition",
8271 Id => Find_Enclosing_Scope (N),
8272 Id_Kind => "package");
8276 elsif Is_Init_Proc (Target_Id)
8277 or else Is_TSS (Target_Id, TSS_Deep_Initialize)
8279 Output_Type_Actions ("initialization");
8283 elsif Is_Invariant_Proc (Target_Id) then
8284 Output_Verification_Call
8285 (Pred => "invariants",
8286 Id => First_Formal_Type (Target_Id),
8289 -- Partial invariant calls must not appear in the output because this
8290 -- creates confusing noise. Note that a partial invariant is always
8291 -- invoked by the "full" invariant which is already placed on the
8294 elsif Is_Partial_Invariant_Proc (Target_Id) then
8299 elsif Is_Postconditions_Proc (Target_Id) then
8300 Output_Verification_Call
8301 (Pred => "postconditions",
8302 Id => Find_Enclosing_Scope (N),
8303 Id_Kind => "subprogram");
8305 -- Subprograms must come last because some of the previous cases fall
8306 -- under this category.
8308 elsif Ekind (Target_Id) = E_Function then
8309 Output_Call ("function");
8311 elsif Ekind (Target_Id) = E_Procedure then
8312 Output_Call ("procedure");
8315 pragma Assert (False);
8324 procedure Output_Header is
8325 Unit_Id : constant Entity_Id := Find_Top_Unit (Root_Scenario);
8328 if Ekind (Unit_Id) = E_Package then
8329 Error_Msg_NE ("\\ spec of unit & elaborated", Error_Nod, Unit_Id);
8331 elsif Ekind (Unit_Id) = E_Package_Body then
8332 Error_Msg_NE ("\\ body of unit & elaborated", Error_Nod, Unit_Id);
8335 Error_Msg_NE ("\\ in body of unit &", Error_Nod, Unit_Id);
8339 --------------------------
8340 -- Output_Instantiation --
8341 --------------------------
8343 procedure Output_Instantiation (N : Node_Id) is
8344 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String);
8345 pragma Inline (Output_Instantiation);
8346 -- Emit a specific diagnostic message concerning an instantiation of
8347 -- generic unit Gen_Id. Kind denotes the kind of the instantiation.
8349 --------------------------
8350 -- Output_Instantiation --
8351 --------------------------
8353 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String) is
8356 ("\\ " & Kind & " & instantiated as & #", Error_Nod, Gen_Id);
8357 end Output_Instantiation;
8362 Inst_Attrs : Instantiation_Attributes;
8363 Inst_Id : Entity_Id;
8366 -- Start of processing for Output_Instantiation
8369 Extract_Instantiation_Attributes
8374 Attrs => Inst_Attrs);
8376 Error_Msg_Node_2 := Inst_Id;
8377 Error_Msg_Sloc := Sloc (Inst);
8379 if Nkind (Inst) = N_Function_Instantiation then
8380 Output_Instantiation (Gen_Id, "function");
8382 elsif Nkind (Inst) = N_Package_Instantiation then
8383 Output_Instantiation (Gen_Id, "package");
8385 elsif Nkind (Inst) = N_Procedure_Instantiation then
8386 Output_Instantiation (Gen_Id, "procedure");
8389 pragma Assert (False);
8392 end Output_Instantiation;
8394 ---------------------------------------
8395 -- Output_SPARK_Refined_State_Pragma --
8396 ---------------------------------------
8398 procedure Output_SPARK_Refined_State_Pragma (N : Node_Id) is
8400 Error_Msg_Sloc := Sloc (N);
8401 Error_Msg_N ("\\ refinement constituents read #", Error_Nod);
8402 end Output_SPARK_Refined_State_Pragma;
8404 --------------------------------
8405 -- Output_Variable_Assignment --
8406 --------------------------------
8408 procedure Output_Variable_Assignment (N : Node_Id) is
8409 Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (N));
8412 Error_Msg_Sloc := Sloc (N);
8413 Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id);
8414 end Output_Variable_Assignment;
8416 -------------------------------
8417 -- Output_Variable_Reference --
8418 -------------------------------
8420 procedure Output_Variable_Reference (N : Node_Id) is
8421 Dummy : Variable_Attributes;
8425 Extract_Variable_Reference_Attributes
8430 Error_Msg_Sloc := Sloc (N);
8433 Error_Msg_NE ("\\ variable & read #", Error_Nod, Var_Id);
8436 pragma Assert (False);
8439 end Output_Variable_Reference;
8443 package Stack renames Scenario_Stack;
8445 Dummy : Call_Attributes;
8448 Target_Id : Entity_Id;
8450 -- Start of processing for Output_Active_Scenarios
8453 -- Active scenarios are emitted only when the static model is in effect
8454 -- because there is an inherent order by which all these scenarios were
8455 -- reached from the declaration or library level.
8457 if not Static_Elaboration_Checks then
8463 for Index in Stack.First .. Stack.Last loop
8464 N := Stack.Table (Index);
8473 if Nkind (N) = N_Attribute_Reference then
8478 elsif Is_Suitable_Call (N) then
8479 Extract_Call_Attributes
8481 Target_Id => Target_Id,
8484 if Is_Activation_Proc (Target_Id) then
8485 Output_Activation_Call (N);
8487 Output_Call (N, Target_Id);
8492 elsif Is_Suitable_Instantiation (N) then
8493 Output_Instantiation (N);
8495 -- Pragma Refined_State
8497 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then
8498 Output_SPARK_Refined_State_Pragma (N);
8500 -- Variable assignments
8502 elsif Nkind (N) = N_Assignment_Statement then
8503 Output_Variable_Assignment (N);
8505 -- Variable references
8507 elsif Is_Suitable_Variable_Reference (N) then
8508 Output_Variable_Reference (N);
8511 pragma Assert (False);
8515 end Output_Active_Scenarios;
8517 -------------------------
8518 -- Pop_Active_Scenario --
8519 -------------------------
8521 procedure Pop_Active_Scenario (N : Node_Id) is
8522 Top : Node_Id renames Scenario_Stack.Table (Scenario_Stack.Last);
8525 pragma Assert (Top = N);
8526 Scenario_Stack.Decrement_Last;
8527 end Pop_Active_Scenario;
8529 --------------------------------
8530 -- Process_Activation_Generic --
8531 --------------------------------
8533 procedure Process_Activation_Generic
8535 Call_Attrs : Call_Attributes;
8536 State : Processing_Attributes)
8538 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id);
8539 -- Perform ABE checks and diagnostics for object Obj_Id with type Typ.
8540 -- Typ may be a task type or a composite type with at least one task
8543 procedure Process_Task_Objects (List : List_Id);
8544 -- Perform ABE checks and diagnostics for all task objects found in the
8547 -------------------------
8548 -- Process_Task_Object --
8549 -------------------------
8551 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id) is
8552 Base_Typ : constant Entity_Id := Base_Type (Typ);
8554 Comp_Id : Entity_Id;
8555 Task_Attrs : Task_Attributes;
8557 New_State : Processing_Attributes := State;
8558 -- Each step of the Processing phase constitutes a new state
8561 if Is_Task_Type (Typ) then
8562 Extract_Task_Attributes
8564 Attrs => Task_Attrs);
8566 -- Warnings are suppressed when a prior scenario is already in
8567 -- that mode, or when the object, activation call, or task type
8568 -- have warnings suppressed. Update the state of the Processing
8569 -- phase to reflect this.
8571 New_State.Suppress_Warnings :=
8572 New_State.Suppress_Warnings
8573 or else not Is_Elaboration_Warnings_OK_Id (Obj_Id)
8574 or else not Call_Attrs.Elab_Warnings_OK
8575 or else not Task_Attrs.Elab_Warnings_OK;
8577 -- Update the state of the Processing phase to indicate that any
8578 -- further traversal is now within a task body.
8580 New_State.Within_Task_Body := True;
8582 Process_Single_Activation
8584 Call_Attrs => Call_Attrs,
8586 Task_Attrs => Task_Attrs,
8587 State => New_State);
8589 -- Examine the component type when the object is an array
8591 elsif Is_Array_Type (Typ) and then Has_Task (Base_Typ) then
8594 Typ => Component_Type (Typ));
8596 -- Examine individual component types when the object is a record
8598 elsif Is_Record_Type (Typ) and then Has_Task (Base_Typ) then
8599 Comp_Id := First_Component (Typ);
8600 while Present (Comp_Id) loop
8603 Typ => Etype (Comp_Id));
8605 Next_Component (Comp_Id);
8608 end Process_Task_Object;
8610 --------------------------
8611 -- Process_Task_Objects --
8612 --------------------------
8614 procedure Process_Task_Objects (List : List_Id) is
8616 Item_Id : Entity_Id;
8617 Item_Typ : Entity_Id;
8620 -- Examine the contents of the list looking for an object declaration
8621 -- of a task type or one that contains a task within.
8623 Item := First (List);
8624 while Present (Item) loop
8625 if Nkind (Item) = N_Object_Declaration then
8626 Item_Id := Defining_Entity (Item);
8627 Item_Typ := Etype (Item_Id);
8629 if Has_Task (Item_Typ) then
8638 end Process_Task_Objects;
8645 -- Start of processing for Process_Activation_Generic
8648 -- Nothing to do when the activation is a guaranteed ABE
8650 if Is_Known_Guaranteed_ABE (Call) then
8654 -- Find the proper context of the activation call where all task objects
8655 -- being activated are declared. This is usually the immediate parent of
8658 Context := Parent (Call);
8660 -- In the case of package bodies, the activation call is in the handled
8661 -- sequence of statements, but the task objects are in the declaration
8662 -- list of the body.
8664 if Nkind (Context) = N_Handled_Sequence_Of_Statements
8665 and then Nkind (Parent (Context)) = N_Package_Body
8667 Context := Parent (Context);
8670 -- Process all task objects defined in both the spec and body when the
8671 -- activation call precedes the "begin" of a package body.
8673 if Nkind (Context) = N_Package_Body then
8676 (Unit_Declaration_Node (Corresponding_Spec (Context)));
8678 Process_Task_Objects (Visible_Declarations (Spec));
8679 Process_Task_Objects (Private_Declarations (Spec));
8680 Process_Task_Objects (Declarations (Context));
8682 -- Process all task objects defined in the spec when the activation call
8683 -- appears at the end of a package spec.
8685 elsif Nkind (Context) = N_Package_Specification then
8686 Process_Task_Objects (Visible_Declarations (Context));
8687 Process_Task_Objects (Private_Declarations (Context));
8689 -- Otherwise the context of the activation is some construct with a
8690 -- declarative part. Note that the corresponding record type of a task
8691 -- type is controlled. Because of this, the finalization machinery must
8692 -- relocate the task object to the handled statements of the construct
8693 -- to perform proper finalization in case of an exception. Examine the
8694 -- statements of the construct rather than the declarations.
8697 pragma Assert (Nkind (Context) = N_Handled_Sequence_Of_Statements);
8699 Process_Task_Objects (Statements (Context));
8701 end Process_Activation_Generic;
8703 ------------------------------------
8704 -- Process_Conditional_ABE_Access --
8705 ------------------------------------
8707 procedure Process_Conditional_ABE_Access
8709 State : Processing_Attributes)
8711 function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id;
8712 pragma Inline (Build_Access_Marker);
8713 -- Create a suitable call marker which invokes target Target_Id
8715 -------------------------
8716 -- Build_Access_Marker --
8717 -------------------------
8719 function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id is
8723 Marker := Make_Call_Marker (Sloc (Attr));
8725 -- Inherit relevant attributes from the attribute
8727 -- Performance note: parent traversal
8729 Set_Target (Marker, Target_Id);
8730 Set_Is_Declaration_Level_Node
8731 (Marker, Find_Enclosing_Level (Attr) = Declaration_Level);
8732 Set_Is_Dispatching_Call
8734 Set_Is_Elaboration_Checks_OK_Node
8735 (Marker, Is_Elaboration_Checks_OK_Node (Attr));
8736 Set_Is_Elaboration_Warnings_OK_Node
8737 (Marker, Is_Elaboration_Warnings_OK_Node (Attr));
8739 (Marker, Comes_From_Source (Attr));
8740 Set_Is_SPARK_Mode_On_Node
8741 (Marker, Is_SPARK_Mode_On_Node (Attr));
8743 -- Partially insert the call marker into the tree by setting its
8746 Set_Parent (Marker, Attr);
8749 end Build_Access_Marker;
8753 Root : constant Node_Id := Root_Scenario;
8754 Target_Id : constant Entity_Id := Entity (Prefix (Attr));
8756 Target_Attrs : Target_Attributes;
8758 New_State : Processing_Attributes := State;
8759 -- Each step of the Processing phase constitutes a new state
8761 -- Start of processing for Process_Conditional_ABE_Access
8764 -- Output relevant information when switch -gnatel (info messages on
8765 -- implicit Elaborate[_All] pragmas) is in effect.
8767 if Elab_Info_Messages then
8769 ("info: access to & during elaboration", Attr, Target_Id);
8772 Extract_Target_Attributes
8773 (Target_Id => Target_Id,
8774 Attrs => Target_Attrs);
8776 -- Warnings are suppressed when a prior scenario is already in that
8777 -- mode, or when the attribute or the target have warnings suppressed.
8778 -- Update the state of the Processing phase to reflect this.
8780 New_State.Suppress_Warnings :=
8781 New_State.Suppress_Warnings
8782 or else not Is_Elaboration_Warnings_OK_Node (Attr)
8783 or else not Target_Attrs.Elab_Warnings_OK;
8785 -- Do not emit any ABE diagnostics when the current or previous scenario
8786 -- in this traversal has suppressed elaboration warnings.
8788 if New_State.Suppress_Warnings then
8791 -- Both the attribute and the corresponding body are in the same unit.
8792 -- The corresponding body must appear prior to the root scenario which
8793 -- started the recursive search. If this is not the case, then there is
8794 -- a potential ABE if the access value is used to call the subprogram.
8795 -- Emit a warning only when switch -gnatw.f (warnings on suspucious
8796 -- 'Access) is in effect.
8798 elsif Warn_On_Elab_Access
8799 and then Present (Target_Attrs.Body_Decl)
8800 and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl)
8801 and then Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl)
8803 Error_Msg_Name_1 := Attribute_Name (Attr);
8804 Error_Msg_NE ("??% attribute of & before body seen", Attr, Target_Id);
8805 Error_Msg_N ("\possible Program_Error on later references", Attr);
8807 Output_Active_Scenarios (Attr);
8810 -- Treat the attribute as an immediate invocation of the target when
8811 -- switch -gnatd.o (conservative elaboration order for indirect calls)
8812 -- is in effect. Note that the prior elaboration of the unit containing
8813 -- the target is ensured processing the corresponding call marker.
8815 if Debug_Flag_Dot_O then
8816 Process_Conditional_ABE
8817 (N => Build_Access_Marker (Target_Id),
8818 State => New_State);
8820 -- Otherwise ensure that the unit with the corresponding body is
8821 -- elaborated prior to the main unit.
8824 Ensure_Prior_Elaboration
8826 Unit_Id => Target_Attrs.Unit_Id,
8827 Prag_Nam => Name_Elaborate_All,
8828 State => New_State);
8830 end Process_Conditional_ABE_Access;
8832 ---------------------------------------------
8833 -- Process_Conditional_ABE_Activation_Impl --
8834 ---------------------------------------------
8836 procedure Process_Conditional_ABE_Activation_Impl
8838 Call_Attrs : Call_Attributes;
8840 Task_Attrs : Task_Attributes;
8841 State : Processing_Attributes)
8843 Check_OK : constant Boolean :=
8844 not Is_Ignored_Ghost_Entity (Obj_Id)
8845 and then not Task_Attrs.Ghost_Mode_Ignore
8846 and then Is_Elaboration_Checks_OK_Id (Obj_Id)
8847 and then Task_Attrs.Elab_Checks_OK;
8848 -- A run-time ABE check may be installed only when the object and the
8849 -- task type have active elaboration checks, and both are not ignored
8850 -- Ghost constructs.
8852 Root : constant Node_Id := Root_Scenario;
8854 New_State : Processing_Attributes := State;
8855 -- Each step of the Processing phase constitutes a new state
8858 -- Output relevant information when switch -gnatel (info messages on
8859 -- implicit Elaborate[_All] pragmas) is in effect.
8861 if Elab_Info_Messages then
8863 ("info: activation of & during elaboration", Call, Obj_Id);
8866 -- Nothing to do when the call activates a task whose type is defined
8867 -- within an instance and switch -gnatd_i (ignore activations and calls
8868 -- to instances for elaboration) is in effect.
8870 if Debug_Flag_Underscore_I
8871 and then In_External_Instance
8873 Target_Decl => Task_Attrs.Task_Decl)
8877 -- Nothing to do when the activation is a guaranteed ABE
8879 elsif Is_Known_Guaranteed_ABE (Call) then
8882 -- Nothing to do when the root scenario appears at the declaration
8883 -- level and the task is in the same unit, but outside this context.
8885 -- task type Task_Typ; -- task declaration
8887 -- procedure Proc is
8888 -- function A ... is
8890 -- if Some_Condition then
8894 -- <activation call> -- activation site
8899 -- X : ... := A; -- root scenario
8902 -- task body Task_Typ is
8906 -- In the example above, the context of X is the declarative list of
8907 -- Proc. The "elaboration" of X may reach the activation of T whose body
8908 -- is defined outside of X's context. The task body is relevant only
8909 -- when Proc is invoked, but this happens only in "normal" elaboration,
8910 -- therefore the task body must not be considered if this is not the
8913 -- Performance note: parent traversal
8915 elsif Is_Up_Level_Target (Task_Attrs.Task_Decl) then
8918 -- Nothing to do when the activation is ABE-safe
8922 -- task type Task_Typ;
8925 -- package body Gen is
8926 -- task body Task_Typ is
8933 -- procedure Main is
8934 -- package Nested is
8935 -- package Inst is new Gen;
8936 -- T : Inst.Task_Typ;
8937 -- <activation call> -- safe activation
8941 elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then
8943 -- Note that the task body must still be examined for any nested
8948 -- The activation call and the task body are both in the main unit
8950 elsif Present (Task_Attrs.Body_Decl)
8951 and then In_Extended_Main_Code_Unit (Task_Attrs.Body_Decl)
8953 -- If the root scenario appears prior to the task body, then this is
8954 -- a possible ABE with respect to the root scenario.
8956 -- task type Task_Typ;
8958 -- function A ... is
8960 -- if Some_Condition then
8964 -- end Pack; -- activation of T
8968 -- X : ... := A; -- root scenario
8970 -- task body Task_Typ is -- task body
8974 -- Y : ... := A; -- root scenario
8976 -- IMPORTANT: The activation of T is a possible ABE for X, but
8977 -- not for Y. Intalling an unconditional ABE raise prior to the
8978 -- activation call would be wrong as it will fail for Y as well
8979 -- but in Y's case the activation of T is never an ABE.
8981 if Earlier_In_Extended_Unit (Root, Task_Attrs.Body_Decl) then
8983 -- Do not emit any ABE diagnostics when a previous scenario in
8984 -- this traversal has suppressed elaboration warnings.
8986 if State.Suppress_Warnings then
8989 -- Do not emit any ABE diagnostics when the activation occurs in
8990 -- a partial finalization context because this leads to confusing
8993 elsif State.Within_Partial_Finalization then
8996 -- ABE diagnostics are emitted only in the static model because
8997 -- there is a well-defined order to visiting scenarios. Without
8998 -- this order diagnostics appear jumbled and result in unwanted
9001 elsif Static_Elaboration_Checks then
9002 Error_Msg_Sloc := Sloc (Call);
9004 ("??task & will be activated # before elaboration of its "
9007 ("\Program_Error may be raised at run time", Obj_Id);
9009 Output_Active_Scenarios (Obj_Id);
9012 -- Install a conditional run-time ABE check to verify that the
9013 -- task body has been elaborated prior to the activation call.
9019 Target_Id => Task_Attrs.Spec_Id,
9020 Target_Decl => Task_Attrs.Task_Decl,
9021 Target_Body => Task_Attrs.Body_Decl);
9023 -- Update the state of the Processing phase to indicate that
9024 -- no implicit Elaborate[_All] pragmas must be generated from
9027 -- task type Task_Typ;
9029 -- function A ... is
9031 -- if Some_Condition then
9036 -- end Pack; -- activation of T
9042 -- task body Task_Typ is
9044 -- External.Subp; -- imparts Elaborate_All
9047 -- If Some_Condition is True, then the ABE check will fail at
9048 -- runtime and the call to External.Subp will never take place,
9049 -- rendering the implicit Elaborate_All useless.
9051 -- If Some_Condition is False, then the call to External.Subp
9052 -- will never take place, rendering the implicit Elaborate_All
9055 New_State.Suppress_Implicit_Pragmas := True;
9059 -- Otherwise the task body is not available in this compilation or it
9060 -- resides in an external unit. Install a run-time ABE check to verify
9061 -- that the task body has been elaborated prior to the activation call
9062 -- when the dynamic model is in effect.
9064 elsif Dynamic_Elaboration_Checks and then Check_OK then
9068 Id => Task_Attrs.Unit_Id);
9071 -- Both the activation call and task type are subject to SPARK_Mode
9072 -- On, this triggers the SPARK rules for task activation. Compared to
9073 -- calls and instantiations, task activation in SPARK does not require
9074 -- the presence of Elaborate[_All] pragmas in case the task type is
9075 -- defined outside the main unit. This is because SPARK utilizes a
9076 -- special policy which activates all tasks after the main unit has
9077 -- finished its elaboration.
9079 if Call_Attrs.SPARK_Mode_On and Task_Attrs.SPARK_Mode_On then
9082 -- Otherwise the Ada rules are in effect. Ensure that the unit with the
9083 -- task body is elaborated prior to the main unit.
9086 Ensure_Prior_Elaboration
9088 Unit_Id => Task_Attrs.Unit_Id,
9089 Prag_Nam => Name_Elaborate_All,
9090 State => New_State);
9094 (N => Task_Attrs.Body_Decl,
9095 State => New_State);
9096 end Process_Conditional_ABE_Activation_Impl;
9098 procedure Process_Conditional_ABE_Activation is
9099 new Process_Activation_Generic (Process_Conditional_ABE_Activation_Impl);
9101 ----------------------------------
9102 -- Process_Conditional_ABE_Call --
9103 ----------------------------------
9105 procedure Process_Conditional_ABE_Call
9107 Call_Attrs : Call_Attributes;
9108 Target_Id : Entity_Id;
9109 State : Processing_Attributes)
9111 function In_Initialization_Context (N : Node_Id) return Boolean;
9112 -- Determine whether arbitrary node N appears within a type init proc,
9113 -- primitive [Deep_]Initialize, or a block created for initialization
9116 function Is_Partial_Finalization_Proc return Boolean;
9117 pragma Inline (Is_Partial_Finalization_Proc);
9118 -- Determine whether call Call with target Target_Id invokes a partial
9119 -- finalization procedure.
9121 -------------------------------
9122 -- In_Initialization_Context --
9123 -------------------------------
9125 function In_Initialization_Context (N : Node_Id) return Boolean is
9127 Spec_Id : Entity_Id;
9130 -- Climb the parent chain looking for initialization actions
9133 while Present (Par) loop
9135 -- A block may be part of the initialization actions of a default
9136 -- initialized object.
9138 if Nkind (Par) = N_Block_Statement
9139 and then Is_Initialization_Block (Par)
9143 -- A subprogram body may denote an initialization routine
9145 elsif Nkind (Par) = N_Subprogram_Body then
9146 Spec_Id := Unique_Defining_Entity (Par);
9148 -- The current subprogram body denotes a type init proc or
9149 -- primitive [Deep_]Initialize.
9151 if Is_Init_Proc (Spec_Id)
9152 or else Is_Controlled_Proc (Spec_Id, Name_Initialize)
9153 or else Is_TSS (Spec_Id, TSS_Deep_Initialize)
9158 -- Prevent the search from going too far
9160 elsif Is_Body_Or_Package_Declaration (Par) then
9164 Par := Parent (Par);
9168 end In_Initialization_Context;
9170 ----------------------------------
9171 -- Is_Partial_Finalization_Proc --
9172 ----------------------------------
9174 function Is_Partial_Finalization_Proc return Boolean is
9176 -- To qualify, the target must denote primitive [Deep_]Finalize or a
9177 -- finalizer procedure, and the call must appear in an initialization
9181 (Is_Controlled_Proc (Target_Id, Name_Finalize)
9182 or else Is_Finalizer_Proc (Target_Id)
9183 or else Is_TSS (Target_Id, TSS_Deep_Finalize))
9184 and then In_Initialization_Context (Call);
9185 end Is_Partial_Finalization_Proc;
9189 SPARK_Rules_On : Boolean;
9190 Target_Attrs : Target_Attributes;
9192 New_State : Processing_Attributes := State;
9193 -- Each step of the Processing phase constitutes a new state
9195 -- Start of processing for Process_Conditional_ABE_Call
9198 Extract_Target_Attributes
9199 (Target_Id => Target_Id,
9200 Attrs => Target_Attrs);
9202 -- The SPARK rules are in effect when both the call and target are
9203 -- subject to SPARK_Mode On.
9206 Call_Attrs.SPARK_Mode_On and Target_Attrs.SPARK_Mode_On;
9208 -- Output relevant information when switch -gnatel (info messages on
9209 -- implicit Elaborate[_All] pragmas) is in effect.
9211 if Elab_Info_Messages then
9214 Target_Id => Target_Id,
9216 In_SPARK => SPARK_Rules_On);
9219 -- Check whether the invocation of an entry clashes with an existing
9222 if Is_Protected_Entry (Target_Id) then
9223 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call);
9225 elsif Is_Task_Entry (Target_Id) then
9226 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call);
9228 -- Task entry calls are never processed because the entry being
9229 -- invoked does not have a corresponding "body", it has a select.
9234 -- Nothing to do when the call invokes a target defined within an
9235 -- instance and switch -gnatd_i (ignore activations and calls to
9236 -- instances for elaboration) is in effect.
9238 if Debug_Flag_Underscore_I
9239 and then In_External_Instance
9241 Target_Decl => Target_Attrs.Spec_Decl)
9245 -- Nothing to do when the call is a guaranteed ABE
9247 elsif Is_Known_Guaranteed_ABE (Call) then
9250 -- Nothing to do when the root scenario appears at the declaration level
9251 -- and the target is in the same unit, but outside this context.
9253 -- function B ...; -- target declaration
9255 -- procedure Proc is
9256 -- function A ... is
9258 -- if Some_Condition then
9259 -- return B; -- call site
9263 -- X : ... := A; -- root scenario
9266 -- function B ... is
9270 -- In the example above, the context of X is the declarative region of
9271 -- Proc. The "elaboration" of X may eventually reach B which is defined
9272 -- outside of X's context. B is relevant only when Proc is invoked, but
9273 -- this happens only by means of "normal" elaboration, therefore B must
9274 -- not be considered if this is not the case.
9276 -- Performance note: parent traversal
9278 elsif Is_Up_Level_Target (Target_Attrs.Spec_Decl) then
9282 -- Warnings are suppressed when a prior scenario is already in that
9283 -- mode, or the call or target have warnings suppressed. Update the
9284 -- state of the Processing phase to reflect this.
9286 New_State.Suppress_Warnings :=
9287 New_State.Suppress_Warnings
9288 or else not Call_Attrs.Elab_Warnings_OK
9289 or else not Target_Attrs.Elab_Warnings_OK;
9291 -- The call occurs in an initial condition context when a prior scenario
9292 -- is already in that mode, or when the target is an Initial_Condition
9293 -- procedure. Update the state of the Processing phase to reflect this.
9295 New_State.Within_Initial_Condition :=
9296 New_State.Within_Initial_Condition
9297 or else Is_Initial_Condition_Proc (Target_Id);
9299 -- The call occurs in a partial finalization context when a prior
9300 -- scenario is already in that mode, or when the target denotes a
9301 -- [Deep_]Finalize primitive or a finalizer within an initialization
9302 -- context. Update the state of the Processing phase to reflect this.
9304 New_State.Within_Partial_Finalization :=
9305 New_State.Within_Partial_Finalization
9306 or else Is_Partial_Finalization_Proc;
9308 -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK
9309 -- elaboration rules in SPARK code) is intentionally not taken into
9310 -- account here because Process_Conditional_ABE_Call_SPARK has two
9311 -- separate modes of operation.
9313 if SPARK_Rules_On then
9314 Process_Conditional_ABE_Call_SPARK
9316 Target_Id => Target_Id,
9317 Target_Attrs => Target_Attrs,
9318 State => New_State);
9320 -- Otherwise the Ada rules are in effect
9323 Process_Conditional_ABE_Call_Ada
9325 Call_Attrs => Call_Attrs,
9326 Target_Id => Target_Id,
9327 Target_Attrs => Target_Attrs,
9328 State => New_State);
9331 -- Inspect the target body (and barried function) for other suitable
9332 -- elaboration scenarios.
9335 (N => Target_Attrs.Body_Barf,
9336 State => New_State);
9339 (N => Target_Attrs.Body_Decl,
9340 State => New_State);
9341 end Process_Conditional_ABE_Call;
9343 --------------------------------------
9344 -- Process_Conditional_ABE_Call_Ada --
9345 --------------------------------------
9347 procedure Process_Conditional_ABE_Call_Ada
9349 Call_Attrs : Call_Attributes;
9350 Target_Id : Entity_Id;
9351 Target_Attrs : Target_Attributes;
9352 State : Processing_Attributes)
9354 Check_OK : constant Boolean :=
9355 not Call_Attrs.Ghost_Mode_Ignore
9356 and then not Target_Attrs.Ghost_Mode_Ignore
9357 and then Call_Attrs.Elab_Checks_OK
9358 and then Target_Attrs.Elab_Checks_OK;
9359 -- A run-time ABE check may be installed only when both the call and the
9360 -- target have active elaboration checks, and both are not ignored Ghost
9363 Root : constant Node_Id := Root_Scenario;
9365 New_State : Processing_Attributes := State;
9366 -- Each step of the Processing phase constitutes a new state
9369 -- Nothing to do for an Ada dispatching call because there are no ABE
9370 -- diagnostics for either models. ABE checks for the dynamic model are
9371 -- handled by Install_Primitive_Elaboration_Check.
9373 if Call_Attrs.Is_Dispatching then
9376 -- Nothing to do when the call is ABE-safe
9379 -- function Gen ...;
9381 -- function Gen ... is
9387 -- procedure Main is
9388 -- function Inst is new Gen;
9389 -- X : ... := Inst; -- safe call
9392 elsif Is_Safe_Call (Call, Target_Attrs) then
9395 -- The call and the target body are both in the main unit
9397 elsif Present (Target_Attrs.Body_Decl)
9398 and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl)
9400 -- If the root scenario appears prior to the target body, then this
9401 -- is a possible ABE with respect to the root scenario.
9405 -- function A ... is
9407 -- if Some_Condition then
9408 -- return B; -- call site
9412 -- X : ... := A; -- root scenario
9414 -- function B ... is -- target body
9418 -- Y : ... := A; -- root scenario
9420 -- IMPORTANT: The call to B from A is a possible ABE for X, but not
9421 -- for Y. Installing an unconditional ABE raise prior to the call to
9422 -- B would be wrong as it will fail for Y as well, but in Y's case
9423 -- the call to B is never an ABE.
9425 if Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) then
9427 -- Do not emit any ABE diagnostics when a previous scenario in
9428 -- this traversal has suppressed elaboration warnings.
9430 if State.Suppress_Warnings then
9433 -- Do not emit any ABE diagnostics when the call occurs in a
9434 -- partial finalization context because this leads to confusing
9437 elsif State.Within_Partial_Finalization then
9440 -- ABE diagnostics are emitted only in the static model because
9441 -- there is a well-defined order to visiting scenarios. Without
9442 -- this order diagnostics appear jumbled and result in unwanted
9445 elsif Static_Elaboration_Checks then
9447 ("??cannot call & before body seen", Call, Target_Id);
9448 Error_Msg_N ("\Program_Error may be raised at run time", Call);
9450 Output_Active_Scenarios (Call);
9453 -- Install a conditional run-time ABE check to verify that the
9454 -- target body has been elaborated prior to the call.
9460 Target_Id => Target_Attrs.Spec_Id,
9461 Target_Decl => Target_Attrs.Spec_Decl,
9462 Target_Body => Target_Attrs.Body_Decl);
9464 -- Update the state of the Processing phase to indicate that
9465 -- no implicit Elaborate[_All] pragmas must be generated from
9470 -- function A ... is
9472 -- if Some_Condition then
9480 -- function B ... is
9481 -- External.Subp; -- imparts Elaborate_All
9484 -- If Some_Condition is True, then the ABE check will fail at
9485 -- runtime and the call to External.Subp will never take place,
9486 -- rendering the implicit Elaborate_All useless.
9488 -- If Some_Condition is False, then the call to External.Subp
9489 -- will never take place, rendering the implicit Elaborate_All
9492 New_State.Suppress_Implicit_Pragmas := True;
9496 -- Otherwise the target body is not available in this compilation or it
9497 -- resides in an external unit. Install a run-time ABE check to verify
9498 -- that the target body has been elaborated prior to the call site when
9499 -- the dynamic model is in effect.
9501 elsif Dynamic_Elaboration_Checks and then Check_OK then
9505 Id => Target_Attrs.Unit_Id);
9508 -- Ensure that the unit with the target body is elaborated prior to the
9509 -- main unit. The implicit Elaborate[_All] is generated only when the
9510 -- call has elaboration checks enabled. This behaviour parallels that of
9511 -- the old ABE mechanism.
9513 if Call_Attrs.Elab_Checks_OK then
9514 Ensure_Prior_Elaboration
9516 Unit_Id => Target_Attrs.Unit_Id,
9517 Prag_Nam => Name_Elaborate_All,
9518 State => New_State);
9520 end Process_Conditional_ABE_Call_Ada;
9522 ----------------------------------------
9523 -- Process_Conditional_ABE_Call_SPARK --
9524 ----------------------------------------
9526 procedure Process_Conditional_ABE_Call_SPARK
9528 Target_Id : Entity_Id;
9529 Target_Attrs : Target_Attributes;
9530 State : Processing_Attributes)
9535 -- Ensure that a suitable elaboration model is in effect for SPARK rule
9538 Check_SPARK_Model_In_Effect (Call);
9540 -- The call and the target body are both in the main unit
9542 if Present (Target_Attrs.Body_Decl)
9543 and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl)
9545 -- If the call appears prior to the target body, then the call must
9546 -- appear within the early call region of the target body.
9550 -- X : ... := B; -- call site
9552 -- <preelaborable construct 1> --+
9553 -- ... | early call region
9554 -- <preelaborable construct N> --+
9556 -- function B ... is -- target body
9560 -- When the call to B is not nested within some other scenario, the
9561 -- call is automatically illegal because it can never appear in the
9562 -- early call region of B's body. This is equivalent to a guaranteed
9565 -- <preelaborable construct 1> --+
9567 -- function B ...; |
9569 -- function A ... is |
9570 -- begin | early call region
9571 -- if Some_Condition then
9572 -- return B; -- call site
9576 -- <preelaborable construct N> --+
9578 -- function B ... is -- target body
9582 -- When the call to B is nested within some other scenario, the call
9583 -- is always ABE-safe. It is not immediately obvious why this is the
9584 -- case. The elaboration safety follows from the early call region
9585 -- rule being applied to ALL calls preceding their associated bodies.
9587 -- In the example above, the call to B is safe as long as the call to
9588 -- A is safe. There are several cases to consider:
9594 -- function A ... is
9596 -- if Some_Condition then
9602 -- function B ... is
9606 -- * Call 1 - This call is either nested within some scenario or not,
9607 -- which falls under the two general cases outlined above.
9609 -- * Call 2 - This is the same case as Call 1.
9611 -- * Call 3 - The placement of this call limits the range of B's
9612 -- early call region unto call 3, therefore the call to B is no
9613 -- longer within the early call region of B's body, making it ABE-
9614 -- unsafe and therefore illegal.
9616 if Earlier_In_Extended_Unit (Call, Target_Attrs.Body_Decl) then
9618 -- Do not emit any ABE diagnostics when a previous scenario in
9619 -- this traversal has suppressed elaboration warnings.
9621 if State.Suppress_Warnings then
9624 -- Do not emit any ABE diagnostics when the call occurs in an
9625 -- initial condition context because this leads to incorrect
9628 elsif State.Within_Initial_Condition then
9631 -- Do not emit any ABE diagnostics when the call occurs in a
9632 -- partial finalization context because this leads to confusing
9635 elsif State.Within_Partial_Finalization then
9638 -- ABE diagnostics are emitted only in the static model because
9639 -- there is a well-defined order to visiting scenarios. Without
9640 -- this order diagnostics appear jumbled and result in unwanted
9643 elsif Static_Elaboration_Checks then
9645 -- Ensure that a call which textually precedes the subprogram
9646 -- body it invokes appears within the early call region of the
9649 -- IMPORTANT: This check must always be performed even when
9650 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is
9651 -- not specified because the static model cannot guarantee the
9652 -- absence of elaboration issues in the presence of dispatching
9655 Region := Find_Early_Call_Region (Target_Attrs.Body_Decl);
9657 if Earlier_In_Extended_Unit (Call, Region) then
9659 ("call must appear within early call region of subprogram "
9660 & "body & (SPARK RM 7.7(3))", Call, Target_Id);
9662 Error_Msg_Sloc := Sloc (Region);
9663 Error_Msg_N ("\region starts #", Call);
9665 Error_Msg_Sloc := Sloc (Target_Attrs.Body_Decl);
9666 Error_Msg_N ("\region ends #", Call);
9668 Output_Active_Scenarios (Call);
9672 -- Otherwise the call appears after the target body. The call is
9673 -- ABE-safe as a consequence of applying the early call region rule
9674 -- to ALL calls preceding their associated bodies.
9681 -- A call to a source target or to a target which emulates Ada or SPARK
9682 -- semantics imposes an Elaborate_All requirement on the context of the
9683 -- main unit. Determine whether the context has a pragma strong enough
9684 -- to meet the requirement.
9686 -- IMPORTANT: This check must be performed only when -gnatd.v (enforce
9687 -- SPARK elaboration rules in SPARK code) is active because the static
9688 -- model can ensure the prior elaboration of the unit which contains a
9689 -- body by installing an implicit Elaborate[_All] pragma.
9691 if Debug_Flag_Dot_V then
9692 if Target_Attrs.From_Source
9693 or else Is_Ada_Semantic_Target (Target_Id)
9694 or else Is_SPARK_Semantic_Target (Target_Id)
9696 Meet_Elaboration_Requirement
9698 Target_Id => Target_Id,
9699 Req_Nam => Name_Elaborate_All);
9702 -- Otherwise ensure that the unit with the target body is elaborated
9703 -- prior to the main unit.
9706 Ensure_Prior_Elaboration
9708 Unit_Id => Target_Attrs.Unit_Id,
9709 Prag_Nam => Name_Elaborate_All,
9712 end Process_Conditional_ABE_Call_SPARK;
9714 -------------------------------------------
9715 -- Process_Conditional_ABE_Instantiation --
9716 -------------------------------------------
9718 procedure Process_Conditional_ABE_Instantiation
9719 (Exp_Inst : Node_Id;
9720 State : Processing_Attributes)
9722 Gen_Attrs : Target_Attributes;
9725 Inst_Attrs : Instantiation_Attributes;
9726 Inst_Id : Entity_Id;
9728 SPARK_Rules_On : Boolean;
9729 -- This flag is set when the SPARK rules are in effect
9731 New_State : Processing_Attributes := State;
9732 -- Each step of the Processing phase constitutes a new state
9735 Extract_Instantiation_Attributes
9736 (Exp_Inst => Exp_Inst,
9740 Attrs => Inst_Attrs);
9742 Extract_Target_Attributes (Gen_Id, Gen_Attrs);
9744 -- The SPARK rules are in effect when both the instantiation and generic
9745 -- are subject to SPARK_Mode On.
9747 SPARK_Rules_On := Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On;
9749 -- Output relevant information when switch -gnatel (info messages on
9750 -- implicit Elaborate[_All] pragmas) is in effect.
9752 if Elab_Info_Messages then
9757 In_SPARK => SPARK_Rules_On);
9760 -- Nothing to do when the instantiation is a guaranteed ABE
9762 if Is_Known_Guaranteed_ABE (Inst) then
9765 -- Nothing to do when the root scenario appears at the declaration level
9766 -- and the generic is in the same unit, but outside this context.
9769 -- procedure Gen is ...; -- generic declaration
9771 -- procedure Proc is
9772 -- function A ... is
9774 -- if Some_Condition then
9776 -- procedure I is new Gen; -- instantiation site
9781 -- X : ... := A; -- root scenario
9788 -- In the example above, the context of X is the declarative region of
9789 -- Proc. The "elaboration" of X may eventually reach Gen which appears
9790 -- outside of X's context. Gen is relevant only when Proc is invoked,
9791 -- but this happens only by means of "normal" elaboration, therefore
9792 -- Gen must not be considered if this is not the case.
9794 -- Performance note: parent traversal
9796 elsif Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then
9800 -- Warnings are suppressed when a prior scenario is already in that
9801 -- mode, or when the instantiation has warnings suppressed. Update
9802 -- the state of the processing phase to reflect this.
9804 New_State.Suppress_Warnings :=
9805 New_State.Suppress_Warnings or else not Inst_Attrs.Elab_Warnings_OK;
9807 -- The SPARK rules are in effect
9809 if SPARK_Rules_On then
9810 Process_Conditional_ABE_Instantiation_SPARK
9813 Gen_Attrs => Gen_Attrs,
9814 State => New_State);
9816 -- Otherwise the Ada rules are in effect, or SPARK code is allowed to
9817 -- violate the SPARK rules.
9820 Process_Conditional_ABE_Instantiation_Ada
9821 (Exp_Inst => Exp_Inst,
9823 Inst_Attrs => Inst_Attrs,
9825 Gen_Attrs => Gen_Attrs,
9826 State => New_State);
9828 end Process_Conditional_ABE_Instantiation;
9830 -----------------------------------------------
9831 -- Process_Conditional_ABE_Instantiation_Ada --
9832 -----------------------------------------------
9834 procedure Process_Conditional_ABE_Instantiation_Ada
9835 (Exp_Inst : Node_Id;
9837 Inst_Attrs : Instantiation_Attributes;
9839 Gen_Attrs : Target_Attributes;
9840 State : Processing_Attributes)
9842 Check_OK : constant Boolean :=
9843 not Inst_Attrs.Ghost_Mode_Ignore
9844 and then not Gen_Attrs.Ghost_Mode_Ignore
9845 and then Inst_Attrs.Elab_Checks_OK
9846 and then Gen_Attrs.Elab_Checks_OK;
9847 -- A run-time ABE check may be installed only when both the instance and
9848 -- the generic have active elaboration checks and both are not ignored
9849 -- Ghost constructs.
9851 Root : constant Node_Id := Root_Scenario;
9853 New_State : Processing_Attributes := State;
9854 -- Each step of the Processing phase constitutes a new state
9857 -- Nothing to do when the instantiation is ABE-safe
9864 -- package body Gen is
9869 -- procedure Main is
9870 -- package Inst is new Gen (ABE); -- safe instantiation
9873 if Is_Safe_Instantiation (Inst, Gen_Attrs) then
9876 -- The instantiation and the generic body are both in the main unit
9878 elsif Present (Gen_Attrs.Body_Decl)
9879 and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl)
9881 -- If the root scenario appears prior to the generic body, then this
9882 -- is a possible ABE with respect to the root scenario.
9889 -- function A ... is
9891 -- if Some_Condition then
9893 -- package Inst is new Gen; -- instantiation site
9897 -- X : ... := A; -- root scenario
9899 -- package body Gen is -- generic body
9903 -- Y : ... := A; -- root scenario
9905 -- IMPORTANT: The instantiation of Gen is a possible ABE for X, but
9906 -- not for Y. Installing an unconditional ABE raise prior to the
9907 -- instance site would be wrong as it will fail for Y as well, but in
9908 -- Y's case the instantiation of Gen is never an ABE.
9910 if Earlier_In_Extended_Unit (Root, Gen_Attrs.Body_Decl) then
9912 -- Do not emit any ABE diagnostics when a previous scenario in
9913 -- this traversal has suppressed elaboration warnings.
9915 if State.Suppress_Warnings then
9918 -- Do not emit any ABE diagnostics when the instantiation occurs
9919 -- in partial finalization context because this leads to unwanted
9922 elsif State.Within_Partial_Finalization then
9925 -- ABE diagnostics are emitted only in the static model because
9926 -- there is a well-defined order to visiting scenarios. Without
9927 -- this order diagnostics appear jumbled and result in unwanted
9930 elsif Static_Elaboration_Checks then
9932 ("??cannot instantiate & before body seen", Inst, Gen_Id);
9933 Error_Msg_N ("\Program_Error may be raised at run time", Inst);
9935 Output_Active_Scenarios (Inst);
9938 -- Install a conditional run-time ABE check to verify that the
9939 -- generic body has been elaborated prior to the instantiation.
9944 Ins_Nod => Exp_Inst,
9945 Target_Id => Gen_Attrs.Spec_Id,
9946 Target_Decl => Gen_Attrs.Spec_Decl,
9947 Target_Body => Gen_Attrs.Body_Decl);
9949 -- Update the state of the Processing phase to indicate that
9950 -- no implicit Elaborate[_All] pragmas must be generated from
9958 -- function A ... is
9960 -- if Some_Condition then
9962 -- declare Inst is new Gen;
9968 -- package body Gen is
9970 -- External.Subp; -- imparts Elaborate_All
9973 -- If Some_Condition is True, then the ABE check will fail at
9974 -- runtime and the call to External.Subp will never take place,
9975 -- rendering the implicit Elaborate_All useless.
9977 -- If Some_Condition is False, then the call to External.Subp
9978 -- will never take place, rendering the implicit Elaborate_All
9981 New_State.Suppress_Implicit_Pragmas := True;
9985 -- Otherwise the generic body is not available in this compilation or it
9986 -- resides in an external unit. Install a run-time ABE check to verify
9987 -- that the generic body has been elaborated prior to the instantiation
9988 -- when the dynamic model is in effect.
9990 elsif Dynamic_Elaboration_Checks and then Check_OK then
9993 Ins_Nod => Exp_Inst,
9994 Id => Gen_Attrs.Unit_Id);
9997 -- Ensure that the unit with the generic body is elaborated prior to
9998 -- the main unit. No implicit pragma is generated if the instantiation
9999 -- has elaboration checks suppressed. This behaviour parallels that of
10000 -- the old ABE mechanism.
10002 if Inst_Attrs.Elab_Checks_OK then
10003 Ensure_Prior_Elaboration
10005 Unit_Id => Gen_Attrs.Unit_Id,
10006 Prag_Nam => Name_Elaborate,
10007 State => New_State);
10009 end Process_Conditional_ABE_Instantiation_Ada;
10011 -------------------------------------------------
10012 -- Process_Conditional_ABE_Instantiation_SPARK --
10013 -------------------------------------------------
10015 procedure Process_Conditional_ABE_Instantiation_SPARK
10017 Gen_Id : Entity_Id;
10018 Gen_Attrs : Target_Attributes;
10019 State : Processing_Attributes)
10024 -- Ensure that a suitable elaboration model is in effect for SPARK rule
10027 Check_SPARK_Model_In_Effect (Inst);
10029 -- A source instantiation imposes an Elaborate[_All] requirement on the
10030 -- context of the main unit. Determine whether the context has a pragma
10031 -- strong enough to meet the requirement. The check is orthogonal to the
10032 -- ABE ramifications of the instantiation.
10034 -- IMPORTANT: This check must be performed only when -gnatd.v (enforce
10035 -- SPARK elaboration rules in SPARK code) is active because the static
10036 -- model can ensure the prior elaboration of the unit which contains a
10037 -- body by installing an implicit Elaborate[_All] pragma.
10039 if Debug_Flag_Dot_V then
10040 if Nkind (Inst) = N_Package_Instantiation then
10041 Req_Nam := Name_Elaborate_All;
10043 Req_Nam := Name_Elaborate;
10046 Meet_Elaboration_Requirement
10048 Target_Id => Gen_Id,
10049 Req_Nam => Req_Nam);
10051 -- Otherwise ensure that the unit with the target body is elaborated
10052 -- prior to the main unit.
10055 Ensure_Prior_Elaboration
10057 Unit_Id => Gen_Attrs.Unit_Id,
10058 Prag_Nam => Name_Elaborate,
10061 end Process_Conditional_ABE_Instantiation_SPARK;
10063 -------------------------------------------------
10064 -- Process_Conditional_ABE_Variable_Assignment --
10065 -------------------------------------------------
10067 procedure Process_Conditional_ABE_Variable_Assignment (Asmt : Node_Id) is
10068 Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (Asmt));
10069 Prag : constant Node_Id := SPARK_Pragma (Var_Id);
10071 SPARK_Rules_On : Boolean;
10072 -- This flag is set when the SPARK rules are in effect
10075 -- The SPARK rules are in effect when both the assignment and the
10076 -- variable are subject to SPARK_Mode On.
10080 and then Get_SPARK_Mode_From_Annotation (Prag) = On
10081 and then Is_SPARK_Mode_On_Node (Asmt);
10083 -- Output relevant information when switch -gnatel (info messages on
10084 -- implicit Elaborate[_All] pragmas) is in effect.
10086 if Elab_Info_Messages then
10088 (Msg => "assignment to & during elaboration",
10092 In_SPARK => SPARK_Rules_On);
10095 -- The SPARK rules are in effect. These rules are applied regardless of
10096 -- whether -gnatd.v (enforce SPARK elaboration rules in SPARK code) is
10097 -- in effect because the static model cannot ensure safe assignment of
10100 if SPARK_Rules_On then
10101 Process_Conditional_ABE_Variable_Assignment_SPARK
10105 -- Otherwise the Ada rules are in effect
10108 Process_Conditional_ABE_Variable_Assignment_Ada
10112 end Process_Conditional_ABE_Variable_Assignment;
10114 -----------------------------------------------------
10115 -- Process_Conditional_ABE_Variable_Assignment_Ada --
10116 -----------------------------------------------------
10118 procedure Process_Conditional_ABE_Variable_Assignment_Ada
10120 Var_Id : Entity_Id)
10122 Var_Decl : constant Node_Id := Declaration_Node (Var_Id);
10123 Spec_Id : constant Entity_Id := Find_Top_Unit (Var_Decl);
10126 -- Emit a warning when an uninitialized variable declared in a package
10127 -- spec without a pragma Elaborate_Body is initialized by elaboration
10128 -- code within the corresponding body.
10130 if Is_Elaboration_Warnings_OK_Id (Var_Id)
10131 and then not Is_Initialized (Var_Decl)
10132 and then not Has_Pragma_Elaborate_Body (Spec_Id)
10135 ("??variable & can be accessed by clients before this "
10136 & "initialization", Asmt, Var_Id);
10139 ("\add pragma ""Elaborate_Body"" to spec & to ensure proper "
10140 & "initialization", Asmt, Spec_Id);
10142 Output_Active_Scenarios (Asmt);
10144 -- Generate an implicit Elaborate_Body in the spec
10146 Set_Elaborate_Body_Desirable (Spec_Id);
10148 end Process_Conditional_ABE_Variable_Assignment_Ada;
10150 -------------------------------------------------------
10151 -- Process_Conditional_ABE_Variable_Assignment_SPARK --
10152 -------------------------------------------------------
10154 procedure Process_Conditional_ABE_Variable_Assignment_SPARK
10156 Var_Id : Entity_Id)
10158 Var_Decl : constant Node_Id := Declaration_Node (Var_Id);
10159 Spec_Id : constant Entity_Id := Find_Top_Unit (Var_Decl);
10162 -- Ensure that a suitable elaboration model is in effect for SPARK rule
10165 Check_SPARK_Model_In_Effect (Asmt);
10167 -- Emit an error when an initialized variable declared in a package spec
10168 -- without pragma Elaborate_Body is further modified by elaboration code
10169 -- within the corresponding body.
10171 if Is_Elaboration_Warnings_OK_Id (Var_Id)
10172 and then Is_Initialized (Var_Decl)
10173 and then not Has_Pragma_Elaborate_Body (Spec_Id)
10176 ("variable & modified by elaboration code in package body",
10180 ("\add pragma ""Elaborate_Body"" to spec & to ensure full "
10181 & "initialization", Asmt, Spec_Id);
10183 Output_Active_Scenarios (Asmt);
10185 end Process_Conditional_ABE_Variable_Assignment_SPARK;
10187 ------------------------------------------------
10188 -- Process_Conditional_ABE_Variable_Reference --
10189 ------------------------------------------------
10191 procedure Process_Conditional_ABE_Variable_Reference (Ref : Node_Id) is
10192 Var_Attrs : Variable_Attributes;
10193 Var_Id : Entity_Id;
10196 Extract_Variable_Reference_Attributes
10199 Attrs => Var_Attrs);
10201 if Is_Read (Ref) then
10202 Process_Conditional_ABE_Variable_Reference_Read
10205 Attrs => Var_Attrs);
10207 end Process_Conditional_ABE_Variable_Reference;
10209 -----------------------------------------------------
10210 -- Process_Conditional_ABE_Variable_Reference_Read --
10211 -----------------------------------------------------
10213 procedure Process_Conditional_ABE_Variable_Reference_Read
10215 Var_Id : Entity_Id;
10216 Attrs : Variable_Attributes)
10219 -- Output relevant information when switch -gnatel (info messages on
10220 -- implicit Elaborate[_All] pragmas) is in effect.
10222 if Elab_Info_Messages then
10224 (Msg => "read of variable & during elaboration",
10231 -- Nothing to do when the variable appears within the main unit because
10232 -- diagnostics on reads are relevant only for external variables.
10234 if Is_Same_Unit (Attrs.Unit_Id, Cunit_Entity (Main_Unit)) then
10237 -- Nothing to do when the variable is already initialized. Note that the
10238 -- variable may be further modified by the external unit.
10240 elsif Is_Initialized (Declaration_Node (Var_Id)) then
10243 -- Nothing to do when the external unit guarantees the initialization of
10244 -- the variable by means of pragma Elaborate_Body.
10246 elsif Has_Pragma_Elaborate_Body (Attrs.Unit_Id) then
10249 -- A variable read imposes an Elaborate requirement on the context of
10250 -- the main unit. Determine whether the context has a pragma strong
10251 -- enough to meet the requirement.
10254 Meet_Elaboration_Requirement
10256 Target_Id => Var_Id,
10257 Req_Nam => Name_Elaborate);
10259 end Process_Conditional_ABE_Variable_Reference_Read;
10261 -----------------------------
10262 -- Process_Conditional_ABE --
10263 -----------------------------
10265 -- NOTE: The body of this routine is intentionally out of order because it
10266 -- invokes an instantiated subprogram (Process_Conditional_ABE_Activation).
10267 -- Placing the body in alphabetical order will result in a guaranteed ABE.
10269 procedure Process_Conditional_ABE
10271 State : Processing_Attributes := Initial_State)
10273 Call_Attrs : Call_Attributes;
10274 Target_Id : Entity_Id;
10277 -- Add the current scenario to the stack of active scenarios
10279 Push_Active_Scenario (N);
10283 if Is_Suitable_Access (N) then
10284 Process_Conditional_ABE_Access
10288 -- Activations and calls
10290 elsif Is_Suitable_Call (N) then
10292 -- In general, only calls found within the main unit are processed
10293 -- because the ALI information supplied to binde is for the main
10294 -- unit only. However, to preserve the consistency of the tree and
10295 -- ensure proper serialization of internal names, external calls
10296 -- also receive corresponding call markers (see Build_Call_Marker).
10297 -- Regardless of the reason, external calls must not be processed.
10299 if In_Main_Context (N) then
10300 Extract_Call_Attributes
10302 Target_Id => Target_Id,
10303 Attrs => Call_Attrs);
10305 if Is_Activation_Proc (Target_Id) then
10306 Process_Conditional_ABE_Activation
10308 Call_Attrs => Call_Attrs,
10312 Process_Conditional_ABE_Call
10314 Call_Attrs => Call_Attrs,
10315 Target_Id => Target_Id,
10322 elsif Is_Suitable_Instantiation (N) then
10323 Process_Conditional_ABE_Instantiation
10327 -- Variable assignments
10329 elsif Is_Suitable_Variable_Assignment (N) then
10330 Process_Conditional_ABE_Variable_Assignment (N);
10332 -- Variable references
10334 elsif Is_Suitable_Variable_Reference (N) then
10336 -- In general, only variable references found within the main unit
10337 -- are processed because the ALI information supplied to binde is for
10338 -- the main unit only. However, to preserve the consistency of the
10339 -- tree and ensure proper serialization of internal names, external
10340 -- variable references also receive corresponding variable reference
10341 -- markers (see Build_Varaible_Reference_Marker). Regardless of the
10342 -- reason, external variable references must not be processed.
10344 if In_Main_Context (N) then
10345 Process_Conditional_ABE_Variable_Reference (N);
10349 -- Remove the current scenario from the stack of active scenarios once
10350 -- all ABE diagnostics and checks have been performed.
10352 Pop_Active_Scenario (N);
10353 end Process_Conditional_ABE;
10355 --------------------------------------------
10356 -- Process_Guaranteed_ABE_Activation_Impl --
10357 --------------------------------------------
10359 procedure Process_Guaranteed_ABE_Activation_Impl
10361 Call_Attrs : Call_Attributes;
10362 Obj_Id : Entity_Id;
10363 Task_Attrs : Task_Attributes;
10364 State : Processing_Attributes)
10366 pragma Unreferenced (State);
10368 Check_OK : constant Boolean :=
10369 not Is_Ignored_Ghost_Entity (Obj_Id)
10370 and then not Task_Attrs.Ghost_Mode_Ignore
10371 and then Is_Elaboration_Checks_OK_Id (Obj_Id)
10372 and then Task_Attrs.Elab_Checks_OK;
10373 -- A run-time ABE check may be installed only when the object and the
10374 -- task type have active elaboration checks, and both are not ignored
10375 -- Ghost constructs.
10378 -- Nothing to do when the root scenario appears at the declaration
10379 -- level and the task is in the same unit, but outside this context.
10381 -- task type Task_Typ; -- task declaration
10383 -- procedure Proc is
10384 -- function A ... is
10386 -- if Some_Condition then
10390 -- <activation call> -- activation site
10395 -- X : ... := A; -- root scenario
10398 -- task body Task_Typ is
10402 -- In the example above, the context of X is the declarative list of
10403 -- Proc. The "elaboration" of X may reach the activation of T whose body
10404 -- is defined outside of X's context. The task body is relevant only
10405 -- when Proc is invoked, but this happens only in "normal" elaboration,
10406 -- therefore the task body must not be considered if this is not the
10409 -- Performance note: parent traversal
10411 if Is_Up_Level_Target (Task_Attrs.Task_Decl) then
10414 -- Nothing to do when the activation is ABE-safe
10418 -- task type Task_Typ;
10421 -- package body Gen is
10422 -- task body Task_Typ is
10429 -- procedure Main is
10430 -- package Nested is
10431 -- package Inst is new Gen;
10432 -- T : Inst.Task_Typ;
10433 -- end Nested; -- safe activation
10436 elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then
10439 -- An activation call leads to a guaranteed ABE when the activation
10440 -- call and the task appear within the same context ignoring library
10441 -- levels, and the body of the task has not been seen yet or appears
10442 -- after the activation call.
10444 -- procedure Guaranteed_ABE is
10445 -- task type Task_Typ;
10447 -- package Nested is
10449 -- <activation call> -- guaranteed ABE
10452 -- task body Task_Typ is
10457 -- Performance note: parent traversal
10459 elsif Is_Guaranteed_ABE
10461 Target_Decl => Task_Attrs.Task_Decl,
10462 Target_Body => Task_Attrs.Body_Decl)
10464 if Call_Attrs.Elab_Warnings_OK then
10465 Error_Msg_Sloc := Sloc (Call);
10467 ("??task & will be activated # before elaboration of its body",
10469 Error_Msg_N ("\Program_Error will be raised at run time", Obj_Id);
10472 -- Mark the activation call as a guaranteed ABE
10474 Set_Is_Known_Guaranteed_ABE (Call);
10476 -- Install a run-time ABE failue because this activation call will
10477 -- always result in an ABE.
10480 Install_ABE_Failure
10485 end Process_Guaranteed_ABE_Activation_Impl;
10487 procedure Process_Guaranteed_ABE_Activation is
10488 new Process_Activation_Generic (Process_Guaranteed_ABE_Activation_Impl);
10490 ---------------------------------
10491 -- Process_Guaranteed_ABE_Call --
10492 ---------------------------------
10494 procedure Process_Guaranteed_ABE_Call
10496 Call_Attrs : Call_Attributes;
10497 Target_Id : Entity_Id)
10499 Target_Attrs : Target_Attributes;
10502 Extract_Target_Attributes
10503 (Target_Id => Target_Id,
10504 Attrs => Target_Attrs);
10506 -- Nothing to do when the root scenario appears at the declaration level
10507 -- and the target is in the same unit, but outside this context.
10509 -- function B ...; -- target declaration
10511 -- procedure Proc is
10512 -- function A ... is
10514 -- if Some_Condition then
10515 -- return B; -- call site
10519 -- X : ... := A; -- root scenario
10522 -- function B ... is
10526 -- In the example above, the context of X is the declarative region of
10527 -- Proc. The "elaboration" of X may eventually reach B which is defined
10528 -- outside of X's context. B is relevant only when Proc is invoked, but
10529 -- this happens only by means of "normal" elaboration, therefore B must
10530 -- not be considered if this is not the case.
10532 -- Performance note: parent traversal
10534 if Is_Up_Level_Target (Target_Attrs.Spec_Decl) then
10537 -- Nothing to do when the call is ABE-safe
10540 -- function Gen ...;
10542 -- function Gen ... is
10548 -- procedure Main is
10549 -- function Inst is new Gen;
10550 -- X : ... := Inst; -- safe call
10553 elsif Is_Safe_Call (Call, Target_Attrs) then
10556 -- A call leads to a guaranteed ABE when the call and the target appear
10557 -- within the same context ignoring library levels, and the body of the
10558 -- target has not been seen yet or appears after the call.
10560 -- procedure Guaranteed_ABE is
10561 -- function Func ...;
10563 -- package Nested is
10564 -- Obj : ... := Func; -- guaranteed ABE
10567 -- function Func ... is
10572 -- Performance note: parent traversal
10574 elsif Is_Guaranteed_ABE
10576 Target_Decl => Target_Attrs.Spec_Decl,
10577 Target_Body => Target_Attrs.Body_Decl)
10579 if Call_Attrs.Elab_Warnings_OK then
10580 Error_Msg_NE ("??cannot call & before body seen", Call, Target_Id);
10581 Error_Msg_N ("\Program_Error will be raised at run time", Call);
10584 -- Mark the call as a guarnateed ABE
10586 Set_Is_Known_Guaranteed_ABE (Call);
10588 -- Install a run-time ABE failure because the call will always result
10589 -- in an ABE. The failure is installed when both the call and target
10590 -- have enabled elaboration checks, and both are not ignored Ghost
10593 if Call_Attrs.Elab_Checks_OK
10594 and then Target_Attrs.Elab_Checks_OK
10595 and then not Call_Attrs.Ghost_Mode_Ignore
10596 and then not Target_Attrs.Ghost_Mode_Ignore
10598 Install_ABE_Failure
10603 end Process_Guaranteed_ABE_Call;
10605 ------------------------------------------
10606 -- Process_Guaranteed_ABE_Instantiation --
10607 ------------------------------------------
10609 procedure Process_Guaranteed_ABE_Instantiation (Exp_Inst : Node_Id) is
10610 Gen_Attrs : Target_Attributes;
10611 Gen_Id : Entity_Id;
10613 Inst_Attrs : Instantiation_Attributes;
10614 Inst_Id : Entity_Id;
10617 Extract_Instantiation_Attributes
10618 (Exp_Inst => Exp_Inst,
10620 Inst_Id => Inst_Id,
10622 Attrs => Inst_Attrs);
10624 Extract_Target_Attributes (Gen_Id, Gen_Attrs);
10626 -- Nothing to do when the root scenario appears at the declaration level
10627 -- and the generic is in the same unit, but outside this context.
10630 -- procedure Gen is ...; -- generic declaration
10632 -- procedure Proc is
10633 -- function A ... is
10635 -- if Some_Condition then
10637 -- procedure I is new Gen; -- instantiation site
10642 -- X : ... := A; -- root scenario
10645 -- procedure Gen is
10649 -- In the example above, the context of X is the declarative region of
10650 -- Proc. The "elaboration" of X may eventually reach Gen which appears
10651 -- outside of X's context. Gen is relevant only when Proc is invoked,
10652 -- but this happens only by means of "normal" elaboration, therefore
10653 -- Gen must not be considered if this is not the case.
10655 -- Performance note: parent traversal
10657 if Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then
10660 -- Nothing to do when the instantiation is ABE-safe
10667 -- package body Gen is
10672 -- procedure Main is
10673 -- package Inst is new Gen (ABE); -- safe instantiation
10676 elsif Is_Safe_Instantiation (Inst, Gen_Attrs) then
10679 -- An instantiation leads to a guaranteed ABE when the instantiation and
10680 -- the generic appear within the same context ignoring library levels,
10681 -- and the body of the generic has not been seen yet or appears after
10682 -- the instantiation.
10684 -- procedure Guaranteed_ABE is
10688 -- package Nested is
10689 -- procedure Inst is new Gen; -- guaranteed ABE
10692 -- procedure Gen is
10697 -- Performance note: parent traversal
10699 elsif Is_Guaranteed_ABE
10701 Target_Decl => Gen_Attrs.Spec_Decl,
10702 Target_Body => Gen_Attrs.Body_Decl)
10704 if Inst_Attrs.Elab_Warnings_OK then
10706 ("??cannot instantiate & before body seen", Inst, Gen_Id);
10707 Error_Msg_N ("\Program_Error will be raised at run time", Inst);
10710 -- Mark the instantiation as a guarantee ABE. This automatically
10711 -- suppresses the instantiation of the generic body.
10713 Set_Is_Known_Guaranteed_ABE (Inst);
10715 -- Install a run-time ABE failure because the instantiation will
10716 -- always result in an ABE. The failure is installed when both the
10717 -- instance and the generic have enabled elaboration checks, and both
10718 -- are not ignored Ghost constructs.
10720 if Inst_Attrs.Elab_Checks_OK
10721 and then Gen_Attrs.Elab_Checks_OK
10722 and then not Inst_Attrs.Ghost_Mode_Ignore
10723 and then not Gen_Attrs.Ghost_Mode_Ignore
10725 Install_ABE_Failure
10727 Ins_Nod => Exp_Inst);
10730 end Process_Guaranteed_ABE_Instantiation;
10732 ----------------------------
10733 -- Process_Guaranteed_ABE --
10734 ----------------------------
10736 -- NOTE: The body of this routine is intentionally out of order because it
10737 -- invokes an instantiated subprogram (Process_Guaranteed_ABE_Activation).
10738 -- Placing the body in alphabetical order will result in a guaranteed ABE.
10740 procedure Process_Guaranteed_ABE (N : Node_Id) is
10741 Call_Attrs : Call_Attributes;
10742 Target_Id : Entity_Id;
10745 -- Add the current scenario to the stack of active scenarios
10747 Push_Active_Scenario (N);
10749 -- Only calls, instantiations, and task activations may result in a
10752 if Is_Suitable_Call (N) then
10753 Extract_Call_Attributes
10755 Target_Id => Target_Id,
10756 Attrs => Call_Attrs);
10758 if Is_Activation_Proc (Target_Id) then
10759 Process_Guaranteed_ABE_Activation
10761 Call_Attrs => Call_Attrs,
10762 State => Initial_State);
10765 Process_Guaranteed_ABE_Call
10767 Call_Attrs => Call_Attrs,
10768 Target_Id => Target_Id);
10771 elsif Is_Suitable_Instantiation (N) then
10772 Process_Guaranteed_ABE_Instantiation (N);
10775 -- Remove the current scenario from the stack of active scenarios once
10776 -- all ABE diagnostics and checks have been performed.
10778 Pop_Active_Scenario (N);
10779 end Process_Guaranteed_ABE;
10781 --------------------------
10782 -- Push_Active_Scenario --
10783 --------------------------
10785 procedure Push_Active_Scenario (N : Node_Id) is
10787 Scenario_Stack.Append (N);
10788 end Push_Active_Scenario;
10790 ---------------------------------
10791 -- Record_Elaboration_Scenario --
10792 ---------------------------------
10794 procedure Record_Elaboration_Scenario (N : Node_Id) is
10795 Level : Enclosing_Level_Kind;
10797 Any_Level_OK : Boolean;
10798 -- This flag is set when a particular scenario is allowed to appear at
10801 Declaration_Level_OK : Boolean;
10802 -- This flag is set when a particular scenario is allowed to appear at
10803 -- the declaration level.
10805 Library_Level_OK : Boolean;
10806 -- This flag is set when a particular scenario is allowed to appear at
10807 -- the library level.
10810 -- Assume that the scenario cannot appear on any level
10812 Any_Level_OK := False;
10813 Declaration_Level_OK := False;
10814 Library_Level_OK := False;
10816 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
10817 -- enabled) is in effect because the legacy ABE mechanism does not need
10818 -- to carry out this action.
10820 if Legacy_Elaboration_Checks then
10823 -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics
10824 -- are performed in this mode.
10826 elsif ASIS_Mode then
10829 -- Nothing to do when the scenario is being preanalyzed
10831 elsif Preanalysis_Active then
10835 -- Ensure that a library-level call does not appear in a preelaborated
10836 -- unit. The check must come before ignoring scenarios within external
10837 -- units or inside generics because calls in those context must also be
10840 if Is_Suitable_Call (N) then
10841 Check_Preelaborated_Call (N);
10844 -- Nothing to do when the scenario does not appear within the main unit
10846 if not In_Main_Context (N) then
10849 -- Scenarios within a generic unit are never considered because generics
10850 -- cannot be elaborated.
10852 elsif Inside_A_Generic then
10855 -- Scenarios which do not fall in one of the elaboration categories
10856 -- listed below are not considered. The categories are:
10858 -- 'Access for entries, operators, and subprograms
10859 -- Assignments to variables
10860 -- Calls (includes task activation)
10863 -- Pragma Refined_State
10864 -- Reads of variables
10866 elsif Is_Suitable_Access (N) then
10867 Library_Level_OK := True;
10869 -- Signal any enclosing local exception handlers that the 'Access may
10870 -- raise Program_Error due to a failed ABE check when switch -gnatd.o
10871 -- (conservative elaboration order for indirect calls) is in effect.
10872 -- Marking the exception handlers ensures proper expansion by both
10873 -- the front and back end restriction when No_Exception_Propagation
10876 if Debug_Flag_Dot_O then
10877 Possible_Local_Raise (N, Standard_Program_Error);
10880 elsif Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N) then
10881 Declaration_Level_OK := True;
10882 Library_Level_OK := True;
10884 -- Signal any enclosing local exception handlers that the call or
10885 -- instantiation may raise Program_Error due to a failed ABE check.
10886 -- Marking the exception handlers ensures proper expansion by both
10887 -- the front and back end restriction when No_Exception_Propagation
10890 Possible_Local_Raise (N, Standard_Program_Error);
10892 elsif Is_Suitable_SPARK_Derived_Type (N) then
10893 Any_Level_OK := True;
10895 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then
10896 Library_Level_OK := True;
10898 elsif Is_Suitable_Variable_Assignment (N)
10899 or else Is_Suitable_Variable_Reference (N)
10901 Library_Level_OK := True;
10903 -- Otherwise the input does not denote a suitable scenario
10909 -- The static model imposes additional restrictions on the placement of
10910 -- scenarios. In contrast, the dynamic model assumes that every scenario
10911 -- will be elaborated or invoked at some point.
10913 if Static_Elaboration_Checks then
10915 -- Certain scenarios are allowed to appear at any level. This check
10916 -- is performed here in order to save on a parent traversal.
10918 if Any_Level_OK then
10921 -- Otherwise the scenario must appear at a specific level
10924 -- Performance note: parent traversal
10926 Level := Find_Enclosing_Level (N);
10928 -- Declaration-level scenario
10930 if Declaration_Level_OK and then Level = Declaration_Level then
10933 -- Library-level or instantiation scenario
10935 elsif Library_Level_OK
10936 and then Level in Library_Or_Instantiation_Level
10940 -- Otherwise the scenario does not appear at the proper level and
10941 -- cannot possibly act as a top-level scenario.
10949 -- Derived types subject to SPARK_Mode On require elaboration-related
10950 -- checks even though the type may not be declared within elaboration
10951 -- code. The types are recorded in a separate table which is examined
10952 -- during the Processing phase. Note that the checks must be delayed
10953 -- because the bodies of overriding primitives are not available yet.
10955 if Is_Suitable_SPARK_Derived_Type (N) then
10956 Record_SPARK_Elaboration_Scenario (N);
10958 -- Nothing left to do for derived types
10962 -- Instantiations of generics both subject to SPARK_Mode On require
10963 -- elaboration-related checks even though the instantiations may not
10964 -- appear within elaboration code. The instantiations are recored in
10965 -- a separate table which is examined during the Procesing phase. Note
10966 -- that the checks must be delayed because it is not known yet whether
10967 -- the generic unit has a body or not.
10969 -- IMPORTANT: A SPARK instantiation is also a normal instantiation which
10970 -- is subject to common conditional and guaranteed ABE checks.
10972 elsif Is_Suitable_SPARK_Instantiation (N) then
10973 Record_SPARK_Elaboration_Scenario (N);
10975 -- External constituents that refine abstract states which appear in
10976 -- pragma Initializes require elaboration-related checks even though
10977 -- a Refined_State pragma lacks any elaboration semantic.
10979 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then
10980 Record_SPARK_Elaboration_Scenario (N);
10982 -- Nothing left to do for pragma Refined_State
10987 -- Perform early detection of guaranteed ABEs in order to suppress the
10988 -- instantiation of generic bodies as gigi cannot handle certain types
10989 -- of premature instantiations.
10991 Process_Guaranteed_ABE (N);
10993 -- At this point all checks have been performed. Record the scenario for
10994 -- later processing by the ABE phase.
10996 Top_Level_Scenarios.Append (N);
10997 Set_Is_Recorded_Top_Level_Scenario (N);
10998 end Record_Elaboration_Scenario;
11000 ---------------------------------------
11001 -- Record_SPARK_Elaboration_Scenario --
11002 ---------------------------------------
11004 procedure Record_SPARK_Elaboration_Scenario (N : Node_Id) is
11006 SPARK_Scenarios.Append (N);
11007 Set_Is_Recorded_SPARK_Scenario (N);
11008 end Record_SPARK_Elaboration_Scenario;
11010 -----------------------------------
11011 -- Recorded_SPARK_Scenarios_Hash --
11012 -----------------------------------
11014 function Recorded_SPARK_Scenarios_Hash
11015 (Key : Node_Id) return Recorded_SPARK_Scenarios_Index
11019 Recorded_SPARK_Scenarios_Index (Key mod Recorded_SPARK_Scenarios_Max);
11020 end Recorded_SPARK_Scenarios_Hash;
11022 ---------------------------------------
11023 -- Recorded_Top_Level_Scenarios_Hash --
11024 ---------------------------------------
11026 function Recorded_Top_Level_Scenarios_Hash
11027 (Key : Node_Id) return Recorded_Top_Level_Scenarios_Index
11031 Recorded_Top_Level_Scenarios_Index
11032 (Key mod Recorded_Top_Level_Scenarios_Max);
11033 end Recorded_Top_Level_Scenarios_Hash;
11035 --------------------------
11036 -- Reset_Visited_Bodies --
11037 --------------------------
11039 procedure Reset_Visited_Bodies is
11041 if Visited_Bodies_In_Use then
11042 Visited_Bodies_In_Use := False;
11043 Visited_Bodies.Reset;
11045 end Reset_Visited_Bodies;
11047 -------------------
11048 -- Root_Scenario --
11049 -------------------
11051 function Root_Scenario return Node_Id is
11052 package Stack renames Scenario_Stack;
11055 -- Ensure that the scenario stack has at least one active scenario in
11056 -- it. The one at the bottom (index First) is the root scenario.
11058 pragma Assert (Stack.Last >= Stack.First);
11059 return Stack.Table (Stack.First);
11062 ---------------------------
11063 -- Set_Early_Call_Region --
11064 ---------------------------
11066 procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id) is
11068 pragma Assert (Ekind_In (Body_Id, E_Entry,
11072 E_Subprogram_Body));
11074 Early_Call_Regions_In_Use := True;
11075 Early_Call_Regions.Set (Body_Id, Start);
11076 end Set_Early_Call_Region;
11078 ----------------------------
11079 -- Set_Elaboration_Status --
11080 ----------------------------
11082 procedure Set_Elaboration_Status
11083 (Unit_Id : Entity_Id;
11084 Val : Elaboration_Attributes)
11087 Elaboration_Statuses_In_Use := True;
11088 Elaboration_Statuses.Set (Unit_Id, Val);
11089 end Set_Elaboration_Status;
11091 ------------------------------------
11092 -- Set_Is_Recorded_SPARK_Scenario --
11093 ------------------------------------
11095 procedure Set_Is_Recorded_SPARK_Scenario
11097 Val : Boolean := True)
11100 Recorded_SPARK_Scenarios_In_Use := True;
11101 Recorded_SPARK_Scenarios.Set (N, Val);
11102 end Set_Is_Recorded_SPARK_Scenario;
11104 ----------------------------------------
11105 -- Set_Is_Recorded_Top_Level_Scenario --
11106 ----------------------------------------
11108 procedure Set_Is_Recorded_Top_Level_Scenario
11110 Val : Boolean := True)
11113 Recorded_Top_Level_Scenarios_In_Use := True;
11114 Recorded_Top_Level_Scenarios.Set (N, Val);
11115 end Set_Is_Recorded_Top_Level_Scenario;
11117 -------------------------
11118 -- Set_Is_Visited_Body --
11119 -------------------------
11121 procedure Set_Is_Visited_Body (Subp_Body : Node_Id) is
11123 Visited_Bodies_In_Use := True;
11124 Visited_Bodies.Set (Subp_Body, True);
11125 end Set_Is_Visited_Body;
11127 -------------------------------
11128 -- Static_Elaboration_Checks --
11129 -------------------------------
11131 function Static_Elaboration_Checks return Boolean is
11133 return not Dynamic_Elaboration_Checks;
11134 end Static_Elaboration_Checks;
11136 -------------------
11137 -- Traverse_Body --
11138 -------------------
11140 procedure Traverse_Body (N : Node_Id; State : Processing_Attributes) is
11141 procedure Find_And_Process_Nested_Scenarios;
11142 pragma Inline (Find_And_Process_Nested_Scenarios);
11143 -- Examine the declarations and statements of subprogram body N for
11144 -- suitable scenarios. Save each discovered scenario and process it
11147 procedure Process_Nested_Scenarios (Nested : Elist_Id);
11148 pragma Inline (Process_Nested_Scenarios);
11149 -- Invoke Process_Conditional_ABE on each individual scenario found in
11152 ---------------------------------------
11153 -- Find_And_Process_Nested_Scenarios --
11154 ---------------------------------------
11156 procedure Find_And_Process_Nested_Scenarios is
11157 Body_Id : constant Entity_Id := Defining_Entity (N);
11159 function Is_Potential_Scenario
11160 (Nod : Node_Id) return Traverse_Result;
11161 -- Determine whether arbitrary node Nod denotes a suitable scenario.
11162 -- If it does, save it in the Nested_Scenarios list of the subprogram
11163 -- body, and process it.
11165 procedure Save_Scenario (Nod : Node_Id);
11166 pragma Inline (Save_Scenario);
11167 -- Save scenario Nod in the Nested_Scenarios list of the subprogram
11170 procedure Traverse_List (List : List_Id);
11171 pragma Inline (Traverse_List);
11172 -- Invoke Traverse_Potential_Scenarios on each node in list List
11174 procedure Traverse_Potential_Scenarios is
11175 new Traverse_Proc (Is_Potential_Scenario);
11177 ---------------------------
11178 -- Is_Potential_Scenario --
11179 ---------------------------
11181 function Is_Potential_Scenario
11182 (Nod : Node_Id) return Traverse_Result
11187 -- Skip constructs which do not have elaboration of their own and
11188 -- need to be elaborated by other means such as invocation, task
11189 -- activation, etc.
11191 if Is_Non_Library_Level_Encapsulator (Nod) then
11194 -- Terminate the traversal of a task body when encountering an
11195 -- accept or select statement, and
11197 -- * Entry calls during elaboration are not allowed. In this
11198 -- case the accept or select statement will cause the task
11199 -- to block at elaboration time because there are no entry
11200 -- calls to unblock it.
11204 -- * Switch -gnatd_a (stop elaboration checks on accept or
11205 -- select statement) is in effect.
11207 elsif (Debug_Flag_Underscore_A
11208 or else Restriction_Active
11209 (No_Entry_Calls_In_Elaboration_Code))
11210 and then Nkind_In (Original_Node (Nod), N_Accept_Statement,
11211 N_Selective_Accept)
11215 -- Terminate the traversal of a task body when encountering a
11216 -- suspension call, and
11218 -- * Entry calls during elaboration are not allowed. In this
11219 -- case the suspension call emulates an entry call and will
11220 -- cause the task to block at elaboration time.
11224 -- * Switch -gnatd_s (stop elaboration checks on synchronous
11225 -- suspension) is in effect.
11227 -- Note that the guard should not be checking the state of flag
11228 -- Within_Task_Body because only suspension calls which appear
11229 -- immediately within the statements of the task are supported.
11230 -- Flag Within_Task_Body carries over to deeper levels of the
11233 elsif (Debug_Flag_Underscore_S
11234 or else Restriction_Active
11235 (No_Entry_Calls_In_Elaboration_Code))
11236 and then Is_Synchronous_Suspension_Call (Nod)
11237 and then In_Task_Body (Nod)
11241 -- Certain nodes carry semantic lists which act as repositories
11242 -- until expansion transforms the node and relocates the contents.
11243 -- Examine these lists in case expansion is disabled.
11245 elsif Nkind_In (Nod, N_And_Then, N_Or_Else) then
11246 Traverse_List (Actions (Nod));
11248 elsif Nkind_In (Nod, N_Elsif_Part, N_Iteration_Scheme) then
11249 Traverse_List (Condition_Actions (Nod));
11251 elsif Nkind (Nod) = N_If_Expression then
11252 Traverse_List (Then_Actions (Nod));
11253 Traverse_List (Else_Actions (Nod));
11255 elsif Nkind_In (Nod, N_Component_Association,
11256 N_Iterated_Component_Association)
11258 Traverse_List (Loop_Actions (Nod));
11262 -- Save a suitable scenario in the Nested_Scenarios list of the
11263 -- subprogram body. As a result any subsequent traversals of the
11264 -- subprogram body started from a different top-level scenario no
11265 -- longer need to reexamine the tree.
11267 elsif Is_Suitable_Scenario (Nod) then
11268 Save_Scenario (Nod);
11270 Process_Conditional_ABE
11276 end Is_Potential_Scenario;
11278 -------------------
11279 -- Save_Scenario --
11280 -------------------
11282 procedure Save_Scenario (Nod : Node_Id) is
11286 Nested := Nested_Scenarios (Body_Id);
11288 if No (Nested) then
11289 Nested := New_Elmt_List;
11290 Set_Nested_Scenarios (Body_Id, Nested);
11293 Append_Elmt (Nod, Nested);
11296 -------------------
11297 -- Traverse_List --
11298 -------------------
11300 procedure Traverse_List (List : List_Id) is
11304 Item := First (List);
11305 while Present (Item) loop
11306 Traverse_Potential_Scenarios (Item);
11311 -- Start of processing for Find_And_Process_Nested_Scenarios
11314 -- Examine the declarations for suitable scenarios
11316 Traverse_List (Declarations (N));
11318 -- Examine the handled sequence of statements. This also includes any
11319 -- exceptions handlers.
11321 Traverse_Potential_Scenarios (Handled_Statement_Sequence (N));
11322 end Find_And_Process_Nested_Scenarios;
11324 ------------------------------
11325 -- Process_Nested_Scenarios --
11326 ------------------------------
11328 procedure Process_Nested_Scenarios (Nested : Elist_Id) is
11329 Nested_Elmt : Elmt_Id;
11332 Nested_Elmt := First_Elmt (Nested);
11333 while Present (Nested_Elmt) loop
11334 Process_Conditional_ABE
11335 (N => Node (Nested_Elmt),
11338 Next_Elmt (Nested_Elmt);
11340 end Process_Nested_Scenarios;
11346 -- Start of processing for Traverse_Body
11349 -- Nothing to do when there is no body
11354 elsif Nkind (N) /= N_Subprogram_Body then
11358 -- Nothing to do if the body was already traversed during the processing
11359 -- of the same top-level scenario.
11361 if Is_Visited_Body (N) then
11364 -- Otherwise mark the body as traversed
11367 Set_Is_Visited_Body (N);
11370 Nested := Nested_Scenarios (Defining_Entity (N));
11372 -- The subprogram body was already examined as part of the elaboration
11373 -- graph starting from a different top-level scenario. There is no need
11374 -- to traverse the declarations and statements again because this will
11375 -- yield the exact same scenarios. Use the nested scenarios collected
11376 -- during the first inspection of the body.
11378 if Present (Nested) then
11379 Process_Nested_Scenarios (Nested);
11381 -- Otherwise examine the declarations and statements of the subprogram
11382 -- body for suitable scenarios, save and process them accordingly.
11385 Find_And_Process_Nested_Scenarios;
11393 function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id is
11394 function Is_Subunit (Id : Entity_Id) return Boolean;
11395 pragma Inline (Is_Subunit);
11396 -- Determine whether the entity of an initial declaration denotes a
11403 function Is_Subunit (Id : Entity_Id) return Boolean is
11404 Decl : constant Node_Id := Unit_Declaration_Node (Id);
11408 Nkind_In (Decl, N_Generic_Package_Declaration,
11409 N_Generic_Subprogram_Declaration,
11410 N_Package_Declaration,
11411 N_Protected_Type_Declaration,
11412 N_Subprogram_Declaration,
11413 N_Task_Type_Declaration)
11414 and then Present (Corresponding_Body (Decl))
11415 and then Nkind (Parent (Unit_Declaration_Node
11416 (Corresponding_Body (Decl)))) = N_Subunit;
11423 -- Start of processing for Unit_Entity
11426 Id := Unique_Entity (Unit_Id);
11428 -- Skip all subunits found in the scope chain which ends at the input
11431 while Is_Subunit (Id) loop
11438 ---------------------------------
11439 -- Update_Elaboration_Scenario --
11440 ---------------------------------
11442 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id) is
11443 procedure Update_SPARK_Scenario;
11444 pragma Inline (Update_SPARK_Scenario);
11445 -- Update the contents of table SPARK_Scenarios if Old_N is recorded
11448 procedure Update_Top_Level_Scenario;
11449 pragma Inline (Update_Top_Level_Scenario);
11450 -- Update the contexts of table Top_Level_Scenarios if Old_N is recorded
11453 ---------------------------
11454 -- Update_SPARK_Scenario --
11455 ---------------------------
11457 procedure Update_SPARK_Scenario is
11458 package Scenarios renames SPARK_Scenarios;
11461 if Is_Recorded_SPARK_Scenario (Old_N) then
11463 -- Performance note: list traversal
11465 for Index in Scenarios.First .. Scenarios.Last loop
11466 if Scenarios.Table (Index) = Old_N then
11467 Scenarios.Table (Index) := New_N;
11469 -- The old SPARK scenario is no longer recorded, but the new
11472 Set_Is_Recorded_Top_Level_Scenario (Old_N, False);
11473 Set_Is_Recorded_Top_Level_Scenario (New_N);
11478 -- A recorded SPARK scenario must be in the table of recorded
11479 -- SPARK scenarios.
11481 pragma Assert (False);
11483 end Update_SPARK_Scenario;
11485 -------------------------------
11486 -- Update_Top_Level_Scenario --
11487 -------------------------------
11489 procedure Update_Top_Level_Scenario is
11490 package Scenarios renames Top_Level_Scenarios;
11493 if Is_Recorded_Top_Level_Scenario (Old_N) then
11495 -- Performance note: list traversal
11497 for Index in Scenarios.First .. Scenarios.Last loop
11498 if Scenarios.Table (Index) = Old_N then
11499 Scenarios.Table (Index) := New_N;
11501 -- The old top-level scenario is no longer recorded, but the
11504 Set_Is_Recorded_Top_Level_Scenario (Old_N, False);
11505 Set_Is_Recorded_Top_Level_Scenario (New_N);
11510 -- A recorded top-level scenario must be in the table of recorded
11511 -- top-level scenarios.
11513 pragma Assert (False);
11515 end Update_Top_Level_Scenario;
11517 -- Start of processing for Update_Elaboration_Requirement
11520 -- Nothing to do when the old and new scenarios are one and the same
11522 if Old_N = New_N then
11525 -- A scenario is being transformed by Atree.Rewrite. Update all relevant
11526 -- internal data structures to reflect this change. This ensures that a
11527 -- potential run-time conditional ABE check or a guaranteed ABE failure
11528 -- is inserted at the proper place in the tree.
11530 elsif Is_Scenario (Old_N) then
11531 Update_SPARK_Scenario;
11532 Update_Top_Level_Scenario;
11534 end Update_Elaboration_Scenario;
11536 -------------------------
11537 -- Visited_Bodies_Hash --
11538 -------------------------
11540 function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index is
11542 return Visited_Bodies_Index (Key mod Visited_Bodies_Max);
11543 end Visited_Bodies_Hash;
11545 ---------------------------------------------------------------------------
11547 -- 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 --
11549 -- M E C H A N I S M --
11551 ---------------------------------------------------------------------------
11553 -- This section contains the implementation of the pre-18.x legacy ABE
11554 -- mechanism. The mechanism can be activated using switch -gnatH (legacy
11555 -- elaboration checking mode enabled).
11557 -----------------------------
11558 -- Description of Approach --
11559 -----------------------------
11561 -- Every non-static call that is encountered by Sem_Res results in a call
11562 -- to Check_Elab_Call, with N being the call node, and Outer set to its
11563 -- default value of True. In addition X'Access is treated like a call
11564 -- for the access-to-procedure case, and in SPARK mode only we also
11565 -- check variable references.
11567 -- The goal of Check_Elab_Call is to determine whether or not the reference
11568 -- in question can generate an access before elaboration error (raising
11569 -- Program_Error) either by directly calling a subprogram whose body
11570 -- has not yet been elaborated, or indirectly, by calling a subprogram
11571 -- whose body has been elaborated, but which contains a call to such a
11574 -- In addition, in SPARK mode, we are checking for a variable reference in
11575 -- another package, which requires an explicit Elaborate_All pragma.
11577 -- The only references that we need to look at the outer level are
11578 -- references that occur in elaboration code. There are two cases. The
11579 -- reference can be at the outer level of elaboration code, or it can
11580 -- be within another unit, e.g. the elaboration code of a subprogram.
11582 -- In the case of an elaboration call at the outer level, we must trace
11583 -- all calls to outer level routines either within the current unit or to
11584 -- other units that are with'ed. For calls within the current unit, we can
11585 -- determine if the body has been elaborated or not, and if it has not,
11586 -- then a warning is generated.
11588 -- Note that there are two subcases. If the original call directly calls a
11589 -- subprogram whose body has not been elaborated, then we know that an ABE
11590 -- will take place, and we replace the call by a raise of Program_Error.
11591 -- If the call is indirect, then we don't know that the PE will be raised,
11592 -- since the call might be guarded by a conditional. In this case we set
11593 -- Do_Elab_Check on the call so that a dynamic check is generated, and
11594 -- output a warning.
11596 -- For calls to a subprogram in a with'ed unit or a 'Access or variable
11597 -- reference (SPARK mode case), we require that a pragma Elaborate_All
11598 -- or pragma Elaborate be present, or that the referenced unit have a
11599 -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none
11600 -- of these conditions is met, then a warning is generated that a pragma
11601 -- Elaborate_All may be needed (error in the SPARK case), or an implicit
11602 -- pragma is generated.
11604 -- For the case of an elaboration call at some inner level, we are
11605 -- interested in tracing only calls to subprograms at the same level, i.e.
11606 -- those that can be called during elaboration. Any calls to outer level
11607 -- routines cannot cause ABE's as a result of the original call (there
11608 -- might be an outer level call to the subprogram from outside that causes
11609 -- the ABE, but that gets analyzed separately).
11611 -- Note that we never trace calls to inner level subprograms, since these
11612 -- cannot result in ABE's unless there is an elaboration problem at a lower
11613 -- level, which will be separately detected.
11615 -- Note on pragma Elaborate. The checking here assumes that a pragma
11616 -- Elaborate on a with'ed unit guarantees that subprograms within the unit
11617 -- can be called without causing an ABE. This is not in fact the case since
11618 -- pragma Elaborate does not guarantee the transitive coverage guaranteed
11619 -- by Elaborate_All. However, we decide to trust the user in this case.
11621 --------------------------------------
11622 -- Instantiation Elaboration Errors --
11623 --------------------------------------
11625 -- A special case arises when an instantiation appears in a context that is
11626 -- known to be before the body is elaborated, e.g.
11628 -- generic package x is ...
11630 -- package xx is new x;
11632 -- package body x is ...
11634 -- In this situation it is certain that an elaboration error will occur,
11635 -- and an unconditional raise Program_Error statement is inserted before
11636 -- the instantiation, and a warning generated.
11638 -- The problem is that in this case we have no place to put the body of
11639 -- the instantiation. We can't put it in the normal place, because it is
11640 -- too early, and will cause errors to occur as a result of referencing
11641 -- entities before they are declared.
11643 -- Our approach in this case is simply to avoid creating the body of the
11644 -- instantiation in such a case. The instantiation spec is modified to
11645 -- include dummy bodies for all subprograms, so that the resulting code
11646 -- does not contain subprogram specs with no corresponding bodies.
11648 -- The following table records the recursive call chain for output in the
11649 -- Output routine. Each entry records the call node and the entity of the
11650 -- called routine. The number of entries in the table (i.e. the value of
11651 -- Elab_Call.Last) indicates the current depth of recursion and is used to
11652 -- identify the outer level.
11654 type Elab_Call_Element is record
11659 package Elab_Call is new Table.Table
11660 (Table_Component_Type => Elab_Call_Element,
11661 Table_Index_Type => Int,
11662 Table_Low_Bound => 1,
11663 Table_Initial => 50,
11664 Table_Increment => 100,
11665 Table_Name => "Elab_Call");
11667 -- The following table records all calls that have been processed starting
11668 -- from an outer level call. The table prevents both infinite recursion and
11669 -- useless reanalysis of calls within the same context. The use of context
11670 -- is important because it allows for proper checks in more complex code:
11673 -- Call; -- requires a check
11674 -- Call; -- does not need a check thanks to the table
11676 -- Call; -- requires a check, different context
11679 -- Call; -- requires a check, different context
11681 type Visited_Element is record
11682 Subp_Id : Entity_Id;
11683 -- The entity of the subprogram being called
11686 -- The context where the call to the subprogram occurs
11689 package Elab_Visited is new Table.Table
11690 (Table_Component_Type => Visited_Element,
11691 Table_Index_Type => Int,
11692 Table_Low_Bound => 1,
11693 Table_Initial => 200,
11694 Table_Increment => 100,
11695 Table_Name => "Elab_Visited");
11697 -- The following table records delayed calls which must be examined after
11698 -- all generic bodies have been instantiated.
11700 type Delay_Element is record
11702 -- The parameter N from the call to Check_Internal_Call. Note that this
11703 -- node may get rewritten over the delay period by expansion in the call
11704 -- case (but not in the instantiation case).
11707 -- The parameter E from the call to Check_Internal_Call
11709 Orig_Ent : Entity_Id;
11710 -- The parameter Orig_Ent from the call to Check_Internal_Call
11712 Curscop : Entity_Id;
11713 -- The current scope of the call. This is restored when we complete the
11714 -- delayed call, so that we do this in the right scope.
11716 Outer_Scope : Entity_Id;
11717 -- Save scope of outer level call
11719 From_Elab_Code : Boolean;
11720 -- Save indication of whether this call is from elaboration code
11722 In_Task_Activation : Boolean;
11723 -- Save indication of whether this call is from a task body. Tasks are
11724 -- activated at the "begin", which is after all local procedure bodies,
11725 -- so calls to those procedures can't fail, even if they occur after the
11728 From_SPARK_Code : Boolean;
11729 -- Save indication of whether this call is under SPARK_Mode => On
11732 package Delay_Check is new Table.Table
11733 (Table_Component_Type => Delay_Element,
11734 Table_Index_Type => Int,
11735 Table_Low_Bound => 1,
11736 Table_Initial => 1000,
11737 Table_Increment => 100,
11738 Table_Name => "Delay_Check");
11740 C_Scope : Entity_Id;
11741 -- Top-level scope of current scope. Compute this only once at the outer
11742 -- level, i.e. for a call to Check_Elab_Call from outside this unit.
11744 Outer_Level_Sloc : Source_Ptr;
11745 -- Save Sloc value for outer level call node for comparisons of source
11746 -- locations. A body is too late if it appears after the *outer* level
11747 -- call, not the particular call that is being analyzed.
11749 From_Elab_Code : Boolean;
11750 -- This flag shows whether the outer level call currently being examined
11751 -- is or is not in elaboration code. We are only interested in calls to
11752 -- routines in other units if this flag is True.
11754 In_Task_Activation : Boolean := False;
11755 -- This flag indicates whether we are performing elaboration checks on task
11756 -- bodies, at the point of activation. If true, we do not raise
11757 -- Program_Error for calls to local procedures, because all local bodies
11758 -- are known to be elaborated. However, we still need to trace such calls,
11759 -- because a local procedure could call a procedure in another package,
11760 -- so we might need an implicit Elaborate_All.
11762 Delaying_Elab_Checks : Boolean := True;
11763 -- This is set True till the compilation is complete, including the
11764 -- insertion of all instance bodies. Then when Check_Elab_Calls is called,
11765 -- the delay table is used to make the delayed calls and this flag is reset
11766 -- to False, so that the calls are processed.
11768 -----------------------
11769 -- Local Subprograms --
11770 -----------------------
11772 -- Note: Outer_Scope in all following specs represents the scope of
11773 -- interest of the outer level call. If it is set to Standard_Standard,
11774 -- then it means the outer level call was at elaboration level, and that
11775 -- thus all calls are of interest. If it was set to some other scope,
11776 -- then the original call was an inner call, and we are not interested
11777 -- in calls that go outside this scope.
11779 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id);
11780 -- Analysis of construct N shows that we should set Elaborate_All_Desirable
11781 -- for the WITH clause for unit U (which will always be present). A special
11782 -- case is when N is a function or procedure instantiation, in which case
11783 -- it is sufficient to set Elaborate_Desirable, since in this case there is
11784 -- no possibility of transitive elaboration issues.
11786 procedure Check_A_Call
11789 Outer_Scope : Entity_Id;
11790 Inter_Unit_Only : Boolean;
11791 Generate_Warnings : Boolean := True;
11792 In_Init_Proc : Boolean := False);
11793 -- This is the internal recursive routine that is called to check for
11794 -- possible elaboration error. The argument N is a subprogram call or
11795 -- generic instantiation, or 'Access attribute reference to be checked, and
11796 -- E is the entity of the called subprogram, or instantiated generic unit,
11797 -- or subprogram referenced by 'Access.
11799 -- In SPARK mode, N can also be a variable reference, since in SPARK this
11800 -- also triggers a requirement for Elaborate_All, and in this case E is the
11801 -- entity being referenced.
11803 -- Outer_Scope is the outer level scope for the original reference.
11804 -- Inter_Unit_Only is set if the call is only to be checked in the
11805 -- case where it is to another unit (and skipped if within a unit).
11806 -- Generate_Warnings is set to False to suppress warning messages about
11807 -- missing pragma Elaborate_All's. These messages are not wanted for
11808 -- inner calls in the dynamic model. Note that an instance of the Access
11809 -- attribute applied to a subprogram also generates a call to this
11810 -- procedure (since the referenced subprogram may be called later
11811 -- indirectly). Flag In_Init_Proc should be set whenever the current
11812 -- context is a type init proc.
11814 -- Note: this might better be called Check_A_Reference to recognize the
11815 -- variable case for SPARK, but we prefer to retain the historical name
11816 -- since in practice this is mostly about checking calls for the possible
11817 -- occurrence of an access-before-elaboration exception.
11819 procedure Check_Bad_Instantiation (N : Node_Id);
11820 -- N is a node for an instantiation (if called with any other node kind,
11821 -- Check_Bad_Instantiation ignores the call). This subprogram checks for
11822 -- the special case of a generic instantiation of a generic spec in the
11823 -- same declarative part as the instantiation where a body is present and
11824 -- has not yet been seen. This is an obvious error, but needs to be checked
11825 -- specially at the time of the instantiation, since it is a case where we
11826 -- cannot insert the body anywhere. If this case is detected, warnings are
11827 -- generated, and a raise of Program_Error is inserted. In addition any
11828 -- subprograms in the generic spec are stubbed, and the Bad_Instantiation
11829 -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this
11830 -- flag as an indication that no attempt should be made to insert an
11833 procedure Check_Internal_Call
11836 Outer_Scope : Entity_Id;
11837 Orig_Ent : Entity_Id);
11838 -- N is a function call or procedure statement call node and E is the
11839 -- entity of the called function, which is within the current compilation
11840 -- unit (where subunits count as part of the parent). This call checks if
11841 -- this call, or any call within any accessed body could cause an ABE, and
11842 -- if so, outputs a warning. Orig_Ent differs from E only in the case of
11843 -- renamings, and points to the original name of the entity. This is used
11844 -- for error messages. Outer_Scope is the outer level scope for the
11847 procedure Check_Internal_Call_Continue
11850 Outer_Scope : Entity_Id;
11851 Orig_Ent : Entity_Id);
11852 -- The processing for Check_Internal_Call is divided up into two phases,
11853 -- and this represents the second phase. The second phase is delayed if
11854 -- Delaying_Elab_Checks is set to True. In this delayed case, the first
11855 -- phase makes an entry in the Delay_Check table, which is processed when
11856 -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to
11857 -- Check_Internal_Call. Outer_Scope is the outer level scope for the
11860 function Get_Referenced_Ent (N : Node_Id) return Entity_Id;
11861 -- N is either a function or procedure call or an access attribute that
11862 -- references a subprogram. This call retrieves the relevant entity. If
11863 -- this is a call to a protected subprogram, the entity is a selected
11864 -- component. The callable entity may be absent, in which case Empty is
11865 -- returned. This happens with non-analyzed calls in nested generics.
11867 -- If SPARK_Mode is On, then N can also be a reference to an E_Variable
11868 -- entity, in which case, the value returned is simply this entity.
11870 function Has_Generic_Body (N : Node_Id) return Boolean;
11871 -- N is a generic package instantiation node, and this routine determines
11872 -- if this package spec does in fact have a generic body. If so, then
11873 -- True is returned, otherwise False. Note that this is not at all the
11874 -- same as checking if the unit requires a body, since it deals with
11875 -- the case of optional bodies accurately (i.e. if a body is optional,
11876 -- then it looks to see if a body is actually present). Note: this
11877 -- function can only do a fully correct job if in generating code mode
11878 -- where all bodies have to be present. If we are operating in semantics
11879 -- check only mode, then in some cases of optional bodies, a result of
11880 -- False may incorrectly be given. In practice this simply means that
11881 -- some cases of warnings for incorrect order of elaboration will only
11882 -- be given when generating code, which is not a big problem (and is
11883 -- inevitable, given the optional body semantics of Ada).
11885 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty);
11886 -- Given code for an elaboration check (or unconditional raise if the check
11887 -- is not needed), inserts the code in the appropriate place. N is the call
11888 -- or instantiation node for which the check code is required. C is the
11889 -- test whose failure triggers the raise.
11891 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean;
11892 -- Returns True if node N is a call to a generic formal subprogram
11894 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean;
11895 -- Determine whether entity Id denotes a [Deep_]Finalize procedure
11897 procedure Output_Calls
11899 Check_Elab_Flag : Boolean);
11900 -- Outputs chain of calls stored in the Elab_Call table. The caller has
11901 -- already generated the main warning message, so the warnings generated
11902 -- are all continuation messages. The argument is the call node at which
11903 -- the messages are to be placed. When Check_Elab_Flag is set, calls are
11904 -- enumerated only when flag Elab_Warning is set for the dynamic case or
11905 -- when flag Elab_Info_Messages is set for the static case.
11907 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean;
11908 -- Given two scopes, determine whether they are the same scope from an
11909 -- elaboration point of view, i.e. packages and blocks are ignored.
11911 procedure Set_C_Scope;
11912 -- On entry C_Scope is set to some scope. On return, C_Scope is reset
11913 -- to be the enclosing compilation unit of this scope.
11915 procedure Set_Elaboration_Constraint
11919 -- The current unit U may depend semantically on some unit P that is not
11920 -- in the current context. If there is an elaboration call that reaches P,
11921 -- we need to indicate that P requires an Elaborate_All, but this is not
11922 -- effective in U's ali file, if there is no with_clause for P. In this
11923 -- case we add the Elaborate_All on the unit Q that directly or indirectly
11924 -- makes P available. This can happen in two cases:
11926 -- a) Q declares a subtype of a type declared in P, and the call is an
11927 -- initialization call for an object of that subtype.
11929 -- b) Q declares an object of some tagged type whose root type is
11930 -- declared in P, and the initialization call uses object notation on
11931 -- that object to reach a primitive operation or a classwide operation
11934 -- If P appears in the context of U, the current processing is correct.
11935 -- Otherwise we must identify these two cases to retrieve Q and place the
11936 -- Elaborate_All_Desirable on it.
11938 function Spec_Entity (E : Entity_Id) return Entity_Id;
11939 -- Given a compilation unit entity, if it is a spec entity, it is returned
11940 -- unchanged. If it is a body entity, then the spec for the corresponding
11941 -- spec is returned
11943 function Within (E1, E2 : Entity_Id) return Boolean;
11944 -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one
11945 -- of its contained scopes, False otherwise.
11947 function Within_Elaborate_All
11948 (Unit : Unit_Number_Type;
11949 E : Entity_Id) return Boolean;
11950 -- Return True if we are within the scope of an Elaborate_All for E, or if
11951 -- we are within the scope of an Elaborate_All for some other unit U, and U
11952 -- with's E. This prevents spurious warnings when the called entity is
11953 -- renamed within U, or in case of generic instances.
11955 --------------------------------------
11956 -- Activate_Elaborate_All_Desirable --
11957 --------------------------------------
11959 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id) is
11960 UN : constant Unit_Number_Type := Get_Code_Unit (N);
11961 CU : constant Node_Id := Cunit (UN);
11962 UE : constant Entity_Id := Cunit_Entity (UN);
11963 Unm : constant Unit_Name_Type := Unit_Name (UN);
11964 CI : constant List_Id := Context_Items (CU);
11968 procedure Add_To_Context_And_Mark (Itm : Node_Id);
11969 -- This procedure is called when the elaborate indication must be
11970 -- applied to a unit not in the context of the referencing unit. The
11971 -- unit gets added to the context as an implicit with.
11973 function In_Withs_Of (UEs : Entity_Id) return Boolean;
11974 -- UEs is the spec entity of a unit. If the unit to be marked is
11975 -- in the context item list of this unit spec, then the call returns
11976 -- True and Itm is left set to point to the relevant N_With_Clause node.
11978 procedure Set_Elab_Flag (Itm : Node_Id);
11979 -- Sets Elaborate_[All_]Desirable as appropriate on Itm
11981 -----------------------------
11982 -- Add_To_Context_And_Mark --
11983 -----------------------------
11985 procedure Add_To_Context_And_Mark (Itm : Node_Id) is
11986 CW : constant Node_Id :=
11987 Make_With_Clause (Sloc (Itm),
11988 Name => Name (Itm));
11991 Set_Library_Unit (CW, Library_Unit (Itm));
11992 Set_Implicit_With (CW);
11994 -- Set elaborate all desirable on copy and then append the copy to
11995 -- the list of body with's and we are done.
11997 Set_Elab_Flag (CW);
11998 Append_To (CI, CW);
11999 end Add_To_Context_And_Mark;
12005 function In_Withs_Of (UEs : Entity_Id) return Boolean is
12006 UNs : constant Unit_Number_Type := Get_Source_Unit (UEs);
12007 CUs : constant Node_Id := Cunit (UNs);
12008 CIs : constant List_Id := Context_Items (CUs);
12011 Itm := First (CIs);
12012 while Present (Itm) loop
12013 if Nkind (Itm) = N_With_Clause then
12015 Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm)));
12028 -------------------
12029 -- Set_Elab_Flag --
12030 -------------------
12032 procedure Set_Elab_Flag (Itm : Node_Id) is
12034 if Nkind (N) in N_Subprogram_Instantiation then
12035 Set_Elaborate_Desirable (Itm);
12037 Set_Elaborate_All_Desirable (Itm);
12041 -- Start of processing for Activate_Elaborate_All_Desirable
12044 -- Do not set binder indication if expansion is disabled, as when
12045 -- compiling a generic unit.
12047 if not Expander_Active then
12051 -- If an instance of a generic package contains a controlled object (so
12052 -- we're calling Initialize at elaboration time), and the instance is in
12053 -- a package body P that says "with P;", then we need to return without
12054 -- adding "pragma Elaborate_All (P);" to P.
12056 if U = Main_Unit_Entity then
12061 while Present (Itm) loop
12062 if Nkind (Itm) = N_With_Clause then
12063 Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm)));
12065 -- If we find it, then mark elaborate all desirable and return
12068 Set_Elab_Flag (Itm);
12076 -- If we fall through then the with clause is not present in the
12077 -- current unit. One legitimate possibility is that the with clause
12078 -- is present in the spec when we are a body.
12080 if Is_Body_Name (Unm)
12081 and then In_Withs_Of (Spec_Entity (UE))
12083 Add_To_Context_And_Mark (Itm);
12087 -- Similarly, we may be in the spec or body of a child unit, where
12088 -- the unit in question is with'ed by some ancestor of the child unit.
12090 if Is_Child_Name (Unm) then
12097 Pkg := Scope (Pkg);
12098 exit when Pkg = Standard_Standard;
12100 if In_Withs_Of (Pkg) then
12101 Add_To_Context_And_Mark (Itm);
12108 -- Here if we do not find with clause on spec or body. We just ignore
12109 -- this case; it means that the elaboration involves some other unit
12110 -- than the unit being compiled, and will be caught elsewhere.
12111 end Activate_Elaborate_All_Desirable;
12117 procedure Check_A_Call
12120 Outer_Scope : Entity_Id;
12121 Inter_Unit_Only : Boolean;
12122 Generate_Warnings : Boolean := True;
12123 In_Init_Proc : Boolean := False)
12125 Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference;
12126 -- Indicates if we have Access attribute case
12128 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean;
12129 -- True if we're calling an instance of a generic subprogram, or a
12130 -- subprogram in an instance of a generic package, and the call is
12131 -- outside that instance.
12133 procedure Elab_Warning
12136 Ent : Node_Or_Entity_Id);
12137 -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for
12138 -- dynamic or static elaboration model), N and Ent. Msg_D is a real
12139 -- warning (output if Msg_D is non-null and Elab_Warnings is set),
12140 -- Msg_S is an info message (output if Elab_Info_Messages is set).
12142 function Find_W_Scope return Entity_Id;
12143 -- Find top-level scope for called entity (not following renamings
12144 -- or derivations). This is where the Elaborate_All will go if it is
12145 -- needed. We start with the called entity, except in the case of an
12146 -- initialization procedure outside the current package, where the init
12147 -- proc is in the root package, and we start from the entity of the name
12150 -----------------------------------
12151 -- Call_To_Instance_From_Outside --
12152 -----------------------------------
12154 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean is
12155 Scop : Entity_Id := Id;
12159 if Scop = Standard_Standard then
12163 if Is_Generic_Instance (Scop) then
12164 return not In_Open_Scopes (Scop);
12167 Scop := Scope (Scop);
12169 end Call_To_Instance_From_Outside;
12175 procedure Elab_Warning
12178 Ent : Node_Or_Entity_Id)
12181 -- Dynamic elaboration checks, real warning
12183 if Dynamic_Elaboration_Checks then
12184 if not Access_Case then
12185 if Msg_D /= "" and then Elab_Warnings then
12186 Error_Msg_NE (Msg_D, N, Ent);
12189 -- In the access case emit first warning message as well,
12190 -- otherwise list of calls will appear as errors.
12192 elsif Elab_Warnings then
12193 Error_Msg_NE (Msg_S, N, Ent);
12196 -- Static elaboration checks, info message
12199 if Elab_Info_Messages then
12200 Error_Msg_NE (Msg_S, N, Ent);
12209 function Find_W_Scope return Entity_Id is
12210 Refed_Ent : constant Entity_Id := Get_Referenced_Ent (N);
12211 W_Scope : Entity_Id;
12214 if Is_Init_Proc (Refed_Ent)
12215 and then not In_Same_Extended_Unit (N, Refed_Ent)
12217 W_Scope := Scope (Refed_Ent);
12222 -- Now loop through scopes to get to the enclosing compilation unit
12224 while not Is_Compilation_Unit (W_Scope) loop
12225 W_Scope := Scope (W_Scope);
12233 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
12234 -- Indicates if we have instantiation case
12236 Loc : constant Source_Ptr := Sloc (N);
12238 Variable_Case : constant Boolean :=
12239 Nkind (N) in N_Has_Entity
12240 and then Present (Entity (N))
12241 and then Ekind (Entity (N)) = E_Variable;
12242 -- Indicates if we have variable reference case
12244 W_Scope : constant Entity_Id := Find_W_Scope;
12245 -- Top-level scope of directly called entity for subprogram. This
12246 -- differs from E_Scope in the case where renamings or derivations
12247 -- are involved, since it does not follow these links. W_Scope is
12248 -- generally in a visible unit, and it is this scope that may require
12249 -- an Elaborate_All. However, there are some cases (initialization
12250 -- calls and calls involving object notation) where W_Scope might not
12251 -- be in the context of the current unit, and there is an intermediate
12252 -- package that is, in which case the Elaborate_All has to be placed
12253 -- on this intermediate package. These special cases are handled in
12254 -- Set_Elaboration_Constraint.
12257 Callee_Unit_Internal : Boolean;
12258 Caller_Unit_Internal : Boolean;
12260 Inst_Callee : Source_Ptr;
12261 Inst_Caller : Source_Ptr;
12262 Unit_Callee : Unit_Number_Type;
12263 Unit_Caller : Unit_Number_Type;
12265 Body_Acts_As_Spec : Boolean;
12266 -- Set to true if call is to body acting as spec (no separate spec)
12268 Cunit_SC : Boolean := False;
12269 -- Set to suppress dynamic elaboration checks where one of the
12270 -- enclosing scopes has Elaboration_Checks_Suppressed set, or else
12271 -- if a pragma Elaborate[_All] applies to that scope, in which case
12272 -- warnings on the scope are also suppressed. For the internal case,
12273 -- we ignore this flag.
12275 E_Scope : Entity_Id;
12276 -- Top-level scope of entity for called subprogram. This value includes
12277 -- following renamings and derivations, so this scope can be in a
12278 -- non-visible unit. This is the scope that is to be investigated to
12279 -- see whether an elaboration check is required.
12282 -- Flag set when the subprogram being invoked is the procedure generated
12283 -- for pragma Default_Initial_Condition.
12285 SPARK_Elab_Errors : Boolean;
12286 -- Flag set when an entity is called or a variable is read during SPARK
12287 -- dynamic elaboration.
12289 -- Start of processing for Check_A_Call
12292 -- If the call is known to be within a local Suppress Elaboration
12293 -- pragma, nothing to check. This can happen in task bodies. But
12294 -- we ignore this for a call to a generic formal.
12296 if Nkind (N) in N_Subprogram_Call
12297 and then No_Elaboration_Check (N)
12298 and then not Is_Call_Of_Generic_Formal (N)
12302 -- If this is a rewrite of a Valid_Scalars attribute, then nothing to
12303 -- check, we don't mind in this case if the call occurs before the body
12304 -- since this is all generated code.
12306 elsif Nkind (Original_Node (N)) = N_Attribute_Reference
12307 and then Attribute_Name (Original_Node (N)) = Name_Valid_Scalars
12311 -- Intrinsics such as instances of Unchecked_Deallocation do not have
12312 -- any body, so elaboration checking is not needed, and would be wrong.
12314 elsif Is_Intrinsic_Subprogram (E) then
12317 -- Do not consider references to internal variables for SPARK semantics
12319 elsif Variable_Case and then not Comes_From_Source (E) then
12323 -- Proceed with check
12327 -- For a variable reference, just set Body_Acts_As_Spec to False
12329 if Variable_Case then
12330 Body_Acts_As_Spec := False;
12332 -- Additional checks for all other cases
12335 -- Go to parent for derived subprogram, or to original subprogram in
12336 -- the case of a renaming (Alias covers both these cases).
12339 if (Suppress_Elaboration_Warnings (Ent)
12340 or else Elaboration_Checks_Suppressed (Ent))
12341 and then (Inst_Case or else No (Alias (Ent)))
12346 -- Nothing to do for imported entities
12348 if Is_Imported (Ent) then
12352 exit when Inst_Case or else No (Alias (Ent));
12353 Ent := Alias (Ent);
12356 Decl := Unit_Declaration_Node (Ent);
12358 if Nkind (Decl) = N_Subprogram_Body then
12359 Body_Acts_As_Spec := True;
12361 elsif Nkind_In (Decl, N_Subprogram_Declaration,
12362 N_Subprogram_Body_Stub)
12365 Body_Acts_As_Spec := False;
12367 -- If we have none of an instantiation, subprogram body or subprogram
12368 -- declaration, or in the SPARK case, a variable reference, then
12369 -- it is not a case that we want to check. (One case is a call to a
12370 -- generic formal subprogram, where we do not want the check in the
12380 if Elaboration_Checks_Suppressed (E_Scope)
12381 or else Suppress_Elaboration_Warnings (E_Scope)
12386 -- Exit when we get to compilation unit, not counting subunits
12388 exit when Is_Compilation_Unit (E_Scope)
12389 and then (Is_Child_Unit (E_Scope)
12390 or else Scope (E_Scope) = Standard_Standard);
12392 pragma Assert (E_Scope /= Standard_Standard);
12394 -- Move up a scope looking for compilation unit
12396 E_Scope := Scope (E_Scope);
12399 -- No checks needed for pure or preelaborated compilation units
12401 if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then
12405 -- If the generic entity is within a deeper instance than we are, then
12406 -- either the instantiation to which we refer itself caused an ABE, in
12407 -- which case that will be handled separately, or else we know that the
12408 -- body we need appears as needed at the point of the instantiation.
12409 -- However, this assumption is only valid if we are in static mode.
12411 if not Dynamic_Elaboration_Checks
12413 Instantiation_Depth (Sloc (Ent)) > Instantiation_Depth (Sloc (N))
12418 -- Do not give a warning for a package with no body
12420 if Ekind (Ent) = E_Generic_Package and then not Has_Generic_Body (N) then
12424 -- Case of entity is in same unit as call or instantiation. In the
12425 -- instantiation case, W_Scope may be different from E_Scope; we want
12426 -- the unit in which the instantiation occurs, since we're analyzing
12427 -- based on the expansion.
12429 if W_Scope = C_Scope then
12430 if not Inter_Unit_Only then
12431 Check_Internal_Call (N, Ent, Outer_Scope, E);
12437 -- Case of entity is not in current unit (i.e. with'ed unit case)
12439 -- We are only interested in such calls if the outer call was from
12440 -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode.
12442 if not From_Elab_Code and then not Dynamic_Elaboration_Checks then
12446 -- Nothing to do if some scope said that no checks were required
12452 -- Nothing to do for a generic instance, because a call to an instance
12453 -- cannot fail the elaboration check, because the body of the instance
12454 -- is always elaborated immediately after the spec.
12456 if Call_To_Instance_From_Outside (Ent) then
12460 -- Nothing to do if subprogram with no separate spec. However, a call
12461 -- to Deep_Initialize may result in a call to a user-defined Initialize
12462 -- procedure, which imposes a body dependency. This happens only if the
12463 -- type is controlled and the Initialize procedure is not inherited.
12465 if Body_Acts_As_Spec then
12466 if Is_TSS (Ent, TSS_Deep_Initialize) then
12468 Typ : constant Entity_Id := Etype (First_Formal (Ent));
12472 if not Is_Controlled (Typ) then
12475 Init := Find_Prim_Op (Typ, Name_Initialize);
12477 if Comes_From_Source (Init) then
12490 -- Check cases of internal units
12492 Callee_Unit_Internal := In_Internal_Unit (E_Scope);
12494 -- Do not give a warning if the with'ed unit is internal and this is
12495 -- the generic instantiation case (this saves a lot of hassle dealing
12496 -- with the Text_IO special child units)
12498 if Callee_Unit_Internal and Inst_Case then
12502 if C_Scope = Standard_Standard then
12503 Caller_Unit_Internal := False;
12505 Caller_Unit_Internal := In_Internal_Unit (C_Scope);
12508 -- Do not give a warning if the with'ed unit is internal and the caller
12509 -- is not internal (since the binder always elaborates internal units
12512 if Callee_Unit_Internal and not Caller_Unit_Internal then
12516 -- For now, if debug flag -gnatdE is not set, do no checking for one
12517 -- internal unit withing another. This fixes the problem with the sgi
12518 -- build and storage errors. To be resolved later ???
12520 if (Callee_Unit_Internal and Caller_Unit_Internal)
12521 and not Debug_Flag_EE
12526 if Is_TSS (E, TSS_Deep_Initialize) then
12530 -- If the call is in an instance, and the called entity is not
12531 -- defined in the same instance, then the elaboration issue focuses
12532 -- around the unit containing the template, it is this unit that
12533 -- requires an Elaborate_All.
12535 -- However, if we are doing dynamic elaboration, we need to chase the
12536 -- call in the usual manner.
12538 -- We also need to chase the call in the usual manner if it is a call
12539 -- to a generic formal parameter, since that case was not handled as
12540 -- part of the processing of the template.
12542 Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N)));
12543 Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent)));
12545 if Inst_Caller = No_Location then
12546 Unit_Caller := No_Unit;
12548 Unit_Caller := Get_Source_Unit (N);
12551 if Inst_Callee = No_Location then
12552 Unit_Callee := No_Unit;
12554 Unit_Callee := Get_Source_Unit (Ent);
12557 if Unit_Caller /= No_Unit
12558 and then Unit_Callee /= Unit_Caller
12559 and then not Dynamic_Elaboration_Checks
12560 and then not Is_Call_Of_Generic_Formal (N)
12562 E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller));
12564 -- If we don't get a spec entity, just ignore call. Not quite
12565 -- clear why this check is necessary. ???
12567 if No (E_Scope) then
12571 -- Otherwise step to enclosing compilation unit
12573 while not Is_Compilation_Unit (E_Scope) loop
12574 E_Scope := Scope (E_Scope);
12577 -- For the case where N is not an instance, and is not a call within
12578 -- instance to other than a generic formal, we recompute E_Scope
12579 -- for the error message, since we do NOT want to go to the unit
12580 -- that has the ultimate declaration in the case of renaming and
12581 -- derivation and we also want to go to the generic unit in the
12582 -- case of an instance, and no further.
12585 -- Loop to carefully follow renamings and derivations one step
12586 -- outside the current unit, but not further.
12588 if not (Inst_Case or Variable_Case)
12589 and then Present (Alias (Ent))
12591 E_Scope := Alias (Ent);
12597 while not Is_Compilation_Unit (E_Scope) loop
12598 E_Scope := Scope (E_Scope);
12601 -- If E_Scope is the same as C_Scope, it means that there
12602 -- definitely was a local renaming or derivation, and we
12603 -- are not yet out of the current unit.
12605 exit when E_Scope /= C_Scope;
12606 Ent := Alias (Ent);
12609 -- If no alias, there could be a previous error, but not if we've
12610 -- already reached the outermost level (Standard).
12618 if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then
12622 -- Determine whether the Default_Initial_Condition procedure of some
12623 -- type is being invoked.
12625 Is_DIC := Ekind (Ent) = E_Procedure and then Is_DIC_Procedure (Ent);
12627 -- Checks related to Default_Initial_Condition fall under the SPARK
12628 -- umbrella because this is a SPARK-specific annotation.
12630 SPARK_Elab_Errors :=
12631 SPARK_Mode = On and (Is_DIC or Dynamic_Elaboration_Checks);
12633 -- Now check if an Elaborate_All (or dynamic check) is needed
12635 if (Elab_Info_Messages or Elab_Warnings or SPARK_Elab_Errors)
12636 and then Generate_Warnings
12637 and then not Suppress_Elaboration_Warnings (Ent)
12638 and then not Elaboration_Checks_Suppressed (Ent)
12639 and then not Suppress_Elaboration_Warnings (E_Scope)
12640 and then not Elaboration_Checks_Suppressed (E_Scope)
12642 -- Instantiation case
12645 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then
12647 ("instantiation of & during elaboration in SPARK", N, Ent);
12650 ("instantiation of & may raise Program_Error?l?",
12651 "info: instantiation of & during elaboration?$?", Ent);
12654 -- Indirect call case, info message only in static elaboration
12655 -- case, because the attribute reference itself cannot raise an
12656 -- exception. Note that SPARK does not permit indirect calls.
12658 elsif Access_Case then
12659 Elab_Warning ("", "info: access to & during elaboration?$?", Ent);
12661 -- Variable reference in SPARK mode
12663 elsif Variable_Case then
12664 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then
12666 ("reference to & during elaboration in SPARK", N, Ent);
12669 -- Subprogram call case
12672 if Nkind (Name (N)) in N_Has_Entity
12673 and then Is_Init_Proc (Entity (Name (N)))
12674 and then Comes_From_Source (Ent)
12677 ("implicit call to & may raise Program_Error?l?",
12678 "info: implicit call to & during elaboration?$?",
12681 elsif SPARK_Elab_Errors then
12683 -- Emit a specialized error message when the elaboration of an
12684 -- object of a private type evaluates the expression of pragma
12685 -- Default_Initial_Condition. This prevents the internal name
12686 -- of the procedure from appearing in the error message.
12690 ("call to Default_Initial_Condition during elaboration in "
12694 ("call to & during elaboration in SPARK", N, Ent);
12699 ("call to & may raise Program_Error?l?",
12700 "info: call to & during elaboration?$?",
12705 Error_Msg_Qual_Level := Nat'Last;
12707 -- Case of Elaborate_All not present and required, for SPARK this
12708 -- is an error, so give an error message.
12710 if SPARK_Elab_Errors then
12711 Error_Msg_NE -- CODEFIX
12712 ("\Elaborate_All pragma required for&", N, W_Scope);
12714 -- Otherwise we generate an implicit pragma. For a subprogram
12715 -- instantiation, Elaborate is good enough, since no transitive
12716 -- call is possible at elaboration time in this case.
12718 elsif Nkind (N) in N_Subprogram_Instantiation then
12720 ("\missing pragma Elaborate for&?l?",
12721 "\implicit pragma Elaborate for& generated?$?",
12724 -- For all other cases, we need an implicit Elaborate_All
12728 ("\missing pragma Elaborate_All for&?l?",
12729 "\implicit pragma Elaborate_All for & generated?$?",
12733 Error_Msg_Qual_Level := 0;
12735 -- Take into account the flags related to elaboration warning
12736 -- messages when enumerating the various calls involved. This
12737 -- ensures the proper pairing of the main warning and the
12738 -- clarification messages generated by Output_Calls.
12740 Output_Calls (N, Check_Elab_Flag => True);
12742 -- Set flag to prevent further warnings for same unit unless in
12743 -- All_Errors_Mode.
12745 if not All_Errors_Mode and not Dynamic_Elaboration_Checks then
12746 Set_Suppress_Elaboration_Warnings (W_Scope);
12750 -- Check for runtime elaboration check required
12752 if Dynamic_Elaboration_Checks then
12753 if not Elaboration_Checks_Suppressed (Ent)
12754 and then not Elaboration_Checks_Suppressed (W_Scope)
12755 and then not Elaboration_Checks_Suppressed (E_Scope)
12756 and then not Cunit_SC
12758 -- Runtime elaboration check required. Generate check of the
12759 -- elaboration Boolean for the unit containing the entity.
12761 -- Note that for this case, we do check the real unit (the one
12762 -- from following renamings, since that is the issue).
12764 -- Could this possibly miss a useless but required PE???
12766 Insert_Elab_Check (N,
12767 Make_Attribute_Reference (Loc,
12768 Attribute_Name => Name_Elaborated,
12770 New_Occurrence_Of (Spec_Entity (E_Scope), Loc)));
12772 -- Prevent duplicate elaboration checks on the same call, which
12773 -- can happen if the body enclosing the call appears itself in a
12774 -- call whose elaboration check is delayed.
12776 if Nkind (N) in N_Subprogram_Call then
12777 Set_No_Elaboration_Check (N);
12781 -- Case of static elaboration model
12784 -- Do not do anything if elaboration checks suppressed. Note that
12785 -- we check Ent here, not E, since we want the real entity for the
12786 -- body to see if checks are suppressed for it, not the dummy
12787 -- entry for renamings or derivations.
12789 if Elaboration_Checks_Suppressed (Ent)
12790 or else Elaboration_Checks_Suppressed (E_Scope)
12791 or else Elaboration_Checks_Suppressed (W_Scope)
12795 -- Do not generate an Elaborate_All for finalization routines
12796 -- that perform partial clean up as part of initialization.
12798 elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then
12801 -- Here we need to generate an implicit elaborate all
12804 -- Generate Elaborate_All warning unless suppressed
12806 if (Elab_Info_Messages and Generate_Warnings and not Inst_Case)
12807 and then not Suppress_Elaboration_Warnings (Ent)
12808 and then not Suppress_Elaboration_Warnings (E_Scope)
12809 and then not Suppress_Elaboration_Warnings (W_Scope)
12811 Error_Msg_Node_2 := W_Scope;
12813 ("info: call to& in elaboration code requires pragma "
12814 & "Elaborate_All on&?$?", N, E);
12817 -- Set indication for binder to generate Elaborate_All
12819 Set_Elaboration_Constraint (N, E, W_Scope);
12824 -----------------------------
12825 -- Check_Bad_Instantiation --
12826 -----------------------------
12828 procedure Check_Bad_Instantiation (N : Node_Id) is
12832 -- Nothing to do if we do not have an instantiation (happens in some
12833 -- error cases, and also in the formal package declaration case)
12835 if Nkind (N) not in N_Generic_Instantiation then
12838 -- Nothing to do if serious errors detected (avoid cascaded errors)
12840 elsif Serious_Errors_Detected /= 0 then
12843 -- Nothing to do if not in full analysis mode
12845 elsif not Full_Analysis then
12848 -- Nothing to do if inside a generic template
12850 elsif Inside_A_Generic then
12853 -- Nothing to do if a library level instantiation
12855 elsif Nkind (Parent (N)) = N_Compilation_Unit then
12858 -- Nothing to do if we are compiling a proper body for semantic
12859 -- purposes only. The generic body may be in another proper body.
12862 Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit
12867 Ent := Get_Generic_Entity (N);
12869 -- The case we are interested in is when the generic spec is in the
12870 -- current declarative part
12872 if not Same_Elaboration_Scope (Current_Scope, Scope (Ent))
12873 or else not In_Same_Extended_Unit (N, Ent)
12878 -- If the generic entity is within a deeper instance than we are, then
12879 -- either the instantiation to which we refer itself caused an ABE, in
12880 -- which case that will be handled separately. Otherwise, we know that
12881 -- the body we need appears as needed at the point of the instantiation.
12882 -- If they are both at the same level but not within the same instance
12883 -- then the body of the generic will be in the earlier instance.
12886 D1 : constant Nat := Instantiation_Depth (Sloc (Ent));
12887 D2 : constant Nat := Instantiation_Depth (Sloc (N));
12894 and then Is_Generic_Instance (Scope (Ent))
12895 and then not In_Open_Scopes (Scope (Ent))
12901 -- Now we can proceed, if the entity being called has a completion,
12902 -- then we are definitely OK, since we have already seen the body.
12904 if Has_Completion (Ent) then
12908 -- If there is no body, then nothing to do
12910 if not Has_Generic_Body (N) then
12914 -- Here we definitely have a bad instantiation
12916 Error_Msg_Warn := SPARK_Mode /= On;
12917 Error_Msg_NE ("cannot instantiate& before body seen<<", N, Ent);
12918 Error_Msg_N ("\Program_Error [<<", N);
12920 Insert_Elab_Check (N);
12921 Set_Is_Known_Guaranteed_ABE (N);
12922 end Check_Bad_Instantiation;
12924 ---------------------
12925 -- Check_Elab_Call --
12926 ---------------------
12928 procedure Check_Elab_Call
12930 Outer_Scope : Entity_Id := Empty;
12931 In_Init_Proc : Boolean := False)
12937 pragma Assert (Legacy_Elaboration_Checks);
12939 -- If the reference is not in the main unit, there is nothing to check.
12940 -- Elaboration call from units in the context of the main unit will lead
12941 -- to semantic dependencies when those units are compiled.
12943 if not In_Extended_Main_Code_Unit (N) then
12947 -- For an entry call, check relevant restriction
12949 if Nkind (N) = N_Entry_Call_Statement
12950 and then not In_Subprogram_Or_Concurrent_Unit
12952 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N);
12954 -- Nothing to do if this is not an expected type of reference (happens
12955 -- in some error conditions, and in some cases where rewriting occurs).
12957 elsif Nkind (N) not in N_Subprogram_Call
12958 and then Nkind (N) /= N_Attribute_Reference
12959 and then (SPARK_Mode /= On
12960 or else Nkind (N) not in N_Has_Entity
12961 or else No (Entity (N))
12962 or else Ekind (Entity (N)) /= E_Variable)
12966 -- Nothing to do if this is a call already rewritten for elab checking.
12967 -- Such calls appear as the targets of If_Expressions.
12969 -- This check MUST be wrong, it catches far too much
12971 elsif Nkind (Parent (N)) = N_If_Expression then
12974 -- Nothing to do if inside a generic template
12976 elsif Inside_A_Generic
12977 and then No (Enclosing_Generic_Body (N))
12981 -- Nothing to do if call is being pre-analyzed, as when within a
12982 -- pre/postcondition, a predicate, or an invariant.
12984 elsif In_Spec_Expression then
12988 -- Nothing to do if this is a call to a postcondition, which is always
12989 -- within a subprogram body, even though the current scope may be the
12990 -- enclosing scope of the subprogram.
12992 if Nkind (N) = N_Procedure_Call_Statement
12993 and then Is_Entity_Name (Name (N))
12994 and then Chars (Entity (Name (N))) = Name_uPostconditions
12999 -- Here we have a reference at elaboration time that must be checked
13001 if Debug_Flag_Underscore_LL then
13002 Write_Str (" Check_Elab_Ref: ");
13004 if Nkind (N) = N_Attribute_Reference then
13005 if not Is_Entity_Name (Prefix (N)) then
13006 Write_Str ("<<not entity name>>");
13008 Write_Name (Chars (Entity (Prefix (N))));
13011 Write_Str ("'Access");
13013 elsif No (Name (N)) or else not Is_Entity_Name (Name (N)) then
13014 Write_Str ("<<not entity name>> ");
13017 Write_Name (Chars (Entity (Name (N))));
13020 Write_Str (" reference at ");
13021 Write_Location (Sloc (N));
13025 -- Climb up the tree to make sure we are not inside default expression
13026 -- of a parameter specification or a record component, since in both
13027 -- these cases, we will be doing the actual reference later, not now,
13028 -- and it is at the time of the actual reference (statically speaking)
13029 -- that we must do our static check, not at the time of its initial
13032 -- However, we have to check references within component definitions
13033 -- (e.g. a function call that determines an array component bound),
13034 -- so we terminate the loop in that case.
13037 while Present (P) loop
13038 if Nkind_In (P, N_Parameter_Specification,
13039 N_Component_Declaration)
13043 -- The reference occurs within the constraint of a component,
13044 -- so it must be checked.
13046 elsif Nkind (P) = N_Component_Definition then
13054 -- Stuff that happens only at the outer level
13056 if No (Outer_Scope) then
13057 Elab_Visited.Set_Last (0);
13059 -- Nothing to do if current scope is Standard (this is a bit odd, but
13060 -- it happens in the case of generic instantiations).
13062 C_Scope := Current_Scope;
13064 if C_Scope = Standard_Standard then
13068 -- First case, we are in elaboration code
13070 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
13072 if From_Elab_Code then
13074 -- Complain if ref that comes from source in preelaborated unit
13075 -- and we are not inside a subprogram (i.e. we are in elab code).
13077 if Comes_From_Source (N)
13078 and then In_Preelaborated_Unit
13079 and then not In_Inlined_Body
13080 and then Nkind (N) /= N_Attribute_Reference
13082 -- This is a warning in GNAT mode allowing such calls to be
13083 -- used in the predefined library with appropriate care.
13085 Error_Msg_Warn := GNAT_Mode;
13087 ("<<non-static call not allowed in preelaborated unit", N);
13091 -- Second case, we are inside a subprogram or concurrent unit, which
13092 -- means we are not in elaboration code.
13095 -- In this case, the issue is whether we are inside the
13096 -- declarative part of the unit in which we live, or inside its
13097 -- statements. In the latter case, there is no issue of ABE calls
13098 -- at this level (a call from outside to the unit in which we live
13099 -- might cause an ABE, but that will be detected when we analyze
13100 -- that outer level call, as it recurses into the called unit).
13102 -- Climb up the tree, doing this test, and also testing for being
13103 -- inside a default expression, which, as discussed above, is not
13104 -- checked at this stage.
13113 -- If we find a parentless subtree, it seems safe to assume
13114 -- that we are not in a declarative part and that no
13115 -- checking is required.
13121 if Is_List_Member (P) then
13122 L := List_Containing (P);
13129 exit when Nkind (P) = N_Subunit;
13131 -- Filter out case of default expressions, where we do not
13132 -- do the check at this stage.
13134 if Nkind_In (P, N_Parameter_Specification,
13135 N_Component_Declaration)
13140 -- A protected body has no elaboration code and contains
13141 -- only other bodies.
13143 if Nkind (P) = N_Protected_Body then
13146 elsif Nkind_In (P, N_Subprogram_Body,
13151 if L = Declarations (P) then
13154 -- We are not in elaboration code, but we are doing
13155 -- dynamic elaboration checks, in this case, we still
13156 -- need to do the reference, since the subprogram we are
13157 -- in could be called from another unit, also in dynamic
13158 -- elaboration check mode, at elaboration time.
13160 elsif Dynamic_Elaboration_Checks then
13162 -- We provide a debug flag to disable this check. That
13163 -- way we have an easy work around for regressions
13164 -- that are caused by this new check. This debug flag
13165 -- can be removed later.
13167 if Debug_Flag_DD then
13171 -- Do the check in this case
13175 elsif Nkind (P) = N_Task_Body then
13177 -- The check is deferred until Check_Task_Activation
13178 -- but we need to capture local suppress pragmas
13179 -- that may inhibit checks on this call.
13181 Ent := Get_Referenced_Ent (N);
13186 elsif Elaboration_Checks_Suppressed (Current_Scope)
13187 or else Elaboration_Checks_Suppressed (Ent)
13188 or else Elaboration_Checks_Suppressed (Scope (Ent))
13190 if Nkind (N) in N_Subprogram_Call then
13191 Set_No_Elaboration_Check (N);
13197 -- Static model, call is not in elaboration code, we
13198 -- never need to worry, because in the static model the
13199 -- top-level caller always takes care of things.
13210 Ent := Get_Referenced_Ent (N);
13216 -- Determine whether a prior call to the same subprogram was already
13217 -- examined within the same context. If this is the case, then there is
13218 -- no need to proceed with the various warnings and checks because the
13219 -- work was already done for the previous call.
13222 Self : constant Visited_Element :=
13223 (Subp_Id => Ent, Context => Parent (N));
13226 for Index in 1 .. Elab_Visited.Last loop
13227 if Self = Elab_Visited.Table (Index) then
13233 -- See if we need to analyze this reference. We analyze it if either of
13234 -- the following conditions is met:
13236 -- It is an inner level call (since in this case it was triggered
13237 -- by an outer level call from elaboration code), but only if the
13238 -- call is within the scope of the original outer level call.
13240 -- It is an outer level reference from elaboration code, or a call to
13241 -- an entity is in the same elaboration scope.
13243 -- And in these cases, we will check both inter-unit calls and
13244 -- intra-unit (within a single unit) calls.
13246 C_Scope := Current_Scope;
13248 -- If not outer level reference, then we follow it if it is within the
13249 -- original scope of the outer reference.
13251 if Present (Outer_Scope)
13252 and then Within (Scope (Ent), Outer_Scope)
13258 Outer_Scope => Outer_Scope,
13259 Inter_Unit_Only => False,
13260 In_Init_Proc => In_Init_Proc);
13262 -- Nothing to do if elaboration checks suppressed for this scope.
13263 -- However, an interesting exception, the fact that elaboration checks
13264 -- are suppressed within an instance (because we can trace the body when
13265 -- we process the template) does not extend to calls to generic formal
13268 elsif Elaboration_Checks_Suppressed (Current_Scope)
13269 and then not Is_Call_Of_Generic_Formal (N)
13273 elsif From_Elab_Code then
13275 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False);
13277 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then
13279 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
13281 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode
13282 -- is set, then we will do the check, but only in the inter-unit case
13283 -- (this is to accommodate unguarded elaboration calls from other units
13284 -- in which this same mode is set). We don't want warnings in this case,
13285 -- it would generate warnings having nothing to do with elaboration.
13287 elsif Dynamic_Elaboration_Checks then
13293 Inter_Unit_Only => True,
13294 Generate_Warnings => False);
13296 -- Otherwise nothing to do
13302 -- A call to an Init_Proc in elaboration code may bring additional
13303 -- dependencies, if some of the record components thereof have
13304 -- initializations that are function calls that come from source. We
13305 -- treat the current node as a call to each of these functions, to check
13306 -- their elaboration impact.
13308 if Is_Init_Proc (Ent) and then From_Elab_Code then
13309 Process_Init_Proc : declare
13310 Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent);
13312 function Check_Init_Call (Nod : Node_Id) return Traverse_Result;
13313 -- Find subprogram calls within body of Init_Proc for Traverse
13314 -- instantiation below.
13316 procedure Traverse_Body is new Traverse_Proc (Check_Init_Call);
13317 -- Traversal procedure to find all calls with body of Init_Proc
13319 ---------------------
13320 -- Check_Init_Call --
13321 ---------------------
13323 function Check_Init_Call (Nod : Node_Id) return Traverse_Result is
13327 if Nkind (Nod) in N_Subprogram_Call
13328 and then Is_Entity_Name (Name (Nod))
13330 Func := Entity (Name (Nod));
13332 if Comes_From_Source (Func) then
13334 (N, Func, Standard_Standard, Inter_Unit_Only => True);
13342 end Check_Init_Call;
13344 -- Start of processing for Process_Init_Proc
13347 if Nkind (Unit_Decl) = N_Subprogram_Body then
13348 Traverse_Body (Handled_Statement_Sequence (Unit_Decl));
13350 end Process_Init_Proc;
13352 end Check_Elab_Call;
13354 -----------------------
13355 -- Check_Elab_Assign --
13356 -----------------------
13358 procedure Check_Elab_Assign (N : Node_Id) is
13362 Pkg_Spec : Entity_Id;
13363 Pkg_Body : Entity_Id;
13366 pragma Assert (Legacy_Elaboration_Checks);
13368 -- For record or array component, check prefix. If it is an access type,
13369 -- then there is nothing to do (we do not know what is being assigned),
13370 -- but otherwise this is an assignment to the prefix.
13372 if Nkind_In (N, N_Indexed_Component,
13373 N_Selected_Component,
13376 if not Is_Access_Type (Etype (Prefix (N))) then
13377 Check_Elab_Assign (Prefix (N));
13383 -- For type conversion, check expression
13385 if Nkind (N) = N_Type_Conversion then
13386 Check_Elab_Assign (Expression (N));
13390 -- Nothing to do if this is not an entity reference otherwise get entity
13392 if Is_Entity_Name (N) then
13398 -- What we are looking for is a reference in the body of a package that
13399 -- modifies a variable declared in the visible part of the package spec.
13402 and then Comes_From_Source (N)
13403 and then not Suppress_Elaboration_Warnings (Ent)
13404 and then Ekind (Ent) = E_Variable
13405 and then not In_Private_Part (Ent)
13406 and then Is_Library_Level_Entity (Ent)
13408 Scop := Current_Scope;
13410 if No (Scop) or else Scop = Standard_Standard then
13412 elsif Ekind (Scop) = E_Package
13413 and then Is_Compilation_Unit (Scop)
13417 Scop := Scope (Scop);
13421 -- Here Scop points to the containing library package
13424 Pkg_Body := Body_Entity (Pkg_Spec);
13426 -- All OK if the package has an Elaborate_Body pragma
13428 if Has_Pragma_Elaborate_Body (Scop) then
13432 -- OK if entity being modified is not in containing package spec
13434 if not In_Same_Source_Unit (Scop, Ent) then
13438 -- All OK if entity appears in generic package or generic instance.
13439 -- We just get too messed up trying to give proper warnings in the
13440 -- presence of generics. Better no message than a junk one.
13442 Scop := Scope (Ent);
13443 while Present (Scop) and then Scop /= Pkg_Spec loop
13444 if Ekind (Scop) = E_Generic_Package then
13446 elsif Ekind (Scop) = E_Package
13447 and then Is_Generic_Instance (Scop)
13452 Scop := Scope (Scop);
13455 -- All OK if in task, don't issue warnings there
13457 if In_Task_Activation then
13461 -- OK if no package body
13463 if No (Pkg_Body) then
13467 -- OK if reference is not in package body
13469 if not In_Same_Source_Unit (Pkg_Body, N) then
13473 -- OK if package body has no handled statement sequence
13476 HSS : constant Node_Id :=
13477 Handled_Statement_Sequence (Declaration_Node (Pkg_Body));
13479 if No (HSS) or else not Comes_From_Source (HSS) then
13484 -- We definitely have a case of a modification of an entity in
13485 -- the package spec from the elaboration code of the package body.
13486 -- We may not give the warning (because there are some additional
13487 -- checks to avoid too many false positives), but it would be a good
13488 -- idea for the binder to try to keep the body elaboration close to
13489 -- the spec elaboration.
13491 Set_Elaborate_Body_Desirable (Pkg_Spec);
13493 -- All OK in gnat mode (we know what we are doing)
13499 -- All OK if all warnings suppressed
13501 if Warning_Mode = Suppress then
13505 -- All OK if elaboration checks suppressed for entity
13507 if Checks_May_Be_Suppressed (Ent)
13508 and then Is_Check_Suppressed (Ent, Elaboration_Check)
13513 -- OK if the entity is initialized. Note that the No_Initialization
13514 -- flag usually means that the initialization has been rewritten into
13515 -- assignments, but that still counts for us.
13518 Decl : constant Node_Id := Declaration_Node (Ent);
13520 if Nkind (Decl) = N_Object_Declaration
13521 and then (Present (Expression (Decl))
13522 or else No_Initialization (Decl))
13528 -- Here is where we give the warning
13530 -- All OK if warnings suppressed on the entity
13532 if not Has_Warnings_Off (Ent) then
13533 Error_Msg_Sloc := Sloc (Ent);
13536 ("??& can be accessed by clients before this initialization",
13539 ("\??add Elaborate_Body to spec to ensure & is initialized",
13543 if not All_Errors_Mode then
13544 Set_Suppress_Elaboration_Warnings (Ent);
13547 end Check_Elab_Assign;
13549 ----------------------
13550 -- Check_Elab_Calls --
13551 ----------------------
13553 -- WARNING: This routine manages SPARK regions
13555 procedure Check_Elab_Calls is
13556 Saved_SM : SPARK_Mode_Type;
13557 Saved_SMP : Node_Id;
13560 pragma Assert (Legacy_Elaboration_Checks);
13562 -- If expansion is disabled, do not generate any checks, unless we
13563 -- are in GNATprove mode, so that errors are issued in GNATprove for
13564 -- violations of static elaboration rules in SPARK code. Also skip
13565 -- checks if any subunits are missing because in either case we lack the
13566 -- full information that we need, and no object file will be created in
13569 if (not Expander_Active and not GNATprove_Mode)
13570 or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
13571 or else Subunits_Missing
13576 -- Skip delayed calls if we had any errors
13578 if Serious_Errors_Detected = 0 then
13579 Delaying_Elab_Checks := False;
13580 Expander_Mode_Save_And_Set (True);
13582 for J in Delay_Check.First .. Delay_Check.Last loop
13583 Push_Scope (Delay_Check.Table (J).Curscop);
13584 From_Elab_Code := Delay_Check.Table (J).From_Elab_Code;
13585 In_Task_Activation := Delay_Check.Table (J).In_Task_Activation;
13587 Saved_SM := SPARK_Mode;
13588 Saved_SMP := SPARK_Mode_Pragma;
13590 -- Set appropriate value of SPARK_Mode
13592 if Delay_Check.Table (J).From_SPARK_Code then
13596 Check_Internal_Call_Continue
13597 (N => Delay_Check.Table (J).N,
13598 E => Delay_Check.Table (J).E,
13599 Outer_Scope => Delay_Check.Table (J).Outer_Scope,
13600 Orig_Ent => Delay_Check.Table (J).Orig_Ent);
13602 Restore_SPARK_Mode (Saved_SM, Saved_SMP);
13606 -- Set Delaying_Elab_Checks back on for next main compilation
13608 Expander_Mode_Restore;
13609 Delaying_Elab_Checks := True;
13611 end Check_Elab_Calls;
13613 ------------------------------
13614 -- Check_Elab_Instantiation --
13615 ------------------------------
13617 procedure Check_Elab_Instantiation
13619 Outer_Scope : Entity_Id := Empty)
13624 pragma Assert (Legacy_Elaboration_Checks);
13626 -- Check for and deal with bad instantiation case. There is some
13627 -- duplicated code here, but we will worry about this later ???
13629 Check_Bad_Instantiation (N);
13631 if Is_Known_Guaranteed_ABE (N) then
13635 -- Nothing to do if we do not have an instantiation (happens in some
13636 -- error cases, and also in the formal package declaration case)
13638 if Nkind (N) not in N_Generic_Instantiation then
13642 -- Nothing to do if inside a generic template
13644 if Inside_A_Generic then
13648 -- Nothing to do if the instantiation is not in the main unit
13650 if not In_Extended_Main_Code_Unit (N) then
13654 Ent := Get_Generic_Entity (N);
13655 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
13657 -- See if we need to analyze this instantiation. We analyze it if
13658 -- either of the following conditions is met:
13660 -- It is an inner level instantiation (since in this case it was
13661 -- triggered by an outer level call from elaboration code), but
13662 -- only if the instantiation is within the scope of the original
13663 -- outer level call.
13665 -- It is an outer level instantiation from elaboration code, or the
13666 -- instantiated entity is in the same elaboration scope.
13668 -- And in these cases, we will check both the inter-unit case and
13669 -- the intra-unit (within a single unit) case.
13671 C_Scope := Current_Scope;
13673 if Present (Outer_Scope) and then Within (Scope (Ent), Outer_Scope) then
13675 Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False);
13677 elsif From_Elab_Code then
13679 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False);
13681 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then
13683 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
13685 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is
13686 -- set, then we will do the check, but only in the inter-unit case (this
13687 -- is to accommodate unguarded elaboration calls from other units in
13688 -- which this same mode is set). We inhibit warnings in this case, since
13689 -- this instantiation is not occurring in elaboration code.
13691 elsif Dynamic_Elaboration_Checks then
13697 Inter_Unit_Only => True,
13698 Generate_Warnings => False);
13703 end Check_Elab_Instantiation;
13705 -------------------------
13706 -- Check_Internal_Call --
13707 -------------------------
13709 procedure Check_Internal_Call
13712 Outer_Scope : Entity_Id;
13713 Orig_Ent : Entity_Id)
13715 function Within_Initial_Condition (Call : Node_Id) return Boolean;
13716 -- Determine whether call Call occurs within pragma Initial_Condition or
13717 -- pragma Check with check_kind set to Initial_Condition.
13719 ------------------------------
13720 -- Within_Initial_Condition --
13721 ------------------------------
13723 function Within_Initial_Condition (Call : Node_Id) return Boolean is
13729 -- Traverse the parent chain looking for an enclosing pragma
13732 while Present (Par) loop
13733 if Nkind (Par) = N_Pragma then
13734 Nam := Pragma_Name (Par);
13736 -- Pragma Initial_Condition appears in its alternative from as
13737 -- Check (Initial_Condition, ...).
13739 if Nam = Name_Check then
13740 Args := Pragma_Argument_Associations (Par);
13742 -- Pragma Check should have at least two arguments
13744 pragma Assert (Present (Args));
13747 Chars (Expression (First (Args))) = Name_Initial_Condition;
13751 elsif Nam = Name_Initial_Condition then
13754 -- Since pragmas are never nested within other pragmas, stop
13761 -- Prevent the search from going too far
13763 elsif Is_Body_Or_Package_Declaration (Par) then
13767 Par := Parent (Par);
13769 -- If assertions are not enabled, the check pragma is rewritten
13770 -- as an if_statement in sem_prag, to generate various warnings
13771 -- on boolean expressions. Retrieve the original pragma.
13773 if Nkind (Original_Node (Par)) = N_Pragma then
13774 Par := Original_Node (Par);
13779 end Within_Initial_Condition;
13783 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
13785 -- Start of processing for Check_Internal_Call
13788 -- For P'Access, we want to warn if the -gnatw.f switch is set, and the
13789 -- node comes from source.
13791 if Nkind (N) = N_Attribute_Reference
13792 and then ((not Warn_On_Elab_Access and then not Debug_Flag_Dot_O)
13793 or else not Comes_From_Source (N))
13797 -- If not function or procedure call, instantiation, or 'Access, then
13798 -- ignore call (this happens in some error cases and rewriting cases).
13800 elsif not Nkind_In (N, N_Attribute_Reference,
13802 N_Procedure_Call_Statement)
13803 and then not Inst_Case
13807 -- Nothing to do if this is a call or instantiation that has already
13808 -- been found to be a sure ABE.
13810 elsif Nkind (N) /= N_Attribute_Reference
13811 and then Is_Known_Guaranteed_ABE (N)
13815 -- Nothing to do if errors already detected (avoid cascaded errors)
13817 elsif Serious_Errors_Detected /= 0 then
13820 -- Nothing to do if not in full analysis mode
13822 elsif not Full_Analysis then
13825 -- Nothing to do if analyzing in special spec-expression mode, since the
13826 -- call is not actually being made at this time.
13828 elsif In_Spec_Expression then
13831 -- Nothing to do for call to intrinsic subprogram
13833 elsif Is_Intrinsic_Subprogram (E) then
13836 -- Nothing to do if call is within a generic unit
13838 elsif Inside_A_Generic then
13841 -- Nothing to do when the call appears within pragma Initial_Condition.
13842 -- The pragma is part of the elaboration statements of a package body
13843 -- and may only call external subprograms or subprograms whose body is
13844 -- already available.
13846 elsif Within_Initial_Condition (N) then
13850 -- Delay this call if we are still delaying calls
13852 if Delaying_Elab_Checks then
13856 Orig_Ent => Orig_Ent,
13857 Curscop => Current_Scope,
13858 Outer_Scope => Outer_Scope,
13859 From_Elab_Code => From_Elab_Code,
13860 In_Task_Activation => In_Task_Activation,
13861 From_SPARK_Code => SPARK_Mode = On));
13864 -- Otherwise, call phase 2 continuation right now
13867 Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent);
13869 end Check_Internal_Call;
13871 ----------------------------------
13872 -- Check_Internal_Call_Continue --
13873 ----------------------------------
13875 procedure Check_Internal_Call_Continue
13878 Outer_Scope : Entity_Id;
13879 Orig_Ent : Entity_Id)
13881 function Find_Elab_Reference (N : Node_Id) return Traverse_Result;
13882 -- Function applied to each node as we traverse the body. Checks for
13883 -- call or entity reference that needs checking, and if so checks it.
13884 -- Always returns OK, so entire tree is traversed, except that as
13885 -- described below subprogram bodies are skipped for now.
13887 procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference);
13888 -- Traverse procedure using above Find_Elab_Reference function
13890 -------------------------
13891 -- Find_Elab_Reference --
13892 -------------------------
13894 function Find_Elab_Reference (N : Node_Id) return Traverse_Result is
13898 -- If user has specified that there are no entry calls in elaboration
13899 -- code, do not trace past an accept statement, because the rendez-
13900 -- vous will happen after elaboration.
13902 if Nkind_In (Original_Node (N), N_Accept_Statement,
13903 N_Selective_Accept)
13904 and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code)
13908 -- If we have a function call, check it
13910 elsif Nkind (N) = N_Function_Call then
13911 Check_Elab_Call (N, Outer_Scope);
13914 -- If we have a procedure call, check the call, and also check
13915 -- arguments that are assignments (OUT or IN OUT mode formals).
13917 elsif Nkind (N) = N_Procedure_Call_Statement then
13918 Check_Elab_Call (N, Outer_Scope, In_Init_Proc => Is_Init_Proc (E));
13920 Actual := First_Actual (N);
13921 while Present (Actual) loop
13922 if Known_To_Be_Assigned (Actual) then
13923 Check_Elab_Assign (Actual);
13926 Next_Actual (Actual);
13931 -- If we have an access attribute for a subprogram, check it.
13932 -- Suppress this behavior under debug flag.
13934 elsif not Debug_Flag_Dot_UU
13935 and then Nkind (N) = N_Attribute_Reference
13936 and then Nam_In (Attribute_Name (N), Name_Access,
13937 Name_Unrestricted_Access)
13938 and then Is_Entity_Name (Prefix (N))
13939 and then Is_Subprogram (Entity (Prefix (N)))
13941 Check_Elab_Call (N, Outer_Scope);
13944 -- In SPARK mode, if we have an entity reference to a variable, then
13945 -- check it. For now we consider any reference.
13947 elsif SPARK_Mode = On
13948 and then Nkind (N) in N_Has_Entity
13949 and then Present (Entity (N))
13950 and then Ekind (Entity (N)) = E_Variable
13952 Check_Elab_Call (N, Outer_Scope);
13955 -- If we have a generic instantiation, check it
13957 elsif Nkind (N) in N_Generic_Instantiation then
13958 Check_Elab_Instantiation (N, Outer_Scope);
13961 -- Skip subprogram bodies that come from source (wait for call to
13962 -- analyze these). The reason for the come from source test is to
13963 -- avoid catching task bodies.
13965 -- For task bodies, we should really avoid these too, waiting for the
13966 -- task activation, but that's too much trouble to catch for now, so
13967 -- we go in unconditionally. This is not so terrible, it means the
13968 -- error backtrace is not quite complete, and we are too eager to
13969 -- scan bodies of tasks that are unused, but this is hardly very
13972 elsif Nkind (N) = N_Subprogram_Body
13973 and then Comes_From_Source (N)
13977 elsif Nkind (N) = N_Assignment_Statement
13978 and then Comes_From_Source (N)
13980 Check_Elab_Assign (Name (N));
13986 end Find_Elab_Reference;
13988 Inst_Case : constant Boolean := Is_Generic_Unit (E);
13989 Loc : constant Source_Ptr := Sloc (N);
13994 -- Start of processing for Check_Internal_Call_Continue
13997 -- Save outer level call if at outer level
13999 if Elab_Call.Last = 0 then
14000 Outer_Level_Sloc := Loc;
14003 -- If the call is to a function that renames a literal, no check needed
14005 if Ekind (E) = E_Enumeration_Literal then
14009 -- Register the subprogram as examined within this particular context.
14010 -- This ensures that calls to the same subprogram but in different
14011 -- contexts receive warnings and checks of their own since the calls
14012 -- may be reached through different flow paths.
14014 Elab_Visited.Append ((Subp_Id => E, Context => Parent (N)));
14016 Sbody := Unit_Declaration_Node (E);
14018 if not Nkind_In (Sbody, N_Subprogram_Body, N_Package_Body) then
14019 Ebody := Corresponding_Body (Sbody);
14024 Sbody := Unit_Declaration_Node (Ebody);
14028 -- If the body appears after the outer level call or instantiation then
14029 -- we have an error case handled below.
14031 if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody))
14032 and then not In_Task_Activation
14036 -- If we have the instantiation case we are done, since we now know that
14037 -- the body of the generic appeared earlier.
14039 elsif Inst_Case then
14042 -- Otherwise we have a call, so we trace through the called body to see
14043 -- if it has any problems.
14046 pragma Assert (Nkind (Sbody) = N_Subprogram_Body);
14048 Elab_Call.Append ((Cloc => Loc, Ent => E));
14050 if Debug_Flag_Underscore_LL then
14051 Write_Str ("Elab_Call.Last = ");
14052 Write_Int (Int (Elab_Call.Last));
14053 Write_Str (" Ent = ");
14054 Write_Name (Chars (E));
14055 Write_Str (" at ");
14056 Write_Location (Sloc (N));
14060 -- Now traverse declarations and statements of subprogram body. Note
14061 -- that we cannot simply Traverse (Sbody), since traverse does not
14062 -- normally visit subprogram bodies.
14067 Decl := First (Declarations (Sbody));
14068 while Present (Decl) loop
14074 Traverse (Handled_Statement_Sequence (Sbody));
14076 Elab_Call.Decrement_Last;
14080 -- Here is the case of calling a subprogram where the body has not yet
14081 -- been encountered. A warning message is needed, except if this is the
14082 -- case of appearing within an aspect specification that results in
14083 -- a check call, we do not really have such a situation, so no warning
14084 -- is needed (e.g. the case of a precondition, where the call appears
14085 -- textually before the body, but in actual fact is moved to the
14086 -- appropriate subprogram body and so does not need a check).
14095 -- Keep looking at parents if we are still in the subexpression
14097 if Nkind (P) in N_Subexpr then
14100 -- Here P is the parent of the expression, check for special case
14103 O := Original_Node (P);
14105 -- Definitely not the special case if orig node is not a pragma
14107 exit when Nkind (O) /= N_Pragma;
14109 -- Check we have an If statement or a null statement (happens
14110 -- when the If has been expanded to be True).
14112 exit when not Nkind_In (P, N_If_Statement, N_Null_Statement);
14114 -- Our special case will be indicated either by the pragma
14115 -- coming from an aspect ...
14117 if Present (Corresponding_Aspect (O)) then
14120 -- Or, in the case of an initial condition, specifically by a
14121 -- Check pragma specifying an Initial_Condition check.
14123 elsif Pragma_Name (O) = Name_Check
14126 (Expression (First (Pragma_Argument_Associations (O)))) =
14127 Name_Initial_Condition
14131 -- For anything else, we have an error
14140 -- Not that special case, warning and dynamic check is required
14142 -- If we have nothing in the call stack, then this is at the outer
14143 -- level, and the ABE is bound to occur, unless it's a 'Access, or
14144 -- it's a renaming.
14146 if Elab_Call.Last = 0 then
14147 Error_Msg_Warn := SPARK_Mode /= On;
14150 Insert_Check : Boolean := True;
14151 -- This flag is set to True if an elaboration check should be
14155 if In_Task_Activation then
14156 Insert_Check := False;
14158 elsif Inst_Case then
14160 ("cannot instantiate& before body seen<<", N, Orig_Ent);
14162 elsif Nkind (N) = N_Attribute_Reference then
14164 ("Access attribute of & before body seen<<", N, Orig_Ent);
14165 Error_Msg_N ("\possible Program_Error on later references<", N);
14166 Insert_Check := False;
14168 elsif Nkind (Unit_Declaration_Node (Orig_Ent)) /=
14169 N_Subprogram_Renaming_Declaration
14172 ("cannot call& before body seen<<", N, Orig_Ent);
14174 elsif not Is_Generic_Actual_Subprogram (Orig_Ent) then
14175 Insert_Check := False;
14178 if Insert_Check then
14179 Error_Msg_N ("\Program_Error [<<", N);
14180 Insert_Elab_Check (N);
14184 -- Call is not at outer level
14187 -- Do not generate elaboration checks in GNATprove mode because the
14188 -- elaboration counter and the check are both forms of expansion.
14190 if GNATprove_Mode then
14193 -- Generate an elaboration check
14195 elsif not Elaboration_Checks_Suppressed (E) then
14196 Set_Elaboration_Entity_Required (E);
14198 -- Create a declaration of the elaboration entity, and insert it
14199 -- prior to the subprogram or the generic unit, within the same
14200 -- scope. Since the subprogram may be overloaded, create a unique
14203 if No (Elaboration_Entity (E)) then
14205 Loce : constant Source_Ptr := Sloc (E);
14206 Ent : constant Entity_Id :=
14207 Make_Defining_Identifier (Loc,
14208 New_External_Name (Chars (E), 'E', -1));
14211 Set_Elaboration_Entity (E, Ent);
14212 Push_Scope (Scope (E));
14214 Insert_Action (Declaration_Node (E),
14215 Make_Object_Declaration (Loce,
14216 Defining_Identifier => Ent,
14217 Object_Definition =>
14218 New_Occurrence_Of (Standard_Short_Integer, Loce),
14220 Make_Integer_Literal (Loc, Uint_0)));
14222 -- Set elaboration flag at the point of the body
14224 Set_Elaboration_Flag (Sbody, E);
14226 -- Kill current value indication. This is necessary because
14227 -- the tests of this flag are inserted out of sequence and
14228 -- must not pick up bogus indications of the wrong constant
14229 -- value. Also, this is never a true constant, since one way
14230 -- or another, it gets reset.
14232 Set_Current_Value (Ent, Empty);
14233 Set_Last_Assignment (Ent, Empty);
14234 Set_Is_True_Constant (Ent, False);
14241 -- raise Program_Error with "access before elaboration";
14244 Insert_Elab_Check (N,
14245 Make_Attribute_Reference (Loc,
14246 Attribute_Name => Name_Elaborated,
14247 Prefix => New_Occurrence_Of (E, Loc)));
14250 -- Generate the warning
14252 if not Suppress_Elaboration_Warnings (E)
14253 and then not Elaboration_Checks_Suppressed (E)
14255 -- Suppress this warning if we have a function call that occurred
14256 -- within an assertion expression, since we can get false warnings
14257 -- in this case, due to the out of order handling in this case.
14260 (Nkind (Original_Node (N)) /= N_Function_Call
14261 or else not In_Assertion_Expression_Pragma (Original_Node (N)))
14263 Error_Msg_Warn := SPARK_Mode /= On;
14267 ("instantiation of& may occur before body is seen<l<",
14270 -- A rather specific check. For Finalize/Adjust/Initialize, if
14271 -- the type has Warnings_Off set, suppress the warning.
14273 if Nam_In (Chars (E), Name_Adjust,
14276 and then Present (First_Formal (E))
14279 T : constant Entity_Id := Etype (First_Formal (E));
14281 if Is_Controlled (T) then
14282 if Warnings_Off (T)
14283 or else (Ekind (T) = E_Private_Type
14284 and then Warnings_Off (Full_View (T)))
14292 -- Go ahead and give warning if not this special case
14295 ("call to& may occur before body is seen<l<", N, Orig_Ent);
14298 Error_Msg_N ("\Program_Error ]<l<", N);
14300 -- There is no need to query the elaboration warning message flags
14301 -- because the main message is an error, not a warning, therefore
14302 -- all the clarification messages produces by Output_Calls must be
14303 -- emitted unconditionally.
14307 Output_Calls (N, Check_Elab_Flag => False);
14310 end Check_Internal_Call_Continue;
14312 ---------------------------
14313 -- Check_Task_Activation --
14314 ---------------------------
14316 procedure Check_Task_Activation (N : Node_Id) is
14317 Loc : constant Source_Ptr := Sloc (N);
14318 Inter_Procs : constant Elist_Id := New_Elmt_List;
14319 Intra_Procs : constant Elist_Id := New_Elmt_List;
14322 Task_Scope : Entity_Id;
14323 Cunit_SC : Boolean := False;
14326 Enclosing : Entity_Id;
14328 procedure Add_Task_Proc (Typ : Entity_Id);
14329 -- Add to Task_Procs the task body procedure(s) of task types in Typ.
14330 -- For record types, this procedure recurses over component types.
14332 procedure Collect_Tasks (Decls : List_Id);
14333 -- Collect the types of the tasks that are to be activated in the given
14334 -- list of declarations, in order to perform elaboration checks on the
14335 -- corresponding task procedures that are called implicitly here.
14337 function Outer_Unit (E : Entity_Id) return Entity_Id;
14338 -- find enclosing compilation unit of Entity, ignoring subunits, or
14339 -- else enclosing subprogram. If E is not a package, there is no need
14340 -- for inter-unit elaboration checks.
14342 -------------------
14343 -- Add_Task_Proc --
14344 -------------------
14346 procedure Add_Task_Proc (Typ : Entity_Id) is
14348 Proc : Entity_Id := Empty;
14351 if Is_Task_Type (Typ) then
14352 Proc := Get_Task_Body_Procedure (Typ);
14354 elsif Is_Array_Type (Typ)
14355 and then Has_Task (Base_Type (Typ))
14357 Add_Task_Proc (Component_Type (Typ));
14359 elsif Is_Record_Type (Typ)
14360 and then Has_Task (Base_Type (Typ))
14362 Comp := First_Component (Typ);
14363 while Present (Comp) loop
14364 Add_Task_Proc (Etype (Comp));
14365 Comp := Next_Component (Comp);
14369 -- If the task type is another unit, we will perform the usual
14370 -- elaboration check on its enclosing unit. If the type is in the
14371 -- same unit, we can trace the task body as for an internal call,
14372 -- but we only need to examine other external calls, because at
14373 -- the point the task is activated, internal subprogram bodies
14374 -- will have been elaborated already. We keep separate lists for
14375 -- each kind of task.
14377 -- Skip this test if errors have occurred, since in this case
14378 -- we can get false indications.
14380 if Serious_Errors_Detected /= 0 then
14384 if Present (Proc) then
14385 if Outer_Unit (Scope (Proc)) = Enclosing then
14387 if No (Corresponding_Body (Unit_Declaration_Node (Proc)))
14389 (not Is_Generic_Instance (Scope (Proc))
14390 or else Scope (Proc) = Scope (Defining_Identifier (Decl)))
14392 Error_Msg_Warn := SPARK_Mode /= On;
14394 ("task will be activated before elaboration of its body<<",
14396 Error_Msg_N ("\Program_Error [<<", Decl);
14399 (Corresponding_Body (Unit_Declaration_Node (Proc)))
14401 Append_Elmt (Proc, Intra_Procs);
14405 -- No need for multiple entries of the same type
14407 Elmt := First_Elmt (Inter_Procs);
14408 while Present (Elmt) loop
14409 if Node (Elmt) = Proc then
14416 Append_Elmt (Proc, Inter_Procs);
14421 -------------------
14422 -- Collect_Tasks --
14423 -------------------
14425 procedure Collect_Tasks (Decls : List_Id) is
14427 if Present (Decls) then
14428 Decl := First (Decls);
14429 while Present (Decl) loop
14430 if Nkind (Decl) = N_Object_Declaration
14431 and then Has_Task (Etype (Defining_Identifier (Decl)))
14433 Add_Task_Proc (Etype (Defining_Identifier (Decl)));
14445 function Outer_Unit (E : Entity_Id) return Entity_Id is
14450 while Present (Outer) loop
14451 if Elaboration_Checks_Suppressed (Outer) then
14455 exit when Is_Child_Unit (Outer)
14456 or else Scope (Outer) = Standard_Standard
14457 or else Ekind (Outer) /= E_Package;
14458 Outer := Scope (Outer);
14464 -- Start of processing for Check_Task_Activation
14467 pragma Assert (Legacy_Elaboration_Checks);
14469 Enclosing := Outer_Unit (Current_Scope);
14471 -- Find all tasks declared in the current unit
14473 if Nkind (N) = N_Package_Body then
14474 P := Unit_Declaration_Node (Corresponding_Spec (N));
14476 Collect_Tasks (Declarations (N));
14477 Collect_Tasks (Visible_Declarations (Specification (P)));
14478 Collect_Tasks (Private_Declarations (Specification (P)));
14480 elsif Nkind (N) = N_Package_Declaration then
14481 Collect_Tasks (Visible_Declarations (Specification (N)));
14482 Collect_Tasks (Private_Declarations (Specification (N)));
14485 Collect_Tasks (Declarations (N));
14488 -- We only perform detailed checks in all tasks that are library level
14489 -- entities. If the master is a subprogram or task, activation will
14490 -- depend on the activation of the master itself.
14492 -- Should dynamic checks be added in the more general case???
14494 if Ekind (Enclosing) /= E_Package then
14498 -- For task types defined in other units, we want the unit containing
14499 -- the task body to be elaborated before the current one.
14501 Elmt := First_Elmt (Inter_Procs);
14502 while Present (Elmt) loop
14503 Ent := Node (Elmt);
14504 Task_Scope := Outer_Unit (Scope (Ent));
14506 if not Is_Compilation_Unit (Task_Scope) then
14509 elsif Suppress_Elaboration_Warnings (Task_Scope)
14510 or else Elaboration_Checks_Suppressed (Task_Scope)
14514 elsif Dynamic_Elaboration_Checks then
14515 if not Elaboration_Checks_Suppressed (Ent)
14516 and then not Cunit_SC
14517 and then not Restriction_Active
14518 (No_Entry_Calls_In_Elaboration_Code)
14520 -- Runtime elaboration check required. Generate check of the
14521 -- elaboration counter for the unit containing the entity.
14523 Insert_Elab_Check (N,
14524 Make_Attribute_Reference (Loc,
14526 New_Occurrence_Of (Spec_Entity (Task_Scope), Loc),
14527 Attribute_Name => Name_Elaborated));
14531 -- Force the binder to elaborate other unit first
14533 if Elab_Info_Messages
14534 and then not Suppress_Elaboration_Warnings (Ent)
14535 and then not Elaboration_Checks_Suppressed (Ent)
14536 and then not Suppress_Elaboration_Warnings (Task_Scope)
14537 and then not Elaboration_Checks_Suppressed (Task_Scope)
14539 Error_Msg_Node_2 := Task_Scope;
14541 ("info: activation of an instance of task type & requires "
14542 & "pragma Elaborate_All on &?$?", N, Ent);
14545 Activate_Elaborate_All_Desirable (N, Task_Scope);
14546 Set_Suppress_Elaboration_Warnings (Task_Scope);
14552 -- For tasks declared in the current unit, trace other calls within the
14553 -- task procedure bodies, which are available.
14555 if not Debug_Flag_Dot_Y then
14556 In_Task_Activation := True;
14558 Elmt := First_Elmt (Intra_Procs);
14559 while Present (Elmt) loop
14560 Ent := Node (Elmt);
14561 Check_Internal_Call_Continue (N, Ent, Enclosing, Ent);
14565 In_Task_Activation := False;
14567 end Check_Task_Activation;
14569 ------------------------
14570 -- Get_Referenced_Ent --
14571 ------------------------
14573 function Get_Referenced_Ent (N : Node_Id) return Entity_Id is
14577 if Nkind (N) in N_Has_Entity
14578 and then Present (Entity (N))
14579 and then Ekind (Entity (N)) = E_Variable
14584 if Nkind (N) = N_Attribute_Reference then
14592 elsif Nkind (Nam) = N_Selected_Component then
14593 return Entity (Selector_Name (Nam));
14594 elsif not Is_Entity_Name (Nam) then
14597 return Entity (Nam);
14599 end Get_Referenced_Ent;
14601 ----------------------
14602 -- Has_Generic_Body --
14603 ----------------------
14605 function Has_Generic_Body (N : Node_Id) return Boolean is
14606 Ent : constant Entity_Id := Get_Generic_Entity (N);
14607 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
14610 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id;
14611 -- Determine if the list of nodes headed by N and linked by Next
14612 -- contains a package body for the package spec entity E, and if so
14613 -- return the package body. If not, then returns Empty.
14615 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id;
14616 -- This procedure is called load the unit whose name is given by Nam.
14617 -- This unit is being loaded to see whether it contains an optional
14618 -- generic body. The returned value is the loaded unit, which is always
14619 -- a package body (only package bodies can contain other entities in the
14620 -- sense in which Has_Generic_Body is interested). We only attempt to
14621 -- load bodies if we are generating code. If we are in semantics check
14622 -- only mode, then it would be wrong to load bodies that are not
14623 -- required from a semantic point of view, so in this case we return
14624 -- Empty. The result is that the caller may incorrectly decide that a
14625 -- generic spec does not have a body when in fact it does, but the only
14626 -- harm in this is that some warnings on elaboration problems may be
14627 -- lost in semantic checks only mode, which is not big loss. We also
14628 -- return Empty if we go for a body and it is not there.
14630 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id;
14631 -- PE is the entity for a package spec. This function locates the
14632 -- corresponding package body, returning Empty if none is found. The
14633 -- package body returned is fully parsed but may not yet be analyzed,
14634 -- so only syntactic fields should be referenced.
14640 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is
14645 while Present (Nod) loop
14647 -- If we found the package body we are looking for, return it
14649 if Nkind (Nod) = N_Package_Body
14650 and then Chars (Defining_Unit_Name (Nod)) = Chars (E)
14654 -- If we found the stub for the body, go after the subunit,
14655 -- loading it if necessary.
14657 elsif Nkind (Nod) = N_Package_Body_Stub
14658 and then Chars (Defining_Identifier (Nod)) = Chars (E)
14660 if Present (Library_Unit (Nod)) then
14661 return Unit (Library_Unit (Nod));
14664 return Load_Package_Body (Get_Unit_Name (Nod));
14667 -- If neither package body nor stub, keep looking on chain
14677 -----------------------
14678 -- Load_Package_Body --
14679 -----------------------
14681 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is
14682 U : Unit_Number_Type;
14685 if Operating_Mode /= Generate_Code then
14695 if U = No_Unit then
14698 return Unit (Cunit (U));
14701 end Load_Package_Body;
14703 -------------------------------
14704 -- Locate_Corresponding_Body --
14705 -------------------------------
14707 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is
14708 Spec : constant Node_Id := Declaration_Node (PE);
14709 Decl : constant Node_Id := Parent (Spec);
14710 Scop : constant Entity_Id := Scope (PE);
14714 if Is_Library_Level_Entity (PE) then
14716 -- If package is a library unit that requires a body, we have no
14717 -- choice but to go after that body because it might contain an
14718 -- optional body for the original generic package.
14720 if Unit_Requires_Body (PE) then
14722 -- Load the body. Note that we are a little careful here to use
14723 -- Spec to get the unit number, rather than PE or Decl, since
14724 -- in the case where the package is itself a library level
14725 -- instantiation, Spec will properly reference the generic
14726 -- template, which is what we really want.
14730 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec))));
14732 -- But if the package is a library unit that does NOT require
14733 -- a body, then no body is permitted, so we are sure that there
14734 -- is no body for the original generic package.
14740 -- Otherwise look and see if we are embedded in a further package
14742 elsif Is_Package_Or_Generic_Package (Scop) then
14744 -- If so, get the body of the enclosing package, and look in
14745 -- its package body for the package body we are looking for.
14747 PBody := Locate_Corresponding_Body (Scop);
14752 return Find_Body_In (PE, First (Declarations (PBody)));
14755 -- If we are not embedded in a further package, then the body
14756 -- must be in the same declarative part as we are.
14759 return Find_Body_In (PE, Next (Decl));
14761 end Locate_Corresponding_Body;
14763 -- Start of processing for Has_Generic_Body
14766 if Present (Corresponding_Body (Decl)) then
14769 elsif Unit_Requires_Body (Ent) then
14772 -- Compilation units cannot have optional bodies
14774 elsif Is_Compilation_Unit (Ent) then
14777 -- Otherwise look at what scope we are in
14780 Scop := Scope (Ent);
14782 -- Case of entity is in other than a package spec, in this case
14783 -- the body, if present, must be in the same declarative part.
14785 if not Is_Package_Or_Generic_Package (Scop) then
14790 -- Declaration node may get us a spec, so if so, go to
14791 -- the parent declaration.
14793 P := Declaration_Node (Ent);
14794 while not Is_List_Member (P) loop
14798 return Present (Find_Body_In (Ent, Next (P)));
14801 -- If the entity is in a package spec, then we have to locate
14802 -- the corresponding package body, and look there.
14806 PBody : constant Node_Id := Locate_Corresponding_Body (Scop);
14814 (Find_Body_In (Ent, (First (Declarations (PBody)))));
14819 end Has_Generic_Body;
14821 -----------------------
14822 -- Insert_Elab_Check --
14823 -----------------------
14825 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is
14827 Loc : constant Source_Ptr := Sloc (N);
14830 -- The check (N_Raise_Program_Error) node to be inserted
14833 -- If expansion is disabled, do not generate any checks. Also
14834 -- skip checks if any subunits are missing because in either
14835 -- case we lack the full information that we need, and no object
14836 -- file will be created in any case.
14838 if not Expander_Active or else Subunits_Missing then
14842 -- If we have a generic instantiation, where Instance_Spec is set,
14843 -- then this field points to a generic instance spec that has
14844 -- been inserted before the instantiation node itself, so that
14845 -- is where we want to insert a check.
14847 if Nkind (N) in N_Generic_Instantiation
14848 and then Present (Instance_Spec (N))
14850 Nod := Instance_Spec (N);
14855 -- Build check node, possibly with condition
14858 Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration);
14860 if Present (C) then
14861 Set_Condition (Chk, Make_Op_Not (Loc, Right_Opnd => C));
14864 -- If we are inserting at the top level, insert in Aux_Decls
14866 if Nkind (Parent (Nod)) = N_Compilation_Unit then
14868 ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod));
14871 if No (Declarations (ADN)) then
14872 Set_Declarations (ADN, New_List (Chk));
14874 Append_To (Declarations (ADN), Chk);
14880 -- Otherwise just insert as an action on the node in question
14883 Insert_Action (Nod, Chk);
14885 end Insert_Elab_Check;
14887 -------------------------------
14888 -- Is_Call_Of_Generic_Formal --
14889 -------------------------------
14891 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean is
14893 return Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
14895 -- Always return False if debug flag -gnatd.G is set
14897 and then not Debug_Flag_Dot_GG
14899 -- For now, we detect this by looking for the strange identifier
14900 -- node, whose Chars reflect the name of the generic formal, but
14901 -- the Chars of the Entity references the generic actual.
14903 and then Nkind (Name (N)) = N_Identifier
14904 and then Chars (Name (N)) /= Chars (Entity (Name (N)));
14905 end Is_Call_Of_Generic_Formal;
14907 -------------------------------
14908 -- Is_Finalization_Procedure --
14909 -------------------------------
14911 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean is
14913 -- Check whether Id is a procedure with at least one parameter
14915 if Ekind (Id) = E_Procedure and then Present (First_Formal (Id)) then
14917 Typ : constant Entity_Id := Etype (First_Formal (Id));
14918 Deep_Fin : Entity_Id := Empty;
14919 Fin : Entity_Id := Empty;
14922 -- If the type of the first formal does not require finalization
14923 -- actions, then this is definitely not [Deep_]Finalize.
14925 if not Needs_Finalization (Typ) then
14929 -- At this point we have the following scenario:
14931 -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]);
14933 -- Recover the two possible versions of [Deep_]Finalize using the
14934 -- type of the first parameter and compare with the input.
14936 Deep_Fin := TSS (Typ, TSS_Deep_Finalize);
14938 if Is_Controlled (Typ) then
14939 Fin := Find_Prim_Op (Typ, Name_Finalize);
14942 return (Present (Deep_Fin) and then Id = Deep_Fin)
14943 or else (Present (Fin) and then Id = Fin);
14948 end Is_Finalization_Procedure;
14954 procedure Output_Calls
14956 Check_Elab_Flag : Boolean)
14958 function Emit (Flag : Boolean) return Boolean;
14959 -- Determine whether to emit an error message based on the combination
14960 -- of flags Check_Elab_Flag and Flag.
14962 function Is_Printable_Error_Name return Boolean;
14963 -- An internal function, used to determine if a name, stored in the
14964 -- Name_Buffer, is either a non-internal name, or is an internal name
14965 -- that is printable by the error message circuits (i.e. it has a single
14966 -- upper case letter at the end).
14972 function Emit (Flag : Boolean) return Boolean is
14974 if Check_Elab_Flag then
14981 -----------------------------
14982 -- Is_Printable_Error_Name --
14983 -----------------------------
14985 function Is_Printable_Error_Name return Boolean is
14987 if not Is_Internal_Name then
14990 elsif Name_Len = 1 then
14994 Name_Len := Name_Len - 1;
14995 return not Is_Internal_Name;
14997 end Is_Printable_Error_Name;
15003 -- Start of processing for Output_Calls
15006 for J in reverse 1 .. Elab_Call.Last loop
15007 Error_Msg_Sloc := Elab_Call.Table (J).Cloc;
15009 Ent := Elab_Call.Table (J).Ent;
15010 Get_Name_String (Chars (Ent));
15012 -- Dynamic elaboration model, warnings controlled by -gnatwl
15014 if Dynamic_Elaboration_Checks then
15015 if Emit (Elab_Warnings) then
15016 if Is_Generic_Unit (Ent) then
15017 Error_Msg_NE ("\\?l?& instantiated #", N, Ent);
15018 elsif Is_Init_Proc (Ent) then
15019 Error_Msg_N ("\\?l?initialization procedure called #", N);
15020 elsif Is_Printable_Error_Name then
15021 Error_Msg_NE ("\\?l?& called #", N, Ent);
15023 Error_Msg_N ("\\?l?called #", N);
15027 -- Static elaboration model, info messages controlled by -gnatel
15030 if Emit (Elab_Info_Messages) then
15031 if Is_Generic_Unit (Ent) then
15032 Error_Msg_NE ("\\?$?& instantiated #", N, Ent);
15033 elsif Is_Init_Proc (Ent) then
15034 Error_Msg_N ("\\?$?initialization procedure called #", N);
15035 elsif Is_Printable_Error_Name then
15036 Error_Msg_NE ("\\?$?& called #", N, Ent);
15038 Error_Msg_N ("\\?$?called #", N);
15045 ----------------------------
15046 -- Same_Elaboration_Scope --
15047 ----------------------------
15049 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is
15054 -- Find elaboration scope for Scop1
15055 -- This is either a subprogram or a compilation unit.
15058 while S1 /= Standard_Standard
15059 and then not Is_Compilation_Unit (S1)
15060 and then Ekind_In (S1, E_Package, E_Protected_Type, E_Block)
15065 -- Find elaboration scope for Scop2
15068 while S2 /= Standard_Standard
15069 and then not Is_Compilation_Unit (S2)
15070 and then Ekind_In (S2, E_Package, E_Protected_Type, E_Block)
15076 end Same_Elaboration_Scope;
15082 procedure Set_C_Scope is
15084 while not Is_Compilation_Unit (C_Scope) loop
15085 C_Scope := Scope (C_Scope);
15089 --------------------------------
15090 -- Set_Elaboration_Constraint --
15091 --------------------------------
15093 procedure Set_Elaboration_Constraint
15098 Elab_Unit : Entity_Id;
15100 -- Check whether this is a call to an Initialize subprogram for a
15101 -- controlled type. Note that Call can also be a 'Access attribute
15102 -- reference, which now generates an elaboration check.
15104 Init_Call : constant Boolean :=
15105 Nkind (Call) = N_Procedure_Call_Statement
15106 and then Chars (Subp) = Name_Initialize
15107 and then Comes_From_Source (Subp)
15108 and then Present (Parameter_Associations (Call))
15109 and then Is_Controlled (Etype (First_Actual (Call)));
15112 -- If the unit is mentioned in a with_clause of the current unit, it is
15113 -- visible, and we can set the elaboration flag.
15115 if Is_Immediately_Visible (Scop)
15116 or else (Is_Child_Unit (Scop) and then Is_Visible_Lib_Unit (Scop))
15118 Activate_Elaborate_All_Desirable (Call, Scop);
15119 Set_Suppress_Elaboration_Warnings (Scop);
15123 -- If this is not an initialization call or a call using object notation
15124 -- we know that the unit of the called entity is in the context, and we
15125 -- can set the flag as well. The unit need not be visible if the call
15126 -- occurs within an instantiation.
15128 if Is_Init_Proc (Subp)
15130 or else Nkind (Original_Node (Call)) = N_Selected_Component
15132 null; -- detailed processing follows.
15135 Activate_Elaborate_All_Desirable (Call, Scop);
15136 Set_Suppress_Elaboration_Warnings (Scop);
15140 -- If the unit is not in the context, there must be an intermediate unit
15141 -- that is, on which we need to place to elaboration flag. This happens
15142 -- with init proc calls.
15144 if Is_Init_Proc (Subp) or else Init_Call then
15146 -- The initialization call is on an object whose type is not declared
15147 -- in the same scope as the subprogram. The type of the object must
15148 -- be a subtype of the type of operation. This object is the first
15149 -- actual in the call.
15152 Typ : constant Entity_Id :=
15153 Etype (First (Parameter_Associations (Call)));
15155 Elab_Unit := Scope (Typ);
15156 while (Present (Elab_Unit))
15157 and then not Is_Compilation_Unit (Elab_Unit)
15159 Elab_Unit := Scope (Elab_Unit);
15163 -- If original node uses selected component notation, the prefix is
15164 -- visible and determines the scope that must be elaborated. After
15165 -- rewriting, the prefix is the first actual in the call.
15167 elsif Nkind (Original_Node (Call)) = N_Selected_Component then
15168 Elab_Unit := Scope (Etype (First (Parameter_Associations (Call))));
15170 -- Not one of special cases above
15173 -- Using previously computed scope. If the elaboration check is
15174 -- done after analysis, the scope is not visible any longer, but
15175 -- must still be in the context.
15180 Activate_Elaborate_All_Desirable (Call, Elab_Unit);
15181 Set_Suppress_Elaboration_Warnings (Elab_Unit);
15182 end Set_Elaboration_Constraint;
15188 function Spec_Entity (E : Entity_Id) return Entity_Id is
15192 -- Check for case of body entity
15193 -- Why is the check for E_Void needed???
15195 if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then
15199 Decl := Parent (Decl);
15200 exit when Nkind (Decl) in N_Proper_Body;
15203 return Corresponding_Spec (Decl);
15214 function Within (E1, E2 : Entity_Id) return Boolean is
15221 elsif Scop = Standard_Standard then
15224 Scop := Scope (Scop);
15229 --------------------------
15230 -- Within_Elaborate_All --
15231 --------------------------
15233 function Within_Elaborate_All
15234 (Unit : Unit_Number_Type;
15235 E : Entity_Id) return Boolean
15237 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean;
15238 pragma Pack (Unit_Number_Set);
15240 Seen : Unit_Number_Set := (others => False);
15241 -- Seen (X) is True after we have seen unit X in the walk. This is used
15242 -- to prevent processing the same unit more than once.
15244 Result : Boolean := False;
15246 procedure Helper (Unit : Unit_Number_Type);
15247 -- This helper procedure does all the work for Within_Elaborate_All. It
15248 -- walks the dependency graph, and sets Result to True if it finds an
15249 -- appropriate Elaborate_All.
15255 procedure Helper (Unit : Unit_Number_Type) is
15256 CU : constant Node_Id := Cunit (Unit);
15260 Elab_Id : Entity_Id;
15264 if Seen (Unit) then
15267 Seen (Unit) := True;
15270 -- First, check for Elaborate_Alls on this unit
15272 Item := First (Context_Items (CU));
15273 while Present (Item) loop
15274 if Nkind (Item) = N_Pragma
15275 and then Pragma_Name (Item) = Name_Elaborate_All
15277 -- Return if some previous error on the pragma itself. The
15278 -- pragma may be unanalyzed, because of a previous error, or
15279 -- if it is the context of a subunit, inherited by its parent.
15281 if Error_Posted (Item) or else not Analyzed (Item) then
15287 (Expression (First (Pragma_Argument_Associations (Item))));
15289 if E = Elab_Id then
15294 Par := Parent (Unit_Declaration_Node (Elab_Id));
15296 Item2 := First (Context_Items (Par));
15297 while Present (Item2) loop
15298 if Nkind (Item2) = N_With_Clause
15299 and then Entity (Name (Item2)) = E
15300 and then not Limited_Present (Item2)
15313 -- Second, recurse on with's. We could do this as part of the above
15314 -- loop, but it's probably more efficient to have two loops, because
15315 -- the relevant Elaborate_All is likely to be on the initial unit. In
15316 -- other words, we're walking the with's breadth-first. This part is
15317 -- only necessary in the dynamic elaboration model.
15319 if Dynamic_Elaboration_Checks then
15320 Item := First (Context_Items (CU));
15321 while Present (Item) loop
15322 if Nkind (Item) = N_With_Clause
15323 and then not Limited_Present (Item)
15325 -- Note: the following call to Get_Cunit_Unit_Number does a
15326 -- linear search, which could be slow, but it's OK because
15327 -- we're about to give a warning anyway. Also, there might
15328 -- be hundreds of units, but not millions. If it turns out
15329 -- to be a problem, we could store the Get_Cunit_Unit_Number
15330 -- in each N_Compilation_Unit node, but that would involve
15331 -- rearranging N_Compilation_Unit_Aux to make room.
15333 Helper (Get_Cunit_Unit_Number (Library_Unit (Item)));
15345 -- Start of processing for Within_Elaborate_All
15350 end Within_Elaborate_All;